diff --git a/.github/workflows/github_autotools_gnu.yml b/.github/workflows/github_autotools_gnu.yml index b7008a0814..00c7f5d31c 100644 --- a/.github/workflows/github_autotools_gnu.yml +++ b/.github/workflows/github_autotools_gnu.yml @@ -9,7 +9,7 @@ jobs: runs-on: ubuntu-latest strategy: matrix: - conf-flag: [ --disable-openmp, --enable-mixed-mode, --disable-setting-flags, --with-mpi=no] + conf-flag: [ --disable-openmp, --disable-setting-flags, --with-mpi=no, --disable-r8-defaults] input-flag: [--with-yaml, --enable-test-input=/home/unit_tests_input] exclude: - conf-flag: --with-mpi=no diff --git a/.github/workflows/github_coupler_gnu.yml b/.github/workflows/github_coupler_gnu.yml index ea24899b95..4e3e357d0d 100644 --- a/.github/workflows/github_coupler_gnu.yml +++ b/.github/workflows/github_coupler_gnu.yml @@ -5,14 +5,16 @@ jobs: coupler-build: runs-on: ubuntu-latest container: - image: ryanmulhall/hpc-me.ubuntu-minimal:coupler + image: ghcr.io/noaa-gfdl/fms/fms-ci-rocky-gnu:12.3.0 + credentials: + username: ${{ github.actor }} + password: ${{ secrets.github_token }} env: CC: mpicc FC: mpif90 - CPPFLAGS: '-I/usr/include -Duse_LARGEFILE -DMAXFIELDMETHODS_=500' - FCFLAGS: '-fcray-pointer -fdefault-double-8 -fdefault-real-8 -Waliasing -ffree-line-length-none -fno-range-check -I/usr/include' - LDFLAGS: '-L/usr/lib' - VERBOSE: 1 + CPPFLAGS: '-I/opt/view/include' + FFLAGS: '-fallow-argument-mismatch' # mkmf uses FFLAGS instead of FC + LDFLAGS: '-L/opt/view/lib' steps: - name: Checkout FMS uses: actions/checkout@v2 diff --git a/CHANGELOG.md b/CHANGELOG.md index 2c616e647d..782f940443 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,42 @@ 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`). +## [2023.03] - 2023-10-27 +### 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. +- `NO_QUAD_PRECISION` macro is no longer set by FMS, the `ENABLE_QUAD_PRECISION` macro has replaced prior usage of `NO_QUAD_PRECISION`. `-DENABLE_QUAD_PRECISION` should be set if quad precision is to be used, otherwise FMS will not use quad precision reals where applicable. + +### Added +- UNIT_TESTS: New unit tests have been created or and existing ones expanded on for any modules utilizing mixed precision support. + +### Changed +- MIXED PRECISION: Most subroutines and functions in FMS have been updated to simultaneously accept both 4 byte and 8 byte reals as arguments. This deprecates the `--enable-mixed-mode` option, which enabled similar functionality but was limited to certain directories and was not enabled by default. To facilitate easier testing of these code changes, the CMake precision options for default real size were left in (along with an equivalent `--disable-r8-default` flag for autotools). The resulting libraries will support mixed-precision real kinds regardless of default real size. It should also be noted that many routines that accept real arguments have been moved to include files along with headers in order to be compiled with both kinds. Most module level variables were explicitly declared as r8_kind for these updates. +- Some type/module changes were made to facilitate mixed precision support. They are **intended** to have minimal impact to other codebases: + - COUPLER_TYPES: In coupler_types.F90, `coupler_nd_field_type` and `coupler_nd_values_type` have been renamed to indicate real kind value: `coupler_nd_real4/8_field_type` and `coupler_nd_real4/8_values_type`. The `bc` field within `coupler_nd_bc_type` was modified to use r8_kind within the value and field types, and an additional field added `bc_r4` to use r4_kind values. + - TRIDIAGONAL: Module state between r4 and r8 calls are distinct (ie. subsequent calls will only be affected by calls of the same precision). This behaviour can be changed via the `save_both_kinds` optional argument to `tri_invert`. +- CODE_STYLE: has been updated to reflect the formatting used for the mixed precision support updates. + +### Fixed +- DIAG_MANAGER: Tile number (ie. tileX) will now be added to filenames for sub-regional diagnostics. +- MPP: Bug affecting non-intel compilers coming from uninitialized pointer in the `nest_domain_type` +- MPP: Bug fix for unallocated field causing seg faults in `mpp_check_field` +- FMS2_IO: Fixed segfault occuring from use of cray pointer remapping along with mpp_scatter/gather +- TEST_FMS: Added various fixes for different compilers within test programs for fms2_io, mpp, diag_manager, parser, and sat_vapor_pres. +- INTERPOLATOR: Deallocates fields in the type that were previously left out in `interpolator_end` + +### Removed +- CPP MACROS: + - `no_4byte_reals` was removed and will not set any additional macros if used. `no_8byte_integers` is still functional. + - `NO_QUAD_PRECISION` was removed. It was conditionally set if ENABLE_QUAD_PRECISION was undefined. ENABLE_QUAD_PRECISION should be used in model components instead (logic is flipped) + - `use_netCDF` was set by autotools previously but wasn't consistently used in the code. FMS should always be compiled with netcdf installed so this was removed with the exception of its use in deprecated IO modules. +- DRIFTERS: The drifters subdirectory has been deprecated. It will only be compiled if using the `-Duse_drifters` CPP flag. + +### Tag Commit Hashes +- 2023.03-beta1 06b94a7f574e7794684b8584391744ded68e2989 +- 2023.03-alpha3 b25a7c52a27dfd52edc10bc0ebe12776af0f03df +- 2023.03-alpha2 9983ce308e62e9f7215b04c227cebd30fd75e784 +- 2023.03-alpha1 a46bd94fd8dd1f6f021501e29179003ff28180ec + ## [2023.02] - 2023-07-27 ### Known Issues - GCC 11.1.0 is unsupported due to compilation issues with select type. The issue is resolved in later GCC releases. diff --git a/CMakeLists.txt b/CMakeLists.txt index f5ef9a7d38..89c7eb329d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -26,7 +26,7 @@ set(CMAKE_Fortran_FLAGS_DEBUG) # Define the CMake project project(FMS - VERSION 2023.02.0 + VERSION 2023.03.0 DESCRIPTION "GFDL FMS Library" HOMEPAGE_URL "https://www.gfdl.noaa.gov/fms" LANGUAGES C Fortran) @@ -321,9 +321,11 @@ foreach(kind ${kinds}) field_manager/include time_interp/include tracer_manager/include + tridiagonal/include interpolator/include coupler/include - data_override/include) + data_override/include + amip_interp/include) target_compile_definitions(${libTgt}_f PRIVATE "${fms_defs}") target_compile_definitions(${libTgt}_f PRIVATE "${${kind}_defs}") @@ -378,7 +380,9 @@ foreach(kind ${kinds}) $ $ $ - $) + $ + $ + $) target_include_directories(${libTgt} INTERFACE $ diff --git a/CODE_STYLE.md b/CODE_STYLE.md index 0db572c07e..f5c949fedc 100644 --- a/CODE_STYLE.md +++ b/CODE_STYLE.md @@ -21,8 +21,7 @@ * Use Fortran 95 standard or newer * Two space indentation -* Use `KIND` parameters from intrinsic fortran modules such as iso_fortran_env - or iso_c_binding to ensure portability +* Use `KIND` parameters from platform_mod * Never use implicit variables (i.e., always specify `IMPLICIT NONE`) * Lines must be <= 120 characters long (including comments) * logical, compound logical, and relational if statements may be one line, @@ -43,7 +42,7 @@ * Inline doxygen descriptions for all member variables. ## Functions -* If a function has a result variable, it should be declared on its own line, +* If a function has a result variable, it should be declared on its own line, and the variable should not be declared with a specific intent. * Inline doxygen descriptions for all arguments, except the result variable. * Doxygen description on the line(s) before the function definition. This must @@ -60,9 +59,37 @@ all shared and private variables. * All critical sections must have a unique name. +## Precision +* Precision of all real arguments are explicitly defined as `real(kind=r4_kind)`, + `real(kind=r8_kind)`, or as any other precision parameters defined in platform_mod. +* The precision of real numerical values should be consistent with the precision + of the associated variable. For example, if the variable `a` has been declared + as r8_kind, then `a=1.4_r8_kind` is acceptable. The following, a=1.4 and a=(1.4,kind=r8_kind), + are not acceptable since the numerical value of 1.4 will be represented in the default precision + set by the compiler. +* The precision of integers do not need to be explicitly defined and can be determined at compile time. +* If the precision of integers are explicitly defined, they are defined with the precision parameters, + _e.g._ i4_kind, i8_kind, found in platform_mod. + +## Macros +* All letters in the macro names are capitalized +* All macro names end with an underscore "_" +* All precision related macro names start with the letters "FMS" +* Macro names should be unique to each module. For example, + `FMS_AU_KIND_` is used in axis_utils_mod. + `FMS_HI_KIND_` is used in horiz_interp_mod + +## .fh and .inc files +* The .fh header files contain macro definitions. +* If the .fh files contain mainly precision related macro definitions, the files + should be named with `_r4.fh` and `_r8.fh` extensions in the include subdirectory found + in the module directory. These .fh files are `#include`-ed at the end of the .F90 module files. +* For precision related .inc files, the .inc files contain the procedure definitions and are + `#include`-ed at the end of both *_r4.fh and *_f8.fh files. These .inc files are located in the + same include subdirectory as the .fh files. See below for details. ## Fortran Example -```Fortran +```Fortran ./example.F90 file !*********************************************************************** !* GNU Lesser General Public License @@ -89,45 +116,165 @@ !! @email gfdl.climate.model.info@noaa.gov module example_mod - use, intrinsic :: iso_fortran_env, only: INT32, REAL32 + use platform_mod, only r4_kind, r8_kind, i4_kind, i8_kind use util_mod, only: util_func1 implicit none private public :: sub1 public :: func1 + public :: ex_subroutine + + interface ex_subroutine !< generic interface block. When the user + module procedure ex_subroutine_r4 !! calls ex_subroutine, the compiler checks + module procedure ex_subroutine_r8 !! the input arguments and invokes either + end interface ex_subroutine !! ex_subroutine_r4 or ex_subroutine_r8 + !! ex_subroutine_r4/8 are generated by the preprocessor + !! which requires example_r4.fh, example_r8.fh, and + !! example.inc files !> @brief Doxygen description of type. type,public :: CustomType private - integer(kind=INT32) :: a_var !< Inline doxygen description. - real(kind=REAL32),dimension(:),allocatable :: b_arr !< long description - !! continued on - !! multiple lines. + integer(kind=i4_kind) :: a_var !< Inline doxygen description. + real(kind=r8_kind),dimension(:),allocatable :: b_arr !< long description + !! continued on + !! multiple lines. endtype CustomType contains !> @brief Doxygen description. - subroutine sub1(arg1, & - & arg2, & + subroutine sub1(arg1, arg2, & & arg3) - real(kind=REAL32),intent(in) :: arg1 !< Inline doxygen description. - integer(kind=INT32),intent(inout) :: arg2 !< Inline doxygen description. + real(kind=r4_kind),intent(in) :: arg1 !< Inline doxygen description. + integer(kind=i8_kind),intent(inout) :: arg2 !< Inline doxygen description. character(len=*),intent(inout) :: arg3 !< Long inline doxygen !! description. + + arg1=2.456_r4_kind end subroutine sub1 !> @brief Doxygen description !! @return Function return value. function func1(arg1, arg2) result(res) - integer(kind=INT32),intent(in) :: arg1 !< Inline doxygen description - integer(kind=INT32),intent(in) :: arg2 !< Inline doxygen description - integer(kind=INT32) :: res + integer(kind=i4_kind),intent(in) :: arg1 !< Inline doxygen description + integer(kind=i4_kind),intent(in) :: arg2 !< Inline doxygen description + integer(kind=r8_kind) :: res + + res=real(arg1,r8_kind) * 3.14_r8_kind end function func1 +#include "example_r4.fh" !< These two header file contains the macro definition +#include "example_r8.fh" !! and an "#include example.inc" where the procedure + !! is defined. See below. end module example_mod ``` +```Fortran ./include/example_r4.fh file +!*********************************************************************** +!* 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 Example _r4.fh file containing macro definitions +!! @author +!! @email gfdl.climate.model.info@noaa.gov + +#undef FMS_EX_KIND_ +#define FMS_EX_KIND_ r4_kind + +#undef EX_SUBROUTINE_ +#define EX_SUBROUTINE_ ex_subroutine_r4 + +#include "example.inc" !< example.inc file contains the procedure definition +``` +```Fortran ./include/example_r8.fh file +!*********************************************************************** +!* 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 Example file _r8.fh file containing macro definitions +!! @author +!! @email gfdl.climate.model.info@noaa.gov + +#undef FMS_EX_KIND_ +#define FMS_EX_KIND_ r8_kind + +#undef EX_SUBROUTINE_ +#define EX_SUBROUTINE_ ex_subroutine_r8 + +#include "example.inc" !< example.inc file contains the procedure definition +``` +``` Fortran ./include/example.inc file +!*********************************************************************** +!* 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 Example .inc file containing subroutine definitions/declarations +!! @author +!! @email gfdl.climate.model.info@noaa.gov + +!> The macro EX_SUBROUTINE_ gets replaced by the preprocessor +!! as ex_subroutine_r4 (as defined in the example_r4.fh file) and +!! as ex_subroutine r8 (as defined in the example_r8.fh file) + +subroutine EX_SUBROUTINE_(arg1, arg2, arg3) + real(FMS_EX_KIND_), intent(in) :: arg2 !< FMS_EX_KIND_ gets replaced by the preprocessor + real(FMS_EX_KIND_), intent(out) :: arg1 !< FMS_EX_KIND_ gets replaced by the preprocessor + integer(i4_kind) :: arg3 + integer, parameter :: lkind=FMS_EX_KIND_ !< kind parameter local to the subroutine + + arg1 = arg2 / 4.0_lkind !< GCC does not like 4.0_FMS_EX_KIND_. Thus, the + !! parameter lkind is declared and used. + +end subroutine EX_SUBROUTINE_ +``` ## C/C++ diff --git a/Makefile.am b/Makefile.am index ffb12344ea..dd1d27696d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -35,8 +35,8 @@ endif # Make targets will be run in each subdirectory. Order is significant. SUBDIRS = \ platform \ - tridiagonal \ mpp \ + tridiagonal \ constants \ constants4 \ memutils \ diff --git a/amip_interp/Makefile.am b/amip_interp/Makefile.am index f5358101d4..27f50fcbf8 100644 --- a/amip_interp/Makefile.am +++ b/amip_interp/Makefile.am @@ -23,14 +23,18 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/amip_interp/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. noinst_LTLIBRARIES = libamip_interp.la # The convenience library depends on its source. -libamip_interp_la_SOURCES = amip_interp.F90 +libamip_interp_la_SOURCES = \ + amip_interp.F90 \ + include/amip_interp.inc \ + include/amip_interp_r4.fh \ + include/amip_interp_r8.fh BUILT_SOURCES = amip_interp_mod.$(FC_MODEXT) nodist_include_HEADERS = amip_interp_mod.$(FC_MODEXT) diff --git a/amip_interp/amip_interp.F90 b/amip_interp/amip_interp.F90 index d276052369..a28073e48b 100644 --- a/amip_interp/amip_interp.F90 +++ b/amip_interp/amip_interp.F90 @@ -135,7 +135,7 @@ module amip_interp_mod NOTE, mpp_error, fms_error_handler use constants_mod, only: TFREEZE, pi -use platform_mod, only: R4_KIND, I2_KIND +use platform_mod, only: r4_kind, r8_kind, i2_kind use mpp_mod, only: input_nml_file use fms2_io_mod, only: FmsNetcdfFile_t, fms2_io_file_exists=>file_exists, open_file, close_file, & get_dimension_size, fms2_io_read_data=>read_data @@ -147,15 +147,15 @@ module amip_interp_mod !----------------- Public interfaces ----------------------------------- public amip_interp_init, get_amip_sst, get_amip_ice, amip_interp_new, & - amip_interp_del, amip_interp_type, assignment(=) + & amip_interp_del, amip_interp_type, assignment(=) !----------------------------------------------------------------------- !----------------- Public Data ----------------------------------- integer :: i_sst = 1200 integer :: j_sst = 600 -real, parameter:: big_number = 1.E30 +real(r8_kind), parameter:: big_number = 1.E30_r8_kind logical :: forecast_mode = .false. -real, allocatable, dimension(:,:) :: sst_ncep, sst_anom +real(r8_kind), allocatable, dimension(:,:) :: sst_ncep, sst_anom public i_sst, j_sst, sst_ncep, sst_anom, forecast_mode, use_ncep_sst @@ -167,9 +167,8 @@ module amip_interp_mod ! Include variable "version" to be written to log file. #include - real, allocatable:: temp1(:,:), temp2(:,:) ! add by JHC - real, allocatable, dimension(:,:) :: tempamip + real(r8_kind), allocatable, dimension(:,:) :: tempamip ! end add by JHC !----------------------------------------------------------------------- !------ private defined data type -------- @@ -186,7 +185,7 @@ module amip_interp_mod !> Assignment overload to allow native assignment between amip_interp_type variables. !> @ingroup amip_interp_mod interface assignment(=) - module procedure amip_interp_type_eq + module procedure amip_interp_type_eq end interface !> Private logical equality overload for amip_interp_type @@ -207,6 +206,15 @@ module amip_interp_mod module procedure date_gt end interface +!> Retrieve sea surface temperature data and interpolated grid +interface get_amip_sst + module procedure get_amip_sst_r4, get_amip_sst_r8 +end interface + +!> AMIP interpolation for ice +interface get_amip_ice + module procedure get_amip_ice_r4, get_amip_ice_r8 +end interface !> Initializes data needed for the horizontal !! interpolation between the sst data and model grid. @@ -265,23 +273,24 @@ module amip_interp_mod !! !> @ingroup amip_interp_mod interface amip_interp_new - module procedure amip_interp_new_1d - module procedure amip_interp_new_2d + module procedure amip_interp_new_1d_r4, amip_interp_new_1d_r8 + module procedure amip_interp_new_2d_r4, amip_interp_new_2d_r8 end interface - !----- public data type ------ -!> @brief Contains information needed by the interpolation module (exchange_mod) and buffers data. +!> @brief Contains information needed by the interpolation module (exchange_mod) and buffers +!! data (r4_kind flavor). !> @ingroup amip_interp_mod type amip_interp_type private - type (horiz_interp_type) :: Hintrp, Hintrp2 ! add by JHC - real, allocatable :: data1(:,:), data2(:,:) - type (date_type) :: Date1, Date2 - logical :: use_climo, use_annual - logical :: I_am_initialized=.false. -end type + type (horiz_interp_type) :: Hintrp, Hintrp2 ! add by JHC + real(r4_kind), dimension(:,:), allocatable :: data1_r4, data2_r4 + real(r8_kind), dimension(:,:), allocatable :: data1_r8, data2_r8 + type (date_type) :: Date1, Date2 + logical :: use_climo, use_annual + logical :: I_am_initialized=.false. +end type amip_interp_type !> @addtogroup amip_interp_mod !> @{ @@ -289,7 +298,7 @@ module amip_interp_mod ! ---- resolution/grid variables ---- integer :: mobs, nobs - real, allocatable :: lon_bnd(:), lat_bnd(:) + real(r8_kind), allocatable, dimension(:) :: lon_bnd, lat_bnd ! ---- global unit & date ---- @@ -301,8 +310,8 @@ module amip_interp_mod type (date_type) :: Curr_date = date_type( -99, -99, -99 ) type (date_type) :: Date_end = date_type( -99, -99, -99 ) - real :: tice_crit_k - integer(I2_KIND) :: ice_crit + real(r8_kind) :: tice_crit_k + integer(i2_kind) :: ice_crit logical :: module_is_initialized = .false. @@ -316,19 +325,19 @@ module amip_interp_mod character(len=16) :: date_out_of_range = 'fail' !< use 'fail', 'initclimo', or 'climo' - real :: tice_crit = -1.80 !< in degC or degK + real(r8_kind) :: tice_crit = -1.80_r8_kind !< in degC or degK integer :: verbose = 0 !< 0 <= verbose <= 3 logical :: use_zonal = .false. !< parameters for prescribed zonal sst option - real :: teq = 305. !< parameters for prescribed zonal sst option - real :: tdif = 50. !< parameters for prescribed zonal sst option - real :: tann = 20. !< parameters for prescribed zonal sst option - real :: tlag = 0.875 !< parameters for prescribed zonal sst option + real(r8_kind) :: teq = 305._r8_kind !< parameters for prescribed zonal sst option + real(r8_kind) :: tdif = 50._r8_kind !< parameters for prescribed zonal sst option + real(r8_kind) :: tann = 20._r8_kind !< parameters for prescribed zonal sst option + real(r8_kind) :: tlag = 0.875_r8_kind !< parameters for prescribed zonal sst option integer :: amip_date(3)=(/-1,-1,-1/) !< amip date for repeating single day (rsd) option - real :: sst_pert = 0. !< global temperature perturbation used for sensitivity experiments + real(r8_kind) :: sst_pert = 0._r8_kind !< global temperature perturbation used for sensitivity experiments character(len=6) :: sst_pert_type = 'fixed' !< use 'random' or 'fixed' logical :: do_sst_pert = .false. @@ -356,507 +365,8 @@ module amip_interp_mod contains -! modified by JHC -!> Retrieve sea surface temperature data and interpolated grid -subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model) - - type (time_type), intent(in) :: Time !< Time to interpolate - type (amip_interp_type), intent(inout) :: Interp !< Holds data for interpolation - real, intent(out) :: sst(:,:) !< Sea surface temperature data - character(len=*), optional, intent(out) :: err_msg !< Holds error message string if present - - real, dimension(mobs,nobs) :: sice - - integer :: year1, year2, month1, month2 - real :: fmonth - type (date_type) :: Date1, Date2, Udate1, Udate2 - - type(time_type) :: Amip_Time - integer :: tod(3),dum(3) - -! add by JHC - real, intent(in), dimension(:,:), optional :: lon_model, lat_model - real :: pert - integer :: i, j, mobs_sst, nobs_sst - integer :: jhctod(6) - type (time_type) :: Udate - character(len=4) :: yyyy - integer :: nrecords, ierr, k, yr, mo, dy - integer, dimension(:), allocatable :: ryr, rmo, rdy - character(len=30) :: time_unit - real, dimension(:), allocatable :: timeval - character(len=maxc) :: ncfilename - type(FmsNetcdfFile_t) :: fileobj - logical :: the_file_exists -! end add by JHC - logical, parameter :: DEBUG = .false. !> switch for debugging output - !> These are fms_io specific - integer :: unit - - if(present(err_msg)) err_msg = '' - if(.not.Interp%I_am_initialized) then - if(fms_error_handler('get_amip_sst','The amip_interp_type variable is not initialized',err_msg)) return - endif - -!----------------------------------------------------------------------- -!----- compute zonally symetric sst --------------- - - if ( use_ncep_sst .and. forecast_mode ) no_anom_sst = .false. - - if (all(amip_date>0)) then - call get_date(Time,dum(1),dum(2),dum(3),tod(1),tod(2),tod(3)) - Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3)) - else - Amip_Time = Time - endif - -! add by JHC -if ( .not.use_daily ) then -! end add by JHC - - if ( .not. allocated(temp1) ) allocate (temp1(mobs,nobs)) - if ( .not. allocated(temp2) ) allocate (temp2(mobs,nobs)) - - if (use_zonal) then - call zonal_sst (Amip_Time, sice, temp1) - call horiz_interp ( Interp%Hintrp, temp1, sst ) - else - -!----------------------------------------------------------------------- -!---------- get new observed sea surface temperature ------------------- - -! ---- time interpolation for months ----- - call time_interp (Amip_Time, fmonth, year1, year2, month1, month2) -! ---- force climatology ---- - if (Interp % use_climo) then - year1=0; year2=0 - endif - if (Interp % use_annual) then - year1=0; year2=0 - month1=0; month2=0 - endif -! --------------------------- - - Date1 = date_type( year1, month1, 0 ) - Date2 = date_type( year2, month2, 0 ) - -! -- open/rewind file -- - unit = -1 -!----------------------------------------------------------------------- - - - if (Date1 /= Interp % Date1) then -! ---- use Date2 for Date1 ---- - if (Date1 == Interp % Date2) then - Interp % Date1 = Interp % Date2 - Interp % data1 = Interp % data2 - temp1(:,:) = temp2(:,:) ! SJL BUG fix: June 24, 2011 - else - call read_record ('sst', Date1, Udate1, temp1) - if ( use_ncep_sst .and. (.not. no_anom_sst) ) then - temp1(:,:) = temp1(:,:) + sst_anom(:,:) - endif - call horiz_interp ( Interp%Hintrp, temp1, Interp%data1 ) - call clip_data ('sst', Interp%data1) - Interp % Date1 = Date1 - endif - endif - -!----------------------------------------------------------------------- - - if (Date2 /= Interp % Date2) then - call read_record ('sst', Date2, Udate2, temp2) - if ( use_ncep_sst .and. (.not. no_anom_sst) ) then - temp2(:,:) = temp2(:,:) + sst_anom(:,:) - endif - call horiz_interp ( Interp%Hintrp, temp2, Interp%data2 ) - call clip_data ('sst', Interp%data2) - Interp % Date2 = Date2 - endif - -!----------------------------------------------------------------------- -!---------- time interpolation (between months) of sst's --------------- -!----------------------------------------------------------------------- - sst = Interp % data1 + fmonth * (Interp % data2 - Interp % data1) - -!------------------------------------------------------------------------------- -! SJL mods for NWP and TCSF --- -! Nudging runs: (Note: NCEP SST updated only every 6-hr) -! Compute SST anomaly from global SST datasets for subsequent forecast runs -!------------------------------------------------------------------------------- - if ( use_ncep_sst .and. no_anom_sst ) then - sst_anom(:,:) = sst_ncep(:,:) - (temp1(:,:) + fmonth*(temp2(:,:) - temp1(:,:)) ) - call horiz_interp ( Interp%Hintrp, sst_ncep, sst ) - call clip_data ('sst', sst) - endif - -!! DEBUG CODE - if (DEBUG) then - call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) - if (mpp_pe() == 0) then - write (*,200) 'JHC: use_daily = F, AMIP_Time: ',jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5), & - & jhctod(6) - write (*,300) 'JHC: use_daily = F, interped SST: ', sst(1,1),sst(5,5),sst(10,10) - endif - endif - - - endif - -! add by JHC -else - call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) - if (mpp_pe() == mpp_root_pe()) write(*,200) 'amip_interp_mod: use_daily = T, Amip_Time = ',jhctod(1), & - & jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6) - - yr = jhctod(1); mo = jhctod(2); dy = jhctod(3) - - write (yyyy,'(i4)') jhctod(1) - - file_name_sst = 'INPUT/' // 'sst.day.mean.'//yyyy//'.v2.nc' - ncfilename = trim(file_name_sst) - time_unit = 'days since 1978-01-01 00:00:00' - - mobs_sst = 1440; nobs_sst = 720 - - call set_sst_grid_edges_daily(mobs_sst, nobs_sst) - call horiz_interp_new ( Interp%Hintrp2, lon_bnd, lat_bnd, & - lon_model, lat_model, interp_method="bilinear" ) - - the_file_exists = fms2_io_file_exists(ncfilename) - - if ( (.NOT. the_file_exists) ) then - call mpp_error ('amip_interp_mod', & - 'cannot find daily SST input data file: '//trim(ncfilename), NOTE) - else - if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & - 'Reading NetCDF formatted daily SST from: '//trim(ncfilename), NOTE) - - if(.not. open_file(fileobj, trim(ncfilename), 'read')) & - call error_mesg ('get_amip_sst', 'Error in opening file '//trim(ncfilename), FATAL) - - call get_dimension_size(fileobj, 'TIME', nrecords) - if (nrecords < 1) call mpp_error('amip_interp_mod', & - 'Invalid number of SST records in daily SST data file: '//trim(ncfilename), FATAL) - allocate(timeval(nrecords), ryr(nrecords), rmo(nrecords), rdy(nrecords)) - call fms2_io_read_data(fileobj, 'TIME', timeval) -!!! DEBUG CODE - if(DEBUG) then - if (mpp_pe() == 0) then - print *, 'JHC: nrecords = ', nrecords - print *, 'JHC: TIME = ', timeval - endif - endif - - ierr = 1 - do k = 1, nrecords - - Udate = get_cal_time (timeval(k), time_unit, 'julian') - call get_date(Udate,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) - ryr(k) = jhctod(1); rmo(k) = jhctod(2); rdy(k) = jhctod(3) - - if ( yr == ryr(k) .and. mo == rmo(k) .and. dy == rdy (k) ) ierr = 0 - if (ierr==0) exit - - enddo - - if(DEBUG) then - if (mpp_pe() == 0) then - print *, 'JHC: k =', k - print *, 'JHC: ryr(k) rmo(k) rdy(k)',ryr(k), rmo(k), rdy(k) - print *, 'JHC: yr mo dy ',yr, mo, dy - endif - endif - - if (ierr .ne. 0) call mpp_error('amip_interp_mod', & - 'Model time is out of range not in SST data: '//trim(ncfilename), FATAL) - endif ! if(file_exist(ncfilename)) - - - !---- read NETCDF data ---- - if ( .not. allocated(tempamip) ) allocate (tempamip(mobs_sst,nobs_sst)) - - if (the_file_exists) then - call fms2_io_read_data(fileobj, 'SST', tempamip, unlim_dim_level=k) - call close_file(fileobj) - tempamip = tempamip + TFREEZE - -!!! DEBUG CODE - if(DEBUG) then - if (mpp_pe() == 0) then - print*, 'JHC: TFREEZE = ', TFREEZE - print*, lbound(sst) - print*, ubound(sst) - print*, lbound(tempamip) - print*, ubound(tempamip) - write(*,300) 'JHC: tempamip : ', tempamip(100,100), tempamip(200,200), tempamip(300,300) - endif - endif - - call horiz_interp ( Interp%Hintrp2, tempamip, sst ) - call clip_data ('sst', sst) - - endif - - if(DEBUG) then - if (mpp_pe() == 400) then - write(*,300)'JHC: use_daily = T, daily SST: ', sst(1,1),sst(5,5),sst(10,10) - print *,'JHC: use_daily = T, daily SST: ', sst - endif - endif - -200 format(a35, 6(i5,1x)) -300 format(a35, 3(f7.3,2x)) - -endif -! end add by JHC - -! add by JHC: add on non-zero sea surface temperature perturbation (namelist option) -! This perturbation may be useful in accessing model sensitivities - - if ( do_sst_pert ) then - - if ( trim(sst_pert_type) == 'fixed' ) then - sst = sst + sst_pert - else if ( trim(sst_pert_type) == 'random' ) then - call random_seed() - - if(DEBUG) then - if (mpp_pe() == 0) then - print*, 'mobs = ', mobs - print*, 'nobs = ', nobs - print*, lbound(sst) - print*, ubound(sst) - endif - endif - - do i = 1, size(sst,1) - do j = 1, size(sst,2) - call random_number(pert) - sst (i,j) = sst (i,j) + sst_pert*((pert-0.5)*2) - end do - end do - endif - - endif -! end add by JHC - -!----------------------------------------------------------------------- - - end subroutine get_amip_sst - -!> AMIP interpolation for ice -subroutine get_amip_ice (Time, Interp, ice, err_msg) - - type (time_type), intent(in) :: Time !< Time to interpolate - type (amip_interp_type), intent(inout) :: Interp !< Holds data for interpolation - real, intent(out) :: ice(:,:) !< ice data - character(len=*), optional, intent(out) :: err_msg !< Holds error message string if present - - real, dimension(mobs,nobs) :: sice, temp - - integer :: year1, year2, month1, month2 - real :: fmonth - type (date_type) :: Date1, Date2, Udate1, Udate2 - - type(time_type) :: Amip_Time - integer :: tod(3),dum(3) - - if(present(err_msg)) err_msg = '' - if(.not.Interp%I_am_initialized) then - if(fms_error_handler('get_amip_ice','The amip_interp_type variable is not initialized',err_msg)) return - endif - -!----------------------------------------------------------------------- -!----- compute zonally symetric sst --------------- - - - if (any(amip_date>0)) then - - call get_date(Time,dum(1),dum(2),dum(3),tod(1),tod(2),tod(3)) - - Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3)) - - else - - Amip_Time = Time - - endif - - -if (use_zonal) then - call zonal_sst (Amip_Time, sice, temp) - call horiz_interp ( Interp%Hintrp, sice, ice ) -else - -!----------------------------------------------------------------------- -!---------- get new observed sea surface temperature ------------------- - -! ---- time interpolation for months ----- - - call time_interp (Amip_Time, fmonth, year1, year2, month1, month2) - -! ---- force climatology ---- - if (Interp % use_climo) then - year1=0; year2=0 - endif - if (Interp % use_annual) then - year1=0; year2=0 - month1=0; month2=0 - endif -! --------------------------- - - Date1 = date_type( year1, month1, 0 ) - Date2 = date_type( year2, month2, 0 ) - - unit = -1 -!----------------------------------------------------------------------- - - if (Date1 /= Interp % Date1) then -! ---- use Date2 for Date1 ---- - if (Date1 == Interp % Date2) then - Interp % Date1 = Interp % Date2 - Interp % data1 = Interp % data2 - else -!-- SJL ------------------------------------------------------------- -! Can NOT use ncep_sst to determine sea_ice For seasonal forecast -! Use climo sea ice for seasonal runs - if ( use_ncep_sst .and. use_ncep_ice ) then - where ( sst_ncep <= (TFREEZE+tice_crit) ) - sice = 1. - elsewhere - sice = 0. - endwhere - else - call read_record ('ice', Date1, Udate1, sice) - endif -!-------------------------------------------------------------------- - call horiz_interp ( Interp%Hintrp, sice, Interp%data1 ) - call clip_data ('ice', Interp%data1) - Interp % Date1 = Date1 - endif - endif - -!----------------------------------------------------------------------- - - if (Date2 /= Interp % Date2) then - -!-- SJL ------------------------------------------------------------- - if ( use_ncep_sst .and. use_ncep_ice ) then - where ( sst_ncep <= (TFREEZE+tice_crit) ) - sice = 1. - elsewhere - sice = 0. - endwhere - else - call read_record ('ice', Date2, Udate2, sice) - endif -!-------------------------------------------------------------------- - call horiz_interp ( Interp%Hintrp, sice, Interp%data2 ) - call clip_data ('ice', Interp%data2) - Interp % Date2 = Date2 - - endif - -!----------------------------------------------------------------------- -!---------- time interpolation (between months) ------------------------ -!----------------------------------------------------------------------- - - ice = Interp % data1 + fmonth * (Interp % data2 - Interp % data1) - -endif - -!----------------------------------------------------------------------- - - end subroutine get_amip_ice - -!####################################################################### - - !> @return A newly created @ref amip_interp_type - function amip_interp_new_1d ( lon , lat , mask , use_climo, use_annual, & - interp_method ) result (Interp) - - real, intent(in), dimension(:) :: lon, lat - logical, intent(in), dimension(:,:) :: mask - character(len=*), intent(in), optional :: interp_method - logical, intent(in), optional :: use_climo, use_annual - - type (amip_interp_type) :: Interp - - if(.not.module_is_initialized) call amip_interp_init - - Interp % use_climo = .false. - if (present(use_climo)) Interp % use_climo = use_climo - Interp % use_annual = .false. - if (present(use_annual)) Interp % use_annual = use_annual - - if ( date_out_of_range == 'fail' .and. Interp%use_climo ) & - call error_mesg ('amip_interp_new_1d', 'use_climo mismatch', FATAL) - - if ( date_out_of_range == 'fail' .and. Interp%use_annual ) & - call error_mesg ('amip_interp_new_1d', 'use_annual(climo) mismatch', FATAL) - - Interp % Date1 = date_type( -99, -99, -99 ) - Interp % Date2 = date_type( -99, -99, -99 ) - -!----------------------------------------------------------------------- -! ---- initialization of horizontal interpolation ---- - - call horiz_interp_new ( Interp%Hintrp, lon_bnd, lat_bnd, & - lon, lat, interp_method= interp_method ) - - allocate ( Interp % data1 (size(lon(:))-1,size(lat(:))-1), & - Interp % data2 (size(lon(:))-1,size(lat(:))-1) ) - - Interp%I_am_initialized = .true. - - end function amip_interp_new_1d - - !> @return A newly created @ref amip_interp_type - function amip_interp_new_2d ( lon , lat , mask , use_climo, use_annual, & - interp_method ) result (Interp) - - real, intent(in), dimension(:,:) :: lon, lat - logical, intent(in), dimension(:,:) :: mask - character(len=*), intent(in), optional :: interp_method - logical, intent(in), optional :: use_climo, use_annual - - type (amip_interp_type) :: Interp - - if(.not.module_is_initialized) call amip_interp_init - - Interp % use_climo = .false. - if (present(use_climo)) Interp % use_climo = use_climo - Interp % use_annual = .false. - if (present(use_annual)) Interp % use_annual = use_annual - - if ( date_out_of_range == 'fail' .and. Interp%use_climo ) & - call error_mesg ('amip_interp_new_2d', 'use_climo mismatch', FATAL) - - if ( date_out_of_range == 'fail' .and. Interp%use_annual ) & - call error_mesg ('amip_interp_new_2d', 'use_annual(climo) mismatch', FATAL) - - Interp % Date1 = date_type( -99, -99, -99 ) - Interp % Date2 = date_type( -99, -99, -99 ) - -!----------------------------------------------------------------------- -! ---- initialization of horizontal interpolation ---- - - call horiz_interp_new ( Interp%Hintrp, lon_bnd, lat_bnd, & - lon, lat, interp_method = interp_method) - - allocate ( Interp % data1 (size(lon,1),size(lat,2)), & - Interp % data2 (size(lon,1),size(lat,2))) - - Interp%I_am_initialized = .true. - - end function amip_interp_new_2d - -!####################################################################### - !> initialize @ref amip_interp_mod for use - subroutine amip_interp_init() - + subroutine amip_interp_init integer :: unit,io,ierr !----------------------------------------------------------------------- @@ -887,8 +397,10 @@ subroutine amip_interp_init() ! ---- freezing point of sea water in deg K --- tice_crit_k = tice_crit - if ( tice_crit_k < 200. ) tice_crit_k = tice_crit_k + TFREEZE - ice_crit = nint((tice_crit_k-TFREEZE)*100., I2_KIND) + if ( tice_crit_k < 200._r8_kind ) then + tice_crit_k = tice_crit_k + TFREEZE + endif + ice_crit = nint((tice_crit_k-TFREEZE)*100._r8_kind, I2_KIND) ! ---- set up file dependent variable ---- ! ---- global file name ---- @@ -909,7 +421,7 @@ subroutine amip_interp_init() mobs = 360; nobs = 180 call set_sst_grid_edges_oi ! --- specfied min for amip2 --- - tice_crit_k = 271.38 + tice_crit_k = 271.38_r8_kind if (mpp_pe() == 0) & call error_mesg ('amip_interp_init', 'using AMIP 2 sst', NOTE) Date_end = date_type( 1996, 3, 0 ) @@ -919,7 +431,7 @@ subroutine amip_interp_init() mobs = 360; nobs = 180 call set_sst_grid_edges_oi ! --- specfied min for hurrell --- - tice_crit_k = 271.38 + tice_crit_k = 271.38_r8_kind if (mpp_pe() == 0) & call error_mesg ('amip_interp_init', 'using HURRELL sst', NOTE) Date_end = date_type( 2011, 8, 16 ) ! updated by JHC @@ -991,230 +503,96 @@ subroutine amip_interp_init() if (.not. open_file(fileobj_ice, trim(file_name_ice), 'read')) & call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_ice), FATAL) module_is_initialized = .true. - end subroutine amip_interp_init -!####################################################################### - -!> Frees data associated with a amip_interp_type variable. Should be used for any -!! variables initialized via @ref amip_interp_new. -!> @param[inout] Interp A defined data type variable initialized by amip_interp_new and used -!! when calling get_amip_sst and get_amip_ice. - subroutine amip_interp_del (Interp) - type (amip_interp_type), intent(inout) :: Interp - if(allocated(Interp%data1)) deallocate(Interp%data1) - if(allocated(Interp%data2)) deallocate(Interp%data2) - if(allocated(lon_bnd)) deallocate(lon_bnd) - if(allocated(lat_bnd)) deallocate(lat_bnd) - call horiz_interp_del ( Interp%Hintrp ) - - Interp%I_am_initialized = .false. - - end subroutine amip_interp_del - -!####################################################################### - subroutine set_sst_grid_edges_amip1 - integer :: i, j - real :: hpie, dlon, dlat, wb, sb + real(r8_kind) :: hpie, dlon, dlat, wb, sb - allocate ( lon_bnd(mobs+1), lat_bnd(nobs+1) ) + allocate(lon_bnd(mobs+1)) + allocate(lat_bnd(nobs+1)) ! ---- compute grid edges (do only once) ----- - hpie = 0.5*pi + hpie = pi / 2._r8_kind + + dlon = 4._r8_kind*hpie/real(mobs, r8_kind) + wb = -0.5_r8_kind*dlon - dlon = 4.*hpie/float(mobs); wb = -0.5*dlon do i = 1, mobs+1 - lon_bnd(i) = wb + dlon * float(i-1) + lon_bnd(i) = wb + dlon*real(i-1, r8_kind) enddo - lon_bnd(mobs+1) = lon_bnd(1) + 4.*hpie + lon_bnd(mobs+1) = lon_bnd(1) + 4._r8_kind*hpie - dlat = 2.*hpie/float(nobs-1); sb = -hpie + 0.5*dlat - lat_bnd(1) = -hpie; lat_bnd(nobs+1) = hpie + dlat = 2._r8_kind*hpie/real(nobs-1, r8_kind) + sb = -hpie + 0.5_r8_kind*dlat + + lat_bnd(1) = -hpie + lat_bnd(nobs+1) = hpie do j = 2, nobs - lat_bnd(j) = sb + dlat * float(j-2) + lat_bnd(j) = sb + dlat * real(j-2, r8_kind) enddo - end subroutine set_sst_grid_edges_amip1 -!####################################################################### subroutine set_sst_grid_edges_oi - integer :: i, j - real :: hpie, dlon, dlat, wb, sb + real(r8_kind) :: hpie, dlon, dlat, wb, sb ! add by JHC - if(allocated(lon_bnd)) deallocate(lon_bnd) - if(allocated(lat_bnd)) deallocate(lat_bnd) + if(allocated(lon_bnd)) deallocate(lon_bnd) + if(allocated(lat_bnd)) deallocate(lat_bnd) ! end add by JHC - allocate ( lon_bnd(mobs+1), lat_bnd(nobs+1) ) + + allocate(lon_bnd(mobs+1)) + allocate(lat_bnd(nobs+1)) ! ---- compute grid edges (do only once) ----- - hpie = 0.5*pi + hpie = pi / 2._r8_kind + dlon = 4._r8_kind*hpie/real(mobs, r8_kind) + wb = 0.0_r8_kind - dlon = 4.*hpie/float(mobs); wb = 0.0 - lon_bnd(1) = wb + lon_bnd(1) = wb do i = 2, mobs+1 - lon_bnd(i) = wb + dlon * float(i-1) + lon_bnd(i) = wb + dlon * real(i-1, r8_kind) enddo - lon_bnd(mobs+1) = lon_bnd(1) + 4.*hpie + lon_bnd(mobs+1) = lon_bnd(1) + 4._r8_kind*hpie - dlat = 2.*hpie/float(nobs); sb = -hpie - lat_bnd(1) = sb; lat_bnd(nobs+1) = hpie + dlat = 2._r8_kind*hpie/real(nobs, r8_kind) + sb = -hpie + + lat_bnd(1) = sb + lat_bnd(nobs+1) = hpie do j = 2, nobs - lat_bnd(j) = sb + dlat * float(j-1) + lat_bnd(j) = sb + dlat * real(j-1, r8_kind) enddo - end subroutine set_sst_grid_edges_oi -!####################################################################### -! add by JHC - subroutine set_sst_grid_edges_daily(mobs_sst, nobs_sst) - - integer :: i, j, mobs_sst, nobs_sst - real :: hpie, dlon, dlat, wb, sb - - if(allocated(lon_bnd)) deallocate(lon_bnd) - if(allocated(lat_bnd)) deallocate(lat_bnd) - allocate ( lon_bnd(mobs_sst+1), lat_bnd(nobs_sst+1) ) - -! ---- compute grid edges (do only once) ----- - - hpie = 0.5*pi - - dlon = 4.*hpie/float(mobs_sst); wb = 0.0 - lon_bnd(1) = wb - do i = 2, mobs_sst+1 - lon_bnd(i) = wb + dlon * float(i-1) - enddo - lon_bnd(mobs_sst+1) = lon_bnd(1) + 4.*hpie - - dlat = 2.*hpie/float(nobs_sst); sb = -hpie - lat_bnd(1) = sb; lat_bnd(nobs_sst+1) = hpie - do j = 2, nobs_sst - lat_bnd(j) = sb + dlat * float(j-1) - enddo - - end subroutine set_sst_grid_edges_daily -! end add by JHC -!####################################################################### - - - subroutine a2a_bilinear(nx, ny, dat1, n1, n2, dat2) - integer, intent(in):: nx, ny - integer, intent(in):: n1, n2 - real, intent(in) :: dat1(nx,ny) - real, intent(out):: dat2(n1,n2) !> output interpolated data - -! local: - real:: lon1(nx), lat1(ny) - real:: lon2(n1), lat2(n2) - real:: dx1, dy1, dx2, dy2 - real:: xc, yc - real:: a1, b1, c1, c2, c3, c4 - integer i1, i2, jc, i0, j0, it, jt - integer i,j - - -!----------------------------------------------------------- -! * Interpolate from "FMS" 1x1 SST data grid to a finer grid -! lon: 0.5, 1.5, ..., 359.5 -! lat: -89.5, -88.5, ... , 88.5, 89.5 -!----------------------------------------------------------- - - dx1 = 360./real(nx) !> INput Grid - dy1 = 180./real(ny) !> INput Grid - - do i=1,nx - lon1(i) = 0.5*dx1 + real(i-1)*dx1 - enddo - do j=1,ny - lat1(j) = -90. + 0.5*dy1 + real(j-1)*dy1 - enddo - - dx2 = 360./real(n1) !> OutPut Grid: - dy2 = 180./real(n2) !> OutPut Grid: - - do i=1,n1 - lon2(i) = 0.5*dx2 + real(i-1)*dx2 - enddo - do j=1,n2 - lat2(j) = -90. + 0.5*dy2 + real(j-1)*dy2 - enddo - - jt = 1 - do 5000 j=1,n2 - - yc = lat2(j) - if ( yclat1(ny) ) then - jc = ny-1 - b1 = 1. - else - do j0=jt,ny-1 - if ( yc>=lat1(j0) .and. yc<=lat1(j0+1) ) then - jc = j0 - jt = j0 - b1 = (yc-lat1(jc)) / dy1 - go to 222 - endif - enddo - endif -222 continue - - it = 1 - do i=1,n1 - xc = lon2(i) - if ( xc>lon1(nx) ) then - i1 = nx; i2 = 1 - a1 = (xc-lon1(nx)) / dx1 - elseif ( xc=lon1(i0) .and. xc<=lon1(i0+1) ) then - i1 = i0; i2 = i0+1 - it = i0 - a1 = (xc-lon1(i1)) / dx1 - go to 111 - endif - enddo - endif -111 continue - -! Debug code: - if ( a1<-0.001 .or. a1>1.001 .or. b1<-0.001 .or. b1>1.001 ) then - write(*,*) i,j,a1, b1 - call mpp_error(FATAL,'a2a bilinear interpolation') - endif - - c1 = (1.-a1) * (1.-b1) - c2 = a1 * (1.-b1) - c3 = a1 * b1 - c4 = (1.-a1) * b1 -! Bilinear interpolation: - dat2(i,j) = c1*dat1(i1,jc) + c2*dat1(i2,jc) + c3*dat1(i2,jc+1) + c4*dat1(i1,jc+1) +!> Frees data associated with a amip_interp_type variable. Should be used for any +!! variables initialized via @ref amip_interp_new. +!> @param[inout] Interp A defined data type variable initialized by amip_interp_new and used +!! when calling get_amip_sst and get_amip_ice. + subroutine amip_interp_del (Interp) + type (amip_interp_type), intent(inout) :: Interp - enddo !i-loop + if(allocated(Interp%data1_r4)) deallocate(Interp%data1_r4) + if(allocated(Interp%data1_r8)) deallocate(Interp%data1_r8) + if(allocated(Interp%data2_r4)) deallocate(Interp%data2_r4) + if(allocated(Interp%data2_r8)) deallocate(Interp%data2_r8) -5000 continue ! j-loop + if(allocated(lon_bnd)) deallocate(lon_bnd) + if(allocated(lat_bnd)) deallocate(lat_bnd) - end subroutine a2a_bilinear + call horiz_interp_del ( Interp%Hintrp ) -!####################################################################### + Interp%I_am_initialized = .false. + end subroutine amip_interp_del !> @brief Returns the size (i.e., number of longitude and latitude !! points) of the observed data grid. !! @throws FATAL have not called amip_interp_new !! Must call amip_interp_new before get_sst_grid_size. subroutine get_sst_grid_size (nlon, nlat) - integer, intent(out) :: nlon !> The number of longitude points (first dimension) in the !! observed data grid. For AMIP 1 nlon = 180, and the Reynolds nlon = 360. integer, intent(out) :: nlat !> The number of latitude points (second dimension) in the @@ -1223,182 +601,8 @@ subroutine get_sst_grid_size (nlon, nlat) if ( .not.module_is_initialized ) call amip_interp_init nlon = mobs; nlat = nobs - end subroutine get_sst_grid_size -!####################################################################### - -!> @brief Returns the grid box boundaries of the observed data grid. -!! -!! @throws FATAL, have not called amip_interp_new -!! Must call amip_interp_new before get_sst_grid_boundary. -!! -!! @throws FATAL, invalid argument dimensions -!! The size of the output argument arrays do not agree with -!! the size of the observed data. See the documentation for -!! interfaces get_sst_grid_size and get_sst_grid_boundary. - subroutine get_sst_grid_boundary (blon, blat, mask) - - real, intent(out) :: blon(:) !> The grid box edges (in radians) for longitude points of the - !! observed data grid. The size of this argument must be nlon+1. - real, intent(out) :: blat(:) !> The grid box edges (in radians) for latitude points of the - !! observed data grid. The size of this argument must be nlat+1. - logical, intent(out) :: mask(:,:) - - if ( .not.module_is_initialized ) call amip_interp_init - -! ---- check size of argument(s) ---- - - if (size(blon(:)) /= mobs+1 .or. size(blat(:)) /= nobs+1) & - call error_mesg ('get_sst_grid_boundary in amip_interp_mod', & - 'invalid argument dimensions', FATAL) - -! ---- return grid box edges ----- - - blon = lon_bnd - blat = lat_bnd - -! ---- masking (data exists at all points) ---- - - mask = .true. - - - end subroutine get_sst_grid_boundary - -!####################################################################### - - subroutine read_record (type, Date, Adate, dat) - - character(len=*), intent(in) :: type - type (date_type), intent(in) :: Date - type (date_type), intent(inout) :: Adate - real, intent(out) :: dat(mobs,nobs) - real :: tmp_dat(360,180) - - integer(I2_KIND) :: idat(mobs,nobs) - integer :: nrecords, yr, mo, dy, ierr, k - integer, dimension(:), allocatable :: ryr, rmo, rdy - character(len=maxc) :: ncfilename, ncfieldname - type(FmsNetcdfFile_t), pointer :: fileobj - - !---- set file and field name for NETCDF data sets ---- - - ncfieldname = 'sst' - if(type(1:3) == 'sst') then - ncfilename = trim(file_name_sst) - fileobj => fileobj_sst - else if(type(1:3) == 'ice') then - ncfilename = trim(file_name_ice) - fileobj => fileobj_ice - if (lowercase(trim(data_set)) == 'amip2' .or. & - lowercase(trim(data_set)) == 'hurrell' .or. & - lowercase(trim(data_set)) == 'daily') ncfieldname = 'ice' ! modified by JHC - endif - - dy = 0 ! only processing monthly data - - if (verbose > 2 .and. mpp_pe() == 0) & - print *, 'looking for date = ', Date - - ! This code can handle amip1, reynolds, or reyoi type SST data files in netCDF format - if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & - 'Reading NetCDF formatted input data file: '//trim(ncfilename), NOTE) - - call fms2_io_read_data (fileobj, 'nrecords', nrecords) - if (nrecords < 1) call mpp_error('amip_interp_mod', & - 'Invalid number of SST records in SST datafile: '//trim(ncfilename), FATAL) - allocate(ryr(nrecords), rmo(nrecords), rdy(nrecords)) - call fms2_io_read_data(fileobj, 'yr', ryr) - call fms2_io_read_data(fileobj, 'mo', rmo) - call fms2_io_read_data(fileobj, 'dy', rdy) - - ierr = 1 - do k = 1, nrecords - yr = ryr(k); mo = rmo(k) - Adate = date_type( yr, mo, 0) - Curr_date = Adate - if (verbose > 2 .and. mpp_pe() == 0) & - print *, '....... checking ', Adate - if (Date == Adate) ierr = 0 - if (yr == 0 .and. mo == Date%month) ierr = 0 - if (ierr == 0) exit - enddo - if (ierr .ne. 0) call mpp_error('amip_interp_mod', & - 'Model time is out of range not in SST data: '//trim(ncfilename), FATAL) - deallocate(ryr, rmo, rdy) - !PRINT *, 'New SST data: ', k, yr, mo, dy, Date%year, Date%month, Date%day, ryr(1), rmo(1) - - !---- check if climatological data should be used ---- - - if (yr == 0 .or. mo == 0) then - ierr = 0 - if (date_out_of_range == 'fail' ) ierr = 1 - if (date_out_of_range == 'initclimo' .and. & - Date > Date_end ) ierr = 1 - if (ierr /= 0) call error_mesg & - ('read_record in amip_interp_mod', & - 'climo data read when NO climo data requested', FATAL) - endif - - !---- read NETCDF data ---- - - if ( interp_oi_sst ) then - call fms2_io_read_data(fileobj, ncfieldname, tmp_dat, unlim_dim_level=k) -! interpolate tmp_dat(360, 180) ---> dat(mobs,nobs) (to enable SST anom computation) - if ( mobs/=360 .or. nobs/=180 ) then - call a2a_bilinear(360, 180, tmp_dat, mobs, nobs, dat) - else - dat(:,:) = tmp_dat(:,:) - endif - else - call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k) - endif - !TODO This assumes that the data is "packed" (has the scale_factor and add_offset attributes) - ! in fms2_io_read_data the data is unpacked (data_in_file*scale_factor + add_offset) - ! the line below "packs" the data again. This is needed for reproducibility - idat = nint(dat*100., I2_KIND) - - !---- unpacking of data ---- - - if (type(1:3) == 'ice') then - !---- create fractional [0,1] ice mask - if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then - where ( idat <= ice_crit ) - dat = 1. - elsewhere - dat = 0. - endwhere - else - dat = dat*0.01 - endif - else if (type(1:3) == 'sst') then - !---- unpack sst ---- - if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then - dat = real(idat)*0.01 + TFREEZE - endif - endif - - return - - end subroutine read_record - -!####################################################################### - - subroutine clip_data (type, dat) - - character(len=*), intent(in) :: type - real, intent(inout) :: dat(:,:) - - if (type(1:3) == 'ice') then - dat = min(max(dat,0.0),1.0) - else if (type(1:3) == 'sst') then - dat = max(tice_crit_k,dat) - endif - - end subroutine clip_data - -!####################################################################### - !> @return logical answer function date_equals (Left, Right) result (answer) type (date_type), intent(in) :: Left, Right @@ -1411,11 +615,8 @@ function date_equals (Left, Right) result (answer) else answer = .false. endif - end function date_equals -!####################################################################### - !> @return logical answer function date_not_equals (Left, Right) result (answer) type (date_type), intent(in) :: Left, Right @@ -1428,11 +629,8 @@ function date_not_equals (Left, Right) result (answer) else answer = .true. endif - end function date_not_equals -!####################################################################### - !> @return logical answer function date_gt (Left, Right) result (answer) type (date_type), intent(in) :: Left, Right @@ -1451,85 +649,9 @@ function date_gt (Left, Right) result (answer) exit endif enddo - end function date_gt -!####################################################################### - -subroutine print_dates (Time, Date1, Udate1, & - Date2, Udate2, fmonth) - - type (time_type), intent(in) :: Time - type (date_type), intent(in) :: Date1, Udate1, Date2, Udate2 - real, intent(in) :: fmonth - - integer :: year, month, day, hour, minute, second - - call get_date (Time, year, month, day, hour, minute, second) - - write (*,10) year,month,day, hour,minute,second - write (*,20) fmonth - write (*,30) Date1, Udate1 - write (*,40) Date2, Udate2 - -10 format (/,' date(y/m/d h:m:s) = ',i4,2('/',i2.2),1x,2(i2.2,':'),i2.2) -20 format (' fmonth = ',f9.7) -30 format (' date1(y/m/d) = ',i4,2('/',i2.2),6x, & - 'used = ',i4,2('/',i2.2),6x ) -40 format (' date2(y/m/d) = ',i4,2('/',i2.2),6x, & - 'used = ',i4,2('/',i2.2),6x ) - -end subroutine print_dates - -!####################################################################### - -subroutine zonal_sst (Time, ice, sst) - - type (time_type), intent(in) :: Time - real, intent(out) :: ice(mobs,nobs), sst(mobs,nobs) - - real :: tpi, fdate, eps, ph, sph, sph2, ts - integer :: j - -! namelist needed -! -! teq = sst at equator -! tdif = equator to pole sst difference -! tann = amplitude of annual cycle -! tlag = offset for time of year (for annual cycle) -! - - tpi = 2.0*pi - - fdate = fraction_of_year (Time) - - eps = sin( tpi*(fdate-tlag) ) * tann - - do j = 1, nobs - - ph = 0.5*(lat_bnd(j)+lat_bnd(j+1)) - sph = sin(ph) - sph2 = sph*sph - - ts = teq - tdif*sph2 - eps*sph - - sst(:,j) = ts - - enddo - - where ( sst < tice_crit_k ) - ice = 1.0 - sst = tice_crit_k - elsewhere - ice = 0.0 - endwhere - - -end subroutine zonal_sst - -!####################################################################### - -subroutine amip_interp_type_eq(amip_interp_out, amip_interp_in) +subroutine amip_interp_type_eq (amip_interp_out, amip_interp_in) type(amip_interp_type), intent(inout) :: amip_interp_out type(amip_interp_type), intent(in) :: amip_interp_in @@ -1539,8 +661,10 @@ subroutine amip_interp_type_eq(amip_interp_out, amip_interp_in) amip_interp_out%Hintrp = amip_interp_in%Hintrp amip_interp_out%Hintrp2 = amip_interp_in%Hintrp2 !< missing assignment statement; added by GPP - amip_interp_out%data1 = amip_interp_in%data1 - amip_interp_out%data2 = amip_interp_in%data2 + amip_interp_out%data1_r4 = amip_interp_in%data1_r4 + amip_interp_out%data1_r8 = amip_interp_in%data1_r8 + amip_interp_out%data2_r4 = amip_interp_in%data2_r4 + amip_interp_out%data2_r8 = amip_interp_in%data2_r8 amip_interp_out%Date1 = amip_interp_in%Date1 amip_interp_out%Date2 = amip_interp_in%Date2 amip_interp_out%Date1 = amip_interp_in%Date1 @@ -1548,10 +672,10 @@ subroutine amip_interp_type_eq(amip_interp_out, amip_interp_in) amip_interp_out%use_climo = amip_interp_in%use_climo amip_interp_out%use_annual = amip_interp_in%use_annual amip_interp_out%I_am_initialized = .true. - end subroutine amip_interp_type_eq -!####################################################################### +#include "amip_interp_r4.fh" +#include "amip_interp_r8.fh" end module amip_interp_mod !> @} diff --git a/amip_interp/include/amip_interp.inc b/amip_interp/include/amip_interp.inc new file mode 100644 index 0000000000..af8e7487b5 --- /dev/null +++ b/amip_interp/include/amip_interp.inc @@ -0,0 +1,810 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +! modified by JHC +!> Retrieve sea surface temperature data and interpolated grid +subroutine GET_AMIP_SST_ (Time, Interp, sst, err_msg, lon_model, lat_model) + type (time_type), intent(in) :: Time !< Time to interpolate + type (amip_interp_type), target, intent(inout) :: Interp !< Holds data for interpolation + real(FMS_AMIP_INTERP_KIND_), intent(out) :: sst(:,:) !< Sea surface temperature data + character(len=*), optional, intent(out) :: err_msg !< Holds error message string if present + + real(FMS_AMIP_INTERP_KIND_), dimension(mobs,nobs) :: sice + real(FMS_AMIP_INTERP_KIND_), allocatable, save :: temp1(:,:), temp2(:,:) + + integer :: year1, year2, month1, month2 + real(FMS_AMIP_INTERP_KIND_) :: fmonth + type (date_type) :: Date1, Date2, Udate1, Udate2 + + type(time_type) :: Amip_Time + integer :: tod(3),dum(3) + +! add by JHC + real(FMS_AMIP_INTERP_KIND_), intent(in), dimension(:,:), optional :: lon_model, lat_model + real(FMS_AMIP_INTERP_KIND_) :: pert + integer :: i, j, mobs_sst, nobs_sst + integer :: jhctod(6) + type (time_type) :: Udate + character(len=4) :: yyyy + integer :: nrecords, ierr, k, yr, mo, dy + integer, dimension(:), allocatable :: ryr, rmo, rdy + character(len=30) :: time_unit + real(FMS_AMIP_INTERP_KIND_), dimension(:), allocatable :: timeval + character(len=maxc) :: ncfilename + type(FmsNetcdfFile_t) :: fileobj + logical :: the_file_exists +! end add by JHC + logical, parameter :: DEBUG = .false. !> switch for debugging output + !> These are fms_io specific + integer :: unit + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + if(present(err_msg)) err_msg = '' + if(.not.Interp%I_am_initialized) then + if(fms_error_handler('get_amip_sst','The amip_interp_type variable is not initialized',err_msg)) return + endif + +!----------------------------------------------------------------------- +!----- compute zonally symetric sst --------------- + + if ( use_ncep_sst .and. forecast_mode ) no_anom_sst = .false. + + if (all(amip_date>0)) then + call get_date(Time,dum(1),dum(2),dum(3),tod(1),tod(2),tod(3)) + Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3)) + else + Amip_Time = Time + endif + +! add by JHC +if ( .not.use_daily ) then +! end add by JHC + + if ( .not. allocated(temp1) ) allocate (temp1(mobs,nobs)) + if ( .not. allocated(temp2) ) allocate (temp2(mobs,nobs)) + + if (use_zonal) then + call ZONAL_SST_ (Amip_Time, sice, temp1) + call horiz_interp (Interp%Hintrp, temp1, sst) + else + +!----------------------------------------------------------------------- +!---------- get new observed sea surface temperature ------------------- + +! ---- time interpolation for months ----- + call time_interp (Amip_Time, fmonth, year1, year2, month1, month2) +! ---- force climatology ---- + if (Interp%use_climo) then + year1=0; year2=0 + endif + if (Interp%use_annual) then + year1=0; year2=0 + month1=0; month2=0 + endif +! --------------------------- + + Date1 = date_type( year1, month1, 0 ) + Date2 = date_type( year2, month2, 0 ) + +! -- open/rewind file -- + unit = -1 +!----------------------------------------------------------------------- + + if (Date1 /= Interp%Date1) then +! ---- use Date2 for Date1 ---- + if (Date1 == Interp%Date2) then + Interp%Date1 = Interp%Date2 + Interp%DATA1_ = Interp%DATA2_ + temp1(:,:) = temp2(:,:) ! SJL BUG fix: June 24, 2011 + else + call READ_RECORD_ ('sst', Date1, Udate1, temp1) + if ( use_ncep_sst .and. (.not. no_anom_sst) ) then + temp1 = temp1 + SST_ANOM_ + endif + call horiz_interp ( Interp%Hintrp, temp1, Interp%DATA1_) + call CLIP_DATA_ ('sst', Interp%DATA1_) + Interp%Date1 = Date1 + endif + endif + +!----------------------------------------------------------------------- + + if (Date2 /= Interp%Date2) then + call READ_RECORD_ ('sst', Date2, Udate2, temp2) + if ( use_ncep_sst .and. (.not. no_anom_sst) ) then + temp2 = temp2 + SST_ANOM_ + endif + call horiz_interp ( Interp%Hintrp, temp2, Interp%DATA2_) + call CLIP_DATA_ ('sst', Interp%DATA2_) + Interp%Date2 = Date2 + endif + +!----------------------------------------------------------------------- +!---------- time interpolation (between months) of sst's --------------- +!----------------------------------------------------------------------- + sst = Interp%DATA1_ + fmonth * (Interp%DATA2_ - Interp%DATA1_) + +!------------------------------------------------------------------------------- +! SJL mods for NWP and TCSF --- +! Nudging runs: (Note: NCEP SST updated only every 6-hr) +! Compute SST anomaly from global SST datasets for subsequent forecast runs +!------------------------------------------------------------------------------- + if ( use_ncep_sst .and. no_anom_sst ) then + sst_anom = SST_NCEP_ - (temp1 + fmonth*(temp2 - temp1)) + call horiz_interp (Interp%Hintrp, SST_NCEP_, sst) + call CLIP_DATA_ ('sst', sst) + endif + +!! DEBUG CODE + if (DEBUG) then + call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) + if (mpp_pe() == 0) then + write (*,200) 'JHC: use_daily = F, AMIP_Time: ',jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5), & + & jhctod(6) + write (*,300) 'JHC: use_daily = F, interped SST: ', sst(1,1),sst(5,5),sst(10,10) + endif + endif + + + endif + +! add by JHC +else + call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) + if (mpp_pe() == mpp_root_pe()) write(*,200) 'amip_interp_mod: use_daily = T, Amip_Time = ',jhctod(1), & + & jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6) + + yr = jhctod(1); mo = jhctod(2); dy = jhctod(3) + + write (yyyy,'(i4)') jhctod(1) + + file_name_sst = 'INPUT/' // 'sst.day.mean.'//yyyy//'.v2.nc' + ncfilename = trim(file_name_sst) + time_unit = 'days since 1978-01-01 00:00:00' + + mobs_sst = 1440; nobs_sst = 720 + + call SET_SST_GRID_EDGES_DAILY_ (mobs_sst, nobs_sst) + call horiz_interp_new ( Interp%Hintrp2, LON_BND_, LAT_BND_, & + lon_model, lat_model, interp_method="bilinear" ) + + the_file_exists = fms2_io_file_exists(ncfilename) + + if ( (.NOT. the_file_exists) ) then + call mpp_error ('amip_interp_mod', & + 'cannot find daily SST input data file: '//trim(ncfilename), NOTE) + else + if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & + 'Reading NetCDF formatted daily SST from: '//trim(ncfilename), NOTE) + + if(.not. open_file(fileobj, trim(ncfilename), 'read')) & + call error_mesg ('get_amip_sst', 'Error in opening file '//trim(ncfilename), FATAL) + + call get_dimension_size(fileobj, 'TIME', nrecords) + if (nrecords < 1) call mpp_error('amip_interp_mod', & + 'Invalid number of SST records in daily SST data file: '//trim(ncfilename), FATAL) + allocate(timeval(nrecords), ryr(nrecords), rmo(nrecords), rdy(nrecords)) + call fms2_io_read_data(fileobj, 'TIME', timeval) +!!! DEBUG CODE + if(DEBUG) then + if (mpp_pe() == 0) then + print *, 'JHC: nrecords = ', nrecords + print *, 'JHC: TIME = ', timeval + endif + endif + + ierr = 1 + do k = 1, nrecords + + Udate = get_cal_time (timeval(k), time_unit, 'julian') + call get_date(Udate,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) + ryr(k) = jhctod(1); rmo(k) = jhctod(2); rdy(k) = jhctod(3) + + if ( yr == ryr(k) .and. mo == rmo(k) .and. dy == rdy (k) ) ierr = 0 + if (ierr==0) exit + + enddo + + if(DEBUG) then + if (mpp_pe() == 0) then + print *, 'JHC: k =', k + print *, 'JHC: ryr(k) rmo(k) rdy(k)',ryr(k), rmo(k), rdy(k) + print *, 'JHC: yr mo dy ',yr, mo, dy + endif + endif + + if (ierr .ne. 0) call mpp_error('amip_interp_mod', & + 'Model time is out of range not in SST data: '//trim(ncfilename), FATAL) + endif ! if(file_exist(ncfilename)) + + + !---- read NETCDF data ---- + if ( .not. allocated(tempamip) ) & + & allocate (tempamip(mobs_sst,nobs_sst)) + + if (the_file_exists) then + call fms2_io_read_data(fileobj, 'SST', tempamip, unlim_dim_level=k) + call close_file(fileobj) + tempamip = tempamip + TFREEZE + +!!! DEBUG CODE + if(DEBUG) then + if (mpp_pe() == 0) then + print*, 'JHC: TFREEZE = ', real(TFREEZE, FMS_AMIP_INTERP_KIND_) + print*, lbound(sst) + print*, ubound(sst) + print*, lbound(tempamip) + print*, ubound(tempamip) + write(*,300) 'JHC: tempamip : ', tempamip(100,100), tempamip(200,200), tempamip(300,300) + endif + endif + + call horiz_interp ( Interp%Hintrp2, TEMPAMIP_, sst ) + call CLIP_DATA_ ('sst', sst) + + endif + + if(DEBUG) then + if (mpp_pe() == 400) then + write(*,300)'JHC: use_daily = T, daily SST: ', sst(1,1),sst(5,5),sst(10,10) + print *,'JHC: use_daily = T, daily SST: ', sst + endif + endif + +200 format(a35, 6(i5,1x)) +300 format(a35, 3(f7.3,2x)) + +endif +! end add by JHC + +! add by JHC: add on non-zero sea surface temperature perturbation (namelist option) +! This perturbation may be useful in accessing model sensitivities + + if ( do_sst_pert ) then + + if ( trim(sst_pert_type) == 'fixed' ) then + sst = sst + real(sst_pert, FMS_AMIP_INTERP_KIND_) + else if ( trim(sst_pert_type) == 'random' ) then + call random_seed() + + if(DEBUG) then + if (mpp_pe() == 0) then + print*, 'mobs = ', mobs + print*, 'nobs = ', nobs + print*, lbound(sst) + print*, ubound(sst) + endif + endif + + do i = 1, size(sst,1) + do j = 1, size(sst,2) + call random_number(pert) + sst (i,j) = sst (i,j) + real(sst_pert, FMS_AMIP_INTERP_KIND_)*((pert-0.5_lkind)*2) + end do + end do + endif + + endif +! end add by JHC + end subroutine GET_AMIP_SST_ + +!> AMIP interpolation for ice +subroutine GET_AMIP_ICE_ (Time, Interp, ice, err_msg) + type (time_type), intent(in) :: Time !< Time to interpolate + type (amip_interp_type), target, intent(inout) :: Interp !< Holds data for interpolation + real(FMS_AMIP_INTERP_KIND_), intent(out) :: ice(:,:) !< ice data + character(len=*), optional, intent(out) :: err_msg !< Holds error message string if present + + real(FMS_AMIP_INTERP_KIND_), dimension(mobs,nobs) :: sice, temp + + integer :: year1, year2, month1, month2 + real(FMS_AMIP_INTERP_KIND_) :: fmonth + type (date_type) :: Date1, Date2, Udate1, Udate2 + + type(time_type) :: Amip_Time + integer :: tod(3),dum(3) + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + if(present(err_msg)) err_msg = '' + if(.not.Interp%I_am_initialized) then + if(fms_error_handler('get_amip_ice','The amip_interp_type variable is not initialized',err_msg)) return + endif + +!----------------------------------------------------------------------- +!----- compute zonally symetric sst --------------- + + + if (any(amip_date>0)) then + + call get_date(Time,dum(1),dum(2),dum(3),tod(1),tod(2),tod(3)) + + Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3)) + + else + + Amip_Time = Time + + endif + + +if (use_zonal) then + call ZONAL_SST_ (Amip_Time, sice, temp) + call horiz_interp ( Interp%Hintrp, sice, ice ) +else + +!----------------------------------------------------------------------- +!---------- get new observed sea surface temperature ------------------- + +! ---- time interpolation for months ----- + + call time_interp (Amip_Time, fmonth, year1, year2, month1, month2) + +! ---- force climatology ---- + if (Interp%use_climo) then + year1=0; year2=0 + endif + if (Interp%use_annual) then + year1=0; year2=0 + month1=0; month2=0 + endif +! --------------------------- + + Date1 = date_type( year1, month1, 0 ) + Date2 = date_type( year2, month2, 0 ) + + unit = -1 +!----------------------------------------------------------------------- + + if (Date1 /= Interp%Date1) then +! ---- use Date2 for Date1 ---- + if (Date1 == Interp%Date2) then + Interp%Date1 = Interp%Date2 + Interp%DATA1_ = Interp%DATA2_ + else +!-- SJL ------------------------------------------------------------- +! Can NOT use ncep_sst to determine sea_ice For seasonal forecast +! Use climo sea ice for seasonal runs + if ( use_ncep_sst .and. use_ncep_ice ) then + where ( SST_NCEP_ <= (real(TFREEZE, FMS_AMIP_INTERP_KIND_)+real(tice_crit, FMS_AMIP_INTERP_KIND_)) ) + sice = 1._lkind + elsewhere + sice = 0._lkind + endwhere + else + call READ_RECORD_ ('ice', Date1, Udate1, sice) + endif +!-------------------------------------------------------------------- + call horiz_interp ( Interp%Hintrp, sice, Interp%DATA1_) + call CLIP_DATA_ ('ice', Interp%DATA1_) + Interp%Date1 = Date1 + endif + endif + +!----------------------------------------------------------------------- + + if (Date2 /= Interp%Date2) then + +!-- SJL ------------------------------------------------------------- + if ( use_ncep_sst .and. use_ncep_ice ) then + where ( SST_NCEP_ <= (real(TFREEZE, FMS_AMIP_INTERP_KIND_)+real(tice_crit, FMS_AMIP_INTERP_KIND_)) ) + sice = 1._lkind + elsewhere + sice = 0._lkind + endwhere + else + call READ_RECORD_ ('ice', Date2, Udate2, sice) + endif +!-------------------------------------------------------------------- + call horiz_interp ( Interp%Hintrp, sice, Interp%DATA2_) + call CLIP_DATA_ ('ice', Interp%DATA2_) + Interp%Date2 = Date2 + + endif + +!----------------------------------------------------------------------- +!---------- time interpolation (between months) ------------------------ +!----------------------------------------------------------------------- + + ice = Interp%DATA1_ + fmonth * (Interp%DATA2_ - Interp%DATA1_) + +endif + end subroutine GET_AMIP_ICE_ + + !> @return A newly created @ref amip_interp_type + function AMIP_INTERP_NEW_1D_ ( lon , lat , mask , use_climo, use_annual, & + interp_method ) result (Interp) + real(FMS_AMIP_INTERP_KIND_), intent(in), dimension(:) :: lon, lat + logical, intent(in), dimension(:,:) :: mask + character(len=*), intent(in), optional :: interp_method + logical, intent(in), optional :: use_climo, use_annual + + type (amip_interp_type) :: Interp + + if(.not.module_is_initialized) call amip_interp_init + + Interp%use_climo = .false. + if (present(use_climo)) Interp%use_climo = use_climo + Interp%use_annual = .false. + if (present(use_annual)) Interp%use_annual = use_annual + + if ( date_out_of_range == 'fail' .and. Interp%use_climo ) & + call error_mesg ('amip_interp_new_1d', 'use_climo mismatch', FATAL) + + if ( date_out_of_range == 'fail' .and. Interp%use_annual ) & + call error_mesg ('amip_interp_new_1d', 'use_annual(climo) mismatch', FATAL) + + Interp%Date1 = date_type( -99, -99, -99 ) + Interp%Date2 = date_type( -99, -99, -99 ) + +!----------------------------------------------------------------------- +! ---- initialization of horizontal interpolation ---- + + call horiz_interp_new ( Interp%Hintrp, LON_BND_, LAT_BND_, & + lon, lat, interp_method= interp_method ) + + allocate(Interp%DATA1_ (size(lon(:))-1,size(lat(:))-1)) + allocate(Interp%DATA2_ (size(lon(:))-1,size(lat(:))-1)) + + Interp%I_am_initialized = .true. + end function AMIP_INTERP_NEW_1D_ + + !> @return A newly created @ref amip_interp_type + function AMIP_INTERP_NEW_2D_ ( lon , lat , mask , use_climo, use_annual, & + interp_method ) result (Interp) + real(FMS_AMIP_INTERP_KIND_), intent(in), dimension(:,:) :: lon, lat + logical, intent(in), dimension(:,:) :: mask + character(len=*), intent(in), optional :: interp_method + logical, intent(in), optional :: use_climo, use_annual + + type (amip_interp_type) :: Interp + + if(.not.module_is_initialized) call amip_interp_init + + Interp%use_climo = .false. + if (present(use_climo)) Interp%use_climo = use_climo + Interp%use_annual = .false. + if (present(use_annual)) Interp%use_annual = use_annual + + if ( date_out_of_range == 'fail' .and. Interp%use_climo ) & + call error_mesg ('amip_interp_new_2d', 'use_climo mismatch', FATAL) + + if ( date_out_of_range == 'fail' .and. Interp%use_annual ) & + call error_mesg ('amip_interp_new_2d', 'use_annual(climo) mismatch', FATAL) + + Interp%Date1 = date_type( -99, -99, -99 ) + Interp%Date2 = date_type( -99, -99, -99 ) + +!----------------------------------------------------------------------- +! ---- initialization of horizontal interpolation ---- + + call horiz_interp_new ( Interp%Hintrp, LON_BND_, LAT_BND_, & + lon, lat, interp_method = interp_method) + + allocate(Interp%DATA1_ (size(lon,1),size(lat,2))) + allocate(Interp%DATA2_ (size(lon,1),size(lat,2))) + + Interp%I_am_initialized = .true. + end function AMIP_INTERP_NEW_2D_ + +! add by JHC + subroutine SET_SST_GRID_EDGES_DAILY_ (mobs_sst, nobs_sst) + integer :: i, j, mobs_sst, nobs_sst + real(FMS_AMIP_INTERP_KIND_) :: hpie, dlon, dlat, wb, sb + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + if(allocated(lon_bnd)) deallocate(lon_bnd) + if(allocated(lat_bnd)) deallocate(lat_bnd) + + allocate(lon_bnd(mobs_sst+1)) + allocate(lat_bnd(nobs_sst+1)) + +! ---- compute grid edges (do only once) ----- + + hpie = pi / 2._r8_kind + dlon = 4._r8_kind*hpie/real(mobs_sst, r8_kind) + wb = 0.0_r8_kind + + lon_bnd(1) = wb + do i = 2, mobs_sst+1 + lon_bnd(i) = wb + dlon * real(i-1, r8_kind) + enddo + lon_bnd(mobs_sst+1) = lon_bnd(1) + 4._r8_kind*hpie + + dlat = 2._r8_kind*hpie/real(nobs_sst, r8_kind) + sb = -hpie + + lat_bnd(1) = sb + lat_bnd(nobs_sst+1) = hpie + do j = 2, nobs_sst + lat_bnd(j) = sb + dlat * real(j-1, r8_kind) + enddo + end subroutine SET_SST_GRID_EDGES_DAILY_ +! end add by JHC + + subroutine A2A_BILINEAR_ (nx, ny, dat1, n1, n2, dat2) + integer, intent(in) :: nx, ny + integer, intent(in) :: n1, n2 + real(FMS_AMIP_INTERP_KIND_), intent(in) :: dat1(nx,ny) + real(FMS_AMIP_INTERP_KIND_), intent(out) :: dat2(n1,n2) !> output interpolated data + +! local: + real(FMS_AMIP_INTERP_KIND_) :: lon1(nx), lat1(ny) + real(FMS_AMIP_INTERP_KIND_) :: lon2(n1), lat2(n2) + real(FMS_AMIP_INTERP_KIND_) :: dx1, dy1, dx2, dy2 + real(FMS_AMIP_INTERP_KIND_) :: xc, yc + real(FMS_AMIP_INTERP_KIND_) :: a1, b1, c1, c2, c3, c4 + integer :: i1, i2, jc, i0, j0, it, jt + integer :: i, j + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + +!----------------------------------------------------------- +! * Interpolate from "FMS" 1x1 SST data grid to a finer grid +! lon: 0.5, 1.5, ..., 359.5 +! lat: -89.5, -88.5, ... , 88.5, 89.5 +!----------------------------------------------------------- + + dx1 = 360._lkind/real(nx, FMS_AMIP_INTERP_KIND_) !> INput Grid + dy1 = 180._lkind/real(ny, FMS_AMIP_INTERP_KIND_) !> INput Grid + + do i=1,nx + lon1(i) = 0.5_lkind*dx1 + real(i-1, FMS_AMIP_INTERP_KIND_)*dx1 + enddo + do j=1,ny + lat1(j) = -90._lkind + 0.5_lkind*dy1 + real(j-1, FMS_AMIP_INTERP_KIND_)*dy1 + enddo + + dx2 = 360._lkind/real(n1, FMS_AMIP_INTERP_KIND_) !> OutPut Grid: + dy2 = 180._lkind/real(n2, FMS_AMIP_INTERP_KIND_) !> OutPut Grid: + + do i=1,n1 + lon2(i) = 0.5_lkind*dx2 + real(i-1, FMS_AMIP_INTERP_KIND_)*dx2 + enddo + do j=1,n2 + lat2(j) = -90._lkind + 0.5_lkind*dy2 + real(j-1, FMS_AMIP_INTERP_KIND_)*dy2 + enddo + + jt = 1 + do 5000 j=1,n2 + + yc = lat2(j) + if ( yclat1(ny) ) then + jc = ny-1 + b1 = 1._lkind + else + do j0=jt,ny-1 + if ( yc>=lat1(j0) .and. yc<=lat1(j0+1) ) then + jc = j0 + jt = j0 + b1 = (yc-lat1(jc)) / dy1 + go to 222 + endif + enddo + endif +222 continue + + it = 1 + do i=1,n1 + xc = lon2(i) + if ( xc>lon1(nx) ) then + i1 = nx; i2 = 1 + a1 = (xc-lon1(nx)) / dx1 + elseif ( xc=lon1(i0) .and. xc<=lon1(i0+1) ) then + i1 = i0; i2 = i0+1 + it = i0 + a1 = (xc-lon1(i1)) / dx1 + go to 111 + endif + enddo + endif +111 continue + +! Debug code: + if ( a1<-0.001_lkind .or. a1>1.001_lkind .or. b1<-0.001_lkind .or. b1>1.001_lkind ) then + write(*,*) i,j,a1, b1 + call mpp_error(FATAL,'a2a bilinear interpolation') + endif + + c1 = (1._lkind-a1) * (1._lkind-b1) + c2 = a1 * (1._lkind-b1) + c3 = a1 * b1 + c4 = (1._lkind-a1) * b1 + +! Bilinear interpolation: + dat2(i,j) = c1*dat1(i1,jc) + c2*dat1(i2,jc) + c3*dat1(i2,jc+1) + c4*dat1(i1,jc+1) + + enddo !i-loop + +5000 continue ! j-loop + end subroutine A2A_BILINEAR_ + + subroutine READ_RECORD_ (type, Date, Adate, dat) + character(len=*), intent(in) :: type + type (date_type), intent(in) :: Date + type (date_type), intent(inout) :: Adate + real(FMS_AMIP_INTERP_KIND_), intent(out) :: dat(mobs,nobs) + real(FMS_AMIP_INTERP_KIND_) :: tmp_dat(360,180) + + integer(I2_KIND) :: idat(mobs,nobs) + integer :: nrecords, yr, mo, dy, ierr, k + integer, dimension(:), allocatable :: ryr, rmo, rdy + character(len=maxc) :: ncfilename, ncfieldname + type(FmsNetcdfFile_t), pointer :: fileobj + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + !---- set file and field name for NETCDF data sets ---- + + ncfieldname = 'sst' + if(type(1:3) == 'sst') then + ncfilename = trim(file_name_sst) + fileobj => fileobj_sst + else if(type(1:3) == 'ice') then + ncfilename = trim(file_name_ice) + fileobj => fileobj_ice + if (lowercase(trim(data_set)) == 'amip2' .or. & + lowercase(trim(data_set)) == 'hurrell' .or. & + lowercase(trim(data_set)) == 'daily') ncfieldname = 'ice' ! modified by JHC + endif + + dy = 0 ! only processing monthly data + + if (verbose > 2 .and. mpp_pe() == 0) & + print *, 'looking for date = ', Date + + ! This code can handle amip1, reynolds, or reyoi type SST data files in netCDF format + if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & + 'Reading NetCDF formatted input data file: '//trim(ncfilename), NOTE) + + call fms2_io_read_data (fileobj, 'nrecords', nrecords) + if (nrecords < 1) call mpp_error('amip_interp_mod', & + 'Invalid number of SST records in SST datafile: '//trim(ncfilename), FATAL) + allocate(ryr(nrecords), rmo(nrecords), rdy(nrecords)) + call fms2_io_read_data(fileobj, 'yr', ryr) + call fms2_io_read_data(fileobj, 'mo', rmo) + call fms2_io_read_data(fileobj, 'dy', rdy) + + ierr = 1 + do k = 1, nrecords + yr = ryr(k); mo = rmo(k) + Adate = date_type( yr, mo, 0) + Curr_date = Adate + if (verbose > 2 .and. mpp_pe() == 0) & + print *, '....... checking ', Adate + if (Date == Adate) ierr = 0 + if (yr == 0 .and. mo == Date%month) ierr = 0 + if (ierr == 0) exit + enddo + if (ierr .ne. 0) call mpp_error('amip_interp_mod', & + 'Model time is out of range not in SST data: '//trim(ncfilename), FATAL) + deallocate(ryr, rmo, rdy) + !PRINT *, 'New SST data: ', k, yr, mo, dy, Date%year, Date%month, Date%day, ryr(1), rmo(1) + + !---- check if climatological data should be used ---- + + if (yr == 0 .or. mo == 0) then + ierr = 0 + if (date_out_of_range == 'fail' ) ierr = 1 + if (date_out_of_range == 'initclimo' .and. & + Date > Date_end ) ierr = 1 + if (ierr /= 0) call error_mesg & + ('read_record in amip_interp_mod', & + 'climo data read when NO climo data requested', FATAL) + endif + + !---- read NETCDF data ---- + + if ( interp_oi_sst ) then + call fms2_io_read_data(fileobj, ncfieldname, tmp_dat, unlim_dim_level=k) +! interpolate tmp_dat(360, 180) ---> dat(mobs,nobs) (to enable SST anom computation) + if ( mobs/=360 .or. nobs/=180 ) then + call A2A_BILINEAR_ (360, 180, tmp_dat, mobs, nobs, dat) + else + dat(:,:) = tmp_dat(:,:) + endif + else + call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k) + endif + !TODO This assumes that the data is "packed" (has the scale_factor and add_offset attributes) + ! in fms2_io_read_data the data is unpacked (data_in_file*scale_factor + add_offset) + ! the line below "packs" the data again. This is needed for reproducibility + idat = nint(dat*100._lkind, I2_KIND) + + !---- unpacking of data ---- + + if (type(1:3) == 'ice') then + !---- create fractional [0,1] ice mask + if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then + where ( idat <= ice_crit ) + dat = 1._lkind + elsewhere + dat = 0._lkind + endwhere + else + dat = dat*0.01_lkind + endif + else if (type(1:3) == 'sst') then + !---- unpack sst ---- + if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then + dat = real(idat, FMS_AMIP_INTERP_KIND_)*0.01_lkind + real(TFREEZE, FMS_AMIP_INTERP_KIND_) + endif + endif + + return + end subroutine READ_RECORD_ + + subroutine CLIP_DATA_ (type, dat) + character(len=*), intent(in) :: type + real(FMS_AMIP_INTERP_KIND_), intent(inout) :: dat(:,:) + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + + if (type(1:3) == 'ice') then + dat = min(max(dat,0.0_lkind), 1.0_lkind) + else if (type(1:3) == 'sst') then + dat = max(real(tice_crit_k, FMS_AMIP_INTERP_KIND_),dat) + endif + end subroutine CLIP_DATA_ + +subroutine ZONAL_SST_ (Time, ice, sst) + type (time_type), intent(in) :: Time + real(FMS_AMIP_INTERP_KIND_), intent(out) :: ice(mobs,nobs), sst(mobs,nobs) + real(FMS_AMIP_INTERP_KIND_) :: tpi, fdate, eps, ph, sph, sph2, ts + integer :: j + integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ + +! namelist needed +! +! teq = sst at equator +! tdif = equator to pole sst difference +! tann = amplitude of annual cycle +! tlag = offset for time of year (for annual cycle) +! + + tpi = 2.0_lkind*real(pi, FMS_AMIP_INTERP_KIND_) + + fdate = fraction_of_year (Time) + + eps = sin( tpi*(fdate-real(tlag, FMS_AMIP_INTERP_KIND_)) ) * real(tann, FMS_AMIP_INTERP_KIND_) + + do j = 1, nobs + + ph = 0.5_lkind * real(lat_bnd(j)+lat_bnd(j+1), FMS_AMIP_INTERP_KIND_) + sph = sin(ph) + sph2 = sph*sph + + ts = real(teq, FMS_AMIP_INTERP_KIND_) - real(tdif, FMS_AMIP_INTERP_KIND_)*sph2 - eps*sph + + sst(:,j) = ts + + enddo + + where ( sst < real(tice_crit_k, FMS_AMIP_INTERP_KIND_) ) + ice = 1.0_lkind + sst = real(tice_crit_k, FMS_AMIP_INTERP_KIND_) + elsewhere + ice = 0.0_lkind + endwhere +end subroutine ZONAL_SST_ diff --git a/amip_interp/include/amip_interp_r4.fh b/amip_interp/include/amip_interp_r4.fh new file mode 100644 index 0000000000..ab4ddd3257 --- /dev/null +++ b/amip_interp/include/amip_interp_r4.fh @@ -0,0 +1,58 @@ +#undef FMS_AMIP_INTERP_KIND_ +#undef SST_NCEP_ +#undef SST_ANOM_ +#undef LON_BND_ +#undef LAT_BND_ +#undef TEMPAMIP_ +#undef DATA1_ +#undef DATA2_ + +#undef GET_AMIP_SST_ +#undef GET_AMIP_ICE_ +#undef AMIP_INTERP_NEW_1D_ +#undef AMIP_INTERP_NEW_2D_ +#undef SET_SST_GRID_EDGES_DAILY_ +#undef A2A_BILINEAR_ +#undef READ_RECORD_ +#undef CLIP_DATA_ +#undef ZONAL_SST_ + +#define FMS_AMIP_INTERP_KIND_ r4_kind +#define SST_NCEP_ real(sst_ncep, r4_kind) +#define SST_ANOM_ real(sst_anom, r4_kind) +#define LON_BND_ real(lon_bnd, r4_kind) +#define LAT_BND_ real(lat_bnd, r4_kind) +#define TEMPAMIP_ real(tempamip, r4_kind) +#define DATA1_ data1_r4 +#define DATA2_ data2_r4 + +#define GET_AMIP_SST_ get_amip_sst_r4 +#define GET_AMIP_ICE_ get_amip_ice_r4 +#define AMIP_INTERP_NEW_1D_ amip_interp_new_1d_r4 +#define AMIP_INTERP_NEW_2D_ amip_interp_new_2d_r4 +#define SET_SST_GRID_EDGES_DAILY_ set_sst_grid_edges_daily_r4 +#define A2A_BILINEAR_ a2a_bilinear_r4 +#define READ_RECORD_ read_record_r4 +#define CLIP_DATA_ clip_data_r4 +#define ZONAL_SST_ zonal_sst_r4 + +#include "amip_interp.inc" + +#undef FMS_AMIP_INTERP_KIND_ +#undef SST_NCEP_ +#undef SST_ANOM_ +#undef LON_BND_ +#undef LAT_BND_ +#undef TEMPAMIP_ +#undef DATA1_ +#undef DATA2_ + +#undef GET_AMIP_SST_ +#undef GET_AMIP_ICE_ +#undef AMIP_INTERP_NEW_1D_ +#undef AMIP_INTERP_NEW_2D_ +#undef SET_SST_GRID_EDGES_DAILY_ +#undef A2A_BILINEAR_ +#undef READ_RECORD_ +#undef CLIP_DATA_ +#undef ZONAL_SST_ diff --git a/amip_interp/include/amip_interp_r8.fh b/amip_interp/include/amip_interp_r8.fh new file mode 100644 index 0000000000..b132f64bd5 --- /dev/null +++ b/amip_interp/include/amip_interp_r8.fh @@ -0,0 +1,58 @@ +#undef FMS_AMIP_INTERP_KIND_ +#undef SST_NCEP_ +#undef SST_ANOM_ +#undef LON_BND_ +#undef LAT_BND_ +#undef TEMPAMIP_ +#undef DATA1_ +#undef DATA2_ + +#undef GET_AMIP_SST_ +#undef GET_AMIP_ICE_ +#undef AMIP_INTERP_NEW_1D_ +#undef AMIP_INTERP_NEW_2D_ +#undef SET_SST_GRID_EDGES_DAILY_ +#undef A2A_BILINEAR_ +#undef READ_RECORD_ +#undef CLIP_DATA_ +#undef ZONAL_SST_ + +#define FMS_AMIP_INTERP_KIND_ r8_kind +#define SST_NCEP_ sst_ncep +#define SST_ANOM_ sst_anom +#define LON_BND_ lon_bnd +#define LAT_BND_ lat_bnd +#define TEMPAMIP_ tempamip +#define DATA1_ data1_r8 +#define DATA2_ data2_r8 + +#define GET_AMIP_SST_ get_amip_sst_r8 +#define GET_AMIP_ICE_ get_amip_ice_r8 +#define AMIP_INTERP_NEW_1D_ amip_interp_new_1d_r8 +#define AMIP_INTERP_NEW_2D_ amip_interp_new_2d_r8 +#define SET_SST_GRID_EDGES_DAILY_ set_sst_grid_edges_daily_r8 +#define A2A_BILINEAR_ a2a_bilinear_r8 +#define READ_RECORD_ read_record_r8 +#define CLIP_DATA_ clip_data_r8 +#define ZONAL_SST_ zonal_sst_r8 + +#include "amip_interp.inc" + +#undef FMS_AMIP_INTERP_KIND_ +#undef SST_NCEP_ +#undef SST_ANOM_ +#undef LON_BND_ +#undef LAT_BND_ +#undef TEMPAMIP_ +#undef DATA1_ +#undef DATA2_ + +#undef GET_AMIP_SST_ +#undef GET_AMIP_ICE_ +#undef AMIP_INTERP_NEW_1D_ +#undef AMIP_INTERP_NEW_2D_ +#undef SET_SST_GRID_EDGES_DAILY_ +#undef A2A_BILINEAR_ +#undef READ_RECORD_ +#undef CLIP_DATA_ +#undef ZONAL_SST_ diff --git a/column_diagnostics/Makefile.am b/column_diagnostics/Makefile.am index af368bc14f..c205abbb4d 100644 --- a/column_diagnostics/Makefile.am +++ b/column_diagnostics/Makefile.am @@ -23,14 +23,22 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/column_diagnostics/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. noinst_LTLIBRARIES = libcolumn_diagnostics.la # The convenience library depends on its source. -libcolumn_diagnostics_la_SOURCES = column_diagnostics.F90 +libcolumn_diagnostics_la_SOURCES = column_diagnostics.F90 \ +include/column_diagnostics.inc \ +include/column_diagnostics_r4.fh \ +include/column_diagnostics_r8.fh + +column_diagnostics.$(FC_MOD_EXT):\ +include/column_diagnostics.inc \ +include/column_diagnostics_r4.fh \ +include/column_diagnostics_r8.fh BUILT_SOURCES = column_diagnostics_mod.$(FC_MODEXT) nodist_include_HEADERS = column_diagnostics_mod.$(FC_MODEXT) diff --git a/column_diagnostics/column_diagnostics.F90 b/column_diagnostics/column_diagnostics.F90 index 2254f32b6a..b75ffd3698 100644 --- a/column_diagnostics/column_diagnostics.F90 +++ b/column_diagnostics/column_diagnostics.F90 @@ -32,7 +32,7 @@ module column_diagnostics_mod get_date, time_type use constants_mod, only: constants_init, PI, RADIAN use mpp_mod, only: input_nml_file - +use platform_mod, only: r4_kind, r8_kind !------------------------------------------------------------------- implicit none @@ -64,23 +64,34 @@ module column_diagnostics_mod column_diagnostics_header, & close_column_diagnostics_units + +interface initialize_diagnostic_columns + module procedure initialize_diagnostic_columns_r4 + module procedure initialize_diagnostic_columns_r8 +end interface initialize_diagnostic_columns + +interface column_diagnostics_header + module procedure column_diagnostics_header_r4 + module procedure column_diagnostics_header_r8 +end interface column_diagnostics_header + !private !-------------------------------------------------------------------- !---- namelist ----- -real :: crit_xdistance = 4.0 !< model grid points must be within crit_xdistance in +real(kind=r8_kind) :: crit_xdistance = 4.0_r8_kind !< model grid points must be within crit_xdistance in !! longitude of the requested diagnostics point !! coordinates in order to be flagged as the desired !! point !! [ degrees ] -real :: crit_ydistance = 4.0 !< model grid points must be within crit_ydistance in +real(kind=r8_kind) :: crit_ydistance = 4.0_r8_kind !< model grid points must be within crit_ydistance in !! latitude of the requested diagnostics point !! coordinates in order to be flagged as the desired !! point !! [ degrees ] -namelist / column_diagnostics_nml / & +namelist / column_diagnostics_nml / & crit_xdistance, & crit_ydistance @@ -163,387 +174,6 @@ subroutine column_diagnostics_init end subroutine column_diagnostics_init - -!#################################################################### - -!> @brief initialize_diagnostic_columns returns the (i, j, lat, lon) coord- -!! inates of any diagnostic columns that are located on the current -!! processor. -subroutine initialize_diagnostic_columns & - (module, num_diag_pts_latlon, num_diag_pts_ij, & - global_i , global_j , global_lat_latlon, & - global_lon_latlon, lonb_in, latb_in, & - do_column_diagnostics, & - diag_lon, diag_lat, diag_i, diag_j, diag_units) - -!--------------------------------------------------------------------- -! initialize_diagnostic_columns returns the (i, j, lat, lon) coord- -! inates of any diagnostic columns that are located on the current -! processor. -!---------------------------------------------------------------------- - -!--------------------------------------------------------------------- -character(len=*), intent(in) :: module !< module calling this subroutine -integer, intent(in) :: num_diag_pts_latlon !< number of diagnostic columns specified - !! by lat-lon coordinates -integer, intent(in) :: num_diag_pts_ij !< number of diagnostic columns specified - !! by global (i,j) coordinates -integer, dimension(:), intent(in) :: global_i !< specified global i coordinates -integer, dimension(:), intent(in) :: global_j !< specified global j coordinates -real , dimension(:), intent(in) :: global_lat_latlon !< specified global lat coordinates -real , dimension(:), intent(in) :: global_lon_latlon !< specified global lon coordinates -real, dimension(:,:), intent(in) :: lonb_in, latb_in -logical, dimension(:,:), intent(out) :: do_column_diagnostics !< is a diagnostic column in this jrow ? -integer, dimension(:), intent(inout) :: diag_i !< processor i indices of diagnstic columns -integer, dimension(:), intent(inout) :: diag_j !< processor j indices of diagnstic columns -real , dimension(:), intent(out) :: diag_lat !< latitudes of diagnostic columns [ degrees ] -real , dimension(:), intent(out) :: diag_lon !< longitudes of diagnostic columns [ degrees ] -integer, dimension(:), intent(out) :: diag_units !< unit number for each diagnostic column -!--------------------------------------------------------------------- - -!--------------------------------------------------------------------- -! intent(in) variables: -! -! module module calling this subroutine -! num_diag_pts_latlon number of diagnostic columns specified -! by lat-lon coordinates -! num_diag_pts_ij number of diagnostic columns specified -! by global (i,j) coordinates -! global_i specified global i coordinates -! global_j specified global j coordinates -! global_lat_latlon specified global lat coordinates -! global_lon_latlon specified global lon coordinates -! -! intent(out) variables: -! -! do_column_diagnostics is a diagnostic column in this jrow ? -! diag_i processor i indices of diagnstic columns -! diag_j processor j indices of diagnstic columns -! diag_lat latitudes of diagnostic columns -! [ degrees ] -! diag_lon longitudes of diagnostic columns -! [ degrees ] -! diag_units unit number for each diagnostic column -! -!--------------------------------------------------------------------- - -!-------------------------------------------------------------------- -! local variables: - - real, dimension(size(diag_i,1)) :: global_lat !< latitudes for all diagnostic columns [ degrees ] - real, dimension(size(diag_i,1)) :: global_lon !< longitudes for all diagnostic columns [ degrees ] - real, dimension(size(latb_in,1)-1, size(latb_in,2)-1) :: & - distance, distance_x, distance_y, & - distance_x2, distance2 - real, dimension(size(latb_in,1), size(latb_in,2)) :: latb_deg - real, dimension(size(lonb_in,1), size(lonb_in,2)) :: lonb_deg - real :: dellat, dellon - real :: latb_max, latb_min, lonb_max, lonb_min - - integer :: num_diag_pts !< total number of diagnostic columns - integer :: i !< do loop indices - integer :: j !< do loop indices - integer :: nn !< do loop indices - real :: ref_lat - real :: current_distance - character(len=8) :: char !< character string for diaganostic column index - character(len=32) :: filename !< filename for output file for diagnostic column - logical :: allow_ij_input - logical :: open_file - integer :: io -!-------------------------------------------------------------------- -! local variables: -! -! global_lat latitudes for all diagnostic columns [ degrees ] -! global_lon longitudes for all diagnostic columns -! [ degrees ] -! num_diag_pts total number of diagnostic columns -! i, j, nn do loop indices -! char character string for diaganostic column index -! filename filename for output file for diagnostic column -! -!--------------------------------------------------------------------- - - if (.not. module_is_initialized) call column_diagnostics_init - -!-------------------------------------------------------------------- -! save the input lat and lon fields. define the delta of latitude -! and longitude. -!-------------------------------------------------------------------- - latb_deg = latb_in*RADIAN - lonb_deg = lonb_in*RADIAN - dellat = latb_in(1,2) - latb_in(1,1) - dellon = lonb_in(2,1) - lonb_in(1,1) - latb_max = MAXVAL (latb_deg(:,:)) - latb_min = MINVAL (latb_deg(:,:)) - lonb_max = MAXVAL (lonb_deg(:,:)) - lonb_min = MINVAL (lonb_deg(:,:)) - if (lonb_min < 10.0 .or. lonb_max > 350.) then - lonb_min = 0. - lonb_max = 360.0 - endif - - allow_ij_input = .true. - ref_lat = latb_in(1,1) - do i =2,size(latb_in,1) - if (latb_in(i,1) /= ref_lat) then - allow_ij_input = .false. - exit - endif - end do - - if ( .not. allow_ij_input .and. num_diag_pts_ij /= 0) then - call error_mesg ('column_diagnostics_mod', & - 'cannot specify column diagnostics column with (i,j) & - &coordinates when using cubed sphere -- must specify & - & lat/lon coordinates', FATAL) - endif - -!---------------------------------------------------------------------- -! initialize column_diagnostics flag and diag unit numbers. define -! total number of diagnostic columns. -!---------------------------------------------------------------------- - do_column_diagnostics = .false. - diag_units(:) = -1 - diag_i(:) = -99 - diag_j(:) = -99 - diag_lat(:) = -999. - diag_lon(:) = -999. - num_diag_pts = size(diag_i(:)) - -!-------------------------------------------------------------------- -! define an array of lat-lon values for all diagnostic columns. -!-------------------------------------------------------------------- - do nn = 1, num_diag_pts_latlon - global_lat(nn) = global_lat_latlon(nn) - global_lon(nn) = global_lon_latlon(nn) - end do - - do nn = 1, num_diag_pts_ij - global_lat(nn+num_diag_pts_latlon) = & - ((-0.5*acos(-1.0) + 0.5*dellat) + & - (global_j (nn)-1) *dellat)*RADIAN - global_lon(nn+num_diag_pts_latlon) = (0.5*dellon + & - (global_i (nn)-1)*dellon)*RADIAN - end do - -!---------------------------------------------------------------------- -! loop over all diagnostic points to check for their presence on -! this processor. -!---------------------------------------------------------------------- - do nn=1,num_diag_pts - open_file = .false. - -!---------------------------------------------------------------------- -! verify that the values of lat and lon are valid. -!---------------------------------------------------------------------- - if (global_lon(nn) >= 0. .and. global_lon(nn) <= 360.0) then - else - call error_mesg ('column_diagnostics_mod', & - ' invalid longitude', FATAL) - endif - if (global_lat(nn) >= -90.0 .and. global_lat(nn) <= 90.0) then - else - call error_mesg ('column_diagnostics_mod', & - ' invalid latitude', FATAL) - endif - -!-------------------------------------------------------------------- -! if the desired diagnostics column is within the current -! processor's domain, define the total and coordinate distances from -! each of the processor's grid points to the diagnostics point. -!-------------------------------------------------------------------- - - if (global_lat(nn) .ge. latb_min .and. & - global_lat(nn) .le. latb_max) then - if (global_lon(nn) .ge. lonb_min .and.& - global_lon(nn) .le. lonb_max) then - do j=1,size(latb_deg,2) - 1 - do i=1,size(lonb_deg,1) - 1 - distance_y(i,j) = ABS(global_lat(nn) - latb_deg(i,j)) - distance_x(i,j) = ABS(global_lon(nn) - lonb_deg(i,j)) - distance_x2(i,j) = ABS((global_lon(nn)-360.) - & - lonb_deg(i,j)) - distance(i,j) = (global_lat(nn) - latb_deg(i,j))**2 + & - (global_lon(nn) - lonb_deg(i,j))**2 - distance2(i,j) = (global_lat(nn) - latb_deg(i,j))**2 + & - ((global_lon(nn)-360.) - & - lonb_deg(i,j))**2 - end do - end do - -!-------------------------------------------------------------------- -! find the grid point on the processor that is within the specified -! critical distance and also closest to the requested diagnostics -! column. save the (i,j) coordinates and (lon,lat) of this model -! grid point. set a flag indicating that a disgnostics file should -! be opened on this processor for this diagnostic point. -!-------------------------------------------------------------------- - current_distance = distance(1,1) - do j=1,size(latb_deg,2) - 1 - do i=1,size(lonb_deg,1) - 1 - if (distance_x(i,j) <= crit_xdistance .and. & - distance_y(i,j) <= crit_ydistance ) then - if (distance(i,j) < current_distance) then - current_distance = distance(i,j) - do_column_diagnostics(i,j) = .true. - diag_j(nn) = j - diag_i(nn) = i - diag_lon(nn) = lonb_deg(i,j) - diag_lat(nn) = latb_deg(i,j) - open_file = .true. - endif - endif - -!--------------------------------------------------------------------- -! check needed because of the 0.0 / 360.0 longitude periodicity. -!--------------------------------------------------------------------- - if (distance_x2(i,j) <= crit_xdistance .and. & - distance_y(i,j) <= crit_ydistance ) then - if (distance2(i,j) < current_distance) then - current_distance = distance2(i,j) - do_column_diagnostics(i,j) = .true. - diag_j(nn) = j - diag_i(nn) = i - diag_lon(nn) = lonb_deg(i,j) - diag_lat(nn) = latb_deg(i,j) - open_file = .true. - endif - endif - end do - end do - -!-------------------------------------------------------------------- -! if the point has been found on this processor, open a diagnostics -! file. -!-------------------------------------------------------------------- - if (open_file) then - write (char, '(i2)') nn - filename = trim(module) // '_point' // & - trim(adjustl(char)) // '.out' - if(mpp_npes() > 10000) then - write( filename,'(a,i6.6)' )trim(filename)//'.', mpp_pe()-mpp_root_pe() - else - write( filename,'(a,i4.4)' )trim(filename)//'.', mpp_pe()-mpp_root_pe() - endif - open(newunit=diag_units(nn), file=trim(filename), action='WRITE', position='rewind', iostat=io) - if(io/=0) call error_mesg ('column_diagnostics_mod', 'Error in opening file '//trim(filename), FATAL) - endif ! (open_file) - endif - endif - end do - -!--------------------------------------------------------------------- - - -end subroutine initialize_diagnostic_columns - - - - -!#################################################################### -!> @brief column_diagnostics_header writes out information concerning -!! time and location of following data into the column_diagnostics -!! output file. -subroutine column_diagnostics_header & - (module, diag_unit, Time, nn, diag_lon, & - diag_lat, diag_i, diag_j) - -!-------------------------------------------------------------------- -! column_diagnostics_header writes out information concerning -! time and location of following data into the column_diagnostics -! output file. -!-------------------------------------------------------------------- - -!-------------------------------------------------------------------- -character(len=*), intent(in) :: module !< module name calling this subroutine -type(time_type), intent(in) :: Time !< current model time [ time_type ] -integer, intent(in) :: diag_unit !< unit number for column_diagnostics output -integer, intent(in) :: nn !< index of diagnostic column currently active -real, dimension(:), intent(in) :: diag_lon !< longitude of current diagnostic column [ degrees ] -real, dimension(:), intent(in) :: diag_lat !< latitude of current diagnostic column [ degrees ] -integer, dimension(:), intent(in) :: diag_i !< i coordinate of current diagnostic column -integer, dimension(:), intent(in) :: diag_j !< j coordinate of current diagnostic column - -!-------------------------------------------------------------------- -! intent(in) variables -! -! module module name calling this subroutine -! Time current model time [ time_type ] -! diag_unit unit number for column_diagnostics output -! nn index of diagnostic column currently active -! diag_lon longitude of current diagnostic column [ degrees ] -! diag_lat latitude of current diagnostic column [ degrees ] -! diag_i i coordinate of current diagnostic column -! diag_j j coordinate of current diagnostic column -! -!--------------------------------------------------------------------- - -!-------------------------------------------------------------------- -! local variables: - - integer :: year !< integers defining the current time - integer :: month !< integers defining the current time - integer :: day !< integers defining the current time - integer :: hour !< integers defining the current time - integer :: minute !< integers defining the current time - integer :: second !< integers defining the current time - character(len=9) :: mon !< character string for the current month - character(len=64) :: header !< title for the output - -!-------------------------------------------------------------------- -! local variables: -! -! year, month, day, hour, minute, seconds -! integers defining the current time -! mon character string for the current month -! header title for the output -! -!-------------------------------------------------------------------- - - if (.not. module_is_initialized) call column_diagnostics_init - -!-------------------------------------------------------------------- -! convert the time type to a date and time for printing. convert -! month to a character string. -!-------------------------------------------------------------------- - call get_date (Time, year, month, day, hour, minute, second) - mon = month_name(month) - -!--------------------------------------------------------------------- -! write timestamp and column location information to the diagnostic -! columns output unit. -!--------------------------------------------------------------------- - write (diag_unit,'(a)') ' ' - write (diag_unit,'(a)') ' ' - write (diag_unit,'(a)') & - '======================================================' - write (diag_unit,'(a)') ' ' - header = ' PRINTING ' // module // ' DIAGNOSTICS' - write (diag_unit,'(a)') header - write (diag_unit,'(a)') ' ' - write (diag_unit,'(a, i6,2x, a,i4,i4,i4,i4)') ' time stamp:', & - year, trim(mon), day, & - hour, minute, second - write (diag_unit,'(a, i4)') & - ' DIAGNOSTIC POINT COORDINATES, point #', nn - write (diag_unit,'(a)') ' ' - write (diag_unit,'(a,f8.3,a,f8.3)') ' longitude = ', & - diag_lon(nn), ' latitude = ', diag_lat(nn) - write (diag_unit,'(a, i6, a,i6,a,i6)') & - ' on processor # ', mpp_pe(), & - ' : processor i =', diag_i(nn), & - ' , processor j =', diag_j(nn) - write (diag_unit,'(a)') ' ' - -!--------------------------------------------------------------------- - - - -end subroutine column_diagnostics_header - - - !###################################################################### !> @brief close_column_diagnostics_units closes any open column_diagnostics !! files associated with the calling module. @@ -588,7 +218,8 @@ end subroutine close_column_diagnostics_units !##################################################################### - +#include "column_diagnostics_r4.fh" +#include "column_diagnostics_r8.fh" end module column_diagnostics_mod diff --git a/column_diagnostics/include/column_diagnostics.inc b/column_diagnostics/include/column_diagnostics.inc new file mode 100644 index 0000000000..c2e18f2a7d --- /dev/null +++ b/column_diagnostics/include/column_diagnostics.inc @@ -0,0 +1,397 @@ +!*********************************************************************** +!* 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 initialize_diagnostic_columns returns the (i, j, lat, lon) coord- +!! inates of any diagnostic columns that are located on the current +!! processor. +subroutine INITIALIZE_DIAGNOSTIC_COLUMNS_ & + (module, num_diag_pts_latlon, num_diag_pts_ij, & + global_i , global_j , global_lat_latlon, & + global_lon_latlon, lonb_in, latb_in, & + do_column_diagnostics, & + diag_lon, diag_lat, diag_i, diag_j, diag_units) + +!--------------------------------------------------------------------- +! initialize_diagnostic_columns returns the (i, j, lat, lon) coord- +! inates of any diagnostic columns that are located on the current +! processor. +!---------------------------------------------------------------------- + +!--------------------------------------------------------------------- +character(len=*), intent(in) :: module !< module calling this subroutine +integer, intent(in) :: num_diag_pts_latlon !< number of diagnostic columns specified + !! by lat-lon coordinates +integer, intent(in) :: num_diag_pts_ij !< number of diagnostic columns specified + !! by global (i,j) coordinates +integer, dimension(:), intent(in) :: global_i !< specified global i coordinates +integer, dimension(:), intent(in) :: global_j !< specified global j coordinates +real(FMS_CD_KIND_), dimension(:), intent(in) :: global_lat_latlon !< specified global lat coordinates +real(FMS_CD_KIND_), dimension(:), intent(in) :: global_lon_latlon !< specified global lon coordinates +real(FMS_CD_KIND_), dimension(:,:), intent(in) :: lonb_in, latb_in +logical, dimension(:,:), intent(out) :: do_column_diagnostics !< is a diagnostic column in this jrow ? +integer, dimension(:), intent(inout) :: diag_i !< processor i indices of diagnstic columns +integer, dimension(:), intent(inout) :: diag_j !< processor j indices of diagnstic columns +real(FMS_CD_KIND_), dimension(:), intent(out) :: diag_lat !< latitudes of diagnostic columns [ degrees ] +real(FMS_CD_KIND_), dimension(:), intent(out) :: diag_lon !< longitudes of diagnostic columns [ degrees ] +integer, dimension(:), intent(out) :: diag_units !< unit number for each diagnostic column +!--------------------------------------------------------------------- + +!--------------------------------------------------------------------- +! intent(in) variables: +! +! module module calling this subroutine +! num_diag_pts_latlon number of diagnostic columns specified +! by lat-lon coordinates +! num_diag_pts_ij number of diagnostic columns specified +! by global (i,j) coordinates +! global_i specified global i coordinates +! global_j specified global j coordinates +! global_lat_latlon specified global lat coordinates +! global_lon_latlon specified global lon coordinates +! +! intent(out) variables: +! +! do_column_diagnostics is a diagnostic column in this jrow ? +! diag_i processor i indices of diagnstic columns +! diag_j processor j indices of diagnstic columns +! diag_lat latitudes of diagnostic columns +! [ degrees ] +! diag_lon longitudes of diagnostic columns +! [ degrees ] +! diag_units unit number for each diagnostic column +! +!--------------------------------------------------------------------- + +!-------------------------------------------------------------------- +! local variables: + + real(FMS_CD_KIND_), dimension(size(diag_i,1)) :: global_lat !< latitudes for all diagnostic columns [ degrees ] + real(FMS_CD_KIND_), dimension(size(diag_i,1)) :: global_lon !< longitudes for all diagnostic columns [ degrees ] + real(FMS_CD_KIND_), dimension(size(latb_in,1)-1, size(latb_in,2)-1) :: & + distance, distance_x, distance_y, & + distance_x2, distance2 + real(FMS_CD_KIND_), dimension(size(latb_in,1), size(latb_in,2)) :: latb_deg + real(FMS_CD_KIND_), dimension(size(lonb_in,1), size(lonb_in,2)) :: lonb_deg + real(FMS_CD_KIND_) :: dellat, dellon + real(FMS_CD_KIND_) :: latb_max, latb_min, lonb_max, lonb_min + + integer :: num_diag_pts !< total number of diagnostic columns + integer :: i !< do loop indices + integer :: j !< do loop indices + integer :: nn !< do loop indices + real(FMS_CD_KIND_) :: ref_lat + real(FMS_CD_KIND_) :: current_distance + character(len=8) :: char !< character string for diaganostic column index + character(len=32) :: filename !< filename for output file for diagnostic column + logical :: allow_ij_input + logical :: open_file + integer :: io + + integer, parameter :: lkind=FMS_CD_KIND_ + real(FMS_CD_KIND_) :: tmp +!-------------------------------------------------------------------- +! local variables: +! +! global_lat latitudes for all diagnostic columns [ degrees ] +! global_lon longitudes for all diagnostic columns +! [ degrees ] +! num_diag_pts total number of diagnostic columns +! i, j, nn do loop indices +! char character string for diaganostic column index +! filename filename for output file for diagnostic column +! +!--------------------------------------------------------------------- + + if (.not. module_is_initialized) call column_diagnostics_init + +!-------------------------------------------------------------------- +! save the input lat and lon fields. define the delta of latitude +! and longitude. +!-------------------------------------------------------------------- + latb_deg = real( real(latb_in,r8_kind)*RADIAN, FMS_CD_KIND_) !< unit conversion in r8_kind + lonb_deg = real( real(lonb_in,r8_kind)*RADIAN, FMS_CD_KIND_ ) !< unit conversion in r8_kind + dellat = latb_in(1,2) - latb_in(1,1) + dellon = lonb_in(2,1) - lonb_in(1,1) + latb_max = MAXVAL (latb_deg(:,:)) + latb_min = MINVAL (latb_deg(:,:)) + lonb_max = MAXVAL (lonb_deg(:,:)) + lonb_min = MINVAL (lonb_deg(:,:)) + if (lonb_min < 10.0_lkind .or. lonb_max > 350.0_lkind) then + lonb_min = 0.0_lkind + lonb_max = 360.0_lkind + endif + + allow_ij_input = .true. + ref_lat = latb_in(1,1) + do i =2,size(latb_in,1) + if (latb_in(i,1) /= ref_lat) then + allow_ij_input = .false. + exit + endif + end do + + if ( .not. allow_ij_input .and. num_diag_pts_ij /= 0) then + call error_mesg ('column_diagnostics_mod', & + 'cannot specify column diagnostics column with (i,j) & + &coordinates when using cubed sphere -- must specify & + & lat/lon coordinates', FATAL) + endif + +!---------------------------------------------------------------------- + +!---------------------------------------------------------------------- +! initialize column_diagnostics flag and diag unit numbers. define +! total number of diagnostic columns. +!---------------------------------------------------------------------- + do_column_diagnostics = .false. + diag_units(:) = -1 + diag_i(:) = -99 + diag_j(:) = -99 + diag_lat(:) = -999.0_lkind + diag_lon(:) = -999.0_lkind + num_diag_pts = size(diag_i(:)) + +!-------------------------------------------------------------------- +! define an array of lat-lon values for all diagnostic columns. +!-------------------------------------------------------------------- + do nn = 1, num_diag_pts_latlon + global_lat(nn) = global_lat_latlon(nn) + global_lon(nn) = global_lon_latlon(nn) + end do + + do nn = 1, num_diag_pts_ij + tmp = (-0.5_lkind*acos(-1.0_lkind) + 0.5_lkind*dellat) + real(global_j(nn)-1,FMS_CD_KIND_)*dellat + global_lat(nn+num_diag_pts_latlon) = real( real(tmp,r8_kind)*RADIAN, FMS_CD_KIND_ ) + tmp = 0.5_lkind*dellon + real(global_i(nn)-1,FMS_CD_KIND_)*dellon + global_lon(nn+num_diag_pts_latlon) = real( real(tmp,r8_kind)*RADIAN, FMS_CD_KIND_ ) + end do + +!---------------------------------------------------------------------- +! loop over all diagnostic points to check for their presence on +! this processor. +!---------------------------------------------------------------------- + do nn=1,num_diag_pts + open_file = .false. + +!---------------------------------------------------------------------- +! verify that the values of lat and lon are valid. +!---------------------------------------------------------------------- + if (global_lon(nn) >= 0.0_lkind .and. & + global_lon(nn) <= 360.0_lkind) then + else + call error_mesg ('column_diagnostics_mod', & + ' invalid longitude', FATAL) + endif + if (global_lat(nn) >= -90.0_lkind .and. & + global_lat(nn) <= 90.0_lkind) then + else + call error_mesg ('column_diagnostics_mod', & + ' invalid latitude', FATAL) + endif + +!-------------------------------------------------------------------- +! if the desired diagnostics column is within the current +! processor's domain, define the total and coordinate distances from +! each of the processor's grid points to the diagnostics point. +!-------------------------------------------------------------------- + + if (global_lat(nn) .ge. latb_min .and. & + global_lat(nn) .le. latb_max) then + if (global_lon(nn) .ge. lonb_min .and.& + global_lon(nn) .le. lonb_max) then + do j=1,size(latb_deg,2) - 1 + do i=1,size(lonb_deg,1) - 1 + distance_y(i,j) = ABS(global_lat(nn) - latb_deg(i,j)) + distance_x(i,j) = ABS(global_lon(nn) - lonb_deg(i,j)) + distance_x2(i,j) = ABS((global_lon(nn)-360.0_lkind) - lonb_deg(i,j)) + distance(i,j) = (global_lat(nn)-latb_deg(i,j))**2 + (global_lon(nn)-lonb_deg(i,j))**2 + distance2(i,j) = (global_lat(nn)-latb_deg(i,j))**2 + ((global_lon(nn)-360.0_lkind) - lonb_deg(i,j))**2 + end do + end do + +!-------------------------------------------------------------------- +! find the grid point on the processor that is within the specified +! critical distance and also closest to the requested diagnostics +! column. save the (i,j) coordinates and (lon,lat) of this model +! grid point. set a flag indicating that a disgnostics file should +! be opened on this processor for this diagnostic point. +!-------------------------------------------------------------------- + current_distance = distance(1,1) + do j=1,size(latb_deg,2) - 1 + do i=1,size(lonb_deg,1) - 1 + if (distance_x(i,j) <= real(crit_xdistance,FMS_CD_KIND_) .and. & + distance_y(i,j) <= real(crit_ydistance,FMS_CD_KIND_)) then + if (distance(i,j) < current_distance) then + current_distance = distance(i,j) + do_column_diagnostics(i,j) = .true. + diag_j(nn) = j + diag_i(nn) = i + diag_lon(nn) = lonb_deg(i,j) + diag_lat(nn) = latb_deg(i,j) + open_file = .true. + endif + endif + +!--------------------------------------------------------------------- +! check needed because of the 0.0 / 360.0 longitude periodicity. +!--------------------------------------------------------------------- + if (distance_x2(i,j)<= real(crit_xdistance,FMS_CD_KIND_) .and. & + distance_y(i,j) <= real(crit_ydistance,FMS_CD_KIND_)) then + if (distance2(i,j) < current_distance) then + current_distance = distance2(i,j) + do_column_diagnostics(i,j) = .true. + diag_j(nn) = j + diag_i(nn) = i + diag_lon(nn) = lonb_deg(i,j) + diag_lat(nn) = latb_deg(i,j) + open_file = .true. + endif + endif + end do + end do + +!-------------------------------------------------------------------- +! if the point has been found on this processor, open a diagnostics +! file. +!-------------------------------------------------------------------- + if (open_file) then + write (char, '(i2)') nn + filename = trim(module) // '_point' // & + trim(adjustl(char)) // '.out' + if(mpp_npes() > 10000) then + write( filename,'(a,i6.6)' )trim(filename)//'.', mpp_pe()-mpp_root_pe() + else + write( filename,'(a,i4.4)' )trim(filename)//'.', mpp_pe()-mpp_root_pe() + endif + open(newunit=diag_units(nn), file=trim(filename), action='WRITE', position='rewind', iostat=io) + if(io/=0) call error_mesg ('column_diagnostics_mod', 'Error in opening file '//trim(filename), FATAL) + endif ! (open_file) + endif + endif + end do + +!--------------------------------------------------------------------- + + +end subroutine INITIALIZE_DIAGNOSTIC_COLUMNS_ + + + + +!#################################################################### +!> @brief column_diagnostics_header writes out information concerning +!! time and location of following data into the column_diagnostics +!! output file. +subroutine COLUMN_DIAGNOSTICS_HEADER_ & + (module, diag_unit, Time, nn, diag_lon, & + diag_lat, diag_i, diag_j) + +!-------------------------------------------------------------------- +! column_diagnostics_header writes out information concerning +! time and location of following data into the column_diagnostics +! output file. +!-------------------------------------------------------------------- + +!-------------------------------------------------------------------- +character(len=*), intent(in) :: module !< module name calling this subroutine +type(time_type), intent(in) :: Time !< current model time [ time_type ] +integer, intent(in) :: diag_unit !< unit number for column_diagnostics output +integer, intent(in) :: nn !< index of diagnostic column currently active +real(FMS_CD_KIND_), dimension(:), intent(in) :: diag_lon !< longitude of current diagnostic column [ degrees ] +real(FMS_CD_KIND_), dimension(:), intent(in) :: diag_lat !< latitude of current diagnostic column [ degrees ] +integer, dimension(:), intent(in) :: diag_i !< i coordinate of current diagnostic column +integer, dimension(:), intent(in) :: diag_j !< j coordinate of current diagnostic column + +!-------------------------------------------------------------------- +! intent(in) variables +! +! module module name calling this subroutine +! Time current model time [ time_type ] +! diag_unit unit number for column_diagnostics output +! nn index of diagnostic column currently active +! diag_lon longitude of current diagnostic column [ degrees ] +! diag_lat latitude of current diagnostic column [ degrees ] +! diag_i i coordinate of current diagnostic column +! diag_j j coordinate of current diagnostic column +! +!--------------------------------------------------------------------- + + +!-------------------------------------------------------------------- +! local variables: + + integer :: year !< integers defining the current time + integer :: month !< integers defining the current time + integer :: day !< integers defining the current time + integer :: hour !< integers defining the current time + integer :: minute !< integers defining the current time + integer :: second !< integers defining the current time + character(len=9) :: mon !< character string for the current month + character(len=64) :: header !< title for the output + +!-------------------------------------------------------------------- +! local variables: +! +! year, month, day, hour, minute, seconds +! integers defining the current time +! mon character string for the current month +! header title for the output +! +!-------------------------------------------------------------------- + + if (.not. module_is_initialized) call column_diagnostics_init + +!-------------------------------------------------------------------- +! convert the time type to a date and time for printing. convert +! month to a character string. +!-------------------------------------------------------------------- + call get_date (Time, year, month, day, hour, minute, second) + mon = month_name(month) + +!--------------------------------------------------------------------- +! write timestamp and column location information to the diagnostic +! columns output unit. +!--------------------------------------------------------------------- + write (diag_unit,'(a)') ' ' + write (diag_unit,'(a)') ' ' + write (diag_unit,'(a)') & + '======================================================' + write (diag_unit,'(a)') ' ' + header = ' PRINTING ' // module // ' DIAGNOSTICS' + write (diag_unit,'(a)') header + write (diag_unit,'(a)') ' ' + write (diag_unit,'(a, i6,2x, a,i4,i4,i4,i4)') ' time stamp:', & + year, trim(mon), day, & + hour, minute, second + write (diag_unit,'(a, i4)') & + ' DIAGNOSTIC POINT COORDINATES, point #', nn + write (diag_unit,'(a)') ' ' + write (diag_unit,'(a,f8.3,a,f8.3)') ' longitude = ', & + diag_lon(nn), ' latitude = ', diag_lat(nn) + write (diag_unit,'(a, i6, a,i6,a,i6)') & + ' on processor # ', mpp_pe(), & + ' : processor i =', diag_i(nn), & + ' , processor j =', diag_j(nn) + write (diag_unit,'(a)') ' ' + +!--------------------------------------------------------------------- + +end subroutine COLUMN_DIAGNOSTICS_HEADER_ +!@} diff --git a/column_diagnostics/include/column_diagnostics_r4.fh b/column_diagnostics/include/column_diagnostics_r4.fh new file mode 100644 index 0000000000..f8cdb30d9f --- /dev/null +++ b/column_diagnostics/include/column_diagnostics_r4.fh @@ -0,0 +1,34 @@ +!*********************************************************************** +!* 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 include file for column_diagnostics_mod to generate subroutine/functions +!! for r4_kind arguments + +#undef FMS_CD_KIND_ +#define FMS_CD_KIND_ r4_kind + +#undef INITIALIZE_DIAGNOSTIC_COLUMNS_ +#define INITIALIZE_DIAGNOSTIC_COLUMNS_ initialize_diagnostic_columns_r4 + +#undef COLUMN_DIAGNOSTICS_HEADER_ +#define COLUMN_DIAGNOSTICS_HEADER_ column_diagnostics_header_r4 + +#include "column_diagnostics.inc" + +!> @} diff --git a/column_diagnostics/include/column_diagnostics_r8.fh b/column_diagnostics/include/column_diagnostics_r8.fh new file mode 100644 index 0000000000..df0b4e2cf0 --- /dev/null +++ b/column_diagnostics/include/column_diagnostics_r8.fh @@ -0,0 +1,34 @@ +!*********************************************************************** +!* 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 include file for column_diagnostics_mod to generate subroutine/functions +!! for r8_kind arguments + +#undef FMS_CD_KIND_ +#define FMS_CD_KIND_ r8_kind + +#undef INITIALIZE_DIAGNOSTIC_COLUMNS_ +#define INITIALIZE_DIAGNOSTIC_COLUMNS_ initialize_diagnostic_columns_r8 + +#undef COLUMN_DIAGNOSTICS_HEADER_ +#define COLUMN_DIAGNOSTICS_HEADER_ column_diagnostics_header_r8 + +#include "column_diagnostics.inc" + +!> @} diff --git a/configure.ac b/configure.ac index 7600457ae4..3b242c0016 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.02.00-dev], + [2023.03.00-dev], [gfdl.climate.model.info@noaa.gov], [FMS], [https://www.github.com/NOAA-GFDL/FMS]) @@ -54,12 +54,6 @@ AS_IF([test x${CRAYPE_VERSION:+yes} = "xyes"],[ # Process user optons. -AC_ARG_ENABLE([mixed-mode], - [AS_HELP_STRING([--enable-mixed-mode], - [Build using mixed mode. Enables both 64-bit and 32-bit reals in Fortran. This option will be ignored if --disable-fortran-flag-setting is also given.])]) -AS_IF([test ${enable_mixed_mode:-no} = no], - [enable_mixed_mode=no], - [enable_mixed_mode=yes]) AC_ARG_WITH([mpi], [AS_HELP_STRING([--with-mpi], [Build with MPI support. This option will be ignored if --disable-fortran-flag-setting is also given. (Default yes)])]) @@ -85,12 +79,6 @@ AS_IF([test ${enable_code_coverage:-no} = no], [enable_code_coverage=no], [enable_code_coverage=yes]) # individual mixed precision overload macros -AC_ARG_ENABLE([overload-r4], - [AS_HELP_STRING([--enable-overload-r4], - [Enables the OVERLOAD_R4 macro to compile with 4 byte real routine overloads. (Default no)])]) -AS_IF([test ${enable_overload_r4:-no} = yes], - [enable_overload_r4=yes], - [enable_overload_r4=no]) AC_ARG_ENABLE([overload-c4], [AS_HELP_STRING([--enable-overload-c4], [Enables the OVERLOAD_C4 macro to compile with 4 byte complex routine overloads. (Default no)])]) @@ -117,6 +105,13 @@ AS_IF([test ${enable_deprecated_io:-no} = yes], [enable_deprecated_io=yes], [enable_deprecated_io=no]) +AC_ARG_ENABLE([r8-default], + [AS_HELP_STRING([--disable-r8-default], + [Disables the build from adding the 8 byte default real kind flag during compilation (default no)])]) +AS_IF([test ${enable_r8_default:-yes} = yes], + [enable_r8_default=yes], + [enable_r8_default=no]) + # user enabled testing with input files AC_MSG_CHECKING([whether to enable tests with input files]) AC_ARG_ENABLE([test-input], @@ -282,7 +277,6 @@ AC_OPENMP() AC_LANG_POP(Fortran) # We passed all the tests. Set the required defines. -AC_DEFINE([use_netCDF], [1], [This is required for the library to build]) if test $with_mpi = yes; then AC_DEFINE([use_libMPI], [1], [This is required for the library to build]) fi @@ -291,16 +285,18 @@ fi if test $enable_deprecated_io = yes; then #If the test pass, define use_deprecated_io macro and skip it's unit tests AC_DEFINE([use_deprecated_io], [1], [This is required to use mpp_io and fms_io modules]) + # this macro was only removed from non-deprecated code so still needs to be set + AC_DEFINE([use_netCDF], [1], [This has been removed elsewhere but is still required to build with deprecated io]) AM_CONDITIONAL([SKIP_DEPRECATED_IO_TESTS], true) else AM_CONDITIONAL([SKIP_DEPRECATED_IO_TESTS], false) fi -# disable mosaic unit tests if FMS is compiled in r4 -if test $enable_mixed_mode = yes ; then - AM_CONDITIONAL([SKIP_MOSAIC_TESTS], true) +# Builds with r8 default unless disable flag is given +if test $enable_r8_default = yes; then + AM_CONDITIONAL([SKIP_MOSAIC_TESTS], false) else - AM_CONDITIONAL([SKIP_MOSAIC_TESTS], false) + AM_CONDITIONAL([SKIP_MOSAIC_TESTS], true) fi # Set any required compile flags. This will not be done if the user wants to @@ -314,20 +310,13 @@ if test $enable_setting_flags = yes; then # necessary fortran flags. AC_FC_LINE_LENGTH([unlimited]) - # Will we build with default 64-bit reals in Fortran, or do mixed mode? - if test $enable_mixed_mode = yes; then - GX_FC_DEFAULT_REAL_KIND4_FLAG([dnl - FCFLAGS="$FCFLAGS $FC_DEFAULT_REAL_KIND8_FLAG"]) - AC_DEFINE([OVERLOAD_R4], [1], [Set to overload the R4 Fortran routines]) - AC_DEFINE([OVERLOAD_R8], [1], [Set to overload the R8 Fortran routines]) - else + # Builds with r8 default unless disable flag is given + if test $enable_r8_default = yes; then GX_FC_DEFAULT_REAL_KIND8_FLAG([dnl FCFLAGS="$FCFLAGS $FC_DEFAULT_REAL_KIND8_FLAG"]) fi + # individual mixed precision overloads - if test $enable_overload_r4 = yes; then - AC_DEFINE([OVERLOAD_R4], [1], [Set to overload with the R4 Fortran routines]) - fi if test $enable_overload_c4 = yes; then AC_DEFINE([OVERLOAD_C4], [1], [Set to overload with the C4 Fortran routines]) fi @@ -498,15 +487,18 @@ AC_CONFIG_FILES([ test_fms/horiz_interp/Makefile test_fms/field_manager/Makefile test_fms/axis_utils/Makefile - test_fms/mosaic/Makefile + test_fms/mosaic2/Makefile test_fms/affinity/Makefile test_fms/coupler/Makefile test_fms/parser/Makefile test_fms/string_utils/Makefile + test_fms/tridiagonal/Makefile test_fms/sat_vapor_pres/Makefile test_fms/diag_integral/Makefile test_fms/tracer_manager/Makefile test_fms/random_numbers/Makefile + test_fms/topography/Makefile + test_fms/column_diagnostics/Makefile FMS.pc ]) diff --git a/coupler/coupler_types.F90 b/coupler/coupler_types.F90 index 25ed6d108e..515eb8ed8f 100644 --- a/coupler/coupler_types.F90 +++ b/coupler/coupler_types.F90 @@ -2837,7 +2837,7 @@ end subroutine CT_increment_data_3d_3d !! @throw FATAL, "axes has less than 2 elements" subroutine CT_set_diags_2d(var, diag_name, axes, time) type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then + character(len=*), intent(in) :: diag_name !< Module name for diagnostic file--if blank, then !! don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field @@ -2893,7 +2893,7 @@ end subroutine CT_set_diags_2d !! @throw FATAL, "axes has less than 3 elements" subroutine CT_set_diags_3d(var, diag_name, axes, time) type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then + character(len=*), intent(in) :: diag_name !< Module name for diagnostic file--if blank, then !! don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field @@ -3727,8 +3727,6 @@ subroutine CT_data_override_2d(gridname, var, Time) character(len=3), intent(in) :: gridname !< 3-character long model grid ID type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override type(time_type), intent(in) :: time !< The current model time - !! TODO remove this when data_override is merged in - real(r8_kind), allocatable :: r8_field_values(:,:) integer :: m, n if(var%set .and. var%num_bcs .gt. 0) then @@ -3752,10 +3750,7 @@ subroutine CT_data_override_2d(gridname, var, Time) else if(associated(var%bc_r4)) then do n = 1, var%num_bcs do m = 1, var%bc_r4(n)%num_fields - !! this should be removed when data override is updated - r8_field_values = real(var%bc_r4(n)%field(m)%values, r8_kind) - call data_override(gridname, var%bc_r4(n)%field(m)%name, r8_field_values, Time) - var%bc_r4(n)%field(m)%values = real(r8_field_values, r4_kind) + call data_override(gridname, var%bc_r4(n)%field(m)%name, var%bc_r4(n)%field(m)%values, Time) enddo enddo else @@ -3795,10 +3790,7 @@ subroutine CT_data_override_3d(gridname, var, Time) else if(associated(var%bc_r4)) then do n = 1, var%num_bcs do m = 1, var%bc_r4(n)%num_fields - !! this should be removed when data override is updated - r8_field_values = real(var%bc_r4(n)%field(m)%values, r8_kind) - call data_override(gridname, var%bc_r4(n)%field(m)%name, r8_field_values, Time) - var%bc_r4(n)%field(m)%values = real(r8_field_values, r4_kind) + call data_override(gridname, var%bc_r4(n)%field(m)%name, var%bc_r4(n)%field(m)%values, Time) enddo enddo else diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index 663d2b0fcf..6d76c0d537 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -103,11 +103,7 @@ real(FMS_DATA_OVERRIDE_KIND_) :: min_glo_lon_lnd, max_glo_lon_lnd real(FMS_DATA_OVERRIDE_KIND_) :: min_glo_lon_ice, max_glo_lon_ice integer :: num_fields = 0 !< number of fields in override_array already processed -#ifdef use_yaml type(data_type), dimension(:), allocatable :: data_table !< user-provided data table -#else -type(data_type), dimension(max_table) :: data_table !< user-provided data table -#endif type(data_type) :: default_table type(override_type), dimension(max_array) :: override_array !< to store processed fields @@ -118,8 +114,9 @@ logical :: reproduce_null_char_bug = .false. !! to reproduce the mpp_io bug where lat/lon_bnd were !! not read correctly if null characters are present in !! the netcdf file +logical :: use_data_table_yaml = .false. -namelist /data_override_nml/ debug_data_override, grid_center_bug, reproduce_null_char_bug +namelist /data_override_nml/ debug_data_override, grid_center_bug, reproduce_null_char_bug, use_data_table_yaml public :: DATA_OVERRIDE_INIT_IMPL_, DATA_OVERRIDE_UNSET_ATM_, DATA_OVERRIDE_UNSET_OCN_, & & DATA_OVERRIDE_UNSET_LND_, DATA_OVERRIDE_UNSET_ICE_, DATA_OVERRIDE_0D_, & @@ -166,6 +163,12 @@ if (grid_center_bug) then "that is no longer supported. Please remove this namelist variable.") endif +if (use_data_table_yaml) then + call mpp_error(NOTE, "You are using YAML.") +else + call mpp_error(NOTE, "You are using the legacy table.") +end if + atm_on = PRESENT(Atm_domain_in) ocn_on = PRESENT(Ocean_domain_in) lnd_on = PRESENT(Land_domain_in) @@ -197,12 +200,25 @@ endif default_table%interpol_method = 'bilinear' #ifdef use_yaml - call read_table_yaml(data_table) + if (use_data_table_yaml) then + call read_table_yaml(data_table) + else + allocate(data_table(max_table)) + do i = 1, max_table + data_table(i) = default_table + enddo + call read_table(data_table) + end if #else - do i = 1,max_table - data_table(i) = default_table - enddo - call read_table(data_table) + if (use_data_table_yaml) then + call mpp_error(FATAL, "compilation error, need to compile with `-Duse_yaml`") + else + allocate(data_table(max_table)) + do i = 1, max_table + data_table(i) = default_table + enddo + call read_table(data_table) + end if #endif ! Initialize override array @@ -330,7 +346,6 @@ function count_ne_1(in_1, in_2, in_3) count_ne_1 = .not.(in_1.NEQV.in_2.NEQV.in_3) .OR. (in_1.AND.in_2.AND.in_3) end function count_ne_1 -#ifndef use_yaml subroutine read_table(data_table) type(data_type), dimension(max_table), intent(inout) :: data_table @@ -475,7 +490,7 @@ subroutine read_table(data_table) if(io_status/=0) call mpp_error(FATAL, 'data_override_mod: Error in closing file data_table') end subroutine read_table -#else +#ifdef use_yaml subroutine read_table_yaml(data_table) type(data_type), dimension(:), allocatable, intent(out) :: data_table diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90 index 96221aee36..7eb5eaf686 100644 --- a/diag_manager/diag_axis.F90 +++ b/diag_manager/diag_axis.F90 @@ -40,9 +40,7 @@ MODULE diag_axis_mod USE diag_data_mod, ONLY: diag_axis_type, max_subaxes, max_axes,& & max_num_axis_sets, max_axis_attributes, debug_diag_manager,& & first_send_data_call, diag_atttype -#ifdef use_netCDF USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR -#endif IMPLICIT NONE diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index a1f5947098..1f443ce220 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -53,10 +53,8 @@ MODULE diag_data_mod USE fms_mod, ONLY: WARNING, write_version_number USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type -#ifdef use_netCDF ! NF90_FILL_REAL has value of 9.9692099683868690e+36. USE netcdf, ONLY: NF_FILL_REAL => NF90_FILL_REAL -#endif use fms2_io_mod IMPLICIT NONE @@ -335,13 +333,9 @@ MODULE diag_data_mod ! -#ifdef use_netCDF REAL :: FILL_VALUE = NF_FILL_REAL !< Fill value used. Value will be NF90_FILL_REAL if using the !! netCDF module, otherwise will be 9.9692099683868690e+36. ! from file /usr/local/include/netcdf.inc -#else - REAL :: FILL_VALUE = 9.9692099683868690e+36 -#endif INTEGER :: pack_size = 1 !< 1 for double and 2 for float diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 92fdf0e122..55048c04f8 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -240,9 +240,7 @@ MODULE diag_manager_mod USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, & & fieldbuff_copy_fieldvals -#ifdef use_netCDF USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR -#endif !---------- !ug support diff --git a/diag_manager/diag_output.F90 b/diag_manager/diag_output.F90 index ff2042f599..095f8e659c 100644 --- a/diag_manager/diag_output.F90 +++ b/diag_manager/diag_output.F90 @@ -44,9 +44,7 @@ MODULE diag_output_mod USE time_manager_mod, ONLY: get_calendar_type, valid_calendar_types USE fms_mod, ONLY: error_mesg, mpp_pe, write_version_number, fms_error_handler, FATAL, note -#ifdef use_netCDF USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR -#endif use mpp_domains_mod, only: mpp_get_UG_io_domain use mpp_domains_mod, only: mpp_get_UG_domain_npes @@ -111,6 +109,9 @@ SUBROUTINE diag_output_init (file_name, file_title, file_unit,& integer, allocatable, dimension(:) :: current_pelist integer :: mype !< The pe you are on character(len=9) :: mype_string !< a string to store the pe + character(len=128) :: filename_tile !< Filename with the tile number included + !! It is needed for subregional diagnostics + !---- initialize mpp_io ---- IF ( .NOT.module_is_initialized ) THEN module_is_initialized = .TRUE. @@ -135,8 +136,13 @@ SUBROUTINE diag_output_init (file_name, file_title, file_unit,& fileob => fileobjND mype = mpp_pe() write(mype_string,'(I0.4)') mype + !! Add the tile number to the subregional file + !! This is needed for the combiner to work correctly + call get_mosaic_tile_file(file_name, filename_tile, .true., domain) + filename_tile = trim(filename_tile)//"."//trim(mype_string) + if (.not.check_if_open(fileob)) then - call open_check(open_file(fileobjND, trim(file_name)//".nc."//trim(mype_string), "overwrite", & + call open_check(open_file(fileobjND, trim(filename_tile), "overwrite", & is_restart=.false.)) !< For regional subaxis add the NumFilesInSet attribute, which is added by fms2_io for (other) !< domains with sufficient decomposition info. Note mppnccombine will work with an entry of zero. diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 9956c2d9c4..23191e62e8 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -72,9 +72,7 @@ MODULE diag_util_mod USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE USE fms2_io_mod USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type -#ifdef use_netCDF USE netcdf, ONLY: NF90_CHAR -#endif IMPLICIT NONE PRIVATE diff --git a/include/fms_platform.h b/include/fms_platform.h index 3b86ac054f..30feb9f73b 100644 --- a/include/fms_platform.h +++ b/include/fms_platform.h @@ -46,7 +46,6 @@ use,intrinsic :: iso_c_binding, only: c_double,c_float,c_int64_t, & !DEC$ MESSAGE:'Using 8-byte addressing' #endif - !Control "pure" functions. #ifdef NO_F95 #define _PURE @@ -56,7 +55,6 @@ use,intrinsic :: iso_c_binding, only: c_double,c_float,c_int64_t, & !DEC$ MESSAGE:'Using pure routines.' #endif - !Control array members of derived types. #ifdef NO_F2000 #define _ALLOCATABLE pointer @@ -70,8 +68,8 @@ use,intrinsic :: iso_c_binding, only: c_double,c_float,c_int64_t, & !DEC$ MESSAGE:'Using allocatable derived type array members.' #endif - -!Control use of cray pointers. +!Control use of cray pointers within mpp_peset +!Other cray pointer usage in mpp routines is compiled regardless #ifdef NO_CRAY_POINTERS #undef use_CRI_pointers !DEC$ MESSAGE:'Not using cray pointers.' @@ -80,40 +78,13 @@ use,intrinsic :: iso_c_binding, only: c_double,c_float,c_int64_t, & !DEC$ MESSAGE:'Using cray pointers.' #endif - -!Control size of integers that will hold address values. -!Appears for legacy reasons, but seems rather dangerous. -#ifdef _32bits -#define POINTER_KIND 4 -!DEC$ MESSAGE:'Using 4-byte addressing' -#endif - - -!If you do not want to use 64-bit integers. + !If you do not want to use 64-bit integers. #ifdef no_8byte_integers #define LONG_KIND INT_KIND #endif - -!If you do not want to use 32-bit floats. -#ifdef no_4byte_reals -#define FLOAT_KIND DOUBLE_KIND -#define NF_GET_VAR_REAL nf_get_var_double -#define NF_GET_VARA_REAL nf_get_vara_double -#define NF_GET_ATT_REAL nf_get_att_double -#undef OVERLOAD_R4 -#undef OVERLOAD_C4 -#endif - - !If you want to use quad-precision. -! The NO_QUAD_PRECISION macro will be deprecated and removed at some future time. -! Model code will rely solely upon the ENABLE_QUAD_PRECISION macro thereafer. -#if defined(ENABLE_QUAD_PRECISION) -#undef NO_QUAD_PRECISION -#else -#define NO_QUAD_PRECISION -#undef QUAD_KIND +#ifndef ENABLE_QUAD_PRECISION #define QUAD_KIND DOUBLE_KIND #endif diff --git a/libFMS/Makefile.am b/libFMS/Makefile.am index db57f86562..9605216504 100644 --- a/libFMS/Makefile.am +++ b/libFMS/Makefile.am @@ -28,7 +28,7 @@ lib_LTLIBRARIES = libFMS.la # These linker flags specify libtool version info. # See http://www.gnu.org/software/libtool/manual/libtool.html#Libtool-versioning # for information regarding incrementing `-version-info`. -libFMS_la_LDFLAGS = -version-info 16:0:0 +libFMS_la_LDFLAGS = -version-info 17:0:0 # Add the convenience libraries to the FMS library. libFMS_la_LIBADD = $(top_builddir)/platform/libplatform.la diff --git a/mosaic/Makefile.am b/mosaic/Makefile.am index d097207105..32166d34d3 100644 --- a/mosaic/Makefile.am +++ b/mosaic/Makefile.am @@ -51,9 +51,9 @@ grid_mod.$(FC_MODEXT): mosaic_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ - mosaic_mod.$(FC_MODEXT) \ - grid_mod.$(FC_MODEXT) \ - gradient_mod.$(FC_MODEXT) + mosaic_mod.$(FC_MODEXT) \ + grid_mod.$(FC_MODEXT) \ + gradient_mod.$(FC_MODEXT) nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) diff --git a/mosaic/read_mosaic.c b/mosaic/read_mosaic.c index b855d4267b..9fafad1f2b 100644 --- a/mosaic/read_mosaic.c +++ b/mosaic/read_mosaic.c @@ -23,9 +23,7 @@ #include "read_mosaic.h" #include "constant.h" #include "mosaic_util.h" -#ifdef use_netCDF #include -#endif /** \file * \ingroup mosaic @@ -258,11 +256,7 @@ void get_var_data(const char *file, const char *name, void *data) switch (vartype) { case NC_DOUBLE:case NC_FLOAT: -#ifdef OVERLOAD_R4 - status = nc_get_var_float(ncid, varid, (float *)data); -#else status = nc_get_var_double(ncid, varid, (double *)data); -#endif break; case NC_INT: status = nc_get_var_int(ncid, varid, (int *)data); @@ -318,11 +312,7 @@ void get_var_data_region(const char *file, const char *name, const size_t *start switch (vartype) { case NC_DOUBLE:case NC_FLOAT: -#ifdef OVERLOAD_R4 - status = nc_get_vara_float(ncid, varid, start, nread, (float *)data); -#else status = nc_get_vara_double(ncid, varid, start, nread, (double *)data); -#endif break; case NC_INT: status = nc_get_vara_int(ncid, varid, start, nread, (int *)data); @@ -400,59 +390,35 @@ int read_mosaic_xgrid_size( const char *xgrid_file ) return ncells; } -#ifdef OVERLOAD_R4 -float get_global_area(void) -{ - float garea; -#else double get_global_area(void) { double garea; -#endif garea = 4*M_PI*RADIUS*RADIUS; return garea; } -#ifdef OVERLOAD_R4 - float get_global_area_(void) + double get_global_area_(void) { - float garea; -#else - double get_global_area_(void) - { - double garea; -#endif - garea = 4*M_PI*RADIUS*RADIUS; + double garea; + garea = 4*M_PI*RADIUS*RADIUS; - return garea; - } + return garea; + } /****************************************************************************/ -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order1_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area ) -#else - void read_mosaic_xgrid_order1_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ) -#endif + void read_mosaic_xgrid_order1_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ) { read_mosaic_xgrid_order1(xgrid_file, i1, j1, i2, j2, area); } -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area ) -#else - void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ) -#endif + void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ) { int ncells, n; int *tile1_cell, *tile2_cell; -#ifdef OVERLOAD_R4 - float garea; -#else double garea; -#endif ncells = get_dimlen(xgrid_file, "ncells"); @@ -479,30 +445,18 @@ float get_global_area(void) } /* read_mosaic_xgrid_order1 */ -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order1_region_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, int *isc, int *iec ) -#else - void read_mosaic_xgrid_order1_region_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ) -#endif + void read_mosaic_xgrid_order1_region_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ) { read_mosaic_xgrid_order1_region(xgrid_file, i1, j1, i2, j2, area, isc, iec); } -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order1_region(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, int *isc, int *iec ) -#else - void read_mosaic_xgrid_order1_region(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ) -#endif + void read_mosaic_xgrid_order1_region(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ) { int ncells, n, i; int *tile1_cell, *tile2_cell; size_t start[4], nread[4]; -#ifdef OVERLOAD_R4 - float garea; -#else double garea; -#endif ncells = *iec-*isc+1; @@ -540,30 +494,17 @@ float get_global_area(void) /* NOTE: di, dj is for tile1, */ /****************************************************************************/ -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order2_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, float *di, float *dj ) -#else - void read_mosaic_xgrid_order2_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, double *di, double *dj ) -#endif - { + void read_mosaic_xgrid_order2_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, double *di, double *dj ) + { read_mosaic_xgrid_order2(xgrid_file, i1, j1, i2, j2, area, di, dj); } -#ifdef OVERLOAD_R4 - void read_mosaic_xgrid_order2(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, float *di, float *dj ) -#else - void read_mosaic_xgrid_order2(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, double *di, double *dj ) -#endif - + void read_mosaic_xgrid_order2(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, double *di, double *dj ) { int ncells, n; int *tile1_cell, *tile2_cell; double *tile1_distance; -#ifdef OVERLOAD_R4 - float garea; -#else double garea; -#endif ncells = get_dimlen(xgrid_file, "ncells"); tile1_cell = (int *)malloc(ncells*2*sizeof(int )); diff --git a/mosaic/read_mosaic.h b/mosaic/read_mosaic.h index 3612fb7bcb..5f377641a7 100644 --- a/mosaic/read_mosaic.h +++ b/mosaic/read_mosaic.h @@ -44,19 +44,6 @@ void get_var_text_att(const char *file, const char *name, const char *attname, c int read_mosaic_xgrid_size( const char *xgrid_file ); -#ifdef OVERLOAD_R4 - -void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area ); - -void read_mosaic_xgrid_order1_region(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, int *isc, int *iec ); - -void read_mosaic_xgrid_order2(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, - float *area, float *di, float *dj ); - -float get_global_area(void); - -#else - void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ); void read_mosaic_xgrid_order1_region(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ); @@ -66,7 +53,6 @@ void read_mosaic_xgrid_order2(const char *xgrid_file, int *i1, int *j1, int *i2, double get_global_area(void); -#endif int read_mosaic_ntiles(const char *mosaic_file); @@ -94,17 +80,6 @@ int read_mosaic_ncontacts_(const char *mosaic_file); void read_mosaic_grid_sizes_(const char *mosaic_file, int *nx, int *ny); -#ifdef OVERLOAD_R4 - -float get_global_area_(void); - -void read_mosaic_xgrid_order1_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area ); - -void read_mosaic_xgrid_order1_region_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, int *isc, int *iec ); - -void read_mosaic_xgrid_order2_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, float *area, float *di, float *dj ); - -#else double get_global_area_(void); @@ -114,6 +89,4 @@ void read_mosaic_xgrid_order1_region_(const char *xgrid_file, int *i1, int *j1, void read_mosaic_xgrid_order2_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, double *di, double *dj ); -#endif /* OVERLOAD_R4 */ - #endif diff --git a/mosaic2/Makefile.am b/mosaic2/Makefile.am index 4830823af2..8801461b03 100644 --- a/mosaic2/Makefile.am +++ b/mosaic2/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/mosaic +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/mosaic -I$(top_srcdir)/mosaic2/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. @@ -32,14 +32,17 @@ noinst_LTLIBRARIES = libmosaic2.la libmosaic2_la_SOURCES = \ mosaic2.F90 \ -grid2.F90 +grid2.F90 \ +include/mosaic2_r4.fh include/mosaic2_r8.fh include/mosaic2.inc \ +include/grid2_r4.fh include/grid2_r8.fh include/grid2.inc # Some mods are dependant on other mods in this dir. -grid2_mod.$(FC_MODEXT): mosaic2_mod.$(FC_MODEXT) +grid2_mod.$(FC_MODEXT): mosaic2_mod.$(FC_MODEXT) include/grid2_r4.fh include/grid2_r8.fh include/grid2.inc +mosaic2_mod.$(FC_MODEXT): include/mosaic2_r4.fh include/mosaic2_r8.fh include/mosaic2.inc MODFILES = \ - mosaic2_mod.$(FC_MODEXT) \ - grid2_mod.$(FC_MODEXT) + mosaic2_mod.$(FC_MODEXT) \ + grid2_mod.$(FC_MODEXT) nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) diff --git a/mosaic2/grid2.F90 b/mosaic2/grid2.F90 index 357e875ebf..e486777744 100644 --- a/mosaic2/grid2.F90 +++ b/mosaic2/grid2.F90 @@ -20,6 +20,8 @@ !> @ingroup mosaic2 !> @brief Routines for grid calculations, using @ref fms2_io +!> @addtogroup grid2_mod +!> @{ module grid2_mod use mpp_mod, only : mpp_root_pe, mpp_error, uppercase, lowercase, FATAL, NOTE @@ -68,31 +70,41 @@ module grid2_mod !! mosaic tile number !> @ingroup grid2_mod interface get_grid_cell_vertices - module procedure get_grid_cell_vertices_1D - module procedure get_grid_cell_vertices_2D - module procedure get_grid_cell_vertices_UG + module procedure get_grid_cell_vertices_1D_r4 + module procedure get_grid_cell_vertices_1D_r8 + module procedure get_grid_cell_vertices_2D_r4 + module procedure get_grid_cell_vertices_2D_r8 + module procedure get_grid_cell_vertices_UG_r4 + module procedure get_grid_cell_vertices_UG_r8 end interface !> Gets grid cell centers !> @ingroup grid2_mod interface get_grid_cell_centers - module procedure get_grid_cell_centers_1D - module procedure get_grid_cell_centers_2D - module procedure get_grid_cell_centers_UG + module procedure get_grid_cell_centers_1D_r4 + module procedure get_grid_cell_centers_1D_r8 + module procedure get_grid_cell_centers_2D_r4 + module procedure get_grid_cell_centers_2D_r8 + module procedure get_grid_cell_centers_UG_r4 + module procedure get_grid_cell_centers_UG_r8 end interface !> Finds area of a grid cell !> @ingroup grid2_mod interface get_grid_cell_area - module procedure get_grid_cell_area_SG - module procedure get_grid_cell_area_UG + module procedure get_grid_cell_area_SG_r4 + module procedure get_grid_cell_area_SG_r8 + module procedure get_grid_cell_area_UG_r4 + module procedure get_grid_cell_area_UG_r8 end interface get_grid_cell_area !> Gets the area of a given component per grid cell !> @ingroup grid2_mod interface get_grid_comp_area - module procedure get_grid_comp_area_SG - module procedure get_grid_comp_area_UG + module procedure get_grid_comp_area_SG_r4 + module procedure get_grid_comp_area_SG_r8 + module procedure get_grid_comp_area_UG_r4 + module procedure get_grid_comp_area_UG_r8 end interface get_grid_comp_area !> @addtogroup grid2_mod @@ -338,1105 +350,6 @@ subroutine get_grid_size_for_one_tile(component,tile,nx,ny) endif end subroutine get_grid_size_for_one_tile -!> @brief return grid cell area for the specified model component and tile -subroutine get_grid_cell_area_SG(component, tile, cellarea, domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer , intent(in) :: tile !< Tile number - class(*) , intent(inout) :: cellarea(:,:) !< Cell area - type(domain2d) , intent(in), optional :: domain !< Domain - - ! local vars - integer :: nlon, nlat - real(r4_kind), allocatable :: glonb_r4(:,:), glatb_r4(:,:) - real(r8_kind), allocatable :: glonb_r8(:,:), glatb_r8(:,:) - - select type(cellarea) - !! R4 argument - type is (real(r4_kind)) - select case(grid_version) - case(VERSION_GEOLON_T,VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_area_SG): grid_spec does not exist') - end if - select case(trim(component)) - case('LND') - call read_data(gridfileobj, 'AREA_LND_CELL', cellarea) - case('ATM','OCN') - call read_data(gridfileobj, 'AREA_'//trim(uppercase(component)),cellarea) - case default - call mpp_error(FATAL, module_name//'/get_grid_cell_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - ! convert area to m2 - cellarea = real(cellarea*4.*PI*radius**2, r4_kind) - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - if (present(domain)) then - call mpp_get_compute_domain(domain,xsize=nlon,ysize=nlat) - else - call get_grid_size(component,tile,nlon,nlat) - endif - allocate(glonb_r4(nlon+1,nlat+1),glatb_r4(nlon+1,nlat+1)) - call get_grid_cell_vertices(component, tile, glonb_r4, glatb_r4, domain) - if (great_circle_algorithm) then - call calc_mosaic_grid_great_circle_area(glonb_r4*pi/180.0, glatb_r4*pi/180.0, cellarea) - else - call calc_mosaic_grid_area(glonb_r4*pi/180.0, glatb_r4*pi/180.0, cellarea) - end if - deallocate(glonb_r4,glatb_r4) - end select - !! R8 argument - type is (real(r8_kind)) - select case(grid_version) - case(VERSION_GEOLON_T,VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_area_SG): grid_spec does not exist') - end if - select case(trim(component)) - case('LND') - call read_data(gridfileobj, 'AREA_LND_CELL', cellarea) - case('ATM','OCN') - call read_data(gridfileobj, 'AREA_'//trim(uppercase(component)),cellarea) - case default - call mpp_error(FATAL, module_name//'/get_grid_cell_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - ! convert area to m2 - cellarea = cellarea*4.*PI*radius**2 - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - if (present(domain)) then - call mpp_get_compute_domain(domain,xsize=nlon,ysize=nlat) - else - call get_grid_size(component,tile,nlon,nlat) - endif - allocate(glonb_r8(nlon+1,nlat+1),glatb_r8(nlon+1,nlat+1)) - call get_grid_cell_vertices(component, tile, glonb_r8, glatb_r8, domain) - if (great_circle_algorithm) then - call calc_mosaic_grid_great_circle_area(glonb_r8*pi/180.0, glatb_r8*pi/180.0, cellarea) - else - call calc_mosaic_grid_area(glonb_r8*pi/180.0, glatb_r8*pi/180.0, cellarea) - end if - deallocate(glonb_r8,glatb_r8) - end select - class default - call mpp_error(FATAL, "get_grid_cell_area_SG: invalid type given for cellarea, must be r4_kind or r8_kind") - end select - -end subroutine get_grid_cell_area_SG - -!> @brief get the area of the component per grid cell -subroutine get_grid_comp_area_SG(component,tile,area,domain) - character(len=*) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - class(*), intent(inout) :: area(:,:) !< Area of grid cell - type(domain2d), intent(in), optional :: domain !< Domain - ! local vars - integer :: n_xgrid_files ! number of exchange grid files in the mosaic - integer :: siz(2), nxgrid - integer :: i,j,m,n - integer, allocatable :: i1(:), j1(:), i2(:), j2(:) - real(r4_kind), allocatable :: xgrid_area_r4(:) - real(r4_kind), allocatable :: rmask_r4(:,:) - real(r8_kind), allocatable :: xgrid_area_r8(:) - real(r8_kind), allocatable :: rmask_r8(:,:) - character(len=MAX_NAME) :: & - xgrid_name, & ! name of the variable holding xgrid names - tile_name, & ! name of the tile - mosaic_name ! name of the mosaic - character(len=MAX_FILE) :: & - tilefile, & ! name of current tile file - xgrid_file ! name of the current xgrid file - character(len=4096) :: attvalue - character(len=MAX_NAME), allocatable :: nest_tile_name(:) - integer :: is,ie,js,je ! boundaries of our domain - integer :: i0, j0 ! offsets for x and y, respectively - integer :: num_nest_tile, ntiles - logical :: is_nest - integer :: found_xgrid_files ! how many xgrid files we actually found in the grid spec - integer :: ibegin, iend, bsize, l - type(FmsNetcdfFile_t) :: tilefileobj, xgrid_fileobj - - select type(area) - type is (real(r4_kind)) - select case (grid_version ) - case(VERSION_GEOLON_T,VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - select case(component) - case('ATM') - call read_data(gridfileobj,'AREA_ATM',area) - case('OCN') - allocate(rmask_r4(size(area,1),size(area,2))) - call read_data(gridfileobj,'AREA_OCN',area) - call read_data(gridfileobj,'wet', rmask_r4) - area = area*rmask_r4 - deallocate(rmask_r4) - case('LND') - call read_data(gridfileobj,'AREA_LND',area) - case default - call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) ! mosaic gridspec - select case (component) - case ('ATM') - ! just read the grid cell area and return - call get_grid_cell_area(component,tile,area) - return - case ('LND') - xgrid_name = 'aXl_file' - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'lnd_mosaic', mosaic_name) - tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) - case ('OCN') - xgrid_name = 'aXo_file' - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'ocn_mosaic', mosaic_name) - tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) - case default - call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - ! get the boundaries of the requested domain - if(present(domain)) then - call mpp_get_compute_domain(domain,is,ie,js,je) - i0 = 1-is ; j0=1-js - else - call get_grid_size(component,tile,ie,je) - is = 1 ; i0 = 0 - js = 1 ; j0 = 0 - endif - if (size(area,1)/=ie-is+1.or.size(area,2)/=je-js+1) & - call mpp_error(FATAL, module_name//'/get_grid_comp_area '//& - 'size of the output argument "area" is not consistent with the domain') - - ! find the nest tile - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'atm_mosaic', mosaic_name) - call get_grid_ntiles('atm', ntiles) - allocate(nest_tile_name(ntiles)) - num_nest_tile = 0 - do n = 1, ntiles - tilefile = read_file_name(mosaic_fileobj(1), 'gridfiles', n) - call open_grid_file(tilefileobj, grid_dir//tilefile) - if (global_att_exists(tilefileobj, "nest_grid")) then - call get_global_attribute(tilefileobj, "nest_grid", attvalue) - if(trim(attvalue) == "TRUE") then - num_nest_tile = num_nest_tile + 1 - nest_tile_name(num_nest_tile) = trim(mosaic_name)//'_tile'//char(n+ichar('0')) - else if(trim(attvalue) .NE. "FALSE") then - call mpp_error(FATAL,module_name//'/get_grid_comp_area value of global attribute nest_grid in file'//& - trim(tilefile)//' should be TRUE or FALSE') - endif - end if - call close_file(tilefileobj) - end do - area(:,:) = 0. - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - if(variable_exists(gridfileobj,xgrid_name)) then - ! get the number of the exchange-grid files - call get_variable_size(gridfileobj,xgrid_name,siz) - n_xgrid_files = siz(2) - found_xgrid_files = 0 - ! loop through all exchange grid files - do n = 1, n_xgrid_files - ! get the name of the current exchange grid file - xgrid_file = read_file_name(gridfileobj,xgrid_name,n) - call open_grid_file(xgrid_fileobj, grid_dir//xgrid_file) - ! skip the rest of the loop if the name of the current tile isn't found - ! in the file name, but check this only if there is more than 1 tile - if(n_xgrid_files>1) then - if(index(xgrid_file,trim(tile_name))==0) cycle - endif - found_xgrid_files = found_xgrid_files + 1 - !---make sure the atmosphere grid is not a nested grid - is_nest = .false. - do m = 1, num_nest_tile - if(index(xgrid_file, trim(nest_tile_name(m))) .NE. 0) then - is_nest = .true. - exit - end if - end do - if(is_nest) cycle - - ! finally read the exchange grid - nxgrid = get_mosaic_xgrid_size(xgrid_fileobj) - if(nxgrid < BUFSIZE) then - allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), xgrid_area_r4(nxgrid)) - else - allocate(i1(BUFSIZE), j1(BUFSIZE), i2(BUFSIZE), j2(BUFSIZE), xgrid_area_r4(BUFSIZE)) - endif - ibegin = 1 - do l = 1,nxgrid,BUFSIZE - bsize = min(BUFSIZE, nxgrid-l+1) - iend = ibegin + bsize - 1 - call get_mosaic_xgrid(xgrid_fileobj, i1(1:bsize), j1(1:bsize), i2(1:bsize), j2(1:bsize), & - xgrid_area_r4(1:bsize), ibegin, iend) - ! and sum the exchange grid areas - do m = 1, bsize - i = i2(m); j = j2(m) - if (iie) cycle - if (jje) cycle - area(i+i0,j+j0) = area(i+i0,j+j0) + xgrid_area_r4(m) - end do - ibegin = iend + 1 - enddo - deallocate(i1, j1, i2, j2, xgrid_area_r4) - call close_file(xgrid_fileobj) - enddo - if (found_xgrid_files == 0) & - call mpp_error(FATAL, 'get_grid_comp_area no xgrid files were found for component '& - //trim(component)//' (mosaic name is '//trim(mosaic_name)//')') - - endif - deallocate(nest_tile_name) - end select ! version - ! convert area to m2 - area = real(area*4.*PI*radius**2, r4_kind) - !! R8 version ################################### - type is (real(r8_kind)) - select case (grid_version ) - case(VERSION_GEOLON_T,VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - select case(component) - case('ATM') - call read_data(gridfileobj,'AREA_ATM',area) - case('OCN') - allocate(rmask_r8(size(area,1),size(area,2))) - call read_data(gridfileobj,'AREA_OCN',area) - call read_data(gridfileobj,'wet', rmask_r8) - area = area*rmask_r8 - deallocate(rmask_r8) - case('LND') - call read_data(gridfileobj,'AREA_LND',area) - case default - call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) ! mosaic gridspec - select case (component) - case ('ATM') - ! just read the grid cell area and return - call get_grid_cell_area(component,tile,area) - return - case ('LND') - xgrid_name = 'aXl_file' - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'lnd_mosaic', mosaic_name) - tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) - case ('OCN') - xgrid_name = 'aXo_file' - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'ocn_mosaic', mosaic_name) - tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) - case default - call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - ! get the boundaries of the requested domain - if(present(domain)) then - call mpp_get_compute_domain(domain,is,ie,js,je) - i0 = 1-is ; j0=1-js - else - call get_grid_size(component,tile,ie,je) - is = 1 ; i0 = 0 - js = 1 ; j0 = 0 - endif - if (size(area,1)/=ie-is+1.or.size(area,2)/=je-js+1) & - call mpp_error(FATAL, module_name//'/get_grid_comp_area '//& - 'size of the output argument "area" is not consistent with the domain') - - ! find the nest tile - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - call read_data(gridfileobj, 'atm_mosaic', mosaic_name) - call get_grid_ntiles('atm', ntiles) - allocate(nest_tile_name(ntiles)) - num_nest_tile = 0 - do n = 1, ntiles - tilefile = read_file_name(mosaic_fileobj(1), 'gridfiles', n) - call open_grid_file(tilefileobj, grid_dir//tilefile) - if (global_att_exists(tilefileobj, "nest_grid")) then - call get_global_attribute(tilefileobj, "nest_grid", attvalue) - if(trim(attvalue) == "TRUE") then - num_nest_tile = num_nest_tile + 1 - nest_tile_name(num_nest_tile) = trim(mosaic_name)//'_tile'//char(n+ichar('0')) - else if(trim(attvalue) .NE. "FALSE") then - call mpp_error(FATAL,module_name//'/get_grid_comp_area value of global attribute nest_grid in file'//& - trim(tilefile)//' should be TRUE or FALSE') - endif - end if - call close_file(tilefileobj) - end do - area(:,:) = 0. - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') - end if - if(variable_exists(gridfileobj,xgrid_name)) then - ! get the number of the exchange-grid files - call get_variable_size(gridfileobj,xgrid_name,siz) - n_xgrid_files = siz(2) - found_xgrid_files = 0 - ! loop through all exchange grid files - do n = 1, n_xgrid_files - ! get the name of the current exchange grid file - xgrid_file = read_file_name(gridfileobj,xgrid_name,n) - call open_grid_file(xgrid_fileobj, grid_dir//xgrid_file) - ! skip the rest of the loop if the name of the current tile isn't found - ! in the file name, but check this only if there is more than 1 tile - if(n_xgrid_files>1) then - if(index(xgrid_file,trim(tile_name))==0) cycle - endif - found_xgrid_files = found_xgrid_files + 1 - !---make sure the atmosphere grid is not a nested grid - is_nest = .false. - do m = 1, num_nest_tile - if(index(xgrid_file, trim(nest_tile_name(m))) .NE. 0) then - is_nest = .true. - exit - end if - end do - if(is_nest) cycle - - ! finally read the exchange grid - nxgrid = get_mosaic_xgrid_size(xgrid_fileobj) - if(nxgrid < BUFSIZE) then - allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), xgrid_area_r8(nxgrid)) - else - allocate(i1(BUFSIZE), j1(BUFSIZE), i2(BUFSIZE), j2(BUFSIZE), xgrid_area_r8(BUFSIZE)) - endif - ibegin = 1 - do l = 1,nxgrid,BUFSIZE - bsize = min(BUFSIZE, nxgrid-l+1) - iend = ibegin + bsize - 1 - call get_mosaic_xgrid(xgrid_fileobj, i1(1:bsize), j1(1:bsize), i2(1:bsize), j2(1:bsize), & - xgrid_area_r8(1:bsize), ibegin, iend) - ! and sum the exchange grid areas - do m = 1, bsize - i = i2(m); j = j2(m) - if (iie) cycle - if (jje) cycle - area(i+i0,j+j0) = area(i+i0,j+j0) + xgrid_area_r8(m) - end do - ibegin = iend + 1 - enddo - deallocate(i1, j1, i2, j2, xgrid_area_r8) - call close_file(xgrid_fileobj) - enddo - if (found_xgrid_files == 0) & - call mpp_error(FATAL, 'get_grid_comp_area no xgrid files were found for component '& - //trim(component)//' (mosaic name is '//trim(mosaic_name)//')') - - endif - deallocate(nest_tile_name) - end select ! version - ! convert area to m2 - area = area*4.*PI*radius**2 - class default - call mpp_error(FATAL, "get_grid_comp_area_SG: invalid type given for area argument, must be r4_kind or r8_kind") - end select -end subroutine get_grid_comp_area_SG - -!> @brief return grid cell area for the specified model component and tile on an -!! unstructured domain -subroutine get_grid_cell_area_UG(component, tile, cellarea, SG_domain, UG_domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer , intent(in) :: tile !< Tile number - real , intent(inout) :: cellarea(:) !< Cell area - type(domain2d) , intent(in) :: SG_domain !< Structured Domain - type(domainUG) , intent(in) :: UG_domain !< Unstructured Domain - integer :: is, ie, js, je - real, allocatable :: SG_area(:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_area(is:ie, js:je)) - call get_grid_cell_area_SG(component, tile, SG_area, SG_domain) - call mpp_pass_SG_to_UG(UG_domain, SG_area, cellarea) - deallocate(SG_area) -end subroutine get_grid_cell_area_UG - -!> @brief get the area of the component per grid cell for an unstructured domain -subroutine get_grid_comp_area_UG(component, tile, area, SG_domain, UG_domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer , intent(in) :: tile !< Tile number - real , intent(inout) :: area(:) !< Area of the component - type(domain2d) , intent(in) :: SG_domain !< Structured domain - type(domainUG) , intent(in) :: UG_domain !< Unstructured domain - integer :: is, ie, js, je - real, allocatable :: SG_area(:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_area(is:ie, js:je)) - call get_grid_comp_area_SG(component, tile, SG_area, SG_domain) - call mpp_pass_SG_to_UG(UG_domain, SG_area, area) - deallocate(SG_area) - -end subroutine get_grid_comp_area_UG - -!> @brief returns arrays of global grid cell boundaries for given model component and -!! mosaic tile number. -subroutine get_grid_cell_vertices_1D(component, tile, glonb, glatb) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - real, intent(inout) :: glonb(:),glatb(:) !< Grid cell vertices - - integer :: nlon, nlat - integer :: start(4), nread(4) - real, allocatable :: tmp(:,:), x_vert_t(:,:,:), y_vert_t(:,:,:) - character(len=MAX_FILE) :: tilefile - type(FmsNetcdfFile_t) :: tilefileobj - - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - if (size(glonb(:))/=nlon+1) & - call mpp_error (FATAL, module_name//'/get_grid_cell_vertices_1D '//& - 'Size of argument "glonb" is not consistent with the grid size') - if (size(glatb(:))/=nlat+1) & - call mpp_error (FATAL, module_name//'/get_grid_cell_vertices_1D '//& - 'Size of argument "glatb" is not consistent with the grid size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_vertices_1D '//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select case(grid_version) - case(VERSION_GEOLON_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_1D): grid_spec does not exist') - end if - select case(trim(component)) - case('ATM','LND') - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), glonb) - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), glatb) - case('OCN') - call read_data(gridfileobj, "gridlon_vert_t", glonb) - call read_data(gridfileobj, "gridlat_vert_t", glatb) - end select - case(VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_1D): grid_spec does not exist') - end if - select case(trim(component)) - case('ATM','LND') - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), glonb) - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), glatb) - case('OCN') - allocate (x_vert_t(nlon,1,2), y_vert_t(1,nlat,2) ) - start = 1; nread = 1 - nread(1) = nlon; nread(2) = 1; start(3) = 1 - call read_data(gridfileobj, "x_vert_T", x_vert_t(:,:,1), corner=start, edge_lengths=nread) - nread(1) = nlon; nread(2) = 1; start(3) = 2 - call read_data(gridfileobj, "x_vert_T", x_vert_t(:,:,2), corner=start, edge_lengths=nread) - - nread(1) = 1; nread(2) = nlat; start(3) = 1 - call read_data(gridfileobj, "y_vert_T", y_vert_t(:,:,1), corner=start, edge_lengths=nread) - nread(1) = 1; nread(2) = nlat; start(3) = 4 - call read_data(gridfileobj, "y_vert_T", y_vert_t(:,:,2), corner=start, edge_lengths=nread) - glonb(1:nlon) = x_vert_t(1:nlon,1,1) - glonb(nlon+1) = x_vert_t(nlon,1,2) - glatb(1:nlat) = y_vert_t(1,1:nlat,1) - glatb(nlat+1) = y_vert_t(1,nlat,2) - deallocate(x_vert_t, y_vert_t) - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - ! get the name of the grid file for the component and tile - tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) - call open_grid_file(tilefileobj, grid_dir//tilefile) - - start = 1; nread = 1 - nread(1) = 2*nlon+1 - allocate( tmp(2*nlon+1,1) ) - call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) - glonb(1:nlon+1) = tmp(1:2*nlon+1:2,1) - deallocate(tmp) - allocate(tmp(1,2*nlat+1)) - - start = 1; nread = 1 - nread(2) = 2*nlat+1 - call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) - glatb(1:nlat+1) = tmp(1,1:2*nlat+1:2) - deallocate(tmp) - call close_file(tilefileobj) - end select -end subroutine get_grid_cell_vertices_1D - -!> @brief returns cell vertices for the specified model component and mosaic tile number -subroutine get_grid_cell_vertices_2D(component, tile, lonb, latb, domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - class(*), intent(inout) :: lonb(:,:),latb(:,:) !< Cell vertices - type(domain2d), optional, intent(in) :: domain !< Domain - - ! local vars - integer :: nlon, nlat - integer :: i,j - real(r4_kind), allocatable :: buffer_r4(:), tmp_r4(:,:), x_vert_t_r4(:,:,:), y_vert_t_r4(:,:,:) - real(r8_kind), allocatable :: buffer_r8(:), tmp_r8(:,:), x_vert_t_r8(:,:,:), y_vert_t_r8(:,:,:) - integer :: is,ie,js,je ! boundaries of our domain - integer :: i0,j0 ! offsets for coordinates - integer :: isg, jsg - integer :: start(4), nread(4) - character(len=MAX_FILE) :: tilefile - type(FmsNetcdfFile_t) :: tilefileobj - logical :: valid_types = .false. - - select type(lonb) - type is (real(r4_kind)) - select type(latb) - type is (real(r4_kind)) - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - valid_types = .true. - end select - type is (real(r8_kind)) - select type(latb) - type is (real(r8_kind)) - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - valid_types = .true. - end select - end select - if(.not. valid_types) call mpp_error(FATAL, & - & 'get_grid_cell_vertices_2D: invalid types, lonb/latb must be r4_kind or r8_kind') - - - if (present(domain)) then - call mpp_get_compute_domain(domain,is,ie,js,je) - else - is = 1 ; ie = nlon - js = 1 ; je = nlat - !--- domain normally should be present - call mpp_error (NOTE, module_name//'/get_grid_cell_vertices '//& - 'domain is not present, global data will be read') - endif - i0 = -is+1; j0 = -js+1 - - ! verify that lonb and latb sizes are consistent with the size of domain - if (size(lonb,1)/=ie-is+2.or.size(lonb,2)/=je-js+2) & - call mpp_error (FATAL, module_name//'/get_grid_cell_vertices '//& - 'Size of argument "lonb" is not consistent with the domain size') - if (size(latb,1)/=ie-is+2.or.size(latb,2)/=je-js+2) & - call mpp_error (FATAL, module_name//'/get_grid_cell_vertices '//& - 'Size of argument "latb" is not consistent with the domain size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_vertices '//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select type(lonb) - type is (real(r4_kind)) - select type(latb) - type is (real(r4_kind)) - - !! use lonb, latb as r4 - select case(grid_version) - case(VERSION_GEOLON_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') - end if - select case(component) - case('ATM','LND') - allocate(buffer_r4(max(nlon,nlat)+1)) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer_r4(1:nlon+1)) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = buffer_r4(i) - enddo - enddo - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer_r4(1:nlat+1)) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = buffer_r4(j) - enddo - enddo - deallocate(buffer_r4) - case('OCN') - if (present(domain)) then - start = 1; nread = 1 - start(1) = is; start(2) = js - nread(1) = ie-is+2; nread(2) = je-js+2 - call read_data(gridfileobj, "geolon_vert_t", lonb, corner=start, edge_lengths=nread) - call read_data(gridfileobj, "geolat_vert_t", latb, corner=start, edge_lengths=nread) - else - call read_data(gridfileobj, "geolon_vert_t", lonb) - call read_data(gridfileobj, "geolat_vert_t", latb) - endif - end select - case(VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') - end if - select case(component) - case('ATM','LND') - allocate(buffer_r4(max(nlon,nlat)+1)) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer_r4(1:nlon+1)) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = buffer_r4(i) - enddo - enddo - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer_r4(1:nlat+1)) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = buffer_r4(j) - enddo - enddo - deallocate(buffer_r4) - case('OCN') - nlon=ie-is+1; nlat=je-js+1 - allocate (x_vert_t_r4(nlon,nlat,4), y_vert_t_r4(nlon,nlat,4) ) - call read_data(gridfileobj, 'x_vert_T', x_vert_t_r4) - call read_data(gridfileobj, 'y_vert_T', y_vert_t_r4) - lonb(1:nlon,1:nlat) = x_vert_t_r4(1:nlon,1:nlat,1) - lonb(nlon+1,1:nlat) = x_vert_t_r4(nlon,1:nlat,2) - lonb(1:nlon,nlat+1) = x_vert_t_r4(1:nlon,nlat,4) - lonb(nlon+1,nlat+1) = x_vert_t_r4(nlon,nlat,3) - latb(1:nlon,1:nlat) = y_vert_t_r4(1:nlon,1:nlat,1) - latb(nlon+1,1:nlat) = y_vert_t_r4(nlon,1:nlat,2) - latb(1:nlon,nlat+1) = y_vert_t_r4(1:nlon,nlat,4) - latb(nlon+1,nlat+1) = y_vert_t_r4(nlon,nlat,3) - deallocate(x_vert_t_r4, y_vert_t_r4) - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - ! get the name of the grid file for the component and tile - tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) - call open_grid_file(tilefileobj, grid_dir//tilefile) - if(PRESENT(domain)) then - call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) - start = 1; nread = 1 - start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 - start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 - allocate(tmp_r4(nread(1), nread(2)) ) - call read_data(tilefileobj, "x", tmp_r4, corner=start, edge_lengths=nread) - do j = 1, je-js+2 - do i = 1, ie-is+2 - lonb(i,j) = tmp_r4(2*i-1,2*j-1) - enddo - enddo - call read_data(tilefileobj, "y", tmp_r4, corner=start, edge_lengths=nread) - do j = 1, je-js+2 - do i = 1, ie-is+2 - latb(i,j) = tmp_r4(2*i-1,2*j-1) - enddo - enddo - else - allocate(tmp_r4(2*nlon+1,2*nlat+1)) - call read_data(tilefileobj, "x", tmp_r4) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = tmp_r4(2*i-1,2*j-1) - end do - end do - call read_data(tilefileobj, "y", tmp_r4) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = tmp_r4(2*i-1,2*j-1) - end do - end do - endif - deallocate(tmp_r4) - call close_file(tilefileobj) - end select ! end grid_version - end select ! end latb r4 - - type is (real(r8_kind)) - select type(latb) - type is (real(r8_kind)) - - !! use lonb, latb as r8 - select case(grid_version) - case(VERSION_GEOLON_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') - end if - select case(component) - case('ATM','LND') - allocate(buffer_r8(max(nlon,nlat)+1)) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer_r8(1:nlon+1)) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = buffer_r8(i) - enddo - enddo - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer_r8(1:nlat+1)) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = buffer_r8(j) - enddo - enddo - deallocate(buffer_r8) - case('OCN') - if (present(domain)) then - start = 1; nread = 1 - start(1) = is; start(2) = js - nread(1) = ie-is+2; nread(2) = je-js+2 - call read_data(gridfileobj, "geolon_vert_t", lonb, corner=start, edge_lengths=nread) - call read_data(gridfileobj, "geolat_vert_t", latb, corner=start, edge_lengths=nread) - else - call read_data(gridfileobj, "geolon_vert_t", lonb) - call read_data(gridfileobj, "geolat_vert_t", latb) - endif - end select - case(VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') - end if - select case(component) - case('ATM','LND') - allocate(buffer_r8(max(nlon,nlat)+1)) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer_r8(1:nlon+1)) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = buffer_r8(i) - enddo - enddo - call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer_r8(1:nlat+1)) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = buffer_r8(j) - enddo - enddo - deallocate(buffer_r8) - case('OCN') - nlon=ie-is+1; nlat=je-js+1 - allocate (x_vert_t_r8(nlon,nlat,4), y_vert_t_r8(nlon,nlat,4) ) - call read_data(gridfileobj, 'x_vert_T', x_vert_t_r8) - call read_data(gridfileobj, 'y_vert_T', y_vert_t_r8) - lonb(1:nlon,1:nlat) = x_vert_t_r8(1:nlon,1:nlat,1) - lonb(nlon+1,1:nlat) = x_vert_t_r8(nlon,1:nlat,2) - lonb(1:nlon,nlat+1) = x_vert_t_r8(1:nlon,nlat,4) - lonb(nlon+1,nlat+1) = x_vert_t_r8(nlon,nlat,3) - latb(1:nlon,1:nlat) = y_vert_t_r8(1:nlon,1:nlat,1) - latb(nlon+1,1:nlat) = y_vert_t_r8(nlon,1:nlat,2) - latb(1:nlon,nlat+1) = y_vert_t_r8(1:nlon,nlat,4) - latb(nlon+1,nlat+1) = y_vert_t_r8(nlon,nlat,3) - deallocate(x_vert_t_r8, y_vert_t_r8) - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - ! get the name of the grid file for the component and tile - tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) - call open_grid_file(tilefileobj, grid_dir//tilefile) - if(PRESENT(domain)) then - call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) - start = 1; nread = 1 - start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 - start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 - allocate(tmp_r8(nread(1), nread(2)) ) - call read_data(tilefileobj, "x", tmp_r8, corner=start, edge_lengths=nread) - do j = 1, je-js+2 - do i = 1, ie-is+2 - lonb(i,j) = tmp_r8(2*i-1,2*j-1) - enddo - enddo - call read_data(tilefileobj, "y", tmp_r8, corner=start, edge_lengths=nread) - do j = 1, je-js+2 - do i = 1, ie-is+2 - latb(i,j) = tmp_r8(2*i-1,2*j-1) - enddo - enddo - else - allocate(tmp_r8(2*nlon+1,2*nlat+1)) - call read_data(tilefileobj, "x", tmp_r8) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = tmp_r8(2*i-1,2*j-1) - end do - end do - call read_data(tilefileobj, "y", tmp_r8) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = tmp_r8(2*i-1,2*j-1) - end do - end do - endif - deallocate(tmp_r8) - call close_file(tilefileobj) - end select ! end grid_version - end select ! end latb r8 - end select ! end lonb -end subroutine get_grid_cell_vertices_2D - -!> @brief returns cell vertices for the specified model component and mosaic tile number for -!! an unstructured domain -subroutine get_grid_cell_vertices_UG(component, tile, lonb, latb, SG_domain, UG_domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - real, intent(inout) :: lonb(:,:),latb(:,:) ! The second dimension is 4 - type(domain2d) , intent(in) :: SG_domain !< Structured domain - type(domainUG) , intent(in) :: UG_domain !< Unstructured domain - integer :: is, ie, js, je, i, j - real, allocatable :: SG_lonb(:,:), SG_latb(:,:), tmp(:,:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_lonb(is:ie+1, js:je+1)) - allocate(SG_latb(is:ie+1, js:je+1)) - allocate(tmp(is:ie,js:je,4)) - call get_grid_cell_vertices_2D(component, tile, SG_lonb, SG_latb, SG_domain) - do j = js, je - do i = is, ie - tmp(i,j,1) = SG_lonb(i,j) - tmp(i,j,2) = SG_lonb(i+1,j) - tmp(i,j,3) = SG_lonb(i+1,j+1) - tmp(i,j,4) = SG_lonb(i,j+1) - enddo - enddo - call mpp_pass_SG_to_UG(UG_domain, tmp, lonb) - do j = js, je - do i = is, ie - tmp(i,j,1) = SG_latb(i,j) - tmp(i,j,2) = SG_latb(i+1,j) - tmp(i,j,3) = SG_latb(i+1,j+1) - tmp(i,j,4) = SG_latb(i,j+1) - enddo - enddo - call mpp_pass_SG_to_UG(UG_domain, tmp, latb) - - - deallocate(SG_lonb, SG_latb, tmp) -end subroutine get_grid_cell_vertices_UG - -!> @brief returns grid cell centers given model component and mosaic tile number -subroutine get_grid_cell_centers_1D(component, tile, glon, glat) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - real, intent(inout) :: glon(:),glat(:) !< Grid cell centers - - integer :: nlon, nlat - integer :: start(4), nread(4) - real, allocatable :: tmp(:,:) - character(len=MAX_FILE) :: tilefile - type(FmsNetcdfFile_t) :: tilefileobj - - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - if (size(glon(:))/=nlon) & - call mpp_error (FATAL, module_name//'/get_grid_cell_centers_1D '//& - 'Size of argument "glon" is not consistent with the grid size') - if (size(glat(:))/=nlat) & - call mpp_error (FATAL, module_name//'/get_grid_cell_centers_1D '//& - 'Size of argument "glat" is not consistent with the grid size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_centers_1D '//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select case(grid_version) - case(VERSION_GEOLON_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_1D): grid_spec does not exist') - end if - select case(trim(component)) - case('ATM','LND') - call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), glon) - call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), glat) - case('OCN') - call read_data(gridfileobj, "gridlon_t", glon) - call read_data(gridfileobj, "gridlat_t", glat) - end select - case(VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_1D): grid_spec does not exist') - end if - select case(trim(component)) - case('ATM','LND') - call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), glon) - call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), glat) - case('OCN') - call read_data(gridfileobj, "grid_x_T", glon) - call read_data(gridfileobj, "grid_y_T", glat) - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) - ! get the name of the grid file for the component and tile - tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) - call open_grid_file(tilefileobj, grid_dir//tilefile) - - start = 1; nread = 1 - nread(1) = 2*nlon+1; start(2) = 2 - allocate( tmp(2*nlon+1,1) ) - call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) - glon(1:nlon) = tmp(2:2*nlon:2,1) - deallocate(tmp) - allocate(tmp(1, 2*nlat+1)) - - start = 1; nread = 1 - nread(2) = 2*nlat+1; start(1) = 2 - call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) - glat(1:nlat) = tmp(1,2:2*nlat:2) - deallocate(tmp) - call close_file(tilefileobj) - end select -end subroutine get_grid_cell_centers_1D - -!> @brief returns grid cell centers given model component and mosaic tile number -subroutine get_grid_cell_centers_2D(component, tile, lon, lat, domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - real, intent(inout) :: lon(:,:),lat(:,:) !< Grid cell centers - type(domain2d), intent(in), optional :: domain !< Domain - ! local vars - integer :: nlon, nlat - integer :: i,j - real, allocatable :: buffer(:),tmp(:,:) - integer :: is,ie,js,je ! boundaries of our domain - integer :: i0,j0 ! offsets for coordinates - integer :: isg, jsg - integer :: start(4), nread(4) - character(len=MAX_FILE) :: tilefile - type(FmsNetcdfFile_t) :: tilefileobj - - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - if (present(domain)) then - call mpp_get_compute_domain(domain,is,ie,js,je) - else - is = 1 ; ie = nlon - js = 1 ; je = nlat - !--- domain normally should be present - call mpp_error (NOTE, module_name//'/get_grid_cell_centers '//& - 'domain is not present, global data will be read') - endif - i0 = -is+1; j0 = -js+1 - - ! verify that lon and lat sizes are consistent with the size of domain - if (size(lon,1)/=ie-is+1.or.size(lon,2)/=je-js+1) & - call mpp_error (FATAL, module_name//'/get_grid_cell_centers '//& - 'Size of array "lon" is not consistent with the domain size') - if (size(lat,1)/=ie-is+1.or.size(lat,2)/=je-js+1) & - call mpp_error (FATAL, module_name//'/get_grid_cell_centers '//& - 'Size of array "lat" is not consistent with the domain size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_vertices '//& - 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select case(grid_version) - case(VERSION_GEOLON_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_2D): grid_spec does not exist') - end if - select case (trim(component)) - case('ATM','LND') - allocate(buffer(max(nlon,nlat))) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), buffer(1:nlon)) - do j = js,je - do i = is,ie - lon(i+i0,j+j0) = buffer(i) - enddo - enddo - call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), buffer(1:nlat)) - do j = js,je - do i = is,ie - lat(i+i0,j+j0) = buffer(j) - enddo - enddo - deallocate(buffer) - case('OCN') - call read_data(gridfileobj, 'geolon_t', lon) - call read_data(gridfileobj, 'geolat_t', lat) - end select - case(VERSION_X_T) - if (.not. grid_spec_exists) then - call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_2D): grid_spec does not exist') - end if - select case(trim(component)) - case('ATM','LND') - allocate(buffer(max(nlon,nlat))) - ! read coordinates of grid cell vertices - call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), buffer(1:nlon)) - do j = js,je - do i = is,ie - lon(i+i0,j+j0) = buffer(i) - enddo - enddo - call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), buffer(1:nlat)) - do j = js,je - do i = is,ie - lat(i+i0,j+j0) = buffer(j) - enddo - enddo - deallocate(buffer) - case('OCN') - call read_data(gridfileobj, 'x_T', lon) - call read_data(gridfileobj, 'y_T', lat) - end select - case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) ! mosaic grid file - ! get the name of the grid file for the component and tile - tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) - call open_grid_file(tilefileobj, grid_dir//tilefile) - - if(PRESENT(domain)) then - call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) - start = 1; nread = 1 - start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 - start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 - allocate(tmp(nread(1), nread(2))) - call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) - do j = 1, je-js+1 - do i = 1, ie-is+1 - lon(i,j) = tmp(2*i,2*j) - enddo - enddo - call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) - do j = 1, je-js+1 - do i = 1, ie-is+1 - lat(i,j) = tmp(2*i,2*j) - enddo - enddo - else - allocate(tmp(2*nlon+1,2*nlat+1)) - call read_data(tilefileobj, 'x', tmp) - do j = js,je - do i = is,ie - lon(i+i0,j+j0) = tmp(2*i,2*j) - end do - end do - call read_data(tilefileobj, 'y', tmp) - do j = js,je - do i = is,ie - lat(i+i0,j+j0) = tmp(2*i,2*j) - end do - end do - deallocate(tmp) - endif - call close_file(tilefileobj) - end select -end subroutine get_grid_cell_centers_2D - -!> @brief returns grid cell centers given model component and mosaic tile number -!! for unstructured domain -subroutine get_grid_cell_centers_UG(component, tile, lon, lat, SG_domain, UG_domain) - character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) - integer, intent(in) :: tile !< Tile number - real, intent(inout) :: lon(:),lat(:) !< Grid cell centers - type(domain2d) , intent(in) :: SG_domain !< Structured domain - type(domainUG) , intent(in) :: UG_domain !< Unstructured domain - integer :: is, ie, js, je - real, allocatable :: SG_lon(:,:), SG_lat(:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_lon(is:ie, js:je)) - allocate(SG_lat(is:ie, js:je)) - call get_grid_cell_centers_2D(component, tile, SG_lon, SG_lat, SG_domain) - call mpp_pass_SG_to_UG(UG_domain, SG_lon, lon) - call mpp_pass_SG_to_UG(UG_domain, SG_lat, lat) - deallocate(SG_lon, SG_lat) -end subroutine get_grid_cell_centers_UG - !> @brief given a model component, a layout, and (optionally) a halo size, returns a !! domain for current processor subroutine define_cube_mosaic(component, domain, layout, halo, maskmap) @@ -1504,6 +417,9 @@ subroutine define_cube_mosaic(component, domain, layout, halo, maskmap) deallocate(is2,ie2,js2,je2) end subroutine define_cube_mosaic +#include "grid2_r4.fh" +#include "grid2_r8.fh" + end module grid2_mod !> @} ! close documentation grouping diff --git a/mosaic2/include/grid2.inc b/mosaic2/include/grid2.inc new file mode 100644 index 0000000000..6717ba530a --- /dev/null +++ b/mosaic2/include/grid2.inc @@ -0,0 +1,802 @@ +!*********************************************************************** +!* 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 return grid cell area for the specified model component and tile +subroutine GET_GRID_CELL_AREA_SG_(component, tile, cellarea, domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer , intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_) , intent(inout) :: cellarea(:,:) !< Cell area + type(domain2d) , intent(in), optional :: domain !< Domain + + ! local vars + integer :: nlon, nlat + real(kind=r8_kind), allocatable :: glonb(:,:), glatb(:,:) + real(kind=r8_kind), allocatable :: cellarea8(:,:) + + allocate(cellarea8(size(cellarea,1),size(cellarea,2))) + + select case(grid_version) + case(VERSION_GEOLON_T,VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_area_SG): grid_spec does not exist') + end if + select case(trim(component)) + case('LND') + call read_data(gridfileobj, 'AREA_LND_CELL', cellarea8) + case('ATM','OCN') + call read_data(gridfileobj, 'AREA_'//trim(uppercase(component)),cellarea8) + case default + call mpp_error(FATAL, module_name//'/get_grid_cell_area'//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + end select + ! convert area to m2 + cellarea = real( cellarea8*4.0_r8_kind*PI*RADIUS**2, FMS_MOS_KIND_) + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) + if (present(domain)) then + call mpp_get_compute_domain(domain,xsize=nlon,ysize=nlat) + else + call get_grid_size(component,tile,nlon,nlat) + endif + allocate(glonb(nlon+1,nlat+1),glatb(nlon+1,nlat+1)) + call get_grid_cell_vertices(component, tile, glonb, glatb, domain) + if (great_circle_algorithm) then + call calc_mosaic_grid_great_circle_area(glonb*PI/180.0_r8_kind, glatb*PI/180_r8_kind, cellarea8) + cellarea=real(cellarea8,FMS_MOS_KIND_) + else + call calc_mosaic_grid_area(glonb*PI/180.0_r8_kind, glatb*PI/180_r8_kind, cellarea8) + cellarea=real(cellarea8,FMS_MOS_KIND_) + end if + deallocate(glonb,glatb) + end select + + deallocate(cellarea8) + +end subroutine GET_GRID_CELL_AREA_SG_ + +!> @brief get the area of the component per grid cell +subroutine GET_GRID_COMP_AREA_SG_(component,tile,area,domain) + character(len=*) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: area(:,:) !< Area of grid cell + type(domain2d), intent(in), optional :: domain !< Domain + ! local vars + integer :: n_xgrid_files ! number of exchange grid files in the mosaic + integer :: siz(2), nxgrid + integer :: i,j,m,n + integer, allocatable :: i1(:), j1(:), i2(:), j2(:) + real(kind=r8_kind), allocatable :: xgrid_area(:) + real(kind=r8_kind), allocatable :: rmask(:,:) + character(len=MAX_NAME) :: & + xgrid_name, & ! name of the variable holding xgrid names + tile_name, & ! name of the tile + mosaic_name ! name of the mosaic + character(len=MAX_FILE) :: & + tilefile, & ! name of current tile file + xgrid_file ! name of the current xgrid file + character(len=4096) :: attvalue + character(len=MAX_NAME), allocatable :: nest_tile_name(:) + integer :: is,ie,js,je ! boundaries of our domain + integer :: i0, j0 ! offsets for x and y, respectively + integer :: num_nest_tile, ntiles + logical :: is_nest + integer :: found_xgrid_files ! how many xgrid files we actually found in the grid spec + integer :: ibegin, iend, bsize, l + type(FmsNetcdfFile_t) :: tilefileobj, xgrid_fileobj + + real(r8_kind),allocatable :: area8(:,:) + + allocate(area8(size(area,1),size(area,2))) + + select case (grid_version ) + case(VERSION_GEOLON_T,VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') + end if + select case(component) + case('ATM') + call read_data(gridfileobj,'AREA_ATM',area8) + case('OCN') + allocate(rmask(size(area8,1),size(area8,2))) + call read_data(gridfileobj,'AREA_OCN',area8) + call read_data(gridfileobj,'wet', rmask) + area = real(area8*rmask, FMS_MOS_KIND_) + deallocate(rmask) + case('LND') + call read_data(gridfileobj,'AREA_LND',area8) + case default + call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + end select + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) ! mosaic gridspec + select case (component) + case ('ATM') + ! just read the grid cell area and return + call get_grid_cell_area(component,tile,area8) + area = real(area8, FMS_MOS_KIND_) + return + case ('LND') + xgrid_name = 'aXl_file' + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') + end if + call read_data(gridfileobj, 'lnd_mosaic', mosaic_name) + tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) + case ('OCN') + xgrid_name = 'aXo_file' + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') + end if + call read_data(gridfileobj, 'ocn_mosaic', mosaic_name) + tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) + case default + call mpp_error(FATAL, module_name//'/get_grid_comp_area'//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + end select + ! get the boundaries of the requested domain + if(present(domain)) then + call mpp_get_compute_domain(domain,is,ie,js,je) + i0 = 1-is ; j0=1-js + else + call get_grid_size(component,tile,ie,je) + is = 1 ; i0 = 0 + js = 1 ; j0 = 0 + endif + if (size(area8,1)/=ie-is+1.or.size(area8,2)/=je-js+1) & + call mpp_error(FATAL, module_name//'/get_grid_comp_area '//& + 'size of the output argument "area" is not consistent with the domain') + + ! find the nest tile + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') + end if + call read_data(gridfileobj, 'atm_mosaic', mosaic_name) + call get_grid_ntiles('atm', ntiles) + allocate(nest_tile_name(ntiles)) + num_nest_tile = 0 + do n = 1, ntiles + tilefile = read_file_name(mosaic_fileobj(1), 'gridfiles', n) + call open_grid_file(tilefileobj, grid_dir//tilefile) + if (global_att_exists(tilefileobj, "nest_grid")) then + call get_global_attribute(tilefileobj, "nest_grid", attvalue) + if(trim(attvalue) == "TRUE") then + num_nest_tile = num_nest_tile + 1 + nest_tile_name(num_nest_tile) = trim(mosaic_name)//'_tile'//char(n+ichar('0')) + else if(trim(attvalue) .NE. "FALSE") then + call mpp_error(FATAL,module_name//'/get_grid_comp_area value of global attribute nest_grid in file'//& + trim(tilefile)//' should be TRUE or FALSE') + endif + end if + call close_file(tilefileobj) + end do + area8(:,:) = 0.0_r8_kind + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_comp_area_SG): grid_spec does not exist') + end if + if(variable_exists(gridfileobj,xgrid_name)) then + ! get the number of the exchange-grid files + call get_variable_size(gridfileobj,xgrid_name,siz) + n_xgrid_files = siz(2) + found_xgrid_files = 0 + ! loop through all exchange grid files + do n = 1, n_xgrid_files + ! get the name of the current exchange grid file + xgrid_file = read_file_name(gridfileobj,xgrid_name,n) + call open_grid_file(xgrid_fileobj, grid_dir//xgrid_file) + ! skip the rest of the loop if the name of the current tile isn't found + ! in the file name, but check this only if there is more than 1 tile + if(n_xgrid_files>1) then + if(index(xgrid_file,trim(tile_name))==0) cycle + endif + found_xgrid_files = found_xgrid_files + 1 + !---make sure the atmosphere grid is not a nested grid + is_nest = .false. + do m = 1, num_nest_tile + if(index(xgrid_file, trim(nest_tile_name(m))) .NE. 0) then + is_nest = .true. + exit + end if + end do + if(is_nest) cycle + + ! finally read the exchange grid + nxgrid = get_mosaic_xgrid_size(xgrid_fileobj) + if(nxgrid < BUFSIZE) then + allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), xgrid_area(nxgrid)) + else + allocate(i1(BUFSIZE), j1(BUFSIZE), i2(BUFSIZE), j2(BUFSIZE), xgrid_area(BUFSIZE)) + endif + ibegin = 1 + do l = 1,nxgrid,BUFSIZE + bsize = min(BUFSIZE, nxgrid-l+1) + iend = ibegin + bsize - 1 + call get_mosaic_xgrid(xgrid_fileobj, i1(1:bsize), j1(1:bsize), i2(1:bsize), j2(1:bsize), & + xgrid_area(1:bsize), ibegin, iend) + ! and sum the exchange grid areas + do m = 1, bsize + i = i2(m); j = j2(m) + if (iie) cycle + if (jje) cycle + area8(i+i0,j+j0) = area8(i+i0,j+j0) + xgrid_area(m) + end do + ibegin = iend + 1 + enddo + deallocate(i1, j1, i2, j2, xgrid_area) + call close_file(xgrid_fileobj) + enddo + if (found_xgrid_files == 0) & + call mpp_error(FATAL, 'get_grid_comp_area no xgrid files were found for component '& + //trim(component)//' (mosaic name is '//trim(mosaic_name)//')') + + endif + deallocate(nest_tile_name) + end select ! version + ! convert area to m2 + area = real(area8*4.0_r8_kind*PI*RADIUS**2, FMS_MOS_KIND_) + + deallocate(area8) + +end subroutine GET_GRID_COMP_AREA_SG_ + +!> @brief return grid cell area for the specified model component and tile on an +!! unstructured domain +subroutine GET_GRID_CELL_AREA_UG_(component, tile, cellarea, SG_domain, UG_domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer , intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: cellarea(:) !< Cell area + type(domain2d) , intent(in) :: SG_domain !< Structured Domain + type(domainUG) , intent(in) :: UG_domain !< Unstructured Domain + integer :: is, ie, js, je + real(kind=FMS_MOS_KIND_), allocatable :: SG_area(:,:) + + call mpp_get_compute_domain(SG_domain, is, ie, js, je) + allocate(SG_area(is:ie, js:je)) + call get_grid_cell_area(component, tile, SG_area, SG_domain) + call mpp_pass_SG_to_UG(UG_domain, SG_area, cellarea) + deallocate(SG_area) +end subroutine GET_GRID_CELL_AREA_UG_ + +!> @brief get the area of the component per grid cell for an unstructured domain +subroutine GET_GRID_COMP_AREA_UG_(component, tile, area, SG_domain, UG_domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer , intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: area(:) !< Area of the component + type(domain2d) , intent(in) :: SG_domain !< Structured domain + type(domainUG) , intent(in) :: UG_domain !< Unstructured domain + integer :: is, ie, js, je + real(kind=FMS_MOS_KIND_), allocatable :: SG_area(:,:) + + call mpp_get_compute_domain(SG_domain, is, ie, js, je) + allocate(SG_area(is:ie, js:je)) + call get_grid_comp_area(component, tile, SG_area, SG_domain) + call mpp_pass_SG_to_UG(UG_domain, SG_area, area) + deallocate(SG_area) + +end subroutine GET_GRID_COMP_AREA_UG_ + +!> @brief returns arrays of global grid cell boundaries for given model component and +!! mosaic tile number. +subroutine GET_GRID_CELL_VERTICES_1D_(component, tile, glonb, glatb) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_),intent(inout) :: glonb(:),glatb(:) !< Grid cell vertices + + integer :: nlon, nlat + integer :: start(4), nread(4) + real(kind=FMS_MOS_KIND_), allocatable :: tmp(:,:), x_vert_t(:,:,:), y_vert_t(:,:,:) + character(len=MAX_FILE) :: tilefile + type(FmsNetcdfFile_t) :: tilefileobj + + call get_grid_size_for_one_tile(component, tile, nlon, nlat) + if (size(glonb(:))/=nlon+1) & + call mpp_error (FATAL, module_name//'/get_grid_cell_vertices_1D '//& + 'Size of argument "glonb" is not consistent with the grid size') + if (size(glatb(:))/=nlat+1) & + call mpp_error (FATAL, module_name//'/get_grid_cell_vertices_1D '//& + 'Size of argument "glatb" is not consistent with the grid size') + if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then + call mpp_error(FATAL, module_name//'/get_grid_cell_vertices_1D '//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + endif + + select case(grid_version) + case(VERSION_GEOLON_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_1D): grid_spec does not exist') + end if + select case(trim(component)) + case('ATM','LND') + call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), glonb) + call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), glatb) + case('OCN') + call read_data(gridfileobj, "gridlon_vert_t", glonb) + call read_data(gridfileobj, "gridlat_vert_t", glatb) + end select + case(VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_1D): grid_spec does not exist') + end if + select case(trim(component)) + case('ATM','LND') + call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), glonb) + call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), glatb) + case('OCN') + allocate (x_vert_t(nlon,1,2), y_vert_t(1,nlat,2) ) + start = 1; nread = 1 + nread(1) = nlon; nread(2) = 1; start(3) = 1 + call read_data(gridfileobj, "x_vert_T", x_vert_t(:,:,1), corner=start, edge_lengths=nread) + nread(1) = nlon; nread(2) = 1; start(3) = 2 + call read_data(gridfileobj, "x_vert_T", x_vert_t(:,:,2), corner=start, edge_lengths=nread) + + nread(1) = 1; nread(2) = nlat; start(3) = 1 + call read_data(gridfileobj, "y_vert_T", y_vert_t(:,:,1), corner=start, edge_lengths=nread) + nread(1) = 1; nread(2) = nlat; start(3) = 4 + call read_data(gridfileobj, "y_vert_T", y_vert_t(:,:,2), corner=start, edge_lengths=nread) + glonb(1:nlon) = x_vert_t(1:nlon,1,1) + glonb(nlon+1) = x_vert_t(nlon,1,2) + glatb(1:nlat) = y_vert_t(1,1:nlat,1) + glatb(nlat+1) = y_vert_t(1,nlat,2) + deallocate(x_vert_t, y_vert_t) + end select + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) + ! get the name of the grid file for the component and tile + tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) + call open_grid_file(tilefileobj, grid_dir//tilefile) + + start = 1; nread = 1 + nread(1) = 2*nlon+1 + allocate( tmp(2*nlon+1,1) ) + call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) + glonb(1:nlon+1) = tmp(1:2*nlon+1:2,1) + deallocate(tmp) + allocate(tmp(1,2*nlat+1)) + + start = 1; nread = 1 + nread(2) = 2*nlat+1 + call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) + glatb(1:nlat+1) = tmp(1,1:2*nlat+1:2) + deallocate(tmp) + call close_file(tilefileobj) + end select +end subroutine GET_GRID_CELL_VERTICES_1D_ + +!> @brief returns cell vertices for the specified model component and mosaic tile number +subroutine GET_GRID_CELL_VERTICES_2D_(component, tile, lonb, latb, domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: lonb(:,:),latb(:,:) !< Cell vertices + type(domain2d), optional, intent(in) :: domain !< Domain + + ! local vars + integer :: nlon, nlat + integer :: i,j + real(kind=FMS_MOS_KIND_), allocatable :: buffer(:), tmp(:,:), x_vert_t(:,:,:), y_vert_t(:,:,:) + integer :: is,ie,js,je ! boundaries of our domain + integer :: i0,j0 ! offsets for coordinates + integer :: isg, jsg + integer :: start(4), nread(4) + character(len=MAX_FILE) :: tilefile + type(FmsNetcdfFile_t) :: tilefileobj + + call get_grid_size_for_one_tile(component, tile, nlon, nlat) + + if (present(domain)) then + call mpp_get_compute_domain(domain,is,ie,js,je) + else + is = 1 ; ie = nlon + js = 1 ; je = nlat + !--- domain normally should be present + call mpp_error (NOTE, module_name//'/get_grid_cell_vertices '//& + 'domain is not present, global data will be read') + endif + i0 = -is+1; j0 = -js+1 + + ! verify that lonb and latb sizes are consistent with the size of domain + if (size(lonb,1)/=ie-is+2.or.size(lonb,2)/=je-js+2) & + call mpp_error (FATAL, module_name//'/get_grid_cell_vertices '//& + 'Size of argument "lonb" is not consistent with the domain size') + if (size(latb,1)/=ie-is+2.or.size(latb,2)/=je-js+2) & + call mpp_error (FATAL, module_name//'/get_grid_cell_vertices '//& + 'Size of argument "latb" is not consistent with the domain size') + if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then + call mpp_error(FATAL, module_name//'/get_grid_cell_vertices '//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + endif + + !! use lonb, latb as r4 + select case(grid_version) + case(VERSION_GEOLON_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') + end if + select case(component) + case('ATM','LND') + allocate(buffer(max(nlon,nlat)+1)) + ! read coordinates of grid cell vertices + call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer(1:nlon+1)) + do j = js, je+1 + do i = is, ie+1 + lonb(i+i0,j+j0) = buffer(i) + enddo + enddo + call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer(1:nlat+1)) + do j = js, je+1 + do i = is, ie+1 + latb(i+i0,j+j0) = buffer(j) + enddo + enddo + deallocate(buffer) + case('OCN') + if (present(domain)) then + start = 1; nread = 1 + start(1) = is; start(2) = js + nread(1) = ie-is+2; nread(2) = je-js+2 + call read_data(gridfileobj, "geolon_vert_t", lonb, corner=start, edge_lengths=nread) + call read_data(gridfileobj, "geolat_vert_t", latb, corner=start, edge_lengths=nread) + else + call read_data(gridfileobj, "geolon_vert_t", lonb) + call read_data(gridfileobj, "geolat_vert_t", latb) + endif + end select + case(VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_vertices_2D): grid_spec does not exist') + end if + select case(component) + case('ATM','LND') + allocate(buffer(max(nlon,nlat)+1)) + ! read coordinates of grid cell vertices + call read_data(gridfileobj, 'xb'//lowercase(component(1:1)), buffer(1:nlon+1)) + do j = js, je+1 + do i = is, ie+1 + lonb(i+i0,j+j0) = buffer(i) + enddo + enddo + call read_data(gridfileobj, 'yb'//lowercase(component(1:1)), buffer(1:nlat+1)) + do j = js, je+1 + do i = is, ie+1 + latb(i+i0,j+j0) = buffer(j) + enddo + enddo + deallocate(buffer) + case('OCN') + nlon=ie-is+1; nlat=je-js+1 + allocate (x_vert_t(nlon,nlat,4), y_vert_t(nlon,nlat,4) ) + call read_data(gridfileobj, 'x_vert_T', x_vert_t) + call read_data(gridfileobj, 'y_vert_T', y_vert_t) + lonb(1:nlon,1:nlat) = x_vert_t(1:nlon,1:nlat,1) + lonb(nlon+1,1:nlat) = x_vert_t(nlon,1:nlat,2) + lonb(1:nlon,nlat+1) = x_vert_t(1:nlon,nlat,4) + lonb(nlon+1,nlat+1) = x_vert_t(nlon,nlat,3) + latb(1:nlon,1:nlat) = y_vert_t(1:nlon,1:nlat,1) + latb(nlon+1,1:nlat) = y_vert_t(nlon,1:nlat,2) + latb(1:nlon,nlat+1) = y_vert_t(1:nlon,nlat,4) + latb(nlon+1,nlat+1) = y_vert_t(nlon,nlat,3) + deallocate(x_vert_t, y_vert_t) + end select + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) + ! get the name of the grid file for the component and tile + tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) + call open_grid_file(tilefileobj, grid_dir//tilefile) + if(PRESENT(domain)) then + call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) + start = 1; nread = 1 + start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 + start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 + allocate(tmp(nread(1), nread(2)) ) + call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) + do j = 1, je-js+2 + do i = 1, ie-is+2 + lonb(i,j) = tmp(2*i-1,2*j-1) + enddo + enddo + call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) + do j = 1, je-js+2 + do i = 1, ie-is+2 + latb(i,j) = tmp(2*i-1,2*j-1) + enddo + enddo + else + allocate(tmp(2*nlon+1,2*nlat+1)) + call read_data(tilefileobj, "x", tmp) + do j = js, je+1 + do i = is, ie+1 + lonb(i+i0,j+j0) = tmp(2*i-1,2*j-1) + end do + end do + call read_data(tilefileobj, "y", tmp) + do j = js, je+1 + do i = is, ie+1 + latb(i+i0,j+j0) = tmp(2*i-1,2*j-1) + end do + end do + endif + deallocate(tmp) + call close_file(tilefileobj) + end select ! end grid_version + end subroutine GET_GRID_CELL_VERTICES_2D_ + +!> @brief returns cell vertices for the specified model component and mosaic tile number for +!! an unstructured domain +subroutine GET_GRID_CELL_VERTICES_UG_(component, tile, lonb, latb, SG_domain, UG_domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: lonb(:,:),latb(:,:) ! The second dimension is 4 + type(domain2d) , intent(in) :: SG_domain !< Structured domain + type(domainUG) , intent(in) :: UG_domain !< Unstructured domain + integer :: is, ie, js, je, i, j + real(kind=FMS_MOS_KIND_), allocatable :: SG_lonb(:,:), SG_latb(:,:), tmp(:,:,:) + + call mpp_get_compute_domain(SG_domain, is, ie, js, je) + allocate(SG_lonb(is:ie+1, js:je+1)) + allocate(SG_latb(is:ie+1, js:je+1)) + allocate(tmp(is:ie,js:je,4)) + call get_grid_cell_vertices(component, tile, SG_lonb, SG_latb, SG_domain) + do j = js, je + do i = is, ie + tmp(i,j,1) = SG_lonb(i,j) + tmp(i,j,2) = SG_lonb(i+1,j) + tmp(i,j,3) = SG_lonb(i+1,j+1) + tmp(i,j,4) = SG_lonb(i,j+1) + enddo + enddo + call mpp_pass_SG_to_UG(UG_domain, tmp, lonb) + do j = js, je + do i = is, ie + tmp(i,j,1) = SG_latb(i,j) + tmp(i,j,2) = SG_latb(i+1,j) + tmp(i,j,3) = SG_latb(i+1,j+1) + tmp(i,j,4) = SG_latb(i,j+1) + enddo + enddo + call mpp_pass_SG_to_UG(UG_domain, tmp, latb) + + + deallocate(SG_lonb, SG_latb, tmp) +end subroutine GET_GRID_CELL_VERTICES_UG_ + +!> @brief returns grid cell centers given model component and mosaic tile number +subroutine GET_GRID_CELL_CENTERS_1D_(component, tile, glon, glat) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: glon(:),glat(:) !< Grid cell centers + + integer :: nlon, nlat + integer :: start(4), nread(4) + real(kind=FMS_MOS_KIND_), allocatable :: tmp(:,:) + character(len=MAX_FILE) :: tilefile + type(FmsNetcdfFile_t) :: tilefileobj + + call get_grid_size_for_one_tile(component, tile, nlon, nlat) + if (size(glon(:))/=nlon) & + call mpp_error (FATAL, module_name//'/get_grid_cell_centers_1D '//& + 'Size of argument "glon" is not consistent with the grid size') + if (size(glat(:))/=nlat) & + call mpp_error (FATAL, module_name//'/get_grid_cell_centers_1D '//& + 'Size of argument "glat" is not consistent with the grid size') + if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then + call mpp_error(FATAL, module_name//'/get_grid_cell_centers_1D '//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + endif + + select case(grid_version) + case(VERSION_GEOLON_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_1D): grid_spec does not exist') + end if + select case(trim(component)) + case('ATM','LND') + call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), glon) + call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), glat) + case('OCN') + call read_data(gridfileobj, "gridlon_t", glon) + call read_data(gridfileobj, "gridlat_t", glat) + end select + case(VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_1D): grid_spec does not exist') + end if + select case(trim(component)) + case('ATM','LND') + call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), glon) + call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), glat) + case('OCN') + call read_data(gridfileobj, "grid_x_T", glon) + call read_data(gridfileobj, "grid_y_T", glat) + end select + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) + ! get the name of the grid file for the component and tile + tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) + call open_grid_file(tilefileobj, grid_dir//tilefile) + + start = 1; nread = 1 + nread(1) = 2*nlon+1; start(2) = 2 + allocate( tmp(2*nlon+1,1) ) + call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) + glon(1:nlon) = tmp(2:2*nlon:2,1) + deallocate(tmp) + allocate(tmp(1, 2*nlat+1)) + + start = 1; nread = 1 + nread(2) = 2*nlat+1; start(1) = 2 + call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) + glat(1:nlat) = tmp(1,2:2*nlat:2) + deallocate(tmp) + call close_file(tilefileobj) + end select +end subroutine GET_GRID_CELL_CENTERS_1D_ + +!> @brief returns grid cell centers given model component and mosaic tile number +subroutine GET_GRID_CELL_CENTERS_2D_(component, tile, lon, lat, domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: lon(:,:),lat(:,:) !< Grid cell centers + type(domain2d), intent(in), optional :: domain !< Domain + ! local vars + integer :: nlon, nlat + integer :: i,j + real(kind=FMS_MOS_KIND_), allocatable :: buffer(:),tmp(:,:) + integer :: is,ie,js,je ! boundaries of our domain + integer :: i0,j0 ! offsets for coordinates + integer :: isg, jsg + integer :: start(4), nread(4) + character(len=MAX_FILE) :: tilefile + type(FmsNetcdfFile_t) :: tilefileobj + + call get_grid_size_for_one_tile(component, tile, nlon, nlat) + if (present(domain)) then + call mpp_get_compute_domain(domain,is,ie,js,je) + else + is = 1 ; ie = nlon + js = 1 ; je = nlat + !--- domain normally should be present + call mpp_error (NOTE, module_name//'/get_grid_cell_centers '//& + 'domain is not present, global data will be read') + endif + i0 = -is+1; j0 = -js+1 + + ! verify that lon and lat sizes are consistent with the size of domain + if (size(lon,1)/=ie-is+1.or.size(lon,2)/=je-js+1) & + call mpp_error (FATAL, module_name//'/get_grid_cell_centers '//& + 'Size of array "lon" is not consistent with the domain size') + if (size(lat,1)/=ie-is+1.or.size(lat,2)/=je-js+1) & + call mpp_error (FATAL, module_name//'/get_grid_cell_centers '//& + 'Size of array "lat" is not consistent with the domain size') + if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then + call mpp_error(FATAL, module_name//'/get_grid_cell_vertices '//& + 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') + endif + + select case(grid_version) + case(VERSION_GEOLON_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_2D): grid_spec does not exist') + end if + select case (trim(component)) + case('ATM','LND') + allocate(buffer(max(nlon,nlat))) + ! read coordinates of grid cell vertices + call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), buffer(1:nlon)) + do j = js,je + do i = is,ie + lon(i+i0,j+j0) = buffer(i) + enddo + enddo + call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), buffer(1:nlat)) + do j = js,je + do i = is,ie + lat(i+i0,j+j0) = buffer(j) + enddo + enddo + deallocate(buffer) + case('OCN') + call read_data(gridfileobj, 'geolon_t', lon) + call read_data(gridfileobj, 'geolat_t', lat) + end select + case(VERSION_X_T) + if (.not. grid_spec_exists) then + call mpp_error(FATAL, 'grid2_mod(get_grid_cell_centers_2D): grid_spec does not exist') + end if + select case(trim(component)) + case('ATM','LND') + allocate(buffer(max(nlon,nlat))) + ! read coordinates of grid cell vertices + call read_data(gridfileobj, 'xt'//lowercase(component(1:1)), buffer(1:nlon)) + do j = js,je + do i = is,ie + lon(i+i0,j+j0) = buffer(i) + enddo + enddo + call read_data(gridfileobj, 'yt'//lowercase(component(1:1)), buffer(1:nlat)) + do j = js,je + do i = is,ie + lat(i+i0,j+j0) = buffer(j) + enddo + enddo + deallocate(buffer) + case('OCN') + call read_data(gridfileobj, 'x_T', lon) + call read_data(gridfileobj, 'y_T', lat) + end select + case(VERSION_OCN_MOSAIC_FILE, VERSION_GRIDFILES) ! mosaic grid file + ! get the name of the grid file for the component and tile + tilefile = read_file_name(mosaic_fileobj(get_component_number(trim(component))), 'gridfiles',tile) + call open_grid_file(tilefileobj, grid_dir//tilefile) + + if(PRESENT(domain)) then + call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) + start = 1; nread = 1 + start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 + start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 + allocate(tmp(nread(1), nread(2))) + call read_data(tilefileobj, "x", tmp, corner=start, edge_lengths=nread) + do j = 1, je-js+1 + do i = 1, ie-is+1 + lon(i,j) = tmp(2*i,2*j) + enddo + enddo + call read_data(tilefileobj, "y", tmp, corner=start, edge_lengths=nread) + do j = 1, je-js+1 + do i = 1, ie-is+1 + lat(i,j) = tmp(2*i,2*j) + enddo + enddo + else + allocate(tmp(2*nlon+1,2*nlat+1)) + call read_data(tilefileobj, 'x', tmp) + do j = js,je + do i = is,ie + lon(i+i0,j+j0) = tmp(2*i,2*j) + end do + end do + call read_data(tilefileobj, 'y', tmp) + do j = js,je + do i = is,ie + lat(i+i0,j+j0) = tmp(2*i,2*j) + end do + end do + deallocate(tmp) + endif + call close_file(tilefileobj) + end select +end subroutine GET_GRID_CELL_CENTERS_2D_ + +!> @brief returns grid cell centers given model component and mosaic tile number +!! for unstructured domain +subroutine GET_GRID_CELL_CENTERS_UG_(component, tile, lon, lat, SG_domain, UG_domain) + character(len=*), intent(in) :: component !< Component model (atm, lnd, ocn) + integer, intent(in) :: tile !< Tile number + real(kind=FMS_MOS_KIND_), intent(inout) :: lon(:),lat(:) !< Grid cell centers + type(domain2d) , intent(in) :: SG_domain !< Structured domain + type(domainUG) , intent(in) :: UG_domain !< Unstructured domain + integer :: is, ie, js, je + real(kind=FMS_MOS_KIND_), allocatable :: SG_lon(:,:), SG_lat(:,:) + + call mpp_get_compute_domain(SG_domain, is, ie, js, je) + allocate(SG_lon(is:ie, js:je)) + allocate(SG_lat(is:ie, js:je)) + call get_grid_cell_centers(component, tile, SG_lon, SG_lat, SG_domain) + call mpp_pass_SG_to_UG(UG_domain, SG_lon, lon) + call mpp_pass_SG_to_UG(UG_domain, SG_lat, lat) + deallocate(SG_lon, SG_lat) +end subroutine GET_GRID_CELL_CENTERS_UG_ + +!> @} +! close documentation grouping diff --git a/mosaic2/include/grid2_r4.fh b/mosaic2/include/grid2_r4.fh new file mode 100644 index 0000000000..07b069fdbb --- /dev/null +++ b/mosaic2/include/grid2_r4.fh @@ -0,0 +1,59 @@ +!*********************************************************************** +!* 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 include file for grid2_mod to generate subroutines/functions for r4_kind arguments + +!> @addtogroup grid2_mod +!> @{ + +#undef FMS_MOS_KIND_ +#define FMS_MOS_KIND_ r4_kind + +#undef GET_GRID_CELL_AREA_SG_ +#define GET_GRID_CELL_AREA_SG_ get_grid_cell_area_SG_r4 + +#undef GET_GRID_COMP_AREA_SG_ +#define GET_GRID_COMP_AREA_SG_ get_grid_comp_area_SG_r4 + +#undef GET_GRID_CELL_AREA_UG_ +#define GET_GRID_CELL_AREA_UG_ get_grid_cell_area_UG_r4 + +#undef GET_GRID_COMP_AREA_UG_ +#define GET_GRID_COMP_AREA_UG_ get_grid_comp_area_UG_r4 + +#undef GET_GRID_CELL_VERTICES_1D_ +#define GET_GRID_CELL_VERTICES_1D_ get_grid_cell_vertices_1D_r4 + +#undef GET_GRID_CELL_VERTICES_2D_ +#define GET_GRID_CELL_VERTICES_2D_ get_grid_cell_vertices_2D_r4 + +#undef GET_GRID_CELL_VERTICES_UG_ +#define GET_GRID_CELL_VERTICES_UG_ get_grid_cell_vertices_UG_r4 + +#undef GET_GRID_CELL_CENTERS_1D_ +#define GET_GRID_CELL_CENTERS_1D_ get_grid_cell_centers_1D_r4 + +#undef GET_GRID_CELL_CENTERS_2D_ +#define GET_GRID_CELL_CENTERS_2D_ get_grid_cell_centers_2D_r4 + +#undef GET_GRID_CELL_CENTERS_UG_ +#define GET_GRID_CELL_CENTERS_UG_ get_grid_cell_centers_UG_r4 + +#include "grid2.inc" +!> @} diff --git a/mosaic2/include/grid2_r8.fh b/mosaic2/include/grid2_r8.fh new file mode 100644 index 0000000000..c9cbf9eb23 --- /dev/null +++ b/mosaic2/include/grid2_r8.fh @@ -0,0 +1,59 @@ +!*********************************************************************** +!* 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 include file for grid2_mod to generate subroutines/functions for r8_kind arguments + +!> @addtogroup grid2_mod +!> @{ + +#undef FMS_MOS_KIND_ +#define FMS_MOS_KIND_ r8_kind + +#undef GET_GRID_CELL_AREA_SG_ +#define GET_GRID_CELL_AREA_SG_ get_grid_cell_area_SG_r8 + +#undef GET_GRID_CELL_AREA_UG_ +#define GET_GRID_CELL_AREA_UG_ get_grid_cell_area_UG_r8 + +#undef GET_GRID_COMP_AREA_SG_ +#define GET_GRID_COMP_AREA_SG_ get_grid_comp_area_SG_r8 + +#undef GET_GRID_COMP_AREA_UG_ +#define GET_GRID_COMP_AREA_UG_ get_grid_comp_area_UG_r8 + +#undef GET_GRID_CELL_VERTICES_1D_ +#define GET_GRID_CELL_VERTICES_1D_ get_grid_cell_vertices_1D_r8 + +#undef GET_GRID_CELL_VERTICES_2D_ +#define GET_GRID_CELL_VERTICES_2D_ get_grid_cell_vertices_2D_r8 + +#undef GET_GRID_CELL_VERTICES_UG_ +#define GET_GRID_CELL_VERTICES_UG_ get_grid_cell_vertices_UG_r8 + +#undef GET_GRID_CELL_CENTERS_1D_ +#define GET_GRID_CELL_CENTERS_1D_ get_grid_cell_centers_1D_r8 + +#undef GET_GRID_CELL_CENTERS_2D_ +#define GET_GRID_CELL_CENTERS_2D_ get_grid_cell_centers_2D_r8 + +#undef GET_GRID_CELL_CENTERS_UG_ +#define GET_GRID_CELL_CENTERS_UG_ get_grid_cell_centers_UG_r8 + +#include "grid2.inc" +!> @} diff --git a/mosaic2/include/mosaic2.inc b/mosaic2/include/mosaic2.inc new file mode 100644 index 0000000000..2da3d136db --- /dev/null +++ b/mosaic2/include/mosaic2.inc @@ -0,0 +1,167 @@ +!*********************************************************************** +!* 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 Get exchange grid information from mosaic xgrid file. +!> Example usage: +!! +!! call get_mosaic_xgrid(fileobj, nxgrid, i1, j1, i2, j2, area) +!! + subroutine GET_MOSAIC_XGRID_(fileobj, i1, j1, i2, j2, area, ibegin, iend) + type(FmsNetcdfFile_t), intent(in) :: fileobj !> The file that contains exchange grid information. + integer, intent(inout) :: i1(:), j1(:), i2(:), j2(:) !> i and j indices for grids 1 and 2 + real(kind=FMS_MOS_KIND_), intent(inout) :: area(:) !> area of the exchange grid. The area is scaled to + !! represent unit earth area + integer, optional, intent(in) :: ibegin, iend + + integer :: start(4), nread(4), istart + real(kind=FMS_MOS_KIND_), dimension(2, size(i1(:))) :: tile1_cell, tile2_cell + integer :: nxgrid, n + real(kind=r8_kind) :: garea + real(kind=r8_kind) :: get_global_area + + garea = get_global_area() !< get_global_area returns a r8_kind + + ! When start and nread present, make sure nread(1) is the same as the size of the data + if(present(ibegin) .and. present(iend)) then + istart = ibegin + nxgrid = iend - ibegin + 1 + if(nxgrid .NE. size(i1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i1(:))") + if(nxgrid .NE. size(j1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j1(:))") + if(nxgrid .NE. size(i2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i2(:))") + if(nxgrid .NE. size(j2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j2(:))") + if(nxgrid .NE. size(area(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(area(:))") + else + istart = 1 + nxgrid = size(i1(:)) + endif + + start = 1; nread = 1 + start(1) = istart; nread(1) = nxgrid + + call read_data(fileobj, 'xgrid_area', area, corner=start, edge_lengths=nread) + + start = 1; nread = 1 + nread(1) = 2 + start(2) = istart; nread(2) = nxgrid + + call read_data(fileobj, 'tile1_cell', tile1_cell, corner=start, edge_lengths=nread) + call read_data(fileobj, 'tile2_cell', tile2_cell, corner=start, edge_lengths=nread) + + do n = 1, nxgrid + i1(n) = int(tile1_cell(1,n)) + j1(n) = int(tile1_cell(2,n)) + i2(n) = int(tile2_cell(1,n)) + j2(n) = int(tile2_cell(2,n)) + area(n) = real( real(area(n),r8_kind)/garea, FMS_MOS_KIND_ ) + end do + + return + + end subroutine GET_MOSAIC_XGRID_ + !############################################################################### + !> @brief Calculate grid cell area. + !> Calculate the grid cell area. The purpose of this routine is to make + !! sure the consistency between model grid area and exchange grid area. + !> @param lon geographical longitude of grid cell vertices. + !> @param lat geographical latitude of grid cell vertices. + !> @param[inout] area grid cell area. + !>
Example usage: + !! call calc_mosaic_grid_area(lon, lat, area) + subroutine CALC_MOSAIC_GRID_AREA_(lon, lat, area) + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lon + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lat + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(inout) :: area + integer :: nlon, nlat + + real(r8_kind) :: area_r8(size(area,1),size(area,2)) + + area_r8=real(area,r8_kind) + + nlon = size(area,1) + nlat = size(area,2) + ! make sure size of lon, lat and area are consitency + if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) & + call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1") + if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) & + call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1") + + ! get_grid_area only accepts double precision data + call get_grid_area( nlon, nlat, real(lon,r8_kind), real(lat,r8_kind), area_r8) + + area=real(area_r8,FMS_MOS_KIND_) + + end subroutine CALC_MOSAIC_GRID_AREA_ + !############################################################################### + !> @brief Calculate grid cell area using great cirlce algorithm + !> Calculate the grid cell area. The purpose of this routine is to make + !! sure the consistency between model grid area and exchange grid area. + !> @param lon geographical longitude of grid cell vertices. + !> @param lat geographical latitude of grid cell vertices. + !> @param[inout] area grid cell area. + !>
Example usage: + !! call calc_mosaic_grid_great_circle_area(lon, lat, area) + subroutine CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_(lon, lat, area) + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lon + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lat + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(inout) :: area + integer :: nlon, nlat + + real(r8_kind) :: area_r8(size(area,1),size(area,2)) + + nlon = size(area,1) + nlat = size(area,2) + ! make sure size of lon, lat and area are consitency + if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) & + call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1") + if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) & + call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1") + + ! get_grid_great_circle_area only accepts r8_kind arguments + call get_grid_great_circle_area( nlon, nlat, real(lon,r8_kind), real(lat,r8_kind), area_r8) + + area=real(area_r8, FMS_MOS_KIND_) + + end subroutine CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_ + !##################################################################### + !> This function check if a point (lon1,lat1) is inside a polygon (lon2(:), lat2(:)) + !! lon1, lat1, lon2, lat2 are in radians. + function IS_INSIDE_POLYGON_(lon1, lat1, lon2, lat2 ) + real(kind=FMS_MOS_KIND_), intent(in) :: lon1, lat1 + real(kind=FMS_MOS_KIND_), intent(in) :: lon2(:), lat2(:) + logical :: IS_INSIDE_POLYGON_ + integer :: npts, isinside + integer :: inside_a_polygon + + npts = size(lon2(:)) + + !> inside_a_polygon function only accepts r8_kind real variables + + isinside = inside_a_polygon(real(lon1,r8_kind), real(lat1,r8_kind), npts, real(lon2,r8_kind), real(lat2,r8_kind)) + if(isinside == 1) then + IS_INSIDE_POLYGON_ = .TRUE. + else + IS_INSIDE_POLYGON_ = .FALSE. + endif + + return + + end function IS_INSIDE_POLYGON_ +!> @} diff --git a/mosaic2/include/mosaic2_r4.fh b/mosaic2/include/mosaic2_r4.fh new file mode 100644 index 0000000000..fa663bec41 --- /dev/null +++ b/mosaic2/include/mosaic2_r4.fh @@ -0,0 +1,41 @@ +!*********************************************************************** +!* 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 include file for mosaic22_mod to generate subroutines/functions for r4_kind arguments + +!> @addtogroup mosaic2_mod +!> @{ + +#undef FMS_MOS_KIND_ +#define FMS_MOS_KIND_ r4_kind + +#undef GET_MOSAIC_XGRID_ +#define GET_MOSAIC_XGRID_ get_mosaic_xgrid_r4 + +#undef CALC_MOSAIC_GRID_AREA_ +#define CALC_MOSAIC_GRID_AREA_ calc_mosaic_grid_area_r4 + +#undef CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_ +#define CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_ calc_mosaic_grid_great_circle_area_r4 + +#undef IS_INSIDE_POLYGON_ +#define IS_INSIDE_POLYGON_ is_inside_polygon_r4 + +#include "mosaic2.inc" +!> @} diff --git a/mosaic2/include/mosaic2_r8.fh b/mosaic2/include/mosaic2_r8.fh new file mode 100644 index 0000000000..fa410a245a --- /dev/null +++ b/mosaic2/include/mosaic2_r8.fh @@ -0,0 +1,41 @@ +!*********************************************************************** +!* 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 include file for mosaic2_mod to generate subroutines/functions for r8_kind arguments + +!> @addtogroup mosaic2_mod +!> @{ + +#undef FMS_MOS_KIND_ +#define FMS_MOS_KIND_ r8_kind + +#undef GET_MOSAIC_XGRID_ +#define GET_MOSAIC_XGRID_ get_mosaic_xgrid_r8 + +#undef CALC_MOSAIC_GRID_AREA_ +#define CALC_MOSAIC_GRID_AREA_ calc_mosaic_grid_area_r8 + +#undef CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_ +#define CALC_MOSAIC_GRID_GREAT_CIRCLE_AREA_ calc_mosaic_grid_great_circle_area_r8 + +#undef IS_INSIDE_POLYGON_ +#define IS_INSIDE_POLYGON_ is_inside_polygon_r8 + +#include "mosaic2.inc" +!> @} diff --git a/mosaic2/mosaic2.F90 b/mosaic2/mosaic2.F90 index 8908ea6b4e..324d57f148 100644 --- a/mosaic2/mosaic2.F90 +++ b/mosaic2/mosaic2.F90 @@ -38,7 +38,7 @@ module mosaic2_mod use constants_mod, only : PI, RADIUS use fms2_io_mod, only : FmsNetcdfFile_t, open_file, close_file, get_dimension_size use fms2_io_mod, only : read_data, variable_exists -use platform_mod +use platform_mod, only : r4_kind, r8_kind implicit none private @@ -66,6 +66,28 @@ module mosaic2_mod public :: calc_mosaic_grid_great_circle_area public :: is_inside_polygon + +interface get_mosaic_xgrid + module procedure get_mosaic_xgrid_r4 + module procedure get_mosaic_xgrid_r8 +end interface get_mosaic_xgrid + +interface calc_mosaic_grid_area + module procedure calc_mosaic_grid_area_r4 + module procedure calc_mosaic_grid_area_r8 +end interface calc_mosaic_grid_area + +interface calc_mosaic_grid_great_circle_area + module procedure calc_mosaic_grid_great_circle_area_r4 + module procedure calc_mosaic_grid_great_circle_area_r8 +end interface calc_mosaic_grid_great_circle_area + +interface is_inside_polygon + module procedure is_inside_polygon_r4 + module procedure is_inside_polygon_r8 +end interface is_inside_polygon + + logical :: module_is_initialized = .true. ! Include variable "version" to be written to log file. #include @@ -103,83 +125,6 @@ function get_mosaic_xgrid_size(fileobj) return end function get_mosaic_xgrid_size -!####################################################################### -!> @brief Get exchange grid information from mosaic xgrid file. -!> Example usage: -!! -!! call get_mosaic_xgrid(fileobj, nxgrid, i1, j1, i2, j2, area) -!! - subroutine get_mosaic_xgrid(fileobj, i1, j1, i2, j2, area, ibegin, iend) - type(FmsNetcdfFile_t), intent(in) :: fileobj !> The file that contains exchange grid information. - integer, intent(inout) :: i1(:), j1(:), i2(:), j2(:) !> i and j indices for grids 1 and 2 - class(*), intent(inout) :: area(:) !> area of the exchange grid. The area is scaled to - !! represent unit earth area - integer, optional, intent(in) :: ibegin, iend - - integer :: start(4), nread(4), istart - real, dimension(2, size(i1(:))) :: tile1_cell, tile2_cell - integer :: nxgrid, n - real :: garea - real :: get_global_area - - garea = get_global_area() - - ! When start and nread present, make sure nread(1) is the same as the size of the data - if(present(ibegin) .and. present(iend)) then - istart = ibegin - nxgrid = iend - ibegin + 1 - if(nxgrid .NE. size(i1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i1(:))") - if(nxgrid .NE. size(j1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j1(:))") - if(nxgrid .NE. size(i2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i2(:))") - if(nxgrid .NE. size(j2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j2(:))") - if(nxgrid .NE. size(area(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(area(:))") - else - istart = 1 - nxgrid = size(i1(:)) - endif - - start = 1; nread = 1 - start(1) = istart; nread(1) = nxgrid - - select type(area) - type is (real(r4_kind)) - call read_data(fileobj, 'xgrid_area', area, corner=start, edge_lengths=nread) - type is (real(r8_kind)) - call read_data(fileobj, 'xgrid_area', area, corner=start, edge_lengths=nread) - class default - call mpp_error(FATAL,"get_mosaic_xgrid: invalid data type for area, must be real(r4_kind) or real(r8_kind)") - end select - - start = 1; nread = 1 - nread(1) = 2 - start(2) = istart; nread(2) = nxgrid - - select type(area) - type is (real(r4_kind)) - call read_data(fileobj, 'tile1_cell', tile1_cell, corner=start, edge_lengths=nread) - call read_data(fileobj, 'tile2_cell', tile2_cell, corner=start, edge_lengths=nread) - type is (real(r8_kind)) - call read_data(fileobj, 'tile1_cell', tile1_cell, corner=start, edge_lengths=nread) - call read_data(fileobj, 'tile2_cell', tile2_cell, corner=start, edge_lengths=nread) - end select - - do n = 1, nxgrid - i1(n) = int(tile1_cell(1,n)) - j1(n) = int(tile1_cell(2,n)) - i2(n) = int(tile2_cell(1,n)) - j2(n) = int(tile2_cell(2,n)) - select type(area) - type is (real(r4_kind)) - area(n) = real(area(n)/garea, r4_kind) - type is (real(r8_kind)) - area(n) = real(area(n)/garea, r8_kind) - end select - end do - - return - - end subroutine get_mosaic_xgrid - !############################################################################### !> Get number of tiles in the mosaic_file. !> @param fileobj mosaic file object @@ -430,172 +375,50 @@ function transfer_to_model_index(istart, iend, refine_ratio) return end function transfer_to_model_index - - !############################################################################### - !> @brief Calculate grid cell area. - !> Calculate the grid cell area. The purpose of this routine is to make - !! sure the consistency between model grid area and exchange grid area. - !> @param lon geographical longitude of grid cell vertices. - !> @param lat geographical latitude of grid cell vertices. - !> @param[inout] area grid cell area. - !>
Example usage: - !! call calc_mosaic_grid_area(lon, lat, area) - subroutine calc_mosaic_grid_area(lon, lat, area) - class(*), dimension(:,:), intent(in) :: lon - class(*), dimension(:,:), intent(in) :: lat - class(*), dimension(:,:), intent(inout) :: area - integer :: nlon, nlat - logical :: valid_types = .false. - - nlon = size(area,1) - nlat = size(area,2) - ! make sure size of lon, lat and area are consitency - if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1") - if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1") - select type (lon) - type is (real(r4_kind)) - select type (lat) - type is (real(r4_kind)) - select type(area) - type is (real(r4_kind)) - call get_grid_area( nlon, nlat, real(lon, r8_kind), real(lat, r8_kind), real(area, r8_kind)) - valid_types = .true. - end select - end select - type is (real(r8_kind)) - select type (lat) - type is (real(r8_kind)) - select type(area) - type is (real(r8_kind)) - call get_grid_area( nlon, nlat, lon, lat, area) - valid_types = .true. - end select - end select - end select - - if(.not. valid_types) call mpp_error(FATAL, "calc_mosaic_grid_area: invalid types given." & - //" Arguments must be all r4_kind or r8_kind") - - end subroutine calc_mosaic_grid_area - - !############################################################################### - !> @brief Calculate grid cell area using great cirlce algorithm - !> Calculate the grid cell area. The purpose of this routine is to make - !! sure the consistency between model grid area and exchange grid area. - !> @param lon geographical longitude of grid cell vertices. - !> @param lat geographical latitude of grid cell vertices. - !> @param[inout] area grid cell area. - !>
Example usage: - !! call calc_mosaic_grid_great_circle_area(lon, lat, area) - subroutine calc_mosaic_grid_great_circle_area(lon, lat, area) - class(*), dimension(:,:), intent(in) :: lon - class(*), dimension(:,:), intent(in) :: lat - class(*), dimension(:,:), intent(inout) :: area - integer :: nlon, nlat - logical :: valid_types = .false. - - nlon = size(area,1) - nlat = size(area,2) - ! make sure size of lon, lat and area are consitency - if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1") - if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1") - - select type (lon) - type is (real(r4_kind)) - select type (lat) - type is (real(r4_kind)) - select type(area) - type is (real(r4_kind)) - call get_grid_great_circle_area( nlon, nlat, real(lon, r8_kind), real(lat, r8_kind), real(area, r8_kind)) - valid_types = .true. - end select - end select - type is (real(r8_kind)) - select type (lat) - type is (real(r8_kind)) - select type(area) - type is (real(r8_kind)) - call get_grid_great_circle_area( nlon, nlat, lon, lat, area) - valid_types = .true. - end select - end select - end select - - if(.not. valid_types) call mpp_error(FATAL, "calc_mosaic_grid_area: invalid types given." & - //" Arguments must be all r4_kind or r8_kind") - - end subroutine calc_mosaic_grid_great_circle_area - - !##################################################################### - !> This function check if a point (lon1,lat1) is inside a polygon (lon2(:), lat2(:)) - !! lon1, lat1, lon2, lat2 are in radians. - function is_inside_polygon(lon1, lat1, lon2, lat2 ) - real, intent(in) :: lon1, lat1 - real, intent(in) :: lon2(:), lat2(:) - logical :: is_inside_polygon - integer :: npts, isinside - integer :: inside_a_polygon - - npts = size(lon2(:)) - - isinside = inside_a_polygon(lon1, lat1, npts, lon2, lat2) - if(isinside == 1) then - is_inside_polygon = .TRUE. - else - is_inside_polygon = .FALSE. - endif - - return - - end function is_inside_polygon - - function parse_string(string, set, sval) - character(len=*), intent(in) :: string - character(len=*), intent(in) :: set - character(len=*), intent(out) :: sval(:) - integer :: parse_string - integer :: nelem, length, first, last - - nelem = size(sval(:)) - length = len_trim(string) - - first = 1; last = 0 - parse_string = 0 - - do while(first .LE. length) - parse_string = parse_string + 1 - if(parse_string>nelem) then - call mpp_error(FATAL, "mosaic_mod(parse_string) : number of element is greater than size(value(:))") - endif - last = first - 1 + scan(string(first:length), set) - if(last == first-1 ) then ! not found, end of string - sval(parse_string) = string(first:length) +!##################################################################### +function parse_string(string, set, sval) + character(len=*), intent(in) :: string + character(len=*), intent(in) :: set + character(len=*), intent(out) :: sval(:) + integer :: parse_string + integer :: nelem, length, first, last + + nelem = size(sval(:)) + length = len_trim(string) + + first = 1; last = 0 + parse_string = 0 + + do while(first .LE. length) + parse_string = parse_string + 1 + if(parse_string>nelem) then + call mpp_error(FATAL, "mosaic_mod(parse_string) : number of element is greater than size(sval(:))") + endif + last = first - 1 + scan(string(first:length), set) + if(last == first-1 ) then ! not found, end of string + value(parse_string) = string(first:length) exit - else + else if(last <= first) then - call mpp_error(FATAL, "mosaic_mod(parse_string) : last <= first") + call mpp_error(FATAL, "mosaic_mod(parse_string) : last <= first") endif sval(parse_string) = string(first:(last-1)) first = last + 1 ! scan to make sure the next is not the character in the set do while (first == last+1) - last = first - 1 + scan(string(first:length), set) - if(last == first) then - first = first+1 - else - exit - endif + last = first - 1 + scan(string(first:length), set) + if(last == first) then + first = first+1 + else + exit + endif end do - endif - enddo + endif + enddo - return + return - end function parse_string +end function parse_string !############################################################################# !> Gets the name of a mosaic tile grid file @@ -603,29 +426,31 @@ end function parse_string !> @param fileobj mosaic file object !> @param domain current domain !> @param tile_count optional count of tiles - subroutine get_mosaic_tile_grid(grid_file, fileobj, domain, tile_count) - character(len=*), intent(out) :: grid_file - type(FmsNetcdfFile_t), intent(in) :: fileobj - type(domain2D), intent(in) :: domain - integer, intent(in), optional :: tile_count - integer :: tile, ntileMe - integer, dimension(:), allocatable :: tile_id - character(len=256), allocatable :: filelist(:) - integer :: ntiles - - ntiles = get_mosaic_ntiles(fileobj) - allocate(filelist(ntiles)) - tile = 1 - if(present(tile_count)) tile = tile_count - ntileMe = mpp_get_current_ntile(domain) - allocate(tile_id(ntileMe)) - tile_id = mpp_get_tile_id(domain) - call read_data(fileobj, "gridfiles", filelist) - grid_file = 'INPUT/'//trim(filelist(tile_id(tile))) - deallocate(tile_id, filelist) - - end subroutine get_mosaic_tile_grid - +subroutine get_mosaic_tile_grid(grid_file, fileobj, domain, tile_count) + character(len=*), intent(out) :: grid_file + type(FmsNetcdfFile_t), intent(in) :: fileobj + type(domain2D), intent(in) :: domain + integer, intent(in), optional :: tile_count + integer :: tile, ntileMe + integer, dimension(:), allocatable :: tile_id + character(len=256), allocatable :: filelist(:) + integer :: ntiles + + ntiles = get_mosaic_ntiles(fileobj) + allocate(filelist(ntiles)) + tile = 1 + if(present(tile_count)) tile = tile_count + ntileMe = mpp_get_current_ntile(domain) + allocate(tile_id(ntileMe)) + tile_id = mpp_get_tile_id(domain) + call read_data(fileobj, "gridfiles", filelist) + grid_file = 'INPUT/'//trim(filelist(tile_id(tile))) + deallocate(tile_id, filelist) + +end subroutine get_mosaic_tile_grid + +#include "mosaic2_r4.fh" +#include "mosaic2_r8.fh" end module mosaic2_mod !> @} diff --git a/test_fms/Makefile.am b/test_fms/Makefile.am index 742d76b7a2..230ad1b164 100644 --- a/test_fms/Makefile.am +++ b/test_fms/Makefile.am @@ -25,9 +25,9 @@ ACLOCAL_AMFLAGS = -I m4 # Make targets will be run in each subdirectory. Order is significant. SUBDIRS = astronomy coupler diag_manager data_override exchange monin_obukhov drifters \ -mosaic interpolator fms mpp mpp_io time_interp time_manager horiz_interp \ +mosaic2 interpolator fms mpp mpp_io time_interp time_manager horiz_interp topography \ field_manager axis_utils affinity fms2_io parser string_utils sat_vapor_pres tracer_manager \ -random_numbers diag_integral +random_numbers diag_integral column_diagnostics tridiagonal # testing utility scripts to distribute EXTRA_DIST = test-lib.sh.in intel_coverage.sh.in tap-driver.sh diff --git a/test_fms/column_diagnostics/Makefile.am b/test_fms/column_diagnostics/Makefile.am new file mode 100644 index 0000000000..8c9f9b6d5a --- /dev/null +++ b/test_fms/column_diagnostics/Makefile.am @@ -0,0 +1,50 @@ +#*********************************************************************** +#* 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 an automake file for the test_fms/time_manager directory of the FMS +# package. + + +# Find the fms_mod.mod file. +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) + +# Link to the FMS library. +LDADD = $(top_builddir)/libFMS/libFMS.la + +# Build this test program. +check_PROGRAMS = test_column_diagnostics_r4 test_column_diagnostics_r8 + +# This is the source code for the test. +test_column_diagnostics_r4_SOURCES = test_column_diagnostics.F90 +test_column_diagnostics_r8_SOURCES = test_column_diagnostics.F90 + +test_column_diagnostics_r4_CPPFLAGS=-DTEST_CD_KIND_=4 -I$(AM_CPPFLAGS) +test_column_diagnostics_r8_CPPFLAGS=-DTEST_CD_KIND_=8 -I$(AM_CPPFLAGS) + +TEST_EXTENSIONS = .sh +SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) $(abs_top_srcdir)/test_fms/tap-driver.sh + +# Run the test program. +TESTS = test_column_diagnostics.sh + +# These files will be included in the distribution. +EXTRA_DIST = test_column_diagnostics.sh + +# Clean up +CLEANFILES = *.nml *.out* *.dpi *.spi *.dyn *.spl fort.* diff --git a/test_fms/column_diagnostics/test_column_diagnostics.F90 b/test_fms/column_diagnostics/test_column_diagnostics.F90 new file mode 100644 index 0000000000..cde97faa6f --- /dev/null +++ b/test_fms/column_diagnostics/test_column_diagnostics.F90 @@ -0,0 +1,191 @@ +!*********************************************************************** +!* 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 unit test for column_diagnostics_mod +!! @author MiKyung Lee +!! @email gfdl.climate.model.info@noaa.gov +!! @description This program mainly tests initialize_diagnostics_columns. +!! TODO: The current test only tests with 1 processor. A test that uses +!! domain decomposition is needed. +program test_column_diagnostics + + use column_diagnostics_mod + use fms_mod, only: fms_init + use mpp_mod, only: FATAL, mpp_error + use time_manager_mod, only: time_manager_init, time_type, set_time, set_calendar_type + use constants_mod, only : PI, DEG_TO_RAD + use platform_mod, only: r4_kind, r8_kind + + implicit none + + character(13), parameter :: mod_name='pemberley_mod' !< made up module name; Mr. Darcy's estate + integer, parameter :: num_diag_pts_latlon=2 !< number of diagnostics column described in terms of latlon coordinates + integer, parameter :: num_diag_pts_ij=2 !< number of diagnostics column describes in terms of i/j indices + integer :: global_i(num_diag_pts_ij) ! global i coordinates of the diagnostic column + integer :: global_j(num_diag_pts_ij) ! global j coordinates of the diagnostic column + real(TEST_CD_KIND_) :: global_lat_latlon(num_diag_pts_latlon)!< latitude value for the diagnostic column + real(TEST_CD_KIND_) :: global_lon_latlon(num_diag_pts_latlon)!< longitude value for the diagnostic columns + + integer, parameter :: nlatlon=6 !< number of latlon grid points + real(TEST_CD_KIND_) :: lonb_in(nlatlon,nlatlon) !< model longitude grid point + real(TEST_CD_KIND_) :: latb_in(nlatlon,nlatlon) !< model latitude point + logical :: do_column_diagnostics(nlatlon,nlatlon) !< out + + integer, parameter :: num_diag_pts=num_diag_pts_latlon + num_diag_pts_ij !< total number of diagnostics column + integer :: diag_i(num_diag_pts) !< out + integer :: diag_j(num_diag_pts) !< out + real(TEST_CD_KIND_) :: diag_lat(num_diag_pts) !< out + real(TEST_CD_KIND_) :: diag_lon(num_diag_pts) !< out + integer :: diag_units(num_diag_pts) + + integer, parameter :: lkind=TEST_CD_KIND_ !< local kind; either r4_kind or r8_kind + + call fms_init() + call time_manager_init() + call initialize_variables(0.0_lkind) !< set up input arrays + call column_diagnostics_init() !< initialize diagnostics column + call initialize_variables(0.01_lkind) !< set up input arrays; + call test_initialize_diagnostic_columns !< initialize diagnostics column + call test_column_diagnostics_header + +contains + !------------------------------------------! + subroutine initialize_variables(dlatlon) + + !> This subroutine initializes all the input arrays for intialize_diagnostic_columns + + implicit none + + real(lkind), intent(in) :: dlatlon !< in degrees; displace lat/lon grid by dlatlon + real(lkind) :: dlat, dlon + integer :: i + + !> lat lon coordinates in degrees; made up to match the diagnostic column coordinates +/- dlatlon + !! see initialize_diagnostic_columns. A-Grid coordinates + dlat=15.0_lkind !< randomly chosen value + dlon=15.0_lkind !< randomly chosen value + do i=1, nlatlon + lonb_in(i,:)=real(i,lkind)*dlat - 0.5_lkind*dlat + latb_in(:,i)=-90._lkind + real(i,lkind)*dlon -0.5_lkind*dlat + end do + + !> initialize_diagnostic_columns coordinates expects these values to be in degrees + global_lon_latlon(1)=lonb_in(2,1) + global_lon_latlon(2)=lonb_in(3,1) + global_lat_latlon(1)=latb_in(1,2) + global_lat_latlon(2)=latb_in(1,3) + global_i(1)=4 ; global_i(2)=5 + global_j(1)=4 ; global_j(2)=5 + + !> intialize_diagnostic_columns expects these values to be in radians + lonb_in=(lonb_in+dlatlon)*DEG_TO_RAD + latb_in=(latb_in+dlatlon)*DEG_TO_RAD + + + end subroutine initialize_variables + !------------------------------------------! + subroutine test_initialize_diagnostic_columns + + !> this subroutine tests intialize_diagnostics_columns + + implicit none + integer :: i + + integer :: i_answers(num_diag_pts), j_answers(num_diag_pts) + real(TEST_CD_KIND_) :: lon_answers(num_diag_pts), lat_answers(num_diag_pts) + + call initialize_diagnostic_columns(mod_name, num_diag_pts_latlon, num_diag_pts_ij, & + global_i, global_j, global_lat_latlon, global_lon_latlon, & + lonb_in, latb_in, do_column_diagnostics, & + diag_lon, diag_lat, diag_i, diag_j, diag_units) + + !> the edge points do not count + i_answers=(/2,3,4,5/) + j_answers=(/2,3,4,5/) + lon_answers=lonb_in(2:5,1)/DEG_TO_RAD + lat_answers=latb_in(1,2:5)/DEG_TO_RAD + + do i=1, num_diag_pts + call check_answers(i_answers(i), diag_i(i), 'test_initialize_diagnostics_column diag_i') + call check_answers(j_answers(i), diag_j(i), 'test_initialize_diagnostics_column diag_j') + call check_answers(lon_answers(i), diag_lon(i), 'test_initialize_diagnostics_column diag_lon') + call check_answers(lat_answers(i), diag_lat(i), 'test_initialize_diagnostics_column diag_lon') + end do + + end subroutine test_initialize_diagnostic_columns + !------------------------------------------! + subroutine test_column_diagnostics_header + + !> This subroutine only tests that column_diagnostics_header works + + implicit none + integer :: nn, diag_unit + type(time_type) :: Time + + diag_unit=45 !< will produce fort.45 file + call set_calendar_type(2) + Time=set_time(12,14,1) + do nn=1, num_diag_pts + call column_diagnostics_header(mod_name, diag_unit, Time, nn, diag_lon, diag_lat, diag_i, diag_j) + end do + + end subroutine test_column_diagnostics_header + !------------------------------------------! + subroutine check_answers(answer, myvalue, whoami) + + implicit none + class(*) :: answer + class(*) :: myvalue + character(*) :: whoami + + select type(answer) + type is ( integer ) + select type(myvalue) + type is( integer ) + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + type is( real(r4_kind) ) + select type( myvalue) + type is(real(r4_kind) ) + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + write(*,*) 'difference of', abs(answer-myvalue) + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + type is( real(r8_kind) ) + select type( myvalue) + type is(real(r4_kind) ) + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + write(*,*) 'difference of', abs(answer-myvalue) + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + end select + + end subroutine check_answers + !------------------------------------------! +end program test_column_diagnostics diff --git a/test_fms/column_diagnostics/test_column_diagnostics.sh b/test_fms/column_diagnostics/test_column_diagnostics.sh new file mode 100755 index 0000000000..909a539bfb --- /dev/null +++ b/test_fms/column_diagnostics/test_column_diagnostics.sh @@ -0,0 +1,29 @@ +#* 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/horiz_interp directory. + +# Copyright 2021 Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +# Prepare the directory to run the tests. +cat << EOF > input.nml +EOF + + +##### +test_expect_success "test_column_diagnostics r4" 'mpirun -n 1 ./test_column_diagnostics_r4' +test_expect_success "test_column_diagnostics r8" 'mpirun -n 1 ./test_column_diagnostics_r8' +test_done diff --git a/test_fms/coupler/Makefile.am b/test_fms/coupler/Makefile.am index 9fba580190..cf6be6a00b 100644 --- a/test_fms/coupler/Makefile.am +++ b/test_fms/coupler/Makefile.am @@ -31,6 +31,7 @@ LDADD = ${top_builddir}/libFMS/libFMS.la # Build this test program. check_PROGRAMS = test_coupler_2d_r4 test_coupler_2d_r8 \ test_coupler_3d_r4 test_coupler_3d_r8 \ + test_coupler_types_r4 test_coupler_types_r8 \ test_atmos_ocean_fluxes_r4 test_atmos_ocean_fluxes_r8 # This is the source code for the test. @@ -38,6 +39,8 @@ test_coupler_2d_r4_SOURCES = test_coupler_2d.F90 test_coupler_utils.inc test_coupler_2d_r8_SOURCES = test_coupler_2d.F90 test_coupler_utils.inc test_coupler_3d_r4_SOURCES = test_coupler_3d.F90 test_coupler_utils.inc test_coupler_3d_r8_SOURCES = test_coupler_3d.F90 test_coupler_utils.inc +test_coupler_types_r4_SOURCES = test_coupler_types.F90 test_coupler_utils.inc +test_coupler_types_r8_SOURCES = test_coupler_types.F90 test_coupler_utils.inc test_atmos_ocean_fluxes_r4_SOURCES = test_atmos_ocean_fluxes.F90 test_atmos_ocean_fluxes_r8_SOURCES = test_atmos_ocean_fluxes.F90 @@ -46,6 +49,8 @@ test_coupler_2d_r4_CPPFLAGS=-DFMS_CP_TEST_KIND_=r4_kind -DFMS_TEST_BC_TYPE_=bc_r test_coupler_2d_r8_CPPFLAGS=-DFMS_CP_TEST_KIND_=r8_kind -DFMS_TEST_BC_TYPE_=bc -I$(MODDIR) test_coupler_3d_r4_CPPFLAGS=-DFMS_CP_TEST_KIND_=r4_kind -DFMS_TEST_BC_TYPE_=bc_r4 -I$(MODDIR) test_coupler_3d_r8_CPPFLAGS=-DFMS_CP_TEST_KIND_=r8_kind -DFMS_TEST_BC_TYPE_=bc -I$(MODDIR) +test_coupler_types_r4_CPPFLAGS=-DFMS_CP_TEST_KIND_=r4_kind -DFMS_TEST_BC_TYPE_=bc_r4 -I$(MODDIR) +test_coupler_types_r8_CPPFLAGS=-DFMS_CP_TEST_KIND_=r8_kind -DFMS_TEST_BC_TYPE_=bc -I$(MODDIR) test_atmos_ocean_fluxes_r4_CPPFLAGS=-DFMS_CP_TEST_KIND_=r4_kind -DFMS_TEST_BC_TYPE_=bc_r4 -I$(MODDIR) test_atmos_ocean_fluxes_r8_CPPFLAGS=-DFMS_CP_TEST_KIND_=r8_kind -DFMS_TEST_BC_TYPE_=bc -I$(MODDIR) @@ -60,4 +65,4 @@ TESTS = test_coupler.sh EXTRA_DIST = test_coupler.sh # Clean up -CLEANFILES = input.nml *.nc* *.out *.dpi *.spi *.dyn *.spl diag_table* +CLEANFILES = input.nml *.nc* *.out *.dpi *.spi *.dyn *.spl *_table* INPUT/*.nc diff --git a/test_fms/coupler/test_coupler.sh b/test_fms/coupler/test_coupler.sh index ece1faffc5..030a33269a 100755 --- a/test_fms/coupler/test_coupler.sh +++ b/test_fms/coupler/test_coupler.sh @@ -1,5 +1,4 @@ #!/bin/sh - #*********************************************************************** #* GNU Lesser General Public License #* @@ -18,9 +17,8 @@ #* 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. +# execute tests in the test_fms/coupler directory. # Ed Hartnett 11/26/19 # Uriel Ramirez 07/22/20 @@ -28,21 +26,92 @@ # Set common test settings. . ../test-lib.sh -# Run the ongrid test case with 2 halos in x and y touch input.nml +# diag_table for test cat <<_EOF > diag_table test_coupler 1 1 1 0 0 0 - #output files - "coupler_types_test", 1, "days", 1, "days", "time" - + "coupler_types_bc2", 1, "days", 1, "days", "time" + "coupler_types_bc1", 1, "days", 1, "days", "time" #output variables - "test_coupler", "dat1", "dat1", "coupler_types_test", "all", .false., "none", 2 - "test_coupler", "dat2", "dat2", "coupler_types_test", "all", .false., "none", 2 + "test_coupler_types", "bc1_var2d_1", "bc1_variable_2d_1_min", "coupler_types_bc1", "all", "min", "none", 2 + "test_coupler_types", "bc1_var2d_2", "bc1_variable_2d_2_max", "coupler_types_bc1", "all", "max", "none", 2 + "test_coupler_types", "bc1_var3d_1", "bc1_variable_3d_1", "coupler_types_bc1", "all", "rms", "none", 2 + "test_coupler_types", "bc1_var3d_2", "bc1_variable_3d_2", "coupler_types_bc1", "all", "avg", "none", 2 + "test_coupler_types", "bc2_var2d_1", "bc2_variable_2d_1_min", "coupler_types_bc2", "all", "min", "none", 2 + "test_coupler_types", "bc2_var2d_2", "bc2_variable_2d_2_max", "coupler_types_bc2", "all", "max", "none", 2 + "test_coupler_types", "bc2_var3d_1", "bc2_variable_3d_1", "coupler_types_bc2", "all", "rms", "none", 2 + "test_coupler_types", "bc2_var3d_2", "bc2_variable_3d_2", "coupler_types_bc2", "all", "avg", "none", 2 +_EOF +# we'll just make both in case compiled with yaml support +cat <<_EOF > diag_table.yaml +title: test_coupler +base_date: 1 1 1 0 0 0 +diag_files: +- file_name: coupler_types_bc2 + filename_time: end + freq: 1 days + time_units: days + unlimdim: time + varlist: + - module: test_coupler_types + var_name: bc1_var2d_1 + output_name: bc1_variable_2d_1_min + reduction: min + - module: test_coupler_types + var_name: bc1_var2d_2 + output_name: bc1_variable_2d_2_max + reduction: max + - module: test_coupler_types + var_name: bc1_var3d_1 + output_name: bc1_variable_3d_1 + reduction: rms + - module: test_coupler_types + var_name: bc1_var3d_2 + output_name: bc1_variable_3d_2 + reduction: avg +- file_name: coupler_types_bc1 + filename_time: end + freq: 1 days + time_units: days + unlimdim: time + varlist: + - module: test_coupler_types + var_name: bc2_var2d_1 + output_name: bc2_variable_2d_1_min + reduction: min + - module: test_coupler_types + var_name: bc2_var2d_2 + output_name: bc2_variable_2d_2_max + reduction: max + - module: test_coupler_types + var_name: bc2_var3d_1 + output_name: bc2_variable_3d_1 + reduction: rms + - module: test_coupler_types + var_name: bc2_var3d_2 + output_name: bc2_variable_3d_2 + reduction: avg +_EOF + +cat <<_EOF > data_table +"ATM", "bc1_var2d_1", "bc1_variable_2d_1_min", "coupler_types_bc1.nc", .false., 300.0 _EOF +rm -rf INPUT +mkdir INPUT + + +test_expect_success "coupler types interfaces (r4_kind)" ' + mpirun -n 4 ./test_coupler_types_r4 +' + +test_expect_success "coupler types interfaces (r8_kind)" ' + mpirun -n 4 ./test_coupler_types_r8 +' + mkdir RESTART test_expect_success "coupler register restart 2D(r4_kind)" ' @@ -69,5 +138,4 @@ test_expect_success "test atmos_ocean_fluxes (r8_kind)" ' ' rm -rf RESTART - test_done diff --git a/test_fms/coupler/test_coupler_types.F90 b/test_fms/coupler/test_coupler_types.F90 new file mode 100644 index 0000000000..8beb9f4695 --- /dev/null +++ b/test_fms/coupler/test_coupler_types.F90 @@ -0,0 +1,317 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** +! Ryan Mulhall 8/23 + +!! defaults to ensure compilation +#ifndef FMS_CP_TEST_KIND_ +#define FMS_CP_TEST_KIND_ r8_kind +#endif + +#ifndef FMS_TEST_BC_TYPE_ +#define FMS_TEST_BC_TYPE_ bc +#endif + +!> Tests for the coupler types interfaces not tested in test_coupler_2d/3d +program test_coupler_types + +use fms_mod, only: fms_init, fms_end, stdout, string +use mpp_mod, only: mpp_error, mpp_pe, mpp_root_pe, FATAL, mpp_sync, mpp_init +use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_data_domain, domain1D +use mpp_domains_mod, only: mpp_domains_set_stack_size +use coupler_types_mod, only: coupler_3d_bc_type, coupler_2d_bc_type, coupler_1d_bc_type +use coupler_types_mod, only: coupler_type_copy, coupler_type_spawn, coupler_type_copy_data +use coupler_types_mod, only: coupler_type_redistribute_data, coupler_type_set_data, coupler_type_data_override +use coupler_types_mod, only: coupler_type_rescale_data, coupler_type_increment_data, coupler_type_extract_data +use coupler_types_mod, only: coupler_type_set_diags, coupler_type_write_chksums, coupler_type_send_data +use coupler_types_mod, only: coupler_type_destructor, coupler_type_initialized +use diag_manager_mod, only: diag_axis_init, diag_manager_end, diag_manager_init, NULL_AXIS_ID +use time_manager_mod, only: time_type, set_date, time_manager_init, set_calendar_type, JULIAN +use data_override_mod, only: data_override_init +use constants_mod, only: pi +use platform_mod, only: r8_kind, r4_kind +use fms2_io_mod, only: fms2_io_init +use netcdf, only: nf90_close, nf90_put_var, nf90_enddef, nf90_create, nf90_def_dim, nf90_clobber, & + nf90_64bit_offset, nf90_char, nf90_def_var, nf90_float +implicit none + +type(coupler_1d_bc_type) :: bc_1d_new +type(coupler_2d_bc_type) :: bc_2d_new, bc_2d_cp +type(coupler_3d_bc_type) :: bc_3d_new, bc_3d_cp +type(coupler_2d_bc_type) :: bc_2d_ref !< just used to check answers +type(coupler_3d_bc_type) :: bc_3d_ref !< just used to check answers +type(domain2D) :: Domain, Domain_out +integer :: layout(2) +integer :: nlat, nlon, nz, i, j +integer :: data_grid(5) !< i/j starting and ending indices for data domain +character(len=3) :: appendix !< appoendix added to filename +type(time_type) :: time_t +integer, parameter :: lkind = FMS_CP_TEST_KIND_ +real(FMS_CP_TEST_KIND_), allocatable :: array_2d(:,:), array_3d(:,:,:) +integer, parameter :: num_bc = 2, num_fields = 2 !< these are set in set_up_coupler_type routines +real(FMS_CP_TEST_KIND_), allocatable :: lats(:), lons(:), nzs(:) !< arrays of coordinate values for diag_axis + !! initalization +integer :: id_x, id_y, id_z, chksum_unit +character(len=128) :: chksum_2d, chksum_3d +real(FMS_CP_TEST_KIND_), allocatable :: expected_2d(:,:), expected_3d(:,:,:) +integer :: err, ncid, dim1D, varid, day + +call fms_init +call time_manager_init +call fms2_io_init +call mpp_init +call set_calendar_type(JULIAN) + +! basic domain set up +nlat=60; nlon=60; nz=12 +layout = (/2, 2/) +call mpp_domains_set_stack_size(86400) +call mpp_define_domains( (/1,nlon,1,nlat/), layout, Domain, name='test_coupler') +call mpp_define_io_domain(Domain, (/1,1/)) +call mpp_get_data_domain(Domain, data_grid(1), data_grid(2), data_grid(3), data_grid(4)) + +! create/allocate new types with routines in utils file +call set_up_1d_coupler_type(bc_1d_new, data_grid) +call set_up_2d_coupler_type(bc_2d_new, data_grid, appendix="new", to_read=.false.) +data_grid(5) = nz +call set_up_3d_coupler_type(bc_3d_new, data_grid, appendix="new", to_read=.false.) + +! coupler_type_set_data +allocate(array_2d(data_grid(1):data_grid(2), data_grid(3):data_grid(4))) +allocate(array_3d(data_grid(1):data_grid(2), data_grid(3):data_grid(4), data_grid(5))) +array_2d = 1.0_lkind +array_3d = 1.0_lkind +do i=1, num_bc + do j=1, num_fields + call coupler_type_set_data(array_2d, i, j, bc_2d_new) + call coupler_type_set_data(array_2d, i, j, data_grid(5), bc_3d_new) + call coupler_type_set_data(array_3d, i, j, bc_3d_new) + enddo +enddo +call check_field_data_2d(bc_2d_new, array_2d) +call check_field_data_3d(bc_3d_new, array_3d) + +! coupler_type_write_chksum +! needs to write to a unit num +call coupler_type_write_chksums(bc_2d_new, stdout()) +call coupler_type_write_chksums(bc_3d_new, stdout()) + +! coupler_type_increment_data +! creates copies to increment into original +call coupler_type_copy(bc_2d_new, bc_2d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), " ", & + (/ 0 /), time_t ) +call coupler_type_copy_data(bc_2d_new, bc_2d_cp) +call coupler_type_copy(bc_3d_new, bc_3d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), data_grid(5), " ", & + (/ 0 /), time_t ) +call coupler_type_copy_data(bc_3d_new, bc_3d_cp) +call coupler_type_increment_data(bc_2d_new, bc_2d_cp) +call coupler_type_increment_data(bc_3d_new, bc_3d_cp) +! copy of itself incremented should just be 2.0 +array_2d = 2.0_lkind; array_3d = 2.0_lkind +call check_field_data_2d(bc_2d_cp, array_2d) +call check_field_data_3d(bc_3d_cp, array_3d) + +! coupler_type_rescale_data +call coupler_type_rescale_data(bc_2d_cp, 2.0_lkind) +call coupler_type_rescale_data(bc_3d_cp, 2.0_lkind) +array_2d = 4.0_lkind; array_3d = 4.0_lkind ! data was 2, rescaled by factor of 2 +call check_field_data_2d(bc_2d_cp, array_2d) +call check_field_data_3d(bc_3d_cp, array_3d) +call coupler_type_destructor(bc_2d_cp) +call coupler_type_destructor(bc_3d_cp) + +! coupler_type_extract_data +do i=1, num_bc + do j=1, num_fields + call coupler_type_extract_data(bc_2d_new, i, j, array_2d) + call coupler_type_extract_data(bc_3d_new, i, j, array_3d) + enddo +enddo +call check_field_data_2d(bc_2d_new, array_2d) +call check_field_data_3d(bc_3d_new, array_3d) + +! test coupler_type_copy, coupler_type_copy_data and coupler_type_destructor +time_t = set_date(1, 1, 1) +! 1d -> 2d, 3d +call coupler_type_copy(bc_1d_new, bc_2d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), " ", & + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_copy(bc_1d_new, bc_3d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), data_grid(5)," ",& + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_destructor(bc_2d_cp) +call coupler_type_destructor(bc_3d_cp) +! 2d -> 2d, 3d +call coupler_type_copy(bc_2d_new, bc_2d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), " ", & + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_copy(bc_2d_new, bc_3d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), data_grid(5), " ", & + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_copy_data(bc_2d_new, bc_2d_cp) +call coupler_type_copy_data(bc_2d_new, bc_3d_cp) +array_2d = 1.0; array_3d = 1.0 +call check_field_data_2d(bc_2d_cp, array_2d) +call check_field_data_3d(bc_3d_cp, array_3d) +call coupler_type_destructor(bc_2d_cp) +call coupler_type_destructor(bc_3d_cp) +! 3d -> 2d, 3d +call coupler_type_copy(bc_3d_new, bc_2d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), " ", & + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_copy(bc_3d_new, bc_3d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), data_grid(5), " ", & + (/ NULL_AXIS_ID /), time_t ) +call coupler_type_copy_data(bc_3d_new, bc_3d_cp) +call check_field_data_3d(bc_3d_cp, array_3d) +call coupler_type_destructor(bc_2d_cp) +call coupler_type_destructor(bc_3d_cp) + +! coupler_type_set_diags and coupler_type_send_data +! set up for diag manager +call diag_manager_init +allocate(lats(1:nlat), lons(1:nlon), nzs(1:nz)) +do i=1, nlat + lats(i) = i +enddo +do i=1, nlon + lons(i) = i +enddo +do i=1, nz + nzs(i) = i +enddo +id_x = diag_axis_init('x', lats, 'point_E', 'x', long_name='point_E', Domain2=Domain) +id_y = diag_axis_init('y', lons, 'point_N', 'y', long_name='point_N', Domain2=Domain) +id_z = diag_axis_init('z', nzs, 'point_Z', 'z', long_name='point_Z') +! registers field with data in type +! reset the time and assign names to each field +time_t = set_date(1, 1, 1) +do i=1, num_bc + do j=1, num_fields + bc_2d_new%FMS_TEST_BC_TYPE_(i)%field(j)%name = "bc"//string(i)//"_var2d_"//string(j) + bc_3d_new%FMS_TEST_BC_TYPE_(i)%field(j)%name = "bc"//string(i)//"_var3d_"//string(j) + bc_2d_new%FMS_TEST_BC_TYPE_(i)%field(j)%long_name = "bc"//string(i)//"_variable_2d_"//string(j)//"_min" + bc_3d_new%FMS_TEST_BC_TYPE_(i)%field(j)%long_name = "bc"//string(i)//"_variable_3d_"//string(j)//"_min" + enddo +enddo +call coupler_type_set_diags(bc_2d_new, "test_coupler_types", (/id_x, id_y/), time_t) +call coupler_type_set_diags(bc_3d_new, "test_coupler_types", (/id_x, id_y, id_z/), time_t) +call coupler_type_copy(bc_2d_new, bc_2d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), " ", & + (/null_axis_id/), time_t) +call coupler_type_copy_data(bc_2d_new, bc_2d_cp) +call coupler_type_copy(bc_3d_new, bc_3d_cp, data_grid(1), data_grid(2), data_grid(3), data_grid(4), data_grid(5), " ",& + (/null_axis_id/), time_t) +call coupler_type_copy_data(bc_3d_new, bc_3d_cp) + +do day=1,31 + time_t = set_date(1, 1, day) + call coupler_type_increment_data(bc_2d_cp, bc_2d_new) ! increment _new with cp + call coupler_type_increment_data(bc_3d_cp, bc_3d_new) + call coupler_type_send_data(bc_2d_new, time_t) + call coupler_type_send_data(bc_3d_new, time_t) +enddo +time_t = set_date(1, 2, 1) +call diag_manager_end(time_t) + +! coupler_type_data_override +! basic grid spec points to outputted .nc's +if( mpp_pe() .eq. mpp_root_pe()) then + err = nf90_create('INPUT/grid_spec.nc', ior(nf90_clobber, nf90_64bit_offset), ncid) + err = nf90_def_dim(ncid, 'str', 60, dim1d) + err = nf90_def_var(ncid, 'x_T', nf90_char, (/dim1d/), varid) + err = nf90_put_var(ncid, varid, "coupler_types_bc1.nc") + err = nf90_def_var(ncid, 'xta', nf90_float, (/dim1d/), varid) + err = nf90_def_var(ncid, 'yta', nf90_float, (/dim1d/), varid) + err = nf90_enddef(ncid) + err = nf90_close(ncid) +endif +call mpp_sync() +call data_override_init(Atm_domain_in=Domain, mode=FMS_CP_TEST_KIND_) + +time_t = set_date(1, 1, 15) +call coupler_type_data_override("ATM", bc_2d_new, time_t) +call coupler_type_data_override("ATM", bc_3d_new, time_t) +call coupler_type_data_override("OCN", bc_2d_new, time_t) +call coupler_type_data_override("OCN", bc_3d_new, time_t) +call coupler_type_data_override("ICE", bc_2d_new, time_t) +call coupler_type_data_override("ICE", bc_3d_new, time_t) +call coupler_type_data_override("LND", bc_2d_new, time_t) +call coupler_type_data_override("LND", bc_3d_new, time_t) + +! coupler_type_redistribute_data +! just using the same domain +call mpp_define_domains((/1, nlon, 1, nlat/), layout, Domain_out, name="test_coupler_redistributed_2x2") +call set_up_2d_coupler_type(bc_2d_cp, data_grid, appendix="new", to_read=.false.) +call set_up_3d_coupler_type(bc_3d_cp, data_grid, appendix="new", to_read=.false.) +call coupler_type_redistribute_data(bc_2d_new, Domain, bc_2d_cp, domain_out, complete=.true.) +call coupler_type_redistribute_data(bc_3d_new, Domain, bc_3d_cp, domain_out, complete=.true.) +call coupler_type_destructor(bc_2d_cp) +call coupler_type_destructor(bc_3d_cp) +! using a different layout +call mpp_define_domains((/1, nlon, 1, nlat/), (/1, 4/), Domain_out, name="test_coupler_redistributed_1x4") +call mpp_get_data_domain(Domain_out, data_grid(1), data_grid(2), data_grid(3), data_grid(4)) +call set_up_2d_coupler_type(bc_2d_cp, data_grid, appendix="new", to_read=.false.) +call set_up_3d_coupler_type(bc_3d_cp, data_grid, appendix="new", to_read=.false.) +call coupler_type_redistribute_data(bc_2d_new, Domain, bc_2d_cp, domain_out, complete=.true.) +call coupler_type_redistribute_data(bc_3d_new, Domain, bc_3d_cp, domain_out, complete=.true.) +! clean up +call coupler_type_destructor(bc_1d_new) +call coupler_type_destructor(bc_2d_new) +call coupler_type_destructor(bc_3d_new) +! check deallocation +! both should be deallocated regardless of kind +if( associated(bc_1d_new%bc) .or. associated(bc_2d_new%bc) .or. associated(bc_3d_new%bc)) & + call mpp_error(FATAL, "test_coupler_types: bc type still associated after destructor called") +if( associated(bc_1d_new%bc_r4) .or. associated(bc_2d_new%bc_r4) .or. associated(bc_3d_new%bc_r4)) & + call mpp_error(FATAL, "test_coupler_types: bc_r4 type still associated after destructor called") + +call fms_end + +contains + +#include "test_coupler_utils.inc" + +subroutine check_field_data_2d(bc_2d, expected) + type(coupler_2d_bc_type) :: bc_2d + real(FMS_CP_TEST_KIND_), intent(in) :: expected(:,:) + real(FMS_CP_TEST_KIND_), pointer :: values_ptr(:,:) + + do i=1, bc_2d%num_bcs + do j=1, bc_2d%FMS_TEST_BC_TYPE_(i)%num_fields + values_ptr => bc_2d%FMS_TEST_BC_TYPE_(i)%field(j)%values + ! checks each index + if(SUM(values_ptr) .ne. SUM(expected)) then + print *, "SUMS", SUM(values_ptr), SUM(expected), SHAPE(values_ptr), SHAPE(expected) + call mpp_error(FATAL, "test_coupler_types: incorrect 2d values against expected result") + endif + enddo + enddo +end subroutine + +subroutine check_field_data_3d(bc_3d, expected) + type(coupler_3d_bc_type) :: bc_3d + real(FMS_CP_TEST_KIND_), intent(in) :: expected(:,:,:) + real(FMS_CP_TEST_KIND_), pointer :: values_ptr(:,:,:) + integer :: x, y, z, vals_start(3) !< need start point for indices, passed in will always be 1-n + + do i=1, bc_3d%num_bcs + do j=1, bc_3d%FMS_TEST_BC_TYPE_(i)%num_fields + values_ptr => bc_3d%FMS_TEST_BC_TYPE_(i)%field(j)%values + if(SUM(values_ptr) .ne. SUM(expected)) then + print *, "SUMS", SUM(values_ptr), SUM(expected), SHAPE(values_ptr), SHAPE(expected) + call mpp_error(FATAL, "test_coupler_types: incorrect 3d values against expected result") + endif + enddo + enddo +end subroutine check_field_data_3d + +end program \ No newline at end of file diff --git a/test_fms/coupler/test_coupler_utils.inc b/test_fms/coupler/test_coupler_utils.inc index 0f6698c423..6c2ee91d77 100644 --- a/test_fms/coupler/test_coupler_utils.inc +++ b/test_fms/coupler/test_coupler_utils.inc @@ -19,16 +19,20 @@ !> Include file to hold common routines for the coupler tests !! Uses the FMS_TEST_BC_TYPE_ macro to test both r4/r8 +!! constants used for test +#define BCNUM_ 2 +#define FLDNUM_ 2 + subroutine set_up_1d_coupler_type(bc_type, data_grid) type(coupler_1d_bc_type), intent(inout) :: bc_type !< Coupler 2d restart types - integer, dimension(4), intent(in) :: data_grid !< Starting and ending indexes of data_domain + integer, dimension(2), intent(in) :: data_grid !< Starting and ending indexes of data_domain integer :: nfiles, nfields, i, j character(len=1) :: field_num, file_num !bc_type%isc = data_grid(1); bc_type%iec = data_grid(2) !bc_type%isd = data_grid(1); bc_type%ied = data_grid(2) bc_type%set = .true. - bc_type%num_bcs = 2 + bc_type%num_bcs = BCNUM_ nfiles = bc_type%num_bcs allocate(bc_type%FMS_TEST_BC_TYPE_(nfiles)) @@ -36,7 +40,7 @@ subroutine set_up_1d_coupler_type(bc_type, data_grid) write(file_num,'(i1)') i bc_type%FMS_TEST_BC_TYPE_(i)%ice_restart_file="default_"//file_num//"_ice_restart_2d.nc" - bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=2 + bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=FLDNUM_ nfields = bc_type%FMS_TEST_BC_TYPE_(i)%num_fields allocate(bc_type%FMS_TEST_BC_TYPE_(i)%field(nfields)) @@ -67,9 +71,9 @@ subroutine set_up_2d_coupler_type(bc_type, data_grid, appendix, to_read) bc_type%set = .true. if (to_read) then - bc_type%num_bcs = 3 + bc_type%num_bcs = BCNUM_ + 1 else - bc_type%num_bcs = 2 + bc_type%num_bcs = BCNUM_ endif bc_type%isc = data_grid(1); bc_type%iec = data_grid(2) @@ -88,7 +92,7 @@ subroutine set_up_2d_coupler_type(bc_type, data_grid, appendix, to_read) bc_type%FMS_TEST_BC_TYPE_(i)%ice_restart_file=appendix//"_"//file_num//"_ice_restart_2d.nc" endif - bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=2 + bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=FLDNUM_ nfields = bc_type%FMS_TEST_BC_TYPE_(i)%num_fields allocate(bc_type%FMS_TEST_BC_TYPE_(i)%field(nfields)) @@ -181,9 +185,9 @@ subroutine set_up_3d_coupler_type(bc_type, data_grid, appendix, to_read) bc_type%set = .true. if (to_read) then - bc_type%num_bcs = 3 + bc_type%num_bcs = BCNUM_ + 1 else - bc_type%num_bcs = 2 + bc_type%num_bcs = BCNUM_ endif nfiles = bc_type%num_bcs @@ -199,7 +203,7 @@ subroutine set_up_3d_coupler_type(bc_type, data_grid, appendix, to_read) bc_type%FMS_TEST_BC_TYPE_(i)%ice_restart_file=appendix//"_"//file_num//"_ice_restart_3d.nc" endif - bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=2 + bc_type%FMS_TEST_BC_TYPE_(i)%num_fields=FLDNUM_ nfields = bc_type%FMS_TEST_BC_TYPE_(i)%num_fields allocate(bc_type%FMS_TEST_BC_TYPE_(i)%field(nfields)) diff --git a/test_fms/data_override/Makefile.am b/test_fms/data_override/Makefile.am index f5c956c446..366c773800 100644 --- a/test_fms/data_override/Makefile.am +++ b/test_fms/data_override/Makefile.am @@ -30,6 +30,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. check_PROGRAMS = \ + test_data_override_init \ test_get_grid_v1_r4 \ test_get_grid_v1_r8 \ test_data_override_r4 \ @@ -38,6 +39,7 @@ check_PROGRAMS = \ test_data_override_ongrid_r8 # This is the source code for the test. +test_data_override_init_SOURCES = test_data_override_init.F90 test_data_override_r4_SOURCES = test_data_override.F90 test_data_override_r8_SOURCES = test_data_override.F90 diff --git a/test_fms/data_override/test_data_override2.sh b/test_fms/data_override/test_data_override2.sh index 35546b41d3..064b0511d4 100755 --- a/test_fms/data_override/test_data_override2.sh +++ b/test_fms/data_override/test_data_override2.sh @@ -117,4 +117,53 @@ fi done +# data_override with the default table (not setting namelist) +cat <<_EOF > data_table +"ICE", "sst_obs", "SST", "INPUT/sst_ice_clim.nc", .false., 300.0 +_EOF + +test_expect_success "data_override_init with the default table" ' + mpirun -n 1 ./test_data_override_init +' +# data_override with yaml table (setting namelist to .True.) +cat <<_EOF > input.nml +&data_override_nml +use_data_table_yaml=.true. +/ +_EOF + +cat <<_EOF > data_table.yaml +data_table: + - gridname : OCN + fieldname_code : runoff + fieldname_file : runoff + file_name : INPUT/runoff.daitren.clim.1440x1080.v20180328.nc + interpol_method : none + factor : 1.0 +_EOF + +if [ ! -z $parser_skip ]; then + test_expect_failure "data_override_init with the yaml table" ' + mpirun -n 1 ./test_data_override_init + ' +else + test_expect_success "data_override_init with the yaml table" ' + mpirun -n 1 ./test_data_override_init + ' +fi +#data_override with default table (setting namelist to .True.) +cat <<_EOF > data_table +"ICE", "sst_obs", "SST", "INPUT/sst_ice_clim.nc", .true., 300.0 +_EOF + +cat <<_EOF > input.nml +&data_override_nml +use_data_table_yaml=.false. +/ +_EOF + +test_expect_success "data_override_init with the default table" ' + mpirun -n 1 ./test_data_override_init +' + test_done diff --git a/test_fms/data_override/test_data_override_init.F90 b/test_fms/data_override/test_data_override_init.F90 new file mode 100644 index 0000000000..dceec5aca3 --- /dev/null +++ b/test_fms/data_override/test_data_override_init.F90 @@ -0,0 +1,29 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +program test_data_override_init + + use fms_mod, only: fms_init, fms_end + use data_override_mod + + call fms_init() + call data_override_init + call fms_end() + +end program test_data_override_init diff --git a/test_fms/mosaic/test_mosaic.F90 b/test_fms/mosaic/test_mosaic.F90 deleted file mode 100644 index 6c436d27f2..0000000000 --- a/test_fms/mosaic/test_mosaic.F90 +++ /dev/null @@ -1,145 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS is free software: you can redistribute it and/or modify it under -!* the terms of the GNU Lesser General Public License as published by -!* the Free Software Foundation, either version 3 of the License, or (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -!* for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with FMS. If not, see . -!*********************************************************************** - -!> @brief This programs tests calls to get_mosaic_ntiles, get_mosaic_ncontacts, -!! get_mosaic_grid_sizes, get_mosaic_contact -program test_mosaic - -use mosaic2_mod, only : get_mosaic_ntiles, get_mosaic_ncontacts -use mosaic2_mod, only : get_mosaic_grid_sizes, get_mosaic_contact -use mpp_mod, only : mpp_init, mpp_error, FATAL, mpp_sync, mpp_npes, mpp_get_current_pelist -use fms2_io_mod, only : open_file, close_file, FmsNetcdfFile_t -use fms2_io_mod, only : register_axis, register_field, write_data -use fms_mod, only : fms_init, fms_end - -implicit none - -integer :: ntiles !< Number of tiles -integer :: ncontacts !< Number of contacts -integer :: n !< For do loops -integer, allocatable :: tile1(:) !< tile number for first contact -integer, allocatable :: tile2(:) !< tile number of the second contact -integer, allocatable :: nx(:), ny(:) !< Number of x/y points for each tile -integer, allocatable :: istart1(:), iend1(:), jstart1(:), jend1(:) !< Indexes of first contact point -integer, allocatable :: istart2(:), iend2(:), jstart2(:), jend2(:) !< Indexes of second contact point -character(len=128) :: mosaic_file !< Mosaic filename -type(FmsNetcdfFile_t):: mosaic_fileobj !< Fileobj for the file read by the test -integer :: answers(2, 8) !< Expected results -integer, allocatable :: pes(:) !< List of pes in the current pelist - -call mpp_init() -call fms_init() - -mosaic_file = "INPUT/ocean_mosaic.nc" -answers(1,:) = (/1440, 1440, 1, 1080, 1, 1, 1, 1080 /) -answers(2,:) = (/1, 720, 1080, 1080, 1440, 721, 1080, 1080 /) - -allocate(pes(mpp_npes())) -call mpp_get_current_pelist(pes) - -call create_files(pes) - -!< Open the mosaic file -if(.not. open_file(mosaic_fileobj, mosaic_file, 'read', pelist=pes)) then - call mpp_error(FATAL, 'test_mosaic: error in opening file '//trim(mosaic_file)) -endif - -ntiles = get_mosaic_ntiles(mosaic_fileobj) -ncontacts = get_mosaic_ncontacts(mosaic_fileobj) -allocate(nx(ntiles), ny(ntiles)) -allocate(tile1(ncontacts), tile2(ncontacts) ) -allocate(istart1(ncontacts), iend1(ncontacts), jstart1(ncontacts), jend1(ncontacts) ) -allocate(istart2(ncontacts), iend2(ncontacts), jstart2(ncontacts), jend2(ncontacts) ) - -call get_mosaic_grid_sizes(mosaic_fileobj, nx, ny ) -call get_mosaic_contact(mosaic_fileobj, tile1, tile2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2) - -!< Compare with expected results: -if (ntiles .ne. 1) call mpp_error(FATAL, "ntiles is not equal to 1") - -do n = 1, ntiles - if (nx(n) .ne. 2880/2) call mpp_error(FATAL, "nx is not the expected result") - if (ny(n) .ne. 2160/2) call mpp_error(FATAL, "ny is not the expected result") -end do - -if (ncontacts .ne. 2) call mpp_error(FATAL, "ncontacts is not the expected result") -do n = 1, ncontacts - if (istart1(n) .ne. answers(n,1)) call mpp_error(FATAL, "istart1 is not the expected result") - if (iend1(n) .ne. answers(n,2)) call mpp_error(FATAL, "iend1 is not the expected result") - - if (jstart1(n) .ne. answers(n,3)) call mpp_error(FATAL, "jstart1 is not the expected result") - if (jend1(n) .ne. answers(n,4)) call mpp_error(FATAL, "jend1 is not the expected result") - - if (istart2(n) .ne. answers(n,5)) call mpp_error(FATAL, "istart2 is not the expected result") - if (iend2(n) .ne. answers(n,6)) call mpp_error(FATAL, "iend2 is not the expected result") - - if (jstart2(n) .ne. answers(n,7)) call mpp_error(FATAL, "jstart2 is not the expected result") - if (jend2(n) .ne. answers(n,8)) call mpp_error(FATAL, "jend2 is not the expected result") -end do - -deallocate(tile1, tile2, nx, ny) -deallocate(istart1, iend1, jstart1, jend1) -deallocate(istart2, iend2, jstart2, jend2) - -call close_file(mosaic_fileobj) -call fms_end() - -contains - -subroutine create_files(pes) - integer, intent(in) :: pes(:) !< List of pes - - type(FmsNetcdfFile_t):: fileobj !< Fileobj for the files written by the test - character(len=255) :: str_array(2) !< Array of strings because GNU - - if( open_file(fileobj, mosaic_file, 'overwrite', pelist=pes)) then - call register_axis(fileobj, "ntiles", 1) - call register_axis(fileobj, "ncontact", 2) - call register_axis(fileobj, "string", 255) - - str_array(1) = "string" - str_array(2) = "ncontact" - call register_field(fileobj, "contacts", "char", dimensions=str_array) - call register_field(fileobj, "contact_index", "char", dimensions=str_array) - call register_field(fileobj, "gridfiles", "char", dimensions=(/"string", "ntiles"/)) - call register_field(fileobj, "gridtiles", "char", dimensions=(/"string", "ntiles"/)) - - call write_data(fileobj, "gridfiles", (/"ocean_hgrid.nc"/)) - call write_data(fileobj, "gridtiles", (/"tile1"/)) - - str_array(1) = "2880:2880,1:2160::1:1,1:2160" - str_array(2) = "1:1440,2160:2160::2880:1441,2160:2160" - call write_data(fileobj, "contact_index", str_array) - call write_data(fileobj, "contacts", & - & (/"ocean_mosaic:tile1::ocean_mosaic:tile1", "ocean_mosaic:tile1::ocean_mosaic:tile1" /)) - - call close_file(fileobj) - endif - call mpp_sync() - - if( open_file(fileobj, "INPUT/ocean_hgrid.nc", "overwrite", pelist=pes)) then - call register_axis(fileobj, "nx", 2880) - call register_axis(fileobj, "ny", 2160) - - call close_file(fileobj) - endif - call mpp_sync() -end subroutine create_files - -end program test_mosaic diff --git a/test_fms/mosaic2/Makefile.am b/test_fms/mosaic2/Makefile.am new file mode 100644 index 0000000000..7f2d6143ab --- /dev/null +++ b/test_fms/mosaic2/Makefile.am @@ -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 . +#*********************************************************************** + +# This is an automake file for the test_fms/mosaic directory of the +# FMS package. + +# uramirez, Ed Hartnett + +# Find the needed mod and include files. +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) -I./INPUT -I$(top_srcdir)/mosaic -I./ + +# Link to the FMS library. +LDADD = $(top_builddir)/libFMS/libFMS.la + +# Build this test program. +check_PROGRAMS = test_mosaic2_r4 test_mosaic2_r8 test_grid2_r4 test_grid2_r8 + +# This is the source code for the test +test_mosaic2_r4_SOURCES = test_mosaic2.F90 write_files.inc +test_grid2_r4_SOURCES = test_grid2.F90 write_files.inc + +test_mosaic2_r8_SOURCES = test_mosaic2.F90 write_files.inc +test_grid2_r8_SOURCES = test_grid2.F90 write_files.inc + +test_mosaic2_r4_CPPFLAGS=-DTEST_MOS_KIND_=4 $(AM_CPPFLAGS) +test_grid2_r4_CPPFLAGS =-DTEST_MOS_KIND_=4 $(AM_CPPFLAGS) + +test_mosaic2_r8_CPPFLAGS=-DTEST_MOS_KIND_=8 $(AM_CPPFLAGS) +test_grid2_r8_CPPFLAGS =-DTEST_MOS_KIND_=8 $(AM_CPPFLAGS) + +# These files are also included in the distribution. +EXTRA_DIST = test_mosaic2.sh + +# Run the test program. +TESTS = test_mosaic2.sh + +if SKIP_MOSAIC_TESTS + TESTS_ENVIRONMENT = SKIP_TESTS="test_mosaic2.1 test_mosaic2.2 test_mosaic2.3 test_mosaic2.4" +endif + +TEST_EXTENSIONS = .sh +SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ + $(abs_top_srcdir)/test_fms/tap-driver.sh +# Clean up +CLEANFILES = input.nml *.nc *.out *.dpi *.spi *.dyn *.spl *.mod diff --git a/test_fms/mosaic2/test_grid2.F90 b/test_fms/mosaic2/test_grid2.F90 new file mode 100644 index 0000000000..3f008badb2 --- /dev/null +++ b/test_fms/mosaic2/test_grid2.F90 @@ -0,0 +1,258 @@ +!*********************************************************************** +!* 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 calls to get_mosaic_ntiles, get_mosaic_ncontacts, +!! get_mosaic_grid_sizes, get_mosaic_contact. All subroutines here are tested +!! with C1 tiles where tiles 1-6 are identical. The tile points are made up with +!! values that result in simple answers. See write_files module for grid details. + +#include "write_files.inc" !> including write_files.mod because I don't know how to compile when write_files.mod is + !! in a separate file. +program test_mosaic + +use mpp_mod, only : mpp_init, mpp_error, FATAL, mpp_npes, mpp_pe, mpp_root_pe +use mpp_domains_mod, only: domain2D, domainUG, mpp_define_domains, mpp_get_compute_domain, mpp_define_unstruct_domain +use fms2_io_mod, only : open_file, close_file, FmsNetcdfFile_t, fms2_io_init +use fms2_io_mod, only : register_axis, register_field, write_data, read_data +use fms_mod, only : fms_init, fms_end +use platform_mod, only : r4_kind, r8_kind +use grid2_mod +use write_files + +implicit none + +!> write out netcdf files +!! write_all sets up the grids +call fms2_io_init() +call write_all() +call fms_init() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_CELL_VERTICIES' +call test_get_cell_vertices + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_CELL_CENTERS' +call test_get_cell_centers + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_GRID_CELL_AREA_SG' +call test_get_grid_cell_area_sg + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST_GET_GRID_CELL_AREA_UG' +call test_get_grid_cell_area_ug + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_GRID_COMP_AREA_SG' +call test_get_grid_comp_area_sg + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_GRID_COMP_AREA_UG' +call test_get_grid_comp_area_ug + +contains + !------------------------------------------! + subroutine test_get_cell_vertices + + !> This subroutine tests get_cell_verticees. This + !! subroutine only tests for vertices in tile 1. + + implicit none + + real(TEST_MOS_KIND_) :: lonb_2d(c1_nx,c1_ny) !< returned values for lon 2d + real(TEST_MOS_KIND_) :: latb_2d(c1_nx,c1_ny) !< returned values for lat 2d + real(TEST_MOS_KIND_) :: answer_lon_2d(c1_nx,c1_ny) !< answers for lon 2d + real(TEST_MOS_KIND_) :: answer_lat_2d(c1_nx,c1_ny) !< answers for lat 2d + + integer :: i,j + + !> answers + answer_lon_2d=x(1:c1_nxp:2, 1:c1_nxp:2) + answer_lat_2d=y(1:c1_nxp:2, 1:c1_nxp:2) + + call get_grid_cell_vertices('ATM',1,lonb_2d,latb_2d) + !> check + do j=1, c1_ny + do i=1, c1_nx + call check_answer(answer_lon_2d(i,j), lonb_2d(i,j), 'TEST_GET_CELL_VERTICIES_2D lon') + call check_answer(answer_lat_2d(i,j), latb_2d(i,j), 'TEST_GET_CELL_VERTICIES_2D lat') + end do + end do + + end subroutine test_get_cell_vertices + !------------------------------------------! + subroutine test_get_cell_centers + + !> This subroutine tests get_cell_centers. + !! There is only one cell center point in a C1 tile. + + implicit none + + integer, parameter :: nx = c1_nx/2 !< number of center points + integer, parameter :: ny = c1_ny/2 !< number of center points + + real(TEST_MOS_KIND_) :: glon_2d(nx,ny) !< results from grid_cell_centers + real(TEST_MOS_KIND_) :: glat_2d(nx,ny) !< results from grid_cell_centers + real(TEST_MOS_KIND_) :: answer_glon_2d(nx,ny) !< answers for glon + real(TEST_MOS_KIND_) :: answer_glat_2d(nx,ny) !< answers for glat + + integer :: i, j + + !--- 2d ---! + answer_glon_2d=x(2:c1_nx:2, 2:c1_nx:2) + answer_glat_2d=y(2:c1_nx:2, 2:c1_nx:2) + + call get_grid_cell_centers('ATM', 1, glon_2d, glat_2d) + do i=1, nx + do j=1, ny + call check_answer(answer_glon_2d(j,i), glon_2d(j,i), 'TEST_GET_CELL_CENTERS_2D lon') + call check_answer(answer_glat_2d(j,i), glat_2d(j,i), 'TEST_GET_CELL_CENTERS_2D lat') + end do + end do + + end subroutine test_get_cell_centers + !------------------------------------------! + subroutine test_get_grid_cell_area_sg + + !> This subroutine tests get_grid_cell_area_SG + !! first without the domain input argument and second + !! with the domain input argument + + implicit none + + type(domain2D) :: SG_domain + real(TEST_MOS_KIND_) :: area_out2(1,1) + real(TEST_MOS_KIND_) :: answer + + answer = real(2.0_r8_kind*PI*RADIUS*RADIUS,lkind) + + !> total of 1 domain with 1 (center) point in the domain + call mpp_define_domains((/1,1,1,1/), (/1,1/), SG_domain) + + !> The area computed by get_grid_cell_area is for the entire cell + !! The array area, set in write_files.F90, is the area for 1/4th of the cell + + !> Test withtout SG_domain + call get_grid_cell_area('ATM',2, area_out2) + call check_answer(answer, area_out2(1,1), 'TEST_GRID_CELL_AREA_SG') + + !> Test with SG_domain + call get_grid_cell_area('ATM',2, area_out2, SG_domain) + call check_answer(answer, area_out2(1,1), 'TEST_GRID_CELL_AREA_SG with SG_domain') + + end subroutine test_get_grid_cell_area_sg + !------------------------------------------! + subroutine test_get_grid_cell_area_ug + + !> This subroutine tests get_grid_cell_area_ug + + implicit none + type(domain2D) :: SG_domain + type(domainUG) :: UG_domain !< UG_domain is the same as SG_domain + real(TEST_MOS_KIND_) :: area_out1(1) + real(TEST_MOS_KIND_) :: answer + integer :: i + integer :: npts_tile(1),grid_nlevel(1), ndivs, grid_index(1) + + npts_tile=1 + grid_nlevel=1 + ndivs=1 + grid_index=1 + + answer = real( 4.0_r8_kind * area(1,1), TEST_MOS_KIND_) + + !> The unstructured grid is the same as the structured grid; there's only one center point in the tile. + call mpp_define_domains((/1,1,1,1/), (/1,1/), SG_domain) + call mpp_define_unstruct_domain(UG_domain, SG_domain,npts_tile,grid_nlevel,& + mpp_npes(),ndivs,grid_index,name='immadeup') + + !> The area computed by get_grid_cell_area is for the entire cell + !! The array area, set in write_files.F90, is the area for 1/4th of the cell + call get_grid_cell_area('ATM',1, area_out1, SG_domain, UG_domain) + call check_answer(answer, area_out1(1), 'TEST_GRID_CELL_AREA_UG') + + end subroutine test_get_grid_cell_area_ug + !------------------------------------------! + subroutine test_get_grid_comp_area_sg + + !> This subroutine tests get_grid_comp_area_sg + !! first without the domain input argument and second + !! with the domain input argument + + implicit none + type(domain2D) :: SG_domain + real(TEST_MOS_KIND_) :: area_out2(1,1) + real(TEST_MOS_KIND_) :: answer + + answer = real( 4.0_r8_kind * area(1,1), TEST_MOS_KIND_) + + call mpp_define_domains((/1,1,1,1/), (/1,1/), SG_domain) + + !> The area computed by get_grid_cell_area is for the entire cell + !! The array area, set in write_files.F90, is the area for 1/4th of the cell + !! Test without SG_domain + call get_grid_comp_area('ATM', 1, area_out2) + call check_answer(answer, area_out2(1,1), 'TEST_GRID_COMP_AREA_SG') + + !> The area computed by get_grid_cell_area is for the entire cell + !! The array area, set in write_files.F90, is the area for 1/4th of the cell + !! Test with SG_domain + call get_grid_comp_area('ATM', 1, area_out2, SG_domain) + call check_answer(answer, area_out2(1,1), 'TEST_GRID_COMP_AREA_SG with SG_domain') + + end subroutine test_get_grid_comp_area_sg + !------------------------------------------! + subroutine test_get_grid_comp_area_ug + + !> This subroutine tests get_grid_comp_area_ug + + implicit none + type(domain2D) :: SG_domain + type(domainUG) :: UG_domain !< UG_domain is the same as SG_domain + integer :: npts_tile(1), ntiles_grid(1), grid_index(1) + real(TEST_MOS_KIND_) :: answer + real(TEST_MOS_KIND_) :: area_out1(1) + + npts_tile=1 + ntiles_grid=1 + grid_index(1)=1 + answer = real( 4.0_r8_kind * area(1,1), TEST_MOS_KIND_) + + !> the unstructured grid is the same as the structured grid + call mpp_define_domains((/1,1,1,1/), (/1,1/), SG_domain) + call mpp_define_unstruct_domain(UG_domain, SG_domain, npts_tile, ntiles_grid,mpp_npes(),1,grid_index) + + !> The area computed by get_grid_cell_area is for the entire cell + !! The array area, set in write_files.F90, is the area for 1/4th of the cell + call get_grid_comp_area('ATM',3,area_out1,SG_domain, UG_domain) + call check_answer(answer, area_out1(1), 'TEST_GRID_CELL_AREA_UG') + + end subroutine test_get_grid_comp_area_ug + !------------------------------------------! + subroutine check_answer(answer, myvalue, whoami) + + implicit none + real(TEST_MOS_KIND_) :: answer + real(TEST_MOS_KIND_) :: myvalue + character(*) :: whoami + + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + write(*,*) 'difference of', abs(answer-myvalue) + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + + end subroutine check_answer +!------------------------------------------------------! +end program test_mosaic diff --git a/test_fms/mosaic2/test_mosaic2.F90 b/test_fms/mosaic2/test_mosaic2.F90 new file mode 100644 index 0000000000..10da8a2820 --- /dev/null +++ b/test_fms/mosaic2/test_mosaic2.F90 @@ -0,0 +1,328 @@ +!*********************************************************************** +!* 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 calls to get_mosaic_ntiles, get_mosaic_ncontacts, +!! get_mosaic_grid_sizes, get_mosaic_contact. The subroutines are tested with +!! made up C1 grids and exchange grids. See write_files mod for grid details. + +#include "write_files.inc" !> including write_files.mod because I don't know how to compile when write_files.mod is + !! in a separate file. +program test_mosaic + +use mosaic2_mod +use grid2_mod +use write_files +use mpp_mod, only : mpp_init, mpp_error, FATAL, mpp_pe, mpp_root_pe +use fms2_io_mod, only : open_file, close_file, FmsNetcdfFile_t, fms2_io_init, read_data +use fms_mod, only : fms_init, fms_end +use constants_mod, only : DEG_TO_RAD +use platform_mod, only : r4_kind, r8_kind + +implicit none + +!> create mosaic and grid files +!! In orderr to create the mosaic and grid files, fms2_io needs to be initialized first +call fms2_io_init() +call write_all() +!< fms_init calls grid_init which reads in the grid_spec file +!! In this case, the grid_version is VERSION_OCN_MOSAIC_FILE. +call fms_init() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_MOSAIC_GRID_SIZES' +call test_get_mosaic_grid_sizes() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_MOSAIC_CONTACT' +call test_get_mosaic_contact() + +!> does not work, results in negative areas for r4_kind. Figure out why later +!if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_GRID_GREAT_CIRCLE_AREA' +!call test_get_grid_great_circle_area() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST CALC_MOSAIC_GRID_AREA' +call test_calc_mosaic_grid_area() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST GET_MOSAIC_XGRID' +call test_get_mosaic_xgrid() + +if(mpp_pe() .eq. mpp_root_pe()) write(*,*) 'TEST IS_INSIDE_POLYGON' +call test_is_inside_polygon() + +call fms_end() + +contains +!------------------------------------------------------! +subroutine test_get_mosaic_grid_sizes + + !> test get_mosaic_grid_sizes + + integer :: ntiles !< number of tiles + integer :: n !< counter + integer, allocatable :: nx_out(:), ny_out(:) !< number of grid points for each tile + type(FmsNetcdfFile_t):: fileobj + + !-- ocean --! + if( .not. open_file(fileobj, 'INPUT/'//trim(ocn_mosaic_file), 'read') ) & + call mpp_error(FATAL, 'test_mosaic: error in opening file '//'INPUT/'//trim(ocn_mosaic_file)) + + allocate( nx_out(ocn_ntiles), ny_out(ocn_ntiles) ) + !> get_mosaic_grid_sizes reads in the grid file + call get_mosaic_grid_sizes(fileobj, nx_out, ny_out ) + do n=1, ocn_ntiles + call check_answer(ocn_nx/2, nx_out(n), 'ocn TEST_GET_MOSAIC_GRID_SIZES') + call check_answer(ocn_nY/2, ny_out(n), 'ocn TEST_GET_MOSAIC_GRID_SIZES') + end do + deallocate(nx_out, ny_out) + call close_file(fileobj) + + !-- atm --! + if( .not. open_file(fileobj, 'INPUT/'//trim(c1_mosaic_file), 'read') ) & + call mpp_error(FATAL, 'test_mosaic: error in opening file '//'INPUT/'//trim(c1_mosaic_file)) + + allocate( nx_out(c1_ntiles), ny_out(c1_ntiles) ) + call get_mosaic_grid_sizes(fileobj, nx_out, ny_out) + do n=1, ntiles + call check_answer(c1_nx/2, nx_out(n), 'atm TEST_GET_MOSAIC_GRID_SIZES') + call check_answer(c1_nx/2, ny_out(n), 'atm TEST_GET_MOSAIC_GRID_SIZES') + end do + deallocate(nx_out, ny_out) + call close_file(fileobj) + +end subroutine test_get_mosaic_grid_sizes +!------------------------------------------------------! +subroutine test_get_mosaic_contact + + !< @uriel.ramirez + + integer :: ntiles !< Number of tiles + integer :: ncontacts !< Number of contacts + integer :: n !< For do loops + integer, allocatable :: tile1(:) !< tile number for first contact + integer, allocatable :: tile2(:) !< tile number of the second contact + integer, allocatable :: nx(:), ny(:) !< Number of x/y points for each tile + integer, allocatable :: istart1(:), iend1(:), jstart1(:), jend1(:) !< Indexes of first contact point + integer, allocatable :: istart2(:), iend2(:), jstart2(:), jend2(:) !< Indexes of second contact point + + integer :: answers(2, 8) !< Expected results + + type(FmsNetcdfFile_t):: ocn_fileobj + + if( .not. open_file(ocn_fileobj, 'INPUT/'//trim(ocn_mosaic_file), 'read') ) & + call mpp_error(FATAL, 'test_mosaic: error in opening file '//'INPUT/'//trim(ocn_mosaic_file)) + + answers(1,:) = (/1440, 1440, 1, 1080, 1, 1, 1, 1080 /) + answers(2,:) = (/1, 720, 1080, 1080, 1440, 721, 1080, 1080 /) + + ntiles = get_mosaic_ntiles(ocn_fileobj) + ncontacts = get_mosaic_ncontacts(ocn_fileobj) + + allocate(nx(ntiles), ny(ntiles)) + allocate(tile1(ncontacts), tile2(ncontacts) ) + allocate(istart1(ncontacts), iend1(ncontacts), jstart1(ncontacts), jend1(ncontacts) ) + allocate(istart2(ncontacts), iend2(ncontacts), jstart2(ncontacts), jend2(ncontacts) ) + + call get_mosaic_contact(ocn_fileobj, tile1, tile2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2) + + !< Compare with expected results: + if (ntiles .ne. 1) call mpp_error(FATAL, "ntiles is not equal to 1") + if (ncontacts .ne. 2) call mpp_error(FATAL, "ncontacts is not the expected result") + do n = 1, ncontacts + if (istart1(n) .ne. answers(n,1)) call mpp_error(FATAL, "istart1 is not the expected result") + if (iend1(n) .ne. answers(n,2)) call mpp_error(FATAL, "iend1 is not the expected result") + + if (jstart1(n) .ne. answers(n,3)) call mpp_error(FATAL, "jstart1 is not the expected result") + if (jend1(n) .ne. answers(n,4)) call mpp_error(FATAL, "jend1 is not the expected result") + + if (istart2(n) .ne. answers(n,5)) call mpp_error(FATAL, "istart2 is not the expected result") + if (iend2(n) .ne. answers(n,6)) call mpp_error(FATAL, "iend2 is not the expected result") + + if (jstart2(n) .ne. answers(n,7)) call mpp_error(FATAL, "jstart2 is not the expected result") + if (jend2(n) .ne. answers(n,8)) call mpp_error(FATAL, "jend2 is not the expected result") + end do + + deallocate(tile1, tile2, nx, ny) + deallocate(istart1, iend1, jstart1, jend1) + deallocate(istart2, iend2, jstart2, jend2) + +end subroutine test_get_mosaic_contact +!------------------------------------------------------! +subroutine test_calc_mosaic_grid_area + + !> This subroutine tests get_grid_area + + implicit none + + real(TEST_MOS_KIND_) :: x_rad(c1_nx, c1_ny), y_rad(c1_nx, c1_ny) !< x and y in radians + real(TEST_MOS_KIND_) :: area_out(1,1) !< area to be computed + + !> x_rad and y_rad can be set to be be the entire cell + !! x_rad = x(1:3:2, 1:3:2) and y_rad = y(1:3:2, 1:3:2) + !! The answer will then be 4.0*area(1,1) + x_rad = real( real(x(1:2,1:2),r8_kind)*DEG_TO_RAD,TEST_MOS_KIND_) !< set coordinates + y_rad = real( real(y(1:2,1:2),r8_kind)*DEG_TO_RAD,TEST_MOS_KIND_) !< set coordinates + + call calc_mosaic_grid_area(x_rad, y_rad, area_out) + call check_answer(area(1,1), area_out(1,1), 'TEST_CALC_MOSAIC_GRID_AREA') + +end subroutine test_calc_mosaic_grid_area +!------------------------------------------------------! +subroutine test_get_grid_great_circle_area + + !> This subroutine tests calc_mosaic_grid_great_circle_area + + implicit none + + real(TEST_MOS_KIND_) :: x_rad(c1_nx, c1_ny), y_rad(c1_nx, c1_ny) !< x and y in radians + real(TEST_MOS_KIND_) :: area_out(1,1) !< area to be computed + + !> x_rad and y_rad can be set to be be the entire cell + !! x_rad = x(1:3:2, 1:3:2) and y_rad = y(1:3:2, 1:3:2) + !! The answer will then be 4.0*area(1,1) + x_rad = real( real(x(1:2,1:2),r8_kind)*DEG_TO_RAD,TEST_MOS_KIND_) !< set coordinates + y_rad = real( real(y(1:2,1:2),r8_kind)*DEG_TO_RAD,TEST_MOS_KIND_) !< set coordinates + call calc_mosaic_grid_great_circle_area(x_rad, y_rad, area_out) + call check_answer(area(1,1), area_out(1,1), 'TEST_GET_GRID_GREAT_CIRCLE_AREA') + +end subroutine test_get_grid_great_circle_area +!------------------------------------------------------! +subroutine test_get_mosaic_xgrid + + !> Test get_mosaic_xgrid + + implicit none + + integer, dimension(ncells) :: i1, j1, i2, j2 !< indices of parent cells + real(TEST_MOS_KIND_), dimension(ncells) :: area !< area to be returned + real(r8_kind) :: garea, get_global_area !< global area + integer :: i !< counter + + type(FmsNetcdfFile_t) x_fileobj + + garea = get_global_area() + + if( .not. open_file(x_fileobj, 'INPUT/'//trim(exchange_file), 'read')) & + call mpp_error(FATAL, 'test_mosaic: error in opening file '//'INPUT/'//trim(exchange_file)) + + call get_mosaic_xgrid(x_fileobj, i1, j1, i2, j2, area) + + !> check answers + do i=1, ncells + call check_answer( real(real(xgrid_area(i),r8_kind)/garea,lkind), area(i),"TEST_GET_MOSAIC_XGRID area") + call check_answer(tile1_cell(1,i), i1(i), "TEST_GET_MOSAIC_XGRID i1") + call check_answer(tile2_cell(1,i), i2(i), "TEST_GET_MOSAIC_XGRID i2") + call check_answer(tile1_cell(1,i), j1(i), "TEST_GET_MOSAIC_XGRID j1") + call check_answer(tile2_cell(1,i), j2(i), "TEST_GET_MOSAIC_XGRID j2") + end do + + call close_file(x_fileobj) + + +end subroutine test_get_mosaic_xgrid +!------------------------------------------------------! +subroutine test_is_inside_polygon + + !> cheating a little. starting with xyz coordinates (cause easier to understand) + + implicit none + + integer, parameter :: n=5 + integer :: i + real(TEST_MOS_KIND_) :: lat1, lon1, x1, y1, z1, r + real(TEST_MOS_KIND_), dimension(n) :: lon2, lat2, x2, y2, z2 + logical :: answer, is_inside + + integer, parameter :: lkind=TEST_MOS_KIND_ !< local kind + + !> polygon + x2=0.0_lkind + y2(1)=1.0_lkind ; y2(2)=1.0_lkind ; y2(3)=4.0_lkind ; y2(4)=4.0_lkind ; y2(5)=1.0_lkind + z2(1)=2.0_lkind ; z2(2)=4.0_lkind ; z2(3)=4.0_lkind ; z2(4)=2.0_lkind ; z2(5)=2.0_lkind + do i=1, n + r = sqrt( x2(i)**2 + y2(i)**2 + z2(i)**2 ) + lon2(i)=atan(y2(i)/x2(i)) + lat2(i)=asin(z2(i)/r) + end do + + !> point outside of the polygon + x1=2.0_lkind + y1=5.0_lkind + z1=4.2_lkind + r = sqrt(x1**2+y1**2+z1**2) + lon1=atan(y1/x1) + lat1=asin(z1/r) + + answer=.false. + is_inside=is_inside_polygon(lon1, lat1, lon2, lat2) + call check_answer(answer,is_inside,' TEST_IS_INSIDE_POLYGON') + + !> point inside the polygon + x1=0.0_lkind + y1=3.0_lkind + z1=2.5_lkind + r = sqrt(x1**2+y1**2+z1**2) + lon1=atan(y1/x1) + lat1=asin(z1/r) + + answer=.true. + is_inside=is_inside_polygon(lon1, lat1, lon2, lat2) + call check_answer(answer,is_inside,'TEST_IS_INSIDE_POLYGON') + +end subroutine test_is_inside_polygon +!------------------------------------------------------! +subroutine check_answer(answer, myvalue, whoami) + + implicit none + class(*) :: answer + class(*) :: myvalue + character(*) :: whoami + + select type(answer) + type is ( logical ) + select type(myvalue) + type is( logical ) + if( answer .neqv. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + type is( real(r4_kind) ) + select type( myvalue) + type is(real(r4_kind) ) + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + write(*,*) 'difference of', abs(answer-myvalue) + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + type is( real(r8_kind) ) + select type( myvalue) + type is(real(r4_kind) ) + if( answer .ne. myvalue ) then + write(*,*) '*************************************' + write(*,*) 'EXPECTED ', answer, 'but got ', myvalue + write(*,*) 'difference of', abs(answer-myvalue) + call mpp_error( FATAL,'failed '//trim(whoami) ) + end if + end select + end select + +end subroutine check_answer +!------------------------------------------------------! +end program test_mosaic diff --git a/test_fms/mosaic/test_mosaic2.sh b/test_fms/mosaic2/test_mosaic2.sh similarity index 71% rename from test_fms/mosaic/test_mosaic2.sh rename to test_fms/mosaic2/test_mosaic2.sh index f67991a9a3..93d0b357c7 100755 --- a/test_fms/mosaic/test_mosaic2.sh +++ b/test_fms/mosaic2/test_mosaic2.sh @@ -20,7 +20,7 @@ #*********************************************************************** # This is part of the GFDL FMS package. This is a shell script to -# execute tests in the test_fms/field_manager directory. +# execute tests in the test_fms/mosaic directory. # Ed Hartnett 11/29/19 @@ -31,8 +31,13 @@ touch input.nml rm -rf INPUT mkdir INPUT -test_expect_success "test mosaic" ' - mpirun -n 2 ./test_mosaic -' + +# The tests are skipped if FMS is compiled in r4 via ./configure --enable-mixedmode +# because answers differ when FMS is compiled in r4. +test_expect_success "test mosaic2 r4" 'mpirun -n 1 ./test_mosaic2_r4' +test_expect_success "test grid2 r4" 'mpirun -n 1 ./test_grid2_r4' +test_expect_success "test mosaic2 r8" 'mpirun -n 1 ./test_mosaic2_r8' +test_expect_success "test grid2 r8" 'mpirun -n 1 ./test_grid2_r8' + rm -rf INPUT test_done diff --git a/test_fms/mosaic2/write_files.inc b/test_fms/mosaic2/write_files.inc new file mode 100644 index 0000000000..4bb247eb31 --- /dev/null +++ b/test_fms/mosaic2/write_files.inc @@ -0,0 +1,351 @@ +module write_files + + use fms2_io_mod, only: fms2_io_init, open_file, close_file, FmsNetcdfFile_t + use fms2_io_mod, only: register_axis, register_field, write_data + use mpp_mod, only: mpp_init, mpp_sync, mpp_npes, mpp_get_current_pelist + use fms_mod, only: fms_init + use constants_mod, only: PI, RADIUS + use platform_mod, only :r4_kind, r8_kind + + implicit none + + character(23), parameter :: grid_spec_file="grid_spec.nc" + character(23), parameter :: c1_mosaic_file="C1_mosaic.nc" + character(30), parameter :: ocn_mosaic_file="ocean_mosaic.nc" + character(50), parameter :: exchange_file="C96_mosaic_tile1Xocean_mosaic_tile1.nc" + character(30), parameter :: ocn_tile_file="ocean_hgrid.nc" + character(23), parameter :: tile1_file="C1_grid.tile1.nc" + character(23), parameter :: tile2_file="C1_grid.tile2.nc" + character(23), parameter :: tile3_file="C1_grid.tile3.nc" + character(23), parameter :: tile4_file="C1_grid.tile4.nc" + character(23), parameter :: tile5_file="C1_grid.tile5.nc" + character(23), parameter :: tile6_file="C1_grid.tile6.nc" + + ! atm and land + integer, parameter :: c1_nx=2 !x---x----x + integer, parameter :: c1_ny=2 !| | + integer, parameter :: c1_nxp=3 !x x x + integer, parameter :: c1_nyp=3 !| | + integer, parameter :: c1_ntiles=6 !x---x----x + integer, parameter :: c1_ncontacts=12 + + !ocn + integer, parameter :: ocn_nx=2880 + integer, parameter :: ocn_ny=2160 + integer, parameter :: ocn_ntiles=1 + integer, parameter :: ocn_ncontacts=2 + + !exchange + integer, parameter :: ncells=2 + + ! variables for tile1 + character(5) :: tile + real(TEST_MOS_KIND_), dimension(c1_nxp,c1_nyp) :: x + real(TEST_MOS_KIND_), dimension(c1_nxp,c1_nyp) :: y + real(TEST_MOS_KIND_), dimension(c1_nx,c1_ny) :: area + + !variables for exchange grid cells + real(TEST_MOS_KIND_), dimension(2,ncells) :: tile1_cell, tile2_cell + real(TEST_MOS_KIND_), dimension(ncells) :: xgrid_area + + integer, parameter :: lkind=TEST_MOS_KIND_ !< local kind parameter + +contains + !---------------------------------! + subroutine write_grid_spec + + implicit none + type(FmsNetcdfFile_t) :: fileobj + integer, allocatable :: pes(:) + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + if( open_file(fileobj, 'INPUT/'//grid_spec_file, 'overwrite', pelist=pes) ) then + call register_axis(fileobj, "string", 128) + + call register_field(fileobj, "atm_mosaic_file", "char", dimensions=(/"string"/)) + call register_field(fileobj, "lnd_mosaic_file", "char", dimensions=(/"string"/)) + call register_field(fileobj, "ocn_mosaic_file", "char", dimensions=(/"string"/)) + + call write_data(fileobj, "atm_mosaic_file", "C1_mosaic.nc") + call write_data(fileobj, "lnd_mosaic_file", "C1_mosaic.nc") + call write_data(fileobj, "ocn_mosaic_file", "ocean_mosaic.nc") + + call close_file(fileobj) + end if + + end subroutine write_grid_spec + !---------------------------------! + subroutine write_c1_mosaic + + implicit none + + type(FmsNetcdfFile_t) :: fileobj + integer, allocatable :: pes(:) + + character(50), dimension(c1_ntiles) :: strings6 + character(50), dimension(c1_ncontacts) :: strings12 + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + + if( open_file(fileobj, 'INPUT/'//trim(c1_mosaic_file), 'overwrite', pelist=pes) ) then + + call register_axis(fileobj, 'ntiles', c1_ntiles) + call register_axis(fileobj, 'ncontact', c1_ncontacts) + call register_axis(fileobj, 'string', 55) + + call register_field(fileobj, 'mosaic', 'char', dimensions=(/'string'/)) + call register_field(fileobj, 'gridfiles', 'char', dimensions=(/'string','ntiles'/)) + call register_field(fileobj, "gridtiles", "char", dimensions=(/"string","ntiles"/)) + call register_field(fileobj, "contacts", "char", dimensions=(/"string ","ncontact"/)) + call register_field(fileobj, "contact_index", "char", dimensions=(/"string ","ncontact"/)) + + call write_data(fileobj, "mosaic", "C1_mosaic") + + strings6(1)=tile1_file + strings6(2)=tile2_file + strings6(3)=tile3_file + strings6(4)=tile4_file + strings6(5)=tile5_file + strings6(6)=tile6_file + call write_data(fileobj, "gridfiles", strings6) + + strings6(1)='tile1' + strings6(2)='tile2' + strings6(3)='tile3' + strings6(4)='tile4' + strings6(5)='tile5' + strings6(6)='tile6' + call write_data(fileobj, "gridtiles", strings6) + + strings12(1) ="C1_mosaic:tile1::C1_mosaic:tile2" + strings12(2) ="C1_mosaic:tile1::C1_mosaic:tile3" + strings12(3) ="C1_mosaic:tile1::C1_mosaic:tile5" + strings12(4) ="C1_mosaic:tile1::C1_mosaic:tile6" + strings12(5) ="C1_mosaic:tile2::C1_mosaic:tile3" + strings12(6) ="C1_mosaic:tile2::C1_mosaic:tile4" + strings12(7) ="C1_mosaic:tile2::C1_mosaic:tile6" + strings12(8) ="C1_mosaic:tile3::C1_mosaic:tile4" + strings12(9) ="C1_mosaic:tile3::C1_mosaic:tile5" + strings12(10)="C1_mosaic:tile4::C1_mosaic:tile5" + strings12(11)="C1_mosaic:tile4::C1_mosaic:tile6" + strings12(12)="C1_mosaic:tile5::C1_mosaic:tile6" + call write_data(fileobj, "contacts", strings12) + + strings12(1) ="2:2,1:2::1:1,1:2" + strings12(2) ="1:2,2:2::1:1,2:1" + strings12(3) ="1:1,1:2::2:1,2:2" + strings12(4) ="1:2,1:1::1:2,2:2" + strings12(5) ="1:2,2:2::1:2,1:1" + strings12(6) ="2:2,1:2::2:1,1:1" + strings12(7) ="1:2,1:1::2:2,2:1" + strings12(8) ="2:2,1:2::1:1,1:2" + strings12(9) ="1:2,2:2::1:1,2:1" + strings12(10)="1:2,2:2::1:2,1:1" + strings12(11)="2:2,1:2::2:1,1:1" + strings12(12)="2:2,1:2::1:1,1:2" + call write_data(fileobj, "contact_index", strings12) + + call close_file(fileobj) + + end if + + end subroutine write_c1_mosaic + !---------------------------------! + subroutine write_c1_tiles + + !> These are made up numbers, numbers chosen + !! for computational convenience + + implicit none + + character(5) :: tile + real(TEST_MOS_KIND_), parameter :: area_value = real(PI*RADIUS*RADIUS/2.0_r8_kind, TEST_MOS_KIND_) + real(r8_kind) :: xtmp(c1_nxp, c1_nyp), ytmp(c1_nxp, c1_nyp) + + xtmp(1,1)=0.0_r8_kind ; xtmp(2,1)=90.0_r8_kind ; xtmp(3,1)=180.0_r8_kind + xtmp(1,2)=0.0_r8_kind ; xtmp(2,2)=90.0_r8_kind ; xtmp(3,2)=180.0_r8_kind + xtmp(1,3)=0.0_r8_kind ; xtmp(2,3)=90.0_r8_kind ; xtmp(3,3)=180.0_r8_kind + + x = real(xtmp,lkind) + + ytmp(1,1)=-90.0_r8_kind ; ytmp(2,1)=-90.0_r8_kind ; ytmp(3,1)=-90.0_r8_kind + ytmp(1,2)= 0.0_r8_kind ; ytmp(2,2)= 0.0_r8_kind ; ytmp(3,2)= 0.0_r8_kind + ytmp(1,3)= 90.0_r8_kind ; ytmp(2,3)= 90.0_r8_kind ; ytmp(3,3)= 90.0_r8_kind + + y = real(ytmp,lkind) + + area(1,1)=area_value ; area(2,1)=area_value + area(1,2)=area_value ; area(2,2)=area_value + + tile='tile1' ; call call_fms2_io(tile1_file, tile, x, y, area) + tile='tile2' ; call call_fms2_io(tile2_file, tile, x, y, area) + tile='tile3' ; call call_fms2_io(tile3_file, tile, x, y, area) + tile='tile4' ; call call_fms2_io(tile4_file, tile, x, y, area) + tile='tile5' ; call call_fms2_io(tile5_file, tile, x, y, area) + tile='tile6' ; call call_fms2_io(tile6_file, tile, x, y, area) + + end subroutine write_c1_tiles + !-----------------------------------! + subroutine call_fms2_io(filename, tile, x_in, y_in, area_in) + + implicit none + + character(*) :: filename + character(*) :: tile + real(TEST_MOS_KIND_), dimension(c1_nxp,c1_nyp), intent(in) :: x_in, y_in + real(TEST_MOS_KIND_), dimension(c1_nx,c1_ny), intent(in) :: area_in + + type(FmsNetcdfFile_t) :: fileobj + integer, allocatable :: pes(:) + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + if( open_file(fileobj, 'INPUT/'//trim(filename), 'overwrite', pelist=pes) ) then + + call register_axis(fileobj, "nx", c1_nx) + call register_axis(fileobj, "ny", c1_ny) + call register_axis(fileobj, 'nxp', c1_nxp) + call register_axis(fileobj, 'nyp', c1_nyp) + call register_axis(fileobj, "string", 5) + + call register_field(fileobj, 'tile', 'char', dimensions=(/'string'/)) + call register_field(fileobj, 'x', 'double', dimensions=(/'nxp', 'nyp'/)) + call register_field(fileobj, 'y', 'double', dimensions=(/'nxp', 'nyp'/)) + call register_field(fileobj, 'area', 'double', dimensions=(/'nx','ny'/)) + + call write_data(fileobj, 'tile', trim(tile)) + call write_data(fileobj, 'x', x_in) + call write_data(fileobj, 'y', y_in) + call write_data(fileobj, 'area', area_in) + + call close_file(fileobj) + + end if + + end subroutine call_fms2_io + !---------------------------------! + subroutine write_ocean_mosaic() + + !> from @uriel.ramirez + + implicit none + + type(FmsNetcdfFile_t):: fileobj !< Fileobj for the files written by the test + integer, allocatable :: pes(:) + + character(38), dimension(ocn_ntiles) :: strings1 + character(38), dimension(ocn_ncontacts) :: strings2 + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + if( open_file(fileobj, 'INPUT/'//ocn_mosaic_file, 'overwrite', pelist=pes)) then + call register_axis(fileobj, "ntiles", ocn_ntiles) + call register_axis(fileobj, "ncontact", ocn_ncontacts) + call register_axis(fileobj, "string", 50) + + call register_field(fileobj, "contacts", "char", dimensions=(/"string ","ncontact"/)) + call register_field(fileobj, "contact_index", "char", dimensions=(/"string ","ncontact"/)) + call register_field(fileobj, "gridfiles", "char", dimensions=(/"string", "ntiles"/)) + call register_field(fileobj, "gridtiles", "char", dimensions=(/"string", "ntiles"/)) + + strings1(1)=ocn_tile_file + call write_data(fileobj, "gridfiles",strings1) + + strings1(1)='tile1' + call write_data(fileobj, "gridtiles",strings1) + + strings2(1)="2880:2880,1:2160::1:1,1:2160" + strings2(2)="1:1440,2160:2160::2880:1441,2160:2160" + call write_data(fileobj, "contact_index", strings2) + + strings2(1)="ocean_mosaic:tile1::ocean_mosaic:tile1" + strings2(2)="ocean_mosaic:tile1::ocean_mosaic:tile1" + call write_data(fileobj, "contacts", strings2) + + call close_file(fileobj) + endif + + end subroutine write_ocean_mosaic + !---------------------------------- + subroutine write_exchange + + implicit none + + type(FmsNetcdfFile_t):: fileobj !< Fileobj for the files written by the test + integer, allocatable :: pes(:) + integer :: i, j, k + real(r8_kind) :: get_global_area !< get_global_area returns a double + + !> These are made up numbers, numbers chosen + !! for computational convenience + + do i=1,ncells + tile1_cell(1,i) = i + tile1_cell(2,i) = i + tile2_cell(1,i) = i + tile2_cell(2,i) = i + end do + + do i=1, ncells + xgrid_area(i) = real(get_global_area(), TEST_MOS_KIND_) + end do + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + if( open_file(fileobj, 'INPUT/'//trim(exchange_file), "overwrite", pelist=pes)) then + call register_axis(fileobj, "ncells", ncells) + call register_axis(fileobj, "two", 2) + + call register_field(fileobj, "tile1_cell", "double", dimensions=(/"two ", "ncells"/)) + call register_field(fileobj, "tile2_cell", "double", dimensions=(/"two ", "ncells"/)) + call register_field(fileobj, "xgrid_area", "double", dimensions=(/"ncells"/)) + + call write_data(fileobj, "tile1_cell", tile1_cell) + call write_data(fileobj, "tile2_cell", tile2_cell) + call write_data(fileobj, "xgrid_area", xgrid_area) + + call close_file(fileobj) + end if + + end subroutine write_exchange + !---------------------------------- + subroutine write_hgrid + + !> from @uriel.ramirez + + implicit none + + type(FmsNetcdfFile_t):: fileobj !< Fileobj for the files written by the test + integer, allocatable :: pes(:) + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + if( open_file(fileobj, 'INPUT/'//ocn_tile_file, "overwrite", pelist=pes)) then + call register_axis(fileobj, "nx", ocn_nx) + call register_axis(fileobj, "ny", ocn_ny) + + call close_file(fileobj) + endif + + end subroutine write_hgrid + !---------------------------------! + subroutine write_all + + implicit none + call write_grid_spec() + call write_c1_mosaic() + call write_ocean_mosaic() + call write_c1_tiles() + call write_hgrid() + call write_exchange() + + end subroutine write_all + !---------------------------------! +end module write_files diff --git a/test_fms/test-lib.sh.in b/test_fms/test-lib.sh.in index b983b48d84..9be57a630a 100644 --- a/test_fms/test-lib.sh.in +++ b/test_fms/test-lib.sh.in @@ -96,8 +96,10 @@ mpirun () { # Set the name of the mpi launcher for use in test scripts. local mpi_launcher='@MPI_LAUNCHER@' local oversubscribe='@OVERSUBSCRIBE@' + # need to strip off any args that may be included with MPI_LAUNCHER arg for check below to work + local mpi_cmd="`echo $mpi_launcher | awk '{print $1;}'`" # Check if running with MPI: if so, the mpi_launcher will point to a command - command -v "$mpi_launcher" 2>&1 > /dev/null + command -v "$mpi_cmd" 2>&1 > /dev/null if test $? -eq 0 then # use `command` to keep from reusing this function diff --git a/test_fms/mosaic/Makefile.am b/test_fms/topography/Makefile.am similarity index 67% rename from test_fms/mosaic/Makefile.am rename to test_fms/topography/Makefile.am index ff36605e0a..8f873da1a9 100644 --- a/test_fms/mosaic/Makefile.am +++ b/test_fms/topography/Makefile.am @@ -17,32 +17,39 @@ #* License along with FMS. If not, see . #*********************************************************************** -# This is an automake file for the test_fms/mosaic directory of the +# This is an automake file for the test_fms/topography directory of the # FMS package. -# uramirez, Ed Hartnett +# Caitlyn McAllister -# Find the needed mod and include files. +# Find the fms and mpp mod files. AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) # Link to the FMS library. LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. -check_PROGRAMS = test_mosaic +check_PROGRAMS = \ + test_topography_r4 \ + test_topography_r8 # This is the source code for the test. -test_mosaic_SOURCES = test_mosaic.F90 +test_topography_r4_SOURCES = test_topography.F90 +test_topography_r8_SOURCES = test_topography.F90 + +# Set r4_kind and r8_kind +test_topography_r4_CPPFLAGS = $(AM_CPPFLAGS) -DTEST_TOP_KIND_=r4_kind +test_topography_r8_CPPFLAGS = $(AM_CPPFLAGS) -DTEST_TOP_KIND_=r8_kind # Run the test program. -TESTS = test_mosaic2.sh +TESTS = test_topography.sh + +# Copy over other needed files to the srcdir +EXTRA_DIST = test_topography.sh TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ $(abs_top_srcdir)/test_fms/tap-driver.sh -# These files are also included in the distribution. -EXTRA_DIST = test_mosaic2.sh - # Clean up -CLEANFILES = input.nml *.nc *.out *.dpi *.spi *.dyn *.spl +CLEANFILES = input.nml *.out* *.dpi *.spi *.dyn *.spl *.nc diff --git a/test_fms/topography/test_topography.F90 b/test_fms/topography/test_topography.F90 new file mode 100644 index 0000000000..0ccbebd63e --- /dev/null +++ b/test_fms/topography/test_topography.F90 @@ -0,0 +1,355 @@ +!*********************************************************************** +!* 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 +!> @author Caitlyn McAllister +!> @brief Unit tests for topography_mod +!> @email gfdl.climate.model.info@noaa.gov +!> @description This suit includes testing for all public functions available +!! in the topography module +!! TODO: More intricate data with larger arrays for lat, lon, and 'zdat' should +!! be added and included +!! TODO: More tests to check a wider range of indices for zmean2d/1d, stdev2d/1d, ocean_mask2d/1d, +!! ocean_frac2d/1d, ocean_mask2d/1d, water_frac2d/1d, and water_mask2d/1d + +program test_top + + use gaussian_topog_mod, only: gaussian_topog_init, get_gaussian_topog + use topography_mod, only: topography_init, get_topog_mean, get_topog_stdev, & + get_ocean_frac, get_ocean_mask, get_water_frac, & + get_water_mask + use fms_mod, only: fms_init, fms_end + use fms2_io_mod, only: fms2_io_init, FmsNetcdfFile_t, open_file, close_file, register_axis, register_field, & + register_variable_attribute, write_data, read_data, unlimited + use mpp_mod, only: mpp_error, FATAL, stdout, mpp_init, mpp_exit + use mpp_mod, only: mpp_pe, mpp_root_pe, mpp_sync, input_nml_file + use horiz_interp_mod, only: horiz_interp_type, horiz_interp_new, & + horiz_interp, horiz_interp_del + use constants_mod, only: pi + use platform_mod, only: r4_kind, r8_kind + + implicit none + + type(FmsNetcdfFile_t) :: top_fileobj ! fileobj for fms2_io + character(len=128) :: topog_file, water_file ! filenames needed for topography_mod + real(kind=TEST_TOP_KIND_) :: xdat(3), ydat(3), zdat(2,2) ! specifc data topog_mod looks for + integer :: ipts, jpts ! axis for files + integer :: iptsp1, jptsp1 ! serves as a counter for data + integer :: ipts_r, jpts_r ! sub axis + integer, parameter :: lkind = TEST_TOP_KIND_ ! kind parameter for mixed precision + + real(kind=TEST_TOP_KIND_), parameter :: deg2rad = real(pi, TEST_TOP_KIND_)/180.0_lkind + real(kind=TEST_TOP_KIND_), dimension(2,2) :: lon2d, lat2d ! in radians + real(kind=TEST_TOP_KIND_), dimension(2) :: lon1d, lat1d ! in radians + + call fms_init + call topography_init + + !-------------------------------------------------------------------------------------------------------------! + + ! define blat and blon, in this test they'll be referred to as lat2d/lon2d, lat1d/lon1d + ! these ordered pair for lon and lat create a perfect square for calculation purposes + lon2d(1,1) = 1.5_lkind*deg2rad ; lat2d(1,1) = 1.5_lkind*deg2rad + lon2d(2,1) = 2.5_lkind*deg2rad ; lat2d(2,1) = 1.5_lkind*deg2rad + lon2d(1,2) = 1.5_lkind*deg2rad ; lat2d(1,2) = 2.5_lkind*deg2rad + lon2d(2,2) = 2.5_lkind*deg2rad ; lat2d(2,2) = 2.5_lkind*deg2rad + + lon1d(1) = 1.5_lkind*deg2rad ; lat1d(1) = 1.5_lkind*deg2rad + lon1d(2) = 2.5_lkind*deg2rad ; lat1d(2) = 1.5_lkind*deg2rad + + ! name files + topog_file = "topography.data.nc" + water_file = "water.data.nc" + + ! create data for both topog and water files + ipts_r = 1 ; ipts = 2 ; iptsp1 = 3 ! axes an sub-axes sizes + jpts_r = 1 ; jpts = 2 ; jptsp1 = 3 + + + xdat = (/1.0_lkind*deg2rad, 2.0_lkind*deg2rad, 3.0_lkind*deg2rad/) !size of iptsp1, in radians + ydat = (/1.0_lkind*deg2rad, 2.0_lkind*deg2rad, 3.0_lkind*deg2rad/) !size of jptsp1, in radians + + zdat(1,1) = 0.0_lkind ; zdat(1,2) = 1.0_lkind + zdat(2,1) = 1.0_lkind ; zdat(2,2) = 0.0_lkind !size of (ipts, jpts) + !-------------------------------------------------------------------------------------------------------------! + + ! write topog file + if (open_file(top_fileobj, topog_file, "overwrite")) then + call register_axis(top_fileobj, "i_zdat", ipts) !first index dimension in zdat + call register_axis(top_fileobj, "j_zdat", jpts) !second index dimension in zdat + call register_axis(top_fileobj, "ipts_r", ipts_r) + call register_axis(top_fileobj, "jpts_r", jpts_r) + call register_axis(top_fileobj, "i_xdat", iptsp1) !# of points in xdat variable + call register_axis(top_fileobj, "j_ydat", jptsp1) !# of point in ydat variable + + call register_field(top_fileobj, "ipts", "double", dimensions=(/"ipts_r"/)) + call register_field(top_fileobj, "jpts", "double", dimensions=(/"jpts_r"/)) + call register_field(top_fileobj, "xdat", "double", dimensions=(/"i_xdat"/)) + call register_field(top_fileobj, "ydat", "double", dimensions=(/"j_ydat"/)) + call register_field(top_fileobj, "zdat", "double", dimensions=(/"i_zdat", "j_zdat"/)) + + call write_data(top_fileobj, "ipts", real(ipts, TEST_TOP_KIND_)) + call write_data(top_fileobj, "jpts", real(jpts, TEST_TOP_KIND_)) + call write_data(top_fileobj, "xdat", xdat) + call write_data(top_fileobj, "ydat", ydat) + call write_data(top_fileobj, "zdat", zdat) + + call close_file(top_fileobj) + + else + call mpp_error(FATAL, "test_topography: error opening topog_file") + end if + !-------------------------------------------------------------------------------------------------------------! + + ! write water file + if (open_file(top_fileobj, water_file, "overwrite")) then + call register_axis(top_fileobj, "i_zdat", ipts) !first index dimension in zdat + call register_axis(top_fileobj, "j_zdat", jpts) !second index dimension in zdat + call register_axis(top_fileobj, "ipts_r", ipts_r) + call register_axis(top_fileobj, "jpts_r", jpts_r) + call register_axis(top_fileobj, "i_xdat", iptsp1) !# of points in xdat variable + call register_axis(top_fileobj, "j_ydat", jptsp1) !# of point in ydat variable + + call register_field(top_fileobj, "ipts", "double", dimensions=(/"ipts_r"/)) + call register_field(top_fileobj, "jpts", "double", dimensions=(/"jpts_r"/)) + call register_field(top_fileobj, "xdat", "double", dimensions=(/"i_xdat"/)) + call register_field(top_fileobj, "ydat", "double", dimensions=(/"j_ydat"/)) + call register_field(top_fileobj, "zdat", "double", dimensions=(/"i_zdat", "j_zdat"/)) + + call write_data(top_fileobj, "ipts", real(ipts, TEST_TOP_KIND_)) + call write_data(top_fileobj, "jpts", real(jpts, TEST_TOP_KIND_)) + call write_data(top_fileobj, "xdat", xdat) + call write_data(top_fileobj, "ydat", ydat) + call write_data(top_fileobj, "zdat", zdat) + + call close_file(top_fileobj) + + else + call mpp_error(FATAL, "test_topography: error opening water_file") + end if + !-------------------------------------------------------------------------------------------------------------! + + call test_topog_mean ; call test_topog_stdev + call test_get_ocean_frac ; call test_get_ocean_mask + call test_get_water_frac ; call test_get_water_mask + + call fms_end + + contains + + subroutine test_topog_mean() + !! The naming convention of zmean2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both zmean2d and zmean1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: zmean2d + real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: zmean1d + logical :: get_mean_answer + + !---------------------------------------- test topog mean 2d ---------------------------------------------! + + get_mean_answer = get_topog_mean(lon2d, lat2d, zmean2d) + + if (get_mean_answer .neqv. .true.) call mpp_error(FATAL, "topog field not read correctly") + call check_answers(zmean2d(1,1), 0.5_lkind, "Error in test_topog_mean 2d") + ! in the case of this simplistic test, size(zmean2d) = 1, more tests should be created + ! with a larger zmean2d array size + + !---------------------------------------- test topog mean 1d ---------------------------------------------! + + get_mean_answer = get_topog_mean(lon1d, lat1d, zmean1d) + + if (get_mean_answer .neqv. .true.) call mpp_error(FATAL, "topog field not read correctly") + call check_answers(zmean1d(1,1), 0.5_lkind, "Error in test_topog_mean 1d") + ! in the case of this simplistic test, size(zmean1d) = 1, more tests should be created + ! with a larger zmean1d array size + + end subroutine test_topog_mean + + subroutine test_topog_stdev + + !! The naming convention of stdev2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both stdev2d and stdev1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: stdev2d + real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: stdev1d + logical :: get_stdev_answer + + !---------------------------------------- test topog stdev 2d ---------------------------------------------! + + get_stdev_answer = get_topog_stdev(lon2d, lat2d, stdev2d) + + if (get_stdev_answer .neqv. .true.) call mpp_error(FATAL, "topog field not read correctly") + call check_answers(stdev2d(1,1), 0.5_lkind, "Error in test_topog_stdev 2d") + ! in the case of this simplistic test, size(stdev2d) = 1, more tests should be created + ! with a larger stdev2d array size + + !---------------------------------------- test topog stdev 2d ---------------------------------------------! + + get_stdev_answer = get_topog_stdev(lon1d, lat1d, stdev1d) + + if (get_stdev_answer .neqv. .true.) call mpp_error(FATAL, "topog field not read correctly") + call check_answers(stdev1d(1,1), 0.5_lkind, "Error in test_topog_stdev 1d") + ! in the case of this simplistic test, size(stdev1d) = 1, more tests should be created + ! with a larger stdev1d array size + + end subroutine test_topog_stdev + + subroutine test_get_ocean_frac + + !! The naming convention of ocean_frac2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both ocean_frac2d and ocean_frac1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: ocean_frac2d + real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: ocean_frac1d + logical :: get_ocean_frac_answer + + !---------------------------------------- test get_ocean_frac 2d ---------------------------------------------! + + get_ocean_frac_answer = get_ocean_frac(lon2d, lat2d, ocean_frac2d) + + if (get_ocean_frac_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + call check_answers(ocean_frac2d(1,1), 0.5_lkind, "Error in test_get_ocean_frac 2d") + ! in the case of this simplistic test, size(ocean_frac2d) = 1, more tests should be created + ! with a larger ocean_frac2d array size + + !---------------------------------------- test get_ocean_frac 1d ---------------------------------------------! + + get_ocean_frac_answer = get_ocean_frac(lon1d, lat1d, ocean_frac1d) + + if (get_ocean_frac_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + call check_answers(ocean_frac1d(1,1), 0.5_lkind, "Error in test_get_ocean_frac 1d") + ! in the case of this simplistic test, size(ocean_frac1d) = 1, more tests should be created + ! with a larger ocean_frac1d array size + end subroutine test_get_ocean_frac + + subroutine test_get_ocean_mask + + !! The naming convention of ocean_mask2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both ocean_mask2d and ocean_mask1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + logical, dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: ocean_mask2d + logical, dimension(size(lon1d)-1,size(lat1d)-1) :: ocean_mask1d + logical :: get_ocean_mask_answer + + !---------------------------------------- test get_ocean_mask 2d ---------------------------------------------! + + get_ocean_mask_answer = get_ocean_mask(lon2d, lat2d, ocean_mask2d) + + + if (get_ocean_mask_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + if (ocean_mask2d(1,1) .neqv. .false.) call mpp_error(FATAL, "test_get_ocean_mask 2d: ocean mask should be false") + ! in the case of this simplistic test, size(ocean_mask2d) = 1, more tests should be created + ! with a larger ocean_mask2d array size + + !---------------------------------------- test get_ocean_mask 1d ---------------------------------------------! + + get_ocean_mask_answer = get_ocean_mask(lon1d, lat1d, ocean_mask1d) + + if (get_ocean_mask_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + if (ocean_mask1d(1,1) .neqv. .false.) call mpp_error(FATAL, "test_get_ocean_mask 1d: ocean mask should be false") + ! ! in the case of this simplistic test, size(ocean_mask1d) = 1, more tests should be created + ! with a larger ocean_mask1d array size + + end subroutine test_get_ocean_mask + + subroutine test_get_water_frac + !! The naming convention of water_frac2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both water_frac2d and water_frac1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: water_frac2d + real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: water_frac1d + logical :: get_water_frac_answer + + !---------------------------------------- test get_water_frac 2d ---------------------------------------------! + + get_water_frac_answer = get_water_frac(lon2d, lat2d, water_frac2d) + + if (get_water_frac_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + call check_answers(water_frac2d(1,1), 0.5_lkind, "Error in test_get_water_frac 2d") + ! in the case of this simplistic test, size(water_frac2d) = 1, more tests should be created + ! with a larger water_frac2d array size + + !---------------------------------------- test get_water_frac 1d ---------------------------------------------! + + get_water_frac_answer = get_water_frac(lon1d, lat1d, water_frac1d) + + if (get_water_frac_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + call check_answers(water_frac1d(1,1), 0.5_lkind, "Error in test_get_ocean_frac 1d") + ! in the case of this simplistic test, size(water_frac1d) = 1, more tests should be created + ! with a larger water_frac1d array size + + end subroutine test_get_water_frac + + subroutine test_get_water_mask + + !! The naming convention of water_mask2d/1d in this routine does not relate to their + !! dimensions but correlates with what dimensions of lat and lon they are being + !! tested with. In this case, the sizes of both water_mask2d and water_mask1d are both the + !! same size but have to be these specific dimensions per the topography_mod code + implicit none + logical, dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: water_mask2d + logical, dimension(size(lon1d)-1,size(lat1d)-1) :: water_mask1d + logical :: get_water_mask_answer + + !---------------------------------------- test get_water_mask 2d ---------------------------------------------! + + get_water_mask_answer = get_water_mask(lon2d, lat2d, water_mask2d) + + if (get_water_mask_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + if (water_mask2d(1,1) .neqv. .false.) call mpp_error(FATAL, "test_get_water_mask 2d: ocean mask should be false") + ! in the case of this simplistic test, size(water_mask2d) = 1, more tests should be created + ! with a larger water_mask2d array size + + !---------------------------------------- test get_water_mask 1d ---------------------------------------------! + + get_water_mask_answer = get_ocean_mask(lon1d, lat1d, water_mask1d) + + if (get_water_mask_answer .neqv. .true.) call mpp_error(FATAL, "ocean field not read correctly") + if (water_mask1d(1,1) .neqv. .false.) call mpp_error(FATAL, "test_get_ocean_mask 1d: ocean mask should be false") + ! in the case of this simplistic test, size(water_mask1d) = 1, more tests should be created + ! with a larger water_mask1d array size + + end subroutine test_get_water_mask + + subroutine check_answers(calculated_answer, expected_answer, what_error) + + implicit none + real(kind=TEST_TOP_KIND_) :: calculated_answer ! value calculated from script + real(kind=TEST_TOP_KIND_) :: expected_answer ! expected answer + character(*) :: what_error ! error message to print + + if (calculated_answer.ne. expected_answer) then + write(*,*) 'Expected ', expected_answer, ' but computed ', calculated_answer + call mpp_error(FATAL, trim(what_error)) + end if + + end subroutine check_answers + + + +end program test_top \ No newline at end of file diff --git a/test_fms/topography/test_topography.sh b/test_fms/topography/test_topography.sh new file mode 100755 index 0000000000..f9c55afda5 --- /dev/null +++ b/test_fms/topography/test_topography.sh @@ -0,0 +1,53 @@ +#!/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/astronomy directory. + +# Caitlyn McAllister + +# Set common test settings. +. ../test-lib.sh + +# Prepare the directory to run the tests. +cat < input.nml +&topography_nml + topog_file = "topography.data.nc", + water_file = "water.data.nc" +/ + +EOF + +# Run the test. + +test_expect_success "Test topography: r4_kind" ' + mpirun -n 1 ./test_topography_r4 +' + +sync; rm -f *.nc + +test_expect_success "Test topography: r8_kind" ' + mpirun -n 1 ./test_topography_r8 +' + +rm -f *.nc + +test_done diff --git a/test_fms/tridiagonal/Makefile.am b/test_fms/tridiagonal/Makefile.am new file mode 100644 index 0000000000..211869202b --- /dev/null +++ b/test_fms/tridiagonal/Makefile.am @@ -0,0 +1,52 @@ +#*********************************************************************** +#* 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 an automake file for the test_fms/tridiagonal directory of the FMS +# package. + +# Ryan Mulhall + +# Find the .mod directory +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) + +# Link to the FMS library. +LDADD = $(top_builddir)/libFMS/libFMS.la + +# Build this test program. +check_PROGRAMS = test_tridiagonal_r4 test_tridiagonal_r8 + +# compiles test file with both kind sizes via macro +test_tridiagonal_r4_SOURCES=test_tridiagonal.F90 +test_tridiagonal_r8_SOURCES=test_tridiagonal.F90 + +test_tridiagonal_r4_CPPFLAGS=-DTRID_REAL_TYPE=tridiag_r4 -DTEST_TRIDIAG_REAL=r4_kind -I$(MODDIR) +test_tridiagonal_r8_CPPFLAGS=-DTRID_REAL_TYPE=tridiag_r8 -DTEST_TRIDIAG_REAL=r8_kind -I$(MODDIR) + +# Run the test program. +TESTS = test_tridiagonal.sh + +TEST_EXTENSIONS = .sh +SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ + $(abs_top_srcdir)/test_fms/tap-driver.sh + +# These files will be included in the distribution. +EXTRA_DIST = test_tridiagonal.sh + +# Clean up +CLEANFILES = *.nml *.out* *.dpi *.spi *.dyn *.spl *.o test_tridiagonal4 test_tridiagonal8 test_tridiagonal diff --git a/test_fms/tridiagonal/test_tridiagonal.F90 b/test_fms/tridiagonal/test_tridiagonal.F90 new file mode 100644 index 0000000000..18200a8c77 --- /dev/null +++ b/test_fms/tridiagonal/test_tridiagonal.F90 @@ -0,0 +1,173 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** +#ifndef TEST_TRIDIAG_KIND +#define TEST_TRIDIAG_KIND 8 +#endif + +!> Tests the tridiagonal module routines (tri_invert and close_tridiagonal) +!! Tests reals with the kind value set above, +program test_tridiagonal + + use tridiagonal_mod + use platform_mod + use mpp_mod + use fms_mod + + implicit none + + integer, parameter :: IN_LEN = 8 !< length of input arrays + integer, parameter :: kindl = TEST_TRIDIAG_KIND !< kind value for all reals in this test + !! set by TEST_TRIDIAG_KIND cpp macro + real(TEST_TRIDIAG_KIND), allocatable :: d(:,:,:), x(:,:,:), ref_array(:,:,:) + real(TEST_TRIDIAG_KIND), allocatable :: a(:,:,:), b(:,:,:), c(:,:,:) + real(r4_kind), allocatable :: d_r4(:,:,:), x_r4(:,:,:) + real(r4_kind), allocatable :: a_r4(:,:,:), b_r4(:,:,:), c_r4(:,:,:) + real(r8_kind), allocatable :: d_r8(:,:,:), x_r8(:,:,:) + real(r8_kind), allocatable :: a_r8(:,:,:), b_r8(:,:,:), c_r8(:,:,:) + integer :: i, end, ierr, io + real(TEST_TRIDIAG_KIND) :: k + ! nml + logical :: do_error_check = .false. + namelist / test_tridiagonal_nml/ do_error_check + + call mpp_init + + read (input_nml_file, test_tridiagonal_nml, iostat=io) + ierr = check_nml_error (io, 'test_tridiagonal_nml') + + ! allocate input and output arrays + allocate(d(1,1,IN_LEN)) + allocate(a(1,1,IN_LEN)) + allocate(b(1,1,IN_LEN)) + allocate(c(1,1,IN_LEN)) + allocate(x(1,1,IN_LEN)) + + !! simple test with only 1 coeff + a = 0.0_kindl + b = 1.0_kindl + c = 0.0_kindl + d = 5.0_kindl + call tri_invert(x, d, a, b, c) + if(any(x .ne. 5.0_kindl)) call mpp_error(FATAL, "test_tridiagonal: invalid results for 1 coefficient check") + !! check with stored data arrays + d = -5.0_kindl + call tri_invert(x, d) + if(any(x .ne. -5.0_kindl)) call mpp_error(FATAL, "test_tridiagonal: invalid results for 1 coefficient check") + + ! test with a,b,c + ! 0.5x(n-2) + x(n-1) + 0.5x(n) = 1 + ! + ! x(n) = k * [4, 1, 3, 2, 2, 3, 1, 4] + ! k * [8 , 1, 7, 2, 6, .. ] = k *(-n/2 + ((n%2)*arr_length/2)) + a = 0.5_kindl + b = 1.0_kindl + c = 0.5_kindl + d = 1.0_kindl + call tri_invert(x, d, a, b, c) + ! set up reference answers + k = 1.0_kindl/(IN_LEN+1.0_kindl) * 2.0_kindl + allocate(ref_array(1,1,IN_LEN)) + do i=1, IN_LEN/2 + end=IN_LEN-i+1 + if(mod(i, 2) .eq. 1) then + ref_array(1,1,i) = real(-(i/2) + (mod(i,2)* IN_LEN/2), kindl) + ref_array(1,1,end) = real(-(i/2) + (mod(i,2)* IN_LEN/2), kindl) + else + ref_array(1,1,i) = real(i/2, kindl) + ref_array(1,1,end) = real(i/2, kindl) + endif + enddo + ref_array = ref_array * k + ! check + do i=1, IN_LEN + if(ABS(x(1,1,i) - ref_array(1,1,i)) .gt. 0.1e-12_kindl) then + print *, i, x(1,1,i), ref_array(1,1,i) + call mpp_error(FATAL, "test_tridiagonal: failed reference check for tri_invert") + endif + enddo + !! check with stored data arrays + d = -1.0_kindl + ref_array = ref_array * -1.0_kindl + call tri_invert(x, d) + do i=1, IN_LEN + if(ABS(x(1,1,i) - ref_array(1,1,i)) .gt. 0.1e-12_kindl) then + print *, i, x(1,1,i), ref_array(1,1,i) + call mpp_error(FATAL, "test_tridiagonal: failed reference check for tri_invert with saved values") + endif + enddo + call close_tridiagonal() + + !! tests for module state across kinds + !! default keeps stored values separate depending on kind + !! store_both_kinds argument can be specified to store both r4 and r8 kinds + if(kindl .eq. r8_kind) then + allocate(a_r4(1,1,IN_LEN), b_r4(1,1,IN_LEN), c_r4(1,1,IN_LEN)) + allocate(d_r4(1,1,IN_LEN), x_r4(1,1,IN_LEN)) + a_r4 = 0.0_r4_kind; b_r4 = 1.0_r4_kind; c_r4 = 0.0_r4_kind + d_r4 = 5.0_r4_kind; x_r4 = 0.0_r4_kind + a = 0.0_kindl; b = 2.0_kindl; c = 0.0_kindl + d = 5.0_kindl + ! default, module variables distinct per kind + call tri_invert(x_r4, d_r4, a_r4, b_r4, c_r4) + ! conditionally errors here for calling with unallocated a/b/c for kind + if( do_error_check ) call tri_invert(x, d) + call tri_invert(x, d, a, b, c) + ! check both values are correct from prior state + call tri_invert(x_r4, d_r4) + call tri_invert(x, d) + if(any(x_r4 .ne. 5.0_r4_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r4 kind result") + if(any(x .ne. 2.5_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + call close_tridiagonal() + ! run with storing for both kinds + call tri_invert(x_r4, d_r4, a_r4, b_r4, c_r4, store_both_kinds=.true.) + call tri_invert(x_r4, d_r4) + call tri_invert(x, d) + if(any(x_r4 .ne. 5.0_r4_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r4 kind result") + if(any(x .ne. 5.0_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + else + allocate(a_r8(1,1,IN_LEN), b_r8(1,1,IN_LEN), c_r8(1,1,IN_LEN)) + allocate(d_r8(1,1,IN_LEN), x_r8(1,1,IN_LEN)) + a_r8 = 0.0_r8_kind; b_r8 = 1.0_r8_kind; c_r8 = 0.0_r8_kind + d_r8 = 5.0_r8_kind; x_r8 = 0.0_r8_kind + a = 0.0_kindl; b = 2.0_kindl; c = 0.0_kindl + d = 5.0_kindl + ! default, module variables distinct per kind + call tri_invert(x_r8, d_r8, a_r8, b_r8, c_r8) + ! conditionally errors here for calling with unallocated a/b/c for kind + if( do_error_check ) call tri_invert(x, d) + call tri_invert(x, d, a, b, c) + ! check both values are correct from prior state + call tri_invert(x_r8, d_r8) + call tri_invert(x, d) + if(any(x_r8 .ne. 5.0_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + if(any(x .ne. 2.5_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + call close_tridiagonal() + ! run with storing for both kinds + call tri_invert(x_r8, d_r8, a_r8, b_r8, c_r8, store_both_kinds=.true.) + call tri_invert(x_r8, d_r8) + call tri_invert(x, d) + if(any(x_r8 .ne. 5.0_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + if(any(x .ne. 5.0_r8_kind)) call mpp_error(FATAL, "test_tridiagonal: invalid r8 kind result") + endif + + call close_tridiagonal() + + call mpp_exit + +end program \ No newline at end of file diff --git a/test_fms/tridiagonal/test_tridiagonal.sh b/test_fms/tridiagonal/test_tridiagonal.sh new file mode 100755 index 0000000000..4be1fa80b1 --- /dev/null +++ b/test_fms/tridiagonal/test_tridiagonal.sh @@ -0,0 +1,51 @@ +#!/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/time_manager directory. + +# Ryan Mulhall 9/2023 + +# Set common test settings. +. ../test-lib.sh + +rm -f input.nml && touch input.nml + +test_expect_success "test tridiagonal functionality 32 bit reals" ' + mpirun -n 1 ./test_tridiagonal_r4 +' +test_expect_success "test tridiagonal functionality 64 bit reals" ' + mpirun -n 1 ./test_tridiagonal_r8 +' +# tries to call without a,b,c args provided or previously set +cat <<_EOF > input.nml +&test_tridiagonal_nml +do_error_check = .true. +/ +_EOF +test_expect_failure "error out if passed in incorrect real size (r4_kind)" ' + mpirun -n 1 ./test_tridiagonal_r4 +' +test_expect_failure "error out if passed in incorrect real size (r8_kind)" ' + mpirun -n 1 ./test_tridiagonal_r8 +' + +test_done diff --git a/time_interp/include/time_interp_external.inc b/time_interp/include/time_interp_external.inc deleted file mode 100644 index 7c446f4c52..0000000000 --- a/time_interp/include/time_interp_external.inc +++ /dev/null @@ -1,1424 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS is free software: you can redistribute it and/or modify it under -!* the terms of the GNU Lesser General Public License as published by -!* the Free Software Foundation, either version 3 of the License, or (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -!* for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with FMS. If not, see . -!*********************************************************************** -!> @defgroup time_interp_external_mod time_interp_external_mod -!> @ingroup time_interp -!> @brief Perform I/O and time interpolation of external fields (contained in a file). -!> @author M.J. Harrison -!! -!! Perform I/O and time interpolation for external fields. -!! Uses udunits library to calculate calendar dates and -!! convert units. Allows for reading data decomposed across -!! model horizontal grid using optional domain2d argument -!! -!! data are defined over data domain for domain2d data -!! (halo values are NOT updated by this module) - -!> @addtogroup time_interp_external_mod -!> @{ -module time_interp_external_mod -#ifdef use_deprecated_io -#include -! -!M.J. Harrison -! -!Harper Simmons -! -! -! - -! -! -! -! -! -! -! size of record dimension for internal buffer. This is useful for tuning i/o performance -! particularly for large datasets (e.g. daily flux fields) -! -! - - use fms_mod, only : write_version_number - use mpp_mod, only : mpp_error,FATAL,WARNING,mpp_pe, stdout, stdlog, NOTE - use mpp_mod, only : input_nml_file - use mpp_io_mod, only : mpp_open, mpp_get_atts, mpp_get_info, MPP_NETCDF, MPP_MULTI, MPP_SINGLE,& - mpp_get_times, MPP_RDONLY, MPP_ASCII, default_axis,axistype,fieldtype,atttype, & - mpp_get_axes, mpp_get_fields, mpp_read, default_field, mpp_close, & - mpp_get_tavg_info, validtype, mpp_is_valid, mpp_get_file_name - use time_manager_mod, only : time_type, get_date, set_date, operator ( >= ) , operator ( + ) , days_in_month, & - operator( - ), operator ( / ) , days_in_year, increment_time, & - set_time, get_time, operator( > ), get_calendar_type, NO_CALENDAR - use get_cal_time_mod, only : get_cal_time - use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, mpp_get_data_domain, & - mpp_get_global_domain, NULL_DOMAIN2D - use time_interp_mod, only : time_interp, time_interp_init - use axis_utils_mod, only : get_axis_cart, get_axis_modulo, get_axis_modulo_times - use fms_mod, only : lowercase, open_namelist_file, check_nml_error, close_file - use platform_mod, only: r8_kind - use horiz_interp_mod, only : horiz_interp, horiz_interp_type - - implicit none - private - -! Include variable "version" to be written to log file. -#include - - integer, parameter, public :: NO_REGION=0, INSIDE_REGION=1, OUTSIDE_REGION=2 - integer, parameter, private :: modulo_year= 0001 - integer, parameter, private :: LINEAR_TIME_INTERP = 1 ! not used currently - integer, parameter, public :: SUCCESS = 0, ERR_FIELD_NOT_FOUND = 1 - integer, private :: max_fields = 100, max_files= 40 - integer, private :: num_fields = 0, num_files=0 - ! denotes time intervals in file (interpreted from metadata) - integer, private :: num_io_buffers = 2 ! set -1 to read all records from disk into memory - logical, private :: module_initialized = .false. - logical, private :: debug_this_module = .false. - - public init_external_field, time_interp_external, time_interp_external_init, & - time_interp_external_exit, get_external_field_size, get_time_axis, get_external_field_missing - public set_override_region, reset_src_data_region, get_external_field_axes - - private find_buf_index,& - set_time_modulo - - !> @} - - !> @ingroup time_interp_external_mod - type, private :: ext_fieldtype - integer :: unit ! keep unit open when not reading all records - character(len=128) :: name, units - integer :: siz(4), ndim - type(domain2d) :: domain - type(axistype) :: axes(4) - type(time_type), dimension(:), pointer :: time =>NULL() ! midpoint of time interval - type(time_type), dimension(:), pointer :: start_time =>NULL(), end_time =>NULL() - type(fieldtype) :: field ! mpp_io type - type(time_type), dimension(:), pointer :: period =>NULL() - logical :: modulo_time ! denote climatological time axis - real, dimension(:,:,:,:), pointer :: data =>NULL() ! defined over data domain or global domain - logical, dimension(:,:,:,:), pointer :: mask =>NULL() ! defined over data domain or global domain - integer, dimension(:), pointer :: ibuf =>NULL() ! record numbers associated with buffers - real, dimension(:,:,:,:), pointer :: src_data =>NULL() ! input data buffer - type(validtype) :: valid ! data validator - integer :: nbuf - logical :: domain_present - real(DOUBLE_KIND) :: slope, intercept - integer :: isc,iec,jsc,jec - type(time_type) :: modulo_time_beg, modulo_time_end - logical :: have_modulo_times, correct_leap_year_inconsistency - integer :: region_type - integer :: is_region, ie_region, js_region, je_region - integer :: is_src, ie_src, js_src, je_src - integer :: tdim - integer :: numwindows - logical, dimension(:,:), pointer :: need_compute=>NULL() - real :: missing ! missing value - end type ext_fieldtype - - !> @ingroup time_interp_external_mod - type, private :: filetype - character(len=128) :: filename = '' - integer :: unit = -1 - end type filetype - - !> Provide data from external file interpolated to current model time. - !! Data may be local to current processor or global, depending on - !! "init_external_field" flags. Uses @ref mpp_io_mod for I/O. - !! - !! @param index index of external field from previous call to init_external_field - !! @param time target time for data - !! @param [inout] data global or local data array - !! @param interp time_interp_external defined interpolation method (optional). Currently - !! this module only supports LINEAR_TIME_INTERP. - !! @param verbose verbose flag for debugging (optional). - !! - !> @ingroup time_interp_external_mod - interface time_interp_external - module procedure time_interp_external_0d - module procedure time_interp_external_2d - module procedure time_interp_external_3d - end interface - - !> @addtogroup time_interp_external_mod - !> @{ - - integer :: outunit - - type(ext_fieldtype), save, private, pointer :: field(:) => NULL() - type(filetype), save, private, pointer :: opened_files(:) => NULL() -!Balaji: really should use field%missing - integer, private, parameter :: dk = DOUBLE_KIND - real(DOUBLE_KIND), private, parameter :: time_interp_missing=-1e99_dk - contains - -! -! -! -! Initialize the time_interp_external module -! -! - subroutine time_interp_external_init() - - integer :: ioun, io_status, logunit, ierr - - namelist /time_interp_external_nml/ num_io_buffers, debug_this_module, & - max_fields, max_files - - ! open and read namelist - - if(module_initialized) return - - logunit = stdlog() - outunit = stdout() - call write_version_number("TIME_INTERP_EXTERNAL_MOD", version) - -#ifdef INTERNAL_FILE_NML - read (input_nml_file, time_interp_external_nml, iostat=io_status) - ierr = check_nml_error(io_status, 'time_interp_external_nml') -#else - ioun = open_namelist_file () - ierr=1; do while (ierr /= 0) - read (ioun, nml=time_interp_external_nml, iostat=io_status, end=10) - ierr = check_nml_error(io_status, 'time_interp_external_nml') - enddo -10 call close_file (ioun) -#endif - - write(logunit,time_interp_external_nml) - call realloc_fields(max_fields) - call realloc_files(max_files) - - module_initialized = .true. - - call time_interp_init() - - return - - end subroutine time_interp_external_init -! NAME="time_interp_external_init" - - -! -! -! -! initialize an external field. Buffer "num_io_buffers" (default=2) in memory to reduce memory allocations. -! distributed reads are supported using the optional "domain" flag. -! Units conversion via the optional "desired_units" flag using udunits_mod. -! -! Return integer id of field for future calls to time_interp_external. -! -! -! -! -! filename -! -! -! fieldname (in file) -! -! -! mpp_io flag for format of file (optional). Currently only "MPP_NETCDF" supported -! -! -! mpp_io flag for threading (optional). "MPP_SINGLE" means root pe reads global field and distributes to other PEs -! "MPP_MULTI" means all PEs read data -! -! -! domain flag (optional) -! -! -! Target units for data (optional), e.g. convert from deg_K to deg_C. -! Failure to convert using udunits will result in failure of this module. -! -! -! verbose flag for debugging (optional). -! -! -! MPP_IO axistype array for grid centers ordered X-Y-Z-T (optional). -! -! -! array of axis lengths ordered X-Y-Z-T (optional). -! - - - !> Initialize an external field. Buffer "num_io_buffers" (default=2) in memory to reduce memory allocations. - !! distributed reads are supported using the optional "domain" flag. - !! Units conversion via the optional "desired_units" flag using udunits_mod. - !! - !> @return integer id of field for future calls to time_interp_external. - !> @param file filename - !> @param fieldname fieldname (in file) - !> @param format mpp_io flag for format of file(optional). Currently only "MPP_NETCDF" supported - !> @param threading mpp_io flag for threading (optional). "MPP_SINGLE" means root pe reads - !! global field and distributes to other PEs. "MPP_MULTI" means all PEs read data - !> @param domain domain flag (optional) - !> @param desired_units Target units for data (optional), e.g. convert from deg_K to deg_C. - !! Failure to convert using udunits will result in failure of this module. - !> @param verbose verbose flag for debugging (optional). - !> @param [out] axis_names List of axis names (optional). - !> @param [inout] axis_sizes array of axis lengths ordered X-Y-Z-T (optional). - function init_external_field(file,fieldname,format,threading,domain,desired_units,& - verbose,axis_centers,axis_sizes,override,correct_leap_year_inconsistency,& - permit_calendar_conversion,use_comp_domain,ierr, nwindows, ignore_axis_atts ) - - character(len=*), intent(in) :: file,fieldname - integer, intent(in), optional :: format, threading - logical, intent(in), optional :: verbose - character(len=*), intent(in), optional :: desired_units - type(domain2d), intent(in), optional :: domain - type(axistype), intent(inout), optional :: axis_centers(4) - integer, intent(inout), optional :: axis_sizes(4) - logical, intent(in), optional :: override, correct_leap_year_inconsistency,& - permit_calendar_conversion,use_comp_domain - integer, intent(out), optional :: ierr - integer, intent(in), optional :: nwindows - logical, optional :: ignore_axis_atts - real :: missing - - integer :: init_external_field - - type(fieldtype), dimension(:), allocatable :: flds - type(axistype), dimension(:), allocatable :: axes, fld_axes - type(axistype) :: time_axis - type(atttype), allocatable, dimension(:) :: global_atts - - real(DOUBLE_KIND) :: slope, intercept - integer :: form, thread, fset, unit,ndim,nvar,natt,ntime,i,j - integer :: iscomp,iecomp,jscomp,jecomp,isglobal,ieglobal,jsglobal,jeglobal - integer :: isdata,iedata,jsdata,jedata, dxsize, dysize,dxsize_max,dysize_max - logical :: verb, transpose_xy,use_comp_domain1 - real, dimension(:), allocatable :: tstamp, tstart, tend, tavg - character(len=1) :: cart - character(len=1), dimension(4) :: cart_dir - character(len=128) :: units, fld_units - character(len=128) :: name, msg, calendar_type, timebeg, timeend - integer :: siz(4), siz_in(4), gxsize, gysize,gxsize_max, gysize_max - type(time_type) :: tdiff - integer :: yr, mon, day, hr, minu, sec - integer :: len, nfile, nfields_orig, nbuf, nx,ny - integer :: numwindows - logical :: ignore_axatts - - - if (.not. module_initialized) call mpp_error(FATAL,'Must call time_interp_external_init first') - if(present(ierr)) ierr = SUCCESS - ignore_axatts=.false. - cart_dir(1)='X';cart_dir(2)='Y';cart_dir(3)='Z';cart_dir(4)='T' - if(present(ignore_axis_atts)) ignore_axatts = ignore_axis_atts - use_comp_domain1 = .false. - if(PRESENT(use_comp_domain)) use_comp_domain1 = use_comp_domain - form=MPP_NETCDF - if (PRESENT(format)) form = format - thread = MPP_MULTI - if (PRESENT(threading)) thread = threading - fset = MPP_SINGLE - verb=.false. - if (PRESENT(verbose)) verb=verbose - if (debug_this_module) verb = .true. - numwindows = 1 - if(present(nwindows)) numwindows = nwindows - - units = 'same' - if (PRESENT(desired_units)) then - units = desired_units - call mpp_error(FATAL,'==> Unit conversion via time_interp_external & - &has been temporarily deprecated. Previous versions of& - &this module used udunits_mod to perform unit conversion.& - & Udunits_mod is in the process of being replaced since & - &there were portability issues associated with this code.& - & Please remove the desired_units argument from calls to & - &this routine.') - endif - nfile = 0 - do i=1,num_files - if(trim(opened_files(i)%filename) == trim(file)) then - nfile = i - exit ! file is already opened - endif - enddo - if(nfile == 0) then - call mpp_open(unit,trim(file),MPP_RDONLY,form,threading=thread,& - fileset=fset) - num_files = num_files + 1 - if(num_files > max_files) then ! not enough space in the file table, reallocate it - !--- z1l: For the case of multiple thread, realoc_files will cause memory leak. - !--- If multiple threads are working on file A. One of the thread finished first and - !--- begin to work on file B, the realloc_files will cause problem for - !--- other threads are working on the file A. - ! call realloc_files(2*size(opened_files)) - call mpp_error(FATAL, "time_interp_external: num_files is greater than max_files, "// & - "increase time_interp_external_nml max_files") - endif - opened_files(num_files)%filename = trim(file) - opened_files(num_files)%unit = unit - else - unit = opened_files(nfile)%unit - endif - - call mpp_get_info(unit,ndim,nvar,natt,ntime) - - if (ntime < 1) then - write(msg,'(a15,a,a58)') 'external field ',trim(fieldname),& - ' does not have an associated record dimension (REQUIRED) ' - call mpp_error(FATAL,trim(msg)) - endif - allocate(global_atts(natt)) - call mpp_get_atts(unit, global_atts) - allocate(axes(ndim)) - call mpp_get_axes(unit, axes, time_axis) - allocate(flds(nvar)) - call mpp_get_fields(unit,flds) - allocate(tstamp(ntime),tstart(ntime),tend(ntime),tavg(ntime)) - call mpp_get_times(unit,tstamp) - transpose_xy = .false. - isdata=1; iedata=1; jsdata=1; jedata=1 - gxsize=1; gysize=1 - siz_in = 1 - - if (PRESENT(domain)) then - call mpp_get_compute_domain(domain,iscomp,iecomp,jscomp,jecomp) - nx = iecomp-iscomp+1; ny = jecomp-jscomp+1 - call mpp_get_data_domain(domain,isdata,iedata,jsdata,jedata,dxsize,dxsize_max,dysize,dysize_max) - call mpp_get_global_domain(domain,isglobal,ieglobal,jsglobal,jeglobal,gxsize,gxsize_max,gysize,gysize_max) - elseif(use_comp_domain1) then - call mpp_error(FATAL,"init_external_field:"//& - " use_comp_domain=true but domain is not present") - endif - - init_external_field = -1 - nfields_orig = num_fields - - do i=1,nvar - call mpp_get_atts(flds(i),name=name,units=fld_units,ndim=ndim,siz=siz_in) - call mpp_get_tavg_info(unit,flds(i),flds,tstamp,tstart,tend,tavg) - call mpp_get_atts(flds(i),missing=missing) - ! why does it convert case of the field name? - if (trim(lowercase(name)) /= trim(lowercase(fieldname))) cycle - - if (verb) write(outunit,*) 'found field ',trim(fieldname), ' in file !!' - num_fields = num_fields + 1 - if(num_fields > max_fields) then - !--- z1l: For the case of multiple thread, realoc_fields will cause memory leak. - !--- If multiple threads are working on field A. One of the thread finished first and - !--- begin to work on field B, the realloc_files will cause problem for - !--- other threads are working on the field A. - !call realloc_fields(size(field)*2) - call mpp_error(FATAL, "time_interp_external: num_fields is greater than max_fields, "// & - "increase time_interp_external_nml max_fields") - endif - - init_external_field = num_fields - field(num_fields)%unit = unit - field(num_fields)%name = trim(name) - field(num_fields)%units = trim(fld_units) - field(num_fields)%field = flds(i) - field(num_fields)%isc = 1 - field(num_fields)%iec = 1 - field(num_fields)%jsc = 1 - field(num_fields)%jec = 1 - field(num_fields)%region_type = NO_REGION - field(num_fields)%is_region = 0 - field(num_fields)%ie_region = -1 - field(num_fields)%js_region = 0 - field(num_fields)%je_region = -1 - if (PRESENT(domain)) then - field(num_fields)%domain_present = .true. - field(num_fields)%domain = domain - field(num_fields)%isc=iscomp;field(num_fields)%iec = iecomp - field(num_fields)%jsc=jscomp;field(num_fields)%jec = jecomp - else - field(num_fields)%domain_present = .false. - endif - - call mpp_get_atts(flds(i),valid=field(num_fields)%valid ) - allocate(fld_axes(ndim)) - call mpp_get_atts(flds(i),axes=fld_axes) - if (ndim > 4) call mpp_error(FATAL, & - 'invalid array rank <=4d fields supported') - field(num_fields)%siz = 1 - field(num_fields)%ndim = ndim - field(num_fields)%tdim = 4 - field(num_fields)%missing = missing - do j=1,field(num_fields)%ndim - cart = 'N' - call get_axis_cart(fld_axes(j), cart) - call mpp_get_atts(fld_axes(j),len=len) - if (cart == 'N' .and. .not. ignore_axatts) then - write(msg,'(a,"/",a)') trim(file),trim(fieldname) - call mpp_error(FATAL,'file/field '//trim(msg)// & - ' couldnt recognize axis atts in time_interp_external') - else if (cart == 'N' .and. ignore_axatts) then - cart = cart_dir(j) - endif - select case (cart) - case ('X') - if (j.eq.2) transpose_xy = .true. - if (.not.PRESENT(domain) .and. .not.PRESENT(override)) then - isdata=1;iedata=len - iscomp=1;iecomp=len - gxsize = len - dxsize = len - field(num_fields)%isc=iscomp;field(num_fields)%iec=iecomp - elseif (PRESENT(override)) then - gxsize = len - if (PRESENT(axis_sizes)) axis_sizes(1) = len - endif - field(num_fields)%axes(1) = fld_axes(j) - if(use_comp_domain1) then - field(num_fields)%siz(1) = nx - else - field(num_fields)%siz(1) = dxsize - endif - if (len /= gxsize) then - write(msg,'(a,"/",a)') trim(file),trim(fieldname) - call mpp_error(FATAL,'time_interp_ext, file/field '//trim(msg)//' x dim doesnt match model') - endif - case ('Y') - field(num_fields)%axes(2) = fld_axes(j) - if (.not.PRESENT(domain) .and. .not.PRESENT(override)) then - jsdata=1;jedata=len - jscomp=1;jecomp=len - gysize = len - dysize = len - field(num_fields)%jsc=jscomp;field(num_fields)%jec=jecomp - elseif (PRESENT(override)) then - gysize = len - if (PRESENT(axis_sizes)) axis_sizes(2) = len - endif - if(use_comp_domain1) then - field(num_fields)%siz(2) = ny - else - field(num_fields)%siz(2) = dysize - endif - if (len /= gysize) then - write(msg,'(a,"/",a)') trim(file),trim(fieldname) - call mpp_error(FATAL,'time_interp_ext, file/field '//trim(msg)//' y dim doesnt match model') - endif - case ('Z') - field(num_fields)%axes(3) = fld_axes(j) - field(num_fields)%siz(3) = siz_in(3) - case ('T') - field(num_fields)%axes(4) = fld_axes(j) - field(num_fields)%siz(4) = ntime - field(num_fields)%tdim = j - end select - enddo - siz = field(num_fields)%siz - - if (PRESENT(axis_centers)) then - axis_centers = field(num_fields)%axes - endif - - if (PRESENT(axis_sizes) .and. .not.PRESENT(override)) then - axis_sizes = field(num_fields)%siz - endif - - deallocate(fld_axes) - if (verb) write(outunit,'(a,4i6)') 'field x,y,z,t local size= ',siz - if (verb) write(outunit,*) 'field contains data in units = ',trim(field(num_fields)%units) - if (transpose_xy) call mpp_error(FATAL,'axis ordering not supported') - if (num_io_buffers .le. 1) call mpp_error(FATAL,'time_interp_ext:num_io_buffers should be at least 2') - nbuf = min(num_io_buffers,siz(4)) - - field(num_fields)%numwindows = numwindows - allocate(field(num_fields)%need_compute(nbuf, numwindows)) - field(num_fields)%need_compute = .true. - - allocate(field(num_fields)%data(isdata:iedata,jsdata:jedata,siz(3),nbuf),& - field(num_fields)%mask(isdata:iedata,jsdata:jedata,siz(3),nbuf) ) - field(num_fields)%mask = .false. - field(num_fields)%data = 0.0 - slope=1.0;intercept=0.0 -! if (units /= 'same') call convert_units(trim(field(num_fields)%units),trim(units),slope,intercept) -! if (verb.and.units /= 'same') then -! write(outunit,*) 'attempting to convert data to units = ',trim(units) -! write(outunit,'(a,f8.3,a,f8.3)') 'factor = ',slope,' offset= ',intercept -! endif - field(num_fields)%slope = slope - field(num_fields)%intercept = intercept - allocate(field(num_fields)%ibuf(nbuf)) - field(num_fields)%ibuf = -1 - field(num_fields)%nbuf = 0 ! initialize buffer number so that first reading fills data(:,:,:,1) - if(PRESENT(override)) then - field(num_fields)%is_src = 1 - field(num_fields)%ie_src = gxsize - field(num_fields)%js_src = 1 - field(num_fields)%je_src = gysize - allocate(field(num_fields)%src_data(gxsize,gysize,siz(3),nbuf)) - else - field(num_fields)%is_src = isdata - field(num_fields)%ie_src = iedata - field(num_fields)%js_src = jsdata - field(num_fields)%je_src = jedata - allocate(field(num_fields)%src_data(isdata:iedata,jsdata:jedata,siz(3),nbuf)) - endif - - allocate(field(num_fields)%time(ntime)) - allocate(field(num_fields)%period(ntime)) - allocate(field(num_fields)%start_time(ntime)) - allocate(field(num_fields)%end_time(ntime)) - - call mpp_get_atts(time_axis,units=units,calendar=calendar_type) - do j=1,ntime - field(num_fields)%time(j) = get_cal_time(tstamp(j),trim(units),trim(calendar_type), & - & permit_calendar_conversion) - field(num_fields)%start_time(j) = get_cal_time(tstart(j),trim(units),trim(calendar_type), & - & permit_calendar_conversion) - field(num_fields)%end_time(j) = get_cal_time( tend(j),trim(units),trim(calendar_type), & - & permit_calendar_conversion) - enddo - - if (field(num_fields)%modulo_time) then - call set_time_modulo(field(num_fields)%Time) - call set_time_modulo(field(num_fields)%start_time) - call set_time_modulo(field(num_fields)%end_time) - endif - - if(present(correct_leap_year_inconsistency)) then - field(num_fields)%correct_leap_year_inconsistency = correct_leap_year_inconsistency - else - field(num_fields)%correct_leap_year_inconsistency = .false. - endif - - if(get_axis_modulo_times(time_axis, timebeg, timeend)) then - if(get_calendar_type() == NO_CALENDAR) then - field(num_fields)%modulo_time_beg = set_time(timebeg) - field(num_fields)%modulo_time_end = set_time(timeend) - else - field(num_fields)%modulo_time_beg = set_date(timebeg) - field(num_fields)%modulo_time_end = set_date(timeend) - endif - field(num_fields)%have_modulo_times = .true. - else - field(num_fields)%have_modulo_times = .false. - endif - if(ntime == 1) then - call mpp_error(NOTE, 'time_interp_external_mod: file '//trim(file)//' has only one time level') - else - do j= 1, ntime - field(num_fields)%period(j) = field(num_fields)%end_time(j)-field(num_fields)%start_time(j) - if (field(num_fields)%period(j) > set_time(0,0)) then - call get_time(field(num_fields)%period(j), sec, day) - sec = sec/2+mod(day,2)*43200 - day = day/2 - field(num_fields)%time(j) = field(num_fields)%start_time(j)+& - set_time(sec,day) - else - if (j > 1 .and. j < ntime) then - tdiff = field(num_fields)%time(j+1) - field(num_fields)%time(j-1) - call get_time(tdiff, sec, day) - sec = sec/2+mod(day,2)*43200 - day = day/2 - field(num_fields)%period(j) = set_time(sec,day) - sec = sec/2+mod(day,2)*43200 - day = day/2 - field(num_fields)%start_time(j) = field(num_fields)%time(j) - set_time(sec,day) - field(num_fields)%end_time(j) = field(num_fields)%time(j) + set_time(sec,day) - elseif ( j == 1) then - tdiff = field(num_fields)%time(2) - field(num_fields)%time(1) - call get_time(tdiff, sec, day) - field(num_fields)%period(j) = set_time(sec,day) - sec = sec/2+mod(day,2)*43200 - day = day/2 - field(num_fields)%start_time(j) = field(num_fields)%time(j) - set_time(sec,day) - field(num_fields)%end_time(j) = field(num_fields)%time(j) + set_time(sec,day) - else - tdiff = field(num_fields)%time(ntime) - field(num_fields)%time(ntime-1) - call get_time(tdiff, sec, day) - field(num_fields)%period(j) = set_time(sec,day) - sec = sec/2+mod(day,2)*43200 - day = day/2 - field(num_fields)%start_time(j) = field(num_fields)%time(j) - set_time(sec,day) - field(num_fields)%end_time(j) = field(num_fields)%time(j) + set_time(sec,day) - endif - endif - enddo - endif - - do j=1,ntime-1 - if (field(num_fields)%time(j) >= field(num_fields)%time(j+1)) then - write(msg,'(A,i20)') "times not monotonically increasing. Filename: " & - //TRIM(file)//" field: "//TRIM(fieldname)//" timeslice: ", j - call mpp_error(FATAL, TRIM(msg)) - endif - enddo - - field(num_fields)%modulo_time = get_axis_modulo(time_axis) - - if (verb) then - if (field(num_fields)%modulo_time) write(outunit,*) 'data are being treated as modulo in time' - do j= 1, ntime - write(outunit,*) 'time index, ', j - call get_date(field(num_fields)%start_time(j),yr,mon,day,hr,minu,sec) - write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') & - 'start time: yyyy/mm/dd hh:mm:ss= ',yr,'/',mon,'/',day,hr,':',minu,':',sec - call get_date(field(num_fields)%time(j),yr,mon,day,hr,minu,sec) - write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') & - 'mid time: yyyy/mm/dd hh:mm:ss= ',yr,'/',mon,'/',day,hr,':',minu,':',sec - call get_date(field(num_fields)%end_time(j),yr,mon,day,hr,minu,sec) - write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') & - 'end time: yyyy/mm/dd hh:mm:ss= ',yr,'/',mon,'/',day,hr,':',minu,':',sec - enddo - end if - - enddo - - if (num_fields == nfields_orig) then - if (present(ierr)) then - ierr = ERR_FIELD_NOT_FOUND - else - call mpp_error(FATAL,'external field "'//trim(fieldname)//'" not found in file "'//trim(file)//'"') - endif - endif - - deallocate(global_atts) - deallocate(axes) - deallocate(flds) - deallocate(tstamp, tstart, tend, tavg) - - return - - end function init_external_field - -! NAME="init_external_field" - - - !> @brief 2D time interpolation for @ref time_interp_external - subroutine time_interp_external_2d(index, time, data_in, interp, verbose,horz_interp, mask_out, & - is_in, ie_in, js_in, je_in, window_id) - - integer, intent(in) :: index - type(time_type), intent(in) :: time - real, dimension(:,:), intent(inout) :: data_in - integer, intent(in), optional :: interp - logical, intent(in), optional :: verbose - type(horiz_interp_type),intent(in), optional :: horz_interp - logical, dimension(:,:), intent(out), optional :: mask_out ! set to true where output data is valid - integer, intent(in), optional :: is_in, ie_in, js_in, je_in - integer, intent(in), optional :: window_id - - real , dimension(size(data_in,1), size(data_in,2), 1) :: data_out - logical, dimension(size(data_in,1), size(data_in,2), 1) :: mask3d - - data_out(:,:,1) = data_in(:,:) ! fill initial values for the portions of array that are not touched by 3d routine - call time_interp_external_3d(index, time, data_out, interp, verbose, horz_interp, mask3d, & - is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - data_in(:,:) = data_out(:,:,1) - if (PRESENT(mask_out)) mask_out(:,:) = mask3d(:,:,1) - - return - end subroutine time_interp_external_2d - -! -! -! -! Provide data from external file interpolated to current model time. -! Data may be local to current processor or global, depending on -! "init_external_field" flags. -! -! -! -! index of external field from previous call to init_external_field -! -! -! target time for data -! -! -! global or local data array -! -! -! time_interp_external defined interpolation method (optional). Currently this module only supports -! LINEAR_TIME_INTERP. -! -! -! verbose flag for debugging (optional). -! - - !> @brief 3D time interpolation for @ref time_interp_external - subroutine time_interp_external_3d(index, time, data, interp,verbose,horz_interp, mask_out, is_in, ie_in, & - & js_in, je_in, window_id) - - integer, intent(in) :: index - type(time_type), intent(in) :: time - real, dimension(:,:,:), intent(inout) :: data - integer, intent(in), optional :: interp - logical, intent(in), optional :: verbose - type(horiz_interp_type), intent(in), optional :: horz_interp - logical, dimension(:,:,:), intent(out), optional :: mask_out ! set to true where output data is valid - integer, intent(in), optional :: is_in, ie_in, js_in, je_in - integer, intent(in), optional :: window_id - - integer :: nx, ny, nz, interp_method, t1, t2 - integer :: i1, i2, isc, iec, jsc, jec, mod_time - integer :: yy, mm, dd, hh, min, ss - character(len=256) :: err_msg, filename - - integer :: isw, iew, jsw, jew, nxw, nyw - ! these are boundaries of the updated portion of the "data" argument - ! they are calculated using sizes of the "data" and isc,iec,jsc,jsc - ! fileds from respective input field, to center the updated portion - ! in the output array - - real :: w1,w2 - logical :: verb - character(len=16) :: message1, message2 - - nx = size(data,1) - ny = size(data,2) - nz = size(data,3) - - interp_method = LINEAR_TIME_INTERP - if (PRESENT(interp)) interp_method = interp - verb=.false. - if (PRESENT(verbose)) verb=verbose - if (debug_this_module) verb = .true. - - if (index < 1.or.index > num_fields) & - call mpp_error(FATAL, & - & 'invalid index in call to time_interp_ext -- field was not initialized or failed to initialize') - - isc=field(index)%isc;iec=field(index)%iec - jsc=field(index)%jsc;jec=field(index)%jec - - if( field(index)%numwindows == 1 ) then - nxw = iec-isc+1 - nyw = jec-jsc+1 - else - if( .not. present(is_in) .or. .not. present(ie_in) .or. .not. present(js_in) .or. .not. present(je_in) ) then - call mpp_error(FATAL, 'time_interp_external: is_in, ie_in, js_in and je_in must be present ' // & - 'when numwindows > 1, field='//trim(field(index)%name)) - endif - nxw = ie_in - is_in + 1 - nyw = je_in - js_in + 1 - isc = isc + is_in - 1 - iec = isc + ie_in - is_in - jsc = jsc + js_in - 1 - jec = jsc + je_in - js_in - endif - - isw = (nx-nxw)/2+1; iew = isw+nxw-1 - jsw = (ny-nyw)/2+1; jew = jsw+nyw-1 - - if (nx < nxw .or. ny < nyw .or. nz < field(index)%siz(3)) then - write(message1,'(i6,2i5)') nx,ny,nz - call mpp_error(FATAL,'field '//trim(field(index)%name)//' Array size mismatch in time_interp_external.'// & - ' Array "data" is too small. shape(data)='//message1) - endif - if(PRESENT(mask_out)) then - if (size(mask_out,1) /= nx .or. size(mask_out,2) /= ny .or. size(mask_out,3) /= nz) then - write(message1,'(i6,2i5)') nx,ny,nz - write(message2,'(i6,2i5)') size(mask_out,1),size(mask_out,2),size(mask_out,3) - call mpp_error(FATAL,'field '//trim(field(index)%name)//' array size mismatch in time_interp_external.'// & - ' Shape of array "mask_out" does not match that of array "data".'// & - ' shape(data)='//message1//' shape(mask_out)='//message2) - endif - endif - - if (field(index)%siz(4) == 1) then - ! only one record in the file => time-independent field - call load_record(field(index),1,horz_interp, is_in, ie_in ,js_in, je_in,window_id) - i1 = find_buf_index(1,field(index)%ibuf) - if( field(index)%region_type == NO_REGION ) then - where(field(index)%mask(isc:iec,jsc:jec,:,i1)) - data(isw:iew,jsw:jew,:) = field(index)%data(isc:iec,jsc:jec,:,i1) - elsewhere -! data(isw:iew,jsw:jew,:) = time_interp_missing !field(index)%missing? Balaji - data(isw:iew,jsw:jew,:) = field(index)%missing - end where - else - where(field(index)%mask(isc:iec,jsc:jec,:,i1)) - data(isw:iew,jsw:jew,:) = field(index)%data(isc:iec,jsc:jec,:,i1) - end where - endif - if(PRESENT(mask_out)) & - mask_out(isw:iew,jsw:jew,:) = field(index)%mask(isc:iec,jsc:jec,:,i1) - else - if(field(index)%have_modulo_times) then - call time_interp(time,field(index)%modulo_time_beg, field(index)%modulo_time_end, field(index)%time(:), & - w2, t1, t2, field(index)%correct_leap_year_inconsistency, err_msg=err_msg) - if(err_msg .NE. '') then - filename = mpp_get_file_name(field(index)%unit) - call mpp_error(FATAL,"time_interp_external 1: "//trim(err_msg)//& - ",file="//trim(filename)//",field="//trim(field(index)%name) ) - endif - else - if(field(index)%modulo_time) then - mod_time=1 - else - mod_time=0 - endif - call time_interp(time,field(index)%time(:),w2,t1,t2,modtime=mod_time, err_msg=err_msg) - if(err_msg .NE. '') then - filename = mpp_get_file_name(field(index)%unit) - call mpp_error(FATAL,"time_interp_external 2: "//trim(err_msg)//& - ",file="//trim(filename)//",field="//trim(field(index)%name) ) - endif - endif - w1 = 1.0-w2 - if (verb) then - call get_date(time,yy,mm,dd,hh,min,ss) - write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') & - 'target time yyyy/mm/dd hh:mm:ss= ',yy,'/',mm,'/',dd,hh,':',min,':',ss - write(outunit,*) 't1, t2, w1, w2= ', t1, t2, w1, w2 - endif - - call load_record(field(index),t1,horz_interp, is_in, ie_in ,js_in, je_in, window_id) - call load_record(field(index),t2,horz_interp, is_in, ie_in ,js_in, je_in, window_id) - i1 = find_buf_index(t1,field(index)%ibuf) - i2 = find_buf_index(t2,field(index)%ibuf) - if(i1<0.or.i2<0) & - call mpp_error(FATAL,'time_interp_external : records were not loaded correctly in memory') - - if (verb) then - write(outunit,*) 'ibuf= ',field(index)%ibuf - write(outunit,*) 'i1,i2= ',i1, i2 - endif - - if( field(index)%region_type == NO_REGION ) then - where(field(index)%mask(isc:iec,jsc:jec,:,i1).and.field(index)%mask(isc:iec,jsc:jec,:,i2)) - data(isw:iew,jsw:jew,:) = field(index)%data(isc:iec,jsc:jec,:,i1)*w1 + & - field(index)%data(isc:iec,jsc:jec,:,i2)*w2 - elsewhere -! data(isw:iew,jsw:jew,:) = time_interp_missing !field(index)%missing? Balaji - data(isw:iew,jsw:jew,:) = field(index)%missing - end where - else - where(field(index)%mask(isc:iec,jsc:jec,:,i1).and.field(index)%mask(isc:iec,jsc:jec,:,i2)) - data(isw:iew,jsw:jew,:) = field(index)%data(isc:iec,jsc:jec,:,i1)*w1 + & - field(index)%data(isc:iec,jsc:jec,:,i2)*w2 - end where - endif - if(PRESENT(mask_out)) & - mask_out(isw:iew,jsw:jew,:) = & - field(index)%mask(isc:iec,jsc:jec,:,i1).and.& - field(index)%mask(isc:iec,jsc:jec,:,i2) - endif - - end subroutine time_interp_external_3d -! NAME="time_interp_external" - - !> @brief Scalar time interpolation for @ref time_interp_external - subroutine time_interp_external_0d(index, time, data, verbose) - - integer, intent(in) :: index - type(time_type), intent(in) :: time - real, intent(inout) :: data - logical, intent(in), optional :: verbose - - integer :: t1, t2 - integer :: i1, i2, mod_time - integer :: yy, mm, dd, hh, min, ss - character(len=256) :: err_msg, filename - - real :: w1,w2 - logical :: verb - - verb=.false. - if (PRESENT(verbose)) verb=verbose - if (debug_this_module) verb = .true. - - if (index < 1.or.index > num_fields) & - call mpp_error(FATAL, & - & 'invalid index in call to time_interp_ext -- field was not initialized or failed to initialize') - - if (field(index)%siz(4) == 1) then - ! only one record in the file => time-independent field - call load_record_0d(field(index),1) - i1 = find_buf_index(1,field(index)%ibuf) - data = field(index)%data(1,1,1,i1) - else - if(field(index)%have_modulo_times) then - call time_interp(time,field(index)%modulo_time_beg, field(index)%modulo_time_end, field(index)%time(:), & - w2, t1, t2, field(index)%correct_leap_year_inconsistency, err_msg=err_msg) - if(err_msg .NE. '') then - filename = mpp_get_file_name(field(index)%unit) - call mpp_error(FATAL,"time_interp_external 3:"//trim(err_msg)//& - ",file="//trim(filename)//",field="//trim(field(index)%name) ) - endif - else - if(field(index)%modulo_time) then - mod_time=1 - else - mod_time=0 - endif - call time_interp(time,field(index)%time(:),w2,t1,t2,modtime=mod_time, err_msg=err_msg) - if(err_msg .NE. '') then - filename = mpp_get_file_name(field(index)%unit) - call mpp_error(FATAL,"time_interp_external 4:"//trim(err_msg)// & - ",file="//trim(filename)//",field="//trim(field(index)%name) ) - endif - endif - w1 = 1.0-w2 - if (verb) then - call get_date(time,yy,mm,dd,hh,min,ss) - write(outunit,'(a,i4,a,i2,a,i2,1x,i2,a,i2,a,i2)') & - 'target time yyyy/mm/dd hh:mm:ss= ',yy,'/',mm,'/',dd,hh,':',min,':',ss - write(outunit,*) 't1, t2, w1, w2= ', t1, t2, w1, w2 - endif - call load_record_0d(field(index),t1) - call load_record_0d(field(index),t2) - i1 = find_buf_index(t1,field(index)%ibuf) - i2 = find_buf_index(t2,field(index)%ibuf) - - if(i1<0.or.i2<0) & - call mpp_error(FATAL,'time_interp_external : records were not loaded correctly in memory') - data = field(index)%data(1,1,1,i1)*w1 + field(index)%data(1,1,1,i2)*w2 - if (verb) then - write(outunit,*) 'ibuf= ',field(index)%ibuf - write(outunit,*) 'i1,i2= ',i1, i2 - endif - endif - - end subroutine time_interp_external_0d - - subroutine set_time_modulo(Time) - - type(time_type), intent(inout), dimension(:) :: Time - - integer :: ntime, n - integer :: yr, mon, dy, hr, minu, sec - - ntime = size(Time(:)) - - do n = 1, ntime - call get_date(Time(n), yr, mon, dy, hr, minu, sec) - yr = modulo_year - Time(n) = set_date(yr, mon, dy, hr, minu, sec) - enddo - - - end subroutine set_time_modulo - -! ============================================================================ -! load specified record from file -subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id_in) - type(ext_fieldtype), intent(inout) :: field - integer , intent(in) :: rec ! record number - type(horiz_interp_type), intent(in), optional :: interp - integer, intent(in), optional :: is_in, ie_in, js_in, je_in - integer, intent(in), optional :: window_id_in - - ! ---- local vars - integer :: ib ! index in the array of input buffers - integer :: isw,iew,jsw,jew ! boundaries of the domain on each window - integer :: is_region, ie_region, js_region, je_region, i, j - integer :: start(4), nread(4) - logical :: need_compute - real :: mask_in(size(field%src_data,1),size(field%src_data,2),size(field%src_data,3)) - real, allocatable :: mask_out(:,:,:) - integer :: window_id - - window_id = 1 - if( PRESENT(window_id_in) ) window_id = window_id_in - need_compute = .true. - -!$OMP CRITICAL - ib = find_buf_index(rec,field%ibuf) - - if(ib>0) then - !--- do nothing - need_compute = .false. - else - ! calculate current buffer number in round-robin fasion - field%nbuf = field%nbuf + 1 - if(field%nbuf > size(field%data,4).or.field%nbuf <= 0) field%nbuf = 1 - ib = field%nbuf - field%ibuf(ib) = rec - field%need_compute(ib,:) = .true. - - if (field%domain_present .and. .not.PRESENT(interp)) then - if (debug_this_module) write(outunit,*) 'reading record with domain for field ',trim(field%name) - call mpp_read(field%unit,field%field,field%domain,field%src_data(:,:,:,ib),rec) - else - if (debug_this_module) write(outunit,*) 'reading record without domain for field ',trim(field%name) - start = 1; nread = 1 - start(1) = field%is_src; nread(1) = field%ie_src - field%is_src + 1 - start(2) = field%js_src; nread(2) = field%je_src - field%js_src + 1 - start(3) = 1; nread(3) = size(field%src_data,3) - start(field%tdim) = rec; nread(field%tdim) = 1 - call mpp_read(field%unit,field%field,field%src_data(:,:,:,ib),start,nread) - endif - endif -!$OMP END CRITICAL - isw=field%isc;iew=field%iec - jsw=field%jsc;jew=field%jec - - if( field%numwindows > 1) then - if( .NOT. PRESENT(is_in) .OR. .NOT. PRESENT(ie_in) .OR. .NOT. PRESENT(js_in) .OR. .NOT. PRESENT(je_in) ) then - call mpp_error(FATAL, & - & 'time_interp_external(load_record): is_in, ie_in, js_in, je_in must be present when numwindows>1') - endif - isw = isw + is_in - 1 - iew = isw + ie_in - is_in - jsw = jsw + js_in - 1 - jew = jsw + je_in - js_in - endif - - ! interpolate to target grid - - need_compute = field%need_compute(ib, window_id) - if(need_compute) then - if(PRESENT(interp)) then - is_region = field%is_region; ie_region = field%ie_region - js_region = field%js_region; je_region = field%je_region - mask_in = 0.0 - where (mpp_is_valid(field%src_data(:,:,:,ib), field%valid)) mask_in = 1.0 - if ( field%region_type .NE. NO_REGION ) then - if( ANY(mask_in == 0.0) ) then - call mpp_error(FATAL, "time_interp_external: mask_in should be all 1 when region_type is not NO_REGION") - endif - if( field%region_type == OUTSIDE_REGION) then - do j = js_region, je_region - do i = is_region, ie_region - mask_in(i,j,:) = 0.0 - enddo - enddo - else ! field%region_choice == INSIDE_REGION - do j = 1, size(mask_in,2) - do i = 1, size(mask_in,1) - if( jje_region .OR. iie_region ) mask_in(i,j,:) = 0.0 - enddo - enddo - endif - endif - allocate(mask_out(isw:iew,jsw:jew, size(field%src_data,3))) - call horiz_interp(interp,field%src_data(:,:,:,ib),field%data(isw:iew,jsw:jew,:,ib), & - mask_in=mask_in, & - mask_out=mask_out) - - field%mask(isw:iew,jsw:jew,:,ib) = mask_out(isw:iew,jsw:jew,:) > 0 - deallocate(mask_out) - else - if ( field%region_type .NE. NO_REGION ) then - call mpp_error(FATAL, "time_interp_external: region_type should be NO_REGION when interp is not present") - endif - field%data(isw:iew,jsw:jew,:,ib) = field%src_data(isw:iew,jsw:jew,:,ib) - field%mask(isw:iew,jsw:jew,:,ib) = mpp_is_valid(field%data(isw:iew,jsw:jew,:,ib),field%valid) - endif - ! convert units - where(field%mask(isw:iew,jsw:jew,:,ib)) field%data(isw:iew,jsw:jew,:,ib) = & - field%data(isw:iew,jsw:jew,:,ib)*field%slope + field%intercept - field%need_compute(ib, window_id) = .false. - endif - -end subroutine load_record - - -subroutine load_record_0d(field, rec) - type(ext_fieldtype), intent(inout) :: field - integer , intent(in) :: rec ! record number - ! ---- local vars - integer :: ib ! index in the array of input buffers - integer :: start(4), nread(4) - - ib = find_buf_index(rec,field%ibuf) - - if(ib>0) then - return - else - ! calculate current buffer number in round-robin fasion - field%nbuf = field%nbuf + 1 - if(field%nbuf > size(field%data,4).or.field%nbuf <= 0) field%nbuf = 1 - ib = field%nbuf - field%ibuf(ib) = rec - - if (debug_this_module) write(outunit,*) 'reading record without domain for field ',trim(field%name) - start = 1; nread = 1 - start(3) = 1; nread(3) = size(field%src_data,3) - start(field%tdim) = rec; nread(field%tdim) = 1 - call mpp_read(field%unit,field%field,field%src_data(:,:,:,ib),start,nread) - if ( field%region_type .NE. NO_REGION ) then - call mpp_error(FATAL, "time_interp_external: region_type should be NO_REGION when field is scalar") - endif - field%data(1,1,:,ib) = field%src_data(1,1,:,ib) - field%mask(1,1,:,ib) = mpp_is_valid(field%data(1,1,:,ib),field%valid) - ! convert units - where(field%mask(1,1,:,ib)) field%data(1,1,:,ib) = & - field%data(1,1,:,ib)*field%slope + field%intercept - endif - -end subroutine load_record_0d - -! ============================================================================ -subroutine reset_src_data_region(index, is, ie, js, je) - integer, intent(in) :: index - integer, intent(in) :: is, ie, js, je - integer :: nk, nbuf - - if( is == field(index)%is_src .AND. ie == field(index)%ie_src .AND. & - js == field(index)%js_src .AND. ie == field(index)%je_src ) return - - if( .NOT. ASSOCIATED(field(index)%src_data) ) call mpp_error(FATAL, & - "time_interp_external: field(index)%src_data is not associated") - nk = size(field(index)%src_data,3) - nbuf = size(field(index)%src_data,4) - deallocate(field(index)%src_data) - allocate(field(index)%src_data(is:ie,js:je,nk,nbuf)) - field(index)%is_src = is - field(index)%ie_src = ie - field(index)%js_src = js - field(index)%je_src = je - - -end subroutine reset_src_data_region - -! ============================================================================ -subroutine set_override_region(index, region_type, is_region, ie_region, js_region, je_region) - integer, intent(in) :: index, region_type - integer, intent(in) :: is_region, ie_region, js_region, je_region - - field(index)%region_type = region_type - field(index)%is_region = is_region - field(index)%ie_region = ie_region - field(index)%js_region = js_region - field(index)%je_region = je_region - - return - -end subroutine set_override_region - -! ============================================================================ -! reallocates array of fields, increasing its size -subroutine realloc_files(n) - integer, intent(in) :: n ! new size - - type(filetype), pointer :: ptr(:) - integer :: i - - if (associated(opened_files)) then - if (n <= size(opened_files)) return ! do nothing, if requested size no more than current - endif - - allocate(ptr(n)) - do i = 1, size(ptr) - ptr(i)%filename = '' - ptr(i)%unit = -1 - enddo - - if (associated(opened_files))then - ptr(1:size(opened_files)) = opened_files(:) - deallocate(opened_files) - endif - opened_files => ptr - -end subroutine realloc_files - -! ============================================================================ -! reallocates array of fields,increasing its size -subroutine realloc_fields(n) - integer, intent(in) :: n ! new size - - type(ext_fieldtype), pointer :: ptr(:) - integer :: i, ier - - if (associated(field)) then - if (n <= size(field)) return ! do nothing if requested size no more then current - endif - - allocate(ptr(n)) - do i=1,size(ptr) - ptr(i)%unit=-1 - ptr(i)%name='' - ptr(i)%units='' - ptr(i)%siz=-1 - ptr(i)%ndim=-1 - ptr(i)%domain = NULL_DOMAIN2D - ptr(i)%axes(:) = default_axis - if (ASSOCIATED(ptr(i)%time)) DEALLOCATE(ptr(i)%time, stat=ier) - if (ASSOCIATED(ptr(i)%start_time)) DEALLOCATE(ptr(i)%start_time, stat=ier) - if (ASSOCIATED(ptr(i)%end_time)) DEALLOCATE(ptr(i)%end_time, stat=ier) - ptr(i)%field = default_field - if (ASSOCIATED(ptr(i)%period)) DEALLOCATE(ptr(i)%period, stat=ier) - ptr(i)%modulo_time=.false. - if (ASSOCIATED(ptr(i)%data)) DEALLOCATE(ptr(i)%data, stat=ier) - if (ASSOCIATED(ptr(i)%ibuf)) DEALLOCATE(ptr(i)%ibuf, stat=ier) - if (ASSOCIATED(ptr(i)%src_data)) DEALLOCATE(ptr(i)%src_data, stat=ier) - ptr(i)%nbuf=-1 - ptr(i)%domain_present=.false. - ptr(i)%slope=1.0 - ptr(i)%intercept=0.0 - ptr(i)%isc=-1;ptr(i)%iec=-1 - ptr(i)%jsc=-1;ptr(i)%jec=-1 - enddo - if (associated(field)) then - ptr(1:size(field)) = field(:) - deallocate(field) - endif - field=>ptr - -end subroutine realloc_fields - - - function find_buf_index(indx,buf) - integer :: indx - integer, dimension(:) :: buf - integer :: find_buf_index - - integer :: nbuf, i - - nbuf = size(buf(:)) - - find_buf_index = -1 - - do i=1,nbuf - if (buf(i) == indx) then - find_buf_index = i - exit - endif - enddo - - end function find_buf_index - -! -! -! -! return size of field after call to init_external_field. -! Ordering is X/Y/Z/T. -! This call only makes sense for non-distributed reads. -! -! -! -! returned from previous call to init_external_field. -! - - function get_external_field_size(index) - - integer :: index - integer :: get_external_field_size(4) - - if (index .lt. 1 .or. index .gt. num_fields) & - call mpp_error(FATAL,'invalid index in call to get_external_field_size') - - - get_external_field_size(1) = field(index)%siz(1) - get_external_field_size(2) = field(index)%siz(2) - get_external_field_size(3) = field(index)%siz(3) - get_external_field_size(4) = field(index)%siz(4) - - end function get_external_field_size -! NAME="get_external_field_size" - - -! -! -! -! return missing value -! -! -! -! returned from previous call to init_external_field. -! - - function get_external_field_missing(index) - - integer :: index - real :: get_external_field_missing - - if (index .lt. 1 .or. index .gt. num_fields) & - call mpp_error(FATAL,'invalid index in call to get_external_field_size') - - -! call mpp_get_atts(field(index)%field,missing=missing) - get_external_field_missing = field(index)%missing - - end function get_external_field_missing -! NAME="get_external_field_missing" - -! -! -! -! return field axes after call to init_external_field. -! Ordering is X/Y/Z/T. -! -! -! -! returned from previous call to init_external_field. -! - - - function get_external_field_axes(index) - - integer :: index - type(axistype), dimension(4) :: get_external_field_axes - - if (index .lt. 1 .or. index .gt. num_fields) & - call mpp_error(FATAL,'invalid index in call to get_external_field_size') - - - get_external_field_axes(1) = field(index)%axes(1) - get_external_field_axes(2) = field(index)%axes(2) - get_external_field_axes(3) = field(index)%axes(3) - get_external_field_axes(4) = field(index)%axes(4) - - end function get_external_field_axes -! NAME="get_external_field_axes" - -! =========================================================================== -subroutine get_time_axis(index, time) - integer , intent(in) :: index ! field id - type(time_type), intent(out) :: time(:) ! array of time values to be filled - - integer :: n ! size of the data to be assigned - - if (index < 1.or.index > num_fields) & - call mpp_error(FATAL,'invalid index in call to get_time_axis') - - n = min(size(time),size(field(index)%time)) - - time(1:n) = field(index)%time(1:n) -end subroutine - -! -! -! -! exit time_interp_external_mod. Close all open files and -! release storage -! - - subroutine time_interp_external_exit() - - integer :: i,j -! -! release storage arrays -! - do i=1,num_fields - deallocate(field(i)%time,field(i)%start_time,field(i)%end_time,& - field(i)%period,field(i)%data,field(i)%mask,field(i)%ibuf) - if (ASSOCIATED(field(i)%src_data)) deallocate(field(i)%src_data) - do j=1,4 - field(i)%axes(j) = default_axis - enddo - field(i)%domain = NULL_DOMAIN2D - field(i)%field = default_field - field(i)%nbuf = 0 - field(i)%slope = 0. - field(i)%intercept = 0. - enddo - - deallocate(field) - deallocate(opened_files) - - num_fields = 0 - - module_initialized = .false. - - end subroutine time_interp_external_exit -! NAME="time_interp_external_exit" -#endif -end module time_interp_external_mod -!> @} -! close documentation grouping diff --git a/tridiagonal/Makefile.am b/tridiagonal/Makefile.am index 177ca904a5..d8b90c409b 100644 --- a/tridiagonal/Makefile.am +++ b/tridiagonal/Makefile.am @@ -23,14 +23,17 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/tridiagonal/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. noinst_LTLIBRARIES = libtridiagonal.la # The convenience library depends on its source. -libtridiagonal_la_SOURCES = tridiagonal.F90 +libtridiagonal_la_SOURCES = tridiagonal.F90 \ + include/tridiagonal.inc \ + include/tridiagonal_r4.fh \ + include/tridiagonal_r8.fh # Mod file depends on its o file, is built and then installed. tridiagonal.lo: tridiagonal_mod.$(FC_MODEXT) diff --git a/tridiagonal/include/tridiagonal.inc b/tridiagonal/include/tridiagonal.inc new file mode 100644 index 0000000000..95788eb795 --- /dev/null +++ b/tridiagonal/include/tridiagonal.inc @@ -0,0 +1,106 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @addtogroup tridiagonal_mod +!> @{ + +!> @brief Sets up and solves the tridiagonal system of equations +!! +!> For simplicity, A and C are assumed to be dimensioned the same size +!! as B, D, and X, although any input values for A(N) and C(1) are ignored. +!! There are no checks to make sure the sizes agree. +!! +!! The value of A(N) is modified on output, and B and C are unchanged. +!! +!! For mixed precision, this routine uses the kind size macro(FMS_TRID_KIND_) to determine +!! which module variables are used/stored. This means a,b, and c values will only be stored for calls +!! of the same real kind value unless store_both_kinds is present and .true.. +subroutine TRI_INVERT_(x,d,a,b,c, store_both_kinds) + + real(FMS_TRID_KIND_), intent(out), dimension(:,:,:) :: x !< Solution to the tridiagonal system of equations + real(FMS_TRID_KIND_), intent(in), dimension(:,:,:) :: d !< The right-hand side term, see the schematic above. + real(FMS_TRID_KIND_), optional, dimension(:,:,:) :: a,b,c !< Left hand side terms(see schematic on module page). + !! If not provided, values from last call are used + logical, optional :: store_both_kinds !< Will save module state + !! variables for both kind types in order to be used in + !! subsequent calls with either kind. + + real(FMS_TRID_KIND_), dimension(size(x,1),size(x,2),size(x,3)) :: f + integer, parameter :: kindl = FMS_TRID_KIND_ + + integer :: k + + if(present(a)) then + !$OMP SINGLE + INIT_VAR = .true. + if(allocated(TRID_REAL_TYPE%e)) deallocate(TRID_REAL_TYPE%e) + if(allocated(TRID_REAL_TYPE%g)) deallocate(TRID_REAL_TYPE%g) + if(allocated(TRID_REAL_TYPE%bb)) deallocate(TRID_REAL_TYPE%bb) + if(allocated(TRID_REAL_TYPE%cc)) deallocate(TRID_REAL_TYPE%cc) + allocate(TRID_REAL_TYPE%e (size(x,1),size(x,2),size(x,3))) + allocate(TRID_REAL_TYPE%g (size(x,1),size(x,2),size(x,3))) + allocate(TRID_REAL_TYPE%bb(size(x,1),size(x,2))) + allocate(TRID_REAL_TYPE%cc(size(x,1),size(x,2),size(x,3))) + !$OMP END SINGLE + + TRID_REAL_TYPE%e(:,:,1) = - a(:,:,1) / b(:,:,1) + a(:,:,size(x,3)) = 0.0_kindl + + do k= 2,size(x,3) + TRID_REAL_TYPE%g(:,:,k) = 1.0_kindl/(b(:,:,k)+c(:,:,k)*TRID_REAL_TYPE%e(:,:,k-1)) + TRID_REAL_TYPE%e(:,:,k) = - a(:,:,k)* TRID_REAL_TYPE%g(:,:,k) + end do + TRID_REAL_TYPE%cc = c + TRID_REAL_TYPE%bb = 1.0_kindl/b(:,:,1) + + end if + + if(.not.INIT_VAR) call mpp_error(FATAL, 'tri_invert: a,b,and c args not provided or previously calculated.') + + f(:,:,1) = d(:,:,1)*TRID_REAL_TYPE%bb + do k= 2, size(x,3) + f(:,:,k) = (d(:,:,k) - TRID_REAL_TYPE%cc(:,:,k)*f(:,:,k-1))*TRID_REAL_TYPE%g(:,:,k) + end do + + x(:,:,size(x,3)) = f(:,:,size(x,3)) + do k = size(x,3)-1,1,-1 + x(:,:,k) = TRID_REAL_TYPE%e(:,:,k)*x(:,:,k+1)+f(:,:,k) + end do + + ! stores both kind values for subsequent calculations if running with option + if( present(store_both_kinds)) then + if( store_both_kinds ) then + if( FMS_TRID_KIND_ .eq. r8_kind) then + tridiag_r4%e = real(TRID_REAL_TYPE%e, r4_kind) + tridiag_r4%g = real(TRID_REAL_TYPE%g, r4_kind) + tridiag_r4%cc = real(TRID_REAL_TYPE%cc, r4_kind) + tridiag_r4%bb = real(TRID_REAL_TYPE%bb, r4_kind) + init_tridiagonal_r4 = .true. + else + tridiag_r8%e = real(TRID_REAL_TYPE%e, r8_kind) + tridiag_r8%g = real(TRID_REAL_TYPE%g, r8_kind) + tridiag_r8%cc = real(TRID_REAL_TYPE%cc, r8_kind) + tridiag_r8%bb = real(TRID_REAL_TYPE%bb, r8_kind) + init_tridiagonal_r8 = .true. + endif + endif + endif + + return +end subroutine TRI_INVERT_ \ No newline at end of file diff --git a/tridiagonal/include/tridiagonal_r4.fh b/tridiagonal/include/tridiagonal_r4.fh new file mode 100644 index 0000000000..09e0ad57ac --- /dev/null +++ b/tridiagonal/include/tridiagonal_r4.fh @@ -0,0 +1,32 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +#undef FMS_TRID_KIND_ +#define FMS_TRID_KIND_ r4_kind + +#undef TRID_REAL_TYPE +#define TRID_REAL_TYPE tridiag_r4 + +#undef TRI_INVERT_ +#define TRI_INVERT_ tri_invert_r4 + +#undef INIT_VAR +#define INIT_VAR init_tridiagonal_r4 + +#include "tridiagonal.inc" \ No newline at end of file diff --git a/tridiagonal/include/tridiagonal_r8.fh b/tridiagonal/include/tridiagonal_r8.fh new file mode 100644 index 0000000000..b007941723 --- /dev/null +++ b/tridiagonal/include/tridiagonal_r8.fh @@ -0,0 +1,32 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +#undef FMS_TRID_KIND_ +#define FMS_TRID_KIND_ r8_kind + +#undef TRID_REAL_TYPE +#define TRID_REAL_TYPE tridiag_r8 + +#undef TRI_INVERT_ +#define TRI_INVERT_ tri_invert_r8 + +#undef INIT_VAR +#define INIT_VAR init_tridiagonal_r8 + +#include "tridiagonal.inc" \ No newline at end of file diff --git a/tridiagonal/tridiagonal.F90 b/tridiagonal/tridiagonal.F90 index c22f99c4ee..e34feb4d92 100644 --- a/tridiagonal/tridiagonal.F90 +++ b/tridiagonal/tridiagonal.F90 @@ -52,128 +52,85 @@ !! 
 !!    call close_tridiagonal
 !!
+!! +!! !! Arguments A, B, and C are optional, and are saved as module variables !! if one recalls tri_invert without changing (A,B,C) +!! +!! @note +!! Optional arguments A,B,C have no intent declaration, +!! so the default intent is inout. The value of A(N) is modified +!! on output, and B and C are unchanged. +!! +!! The following private allocatable arrays save the relevant information +!! if one recalls tri_invert without changing (A,B,C): +!! 
+!!        allocate ( e  (size(x,1), size(x,2), size(x,3)) )
+!!        allocate ( g  (size(x,1), size(x,2), size(x,3)) )
+!!        allocate ( cc (size(x,1), size(x,2), size(x,3)) )
+!!        allocate ( bb (size(x,1), size(x,2)) )
+!!
+!! This storage is deallocated when close_tridiagonal is called. !> @addtogroup tridiagonal_mod !> @{ module tridiagonal_mod -!-------------------------------------------------------------------------- -real, private, allocatable, dimension(:,:,:) :: e,g,cc -real, private, allocatable, dimension(:,:) :: bb -logical, private :: init_tridiagonal = .false. -!-------------------------------------------------------------------------- - -contains - -!-------------------------------------------------------------------------- - -!> @brief Sets up and solves the tridiagonal system of equations -!! -!> For simplicity, A and C are assumed to be dimensioned the same size -!! as B, D, and X, although any input values for A(N) and C(1) are ignored. -!! There are no checks to make sure the sizes agree. -!! -!! The value of A(N) is modified on output, and B and C are unchanged. -subroutine tri_invert(x,d,a,b,c) - -implicit none - -real, intent(out), dimension(:,:,:) :: x !< Solution to the tridiagonal system of equations -real, intent(in), dimension(:,:,:) :: d !< The right-hand side term, see the schematic above. -real, optional, dimension(:,:,:) :: a,b,c !< Left hand side terms(see schematic above). - !! If not provided, values from last call are used - -real, dimension(size(x,1),size(x,2),size(x,3)) :: f -integer :: k - -if(present(a)) then - - !< Check if module variables are allocated - !$OMP SINGLE - init_tridiagonal = .true. - if(allocated(e)) deallocate(e) - if(allocated(g)) deallocate(g) - if(allocated(bb)) deallocate(bb) - if(allocated(cc)) deallocate(cc) - allocate(e (size(x,1),size(x,2),size(x,3))) - allocate(g (size(x,1),size(x,2),size(x,3))) - allocate(bb(size(x,1),size(x,2))) - allocate(cc(size(x,1),size(x,2),size(x,3))) - !$OMP END SINGLE !< There is an implicit barrier. - - e(:,:,1) = - a(:,:,1)/b(:,:,1) - a(:,:,size(x,3)) = 0.0 - - do k= 2,size(x,3) - g(:,:,k) = 1.0/(b(:,:,k)+c(:,:,k)*e(:,:,k-1)) - e(:,:,k) = - a(:,:,k)*g(:,:,k) - end do - cc = c - bb = 1.0/b(:,:,1) - -end if - -! if(.not.init_tridiagonal) error - -f(:,:,1) = d(:,:,1)*bb -do k= 2, size(x,3) - f(:,:,k) = (d(:,:,k) - cc(:,:,k)*f(:,:,k-1))*g(:,:,k) -end do - -x(:,:,size(x,3)) = f(:,:,size(x,3)) -do k = size(x,3)-1,1,-1 - x(:,:,k) = e(:,:,k)*x(:,:,k+1)+f(:,:,k) -end do - -return -end subroutine tri_invert - -!----------------------------------------------------------------- - -!> @brief Releases memory used by the solver -subroutine close_tridiagonal - - implicit none - - !< Check if module variables are allocated - !$OMP SINGLE - if(allocated(e)) deallocate(e) - if(allocated(g)) deallocate(g) - if(allocated(bb)) deallocate(bb) - if(allocated(cc)) deallocate(cc) - !$OMP END SINGLE !< There is an implicit barrier. - -return -end subroutine close_tridiagonal - -!---------------------------------------------------------------- + use platform_mod, only: r4_kind, r8_kind + use mpp_mod, only: mpp_error, FATAL + implicit none + + type :: tridiag_reals_r4 + real(r4_kind), private, allocatable, dimension(:,:,:) :: e, g, cc + real(r4_kind), private, allocatable, dimension(:,:) :: bb + end type + + type :: tridiag_reals_r8 + real(r8_kind), private, allocatable, dimension(:,:,:) :: e, g, cc + real(r8_kind), private, allocatable, dimension(:,:) :: bb + end type + + type(tridiag_reals_r4) :: tridiag_r4 !< holds reals stored from r4_kind calls to tri_invert + type(tridiag_reals_r8) :: tridiag_r8 !< holds reals stored from r8_kind calls to tri_invert + + logical, private :: init_tridiagonal_r4 = .false. !< true when fields in tridiag_r4 are allocated + logical, private :: init_tridiagonal_r8 = .false. !< true when fields in tridiag_r8 are allocated + + !> Interface to solve tridiagonal systems of equations for either kind value. + !! Module level variables will be deallocated and allocated for every + !! Since this relies on the state of module variables (unless A,B,C are specified) + !! the values stored are distinct for each kind call unless the added optional argument store_both_kinds + !! is true. + interface tri_invert + module procedure tri_invert_r4 + module procedure tri_invert_r8 + end interface + + public :: tri_invert + + contains + + !> @brief Releases memory used by the solver + subroutine close_tridiagonal + if(.not. init_tridiagonal_r4 .and. .not. init_tridiagonal_r8) return + !$OMP SINGLE + if(allocated(tridiag_r4%e)) deallocate(tridiag_r4%e) + if(allocated(tridiag_r4%g)) deallocate(tridiag_r4%g) + if(allocated(tridiag_r4%cc)) deallocate(tridiag_r4%cc) + if(allocated(tridiag_r4%bb)) deallocate(tridiag_r4%bb) + if(allocated(tridiag_r8%e)) deallocate(tridiag_r8%e) + if(allocated(tridiag_r8%g)) deallocate(tridiag_r8%g) + if(allocated(tridiag_r8%cc)) deallocate(tridiag_r8%cc) + if(allocated(tridiag_r8%bb)) deallocate(tridiag_r8%bb) + init_tridiagonal_r4 = .false.; init_tridiagonal_r8 = .false. + !$OMP END SINGLE + return + end subroutine close_tridiagonal + +#include "tridiagonal_r4.fh" +#include "tridiagonal_r8.fh" end module tridiagonal_mod -! - -! -! Optional arguments A,B,C have no intent declaration, -! so the default intent is inout. The value of A(N) is modified -! on output, and B and C are unchanged. -! -! -! The following private allocatable arrays save the relevant information -! if one recalls tri_invert without changing (A,B,C): -! 
-!        allocate ( e  (size(x,1), size(x,2), size(x,3)) )
-!        allocate ( g  (size(x,1), size(x,2), size(x,3)) )
-!        allocate ( cc (size(x,1), size(x,2), size(x,3)) )
-!        allocate ( bb (size(x,1), size(x,2)) )
-!
-! This storage is deallocated when close_tridiagonal is called. -! -! -! Maybe a cleaner version? -! - -! !> @} -! close documentation grouping +! close documentation grouping \ No newline at end of file