diff --git a/.github/workflows/github_autotools_gnu.yml b/.github/workflows/github_autotools_gnu.yml index 00c7f5d31c..8df7021bb9 100644 --- a/.github/workflows/github_autotools_gnu.yml +++ b/.github/workflows/github_autotools_gnu.yml @@ -4,6 +4,11 @@ name: Build libFMS test with autotools on: [push, pull_request] +# cancel running jobs if theres a newer push +concurrency: + group: ${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: true + jobs: build: runs-on: ubuntu-latest @@ -22,7 +27,7 @@ jobs: SKIP_TESTS: "test_yaml_parser.5" # temporary till fixes are in steps: - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - name: Prepare GNU autoconf for build run: autoreconf -if - name: Configure the build diff --git a/.github/workflows/github_autotools_intel.yml b/.github/workflows/github_autotools_intel.yml index 851ad71520..a09f8c87d3 100644 --- a/.github/workflows/github_autotools_intel.yml +++ b/.github/workflows/github_autotools_intel.yml @@ -1,4 +1,10 @@ on: pull_request + +# cancel running jobs if theres a newer push +concurrency: + group: ${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: true + jobs: intel-autotools: runs-on: ubuntu-latest @@ -47,7 +53,7 @@ jobs: ./configure --prefix=/libs make -j install && cd - name: checkout - uses: actions/checkout@v2 + uses: actions/checkout@v4 - name: Configure run: autoreconf -if ./configure.ac && ./configure --with-yaml - name: Compile diff --git a/.github/workflows/github_cmake_gnu.yml b/.github/workflows/github_cmake_gnu.yml index d4f7e2a248..08fed288cc 100644 --- a/.github/workflows/github_cmake_gnu.yml +++ b/.github/workflows/github_cmake_gnu.yml @@ -2,6 +2,11 @@ name: Build libFMS with cmake on: [push, pull_request] +# cancel running jobs if theres a newer push +concurrency: + group: ${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: true + jobs: build: runs-on: ubuntu-latest @@ -16,7 +21,7 @@ jobs: CMAKE_FLAGS: "${{ matrix.omp-flags }} ${{ matrix.io-flag }} ${{ matrix.libyaml-flag }} -D64BIT=on" steps: - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - name: Generate makefiles with CMake run: cmake $CMAKE_FLAGS . - name: Build the library diff --git a/.github/workflows/github_coupler_gnu.yml b/.github/workflows/github_coupler_gnu.yml index 4e3e357d0d..70cf0db3a5 100644 --- a/.github/workflows/github_coupler_gnu.yml +++ b/.github/workflows/github_coupler_gnu.yml @@ -1,6 +1,11 @@ name: Test coupler build on: [pull_request] +# cancel running jobs if theres a newer push +concurrency: + group: ${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: true + jobs: coupler-build: runs-on: ubuntu-latest @@ -17,11 +22,11 @@ jobs: LDFLAGS: '-L/opt/view/lib' steps: - name: Checkout FMS - uses: actions/checkout@v2 + uses: actions/checkout@v4 with: path: FMS - name: Checkout FMScoupler - uses: actions/checkout@v2 + uses: actions/checkout@v4 with: repository: 'NOAA-GFDL/FMScoupler' path: FMScoupler diff --git a/.github/workflows/github_doc_site.yml b/.github/workflows/github_doc_site.yml index bbf2335811..43c4d89897 100644 --- a/.github/workflows/github_doc_site.yml +++ b/.github/workflows/github_doc_site.yml @@ -10,7 +10,7 @@ jobs: runs-on: ubuntu-latest steps: - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - name: Setup repo run: | # do autotool's job for substitutes since we don't need a full build environement mkdir gen_docs diff --git a/.github/workflows/github_linter.yml b/.github/workflows/github_linter.yml index c24de95783..9c0d00e67e 100644 --- a/.github/workflows/github_linter.yml +++ b/.github/workflows/github_linter.yml @@ -7,7 +7,7 @@ jobs: runs-on: ubuntu-latest steps: - name: Checkout code - uses: actions/checkout@v2 + uses: actions/checkout@v4 - name: Run Lint uses: NOAA-GFDL/simple_lint@f5aa1fe976bd4c231db0536ba00cbfdc26708253 with: diff --git a/.github/workflows/version.yml b/.github/workflows/version.yml index 31641aea69..d910b6c8f8 100644 --- a/.github/workflows/version.yml +++ b/.github/workflows/version.yml @@ -7,7 +7,7 @@ jobs: add-dev-to-version: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - name: Append version with dev run: sed -i '/20[0-9][0-9]\.[0-9][0-9]/ s/]/-dev]/' configure.ac - name: Create pull request diff --git a/CHANGELOG.md b/CHANGELOG.md index 2c616e647d..89c455606c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,68 @@ 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.04] - 2023-12-04 +### Known Issues +- GCC 9 and below as well as GCC 11.1.0 are unsupported due to compilation issues. See prior releases for more details. +- `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 +- DATA_OVERRIDE: A new namelist flag `use_data_table_yaml` has been added to enable usage of the yaml format data_override tables. This allows an executable built with yaml support be able to accept either format. + +### Changed +- RESERVED KEYWORD CHANGES: Various routines in FMS have been updated to not use fortran keywords for variable names. The names changed were: `data`, `unit`, and `value`. This may affect usage of external code if argument names are explicitly used. Only required arguement names were changed to mitigate any breaking changes. +- TESTS: Changes the testing scripts to allow for the `MPI_LAUNCHER` environment variable override to work with any provided arguments. + +### Fixed +- CMAKE: Fixed build issue with CMake where precision default flags were being overwritten when using GNU and MPICH. +- AUTOTOOLS: Fixes issue affecting installs where the global libFMS.F90 module was not being installed correctly and adds post-install message. +- DIAG_MANAGER: Fixes issue with incorrect start_time functionality (from the 2023.02.01 patch) + +### Tag Commit Hashes +- 2023.04-beta1 be1856c45accfe2fb15953c5f51e0d58a8816882 + +## [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.01] - 2023-10-13 +### Fixed +- DIAG_MANAGER: Fixes issue with incorrect start_time functionality + + ## [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 a70abe14da..bb27522c81 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.04.0 DESCRIPTION "GFDL FMS Library" HOMEPAGE_URL "https://www.gfdl.noaa.gov/fms" LANGUAGES C Fortran) @@ -349,7 +349,7 @@ foreach(kind ${kinds}) if ( CMAKE_Fortran_COMPILER_VERSION MATCHES "1[0-9]\.[0-9]*\.[0-9]*" AND CMAKE_Fortran_COMPILER_ID MATCHES "GNU") if(MPI_C_COMPILER MATCHES ".*mpich.*" ) message(STATUS "Adding -fallow-argument-mismatch flag to compile with GCC >=10 and MPICH") - set_target_properties(${libTgt}_f PROPERTIES COMPILE_FLAGS "-fallow-argument-mismatch -w") + target_compile_options(${libTgt}_f PRIVATE "-fallow-argument-mismatch;-w") endif() endif() diff --git a/Makefile.am b/Makefile.am index dd1d27696d..22fb68f97d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -79,7 +79,7 @@ pkgconfigdir = $(libdir)/pkgconfig pkgconfig_DATA = FMS.pc ## Build libFMS module -AM_CPPFLAGS = -I${top_srcdir}/include -I${top_srcdir}/mpp/include +AM_CPPFLAGS = -I${top_srcdir}/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) noinst_LTLIBRARIES = libFMS_mod.la @@ -87,7 +87,7 @@ libFMS_mod_la_SOURCES = libFMS.F90 fms.$(FC_MODEXT): .mods/*_mod.$(FC_MODEXT) -nodist_include_HEADERS = libFMS_mod.la +nodist_include_HEADERS = .mods/fms.$(FC_MODEXT) include $(top_srcdir)/mkmods.mk @@ -130,3 +130,20 @@ else clean-local: -rm -rf .mods endif + +install-data-hook: + @echo '' + @echo '+-------------------------------------------------------------+' + @echo '| Congratulations! You have successfully installed the FMS |' + @echo '| Fortran library. |' + @echo '| |' + @echo '| After the installed include and link paths have been |' + @echo '| specified, code using FMS should be compiled using the |' + @echo '| "-lFMS" flag. |' + @echo '| |' + @echo '| FMS is developed and maintained at the GFDL publicly on |' + @echo '| Github. To report an issue or view available documentation, |' + @echo '| please see our page: https://www.github.com/NOAA-GFDL/FMS |' + @echo '+-------------------------------------------------------------+' + @echo '' + diff --git a/affinity/fms_affinity.F90 b/affinity/fms_affinity.F90 index c02fbc69cf..33a305ebb0 100644 --- a/affinity/fms_affinity.F90 +++ b/affinity/fms_affinity.F90 @@ -91,7 +91,7 @@ subroutine fms_affinity_init() !--- local variables integer:: io_stat integer:: ierr - integer:: unit + integer:: iunit !--- return if module is initialized if (module_is_initialized) return @@ -105,8 +105,8 @@ subroutine fms_affinity_init() !--- output information to logfile call write_version_number("fms_affinity_mod", version) - unit = stdlog() - write(unit,nml=fms_affinity_nml) + iunit = stdlog() + write(iunit,nml=fms_affinity_nml) module_is_initialized = .TRUE. diff --git a/amip_interp/amip_interp.F90 b/amip_interp/amip_interp.F90 index a28073e48b..98fe717e06 100644 --- a/amip_interp/amip_interp.F90 +++ b/amip_interp/amip_interp.F90 @@ -303,7 +303,7 @@ module amip_interp_mod ! ---- global unit & date ---- integer, parameter :: maxc = 128 - integer :: unit + integer :: iunit character(len=maxc) :: file_name_sst, file_name_ice type(FmsNetcdfFile_t), target :: fileobj_sst, fileobj_ice @@ -367,7 +367,7 @@ module amip_interp_mod !> initialize @ref amip_interp_mod for use subroutine amip_interp_init - integer :: unit,io,ierr + integer :: iunit,io,ierr !----------------------------------------------------------------------- @@ -381,9 +381,9 @@ subroutine amip_interp_init ! ----- write namelist/version info ----- call write_version_number("AMIP_INTERP_MOD", version) - unit = stdlog ( ) + iunit = stdlog ( ) if (mpp_pe() == 0) then - write (unit,nml=amip_interp_nml) + write (iunit,nml=amip_interp_nml) endif if (use_mpp_io) then diff --git a/amip_interp/include/amip_interp.inc b/amip_interp/include/amip_interp.inc index af8e7487b5..07034bc3f9 100644 --- a/amip_interp/include/amip_interp.inc +++ b/amip_interp/include/amip_interp.inc @@ -52,7 +52,7 @@ subroutine GET_AMIP_SST_ (Time, Interp, sst, err_msg, lon_model, lat_model) ! end add by JHC logical, parameter :: DEBUG = .false. !> switch for debugging output !> These are fms_io specific - integer :: unit + integer :: iunit integer, parameter :: lkind = FMS_AMIP_INTERP_KIND_ if(present(err_msg)) err_msg = '' @@ -103,7 +103,7 @@ if ( .not.use_daily ) then Date2 = date_type( year2, month2, 0 ) ! -- open/rewind file -- - unit = -1 + iunit = -1 !----------------------------------------------------------------------- if (Date1 /= Interp%Date1) then @@ -368,7 +368,7 @@ else Date1 = date_type( year1, month1, 0 ) Date2 = date_type( year2, month2, 0 ) - unit = -1 + iunit = -1 !----------------------------------------------------------------------- if (Date1 /= Interp%Date1) then diff --git a/astronomy/astronomy.F90 b/astronomy/astronomy.F90 index 48e314efd8..3809c98a8a 100644 --- a/astronomy/astronomy.F90 +++ b/astronomy/astronomy.F90 @@ -437,7 +437,7 @@ subroutine astronomy_init (latb, lonb) !------------------------------------------------------------------- ! local variables: !------------------------------------------------------------------- -integer :: unit, ierr, io, seconds, days, jd, id +integer :: iunit, ierr, io, seconds, days, jd, id character(len=17) :: err_str !------------------------------------------------------------------- @@ -463,8 +463,8 @@ subroutine astronomy_init (latb, lonb) !--------------------------------------------------------------------- call write_version_number("ASTRONOMY_MOD", version) if (mpp_pe() == mpp_root_pe() ) then - unit = stdlog() - write (unit, nml=astronomy_nml) + iunit = stdlog() + write (iunit, nml=astronomy_nml) endif !-------------------------------------------------------------------- !> Be sure input values are within valid ranges. diff --git a/axis_utils/include/axis_utils2.inc b/axis_utils/include/axis_utils2.inc index baad2092e5..a1055dfd41 100644 --- a/axis_utils/include/axis_utils2.inc +++ b/axis_utils/include/axis_utils2.inc @@ -218,10 +218,10 @@ end subroutine TRANLON_ - function FRAC_INDEX_(value, array) + function FRAC_INDEX_(rval, array) - integer :: ia, i, ii, unit - real(kind=FMS_AU_KIND_) :: value !< arbitrary data...same units as elements in "array" + integer :: ia, i, ii, iunit + real(kind=FMS_AU_KIND_) :: rval !< arbitrary data...same units as elements in "array" real(kind=FMS_AU_KIND_) :: FRAC_INDEX_ real(kind=FMS_AU_KIND_), dimension(:) :: array !< array of data points (must be monotonically increasing) logical :: keep_going @@ -230,29 +230,27 @@ do i = 2, ia if (array(i) < array(i-1)) then - unit = stdout() - write (unit,*) '=> Error: "frac_index" array must be monotonically' & - & // 'increasing when searching for nearest value to ', value - write (unit,*) ' array(i) < array(i-1) for i=',i - write (unit,*) ' array(i) for i=1..ia follows:' + iunit = stdout() + write (iunit,*) '=> Error: "frac_index" array must be monotonically' & + & // 'increasing when searching for nearest value to ', rval + write (iunit,*) ' array(i) < array(i-1) for i=',i + write (iunit,*) ' array(i) for i=1..ia follows:' do ii = 1, ia - write (unit,*) 'i=',ii, ' array(i)=',array(ii) + write (iunit,*) 'i=',ii, ' array(i)=',array(ii) enddo call mpp_error(FATAL,' "frac_index" array must be monotonically increasing.') endif enddo - if (value < array(1) .or. value > array(ia)) then - ! if (value < array(1)) frac_index = 1. - ! if (value > array(ia)) frac_index = float(ia) + if (rval < array(1) .or. rval > array(ia)) then FRAC_INDEX_ = -1.0_lkind else i = 1 keep_going = .true. do while (i <= ia .and. keep_going) i = i+1 - if (value <= array(i)) then - FRAC_INDEX_ = real((i-1), lkind) + (value-array(i-1)) / (array(i) - array(i-1)) + if (rval <= array(i)) then + FRAC_INDEX_ = real((i-1), lkind) + (rval-array(i-1)) / (array(i) - array(i-1)) keep_going = .false. endif enddo @@ -266,7 +264,7 @@ !! !! inputs: !! - !! value = arbitrary data...same units as elements in "array" + !! rval = arbitrary data...same units as elements in "array" !! array = array of data points (must be monotonically increasing) !! ia = dimension of "array" !! @@ -298,12 +296,12 @@ - function NEAREST_INDEX_(value, array) + function NEAREST_INDEX_(rval, array) integer :: NEAREST_INDEX_ integer :: ia !< dimension of "array" - integer :: i, ii, unit - real(kind=FMS_AU_KIND_) :: value !< arbitrary data...same units as elements in "array" + integer :: i, ii, iunit + real(kind=FMS_AU_KIND_) :: rval !< arbitrary data...same units as elements in "array" real(kind=FMS_AU_KIND_), dimension(:) :: array !< array of data points (must be monotonically increasing) logical :: keep_going @@ -311,29 +309,29 @@ do i = 2, ia if (array(i) < array(i-1)) then - unit = stdout() - write (unit,*) '=> Error: "nearest_index" array must be monotonically increasing' & - & // 'when searching for nearest value to ', value - write (unit,*) ' array(i) < array(i-1) for i=',i - write (unit,*) ' array(i) for i=1..ia follows:' + iunit = stdout() + write (iunit,*) '=> Error: "nearest_index" array must be monotonically increasing' & + & // 'when searching for nearest value to ', rval + write (iunit,*) ' array(i) < array(i-1) for i=',i + write (iunit,*) ' array(i) for i=1..ia follows:' do ii = 1, ia - write (unit,*) 'i=',ii, ' array(i)=', array(ii) + write (iunit,*) 'i=',ii, ' array(i)=', array(ii) enddo call mpp_error(FATAL,' "nearest_index" array must be monotonically increasing.') endif enddo - if (value < array(1) .or. value > array(ia)) then - if (value < array(1)) NEAREST_INDEX_ = 1 - if (value > array(ia)) NEAREST_INDEX_ = ia + if (rval < array(1) .or. rval > array(ia)) then + if (rval < array(1)) NEAREST_INDEX_ = 1 + if (rval > array(ia)) NEAREST_INDEX_ = ia else i = 1 keep_going = .true. do while (i <= ia .and. keep_going) i = i+1 - if (value <= array(i)) then + if (rval <= array(i)) then NEAREST_INDEX_ = i - if (array(i)-value > value-array(i-1)) NEAREST_INDEX_ = i-1 + if (array(i)-rval > rval-array(i-1)) NEAREST_INDEX_ = i-1 keep_going = .false. endif enddo diff --git a/column_diagnostics/column_diagnostics.F90 b/column_diagnostics/column_diagnostics.F90 index b75ffd3698..b7a3eb6874 100644 --- a/column_diagnostics/column_diagnostics.F90 +++ b/column_diagnostics/column_diagnostics.F90 @@ -129,7 +129,7 @@ subroutine column_diagnostics_init !-------------------------------------------------------------------- ! local variables: ! - integer :: unit !< unit number for nml file + integer :: iunit !< unit number for nml file integer :: ierr !< error return flag integer :: io !< error return code @@ -164,8 +164,8 @@ subroutine column_diagnostics_init !--------------------------------------------------------------------- call write_version_number("COLUMN_DIAGNOSTICS_MOD", version) if (mpp_pe() == mpp_root_pe()) then - unit = stdlog() - write (unit, nml=column_diagnostics_nml) + iunit = stdlog() + write (iunit, nml=column_diagnostics_nml) endif !-------------------------------------------------------------------- module_is_initialized = .true. diff --git a/configure.ac b/configure.ac index 65e3c0fe73..223733b9f9 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.04.00-dev], [gfdl.climate.model.info@noaa.gov], [FMS], [https://www.github.com/NOAA-GFDL/FMS]) diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index 663d2b0fcf..aa2df0d0c2 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -44,8 +44,9 @@ use mpp_domains_mod, only : domainUG, mpp_pass_SG_to_UG, mpp_get_UG_SG_domain, N use time_manager_mod, only: time_type use fms2_io_mod, only : FmsNetcdfFile_t, open_file, close_file, & read_data, fms2_io_init, variable_exists, & - get_mosaic_tile_file + get_mosaic_tile_file, file_exists use get_grid_version_mod, only: get_grid_version_1, get_grid_version_2 +use fms_string_utils_mod, only: string implicit none private @@ -103,11 +104,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 +115,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_, & @@ -147,7 +145,7 @@ subroutine DATA_OVERRIDE_INIT_IMPL_(Atm_domain_in, Ocean_domain_in, Ice_domain_i character(len=128) :: grid_file = 'INPUT/grid_spec.nc' integer :: is,ie,js,je,use_get_grid_version - integer :: i, unit, io_status, ierr + integer :: i, iunit, io_status, ierr logical :: atm_on, ocn_on, lnd_on, ice_on, lndUG_on logical :: file_open type(FmsNetcdfFile_t) :: fileobj @@ -156,8 +154,8 @@ subroutine DATA_OVERRIDE_INIT_IMPL_(Atm_domain_in, Ocean_domain_in, Ice_domain_i read (input_nml_file, data_override_nml, iostat=io_status) ierr = check_nml_error(io_status, 'data_override_nml') - unit = stdlog() - write(unit, data_override_nml) + iunit = stdlog() + write(iunit, data_override_nml) ! grid_center_bug is no longer supported. if (grid_center_bug) then @@ -166,6 +164,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 +201,33 @@ endif default_table%interpol_method = 'bilinear' #ifdef use_yaml - call read_table_yaml(data_table) + if (use_data_table_yaml) then + if (file_exists("data_table")) & + call mpp_error(FATAL, "You cannot have the legacy data_table if use_data_table_yaml=.true.") + call read_table_yaml(data_table) + else + if (file_exists("data_table.yaml"))& + call mpp_error(FATAL, "You cannot have the yaml data_table if use_data_table_yaml=.false.") + 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 (file_exists("data_table.yaml"))& + call mpp_error(FATAL, "You cannot have the yaml data_table if use_data_table_yaml=.false.") + + if (use_data_table_yaml) then + call mpp_error(FATAL, "You cannot have use_data_table_yaml=.true. without compiling 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 +355,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,9 +499,10 @@ 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 +!> @brief Read and parse the data_table.yaml subroutine read_table_yaml(data_table) - type(data_type), dimension(:), allocatable, intent(out) :: data_table + type(data_type), dimension(:), allocatable, intent(out) :: data_table !< Contents of the data_table.yaml integer, allocatable :: entry_id(:) integer :: nentries @@ -496,6 +521,7 @@ subroutine read_table_yaml(data_table) do i = 1, nentries call get_value_from_key(file_id, entry_id(i), "gridname", data_table(i)%gridname) + call check_for_valid_gridname(data_table(i)%gridname) call get_value_from_key(file_id, entry_id(i), "fieldname_code", data_table(i)%fieldname_code) data_table(i)%fieldname_file = "" @@ -509,28 +535,98 @@ subroutine read_table_yaml(data_table) data_table(i)%interpol_method = "none" call get_value_from_key(file_id, entry_id(i), "interpol_method", data_table(i)%interpol_method, & & is_optional=.true.) + call check_interpol_method(data_table(i)%interpol_method, data_table(i)%file_name, & + data_table(i)%fieldname_file) call get_value_from_key(file_id, entry_id(i), "factor", data_table(i)%factor) + buffer = "" call get_value_from_key(file_id, entry_id(i), "region_type", buffer, is_optional=.true.) - - if(trim(buffer) == "inside_region" ) then - data_table(i)%region_type = INSIDE_REGION - else if( trim(buffer) == "outside_region" ) then - data_table(i)%region_type = OUTSIDE_REGION - else - data_table(i)%region_type = NO_REGION - endif - - call get_value_from_key(file_id, entry_id(i), "lon_start", data_table(i)%lon_start, is_optional=.true.) - call get_value_from_key(file_id, entry_id(i), "lon_end", data_table(i)%lon_end, is_optional=.true.) - call get_value_from_key(file_id, entry_id(i), "lat_start", data_table(i)%lat_start, is_optional=.true.) - call get_value_from_key(file_id, entry_id(i), "lat_end", data_table(i)%lat_end, is_optional=.true.) - + call check_and_set_region_type(buffer, data_table(i)%region_type) + + if (data_table(i)%region_type .ne. NO_REGION) then + call get_value_from_key(file_id, entry_id(i), "lon_start", data_table(i)%lon_start, is_optional=.true.) + call get_value_from_key(file_id, entry_id(i), "lon_end", data_table(i)%lon_end, is_optional=.true.) + call get_value_from_key(file_id, entry_id(i), "lat_start", data_table(i)%lat_start, is_optional=.true.) + call get_value_from_key(file_id, entry_id(i), "lat_end", data_table(i)%lat_end, is_optional=.true.) + call check_valid_lat_lon(data_table(i)%lon_start, data_table(i)%lon_end, & + data_table(i)%lat_start, data_table(i)%lat_end) + endif end do end if table_size = nentries !< Because one variable is not enough end subroutine read_table_yaml + +!> @brief Check if a grid name is valid, crashes if it is not +subroutine check_for_valid_gridname(gridname) + character(len=*), intent(in) :: gridname !< Gridname + + select case(trim(gridname)) + case ("OCN", "ATM", "LND", "ICE") + case default + call mpp_error(FATAL, trim(gridname)//" is not a valid gridname. "//& + "The acceptable values are OCN ATM LND and ICE. Check your data_table.yaml") + end select +end subroutine check_for_valid_gridname + +!> @brief Check if the interpol method is correct, crashes if it is not +subroutine check_interpol_method(interp_method, filename, fieldname) + character(len=*), intent(in) :: interp_method !< The interpo_method + character(len=*), intent(in) :: filename !< The filename + character(len=*), intent(in) :: fieldname !< The fieldname in the file + + select case(trim(interp_method)) + case ("bicubic", "bilinear") + if (trim(filename) .eq. "" .or. trim(fieldname) .eq. "") call mpp_error(FATAL, & + "The file_name and the fieldname_file must be set if using the bicubic or bilinear interpolation method."//& + " Check your data_table.yaml") + case ("none") + if (trim(filename) .ne. "" ) then + if (trim(fieldname) .eq. "") call mpp_error(FATAL, & + "If the interpol_method is none and file_name is specified (ongrid case), "//& + "you must also specify the fieldname_file") + endif + case default + call mpp_error(FATAL, trim(interp_method)//" is not a valid interp method. "//& + "The acceptable values are bilinear and bicubic") + end select +end subroutine check_interpol_method + +!> @brief Check if a region_type is valid, crashes if it is not. Otherwise it sets the +!! correct integer parameter. +subroutine check_and_set_region_type(region_type_str, region_type_int) + character(len=*), intent(in) :: region_type_str !< The region type as defined in the data.yaml + integer, intent(out) :: region_type_int !< The region type as an integer parameter + + select case(trim(region_type_str)) + case ("inside_region") + region_type_int = INSIDE_REGION + case ("outside_region") + region_type_int = OUTSIDE_REGION + case ("") + region_type_int = NO_REGION + case default + call mpp_error(FATAL, trim(region_type_str)//" is not a valid region type. "//& + "The acceptable values are inside_region and outside_regioon. Check your data_table.yaml") + end select +end subroutine check_and_set_region_type + +!> @brief Check if a region lon_start, lon_end, lat_start and lat_end is valid. +!! Crashes if it is not. +subroutine check_valid_lat_lon(lon_start, lon_end, lat_start, lat_end) + real(FMS_DATA_OVERRIDE_KIND_), intent(in) :: lon_start !< Starting longitude of the data_override region + real(FMS_DATA_OVERRIDE_KIND_), intent(in) :: lon_end !< Ending longitude of the data_override region + real(FMS_DATA_OVERRIDE_KIND_), intent(in) :: lat_start !< Starting lattiude of the data_override region + real(FMS_DATA_OVERRIDE_KIND_), intent(in) :: lat_end !< Ending lattiude of the data_override region + + if (lon_start > lon_end) call mpp_error(FATAL, & + "lon_start:"//string(lon_start)//" is greater than lon_end"//string(lon_end)//& + ". Check your data_table.yaml.") + + if (lat_start > lat_end) call mpp_error(FATAL, & + "lat_start:"//string(lat_start)//" is greater than lat_end:"//string(lat_end)//& + ". Check your data_table.yaml.") +end subroutine check_valid_lat_lon #endif subroutine DATA_OVERRIDE_UNSET_ATM_ @@ -603,13 +699,13 @@ end subroutine get_domainUG !=============================================================================================== !> @brief Routine to perform data override for scalar fields -subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data,time,override,data_index) +subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data_out,time,override,data_index) character(len=3), intent(in) :: gridname !< model grid ID (ocn,ice,atm,lnd) character(len=*), intent(in) :: fieldname_code !< field name as used in the model (may be !! different from the name in NetCDF data file) logical, intent(out), optional :: override !< true if the field has been overriden succesfully type(time_type), intent(in) :: time !< (target) model time - real(FMS_DATA_OVERRIDE_KIND_), intent(out) :: data !< output data array returned by this call + real(FMS_DATA_OVERRIDE_KIND_), intent(out) :: data_out !< output data array returned by this call integer, intent(in), optional :: data_index character(len=512) :: filename !< file containing source data @@ -646,7 +742,7 @@ subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data,time,override,data_ind factor = data_table(index1)%factor if(fieldname == "") then - data = factor + data_out = factor if(PRESENT(override)) override = .true. return else @@ -681,8 +777,8 @@ subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data,time,override,data_ind endif !if curr_position < 0 !10 do time interp to get data in compute_domain - call time_interp_external(id_time, time, data, verbose=.false.) - data = data*factor + call time_interp_external(id_time, time, data_out, verbose=.false.) + data_out = data_out*factor !$OMP END SINGLE if(PRESENT(override)) override = .true. @@ -722,13 +818,13 @@ subroutine DATA_OVERRIDE_2D_(gridname,fieldname,data_2D,time,override, is_in, ie end subroutine DATA_OVERRIDE_2D_ !> @brief This routine performs data override for 3D fields -subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_index, is_in, ie_in, js_in, je_in) +subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,return_data,time,override,data_index, is_in, ie_in, js_in, je_in) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname_code !< field name as used in the model logical, optional, intent(out) :: override !< true if the field has been overriden succesfully type(time_type), intent(in) :: time !< (target) model time integer, optional, intent(in) :: data_index - real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:,:), intent(inout) :: data !< data returned by this call + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:,:), intent(inout) :: return_data !< data returned by this call integer, optional, intent(in) :: is_in, ie_in, js_in, je_in logical, dimension(:,:,:), allocatable :: mask_out @@ -795,7 +891,7 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind factor = data_table(index1)%factor if(fieldname == "") then - data = factor + return_data = factor if(PRESENT(override)) override = .true. return else @@ -837,23 +933,25 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind override_array(curr_position)%numthreads = omp_get_num_threads() #endif !--- data_override may be called from physics windows. The following are possible situations -!--- 1. size(data,1) == nxd and size(data,2) == nyd ( on data domain and there is only one window). -!--- 2. nxc is divisible by size(data,1), nyc is divisible by size(data,2), -!--- nwindow = (nxc/size(data(1))*(nyc/size(data,2)), also we require nwindows is divisible by nthreads. -!--- The another restrition is that size(data,1) == ie_in - is_in + 1, -!--- size(data,2) == je_in - js_in + 1 +!--- 1. size(return_data,1) == nxd and size(return_data,2) == nyd +!--- (on return_data domain and there is only one window). +!--- 2. nxc is divisible by size(return_data,1), nyc is divisible by size(return_data,2), +!--- nwindow = (nxc/size(return_data(1))*(nyc/size(return_data,2)), +!--- also we require nwindows is divisible by nthreads. +!--- The another restrition is that size(return_data,1) == ie_in - is_in + 1, +!--- size(return_data,2) == je_in - js_in + 1 nwindows = 1 - if( nxd == size(data,1) .AND. nyd == size(data,2) ) then ! + if( nxd == size(return_data,1) .AND. nyd == size(return_data,2) ) then ! use_comp_domain = .false. - else if ( mod(nxc, size(data,1)) ==0 .AND. mod(nyc, size(data,2)) ==0 ) then + else if ( mod(nxc, size(return_data,1)) ==0 .AND. mod(nyc, size(return_data,2)) ==0 ) then use_comp_domain = .true. - nwindows = (nxc/size(data,1))*(nyc/size(data,2)) + nwindows = (nxc/size(return_data,1))*(nyc/size(return_data,2)) else call mpp_error(FATAL, & & "data_override: data is not on data domain and compute domain is not divisible by size(data)") endif - override_array(curr_position)%window_size(1) = size(data,1) - override_array(curr_position)%window_size(2) = size(data,2) + override_array(curr_position)%window_size(1) = size(return_data,1) + override_array(curr_position)%window_size(2) = size(return_data,2) window_size = override_array(curr_position)%window_size override_array(curr_position)%numwindows = nwindows @@ -999,7 +1097,7 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind je_src = override_array(curr_position)%je_src window_size = override_array(curr_position)%window_size !---make sure data size match window_size - if( window_size(1) .NE. size(data,1) .OR. window_size(2) .NE. size(data,2) ) then + if( window_size(1) .NE. size(return_data,1) .OR. window_size(2) .NE. size(return_data,2) ) then call mpp_error(FATAL, "data_override: window_size does not match size(data)") endif !9 Get id_time previously stored in override_array @@ -1071,92 +1169,92 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind ! Determine if data in netCDF file is 2D or not data_file_is_2D = .false. - if((dims(3) == 1) .and. (size(data,3)>1)) data_file_is_2D = .true. + if((dims(3) == 1) .and. (size(return_data,3)>1)) data_file_is_2D = .true. - if(dims(3) .NE. 1 .and. (size(data,3) .NE. dims(3))) & - call mpp_error(FATAL, "data_override: dims(3) .NE. 1 and size(data,3) .NE. dims(3)") + if(dims(3) .NE. 1 .and. (size(return_data,3) .NE. dims(3))) & + call mpp_error(FATAL, "data_override: dims(3) .NE. 1 and size(return_data,3) .NE. dims(3)") if(ongrid) then if (.not. use_comp_domain) then !< Determine the size of the halox and the part of `data` that is in the compute domain - nhalox = (size(data,1) - nxc)/2 - nhaloy = (size(data,2) - nyc)/2 - startingi = lbound(data,1) + nhalox - startingj = lbound(data,2) + nhaloy - endingi = ubound(data,1) - nhalox - endingj = ubound(data,2) - nhaloy + nhalox = (size(return_data,1) - nxc)/2 + nhaloy = (size(return_data,2) - nyc)/2 + startingi = lbound(return_data,1) + nhalox + startingj = lbound(return_data,2) + nhaloy + endingi = ubound(return_data,1) - nhalox + endingj = ubound(return_data,2) - nhaloy end if !10 do time interp to get data in compute_domain if(data_file_is_2D) then if (use_comp_domain) then - call time_interp_external(id_time,time,data(:,:,1),verbose=.false., & + call time_interp_external(id_time,time,return_data(:,:,1),verbose=.false., & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) else !> If this in an ongrid case and you are not in the compute domain, send in `data` to be the correct !! size - call time_interp_external(id_time,time,data(startingi:endingi,startingj:endingj,1),verbose=.false., & + call time_interp_external(id_time,time,return_data(startingi:endingi,startingj:endingj,1),verbose=.false., & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) end if - data(:,:,1) = data(:,:,1)*factor - do i = 2, size(data,3) - data(:,:,i) = data(:,:,1) + return_data(:,:,1) = return_data(:,:,1)*factor + do i = 2, size(return_data,3) + return_data(:,:,i) = return_data(:,:,1) end do else if (use_comp_domain) then - call time_interp_external(id_time,time,data,verbose=.false., & + call time_interp_external(id_time,time,return_data,verbose=.false., & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) else !> If this in an ongrid case and you are not in the compute domain, send in `data` to be the correct !! size - call time_interp_external(id_time,time,data(startingi:endingi,startingj:endingj,:),verbose=.false., & + call time_interp_external(id_time,time,return_data(startingi:endingi,startingj:endingj,:),verbose=.false., & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) end if - data = data*factor + return_data = return_data*factor endif else ! off grid case ! do time interp to get global data if(data_file_is_2D) then if( data_table(index1)%region_type == NO_REGION ) then - call time_interp_external(id_time,time,data(:,:,1),verbose=.false., & + call time_interp_external(id_time,time,return_data(:,:,1),verbose=.false., & horz_interp=override_array(curr_position)%horz_interp(window_id), & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - data(:,:,1) = data(:,:,1)*factor - do i = 2, size(data,3) - data(:,:,i) = data(:,:,1) + return_data(:,:,1) = return_data(:,:,1)*factor + do i = 2, size(return_data,3) + return_data(:,:,i) = return_data(:,:,1) enddo else - allocate(mask_out(size(data,1), size(data,2),1)) + allocate(mask_out(size(return_data,1), size(return_data,2),1)) mask_out = .false. - call time_interp_external(id_time,time,data(:,:,1),verbose=.false., & + call time_interp_external(id_time,time,return_data(:,:,1),verbose=.false., & horz_interp=override_array(curr_position)%horz_interp(window_id), & mask_out =mask_out(:,:,1), & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) where(mask_out(:,:,1)) - data(:,:,1) = data(:,:,1)*factor + return_data(:,:,1) = return_data(:,:,1)*factor end where - do i = 2, size(data,3) + do i = 2, size(return_data,3) where(mask_out(:,:,1)) - data(:,:,i) = data(:,:,1) + return_data(:,:,i) = return_data(:,:,1) end where enddo deallocate(mask_out) endif else if( data_table(index1)%region_type == NO_REGION ) then - call time_interp_external(id_time,time,data,verbose=.false., & + call time_interp_external(id_time,time,return_data,verbose=.false., & horz_interp=override_array(curr_position)%horz_interp(window_id), & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - data = data*factor + return_data = return_data*factor else - allocate(mask_out(size(data,1), size(data,2), size(data,3)) ) + allocate(mask_out(size(return_data,1), size(return_data,2), size(return_data,3)) ) mask_out = .false. - call time_interp_external(id_time,time,data,verbose=.false., & + call time_interp_external(id_time,time,return_data,verbose=.false., & horz_interp=override_array(curr_position)%horz_interp(window_id), & mask_out =mask_out, & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) where(mask_out) - data = data*factor + return_data = return_data*factor end where deallocate(mask_out) endif @@ -1168,10 +1266,10 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind end subroutine DATA_OVERRIDE_3D_ !> @brief Data override for 1D unstructured grids -subroutine DATA_OVERRIDE_UG_1D_(gridname,fieldname,data,time,override) +subroutine DATA_OVERRIDE_UG_1D_(gridname,fieldname,return_data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override - real(FMS_DATA_OVERRIDE_KIND_), dimension(:), intent(inout) :: data !< data returned by this call + real(FMS_DATA_OVERRIDE_KIND_), dimension(:), intent(inout) :: return_data !< data returned by this call type(time_type), intent(in) :: time !< model time logical, intent(out), optional :: override !< true if the field has been overriden succesfully !local vars @@ -1197,16 +1295,16 @@ subroutine DATA_OVERRIDE_UG_1D_(gridname,fieldname,data,time,override) call DATA_OVERRIDE_2D_(gridname,fieldname,data_SG,time,override) - call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:), data(:)) + call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:), return_data(:)) deallocate(data_SG) end subroutine DATA_OVERRIDE_UG_1D_ !> @brief Data override for 2D unstructured grids -subroutine DATA_OVERRIDE_UG_2D_(gridname,fieldname,data,time,override) +subroutine DATA_OVERRIDE_UG_2D_(gridname,fieldname,return_data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override - real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), intent(inout) :: data !< data returned by this call + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), intent(inout) :: return_data !< data returned by this call type(time_type), intent(in) :: time !< model time logical, intent(out), optional :: override !< true if the field has been overriden succesfully !local vars @@ -1228,18 +1326,18 @@ subroutine DATA_OVERRIDE_UG_2D_(gridname,fieldname,data,time,override) enddo if(index1 .eq. -1) return ! NO override was performed - nlevel = size(data,2) + nlevel = size(return_data,2) nlevel_max = nlevel call mpp_max(nlevel_max) call get_domainUG(gridname,UG_domain,comp_domain) allocate(data_SG(comp_domain(1):comp_domain(2),comp_domain(3):comp_domain(4),nlevel_max)) - allocate(data_UG(size(data,1), nlevel_max)) + allocate(data_UG(size(return_data,1), nlevel_max)) data_SG = 0._lkind call DATA_OVERRIDE_3D_(gridname,fieldname,data_SG,time,override) call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:,:), data_UG(:,:)) - data(:,1:nlevel) = data_UG(:,1:nlevel) + return_data(:,1:nlevel) = data_UG(:,1:nlevel) deallocate(data_SG, data_UG) end subroutine DATA_OVERRIDE_UG_2D_ diff --git a/diag_integral/diag_integral.F90 b/diag_integral/diag_integral.F90 index 45deb4c446..ed898a52d3 100644 --- a/diag_integral/diag_integral.F90 +++ b/diag_integral/diag_integral.F90 @@ -1043,30 +1043,30 @@ end function diag_integral_alarm !! Template: !! !! @code{.f90} -!! data2 = vert_diag_integral (data, wt) +!! data2 = vert_diag_integral (field_data, wt) !! @endcode !! !! Parameters: !! !! @code{.f90} -!! real, dimension (:,:,:), intent(in) :: data, wt -!! real, dimension (size(data,1),size(data,2)) :: data2 +!! real, dimension (:,:,:), intent(in) :: field_data, wt +!! real, dimension (size(field_data,1),size(field_data,2)) :: data2 !! @endcode !! -!! @param [in] integral field data arrays +!! @param [in] integral field data arrays !! @param [in] integral field weighting functions !! @param [out] !! @return real array data2 -function vert_diag_integral (data, wt) result (data2) -real(r8_kind), dimension (:,:,:), intent(in) :: data !< integral field data arrays +function vert_diag_integral (field_data, wt) result (data2) +real(r8_kind), dimension (:,:,:), intent(in) :: field_data !< integral field data arrays real(r8_kind), dimension (:,:,:), intent(in) :: wt !< integral field weighting functions -real(r8_kind), dimension (size(data,1),size(data,2)) :: data2 +real(r8_kind), dimension (size(field_data,1),size(field_data,2)) :: data2 !------------------------------------------------------------------------------- ! local variables: ! wt2 !------------------------------------------------------------------------------- - real, dimension(size(data,1),size(data,2)) :: wt2 + real, dimension(size(field_data,1),size(field_data,2)) :: wt2 !------------------------------------------------------------------------------- wt2 = sum(wt,3) @@ -1074,7 +1074,7 @@ function vert_diag_integral (data, wt) result (data2) call error_mesg ('diag_integral_mod', & 'vert sum of weights equals zero', FATAL) endif - data2 = sum(data*wt,3) / wt2 + data2 = sum(field_data*wt,3) / wt2 end function vert_diag_integral diff --git a/diag_integral/include/diag_integral.inc b/diag_integral/include/diag_integral.inc index a407b49796..200819c171 100644 --- a/diag_integral/include/diag_integral.inc +++ b/diag_integral/include/diag_integral.inc @@ -31,25 +31,25 @@ !! Template: !! !! @code{.f90} -!! call sum_field_2d (name, data, is, js) +!! call sum_field_2d (name, field_data2d, is, js) !! @endcode !! !! Parameters: !! !! @code{.f90} !! character(len=*), intent(in) :: name -!! real, intent(in) :: data(:,:) +!! real, intent(in) :: field_data2d(:,:) !! integer, optional, intent(in) :: is, js !! @endcode !! !! @param [in] Name of the field to be integrated -!! @param [in] field of integrands to be summed over +!! @param [in] field of integrands to be summed over !! @param [in] starting i,j indices over which summation is to occur !! -subroutine SUM_FIELD_2D_ (name, data, is, js) +subroutine SUM_FIELD_2D_ (name, field_data2d, is, js) character(len=*), intent(in) :: name !< Name of the field to be integrated -real(FMS_DI_KIND_), intent(in) :: data(:,:) !< field of integrands to be summed over +real(FMS_DI_KIND_), intent(in) :: field_data2d(:,:) !< field of integrands to be summed over integer, optional, intent(in) :: is !< starting i indices over which summation is to occur integer, optional, intent(in) :: js !< starting j indices over which summation is to occur @@ -90,8 +90,8 @@ integer, optional, intent(in) :: js !< starting j indices over which summation i !------------------------------------------------------------------------------- i1 = 1; if (present(is)) i1 = is j1 = 1; if (present(js)) j1 = js - i2 = i1 + size(data,1) - 1 - j2 = j1 + size(data,2) - 1 + i2 = i1 + size(field_data2d,1) - 1 + j2 = j1 + size(field_data2d,2) - 1 !------------------------------------------------------------------------------- ! increment the count of points toward this integral and add the @@ -99,9 +99,9 @@ integer, optional, intent(in) :: js !< starting j indices over which summation i !------------------------------------------------------------------------------- !$OMP CRITICAL field_count (field) = field_count(field) + & - size(data,1)*size(data,2) + size(field_data2d,1)*size(field_data2d,2) field_sum (field) = field_sum (field) + & - sum (real(data,r8_kind) * area(i1:i2,j1:j2)) + sum (real(field_data2d,r8_kind) * area(i1:i2,j1:j2)) !$OMP END CRITICAL @@ -117,25 +117,25 @@ end subroutine SUM_FIELD_2D_ !! Template: !! !! @code{.f90} -!! call sum_field_3d (name, data, is, js) +!! call sum_field_3d (name, field_data3d, is, js) !! @endcode !! !! Parameters: !! !! @code{.f90} !! character(len=*), intent(in) :: name -!! real, intent(in) :: data(:,:,:) +!! real, intent(in) :: field_data3d(:,:,:) !! integer, optional, intent(in) :: is, js !! @endcode !! !! @param [in] Name of the field to be integrated -!! @param [in] field of integrands to be summed over +!! @param [in] field of integrands to be summed over !! @param [in] starting i,j indices over which summation is to occur !! -subroutine SUM_FIELD_3D_ (name, data, is, js) +subroutine SUM_FIELD_3D_ (name, field_data3d, is, js) character(len=*), intent(in) :: name !< Name of the field to be integrated -real(FMS_DI_KIND_), intent(in) :: data(:,:,:) !< field of integrands to be summed over +real(FMS_DI_KIND_), intent(in) :: field_data3d(:,:,:) !< field of integrands to be summed over integer, optional, intent(in) :: is !< starting i,j indices over which summation is to occur integer, optional, intent(in) :: js !< starting i,j indices over which summation is to occur @@ -146,8 +146,8 @@ integer, optional, intent(in) :: js !< starting i,j indices over which summation ! i1, j1, i2, j2 ! location indices of current data in ! processor-global coordinates !------------------------------------------------------------------------------- - real(r8_kind), dimension (size(data,1), & - size(data,2)) :: data2 + real(r8_kind), dimension (size(field_data3d,1), & + size(field_data3d,2)) :: data2 integer :: field !< index of desired integral integer :: i1 !< location indices of current data in @@ -183,8 +183,8 @@ integer, optional, intent(in) :: js !< starting i,j indices over which summation !------------------------------------------------------------------------------- i1 = 1; if (present(is)) i1 = is j1 = 1; if (present(js)) j1 = js - i2 = i1 + size(data,1) - 1 - j2 = j1 + size(data,2) - 1 + i2 = i1 + size(field_data3d,1) - 1 + j2 = j1 + size(field_data3d,2) - 1 !------------------------------------------------------------------------------- ! increment the count of points toward this integral. sum first @@ -193,8 +193,8 @@ integer, optional, intent(in) :: js !< starting i,j indices over which summation !------------------------------------------------------------------------------- !$OMP CRITICAL field_count (field) = field_count (field) + & - size(data,1)*size(data,2) - data2 = sum(real(data,r8_kind),3) + size(field_data3d,1)*size(field_data3d,2) + data2 = sum(real(field_data3d,r8_kind),3) field_sum (field) = field_sum (field) + & sum (data2 * area(i1:i2,j1:j2)) @@ -212,26 +212,26 @@ end subroutine SUM_FIELD_3D_ !! Template: !! !! @code{.f90} -!! call sum_field_wght_3d (name, data, wt, is, js) +!! call sum_field_wght_3d (name, field_data3d, wt, is, js) !! @endcode !! !! Parameters: !! !! @code{.f90} !! character(len=*), intent(in) :: name -!! real, intent(in) :: data(:,:,:), wt(:,:,:) +!! real, intent(in) :: field_data3d(:,:,:), wt(:,:,:) !! integer, optional, intent(in) :: is, js !! @endcode !! !! @param [in] Name of the field to be integrated -!! @param [in] field of integrands to be summed over +!! @param [in] field of integrands to be summed over !! @param [in] the weight function to be evaluated at summation !! @param [in] starting i,j indices over which summation is to occur !! -subroutine SUM_FIELD_WGHT_3D_ (name, data, wt, is, js) +subroutine SUM_FIELD_WGHT_3D_ (name, field_data3d, wt, is, js) character(len=*), intent(in) :: name !< Name of the field to be integrated -real(FMS_DI_KIND_), intent(in) :: data(:,:,:) !< field of integrands to be summed over +real(FMS_DI_KIND_), intent(in) :: field_data3d(:,:,:) !< field of integrands to be summed over real(FMS_DI_KIND_), intent(in) :: wt(:,:,:) !< the weight function to be evaluated at summation integer, optional, intent(in) :: is !< starting i indices over which summation is to occur integer, optional, intent(in) :: js !< starting j indices over which summation is to occur @@ -243,7 +243,7 @@ integer, optional, intent(in) :: js !< starting j indices over which summation ! i1, j1, i2, j2 ! location indices of current data in ! processor-global coordinates !------------------------------------------------------------------------------- - real(r8_kind), dimension (size(data,1),size(data,2)) :: data2 + real(r8_kind), dimension (size(field_data3d,1),size(field_data3d,2)) :: data2 integer :: field !< index of desired integral integer :: i1 !< location indices of current data in !! processor-global coordinates @@ -277,8 +277,8 @@ integer, optional, intent(in) :: js !< starting j indices over which summation !------------------------------------------------------------------------------- i1 = 1; if (present(is)) i1 = is j1 = 1; if (present(js)) j1 = js - i2 = i1 + size(data,1) - 1 - j2 = j1 + size(data,2) - 1 + i2 = i1 + size(field_data3d,1) - 1 + j2 = j1 + size(field_data3d,2) - 1 !------------------------------------------------------------------------------- ! increment the count of points toward this integral. sum first @@ -288,8 +288,8 @@ integer, optional, intent(in) :: js !< starting j indices over which summation !------------------------------------------------------------------------------- !$OMP CRITICAL field_count (field) = field_count (field) + & - size(data,1)*size(data,2) - data2 = vert_diag_integral (real(data,r8_kind), real(wt,r8_kind)) + size(field_data3d,1)*size(field_data3d,2) + data2 = vert_diag_integral (real(field_data3d,r8_kind), real(wt,r8_kind)) field_sum(field) = field_sum (field) + & sum (data2 * area(i1:i2,j1:j2)) @@ -307,26 +307,26 @@ end subroutine SUM_FIELD_WGHT_3D_ !! Template: !! !! @code{.f90} -!! call sum_field_2d_hemi (name, data, is, ie, js, je) +!! call sum_field_2d_hemi (name, field_data2d, is, ie, js, je) !! @endcode !! !! Parameters: !! !! @code{.f90} !! character(len=*), intent(in) :: name -!! real, intent(in) :: data(:,:) +!! real, intent(in) :: field_data2d(:,:) !! integer, intent(in) :: is, js, ie, je !! @endcode !! !! @param [in] Name of the field to be integrated -!! @param [in] field of integrands to be summed over +!! @param [in] field of integrands to be summed over !! @param [in] starting/ending i,j indices over which summation !! is to occur !! -subroutine SUM_FIELD_2D_HEMI_ (name, data, is, ie, js, je) +subroutine SUM_FIELD_2D_HEMI_ (name, field_data2d, is, ie, js, je) character(len=*), intent(in) :: name !< Name of the field to be integrated -real(FMS_DI_KIND_),intent(in) :: data(:,:) !< field of integrands to be summed over +real(FMS_DI_KIND_),intent(in) :: field_data2d(:,:) !< field of integrands to be summed over integer, intent(in) :: is !< starting/ending i,j indices over which summation !! is to occur integer, intent(in) :: js !< starting/ending i,j indices over which summation @@ -374,14 +374,14 @@ integer, intent(in) :: je !< starting/ending i,j indices over which su ! is needed to handle case of 2d domain decomposition with physics ! window smaller than processor domain size. !------------------------------------------------------------------------------- - i1 = mod ( (is-1), size(data,1) ) + 1 - i2 = i1 + size(data,1) - 1 + i1 = mod ( (is-1), size(field_data2d,1) ) + 1 + i2 = i1 + size(field_data2d,1) - 1 !------------------------------------------------------------------------------- ! for a hemispheric sum, sum one jrow at a time in case a processor ! has data from both hemispheres. !------------------------------------------------------------------------------- - j1 = mod ( (js-1) ,size(data,2) ) + 1 + j1 = mod ( (js-1) ,size(field_data2d,2) ) + 1 j2 = j1 !------------------------------------------------------------------------------- @@ -392,7 +392,7 @@ integer, intent(in) :: je !< starting/ending i,j indices over which su !$OMP CRITICAL field_count (field) = field_count (field) + 2* (i2-i1+1)*(j2-j1+1) field_sum (field) = field_sum (field) + & - sum ( real(data(i1:i2,j1:j2),r8_kind) * area(is:ie,js:je)) + sum ( real(field_data2d(i1:i2,j1:j2),r8_kind) * area(is:ie,js:je)) !$OMP END CRITICAL diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90 index 7eb5eaf686..606ebd76f2 100644 --- a/diag_manager/diag_axis.F90 +++ b/diag_manager/diag_axis.F90 @@ -105,10 +105,10 @@ MODULE diag_axis_mod !! increments the axis counter and fills in the axes !! !! @return integer axis ID - INTEGER FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, direction,& + INTEGER FUNCTION diag_axis_init(name, array_data, units, cart_name, long_name, direction,& & set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position ) CHARACTER(len=*), INTENT(in) :: name !< Short name for axis - CLASS(*), DIMENSION(:), INTENT(in) :: DATA !< Array of coordinate values + CLASS(*), DIMENSION(:), INTENT(in) :: array_data !< Array of coordinate values CHARACTER(len=*), INTENT(in) :: units !< Units for the axis CHARACTER(len=*), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T") CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis. @@ -220,17 +220,17 @@ INTEGER FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, directi IF ( Axes(diag_axis_init)%cart_name == 'T' ) THEN axlen = 0 ELSE - axlen = SIZE(DATA(:)) + axlen = SIZE(array_data(:)) END IF - ALLOCATE ( Axes(diag_axis_init)%data(1:axlen) ) + ALLOCATE ( Axes(diag_axis_init)%diag_type_data(1:axlen) ) ! Initialize Axes(diag_axis_init) Axes(diag_axis_init)%name = TRIM(name) - SELECT TYPE (DATA) + SELECT TYPE (array_data) TYPE IS (real(kind=r4_kind)) - Axes(diag_axis_init)%data = DATA(1:axlen) + Axes(diag_axis_init)%diag_type_data = array_data(1:axlen) TYPE IS (real(kind=r8_kind)) - Axes(diag_axis_init)%data = real(DATA(1:axlen)) + Axes(diag_axis_init)%diag_type_data = real(array_data(1:axlen)) CLASS DEFAULT CALL error_mesg('diag_axis_mod::diag_axis_init',& & 'The axis data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -455,7 +455,7 @@ INTEGER FUNCTION diag_subaxes_init(axis, subdata, start_indx, end_indx, domain_2 END FUNCTION diag_subaxes_init !> @brief Return information about the axis with index ID SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,& - & direction, edges, Domain, DomainU, DATA, num_attributes, attributes, domain_position) + & direction, edges, Domain, DomainU, array_data, num_attributes, attributes, domain_position) CHARACTER(len=*), INTENT(out) :: name, units, long_name, cart_name INTEGER, INTENT(in) :: id !< Axis ID TYPE(domain1d), INTENT(out) :: Domain @@ -463,7 +463,7 @@ SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,& INTEGER, INTENT(out) :: direction !< Direction of data. (See @ref diag_axis_init for a description of !! allowed values) INTEGER, INTENT(out) :: edges !< Axis ID for the previously defined "edges axis". - CLASS(*), DIMENSION(:), INTENT(out) :: DATA !< Array of coordinate values for this axis. + CLASS(*), DIMENSION(:), INTENT(out) :: array_data !< Array of coordinate values for this axis. INTEGER, INTENT(out), OPTIONAL :: num_attributes TYPE(diag_atttype), ALLOCATABLE, DIMENSION(:), INTENT(out), OPTIONAL :: attributes INTEGER, INTENT(out), OPTIONAL :: domain_position @@ -480,15 +480,15 @@ SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,& Domain = Axes(id)%Domain DomainU = Axes(id)%DomainUG if (present(domain_position)) domain_position = Axes(id)%domain_position - IF ( Axes(id)%length > SIZE(DATA(:)) ) THEN + IF ( Axes(id)%length > SIZE(array_data(:)) ) THEN ! array data is too small. CALL error_mesg('diag_axis_mod::get_diag_axis', 'array data is too small', FATAL) ELSE - SELECT TYPE (DATA) + SELECT TYPE (array_data) TYPE IS (real(kind=r4_kind)) - DATA(1:Axes(id)%length) = real(Axes(id)%data(1:Axes(id)%length), kind=r4_kind) + array_data(1:Axes(id)%length) = real(Axes(id)%diag_type_data(1:Axes(id)%length), kind=r4_kind) TYPE IS (real(kind=r8_kind)) - DATA(1:Axes(id)%length) = Axes(id)%data(1:Axes(id)%length) + array_data(1:Axes(id)%length) = Axes(id)%diag_type_data(1:Axes(id)%length) CLASS DEFAULT CALL error_mesg('diag_axis_mod::get_diag_axis',& & 'The axis data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -562,16 +562,16 @@ SUBROUTINE get_diag_axis_cart(id, cart_name) END SUBROUTINE get_diag_axis_cart !> @brief Return the axis data. - SUBROUTINE get_diag_axis_data(id, DATA) + SUBROUTINE get_diag_axis_data(id, axis_data) INTEGER, INTENT(in) :: id !< Axis ID - REAL, DIMENSION(:), INTENT(out) :: DATA !< Axis data + REAL, DIMENSION(:), INTENT(out) :: axis_data !< Axis data CALL valid_id_check(id, 'get_diag_axis_data') - IF (Axes(id)%length > SIZE(DATA(:))) THEN + IF (Axes(id)%length > SIZE(axis_data(:))) THEN ! array data is too small CALL error_mesg('diag_axis_mod::get_diag_axis_data', 'array data is too small', FATAL) ELSE - DATA(1:Axes(id)%length) = Axes(id)%data + axis_data(1:Axes(id)%length) = Axes(id)%diag_type_data END IF END SUBROUTINE get_diag_axis_data diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 1f443ce220..e5d7942946 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -258,7 +258,7 @@ MODULE diag_data_mod CHARACTER(len=128) :: name CHARACTER(len=256) :: units, long_name CHARACTER(len=1) :: cart_name - REAL, DIMENSION(:), POINTER :: data + REAL, DIMENSION(:), POINTER :: diag_type_data INTEGER, DIMENSION(MAX_SUBAXES) :: start INTEGER, DIMENSION(MAX_SUBAXES) :: end CHARACTER(len=128), DIMENSION(MAX_SUBAXES) :: subaxis_name diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 55048c04f8..9a72598915 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -218,7 +218,8 @@ MODULE diag_manager_mod & check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,& & diag_time_inc, find_input_field, init_input_field, init_output_field,& & diag_data_out, write_static, get_date_dif, get_subfield_vert_size, sync_file_times,& - & prepend_attribute, attribute_init, diag_util_init, field_log_separator + & prepend_attribute, attribute_init, diag_util_init, field_log_separator, & + & get_file_start_time USE diag_data_mod, ONLY: max_files, CMOR_MISSING_VALUE, DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, EVERY_TIME,& & END_OF_RUN, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, num_files,& & max_input_fields, max_output_fields, num_output_fields, EMPTY, FILL_VALUE, null_axis_id,& @@ -442,6 +443,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t INTEGER :: stdout_unit LOGICAL :: mask_variant1, verbose1 CHARACTER(len=128) :: msg + TYPE(time_type) :: diag_file_init_time !< The intial time of the diag_file ! get stdout unit number stdout_unit = stdout() @@ -557,7 +559,6 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t ind = input_fields(field)%output_fields(j) output_fields(ind)%static = .FALSE. ! Set up times in output_fields - output_fields(ind)%last_output = init_time ! Get output frequency from for the appropriate output file file_num = output_fields(ind)%output_file IF ( file_num == max_files ) CYCLE @@ -576,8 +577,10 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t END IF freq = files(file_num)%output_freq + diag_file_init_time = get_file_start_time(file_num) output_units = files(file_num)%output_units - output_fields(ind)%next_output = diag_time_inc(init_time, freq, output_units, err_msg=msg) + output_fields(ind)%last_output = diag_file_init_time + output_fields(ind)%next_output = diag_time_inc(diag_file_init_time, freq, output_units, err_msg=msg) IF ( msg /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::register_diag_field',& & ' file='//TRIM(files(file_num)%name)//': '//TRIM(msg),err_msg)) RETURN @@ -1909,6 +1912,11 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, ! Finished output of previously buffered data, now deal with buffering new data END IF + if (present(time)) then + !! If the last_output is greater than the time passed in, it is not time to start averaging the data + if (output_fields(out_num)%last_output > time) CYCLE + endif + IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN CALL check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN @@ -3997,7 +4005,7 @@ END FUNCTION need_data INTEGER FUNCTION init_diurnal_axis(n_samples) INTEGER, INTENT(in) :: n_samples !< number of intervals during the day - REAL :: DATA (n_samples) !< central points of time intervals + REAL :: center_data (n_samples) !< central points of time intervals REAL :: edges (n_samples+1) !< boundaries of time intervals INTEGER :: edges_id !< id of the corresponding edges INTEGER :: i @@ -4016,7 +4024,7 @@ INTEGER FUNCTION init_diurnal_axis(n_samples) ! compute central points and units edges(1) = 0.0 DO i = 1, n_samples - DATA (i) = 24.0*(REAL(i)-0.5)/n_samples + center_data (i) = 24.0*(REAL(i)-0.5)/n_samples edges(i+1) = 24.0* REAL(i)/n_samples END DO @@ -4033,7 +4041,8 @@ INTEGER FUNCTION init_diurnal_axis(n_samples) WRITE (name,'(a,i2.2)') 'time_of_day_', n_samples init_diurnal_axis = get_axis_num(name, 'diurnal') IF ( init_diurnal_axis <= 0 ) THEN - init_diurnal_axis = diag_axis_init(name, DATA, units, 'N', 'time of day', set_name='diurnal', edges=edges_id) + init_diurnal_axis = diag_axis_init(name, center_data, units, 'N', 'time of day', & + set_name='diurnal', edges=edges_id) END IF END FUNCTION init_diurnal_axis diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 23191e62e8..5591c293a3 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -82,7 +82,7 @@ MODULE diag_util_mod & prepend_attribute, attribute_init, diag_util_init,& & update_bounds, check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,& & fms_diag_check_out_of_bounds, & - & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static + & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static, get_file_start_time !> @brief Prepend a value to a string attribute in the output field or output file. @@ -1706,7 +1706,7 @@ SUBROUTINE opening_file(file, time, filename_time) !! writting periodic files TYPE(time_type) :: fname_time !< Time used in setting the filename when writting periodic files - REAL, DIMENSION(2) :: DATA + REAL, DIMENSION(2) :: open_file_data INTEGER :: j, field_num, input_field_num, num_axes, k INTEGER :: field_num1 INTEGER :: position @@ -2084,9 +2084,9 @@ SUBROUTINE opening_file(file, time, filename_time) time_axis_id(1) = files(file)%time_axis_id time_bounds_id(1) = files(file)%time_bounds_id CALL get_diag_axis( time_axis_id(1), time_name, time_units, time_longname,& - & cart_name, dir, edges, Domain, domainU, DATA) + & cart_name, dir, edges, Domain, domainU, open_file_data) CALL get_diag_axis( time_bounds_id(1), timeb_name, timeb_units, timeb_longname,& - & cart_name, dir, edges, Domain, domainU, DATA) + & cart_name, dir, edges, Domain, domainU, open_file_data) ! CF Compliance requires the unit on the _bnds axis is the same as 'time' files(file)%f_bounds = write_field_meta_data(files(file)%file_unit,& & TRIM(time_name)//'_bnds', (/time_bounds_id,time_axis_id/),& @@ -2751,6 +2751,16 @@ SUBROUTINE prepend_attribute_file(out_file, att_name, prepend_value, err_msg) END IF END SUBROUTINE prepend_attribute_file + !> @brief Get the a diag_file's start_time as it is defined in the diag_table + !! @return the start_time for the file + function get_file_start_time(file_num) & + result (start_time) + integer, intent(in) :: file_num !< File number of the file to get the start_time from + + TYPE(time_type) :: start_time !< The start_time to return + + start_time = files(file_num)%start_time + end function get_file_start_time END MODULE diag_util_mod !> @} ! close documentation grouping diff --git a/drifters/drifters_comm.F90 b/drifters/drifters_comm.F90 index e94e2a7f23..b5a40e82e3 100644 --- a/drifters/drifters_comm.F90 +++ b/drifters/drifters_comm.F90 @@ -641,7 +641,7 @@ subroutine drifters_comm_gather(self, drfts, dinp, & integer, allocatable :: nps(:) real :: x, y real, allocatable :: lons0(:), lats0(:), recvbuf(:,:) - real :: data(drfts%nd+3, drfts%np) + real :: com_data(drfts%nd+3, drfts%np) !communication data comm = MPI_COMM_WORLD if(present(mycomm)) comm = mycomm @@ -668,10 +668,10 @@ subroutine drifters_comm_gather(self, drfts, dinp, & if( x <= self%xcmax .and. x >= self%xcmin .and. & & y <= self%ycmax .and. y >= self%ycmin) then npf = npf + 1 - data(1 , npf) = real(drfts%ids(ip)) - data(1+1:1+nd, npf) = drfts%positions(:, ip) - data( 2+nd, npf) = lons(ip) - data( 3+nd, npf) = lats(ip) + com_data(1 , npf) = real(drfts%ids(ip)) + com_data(1+1:1+nd, npf) = drfts%positions(:, ip) + com_data( 2+nd, npf) = lons(ip) + com_data( 3+nd, npf) = lats(ip) endif enddo @@ -700,12 +700,12 @@ subroutine drifters_comm_gather(self, drfts, dinp, & ! Each PE sends data to recvbuf on root_pe. #ifdef _USE_MPI - call mpi_gather( data , npf*(nd+3), MPI_REAL8, & + call mpi_gather( com_data , npf*(nd+3), MPI_REAL8, & & recvbuf, npmax*(nd+3), MPI_REAL8, & & root_pe, comm, ier) !!if(ier/=0) ermesg = 'drifters_write_restart: ERROR while gathering "data"' #else - if(npf > 0) call mpp_send(data(1,1), plen=npf*(nd+3), to_pe=root_pe, tag=COMM_TAG_4) + if(npf > 0) call mpp_send(com_data(1,1), plen=npf*(nd+3), to_pe=root_pe, tag=COMM_TAG_4) if(pe==root_pe) then do i = self%pe_beg, self%pe_end if(nps(i) > 0) call mpp_recv(recvbuf(1, i), glen=nps(i)*(nd+3), from_pe=i, tag=COMM_TAG_4) diff --git a/drifters/drifters_set_field.fh b/drifters/drifters_set_field.fh index 9ca2a2acf5..dd60b20f3b 100644 --- a/drifters/drifters_set_field.fh +++ b/drifters/drifters_set_field.fh @@ -22,7 +22,7 @@ subroutine drifters_set_field_XXX(self, index_field, x, y, & #if _DIMS >= 3 & z, & #endif - & data, ermesg) + & set_field_data, ermesg) use cloud_interpolator_mod type(drifters_type) :: self ! field index must be consistent with field_names from input file @@ -30,11 +30,11 @@ subroutine drifters_set_field_XXX(self, index_field, x, y, & real, intent(in) :: x(:) real, intent(in) :: y(:) #if _DIMS == 2 - real, intent(in) :: data(:,:) + real, intent(in) :: set_field_data(:,:) #endif #if _DIMS == 3 real, intent(in) :: z(:) - real, intent(in) :: data(:,:,:) + real, intent(in) :: set_field_data(:,:,:) #endif character(len=*), intent(out) :: ermesg @@ -52,12 +52,12 @@ subroutine drifters_set_field_XXX(self, index_field, x, y, & nsizes(3) = size(z) #endif - if(nsizes(1) /= size(data, 1) .or. nsizes(2) /= size(data, 2)) then + if(nsizes(1) /= size(set_field_data, 1) .or. nsizes(2) /= size(set_field_data, 2)) then ermesg = 'drifters_set_field_XXX: ERROR size mismatch between data and x or y' return end if #if _DIMS >=3 - if(nsizes(3) /= size(data, 3)) then + if(nsizes(3) /= size(set_field_data, 3)) then ermesg = 'drifters_set_field_XXX: ERROR size mismatch between data and z' return endif @@ -104,7 +104,7 @@ subroutine drifters_set_field_XXX(self, index_field, x, y, & ts(3) = (self%core%positions(3,ip) - z(j))/(z(j+1) - z(j)) #endif - call cld_ntrp_get_cell_values(nsizes, _FLATTEN(data), ij, fvals, ier) + call cld_ntrp_get_cell_values(nsizes, _FLATTEN(set_field_data), ij, fvals, ier) call cld_ntrp_linear_cell_interp(fvals, ts, self%fields(index_field, ip), ier) enddo diff --git a/exchange/xgrid.F90 b/exchange/xgrid.F90 index d8565cfd48..3cf69cfab4 100644 --- a/exchange/xgrid.F90 +++ b/exchange/xgrid.F90 @@ -523,7 +523,7 @@ subroutine xgrid_init(remap_method) integer, intent(out) :: remap_method !< exchange grid interpolation method. It has four possible values: !! FIRST_ORDER (=1), SECOND_ORDER(=2). - integer :: unit, ierr, io, out_unit + integer :: iunit, ierr, io, out_unit if (module_is_initialized) return module_is_initialized = .TRUE. @@ -534,9 +534,9 @@ subroutine xgrid_init(remap_method) !--------- write version number and namelist ------------------ call write_version_number("XGRID_MOD", version) - unit = stdlog ( ) + iunit = stdlog ( ) out_unit = stdout() - if ( mpp_pe() == mpp_root_pe() ) write (unit,nml=xgrid_nml) + if ( mpp_pe() == mpp_root_pe() ) write (iunit,nml=xgrid_nml) if (use_mpp_io) then ! FATAL error if trying to use mpp_io @@ -1457,18 +1457,18 @@ end subroutine get_grid_version2 !####################################################################### !> @brief Read the area elements from NetCDF file -subroutine get_area_elements_fms2_io(fileobj, name, data) +subroutine get_area_elements_fms2_io(fileobj, name, get_area_data) type(FmsNetcdfDomainFile_t), intent(in) :: fileobj character(len=*), intent(in) :: name - real(r8_kind), intent(out) :: data(:,:) + real(r8_kind), intent(out) :: get_area_data(:,:) if(variable_exists(fileobj, name)) then - call read_data(fileobj, name, data) + call read_data(fileobj, name, get_area_data) else call error_mesg('xgrid_mod', 'no field named '//trim(name)//' in grid file '//trim(fileobj%path)// & ' Will set data to negative values...', NOTE) ! area elements no present in grid_spec file, set to negative values.... - data = -1.0_r8_kind + get_area_data = -1.0_r8_kind endif end subroutine get_area_elements_fms2_io @@ -4418,7 +4418,7 @@ end subroutine get_index_range !! first grid, which typically is on the atmos side. !! note that "from" and "to" are optional, the stocks will be subtracted, resp. added, only !! if these are present. -subroutine stock_move_3d(from, to, grid_index, data, xmap, & +subroutine stock_move_3d(from, to, grid_index, stock_data3d, xmap, & & delta_t, from_side, to_side, radius, verbose, ier) ! this version takes rank 3 data, it can be used to compute the flux on anything but the @@ -4431,7 +4431,7 @@ subroutine stock_move_3d(from, to, grid_index, data, xmap, & type(stock_type), intent(inout), optional :: from, to integer, intent(in) :: grid_index !< grid index - real(r8_kind), intent(in) :: data(:,:,:) !< data array is 3d + real(r8_kind), intent(in) :: stock_data3d(:,:,:) !< data array is 3d type(xmap_type), intent(in) :: xmap real(r8_kind), intent(in) :: delta_t integer, intent(in) :: from_side !< ISTOCK_TOP, ISTOCK_BOTTOM, or ISTOCK_SIDE @@ -4455,7 +4455,7 @@ subroutine stock_move_3d(from, to, grid_index, data, xmap, & endif from_dq = delta_t * 4.0_r8_kind * PI * radius**2 * sum( sum(xmap%grids(grid_index)%area * & - & sum(xmap%grids(grid_index)%frac_area * data, DIM=3), DIM=1)) + & sum(xmap%grids(grid_index)%frac_area * stock_data3d, DIM=3), DIM=1)) to_dq = from_dq ! update only if argument is present. @@ -4478,7 +4478,7 @@ end subroutine stock_move_3d !> @brief this version takes rank 2 data, it can be used to compute the flux on the atmos side !! note that "from" and "to" are optional, the stocks will be subtracted, resp. added, only !! if these are present. -subroutine stock_move_2d(from, to, grid_index, data, xmap, & +subroutine stock_move_2d(from, to, grid_index, stock_data2d, xmap, & & delta_t, from_side, to_side, radius, verbose, ier) ! this version takes rank 2 data, it can be used to compute the flux on the atmos side @@ -4490,7 +4490,7 @@ subroutine stock_move_2d(from, to, grid_index, data, xmap, & type(stock_type), intent(inout), optional :: from, to integer, optional, intent(in) :: grid_index - real(r8_kind), intent(in) :: data(:,:) !< data array is 2d + real(r8_kind), intent(in) :: stock_data2d(:,:) !< data array is 2d type(xmap_type), intent(in) :: xmap real(r8_kind), intent(in) :: delta_t integer, intent(in) :: from_side !< ISTOCK_TOP, ISTOCK_BOTTOM, or ISTOCK_SIDE @@ -4511,7 +4511,7 @@ subroutine stock_move_2d(from, to, grid_index, data, xmap, & if( .not. present(grid_index) .or. grid_index==1 ) then ! only makes sense if grid_index == 1 - from_dq = delta_t * 4.0_r8_kind*PI*radius**2 * sum(sum(xmap%grids(1)%area * data, DIM=1)) + from_dq = delta_t * 4.0_r8_kind*PI*radius**2 * sum(sum(xmap%grids(1)%area * stock_data2d, DIM=1)) to_dq = from_dq else @@ -4542,7 +4542,7 @@ end subroutine stock_move_2d !! first grid, which typically is on the atmos side. !! note that "from" and "to" are optional, the stocks will be subtracted, resp. added, only !! if these are present. -subroutine stock_move_ug_3d(from, to, grid_index, data, xmap, & +subroutine stock_move_ug_3d(from, to, grid_index, stock_ug_data3d, xmap, & & delta_t, from_side, to_side, radius, verbose, ier) ! this version takes rank 3 data, it can be used to compute the flux on anything but the @@ -4555,7 +4555,7 @@ subroutine stock_move_ug_3d(from, to, grid_index, data, xmap, & type(stock_type), intent(inout), optional :: from, to integer, intent(in) :: grid_index !< grid index - real(r8_kind), intent(in) :: data(:,:) !< data array is 3d + real(r8_kind), intent(in) :: stock_ug_data3d(:,:) !< data array is 3d type(xmap_type), intent(in) :: xmap real(r8_kind), intent(in) :: delta_t integer, intent(in) :: from_side !< ISTOCK_TOP, ISTOCK_BOTTOM, or ISTOCK_SIDE @@ -4563,7 +4563,7 @@ subroutine stock_move_ug_3d(from, to, grid_index, data, xmap, & real(r8_kind), intent(in) :: radius !< earth radius character(len=*), intent(in), optional :: verbose integer, intent(out) :: ier - real(r8_kind), dimension(size(data,1),size(data,2)) :: tmp + real(r8_kind), dimension(size(stock_ug_data3d,1),size(stock_ug_data3d,2)) :: tmp real(r8_kind) :: from_dq, to_dq @@ -4579,7 +4579,7 @@ subroutine stock_move_ug_3d(from, to, grid_index, data, xmap, & return endif - tmp = xmap%grids(grid_index)%frac_area(:,1,:) * data + tmp = xmap%grids(grid_index)%frac_area(:,1,:) * stock_ug_data3d from_dq = delta_t * 4.0_r8_kind * PI * radius**2 * sum( xmap%grids(grid_index)%area(:,1) * & & sum(tmp, DIM=2)) to_dq = from_dq @@ -4604,13 +4604,13 @@ end subroutine stock_move_ug_3d !####################################################################### !> @brief surface/time integral of a 2d array -subroutine stock_integrate_2d(data, xmap, delta_t, radius, res, ier) +subroutine stock_integrate_2d(integrate_data2d, xmap, delta_t, radius, res, ier) ! surface/time integral of a 2d array use mpp_mod, only : mpp_sum - real(r8_kind), intent(in) :: data(:,:) !< data array is 2d + real(r8_kind), intent(in) :: integrate_data2d(:,:) !< data array is 2d type(xmap_type), intent(in) :: xmap real(r8_kind), intent(in) :: delta_t real(r8_kind), intent(in) :: radius !< earth radius @@ -4625,7 +4625,7 @@ subroutine stock_integrate_2d(data, xmap, delta_t, radius, res, ier) return endif - res = delta_t * 4.0_r8_kind * PI * radius**2 * sum(sum(xmap%grids(1)%area * data, DIM=1)) + res = delta_t * 4.0_r8_kind * PI * radius**2 * sum(sum(xmap%grids(1)%area * integrate_data2d, DIM=1)) end subroutine stock_integrate_2d !####################################################################### diff --git a/field_manager/field_manager.F90 b/field_manager/field_manager.F90 index 61c3e234ba..ecb04a6575 100644 --- a/field_manager/field_manager.F90 +++ b/field_manager/field_manager.F90 @@ -1512,28 +1512,28 @@ function parse_strings ( text, label, values ) result (parse) include 'parse.inc' end function parse_strings -function parse_integer ( text, label, value ) result (parse) +function parse_integer ( text, label, parse_ival ) result (parse) character(len=*), intent(in) :: text !< The text string from which the values will be parsed. character(len=*), intent(in) :: label !< A label which describes the values being decoded. -integer, intent(out) :: value !< The value or values that have been decoded. +integer, intent(out) :: parse_ival !< The value or values that have been decoded. integer :: parse integer :: values(1) parse = parse_integers ( text, label, values ) - if (parse > 0) value = values(1) + if (parse > 0) parse_ival = values(1) end function parse_integer -function parse_string ( text, label, value ) result (parse) +function parse_string ( text, label, parse_sval ) result (parse) character(len=*), intent(in) :: text !< The text string from which the values will be parsed. character(len=*), intent(in) :: label !< A label which describes the values being decoded. -character(len=*), intent(out) :: value !< The value or values that have been decoded. +character(len=*), intent(out) :: parse_sval !< The value or values that have been decoded. integer :: parse -character(len=len(value)) :: values(1) +character(len=len(parse_sval)) :: values(1) parse = parse_strings ( text, label, values ) - if (parse > 0) value = values(1) + if (parse > 0) parse_sval = values(1) end function parse_string !> @brief A function to create a field as a child of parent_p. This will return @@ -2277,11 +2277,11 @@ end function fm_get_type !> @returns A flag to indicate whether the function operated with (false) or without !! (true) errors. -function fm_get_value_integer(name, value, index) & +function fm_get_value_integer(name, get_ival, index) & result (success) logical :: success character(len=*), intent(in) :: name !< The name of a field that the user wishes to get a value for. -integer, intent(out) :: value !< The value associated with the named field. +integer, intent(out) :: get_ival !< The value associated with the named field. integer, intent(in), optional :: index !< An optional index to retrieve a single value from an array. integer :: index_t @@ -2295,7 +2295,7 @@ function fm_get_value_integer(name, value, index) & endif ! Must supply a field field name if (name .eq. ' ') then - value = 0 + get_ival = 0 success = .false. return endif @@ -2313,20 +2313,20 @@ function fm_get_value_integer(name, value, index) & if (temp_field_p%field_type .eq. integer_type) then if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index) then ! Index is not positive or index too large - value = 0 + get_ival = 0 success = .false. else ! extract the value - value = temp_field_p%i_value(index_t) + get_ival = temp_field_p%i_value(index_t) success = .true. endif else ! Field not corrcet type - value = 0 + get_ival = 0 success = .false. endif else - value = 0 + get_ival = 0 success = .false. endif @@ -2334,11 +2334,11 @@ end function fm_get_value_integer !> @returns A flag to indicate whether the function operated with (false) or without !! (true) errors. -function fm_get_value_logical(name, value, index) & +function fm_get_value_logical(name, get_lval, index) & result (success) logical :: success character(len=*), intent(in) :: name !< The name of a field that the user wishes to get a value for. -logical, intent(out) :: value !< The value associated with the named field +logical, intent(out) :: get_lval !< The value associated with the named field integer, intent(in), optional :: index !< An optional index to retrieve a single value from an array. integer :: index_t @@ -2352,7 +2352,7 @@ function fm_get_value_logical(name, value, index) & endif ! Must supply a field field name if (name .eq. ' ') then - value = .false. + get_lval = .false. success = .false. return endif @@ -2371,20 +2371,20 @@ function fm_get_value_logical(name, value, index) & if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index) then ! Index is not positive or too large - value = .false. + get_lval = .false. success = .false. else ! extract the value - value = temp_field_p%l_value(index_t) + get_lval = temp_field_p%l_value(index_t) success = .true. endif else ! Field not correct type - value = .false. + get_lval = .false. success = .false. endif else - value = .false. + get_lval = .false. success = .false. endif @@ -2392,11 +2392,11 @@ end function fm_get_value_logical !> @returns A flag to indicate whether the function operated with (false) or without !! (true) errors. -function fm_get_value_string(name, value, index) & +function fm_get_value_string(name, get_sval, index) & result (success) logical :: success character(len=*), intent(in) :: name !< The name of a field that the user wishes to get a value for. -character(len=*), intent(out) :: value !< The value associated with the named field +character(len=*), intent(out) :: get_sval !< The value associated with the named field integer, intent(in), optional :: index !< An optional index to retrieve a single value from an array. integer :: index_t @@ -2410,7 +2410,7 @@ function fm_get_value_string(name, value, index) & endif ! Must supply a field field name if (name .eq. ' ') then - value = '' + get_sval = '' success = .false. return endif @@ -2428,20 +2428,20 @@ function fm_get_value_string(name, value, index) & if (temp_field_p%field_type .eq. string_type) then if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index) then ! Index is not positive or is too large - value = '' + get_sval = '' success = .false. else ! extract the value - value = temp_field_p%s_value(index_t) + get_sval = temp_field_p%s_value(index_t) success = .true. endif else ! Field not correct type - value = '' + get_sval = '' success = .false. endif else - value = '' + get_sval = '' success = .false. endif @@ -2624,12 +2624,12 @@ end function fm_new_list !> @brief Assigns a given value to a given field !> @returns An index for the named field -function fm_new_value_integer(name, value, create, index, append) & +function fm_new_value_integer(name, new_ival, create, index, append) & result (field_index) integer :: field_index character(len=*), intent(in) :: name !< The name of a field that the user wishes to create !! a value for. -integer, intent(in) :: value !< The value that the user wishes to apply to the +integer, intent(in) :: new_ival !< The value that the user wishes to apply to the !! named field. logical, intent(in), optional :: create !< If present and .true., then a value for this !! field will be created. @@ -2698,7 +2698,7 @@ function fm_new_value_integer(name, value, create, index, append) & if (temp_field_p%field_type == real_type ) then ! promote integer input to real ! all real field values are stored as r8_kind - field_index = fm_new_value(name, real(value,r8_kind), create, index, append) + field_index = fm_new_value(name, real(new_ival,r8_kind), create, index, append) return else if (temp_field_p%field_type /= integer_type ) then ! slm: why would we reset index? Is it not an error to have a "list" defined @@ -2746,7 +2746,7 @@ function fm_new_value_integer(name, value, create, index, append) & ! Assign the value and set the field_index for return ! for non-null fields (index_t > 0) if (index_t .gt. 0) then - temp_field_p%i_value(index_t) = value + temp_field_p%i_value(index_t) = new_ival if (index_t .gt. temp_field_p%max_index) then temp_field_p%max_index = index_t endif @@ -2764,12 +2764,12 @@ end function fm_new_value_integer !> @brief Assigns a given value to a given field !> @returns An index for the named field -function fm_new_value_logical(name, value, create, index, append) & +function fm_new_value_logical(name, new_lval, create, index, append) & result (field_index) integer :: field_index character(len=*), intent(in) :: name !< The name of a field that the user wishes to create !! a value for. -logical, intent(in) :: value !< The value that the user wishes to apply to the +logical, intent(in) :: new_lval !< The value that the user wishes to apply to the !! named field. logical, intent(in), optional :: create !< If present and .true., then a value for this !! field will be created. @@ -2881,7 +2881,7 @@ function fm_new_value_logical(name, value, create, index, append) & ! Assign the value and set the field_index for return ! for non-null fields (index_t > 0) if (index_t .gt. 0) then - temp_field_p%l_value(index_t) = value + temp_field_p%l_value(index_t) = new_lval if (index_t .gt. temp_field_p%max_index) then temp_field_p%max_index = index_t endif @@ -2898,12 +2898,12 @@ end function fm_new_value_logical !> @brief Assigns a given value to a given field !> @returns An index for the named field -function fm_new_value_string(name, value, create, index, append) & +function fm_new_value_string(name, new_sval, create, index, append) & result (field_index) integer :: field_index character(len=*), intent(in) :: name !< The name of a field that the user wishes to create !! a value for. -character(len=*), intent(in) :: value !< The value that the user wishes to apply to the +character(len=*), intent(in) :: new_sval !< The value that the user wishes to apply to the !! named field. logical, intent(in), optional :: create !< If present and .true., then a value for this !! field will be created. @@ -3014,7 +3014,7 @@ function fm_new_value_string(name, value, create, index, append) & ! Assign the value and set the field_index for return ! for non-null fields (index_t > 0) if (index_t .gt. 0) then - temp_field_p%s_value(index_t) = value + temp_field_p%s_value(index_t) = new_sval if (index_t .gt. temp_field_p%max_index) then temp_field_p%max_index = index_t endif diff --git a/field_manager/fm_util.F90 b/field_manager/fm_util.F90 index db729c5ef5..41432ca9e3 100644 --- a/field_manager/fm_util.F90 +++ b/field_manager/fm_util.F90 @@ -1129,7 +1129,7 @@ end function fm_util_get_string_array !} !> Get an integer value from the Field Manager tree. function fm_util_get_integer(name, caller, index, default_value, scalar) & - result (value) !{ + result (ival) !{ implicit none @@ -1137,7 +1137,7 @@ function fm_util_get_integer(name, caller, index, default_value, scalar) ! Return type ! -integer :: value +integer :: ival ! ! arguments @@ -1223,11 +1223,11 @@ function fm_util_get_integer(name, caller, index, default_value, scalar) fm_type = fm_get_type(name) if (fm_type .eq. 'integer') then !{ - if (.not. fm_get_value(name, value, index = index_t)) then !{ + if (.not. fm_get_value(name, ival, index = index_t)) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name)) endif !} elseif (fm_type .eq. ' ' .and. present(default_value)) then !}{ - value = default_value + ival = default_value elseif (fm_type .eq. ' ') then !}{ call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name)) else !}{ @@ -1242,7 +1242,7 @@ end function fm_util_get_integer !} !> Get a logical value from the Field Manager tree. function fm_util_get_logical(name, caller, index, default_value, scalar) & - result (value) !{ + result (lval) !{ implicit none @@ -1250,7 +1250,7 @@ function fm_util_get_logical(name, caller, index, default_value, scalar) ! Return type ! -logical :: value +logical :: lval ! ! arguments @@ -1336,11 +1336,11 @@ function fm_util_get_logical(name, caller, index, default_value, scalar) fm_type = fm_get_type(name) if (fm_type .eq. 'logical') then !{ - if (.not. fm_get_value(name, value, index = index_t)) then !{ + if (.not. fm_get_value(name, lval, index = index_t)) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name)) endif !} elseif (fm_type .eq. ' ' .and. present(default_value)) then !}{ - value = default_value + lval = default_value elseif (fm_type .eq. ' ') then !}{ call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name)) else !}{ @@ -1356,7 +1356,7 @@ end function fm_util_get_logical !} !> Get a real value from the Field Manager tree. function fm_util_get_real(name, caller, index, default_value, scalar) & - result (value) !{ + result (rval) !{ implicit none @@ -1364,7 +1364,7 @@ function fm_util_get_real(name, caller, index, default_value, scalar) ! Return type ! -real(r8_kind) :: value +real(r8_kind) :: rval ! ! arguments @@ -1451,16 +1451,16 @@ function fm_util_get_real(name, caller, index, default_value, scalar) fm_type = fm_get_type(name) if (fm_type .eq. 'real') then !{ - if (.not. fm_get_value(name, value, index = index_t)) then !{ + if (.not. fm_get_value(name, rval, index = index_t)) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name)) endif !} else if (fm_type .eq. 'integer') then if (.not. fm_get_value(name, ivalue, index = index_t)) then call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name)) endif - value = real(ivalue,r8_kind) + rval = real(ivalue,r8_kind) elseif (fm_type .eq. ' ' .and. present(default_value)) then !}{ - value = default_value + rval = default_value elseif (fm_type .eq. ' ') then !}{ call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name)) else !}{ @@ -1477,7 +1477,7 @@ end function fm_util_get_real !} !> Get a string value from the Field Manager tree. function fm_util_get_string(name, caller, index, default_value, scalar) & - result (value) !{ + result (sval) !{ implicit none @@ -1485,7 +1485,7 @@ function fm_util_get_string(name, caller, index, default_value, scalar) ! Return type ! -character(len=fm_string_len) :: value +character(len=fm_string_len) :: sval ! ! arguments @@ -1571,11 +1571,11 @@ function fm_util_get_string(name, caller, index, default_value, scalar) fm_type = fm_get_type(name) if (fm_type .eq. 'string') then !{ - if (.not. fm_get_value(name, value, index = index_t)) then !{ + if (.not. fm_get_value(name, sval, index = index_t)) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem getting ' // trim(name)) endif !} elseif (fm_type .eq. ' ' .and. present(default_value)) then !}{ - value = default_value + sval = default_value elseif (fm_type .eq. ' ') then !}{ call mpp_error(FATAL, trim(error_header) // ' Field does not exist: ' // trim(name)) else !}{ @@ -1589,7 +1589,7 @@ end function fm_util_get_string !} !####################################################################### !> Set an integer array in the Field Manager tree. -subroutine fm_util_set_value_integer_array(name, value, length, caller, no_overwrite, good_name_list) !{ +subroutine fm_util_set_value_integer_array(name, ival, length, caller, no_overwrite, good_name_list) !{ implicit none @@ -1599,7 +1599,7 @@ subroutine fm_util_set_value_integer_array(name, value, length, caller, no_overw character(len=*), intent(in) :: name integer, intent(in) :: length -integer, intent(in) :: value(length) +integer, intent(in) :: ival(length) character(len=*), intent(in), optional :: caller logical, intent(in), optional :: no_overwrite character(len=fm_path_name_len), intent(in), optional :: good_name_list @@ -1698,19 +1698,19 @@ subroutine fm_util_set_value_integer_array(name, value, length, caller, no_overw call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name)) endif !} do n = field_length + 1, length !{ - field_index = fm_new_value(name, value(n), index = n) + field_index = fm_new_value(name, ival(n), index = n) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', n call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) endif !} enddo !} n else !}{ - field_index = fm_new_value(name, value(1)) + field_index = fm_new_value(name, ival(1)) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name)) endif !} do n = 2, length !{ - field_index = fm_new_value(name, value(n), index = n) + field_index = fm_new_value(name, ival(n), index = n) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', n call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) @@ -1746,7 +1746,7 @@ end subroutine fm_util_set_value_integer_array !} !####################################################################### !> Set a logical array in the Field Manager tree. -subroutine fm_util_set_value_logical_array(name, value, length, caller, no_overwrite, good_name_list) !{ +subroutine fm_util_set_value_logical_array(name, lval, length, caller, no_overwrite, good_name_list) !{ implicit none @@ -1756,7 +1756,7 @@ subroutine fm_util_set_value_logical_array(name, value, length, caller, no_overw character(len=*), intent(in) :: name integer, intent(in) :: length -logical, intent(in) :: value(length) +logical, intent(in) :: lval(length) character(len=*), intent(in), optional :: caller logical, intent(in), optional :: no_overwrite character(len=fm_path_name_len), intent(in), optional :: good_name_list @@ -1855,19 +1855,19 @@ subroutine fm_util_set_value_logical_array(name, value, length, caller, no_overw call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name)) endif !} do n = field_length + 1, length !{ - field_index = fm_new_value(name, value(n), index = n) + field_index = fm_new_value(name, lval(n), index = n) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', n call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) endif !} enddo !} n else !}{ - field_index = fm_new_value(name, value(1)) + field_index = fm_new_value(name, lval(1)) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name)) endif !} do n = 2, length !{ - field_index = fm_new_value(name, value(n), index = n) + field_index = fm_new_value(name, lval(n), index = n) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', n call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) @@ -1903,7 +1903,7 @@ end subroutine fm_util_set_value_logical_array !} !####################################################################### !> Set a string array in the Field Manager tree. -subroutine fm_util_set_value_string_array(name, value, length, caller, no_overwrite, good_name_list) !{ +subroutine fm_util_set_value_string_array(name, sval, length, caller, no_overwrite, good_name_list) !{ implicit none @@ -1913,7 +1913,7 @@ subroutine fm_util_set_value_string_array(name, value, length, caller, no_overwr character(len=*), intent(in) :: name integer, intent(in) :: length -character(len=*), intent(in) :: value(length) +character(len=*), intent(in) :: sval(length) character(len=*), intent(in), optional :: caller logical, intent(in), optional :: no_overwrite character(len=fm_path_name_len), intent(in), optional :: good_name_list @@ -2012,19 +2012,19 @@ subroutine fm_util_set_value_string_array(name, value, length, caller, no_overwr call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name)) endif !} do n = field_length + 1, length !{ - field_index = fm_new_value(name, value(n), index = n) + field_index = fm_new_value(name, sval(n), index = n) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', n call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) endif !} enddo !} n else !}{ - field_index = fm_new_value(name, value(1)) + field_index = fm_new_value(name, sval(1)) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name)) endif !} do n = 2, length !{ - field_index = fm_new_value(name, value(n), index = n) + field_index = fm_new_value(name, sval(n), index = n) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', n call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) @@ -2060,7 +2060,7 @@ end subroutine fm_util_set_value_string_array !} !####################################################################### !> Set an integer value in the Field Manager tree. -subroutine fm_util_set_value_integer(name, value, caller, index, append, no_create, & +subroutine fm_util_set_value_integer(name, ival, caller, index, append, no_create, & no_overwrite, good_name_list) !{ implicit none @@ -2070,7 +2070,7 @@ subroutine fm_util_set_value_integer(name, value, caller, index, append, no_crea ! character(len=*), intent(in) :: name -integer, intent(in) :: value +integer, intent(in) :: ival character(len=*), intent(in), optional :: caller integer, intent(in), optional :: index logical, intent(in), optional :: append @@ -2170,21 +2170,21 @@ subroutine fm_util_set_value_integer(name, value, caller, index, append, no_crea call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name)) endif !} if (.not. (no_overwrite_use .and. field_length .ge. index)) then !{ - field_index = fm_new_value(name, value, index = index) + field_index = fm_new_value(name, ival, index = index) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', index call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error)) endif !} endif !} else !}{ - field_index = fm_new_value(name, value, index = index) + field_index = fm_new_value(name, ival, index = index) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', index call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) endif !} endif !} elseif (present(append)) then !}{ - field_index = fm_new_value(name, value, append = append) + field_index = fm_new_value(name, ival, append = append) if (field_index .le. 0) then !{ write (str_error,*) ' with append = ', append call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) @@ -2192,13 +2192,13 @@ subroutine fm_util_set_value_integer(name, value, caller, index, append, no_crea else !}{ if (fm_exists(name)) then !{ if (.not. no_overwrite_use) then !{ - field_index = fm_new_value(name, value) + field_index = fm_new_value(name, ival) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name)) endif !} endif !} elseif (create) then !}{ - field_index = fm_new_value(name, value) + field_index = fm_new_value(name, ival) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem creating ' // trim(name)) endif !} @@ -2232,7 +2232,7 @@ end subroutine fm_util_set_value_integer !} !####################################################################### !> Set a logical value in the Field Manager tree. -subroutine fm_util_set_value_logical(name, value, caller, index, append, no_create, & +subroutine fm_util_set_value_logical(name, lval, caller, index, append, no_create, & no_overwrite, good_name_list) !{ implicit none @@ -2242,7 +2242,7 @@ subroutine fm_util_set_value_logical(name, value, caller, index, append, no_crea ! character(len=*), intent(in) :: name -logical, intent(in) :: value +logical, intent(in) :: lval character(len=*), intent(in), optional :: caller integer, intent(in), optional :: index logical, intent(in), optional :: append @@ -2342,21 +2342,21 @@ subroutine fm_util_set_value_logical(name, value, caller, index, append, no_crea call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name)) endif !} if (.not. (no_overwrite_use .and. field_length .ge. index)) then !{ - field_index = fm_new_value(name, value, index = index) + field_index = fm_new_value(name, lval, index = index) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', index call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error)) endif !} endif !} else !}{ - field_index = fm_new_value(name, value, index = index) + field_index = fm_new_value(name, lval, index = index) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', index call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) endif !} endif !} elseif (present(append)) then !}{ - field_index = fm_new_value(name, value, append = append) + field_index = fm_new_value(name, lval, append = append) if (field_index .le. 0) then !{ write (str_error,*) ' with append = ', append call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) @@ -2364,13 +2364,13 @@ subroutine fm_util_set_value_logical(name, value, caller, index, append, no_crea else !}{ if (fm_exists(name)) then !{ if (.not. no_overwrite_use) then !{ - field_index = fm_new_value(name, value) + field_index = fm_new_value(name, lval) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name)) endif !} endif !} elseif (create) then !}{ - field_index = fm_new_value(name, value) + field_index = fm_new_value(name, lval) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem creating ' // trim(name)) endif !} @@ -2403,7 +2403,7 @@ end subroutine fm_util_set_value_logical !} !####################################################################### !> Set a string value in the Field Manager tree. -subroutine fm_util_set_value_string(name, value, caller, index, append, no_create, & +subroutine fm_util_set_value_string(name, sval, caller, index, append, no_create, & no_overwrite, good_name_list) !{ implicit none @@ -2413,7 +2413,7 @@ subroutine fm_util_set_value_string(name, value, caller, index, append, no_creat ! character(len=*), intent(in) :: name -character(len=*), intent(in) :: value +character(len=*), intent(in) :: sval character(len=*), intent(in), optional :: caller integer, intent(in), optional :: index logical, intent(in), optional :: append @@ -2513,21 +2513,21 @@ subroutine fm_util_set_value_string(name, value, caller, index, append, no_creat call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name)) endif !} if (.not. (no_overwrite_use .and. field_length .ge. index)) then !{ - field_index = fm_new_value(name, value, index = index) + field_index = fm_new_value(name, sval, index = index) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', index call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error)) endif !} endif !} else !}{ - field_index = fm_new_value(name, value, index = index) + field_index = fm_new_value(name, sval, index = index) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', index call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) endif !} endif !} elseif (present(append)) then !}{ - field_index = fm_new_value(name, value, append = append) + field_index = fm_new_value(name, sval, append = append) if (field_index .le. 0) then !{ write (str_error,*) ' with append = ', append call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) @@ -2535,13 +2535,13 @@ subroutine fm_util_set_value_string(name, value, caller, index, append, no_creat else !}{ if (fm_exists(name)) then !{ if (.not. no_overwrite_use) then !{ - field_index = fm_new_value(name, value) + field_index = fm_new_value(name, sval) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name)) endif !} endif !} elseif (create) then !}{ - field_index = fm_new_value(name, value) + field_index = fm_new_value(name, sval) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem creating ' // trim(name)) endif !} diff --git a/field_manager/include/field_manager.inc b/field_manager/include/field_manager.inc index bbf648d236..53f5f4bc7c 100644 --- a/field_manager/include/field_manager.inc +++ b/field_manager/include/field_manager.inc @@ -27,25 +27,25 @@ real(FMS_FM_KIND_), intent(out) :: values(:) !< The value or values that have be include 'parse.inc' end function PARSE_REALS_ -function PARSE_REAL_ ( text, label, value ) result (parse) +function PARSE_REAL_ ( text, label, parse_rval ) result (parse) character(len=*), intent(in) :: text !< The text string from which the values will be parsed. character(len=*), intent(in) :: label !< A label which describes the values being decoded. -real(FMS_FM_KIND_), intent(out) :: value !< The value or values that have been decoded. +real(FMS_FM_KIND_), intent(out) :: parse_rval !< The value or values that have been decoded. integer :: parse real(FMS_FM_KIND_) :: values(1) parse = PARSE_REALS_( text, label, values ) - if (parse > 0) value = values(1) + if (parse > 0) parse_rval = values(1) end function PARSE_REAL_ !> @returns A flag to indicate whether the function operated with (false) or without !! (true) errors. -function FM_GET_VALUE_REAL_(name, value, index) & +function FM_GET_VALUE_REAL_(name, get_rval, index) & result (success) logical :: success character(len=*), intent(in) :: name !< The name of a field that the user wishes to get a value for. -real(FMS_FM_KIND_), intent(out) :: value !< The value associated with the named field +real(FMS_FM_KIND_), intent(out) :: get_rval !< The value associated with the named field integer, intent(in), optional :: index !< An optional index to retrieve a single value from an array. integer :: index_t @@ -61,7 +61,7 @@ if (.not. module_is_initialized) then endif ! Must supply a field field name if (name .eq. ' ') then - value = 0.0_lkind + get_rval = 0.0_lkind success = .false. return endif @@ -79,19 +79,19 @@ if (associated(temp_field_p)) then if (temp_field_p%field_type .eq. real_type) then if (index_t .lt. 1 .or. index_t .gt. temp_field_p%max_index) then ! Index is not positive or is too large - value = 0.0_lkind + get_rval = 0.0_lkind success = .false. else ! extract the value; the value is stored as r8_kind - value = real(temp_field_p%r_value(index_t),lkind) + get_rval = real(temp_field_p%r_value(index_t),lkind) success = .true. endif else - value = 0.0_lkind + get_rval = 0.0_lkind success = .false. endif else - value = 0.0_lkind + get_rval = 0.0_lkind success = .false. endif @@ -99,12 +99,12 @@ end function FM_GET_VALUE_REAL_ !> @brief Assigns a given value to a given field !> @returns An index for the named field -function FM_NEW_VALUE_REAL_(name, value, create, index, append) & +function FM_NEW_VALUE_REAL_(name, new_rval, create, index, append) & result (field_index) integer :: field_index character(len=*), intent(in) :: name !< The name of a field that the user wishes to create !! a value for. -real(FMS_FM_KIND_), intent(in) :: value !< The value that the user wishes to apply to the +real(FMS_FM_KIND_), intent(in) :: new_rval !< The value that the user wishes to apply to the !! named field. logical, intent(in), optional :: create !< If present and .true., then a value for this !! field will be created. @@ -226,7 +226,7 @@ if (associated(temp_list_p)) then ! for non-null fields (index_t > 0) if (index_t .gt. 0) then ! all real field values are stored as r8_kind - temp_field_p%r_value(index_t) = real(value,r8_kind) + temp_field_p%r_value(index_t) = real(new_rval,r8_kind) if (index_t .gt. temp_field_p%max_index) then temp_field_p%max_index = index_t endif diff --git a/field_manager/include/fm_util.inc b/field_manager/include/fm_util.inc index a02011b8d5..26066ca868 100644 --- a/field_manager/include/fm_util.inc +++ b/field_manager/include/fm_util.inc @@ -23,7 +23,7 @@ !####################################################################### !> Set a real array in the Field Manager tree. -subroutine FM_UTIL_SET_VALUE_REAL_ARRAY_(name, value, length, caller, no_overwrite, good_name_list) !{ +subroutine FM_UTIL_SET_VALUE_REAL_ARRAY_(name, rval, length, caller, no_overwrite, good_name_list) !{ implicit none @@ -33,7 +33,7 @@ implicit none character(len=*), intent(in) :: name integer, intent(in) :: length -real(FMS_FM_KIND_), intent(in) :: value(length) +real(FMS_FM_KIND_), intent(in) :: rval(length) character(len=*), intent(in), optional :: caller logical, intent(in), optional :: no_overwrite character(len=fm_path_name_len), intent(in), optional :: good_name_list @@ -134,19 +134,19 @@ else !}{ call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name)) endif !} do n = field_length + 1, length !{ - field_index = fm_new_value(name, value(n), index = n) + field_index = fm_new_value(name, rval(n), index = n) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', n call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) endif !} enddo !} n else !}{ - field_index = fm_new_value(name, value(1)) + field_index = fm_new_value(name, rval(1)) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name)) endif !} do n = 2, length !{ - field_index = fm_new_value(name, value(n), index = n) + field_index = fm_new_value(name, rval(n), index = n) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', n call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) @@ -182,7 +182,7 @@ end subroutine FM_UTIL_SET_VALUE_REAL_ARRAY_ !} !####################################################################### !> Set a real value in the Field Manager tree. -subroutine FM_UTIL_SET_VALUE_REAL_(name, value, caller, index, append, no_create, & +subroutine FM_UTIL_SET_VALUE_REAL_(name, rval, caller, index, append, no_create, & no_overwrite, good_name_list) !{ implicit none @@ -192,7 +192,7 @@ implicit none ! character(len=*), intent(in) :: name -real(FMS_FM_KIND_), intent(in) :: value +real(FMS_FM_KIND_), intent(in) :: rval character(len=*), intent(in), optional :: caller integer, intent(in), optional :: index logical, intent(in), optional :: append @@ -292,21 +292,21 @@ if (present(index)) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem getting length of ' // trim(name)) endif !} if (.not. (no_overwrite_use .and. field_length .ge. index)) then !{ - field_index = fm_new_value(name, value, index = index) + field_index = fm_new_value(name, rval, index = index) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', index call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name) // trim(str_error)) endif !} endif !} else !}{ - field_index = fm_new_value(name, value, index = index) + field_index = fm_new_value(name, rval, index = index) if (field_index .le. 0) then !{ write (str_error,*) ' with index = ', index call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) endif !} endif !} elseif (present(append)) then !}{ - field_index = fm_new_value(name, value, append = append) + field_index = fm_new_value(name, rval, append = append) if (field_index .le. 0) then !{ write (str_error,*) ' with append = ', append call mpp_error(FATAL, trim(error_header) // ' Problem setting ' // trim(name) // trim(str_error)) @@ -314,13 +314,13 @@ elseif (present(append)) then !}{ else !}{ if (fm_exists(name)) then !{ if (.not. no_overwrite_use) then !{ - field_index = fm_new_value(name, value) + field_index = fm_new_value(name, rval) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem overwriting ' // trim(name)) endif !} endif !} elseif (create) then !}{ - field_index = fm_new_value(name, value) + field_index = fm_new_value(name, rval) if (field_index .le. 0) then !{ call mpp_error(FATAL, trim(error_header) // ' Problem creating ' // trim(name)) endif !} diff --git a/horiz_interp/horiz_interp.F90 b/horiz_interp/horiz_interp.F90 index 5b29559f3d..820e9079b9 100644 --- a/horiz_interp/horiz_interp.F90 +++ b/horiz_interp/horiz_interp.F90 @@ -246,7 +246,7 @@ module horiz_interp_mod !> Initialize module and writes version number to logfile.out subroutine horiz_interp_init - integer :: unit, ierr, io + integer :: iunit, ierr, io if(module_is_initialized) return call write_version_number("HORIZ_INTERP_MOD", version) @@ -254,8 +254,8 @@ subroutine horiz_interp_init read (input_nml_file, horiz_interp_nml, iostat=io) ierr = check_nml_error(io,'horiz_interp_nml') if (mpp_pe() == mpp_root_pe() ) then - unit = stdlog() - write (unit, nml=horiz_interp_nml) + iunit = stdlog() + write (iunit, nml=horiz_interp_nml) endif if (reproduce_siena) then diff --git a/horiz_interp/include/horiz_interp_bicubic.inc b/horiz_interp/include/horiz_interp_bicubic.inc index 1c2f744f2b..5ff567dbb8 100644 --- a/horiz_interp/include/horiz_interp_bicubic.inc +++ b/horiz_interp/include/horiz_interp_bicubic.inc @@ -45,7 +45,7 @@ integer :: nlon_in, nlat_in, nlon_out, nlat_out integer :: jcl, jcu, icl, icu, jj real(FMS_HI_KIND_) :: xz, yz - integer :: unit + integer :: iunit integer, parameter :: kindl = FMS_HI_KIND_ !< real size at compile time if(present(verbose)) verbose_bicubic = verbose @@ -74,21 +74,21 @@ Interp%HI_KIND_TYPE_%lat_in = lat_in if ( verbose_bicubic > 0 ) then - unit = stdout() - write (unit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_new_1d_s")') - write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src - write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lon_in(jj),jj=1,Interp%nlon_src) - write (unit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src - write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lat_in(jj),jj=1,Interp%nlat_src) + iunit = stdout() + write (iunit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_new_1d_s")') + write (iunit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src + write (iunit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lon_in(jj),jj=1,Interp%nlon_src) + write (iunit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src + write (iunit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lat_in(jj),jj=1,Interp%nlat_src) do i=1, Interp%nlat_dst - write (unit,*) - write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst - write (unit,'(1x,10f10.4)') (lon_out(jj,i),jj=1,Interp%nlon_dst) + write (iunit,*) + write (iunit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst + write (iunit,'(1x,10f10.4)') (lon_out(jj,i),jj=1,Interp%nlon_dst) enddo do i=1, Interp%nlon_dst - write (unit,*) - write (unit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst - write (unit,'(1x,10f10.4)') (lat_out(i,jj),jj=1,Interp%nlat_dst) + write (iunit,*) + write (iunit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst + write (iunit,'(1x,10f10.4)') (lat_out(i,jj),jj=1,Interp%nlat_dst) enddo endif @@ -210,7 +210,7 @@ integer :: nlon_in, nlat_in, nlon_out, nlat_out integer :: jcl, jcu, icl, icu, jj real(FMS_HI_KIND_) :: xz, yz - integer :: unit + integer :: iunit integer, parameter :: kindl = FMS_HI_KIND_ !< real size at compile time if(present(verbose)) verbose_bicubic = verbose @@ -234,17 +234,17 @@ Interp%HI_KIND_TYPE_%lat_in = lat_in if ( verbose_bicubic > 0 ) then - unit = stdout() - write (unit,'(/,"Initialising bicubic interpolation, interface HORIZ_INTERP_BICUBIC_NEW_1D_")') - write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src - write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lon_in(jj),jj=1,Interp%nlon_src) - write (unit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src - write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lat_in(jj),jj=1,Interp%nlat_src) - write (unit,*) - write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst - write (unit,'(1x,10f10.4)') (lon_out(jj),jj=1,Interp%nlon_dst) - write (unit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst - write (unit,'(1x,10f10.4)') (lat_out(jj),jj=1,Interp%nlat_dst) + iunit = stdout() + write (iunit,'(/,"Initialising bicubic interpolation, interface HORIZ_INTERP_BICUBIC_NEW_1D_")') + write (iunit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src + write (iunit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lon_in(jj),jj=1,Interp%nlon_src) + write (iunit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src + write (iunit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lat_in(jj),jj=1,Interp%nlat_src) + write (iunit,*) + write (iunit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst + write (iunit,'(1x,10f10.4)') (lon_out(jj),jj=1,Interp%nlon_dst) + write (iunit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst + write (iunit,'(1x,10f10.4)') (lat_out(jj),jj=1,Interp%nlat_dst) endif diff --git a/horiz_interp/include/horiz_interp_bilinear.inc b/horiz_interp/include/horiz_interp_bilinear.inc index 7b6fcd7ed2..8f81e86f79 100644 --- a/horiz_interp/include/horiz_interp_bilinear.inc +++ b/horiz_interp/include/horiz_interp_bilinear.inc @@ -30,7 +30,7 @@ logical :: src_is_modulo integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m - integer :: ie, is, je, js, ln_err, lt_err, warns, unit + integer :: ie, is, je, js, ln_err, lt_err, warns, iunit real(FMS_HI_KIND_) :: wtw, wte, wts, wtn, lon, lat, tpi, hpi real(FMS_HI_KIND_) :: glt_min, glt_max, gln_min, gln_max, min_lon, max_lon integer,parameter :: kindl = FMS_HI_KIND_ @@ -143,26 +143,26 @@ enddo enddo - unit = stdout() + iunit = stdout() if (ln_err .eq. 1 .and. warns > 0) then - write (unit,'(/,(1x,a))') & + write (iunit,'(/,(1x,a))') & '==> Warning: the geographic data set does not extend far ', & ' enough east or west - a cyclic boundary ', & ' condition was applied. check if appropriate ' - write (unit,'(/,(1x,a,2f8.4))') & + write (iunit,'(/,(1x,a,2f8.4))') & ' data required between longitudes:', gln_min, gln_max, & ' data set is between longitudes:', lon_in(1), lon_in(nlon_in) warns = warns - 1 endif if (lt_err .eq. 1 .and. warns > 0) then - write (unit,'(/,(1x,a))') & + write (iunit,'(/,(1x,a))') & '==> Warning: the geographic data set does not extend far ',& ' enough north or south - extrapolation from ',& ' the nearest data was applied. this may create ',& ' artificial gradients near a geographic pole ' - write (unit,'(/,(1x,a,2f8.4))') & + write (iunit,'(/,(1x,a,2f8.4))') & ' data required between latitudes:', glt_min, glt_max, & ' data set is between latitudes:', lat_in(1), lat_in(nlat_in) endif @@ -893,7 +893,7 @@ !----------------------------------------------------------------------- integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m, & is, ie, js, je, iverbose, max_missing, num_missing, & - miss_in, miss_out, unit + miss_in, miss_out, iunit real(FMS_HI_KIND_) :: dwtsum, wtsum, min_in, max_in, avg_in, & min_out, max_out, avg_out, wtw, wte, wts, wtn real(FMS_HI_KIND_) :: mask(size(data_in,1), size(data_in,2) ) @@ -1163,12 +1163,12 @@ call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask_out) !---- output statistics ---- - unit = stdout() - write (unit,900) - write (unit,901) min_in ,max_in, avg_in - if (present(mask_in)) write (unit,903) miss_in - write (unit,902) min_out,max_out,avg_out - if (present(mask_out)) write (unit,903) miss_out + iunit = stdout() + write (iunit,900) + write (iunit,901) min_in ,max_in, avg_in + if (present(mask_in)) write (iunit,903) miss_in + write (iunit,902) min_out,max_out,avg_out + if (present(mask_out)) write (iunit,903) miss_out 900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) 901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) @@ -1187,40 +1187,40 @@ !! if "value" is outside the domain of "array" then INDP_ = 1 !! or "ia" depending on whether array(1) or array(ia) is !! closest to "value" - function INDP_ (value, array) + function INDP_ (rval, array) integer :: INDP_ !< index of nearest data point within "array" !! corresponding to "value". real(FMS_HI_KIND_), dimension(:), intent(in) :: array !< array of data points (must be monotonically increasing) - real(FMS_HI_KIND_), intent(in) :: value !< arbitrary data, same units as elements in 'array' + real(FMS_HI_KIND_), intent(in) :: rval !< arbitrary data, same units as elements in 'array' !======================================================================= - integer i, ia, unit + integer i, ia, iunit logical keep_going ! ia = size(array(:)) do i=2,ia if (array(i) .lt. array(i-1)) then - unit = stdout() - write (unit,*) & + iunit = stdout() + write (iunit,*) & ' => Error: array must be monotonically increasing in "INDP_"' , & - ' when searching for nearest element to value=',value - write (unit,*) ' array(i) < array(i-1) for i=',i - write (unit,*) ' array(i) for i=1..ia follows:' + ' when searching for nearest element to value=',rval + write (iunit,*) ' array(i) < array(i-1) for i=',i + write (iunit,*) ' array(i) for i=1..ia follows:' call mpp_error() endif enddo - if (value .lt. array(1) .or. value .gt. array(ia)) then - if (value .lt. array(1)) INDP_ = 1 - if (value .gt. array(ia)) INDP_ = ia + if (rval .lt. array(1) .or. rval .gt. array(ia)) then + if (rval .lt. array(1)) INDP_ = 1 + if (rval .gt. array(ia)) INDP_ = ia else i=1 keep_going = .true. do while (i .le. ia .and. keep_going) i = i+1 - if (value .le. array(i)) then + if (rval .le. array(i)) then INDP_ = i - if (array(i)-value .gt. value-array(i-1)) INDP_ = i-1 + if (array(i)-rval .gt. rval-array(i-1)) INDP_ = i-1 keep_going = .false. endif enddo diff --git a/horiz_interp/include/horiz_interp_conserve.inc b/horiz_interp/include/horiz_interp_conserve.inc index 3fe5168e4b..0ec17fcacd 100644 --- a/horiz_interp/include/horiz_interp_conserve.inc +++ b/horiz_interp/include/horiz_interp_conserve.inc @@ -881,18 +881,18 @@ subroutine HORIZ_INTERP_CONSERVE_NEW_1DX1D_ ( Interp, lon_in, lat_in, lon_out, l !####################################################################### !> sums up the data and weights for a single output grid box - subroutine DATA_SUM_( data, area, facis, facie, facjs, facje, & + subroutine DATA_SUM_( grid_data, area, facis, facie, facjs, facje, & dwtsum, wtsum, arsum, mask ) !----------------------------------------------------------------------- - real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data, area + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: grid_data, area real(FMS_HI_KIND_), intent(in) :: facis, facie, facjs, facje real(FMS_HI_KIND_), intent(inout) :: dwtsum, wtsum, arsum real(FMS_HI_KIND_), intent(in), optional :: mask(:,:) ! fac__ = fractional portion of each boundary grid box included ! in the integral - ! dwtsum = sum(data*area*mask) + ! dwtsum = sum(grid_data*area*mask) ! wtsum = sum(area*mask) ! arsum = sum(area) !----------------------------------------------------------------------- @@ -914,10 +914,10 @@ subroutine HORIZ_INTERP_CONSERVE_NEW_1DX1D_ ( Interp, lon_in, lat_in, lon_out, l if (present(mask)) then wt = wt * mask - dwtsum = dwtsum + sum(wt*data) + dwtsum = dwtsum + sum(wt*grid_data) wtsum = wtsum + sum(wt) else - dwtsum = dwtsum + sum(wt*data) + dwtsum = dwtsum + sum(wt*grid_data) wtsum = wtsum + asum endif !----------------------------------------------------------------------- diff --git a/interpolator/include/interpolator.inc b/interpolator/include/interpolator.inc index 3c3668f3d2..c774593561 100644 --- a/interpolator/include/interpolator.inc +++ b/interpolator/include/interpolator.inc @@ -642,7 +642,7 @@ select case(ntime) if (non_monthly) then ! We have a broken time-line. e.g. We have monthly data but only for years ending in 0. 1960,1970 etc. -! allocate(clim_type%data(size(lonb_mod(:))-1, size(latb_mod(:))-1, nlev, 2, num_fields)) +! allocate(clim_type%data5d(size(lonb_mod(:))-1, size(latb_mod(:))-1, nlev, 2, num_fields)) allocate(clim_type%FMS_INTP_TYPE_%pmon_pyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields)) allocate(clim_type%FMS_INTP_TYPE_%pmon_nyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields)) allocate(clim_type%FMS_INTP_TYPE_%nmon_nyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields)) @@ -655,12 +655,12 @@ select case(ntime) else ! We have a continuous time-line so treat as for 5-12 timelevels as below. if ( .not. read_all_on_init) then - allocate(clim_type%FMS_INTP_TYPE_%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields)) + allocate(clim_type%FMS_INTP_TYPE_%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields)) else - allocate(clim_type%FMS_INTP_TYPE_%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, & + allocate(clim_type%FMS_INTP_TYPE_%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, & ntime, num_fields)) endif - clim_type%FMS_INTP_TYPE_%data = 0.0_lkind + clim_type%FMS_INTP_TYPE_%data5d = 0.0_lkind clim_type%TIME_FLAG = LINEAR endif @@ -672,26 +672,26 @@ endif ! Assume we have monthly or higher time resolution datasets (climatology or time series) ! So we only need to read 2 datasets and apply linear temporal interpolation. if ( .not. read_all_on_init) then - allocate(clim_type%FMS_INTP_TYPE_%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields)) + allocate(clim_type%FMS_INTP_TYPE_%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields)) else - allocate(clim_type%FMS_INTP_TYPE_%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, & + allocate(clim_type%FMS_INTP_TYPE_%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, & ntime, num_fields)) endif - clim_type%FMS_INTP_TYPE_%data = 0.0_lkind + clim_type%FMS_INTP_TYPE_%data5d = 0.0_lkind clim_type%TIME_FLAG = LINEAR !++lwh !case (1:4) ! Assume we have seasonal data and read in all the data. ! We can apply sine curves to these data. -! allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, ntime, num_fields)) -! clim_type%data = 0.0 +! allocate(clim_type%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, ntime, num_fields)) +! clim_type%data5d = 0.0 ! clim_type%TIME_FLAG = SEASONAL !--lwh ! case (default) case(:0) clim_type%TIME_FLAG = NOTIME - allocate(clim_type%FMS_INTP_TYPE_%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 1, num_fields)) + allocate(clim_type%FMS_INTP_TYPE_%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 1, num_fields)) end select @@ -818,7 +818,7 @@ if( clim_type%TIME_FLAG .eq. SEASONAL ) then do i=1,num_fields do n = 1, ntime call read_data( clim_type, clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,n,i), n, i, base_time ) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,n,i), n, i, base_time ) enddo enddo endif @@ -828,7 +828,7 @@ if( clim_type%TIME_FLAG .eq. LINEAR .and. read_all_on_init) then do i=1,num_fields do n = 1, ntime call read_data( clim_type, clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,n,i), n, i, base_time ) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,n,i), n, i, base_time ) enddo enddo @@ -839,7 +839,7 @@ if( clim_type%TIME_FLAG .eq. NOTIME ) then ! Read all the data at this point. do i=1,num_fields call read_data_no_time_axis( clim_type, clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,1,i), i ) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,1,i), i ) enddo call close_file (fileobj) endif @@ -850,14 +850,14 @@ endif end subroutine FMS2IO_INTERPOLATOR_INIT_ -subroutine GET_AXIS_LATLON_DATA_(fileobj, name, data) +subroutine GET_AXIS_LATLON_DATA_(fileobj, name, latlon_data) type(FmsNetcdfFile_t), intent(in) :: fileobj character(len=*), intent(in) :: name - real(FMS_INTP_KIND_), dimension(:), intent(out) :: data + real(FMS_INTP_KIND_), dimension(:), intent(out) :: latlon_data if(variable_exists(fileobj, name)) then - call fms2_io_read_data(fileobj, name, data) + call fms2_io_read_data(fileobj, name, latlon_data) else call mpp_error(FATAL,'get_axis_latlon_data: variable '// & & trim(name)//' does not exist in file '//trim(fileobj%path) ) @@ -865,7 +865,7 @@ subroutine GET_AXIS_LATLON_DATA_(fileobj, name, data) call get_variable_units(fileobj, name, units) select case(units(1:6)) case('degree') - data = data*real(DTR,FMS_INTP_KIND_) + latlon_data = latlon_data*real(DTR,FMS_INTP_KIND_) case('radian') case default call mpp_error(FATAL, "get_axis_latlon_data : Units for '// & @@ -875,10 +875,10 @@ subroutine GET_AXIS_LATLON_DATA_(fileobj, name, data) end subroutine GET_AXIS_LATLON_DATA_ -subroutine GET_AXIS_LEVEL_DATA_(fileobj, name, data, level_type, vertical_indices) +subroutine GET_AXIS_LEVEL_DATA_(fileobj, name, level_data, level_type, vertical_indices) type(FmsNetcdfFile_t), intent(in) :: fileobj character(len=*), intent(in) :: name - real(FMS_INTP_KIND_), dimension(:), intent(out) :: data + real(FMS_INTP_KIND_), dimension(:), intent(out) :: level_data integer, intent(out) :: level_type, vertical_indices real(FMS_INTP_KIND_), dimension(:), allocatable :: alpha integer :: n, nlev @@ -886,7 +886,7 @@ subroutine GET_AXIS_LEVEL_DATA_(fileobj, name, data, level_type, vertical_indice integer, parameter :: lkind=FMS_INTP_KIND_ if(variable_exists(fileobj, name)) then - call fms2_io_read_data(fileobj, name, data) + call fms2_io_read_data(fileobj, name, level_data) else call mpp_error(FATAL,'get_axis_level_data: variable '// & & trim(name)//' does not exist in file '//trim(fileobj%path) ) @@ -895,9 +895,9 @@ subroutine GET_AXIS_LEVEL_DATA_(fileobj, name, data, level_type, vertical_indice level_type = PRESSURE ! Convert to Pa if( trim(adjustl(lowercase(chomp(units)))) == "mb" .or. trim(adjustl(lowercase(chomp(units)))) == "hpa") then - data = data * 100._lkind + level_data = level_data * 100._lkind endif - nlev = size(data(:)) + nlev = size(level_data(:)) sense = get_variable_sense(fileobj, name) ! define the direction of the vertical data axis ! switch index order if necessary so that indx 1 is at lowest pressure, @@ -906,10 +906,10 @@ subroutine GET_AXIS_LEVEL_DATA_(fileobj, name, data, level_type, vertical_indice vertical_indices = INCREASING_UPWARD allocate (alpha(nlev)) do n = 1, nlev - alpha(n) = data(nlev-n+1) + alpha(n) = level_data(nlev-n+1) end do do n = 1, nlev - data(n) = alpha(n) + level_data(n) = alpha(n) end do deallocate (alpha) else @@ -1355,10 +1355,10 @@ integer, parameter :: lkind=FMS_INTP_KIND_ ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. do i=1, size(clim_type%field_name(:)) - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,1,i), taum,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum clim_type%itaum = 1 - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,2,i), taup,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,2,i), taup,i,Time) clim_type%time_init(i,2) = taup clim_type%itaup = 2 end do @@ -1374,7 +1374,7 @@ integer, parameter :: lkind=FMS_INTP_KIND_ if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 do i=1, size(clim_type%field_name(:)) call read_data(clim_type,clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,clim_type%itaup,i), taup,i, Time) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,clim_type%itaup,i), taup,i, Time) clim_type%time_init(i,clim_type%itaup)=taup end do endif @@ -1704,10 +1704,10 @@ if ( .not. clim_type%separate_time_vary_calc) then ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. do i=1, size(clim_type%field_name(:)) - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,1,i), taum,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum clim_type%itaum = 1 - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,2,i), taup,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,2,i), taup,i,Time) clim_type%time_init(i,2) = taup clim_type%itaup = 2 end do @@ -1723,7 +1723,7 @@ if ( .not. clim_type%separate_time_vary_calc) then if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 do i=1, size(clim_type%field_name(:)) call read_data(clim_type,clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,clim_type%itaup,i), taup,i, Time) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,clim_type%itaup,i), taup,i, Time) clim_type%time_init(i,clim_type%itaup)=taup end do endif @@ -1739,9 +1739,9 @@ select case(clim_type%TIME_FLAG) case (LINEAR) do n=1, size(clim_type%field_name(:)) hinterp_data(:,:,:,n) = (1._lkind-clim_type%FMS_INTP_TYPE_%tweight)* & - clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaum,n) + & + clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,clim_type%itaum,n) + & clim_type%FMS_INTP_TYPE_%tweight* & - clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaup,n) + clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,clim_type%itaup,n) end do ! case (SEASONAL) ! Do sine fit to data at this point @@ -2160,10 +2160,10 @@ if ( .not. clim_type%separate_time_vary_calc) then !Set up ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,1,i), taum,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum clim_type%itaum = 1 - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,2,i), taup,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,2,i), taup,i,Time) clim_type%time_init(i,2) = taup clim_type%itaup = 2 endif ! clim_type%itaum.eq.clim_type%itaup.eq.0 @@ -2177,7 +2177,7 @@ if ( .not. clim_type%separate_time_vary_calc) then clim_type%itaup = 1 if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 call read_data(clim_type,clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,clim_type%itaup,i), taup,i, Time) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,clim_type%itaup,i), taup,i, Time) clim_type%time_init(i,clim_type%itaup)=taup endif @@ -2188,9 +2188,9 @@ if ( .not. clim_type%separate_time_vary_calc) then select case(clim_type%TIME_FLAG) case (LINEAR) hinterp_data = (1._lkind-clim_type%FMS_INTP_TYPE_%tweight) * & - clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaum,i) + & + clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,clim_type%itaum,i) + & clim_type%FMS_INTP_TYPE_%tweight * & - clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaup,i) + clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,clim_type%itaup,i) ! case (SEASONAL) ! Do sine fit to data at this point case (BILINEAR) @@ -2615,10 +2615,10 @@ if ( .not. clim_type%separate_time_vary_calc) then !Set up ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,1,i), taum,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum clim_type%itaum = 1 - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,2,i), taup,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,2,i), taup,i,Time) clim_type%time_init(i,2) = taup clim_type%itaup = 2 endif ! clim_type%itaum.eq.clim_type%itaup.eq.0 @@ -2632,7 +2632,7 @@ if ( .not. clim_type%separate_time_vary_calc) then clim_type%itaup = 1 if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 call read_data(clim_type,clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,clim_type%itaup,i), taup,i, Time) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,clim_type%itaup,i), taup,i, Time) clim_type%time_init(i,clim_type%itaup)=taup endif endif! TIME_FLAG .eq. LINEAR .and. (.not. read_all_on_init) @@ -2644,8 +2644,9 @@ if ( .not. clim_type%separate_time_vary_calc) then select case(clim_type%TIME_FLAG) case (LINEAR) hinterp_data = (1._lkind-clim_type%FMS_INTP_TYPE_%tweight)*& - clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaum,i) & - + clim_type%FMS_INTP_TYPE_%tweight*clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaup,i) + clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,clim_type%itaum,i) & + + clim_type%FMS_INTP_TYPE_%tweight*clim_type%FMS_INTP_TYPE_%data5d & + (istart:iend,jstart:jend,:,clim_type%itaup,i) ! case (SEASONAL) ! Do sine fit to data at this point case (BILINEAR) @@ -2784,7 +2785,7 @@ if(present(clim_units)) then endif do n=1, size(clim_type%field_name(:)) - hinterp_data(:,:,:,n) = clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,1,n) + hinterp_data(:,:,:,n) = clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,1,n) end do select case(clim_type%level_type) @@ -2935,7 +2936,7 @@ do i= 1,size(clim_type%field_name(:)) clim_units = chomp(clim_units) endif - hinterp_data = clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,1,i) + hinterp_data = clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,1,i) select case(clim_type%level_type) case(PRESSURE) @@ -3065,7 +3066,7 @@ do i= 1,size(clim_type%field_name(:)) clim_units = chomp(clim_units) endif - hinterp_data = clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,1,i) + hinterp_data = clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,1,i) interp_data(:,:) = hinterp_data(:,:,1) diff --git a/interpolator/interpolator.F90 b/interpolator/interpolator.F90 index f04e327915..a00cf6b7c0 100644 --- a/interpolator/interpolator.F90 +++ b/interpolator/interpolator.F90 @@ -257,7 +257,7 @@ module interpolator_mod real(r4_kind), allocatable :: lonb(:) !< No description real(r4_kind), allocatable :: levs(:) !< No description real(r4_kind), allocatable :: halflevs(:) !< No description -real(r4_kind), allocatable :: data(:,:,:,:,:) !< (nlatmod,nlonmod,nlevclim,size(time_init,2),nfields) +real(r4_kind), allocatable :: data5d(:,:,:,:,:) !< (nlatmod,nlonmod,nlevclim,size(time_init,2),nfields) real(r4_kind), allocatable :: pmon_pyear(:,:,:,:) !< No description real(r4_kind), allocatable :: pmon_nyear(:,:,:,:) !< No description real(r4_kind), allocatable :: nmon_nyear(:,:,:,:) !< No description @@ -276,7 +276,7 @@ module interpolator_mod real(r8_kind), allocatable :: lonb(:) !< No description real(r8_kind), allocatable :: levs(:) !< No description real(r8_kind), allocatable :: halflevs(:) !< No description -real(r8_kind), allocatable :: data(:,:,:,:,:) !< (nlatmod,nlonmod,nlevclim,size(time_init,2),nfields) +real(r8_kind), allocatable :: data5d(:,:,:,:,:) !< (nlatmod,nlonmod,nlevclim,size(time_init,2),nfields) real(r8_kind), allocatable :: pmon_pyear(:,:,:,:) !< No description real(r8_kind), allocatable :: pmon_nyear(:,:,:,:) !< No description real(r8_kind), allocatable :: nmon_nyear(:,:,:,:) !< No description @@ -454,13 +454,13 @@ subroutine interpolate_type_eq (Out, In) if (allocated(In%out_of_bounds)) Out%out_of_bounds = In%out_of_bounds if (allocated(In%vert_interp )) Out%vert_interp = In%vert_interp if(In%r4_type%is_allocated) then - if (allocated(In%r4_type%data )) Out%r4_type%data = In%r4_type%data + if (allocated(In%r4_type%data5d )) Out%r4_type%data5d = In%r4_type%data5d if (allocated(In%r4_type%pmon_pyear )) Out%r4_type%pmon_pyear = In%r4_type%pmon_pyear if (allocated(In%r4_type%pmon_nyear )) Out%r4_type%pmon_nyear = In%r4_type%pmon_nyear if (allocated(In%r4_type%nmon_nyear )) Out%r4_type%nmon_nyear = In%r4_type%nmon_nyear if (allocated(In%r4_type%nmon_pyear )) Out%r4_type%nmon_pyear = In%r4_type%nmon_pyear else if(In%r8_type%is_allocated) then - if (allocated(In%r8_type%data )) Out%r8_type%data = In%r8_type%data + if (allocated(In%r8_type%data5d )) Out%r8_type%data5d = In%r8_type%data5d if (allocated(In%r8_type%pmon_pyear )) Out%r8_type%pmon_pyear = In%r8_type%pmon_pyear if (allocated(In%r8_type%pmon_nyear )) Out%r8_type%pmon_nyear = In%r8_type%pmon_nyear if (allocated(In%r8_type%nmon_nyear )) Out%r8_type%nmon_nyear = In%r8_type%nmon_nyear @@ -671,7 +671,7 @@ subroutine interpolator_end(clim_type) if (allocated (clim_type%r4_type%lonb )) deallocate(clim_type%r4_type%lonb) if (allocated (clim_type%r4_type%levs )) deallocate(clim_type%r4_type%levs) if (allocated (clim_type%r4_type%halflevs)) deallocate(clim_type%r4_type%halflevs) - if (allocated (clim_type%r4_type%data)) deallocate(clim_type%r4_type%data) + if (allocated (clim_type%r4_type%data5d )) deallocate(clim_type%r4_type%data5d) else if(clim_type%r8_type%is_allocated) then if (allocated (clim_type%r8_type%lat )) deallocate(clim_type%r8_type%lat) if (allocated (clim_type%r8_type%lon )) deallocate(clim_type%r8_type%lon) @@ -679,7 +679,7 @@ subroutine interpolator_end(clim_type) if (allocated (clim_type%r8_type%lonb )) deallocate(clim_type%r8_type%lonb) if (allocated (clim_type%r8_type%levs )) deallocate(clim_type%r8_type%levs) if (allocated (clim_type%r8_type%halflevs)) deallocate(clim_type%r8_type%halflevs) - if (allocated (clim_type%r8_type%data)) deallocate(clim_type%r8_type%data) + if (allocated (clim_type%r8_type%data5d)) deallocate(clim_type%r8_type%data5d) end if if (allocated (clim_type%time_slice)) deallocate(clim_type%time_slice) diff --git a/libFMS/Makefile.am b/libFMS/Makefile.am index db57f86562..4dea086bf2 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 18:0:0 # Add the convenience libraries to the FMS library. libFMS_la_LIBADD = $(top_builddir)/platform/libplatform.la diff --git a/mosaic2/mosaic2.F90 b/mosaic2/mosaic2.F90 index 0cb68f60ec..c76b30adb7 100644 --- a/mosaic2/mosaic2.F90 +++ b/mosaic2/mosaic2.F90 @@ -376,14 +376,14 @@ function transfer_to_model_index(istart, iend, refine_ratio) end function transfer_to_model_index !##################################################################### -function parse_string(string, set, value) +function parse_string(string, set, sval) character(len=*), intent(in) :: string character(len=*), intent(in) :: set - character(len=*), intent(out) :: value(:) + character(len=*), intent(out) :: sval(:) integer :: parse_string integer :: nelem, length, first, last - nelem = size(value(:)) + nelem = size(sval(:)) length = len_trim(string) first = 1; last = 0 @@ -392,17 +392,17 @@ function parse_string(string, set, value) 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(:))") + 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) + sval(parse_string) = string(first:length) exit else if(last <= first) then call mpp_error(FATAL, "mosaic_mod(parse_string) : last <= first") endif - value(parse_string) = string(first:(last-1)) + 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) diff --git a/mpp/include/mpp_comm_mpi.inc b/mpp/include/mpp_comm_mpi.inc index 928f9fcb92..d7fd2352ae 100644 --- a/mpp/include/mpp_comm_mpi.inc +++ b/mpp/include/mpp_comm_mpi.inc @@ -319,13 +319,13 @@ end subroutine mpp_exit ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> Broadcasts a character string from the given pe to it's pelist - subroutine mpp_broadcast_char(data, length, from_pe, pelist ) - character(len=*), intent(inout) :: data(:) !< Character string to send + subroutine mpp_broadcast_char(char_data, length, from_pe, pelist ) + character(len=*), intent(inout) :: char_data(:) !< Character string to send integer, intent(in) :: length !< length of given data to broadcast integer, intent(in) :: from_pe !< pe to broadcast from integer, intent(in), optional :: pelist(:) !< optional pelist to broadcast to integer :: n, i, from_rank - character :: str1D(length*size(data(:))) + character :: str1D(length*size(char_data(:))) pointer(lptr, str1D) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'mpp_broadcast_text: You must first call mpp_init.' ) @@ -351,8 +351,9 @@ end subroutine mpp_exit exit endif enddo - lptr = LOC (data) - if( mpp_npes().GT.1 ) call MPI_BCAST( data, length*size(data(:)), MPI_CHARACTER, from_rank, peset(n)%id, error ) + lptr = LOC (char_data) + if( mpp_npes().GT.1 ) call MPI_BCAST( char_data, length*size(char_data(:)), & + MPI_CHARACTER, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length ) return end subroutine mpp_broadcast_char diff --git a/mpp/include/mpp_comm_nocomm.inc b/mpp/include/mpp_comm_nocomm.inc index a1d849b831..895e8130e0 100644 --- a/mpp/include/mpp_comm_nocomm.inc +++ b/mpp/include/mpp_comm_nocomm.inc @@ -244,8 +244,8 @@ end subroutine mpp_exit return end subroutine mpp_set_stack_size - subroutine mpp_broadcast_char(data, length, from_pe, pelist ) - character(len=*), intent(inout) :: data(:) + subroutine mpp_broadcast_char(char_data, length, from_pe, pelist ) + character(len=*), intent(inout) :: char_data(:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) diff --git a/mpp/include/mpp_define_nest_domains.inc b/mpp/include/mpp_define_nest_domains.inc index e8eea60d00..883f68814c 100644 --- a/mpp/include/mpp_define_nest_domains.inc +++ b/mpp/include/mpp_define_nest_domains.inc @@ -1350,22 +1350,22 @@ subroutine compute_overlap_fine_to_coarse(nest_domain, overlap, position, name) end subroutine compute_overlap_fine_to_coarse -function find_index(array, data, start_pos) +function find_index(array, index_data, start_pos) integer, intent(in) :: array(:) - integer, intent(in) :: data + integer, intent(in) :: index_data integer, intent(in) :: start_pos integer :: find_index integer :: i find_index = 0 do i = start_pos, size(array) - if(array(i) == data) then + if(array(i) == index_data) then find_index = i exit endif enddo if(find_index == 0) then - print*, "start_pos = ", start_pos, data, array + print*, "start_pos = ", start_pos, index_data, array call mpp_error(FATAL, "mpp_define_nest_domains.inc: can not find data in array") endif diff --git a/mpp/include/mpp_do_get_boundary.fh b/mpp/include/mpp_do_get_boundary.fh index f346e6e629..a8c683bbf8 100644 --- a/mpp/include/mpp_do_get_boundary.fh +++ b/mpp/include/mpp_do_get_boundary.fh @@ -1012,7 +1012,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, tMe = 1 if( BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 diff --git a/mpp/include/mpp_do_get_boundary_ad.fh b/mpp/include/mpp_do_get_boundary_ad.fh index b2595e041a..b4d83786d6 100644 --- a/mpp/include/mpp_do_get_boundary_ad.fh +++ b/mpp/include/mpp_do_get_boundary_ad.fh @@ -580,7 +580,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun tMe = 1 if( BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 diff --git a/mpp/include/mpp_do_global_field.fh b/mpp/include/mpp_do_global_field.fh index f38d4054e1..7dfe2ab42b 100644 --- a/mpp/include/mpp_do_global_field.fh +++ b/mpp/include/mpp_do_global_field.fh @@ -107,8 +107,8 @@ else if( size(local,1).EQ.(domain%x(tile)%memory%size+ishift) .AND. & size(local,2).EQ.(domain%y(tile)%memory%size+jshift) )then !local is on data domain - ioff = -domain%x(tile)%data%begin + 1 - joff = -domain%y(tile)%data%begin + 1 + ioff = -domain%x(tile)%domain_data%begin + 1 + joff = -domain%y(tile)%domain_data%begin + 1 else call mpp_error( FATAL, & & 'MPP_GLOBAL_FIELD_: incoming field array must match either compute domain or memory domain.') @@ -374,8 +374,8 @@ else if( size(local,1).EQ.(domain%x(tile)%memory%size+ishift) .AND. & size(local,2).EQ.(domain%y(tile)%memory%size+jshift) )then !local is on data domain - ioff = -domain%x(tile)%data%begin - joff = -domain%y(tile)%data%begin + ioff = -domain%x(tile)%domain_data%begin + joff = -domain%y(tile)%domain_data%begin else call mpp_error( FATAL, & & 'MPP_GLOBAL_FIELD_: incoming field array must match either compute domain or memory domain.' ) diff --git a/mpp/include/mpp_do_global_field_ad.fh b/mpp/include/mpp_do_global_field_ad.fh index d32e6aa4b8..cb635cae11 100644 --- a/mpp/include/mpp_do_global_field_ad.fh +++ b/mpp/include/mpp_do_global_field_ad.fh @@ -109,8 +109,8 @@ else if( size(local,1).EQ.(domain%x(tile)%memory%size+ishift) .AND. size(local, & & 2).EQ.(domain%y(tile)%memory%size+jshift) )then !local is on data domain - ioff = -domain%x(tile)%data%begin + 1 - joff = -domain%y(tile)%data%begin + 1 + ioff = -domain%x(tile)%domain_data%begin + 1 + joff = -domain%y(tile)%domain_data%begin + 1 else call mpp_error( FATAL, & & 'MPP_GLOBAL_FIELD_: incoming field array must match either compute domain or memory domain.') diff --git a/mpp/include/mpp_do_redistribute.fh b/mpp/include/mpp_do_redistribute.fh index cf812b721c..26c9dc9ff3 100644 --- a/mpp/include/mpp_do_redistribute.fh +++ b/mpp/include/mpp_do_redistribute.fh @@ -22,11 +22,11 @@ integer(i8_kind), intent(in) :: f_in(:), f_out(:) type(DomainCommunicator2D), intent(in) :: d_comm MPP_TYPE_, intent(in) :: d_type - MPP_TYPE_ :: field_in(d_comm%domain_in%x(1)%data%begin:d_comm%domain_in%x(1)%data%end, & - d_comm%domain_in%y(1)%data%begin:d_comm%domain_in%y(1)%data%end,d_comm%ke) + MPP_TYPE_ :: field_in(d_comm%domain_in%x(1)%domain_data%begin:d_comm%domain_in%x(1)%domain_data%end, & + d_comm%domain_in%y(1)%domain_data%begin:d_comm%domain_in%y(1)%domain_data%end,d_comm%ke) pointer( ptr_field_in, field_in) - MPP_TYPE_ :: field_out(d_comm%domain_out%x(1)%data%begin:d_comm%domain_out%x(1)%data%end, & - d_comm%domain_out%y(1)%data%begin:d_comm%domain_out%y(1)%data%end,d_comm%ke) + MPP_TYPE_ :: field_out(d_comm%domain_out%x(1)%domain_data%begin:d_comm%domain_out%x(1)%domain_data%end, & + d_comm%domain_out%y(1)%domain_data%begin:d_comm%domain_out%y(1)%domain_data%end,d_comm%ke) pointer( ptr_field_out, field_out) type(domain2D), pointer :: domain_in, domain_out integer :: i, j, k, l, n, l_size diff --git a/mpp/include/mpp_do_updateV.fh b/mpp/include/mpp_do_updateV.fh index 4009cd2b1b..adc509b3fb 100644 --- a/mpp/include/mpp_do_updateV.fh +++ b/mpp/include/mpp_do_updateV.fh @@ -843,7 +843,7 @@ is = domain%x(1)%global%begin - 1 end if if( is.GT.isd )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) @@ -859,7 +859,7 @@ case(CGRID_NE) is = domain%x(1)%global%begin if( is.GT.isd )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) @@ -908,14 +908,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-south boundary j = domain%y(1)%global%begin - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then j = domain%y(1)%global%begin is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -936,15 +937,15 @@ select case(gridtype) case(BGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-south BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) fieldy(i,j,k) = fieldy(2*is-i,j,k) end do @@ -953,13 +954,13 @@ end if case(CGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-south CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) end do end do @@ -970,8 +971,8 @@ !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then - ie = domain%x(1)%data%end + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then + ie = domain%x(1)%domain_data%end is = is + 1 select case(gridtype) case(BGRID_NE) @@ -1003,14 +1004,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%begin - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%begin js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -1031,15 +1033,15 @@ select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-west BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) fieldy(i,j,k) = fieldy(i,2*js-j,k) end do @@ -1048,13 +1050,13 @@ end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-west CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) end do end do @@ -1065,8 +1067,8 @@ !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) @@ -1098,14 +1100,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%end+shift - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%end+shift js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -1126,15 +1129,15 @@ select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-east BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) fieldy(i,j,k) = fieldy(i,2*js-j,k) end do @@ -1143,13 +1146,13 @@ end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-east CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) end do end do @@ -1160,8 +1163,8 @@ !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) diff --git a/mpp/include/mpp_do_updateV_ad.fh b/mpp/include/mpp_do_updateV_ad.fh index 8d230f501c..f1d11ec809 100644 --- a/mpp/include/mpp_do_updateV_ad.fh +++ b/mpp/include/mpp_do_updateV_ad.fh @@ -403,7 +403,8 @@ if(domain%symmetry) shift = 1 if( BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(update_flags,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift ) then !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 @@ -411,7 +412,7 @@ is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift if( .NOT. domain%symmetry ) is = is - 1 do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -436,15 +437,15 @@ else is = domain%x(1)%global%begin - 1 end if - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(2*is-i,j,k) = fieldx(2*is-i,j,k) + fieldx(i,j,k) fieldy(2*is-i,j,k) = fieldy(2*is-i,j,k) + fieldy(i,j,k) end do @@ -453,13 +454,13 @@ end if case(CGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldy(2*is-i-1,j,k) = fieldy(2*is-i-1,j,k) + fieldy(i,j,k) end do end do @@ -470,8 +471,8 @@ !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then - ie = domain%x(1)%data%end + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then + ie = domain%x(1)%domain_data%end is = is + 1 select case(gridtype) case(BGRID_NE) @@ -503,14 +504,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-south boundary j = domain%y(1)%global%begin - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then j = domain%y(1)%global%begin is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -531,15 +533,15 @@ select case(gridtype) case(BGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-south BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(2*is-i,j,k) = fieldx(2*is-i,j,k) + fieldx(i,j,k) fieldy(2*is-i,j,k) = fieldy(2*is-i,j,k) + fieldy(i,j,k) end do @@ -548,13 +550,13 @@ end if case(CGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-south CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldy(2*is-i-1,j,k) = fieldy(2*is-i-1,j,k) + fieldy(i,j,k) end do end do @@ -565,8 +567,8 @@ !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then - ie = domain%x(1)%data%end + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then + ie = domain%x(1)%domain_data%end is = is + 1 select case(gridtype) case(BGRID_NE) @@ -598,14 +600,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%begin - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%begin js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -626,15 +629,15 @@ select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-west BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,2*js-j,k) = fieldx(i,2*js-j,k) + fieldx(i,j,k) fieldy(i,2*js-j,k) = fieldy(i,2*js-j,k) + fieldy(i,j,k) end do @@ -643,13 +646,13 @@ end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-west CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i, 2*js-j-1,k) = fieldx(i, 2*js-j-1,k) + fieldx(i,j,k) end do end do @@ -660,8 +663,8 @@ !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) @@ -693,14 +696,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%end+shift - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%end+shift js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -721,15 +725,15 @@ select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-east BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,2*js-j,k) = fieldx(i,2*js-j,k) + fieldx(i,j,k) fieldy(i,2*js-j,k) = fieldy(i,2*js-j,k) + fieldy(i,j,k) end do @@ -738,13 +742,13 @@ end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-east CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i, 2*js-j-1,k) = fieldx(i, 2*js-j-1,k) + fieldx(i,j,k) end do end do @@ -755,8 +759,8 @@ !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) diff --git a/mpp/include/mpp_do_updateV_nonblock.fh b/mpp/include/mpp_do_updateV_nonblock.fh index aa4a83607d..7ae9e73f14 100644 --- a/mpp/include/mpp_do_updateV_nonblock.fh +++ b/mpp/include/mpp_do_updateV_nonblock.fh @@ -707,7 +707,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u if(domain%symmetry) shift = 1 if( BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 @@ -715,7 +715,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift if( .NOT. domain%symmetry ) is = is - 1 do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -740,9 +740,9 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u else is = domain%x(1)%global%begin - 1 end if - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,l_size @@ -750,7 +750,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) fieldy(i,j,k) = fieldy(2*is-i,j,k) end do @@ -759,14 +759,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end if case(CGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) end do end do @@ -777,8 +777,8 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then - ie = domain%x(1)%data%end + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then + ie = domain%x(1)%domain_data%end is = is + 1 select case(gridtype) case(BGRID_NE) @@ -809,14 +809,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u else if( BTEST(domain%fold,SOUTH) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then ! ---southern boundary fold ! NOTE: symmetry is assumed for fold-south boundary j = domain%y(1)%global%begin - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then j = domain%y(1)%global%begin is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -837,15 +837,15 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u select case(gridtype) case(BGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-south BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) fieldy(i,j,k) = fieldy(2*is-i,j,k) end do @@ -854,14 +854,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end if case(CGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-south CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) end do end do @@ -872,8 +872,8 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then - ie = domain%x(1)%data%end + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then + ie = domain%x(1)%domain_data%end is = is + 1 select case(gridtype) case(BGRID_NE) @@ -904,14 +904,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u else if( BTEST(domain%fold,WEST) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then ! ---eastern boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%begin - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then !fold is within domain midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%begin js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -932,16 +932,16 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-west BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) fieldy(i,j,k) = fieldy(i,2*js-j,k) end do @@ -950,14 +950,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-west CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke_list(l,tMe) - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) end do end do @@ -968,8 +968,8 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) @@ -1000,14 +1000,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u else if( BTEST(domain%fold,EAST) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then ! ---eastern boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%end+shift - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then !fold is within domain midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%end+shift js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -1028,16 +1028,16 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-east BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) fieldy(i,j,k) = fieldy(i,2*js-j,k) end do @@ -1046,14 +1046,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-east CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke_list(l,tMe) - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) end do end do @@ -1064,8 +1064,8 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) diff --git a/mpp/include/mpp_domains_comm.inc b/mpp/include/mpp_domains_comm.inc index a092aaf41c..10940e048a 100644 --- a/mpp/include/mpp_domains_comm.inc +++ b/mpp/include/mpp_domains_comm.inc @@ -71,11 +71,11 @@ & 'MPP_REDISTRIBUTE_INIT_COMM: either domain_in or domain_out must be native.' ) !check sizes if( domain_in%pe /= NULL_PE )then - if( isize_in /= domain_in%x(1)%data%size .OR. jsize_in /= domain_in%y(1)%data%size ) & + if( isize_in /= domain_in%x(1)%domain_data%size .OR. jsize_in /= domain_in%y(1)%domain_data%size ) & call mpp_error( FATAL, 'MPP_REDISTRIBUTE_INIT_COMM: field_in must be on data domain of domain_in.' ) end if if( domain_out%pe /= NULL_PE )then - if( isize_out /= domain_out%x(1)%data%size .OR. jsize_out /= domain_out%y(1)%data%size ) & + if( isize_out /= domain_out%x(1)%domain_data%size .OR. jsize_out /= domain_out%y(1)%domain_data%size ) & call mpp_error( FATAL, 'MPP_REDISTRIBUTE_INIT_COMM: field_out must be on data domain of domain_out.' ) end if @@ -115,8 +115,8 @@ d_comm%S_msize=0 d_comm%S_do_buf=.false. - ioff = domain_in%x(1)%data%begin - joff = domain_in%y(1)%data%begin + ioff = domain_in%x(1)%domain_data%begin + joff = domain_in%y(1)%domain_data%begin mytile = domain_in%tile_id(1) call mpp_get_compute_domain( domain_in, isc, iec, jsc, jec ) @@ -256,8 +256,8 @@ joff = -domain%y(1)%compute%begin + 1 elseif( isize_l == (domain%x(1)%memory%size+ishift) .AND. jsize_l == (domain%y(1)%memory%size+jshift) )then !local is on data domain - ioff = -domain%x(1)%data%begin + 1 - joff = -domain%y(1)%data%begin + 1 + ioff = -domain%x(1)%domain_data%begin + 1 + joff = -domain%y(1)%domain_data%begin + 1 else call mpp_error(FATAL, & & 'MPP_GLOBAL_FIELD_INIT_COMM: incoming field array must match either compute domain or data domain.') diff --git a/mpp/include/mpp_domains_define.inc b/mpp/include/mpp_domains_define.inc index 5da34c5c47..b606aa3d20 100644 --- a/mpp/include/mpp_domains_define.inc +++ b/mpp/include/mpp_domains_define.inc @@ -408,41 +408,41 @@ !get data domain !data domain is at least equal to compute domain - domain%list(:)%data%begin = domain%list(:)%compute%begin - domain%list(:)%data%end = domain%list(:)%compute%end - domain%list(:)%data%is_global = .FALSE. + domain%list(:)%domain_data%begin = domain%list(:)%compute%begin + domain%list(:)%domain_data%end = domain%list(:)%compute%end + domain%list(:)%domain_data%is_global = .FALSE. !apply global flags if( data_domain_is_global )then - domain%list(:)%data%begin = isg - domain%list(:)%data%end = ieg - domain%list(:)%data%is_global = .TRUE. + domain%list(:)%domain_data%begin = isg + domain%list(:)%domain_data%end = ieg + domain%list(:)%domain_data%is_global = .TRUE. end if !apply margins - domain%list(:)%data%begin = domain%list(:)%data%begin - halobegin - domain%list(:)%data%end = domain%list(:)%data%end + haloend - domain%list(:)%data%size = domain%list(:)%data%end - domain%list(:)%data%begin + 1 + domain%list(:)%domain_data%begin = domain%list(:)%domain_data%begin - halobegin + domain%list(:)%domain_data%end = domain%list(:)%domain_data%end + haloend + domain%list(:)%domain_data%size = domain%list(:)%domain_data%end - domain%list(:)%domain_data%begin + 1 !--- define memory domain, if memory_size is not present or memory size is 0, memory domain size !--- will be the same as data domain size. if momory_size is present, memory_size should greater than !--- or equal to data size. The begin of memory domain will be always the same as data domain. - domain%list(:)%memory%begin = domain%list(:)%data%begin - domain%list(:)%memory%end = domain%list(:)%data%end + domain%list(:)%memory%begin = domain%list(:)%domain_data%begin + domain%list(:)%memory%end = domain%list(:)%domain_data%end if( present(memory_size) ) then if(memory_size > 0) then - if( domain%list(domain%pos)%data%size > memory_size ) call mpp_error(FATAL, & + if( domain%list(domain%pos)%domain_data%size > memory_size ) call mpp_error(FATAL, & "mpp_domains_define.inc: data domain size is larger than memory domain size on this pe") domain%list(:)%memory%end = domain%list(:)%memory%begin + memory_size - 1 end if end if domain%list(:)%memory%size = domain%list(:)%memory%end - domain%list(:)%memory%begin + 1 - domain%list(:)%memory%is_global = domain%list(:)%data%is_global + domain%list(:)%memory%is_global = domain%list(:)%domain_data%is_global domain%compute = domain%list(domain%pos)%compute - domain%data = domain%list(domain%pos)%data + domain%domain_data = domain%list(domain%pos)%domain_data domain%global = domain%list(domain%pos)%global domain%memory = domain%list(domain%pos)%memory domain%compute%max_size = MAXVAL( domain%list(:)%compute%size ) - domain%data%max_size = MAXVAL( domain%list(:)%data%size ) + domain%domain_data%max_size = MAXVAL( domain%list(:)%domain_data%size ) domain%global%max_size = domain%global%size domain%memory%max_size = domain%memory%size @@ -565,10 +565,10 @@ enddo io_domain%pos = n io_domain%x(1)%compute = domain%x(1)%compute - io_domain%x(1)%data = domain%x(1)%data + io_domain%x(1)%domain_data = domain%x(1)%domain_data io_domain%x(1)%memory = domain%x(1)%memory io_domain%y(1)%compute = domain%y(1)%compute - io_domain%y(1)%data = domain%y(1)%data + io_domain%y(1)%domain_data = domain%y(1)%domain_data io_domain%y(1)%memory = domain%y(1)%memory io_domain%x(1)%global%begin = domain%x(1)%list(ipos_beg)%compute%begin io_domain%x(1)%global%end = domain%x(1)%list(ipos_end)%compute%end @@ -907,7 +907,7 @@ if( PRESENT(xflags) )then if( BTEST(xflags,WEST) ) then !--- make sure no cross-domain in y-direction - if(domain%x(tile)%data%begin .LE. domain%x(tile)%global%begin .AND. & + if(domain%x(tile)%domain_data%begin .LE. domain%x(tile)%global%begin .AND. & domain%x(tile)%compute%begin > domain%x(tile)%global%begin ) then call mpp_error(FATAL, & 'MPP_DEFINE_DOMAINS: the domain could not be crossed when west is folded') @@ -919,7 +919,7 @@ endif if( BTEST(xflags,EAST) ) then !--- make sure no cross-domain in y-direction - if(domain%x(tile)%data%end .GE. domain%x(tile)%global%end .AND. & + if(domain%x(tile)%domain_data%end .GE. domain%x(tile)%global%end .AND. & domain%x(tile)%compute%end < domain%x(tile)%global%end ) then call mpp_error(FATAL, & 'MPP_DEFINE_DOMAINS: the domain could not be crossed when north is folded') @@ -933,7 +933,7 @@ if( PRESENT(yflags) )then if( BTEST(yflags,SOUTH) ) then !--- make sure no cross-domain in y-direction - if(domain%y(tile)%data%begin .LE. domain%y(tile)%global%begin .AND. & + if(domain%y(tile)%domain_data%begin .LE. domain%y(tile)%global%begin .AND. & domain%y(tile)%compute%begin > domain%y(tile)%global%begin ) then call mpp_error(FATAL, & 'MPP_DEFINE_DOMAINS: the domain could not be crossed when south is folded') @@ -1607,7 +1607,7 @@ end subroutine check_message_size type(overlap_type), pointer :: checkList(:)=>NULL() integer :: nsend, nrecv integer :: nsend_check, nrecv_check - integer :: unit + integer :: iunit logical :: set_check !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe. @@ -2140,15 +2140,15 @@ end subroutine check_message_size if(debug_message_passing) then !--- write out send information - unit = mpp_pe() + 1000 + iunit = mpp_pe() + 1000 do m =1,nsend - write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count + write(iunit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count do n = 1, overlapList(m)%count - write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & + write(iunit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & overlapList(m)%dir(n), overlapList(m)%rotation(n) enddo enddo - if(nsend >0) flush(unit) + if(nsend >0) flush(iunit) endif ! copy the overlapping information into domain data structure @@ -2719,15 +2719,15 @@ end subroutine check_message_size if(debug_message_passing) then !--- write out send information - unit = mpp_pe() + 1000 + iunit = mpp_pe() + 1000 do m =1,nrecv - write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count + write(iunit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count do n = 1, overlapList(m)%count - write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & + write(iunit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & overlapList(m)%dir(n), overlapList(m)%rotation(n) enddo enddo - if(nrecv >0) flush(unit) + if(nrecv >0) flush(iunit) endif ! copy the overlapping information into domain @@ -3017,7 +3017,7 @@ end subroutine check_message_size type(overlapSpec), pointer :: check =>NULL() integer :: nsend, nrecv integer :: nsend_check, nrecv_check - integer :: unit + integer :: iunit !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe. !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile @@ -3267,8 +3267,8 @@ end subroutine check_message_size !--- Now calculate the overlapping for fold-edge. !--- only position at NORTH and CORNER need to be considered if( ( position == NORTH .OR. position == CORNER) ) then - if( domain%y(tMe)%data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%data%end+jshift )then !fold - !! is within domain + !fold is within domain + if( domain%y(tMe)%domain_data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%domain_data%end+jshift )then dir = 3 !--- calculate the overlapping for sending if( domain%x(tMe)%pos .LT. (size(domain%x(tMe)%list(:))+1)/2 )then @@ -3312,15 +3312,15 @@ end subroutine check_message_size if(debug_message_passing) then !--- write out send information - unit = mpp_pe() + 1000 + iunit = mpp_pe() + 1000 do m =1,nsend - write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count + write(iunit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count do n = 1, overlapList(m)%count - write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & + write(iunit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & overlapList(m)%dir(n), overlapList(m)%rotation(n) enddo enddo - if( nsend > 0) flush(unit) + if( nsend > 0) flush(iunit) endif ! copy the overlapping information into domain data structure @@ -3367,7 +3367,7 @@ end subroutine check_message_size jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift !recv_e dir = 1 - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec if( (position == NORTH .OR. position == CORNER ) .AND. ( jsd == je .or. jed == js ) ) then @@ -3402,8 +3402,8 @@ end subroutine check_message_size !recv_se dir = 2 folded = .false. - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( jsd.LT.jsg )then folded = .true. @@ -3419,7 +3419,7 @@ end subroutine check_message_size dir = 3 folded = .false. isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( jsd.LT.jsg )then folded = .true. @@ -3441,8 +3441,8 @@ end subroutine check_message_size !recv_sw dir = 4 folded = .false. - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( jsd.LT.jsg )then folded = .true. @@ -3462,7 +3462,7 @@ end subroutine check_message_size !recv_w dir = 5 - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec if( (position == NORTH .OR. position == CORNER ) .AND. ( jsd == je .or. jed == js ) ) then @@ -3506,8 +3506,8 @@ end subroutine check_message_size !recv_nw dir = 6 - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( isd.LT.isg .AND. is.GE.ied )then !cyclic offset is = is-ioff; ie = ie-ioff @@ -3519,15 +3519,15 @@ end subroutine check_message_size !recv_n dir = 7 isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec call insert_update_overlap( overlap, domain%list(m)%pe, & is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry) !recv_ne dir = 8 - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( ied.GT.ieg .AND. ie.LT.isd )then ! cyclic offset is = is+ioff; ie = ie+ioff @@ -3539,8 +3539,8 @@ end subroutine check_message_size !--- for folded-south-edge, only need to consider to_pe's south(3) direction !--- only position at NORTH and CORNER need to be considered if( ( position == NORTH .OR. position == CORNER) ) then - if( domain%y(tMe)%data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%data%end+jshift )then !fold - !! is within domain + !fold is within domain + if( domain%y(tMe)%domain_data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%domain_data%end+jshift )then dir = 3 !--- calculating overlapping for receving on north if( domain%x(tMe)%pos .GE. size(domain%x(tMe)%list(:))/2 )then @@ -3585,15 +3585,15 @@ end subroutine check_message_size if(debug_message_passing) then !--- write out send information - unit = mpp_pe() + 1000 + iunit = mpp_pe() + 1000 do m =1,nrecv - write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count + write(iunit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count do n = 1, overlapList(m)%count - write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & + write(iunit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & overlapList(m)%dir(n), overlapList(m)%rotation(n) enddo enddo - if(nrecv >0) flush(unit) + if(nrecv >0) flush(iunit) endif ! copy the overlapping information into domain @@ -3662,7 +3662,7 @@ end subroutine check_message_size type(overlapSpec), pointer :: check =>NULL() integer :: nsend, nrecv integer :: nsend_check, nrecv_check - integer :: unit + integer :: iunit !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe. !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile @@ -3907,8 +3907,8 @@ end subroutine check_message_size !--- Now calculate the overlapping for fold-edge. !--- only position at EAST and CORNER need to be considered if( ( position == EAST .OR. position == CORNER) ) then - if( domain%x(tMe)%compute%begin-whalo .LE. isg .AND. isg .LE. domain%x(tMe)%data%end+ishift )then !fold - !! is within domain + !fold is within domain + if( domain%x(tMe)%compute%begin-whalo .LE. isg .AND. isg .LE. domain%x(tMe)%domain_data%end+ishift )then dir = 5 !--- calculate the overlapping for sending if( domain%y(tMe)%pos .LT. (size(domain%y(tMe)%list(:))+1)/2 )then @@ -3950,15 +3950,15 @@ end subroutine check_message_size if(debug_message_passing) then !--- write out send information - unit = mpp_pe() + 1000 + iunit = mpp_pe() + 1000 do m =1,nsend - write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count + write(iunit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count do n = 1, overlapList(m)%count - write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & + write(iunit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & overlapList(m)%dir(n), overlapList(m)%rotation(n) enddo enddo - if(nsend >0) flush(unit) + if(nsend >0) flush(iunit) endif ! copy the overlapping information into domain data structure @@ -4000,7 +4000,7 @@ end subroutine check_message_size jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift !recv_e dir = 1 - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec call insert_update_overlap( overlap, domain%list(m)%pe, & @@ -4008,8 +4008,8 @@ end subroutine check_message_size !recv_se dir = 2 - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( jsd.LT.jsg .AND. js.GE.jed )then ! cyclic is assumed js = js-joff; je = je-joff @@ -4021,7 +4021,7 @@ end subroutine check_message_size dir = 3 folded = .false. isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then @@ -4065,8 +4065,8 @@ end subroutine check_message_size !recv_sw dir = 4 folded = .false. - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( isd.LT.isg )then folded = .true. @@ -4087,7 +4087,7 @@ end subroutine check_message_size !recv_w dir = 5 folded = .false. - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec if( isd.LT.isg )then @@ -4110,8 +4110,8 @@ end subroutine check_message_size !recv_nw dir = 6 folded = .false. - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( isd.LT.isg) then folded = .true. @@ -4128,7 +4128,7 @@ end subroutine check_message_size dir = 7 folded = .false. isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then !--- do nothing, this point will come from other pe @@ -4159,8 +4159,8 @@ end subroutine check_message_size !recv_ne dir = 8 - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( jed.GT.jeg .AND. je.LT.jsd )then ! cyclic offset js = js+joff; je = je+joff @@ -4172,8 +4172,8 @@ end subroutine check_message_size !--- for folded-south-edge, only need to consider to_pe's south(3) direction !--- only position at EAST and CORNER need to be considered if( ( position == EAST .OR. position == CORNER) ) then - if( domain%x(tMe)%data%begin .LE. isg .AND. isg .LE. domain%x(tMe)%data%end+ishift )then !fold - !! is within domain + !fold is within domain + if( domain%x(tMe)%domain_data%begin .LE. isg .AND. isg .LE. domain%x(tMe)%domain_data%end+ishift )then dir = 5 !--- calculating overlapping for receving on north if( domain%y(tMe)%pos .GE. size(domain%y(tMe)%list(:))/2 )then @@ -4216,15 +4216,15 @@ end subroutine check_message_size if(debug_message_passing) then !--- write out send information - unit = mpp_pe() + 1000 + iunit = mpp_pe() + 1000 do m =1,nrecv - write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count + write(iunit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count do n = 1, overlapList(m)%count - write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & + write(iunit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), & overlapList(m)%dir(n), overlapList(m)%rotation(n) enddo enddo - if(nrecv >0) flush(unit) + if(nrecv >0) flush(iunit) endif ! copy the overlapping information into domain @@ -4536,8 +4536,8 @@ end subroutine check_message_size !--- Now calculate the overlapping for fold-edge. !--- only position at EAST and CORNER need to be considered if( ( position == EAST .OR. position == CORNER) ) then - if( domain%x(tMe)%data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%data%end+ishift )then !fold - !! is within domain + !fold is within domain + if( domain%x(tMe)%domain_data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%domain_data%end+ishift )then dir = 1 !--- calculate the overlapping for sending if( domain%y(tMe)%pos .LT. (size(domain%y(tMe)%list(:))+1)/2 )then @@ -4617,7 +4617,7 @@ end subroutine check_message_size !recv_e dir = 1 folded = .false. - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec if( ied.GT.ieg )then @@ -4640,8 +4640,8 @@ end subroutine check_message_size !recv_se dir = 2 folded = .false. - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( ied.GT.ieg )then folded = .true. @@ -4663,7 +4663,7 @@ end subroutine check_message_size dir = 3 folded = .false. isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then @@ -4706,8 +4706,8 @@ end subroutine check_message_size !recv_sw dir = 4 - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( jsd.LT.jsg .AND. js.GE.jed )then ! cyclic is assumed js = js-joff; je = je-joff @@ -4717,7 +4717,7 @@ end subroutine check_message_size !recv_w dir = 5 - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec call insert_update_overlap( overlap, domain%list(m)%pe, & @@ -4726,8 +4726,8 @@ end subroutine check_message_size !recv_nw dir = 6 folded = .false. - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( jed.GT.jeg .AND. je.LT.jsd )then ! cyclic offset js = js+joff; je = je+joff @@ -4739,7 +4739,7 @@ end subroutine check_message_size dir = 7 folded = .false. isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then !--- do nothing, this point will come from other pe @@ -4771,8 +4771,8 @@ end subroutine check_message_size !recv_ne dir = 8 folded = .false. - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( ied.GT.ieg) then folded = .true. @@ -4788,8 +4788,8 @@ end subroutine check_message_size !--- for folded-south-edge, only need to consider to_pe's south(3) direction !--- only position at EAST and CORNER need to be considered if( ( position == EAST .OR. position == CORNER) ) then - if( domain%x(tMe)%data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%data%end+ishift )then !fold - !! is within domain + !fold is within domain + if( domain%x(tMe)%domain_data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%domain_data%end+ishift )then dir = 1 !--- calculating overlapping for receving on north if( domain%y(tMe)%pos .GE. size(domain%y(tMe)%list(:))/2 )then @@ -5319,7 +5319,7 @@ end subroutine check_message_size integer :: nsend, nrecv, nsend2, nrecv2 type(contact_type), dimension(domain%ntiles) :: eCont, wCont, sCont, nCont type(overlap_type), dimension(0:size(domain%list(:))-1) :: overlapSend, overlapRecv - integer :: unit + integer :: iunit if( position .NE. CENTER ) call mpp_error(FATAL, "mpp_domains_define.inc: " //& "routine define_contact_point can only be used to calculate overlapping for cell center.") @@ -5702,32 +5702,32 @@ end subroutine check_message_size select case ( dir ) case ( 1 ) ! eastern halo if( align1Recv(n) .NE. EAST ) cycle - isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end + isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%domain_data%end jsd2 = domain%y(tMe)%compute%begin; jed2 = domain%y(tMe)%compute%end case ( 2 ) ! southeast halo - isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end - jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1 + isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%domain_data%end + jsd2 = domain%y(tMe)%domain_data%begin; jed2 = domain%y(tMe)%compute%begin-1 case ( 3 ) ! southern halo if( align1Recv(n) .NE. SOUTH ) cycle isd2 = domain%x(tMe)%compute%begin; ied2 = domain%x(tMe)%compute%end - jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1 + jsd2 = domain%y(tMe)%domain_data%begin; jed2 = domain%y(tMe)%compute%begin-1 case ( 4 ) ! southwest halo - isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1 - jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1 + isd2 = domain%x(tMe)%domain_data%begin; ied2 = domain%x(tMe)%compute%begin-1 + jsd2 = domain%y(tMe)%domain_data%begin; jed2 = domain%y(tMe)%compute%begin-1 case ( 5 ) ! western halo if( align1Recv(n) .NE. WEST ) cycle - isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1 + isd2 = domain%x(tMe)%domain_data%begin; ied2 = domain%x(tMe)%compute%begin-1 jsd2 = domain%y(tMe)%compute%begin; jed2 = domain%y(tMe)%compute%end case ( 6 ) ! northwest halo - isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1 - jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end + isd2 = domain%x(tMe)%domain_data%begin; ied2 = domain%x(tMe)%compute%begin-1 + jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%domain_data%end case ( 7 ) ! northern halo if( align1Recv(n) .NE. NORTH ) cycle isd2 = domain%x(tMe)%compute%begin; ied2 = domain%x(tMe)%compute%end - jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end + jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%domain_data%end case ( 8 ) ! northeast halo - isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end - jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end + isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%domain_data%end + jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%domain_data%end end select is = max(isd1,isd2); ie = min(ied1,ied2) js = max(jsd1,jsd2); je = min(jed1,jed2) @@ -5753,17 +5753,17 @@ end subroutine check_message_size if(debug_message_passing) then !--- write out send information - unit = mpp_pe() + 1000 + iunit = mpp_pe() + 1000 do list = 0, nlist-1 m = mod( domain%pos+list, nlist ) if(overlapSend(m)%count==0) cycle - write(unit, *) "********to_pe = " ,overlapSend(m)%pe, " count = ",overlapSend(m)%count + write(iunit, *) "********to_pe = " ,overlapSend(m)%pe, " count = ",overlapSend(m)%count do n = 1, overlapSend(m)%count - write(unit, *) overlapSend(m)%is(n), overlapSend(m)%ie(n), overlapSend(m)%js(n), overlapSend(m)%je(n), & + write(iunit, *) overlapSend(m)%is(n), overlapSend(m)%ie(n), overlapSend(m)%js(n), overlapSend(m)%je(n), & overlapSend(m)%dir(n), overlapSend(m)%rotation(n) enddo enddo - if(nsend >0) flush(unit) + if(nsend >0) flush(iunit) endif dirlist(1) = 1; dirlist(2) = 3; dirlist(3) = 5; dirlist(4) = 7 @@ -5827,13 +5827,13 @@ end subroutine check_message_size do list = 0, nlist-1 m = mod( domain%pos+list, nlist ) if(overlapRecv(m)%count==0) cycle - write(unit, *) "********from_pe = " ,overlapRecv(m)%pe, " count = ",overlapRecv(m)%count + write(iunit, *) "********from_pe = " ,overlapRecv(m)%pe, " count = ",overlapRecv(m)%count do n = 1, overlapRecv(m)%count - write(unit, *) overlapRecv(m)%is(n), overlapRecv(m)%ie(n), overlapRecv(m)%js(n), overlapRecv(m)%je(n), & + write(iunit, *) overlapRecv(m)%is(n), overlapRecv(m)%ie(n), overlapRecv(m)%js(n), overlapRecv(m)%je(n), & overlapRecv(m)%dir(n), overlapRecv(m)%rotation(n) enddo enddo - if(nrecv >0) flush(unit) + if(nrecv >0) flush(iunit) endif if(nrecv >0) then @@ -7554,7 +7554,7 @@ ndivs = size(domain_in%list(:)) ! get the flag flag = 0 if(domain_in%cyclic) flag = flag + CYCLIC_GLOBAL_DOMAIN -if(domain_in%data%is_global) flag = flag + GLOBAL_DATA_DOMAIN +if(domain_in%domain_data%is_global) flag = flag + GLOBAL_DATA_DOMAIN call mpp_define_domains( global_indices, ndivs, domain_out, pelist = domain_in%list(:)%pe, & flags = flag, begin_halo = hbegin, end_halo = hend, extent = domain_in%list(:)%compute%size ) @@ -7594,9 +7594,9 @@ if(present(whalo) .or. present(ehalo) .or. present(shalo) .or. present(nhalo) ) ! get the flag xflag = 0; yflag = 0 if(domain_in%x(1)%cyclic) xflag = xflag + CYCLIC_GLOBAL_DOMAIN - if(domain_in%x(1)%data%is_global) xflag = xflag + GLOBAL_DATA_DOMAIN + if(domain_in%x(1)%domain_data%is_global) xflag = xflag + GLOBAL_DATA_DOMAIN if(domain_in%y(1)%cyclic) yflag = yflag + CYCLIC_GLOBAL_DOMAIN - if(domain_in%y(1)%data%is_global) yflag = yflag + GLOBAL_DATA_DOMAIN + if(domain_in%y(1)%domain_data%is_global) yflag = yflag + GLOBAL_DATA_DOMAIN call mpp_define_domains( global_indices, layout, domain_out, pelist = domain_in%list(:)%pe, & xflags = xflag, yflags = yflag, whalo = whalo, ehalo = ehalo, & @@ -7632,7 +7632,7 @@ subroutine mpp_define_null_domain1D(domain) type(domain1D), intent(inout) :: domain domain%global%begin = -1; domain%global%end = -1; domain%global%size = 0 -domain%data%begin = -1; domain%data%end = -1; domain%data%size = 0 +domain%domain_data%begin = -1; domain%domain_data%end = -1; domain%domain_data%size = 0 domain%compute%begin = -1; domain%compute%end = -1; domain%compute%size = 0 domain%pe = NULL_PE diff --git a/mpp/include/mpp_domains_misc.inc b/mpp/include/mpp_domains_misc.inc index 2c8de69237..f64dd2fc77 100644 --- a/mpp/include/mpp_domains_misc.inc +++ b/mpp/include/mpp_domains_misc.inc @@ -44,14 +44,14 @@ subroutine mpp_domains_init(flags) integer, intent(in), optional :: flags integer :: n - integer :: io_status, unit + integer :: io_status, iunit if( module_is_initialized )return call mpp_init(flags) !this is a no-op if already initialized module_is_initialized = .TRUE. pe = mpp_root_pe() - unit = stdlog() - if( mpp_pe() .EQ.mpp_root_pe() ) write( unit,'(/a)' )'MPP_DOMAINS module '//trim(version) + iunit = stdlog() + if( mpp_pe() .EQ.mpp_root_pe() ) write( iunit,'(/a)' )'MPP_DOMAINS module '//trim(version) if( PRESENT(flags) )then debug = flags.EQ.MPP_DEBUG @@ -164,11 +164,11 @@ end subroutine init_nonblock_type !! Serves no particular purpose, but is provided should you require to !! re-initialize mpp_domains_mod, for some odd reason. subroutine mpp_domains_exit() - integer :: unit + integer :: iunit if( .NOT.module_is_initialized )return call mpp_max(mpp_domains_stack_hwm) - unit = stdout() - if( mpp_pe().EQ.mpp_root_pe() )write( unit,* )'MPP_DOMAINS_STACK high water mark=', mpp_domains_stack_hwm + iunit = stdout() + if( mpp_pe().EQ.mpp_root_pe() )write( iunit,* )'MPP_DOMAINS_STACK high water mark=', mpp_domains_stack_hwm module_is_initialized = .FALSE. return end subroutine mpp_domains_exit @@ -507,10 +507,10 @@ end subroutine init_nonblock_type domain%x%compute%end = -1 domain%y%compute%begin = 1 domain%y%compute%end = -1 - domain%x%data %begin = -1 - domain%x%data %end = -1 - domain%y%data %begin = -1 - domain%y%data %end = -1 + domain%x%domain_data %begin = -1 + domain%x%domain_data %end = -1 + domain%y%domain_data %begin = -1 + domain%y%domain_data %end = -1 domain%x%global %begin = -1 domain%x%global %end = -1 domain%y%global %begin = -1 @@ -552,10 +552,10 @@ end subroutine init_nonblock_type domain%list(listpos)%y%compute%end = msg(5) domain%list(listpos)%tile_id(1) = msg(6) if(domain%x(1)%global%begin < 0) then - domain%x(1)%data %begin = msg(2) - domain%x(1)%data %end = msg(3) - domain%y(1)%data %begin = msg(4) - domain%y(1)%data %end = msg(5) + domain%x(1)%domain_data %begin = msg(2) + domain%x(1)%domain_data %end = msg(3) + domain%y(1)%domain_data %begin = msg(4) + domain%y(1)%domain_data %end = msg(5) domain%x(1)%global%begin = msg(2) domain%x(1)%global%end = msg(3) domain%y(1)%global%begin = msg(4) @@ -571,10 +571,10 @@ end subroutine init_nonblock_type endif domain%ntiles = msg(12) else - domain%x(1)%data %begin = msg(2) - msg(7) - domain%x(1)%data %end = msg(3) + msg(8) - domain%y(1)%data %begin = msg(4) - msg(9) - domain%y(1)%data %end = msg(5) + msg(10) + domain%x(1)%domain_data %begin = msg(2) - msg(7) + domain%x(1)%domain_data %end = msg(3) + msg(8) + domain%y(1)%domain_data %begin = msg(4) - msg(9) + domain%y(1)%domain_data %end = msg(5) + msg(10) domain%x(1)%global%begin = min(domain%x(1)%global%begin, msg(2)) domain%x(1)%global%end = max(domain%x(1)%global%end, msg(3)) domain%y(1)%global%begin = min(domain%y(1)%global%begin, msg(4)) @@ -633,10 +633,10 @@ end subroutine init_nonblock_type domain_out%x%compute%end = -1 domain_out%y%compute%begin = 1 domain_out%y%compute%end = -1 - domain_out%x%data %begin = -1 - domain_out%x%data %end = -1 - domain_out%y%data %begin = -1 - domain_out%y%data %end = -1 + domain_out%x%domain_data %begin = -1 + domain_out%x%domain_data %end = -1 + domain_out%y%domain_data %begin = -1 + domain_out%y%domain_data %end = -1 domain_out%x%global %begin = -1 domain_out%x%global %end = -1 domain_out%y%global %begin = -1 @@ -684,10 +684,10 @@ end subroutine init_nonblock_type domain_out%list(listpos)%y%compute%end = msg(5) domain_out%list(listpos)%tile_id(1) = msg(6) if(domain_out%x(1)%global%begin < 0) then - domain_out%x(1)%data %begin = msg(2) - domain_out%x(1)%data %end = msg(3) - domain_out%y(1)%data %begin = msg(4) - domain_out%y(1)%data %end = msg(5) + domain_out%x(1)%domain_data %begin = msg(2) + domain_out%x(1)%domain_data %end = msg(3) + domain_out%y(1)%domain_data %begin = msg(4) + domain_out%y(1)%domain_data %end = msg(5) domain_out%x(1)%global%begin = msg(2) domain_out%x(1)%global%end = msg(3) domain_out%y(1)%global%begin = msg(4) @@ -703,10 +703,10 @@ end subroutine init_nonblock_type endif domain_out%ntiles = msg(12) else - domain_out%x(1)%data %begin = msg(2) - msg(7) - domain_out%x(1)%data %end = msg(3) + msg(8) - domain_out%y(1)%data %begin = msg(4) - msg(9) - domain_out%y(1)%data %end = msg(5) + msg(10) + domain_out%x(1)%domain_data %begin = msg(2) - msg(7) + domain_out%x(1)%domain_data %end = msg(3) + msg(8) + domain_out%y(1)%domain_data %begin = msg(4) - msg(9) + domain_out%y(1)%domain_data %end = msg(5) + msg(10) domain_out%x(1)%global%begin = min(domain_out%x(1)%global%begin, msg(2)) domain_out%x(1)%global%end = max(domain_out%x(1)%global%end, msg(3)) domain_out%y(1)%global%begin = min(domain_out%y(1)%global%begin, msg(4)) @@ -771,10 +771,10 @@ end subroutine init_nonblock_type domain%x%compute%end = -1 domain%y%compute%begin = 0 domain%y%compute%end = -1 - domain%x%data %begin = 0 - domain%x%data %end = -1 - domain%y%data %begin = 0 - domain%y%data %end = -1 + domain%x%domain_data %begin = 0 + domain%x%domain_data %end = -1 + domain%y%domain_data %begin = 0 + domain%y%domain_data %end = -1 domain%x%global %begin = 0 domain%x%global %end = -1 domain%y%global %begin = 0 @@ -888,10 +888,10 @@ end subroutine init_nonblock_type domain%x%compute%end = -1 domain%y%compute%begin = 0 domain%y%compute%end = -1 - domain%x%data %begin = 0 - domain%x%data %end = -1 - domain%y%data %begin = 0 - domain%y%data %end = -1 + domain%x%domain_data %begin = 0 + domain%x%domain_data %end = -1 + domain%y%domain_data %begin = 0 + domain%y%domain_data %end = -1 domain%x%global %begin = 0 domain%x%global %end = -1 domain%y%global %begin = 0 @@ -930,10 +930,10 @@ end subroutine init_nonblock_type if( .NOT.native .AND. msg(1).NE.NULL_PE .AND. tile_coarse==msg(16) )then domain%list(listpos)%pe = msg(1) if(domain%x(1)%compute%begin == 0) then - domain%x(1)%data %begin = msg(2) - msg(7) - domain%x(1)%data %end = msg(3) + msg(8) - domain%y(1)%data %begin = msg(4) - msg(9) - domain%y(1)%data %end = msg(5) + msg(10) + domain%x(1)%domain_data %begin = msg(2) - msg(7) + domain%x(1)%domain_data %end = msg(3) + msg(8) + domain%y(1)%domain_data %begin = msg(4) - msg(9) + domain%y(1)%domain_data %end = msg(5) + msg(10) domain%x(1)%global%begin = msg(12) domain%x(1)%global%end = msg(13) domain%y(1)%global%begin = msg(14) diff --git a/mpp/include/mpp_domains_util.inc b/mpp/include/mpp_domains_util.inc index 3d72df4a43..a8210895ed 100644 --- a/mpp/include/mpp_domains_util.inc +++ b/mpp/include/mpp_domains_util.inc @@ -63,8 +63,8 @@ mpp_domain1D_eq = ( a%compute%begin.EQ.b%compute%begin .AND. & a%compute%end .EQ.b%compute%end .AND. & - a%data%begin .EQ.b%data%begin .AND. & - a%data%end .EQ.b%data%end .AND. & + a%domain_data%begin .EQ.b%domain_data%begin .AND. & + a%domain_data%end .EQ.b%domain_data%end .AND. & a%global%begin .EQ.b%global%begin .AND. & a%global%end .EQ.b%global%end ) !compare pelists @@ -140,11 +140,11 @@ integer, intent(out), optional :: begin, end, size, max_size logical, intent(out), optional :: is_global - if( PRESENT(begin) )begin = domain%data%begin - if( PRESENT(end) )end = domain%data%end - if( PRESENT(size) )size = domain%data%size - if( PRESENT(max_size) )max_size = domain%data%max_size - if( PRESENT(is_global) )is_global = domain%data%is_global + if( PRESENT(begin) )begin = domain%domain_data%begin + if( PRESENT(end) )end = domain%domain_data%end + if( PRESENT(size) )size = domain%domain_data%size + if( PRESENT(max_size) )max_size = domain%domain_data%max_size + if( PRESENT(is_global) )is_global = domain%domain_data%is_global return end subroutine mpp_get_data_domain1D @@ -320,8 +320,8 @@ call mpp_set_super_grid_indices(domain%list(i-1)%y(1)%compute) !< There is no data domain in domain%list - !call mpp_set_super_grid_indices(domain%list(i-1)%x(1)%data) - !call mpp_set_super_grid_indices(domain%list(i-1)%y(1)%data) + !call mpp_set_super_grid_indices(domain%list(i-1)%x(1)%domain_data) + !call mpp_set_super_grid_indices(domain%list(i-1)%y(1)%domain_data) enddo do i=1, size(domain%x(1)%list) @@ -370,10 +370,10 @@ integer, intent(in), optional :: begin, end, size logical, intent(in), optional :: is_global - if(present(begin)) domain%data%begin = begin - if(present(end)) domain%data%end = end - if(present(size)) domain%data%size = size - if(present(is_global)) domain%data%is_global = is_global + if(present(begin)) domain%domain_data%begin = begin + if(present(end)) domain%domain_data%end = end + if(present(size)) domain%domain_data%size = size + if(present(is_global)) domain%domain_data%is_global = is_global end subroutine mpp_set_data_domain1D @@ -1728,7 +1728,7 @@ end subroutine mpp_get_tile_compute_domains integer :: ending !< Ending bounds domain_out%compute = domain_in%compute - domain_out%data = domain_in%data + domain_out%domain_data = domain_in%domain_data domain_out%global = domain_in%global domain_out%memory = domain_in%memory domain_out%cyclic = domain_in%cyclic diff --git a/mpp/include/mpp_gather.fh b/mpp/include/mpp_gather.fh index 8ead643f3a..d51960de2f 100644 --- a/mpp/include/mpp_gather.fh +++ b/mpp/include/mpp_gather.fh @@ -109,12 +109,12 @@ subroutine MPP_GATHER_1DV_(sbuf, ssize, rbuf, rsize, pelist) end subroutine MPP_GATHER_1DV_ -subroutine MPP_GATHER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_root_pe, & +subroutine MPP_GATHER_PELIST_2D_(is, ie, js, je, pelist, array_seg, gather_data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je integer, dimension(:), intent(in) :: pelist MPP_TYPE_, dimension(is:ie,js:je), target, intent(in) :: array_seg - MPP_TYPE_, dimension(:,:), contiguous, target, intent(inout) :: data + MPP_TYPE_, dimension(:,:), contiguous, target, intent(inout) :: gather_data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift @@ -123,7 +123,7 @@ subroutine MPP_GATHER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_roo arr3D(1:size(array_seg,1),1:size(array_seg,2),1:1) => array_seg if (is_root_pe) then - data3D(1:size(data,1),1:size(data,2),1:1) => data + data3D(1:size(gather_data,1),1:size(gather_data,2),1:1) => gather_data else data3D => null() endif @@ -135,12 +135,12 @@ subroutine MPP_GATHER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_roo end subroutine MPP_GATHER_PELIST_2D_ -subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is_root_pe, & +subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, gather_data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je, nk integer, dimension(:), intent(in) :: pelist MPP_TYPE_, dimension(is:ie,js:je,1:nk), intent(in) :: array_seg - MPP_TYPE_, dimension(:,:,:), intent(inout) :: data + MPP_TYPE_, dimension(:,:,:), intent(inout) :: gather_data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift @@ -148,7 +148,7 @@ subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is integer :: i1, i2, j1, j2, ioff, joff integer :: my_ind(4), gind(4,size(pelist)) type array3D - MPP_TYPE_, dimension(:,:,:), allocatable :: data + MPP_TYPE_, dimension(:,:,:), allocatable :: data3D_type endtype array3D type(array3d), dimension(:), allocatable :: temp @@ -200,7 +200,8 @@ subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is gind(3,:)=gind(3,:)+joff gind(4,:)=gind(4,:)+joff ! check indices to make sure they are within the range of "data" - if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(data,1)) .OR. (maxval(gind(3:4,:)).gt.size(data,2))) & + if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(gather_data,1)) .OR. & + (maxval(gind(3:4,:)).gt.size(gather_data,2))) & call mpp_error(FATAL,"fms_io(mpp_gather_pelist): specified indices (with shift) are outside of the & &range of the receiving array") else @@ -218,8 +219,8 @@ subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is j1 = gind(3,i) j2 = gind(4,i) msgsize = (i2-i1+1)*(j2-j1+1)*nk - allocate(temp(i)%data(i1:i2,j1:j2,1:nk)) - call mpp_recv(temp(i)%data(i1:i2,j1:j2,1:nk), msgsize, pelist(i), .FALSE., COMM_TAG_2) + allocate(temp(i)%data3D_type(i1:i2,j1:j2,1:nk)) + call mpp_recv(temp(i)%data3D_type(i1:i2,j1:j2,1:nk), msgsize, pelist(i), .FALSE., COMM_TAG_2) endif enddo call mpp_sync_self(check=EVENT_RECV) @@ -227,14 +228,14 @@ subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is do i = 1, size(pelist) if (pelist(i).eq.root_pe) then ! data copy - no send to self - data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) = array_seg(is:ie,js:je,1:nk) + gather_data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) = array_seg(is:ie,js:je,1:nk) else i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) - data(i1:i2,j1:j2,1:nk)=temp(i)%data(i1:i2,j1:j2,1:nk) - deallocate(temp(i)%data) + gather_data(i1:i2,j1:j2,1:nk)=temp(i)%data3D_type(i1:i2,j1:j2,1:nk) + deallocate(temp(i)%data3D_type) endif enddo deallocate(temp) diff --git a/mpp/include/mpp_global_field.fh b/mpp/include/mpp_global_field.fh index 3e5ff0d9db..1dd3d1121a 100644 --- a/mpp/include/mpp_global_field.fh +++ b/mpp/include/mpp_global_field.fh @@ -67,8 +67,8 @@ ! Also worth noting that many of the nD->3D conversion also assumes ! contiguity, so there many be other issues here. - isize = domain%x(tile)%data%size + ishift - jsize = domain%y(tile)%data%size + jshift + isize = domain%x(tile)%domain_data%size + ishift + jsize = domain%y(tile)%domain_data%size + jshift if ((size(local, 1) .eq. isize) .and. (size(local, 2) .eq. jsize) & .and. use_alltoallw) then call mpp_do_global_field_a2a(domain, local, global, tile, & diff --git a/mpp/include/mpp_global_reduce.fh b/mpp/include/mpp_global_reduce.fh index 060a052868..942f7876e1 100644 --- a/mpp/include/mpp_global_reduce.fh +++ b/mpp/include/mpp_global_reduce.fh @@ -63,8 +63,8 @@ joff = jsc else if( size(field,1).EQ.domain%x(1)%memory%size+ishift .AND. size(field,2).EQ.domain%y(1)%memory%size+jshift)then !field is on data domain - ioff = domain%x(1)%data%begin - joff = domain%y(1)%data%begin + ioff = domain%x(1)%domain_data%begin + joff = domain%y(1)%domain_data%begin else call mpp_error( FATAL, & & 'MPP_GLOBAL_REDUCE_: incoming field array must match either compute domain or data domain.' ) diff --git a/mpp/include/mpp_global_sum.fh b/mpp/include/mpp_global_sum.fh index a230191952..1a487a4f4d 100644 --- a/mpp/include/mpp_global_sum.fh +++ b/mpp/include/mpp_global_sum.fh @@ -53,8 +53,8 @@ else if( size(field,1).EQ.domain%x(tile)%memory%size+ishift .AND. & & size(field,2).EQ.domain%y(tile)%memory%size+jshift )then !field is on data domain - ioff = -domain%x(tile)%data%begin + 1 - joff = -domain%y(tile)%data%begin + 1 + ioff = -domain%x(tile)%domain_data%begin + 1 + joff = -domain%y(tile)%domain_data%begin + 1 else call mpp_error( FATAL, & & 'MPP_GLOBAL_SUM_: incoming field array must match either compute domain or data domain.' ) diff --git a/mpp/include/mpp_global_sum_ad.fh b/mpp/include/mpp_global_sum_ad.fh index 627b208f17..d1d9bb7699 100644 --- a/mpp/include/mpp_global_sum_ad.fh +++ b/mpp/include/mpp_global_sum_ad.fh @@ -57,8 +57,8 @@ subroutine MPP_GLOBAL_SUM_AD_( domain, field, gsum_, flags, position, tile_count else if( size(field,1).EQ.domain%x(tile)%memory%size+ishift .AND. & & size(field,2).EQ.domain%y(tile)%memory%size+jshift )then !field is on data domain - ioff = -domain%x(tile)%data%begin + 1 - joff = -domain%y(tile)%data%begin + 1 + ioff = -domain%x(tile)%domain_data%begin + 1 + joff = -domain%y(tile)%domain_data%begin + 1 else call mpp_error( FATAL, & & 'MPP_GLOBAL_SUM_: incoming field array must match either compute domain or data domain.' ) diff --git a/mpp/include/mpp_group_update.fh b/mpp/include/mpp_group_update.fh index 0f04c06c3b..45be7ea531 100644 --- a/mpp/include/mpp_group_update.fh +++ b/mpp/include/mpp_group_update.fh @@ -526,7 +526,7 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) if(domain%symmetry) shift = 1 if( nvector >0 .AND. BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(flags_v,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 @@ -534,7 +534,7 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift if( .NOT. domain%symmetry ) is = is - 1 do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,nvector ptr_fieldx = group%addrs_x(l) ptr_fieldy = group%addrs_y(l) @@ -558,15 +558,15 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) else is = domain%x(1)%global%begin - 1 end if - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,nvector ptr_fieldx = group%addrs_x(l) ptr_fieldy = group%addrs_y(l) do k = 1,ksize - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) fieldy(i,j,k) = fieldy(2*is-i,j,k) end do @@ -577,7 +577,7 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) is = domain%x(1)%global%begin isd = domain%x(1)%compute%begin - group%whalo_v if( is.GT.isd )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,nvector ptr_fieldy = group%addrs_y(l) @@ -592,7 +592,7 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) end if !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then ie = domain%x(1)%compute%end+group%ehalo_v is = is + 1 select case(gridtype) @@ -802,7 +802,7 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) if(domain%symmetry) shift = 1 if( nvector >0 .AND. BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(flags_v,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 @@ -810,7 +810,7 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift if( .NOT. domain%symmetry ) is = is - 1 do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,nvector ptr_fieldx = group%addrs_x(l) ptr_fieldy = group%addrs_y(l) @@ -834,15 +834,15 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) else is = domain%x(1)%global%begin - 1 end if - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,nvector ptr_fieldx = group%addrs_x(l) ptr_fieldy = group%addrs_y(l) do k = 1,ksize - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) fieldy(i,j,k) = fieldy(2*is-i,j,k) end do @@ -853,7 +853,7 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) is = domain%x(1)%global%begin isd = domain%x(1)%compute%begin - group%whalo_v if( is.GT.isd)then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,nvector ptr_fieldy = group%addrs_y(l) @@ -868,7 +868,7 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) end if !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then ie = domain%x(1)%compute%end+group%ehalo_v is = is + 1 select case(gridtype) diff --git a/mpp/include/mpp_io_misc.inc b/mpp/include/mpp_io_misc.inc index 0f2168a92d..3b0abdd35f 100644 --- a/mpp/include/mpp_io_misc.inc +++ b/mpp/include/mpp_io_misc.inc @@ -51,7 +51,7 @@ subroutine mpp_io_init( flags, maxunit ) integer, intent(in), optional :: flags, maxunit - integer :: io_status, iunit + integer :: io_status, unit integer :: logunit, outunit, inunit, errunit logical :: opened real(r8_kind) :: doubledata = 0 @@ -175,11 +175,11 @@ if (errunit > NULLUNIT .AND. errunit < 2*maxunits) mpp_file(errunit)%opened = .TRUE. if( pe.EQ.mpp_root_pe() )then - iunit = stdlog() ! PGI compiler does not like stdlog() doing I/O within write call - write( iunit,'(/a)' )'MPP_IO module '//trim(version) + unit = stdlog() ! PGI compiler does not like stdlog() doing I/O within write call + write( unit,'(/a)' )'MPP_IO module '//trim(version) #ifdef use_netCDF text = NF_INQ_LIBVERS() - write( iunit,'(/a)' )'Using netCDF library version '//trim(text) + write( unit,'(/a)' )'Using netCDF library version '//trim(text) #endif endif diff --git a/mpp/include/mpp_scatter.fh b/mpp/include/mpp_scatter.fh index fce54f5a78..181796e87e 100644 --- a/mpp/include/mpp_scatter.fh +++ b/mpp/include/mpp_scatter.fh @@ -24,13 +24,13 @@ !! !> Scatter (ie - is) * (je - js) contiguous elements of array data from the designated root pe !! into contigous members of array segment in each pe that is included in the pelist argument. -subroutine MPP_SCATTER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_root_pe, & +subroutine MPP_SCATTER_PELIST_2D_(is, ie, js, je, pelist, array_seg, input_data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je !< indices of segment array integer, dimension(:), intent(in) :: pelist ! array_seg if (is_root_pe) then - data3D(1:size(data,1),1:size(data,2),1:1) => data + data3D(1:size(input_data,1),1:size(input_data,2),1:1) => input_data else data3D => null() endif @@ -51,12 +51,12 @@ subroutine MPP_SCATTER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_ro end subroutine MPP_SCATTER_PELIST_2D_ -subroutine MPP_SCATTER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is_root_pe, & +subroutine MPP_SCATTER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, input_data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je, nk integer, dimension(:), intent(in) :: pelist MPP_TYPE_, dimension(is:ie,js:je,1:nk), intent(inout) :: array_seg - MPP_TYPE_, dimension(:,:,:), intent(in) :: data + MPP_TYPE_, dimension(:,:,:), intent(in) :: input_data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift @@ -64,7 +64,7 @@ subroutine MPP_SCATTER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, i integer :: i1, i2, j1, j2, ioff, joff integer :: my_ind(4), gind(4,size(pelist)) type array3D - MPP_TYPE_, dimension(:,:,:), allocatable :: data + MPP_TYPE_, dimension(:,:,:), allocatable :: data3D_type endtype array3D type(array3d), dimension(size(pelist)) :: temp @@ -115,7 +115,8 @@ subroutine MPP_SCATTER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, i gind(3,:)=gind(3,:)+joff gind(4,:)=gind(4,:)+joff ! check indices to make sure they are within the range of "data" - if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(data,1)) .OR. (maxval(gind(3:4,:)).gt.size(data,2))) & + if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(input_data,1)) & + .OR. (maxval(gind(3:4,:)).gt.size(input_data,2))) & call mpp_error(FATAL,"fms_io(mpp_scatter_pelist): specified indices (with shift) are outside of the & &range of the receiving array") else @@ -134,18 +135,18 @@ subroutine MPP_SCATTER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, i j2 = gind(4,i) msgsize = (i2-i1+1)*(j2-j1+1)*nk ! allocate and copy data into a contiguous memory space - allocate(temp(i)%data(i1:i2,j1:j2,1:nk)) - temp(i)%data(i1:i2,j1:j2,1:nk)=data(i1:i2,j1:j2,1:nk) - call mpp_send(temp(i)%data, msgsize, pelist(i), COMM_TAG_2) + allocate(temp(i)%data3D_type(i1:i2,j1:j2,1:nk)) + temp(i)%data3D_type(i1:i2,j1:j2,1:nk)=input_data(i1:i2,j1:j2,1:nk) + call mpp_send(temp(i)%data3D_type, msgsize, pelist(i), COMM_TAG_2) else ! data copy - no send to self - array_seg(is:ie,js:je,1:nk) = data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) + array_seg(is:ie,js:je,1:nk) = input_data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) endif enddo call mpp_sync_self(check=EVENT_SEND) ! deallocate the temporary array used for the send do i = 1, size(pelist) - if (allocated(temp(i)%data)) deallocate(temp(i)%data) + if (allocated(temp(i)%data3D_type)) deallocate(temp(i)%data3D_type) enddo else ! non root_pe's recv data from root_pe diff --git a/mpp/include/mpp_transmit.inc b/mpp/include/mpp_transmit.inc index 24d0cc437f..aaa770cc06 100644 --- a/mpp/include/mpp_transmit.inc +++ b/mpp/include/mpp_transmit.inc @@ -305,79 +305,79 @@ ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine MPP_BROADCAST_SCALAR_( data, from_pe, pelist ) - MPP_TYPE_, intent(inout) :: data + subroutine MPP_BROADCAST_SCALAR_( broadcast_data, from_pe, pelist ) + MPP_TYPE_, intent(inout) :: broadcast_data integer, intent(in) :: from_pe integer, intent(in), optional :: pelist(:) MPP_TYPE_ :: data1D(1) pointer( ptr, data1D ) - ptr = LOC(data) + ptr = LOC(broadcast_data) call MPP_BROADCAST_( data1D, 1, from_pe, pelist ) return end subroutine MPP_BROADCAST_SCALAR_ - subroutine MPP_BROADCAST_2D_( data, length, from_pe, pelist ) + subroutine MPP_BROADCAST_2D_( broadcast_data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: data(:,:) + MPP_TYPE_, intent(inout) :: broadcast_data(:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) MPP_TYPE_ :: data1D(length) pointer( ptr, data1D ) - ptr = LOC(data) + ptr = LOC(broadcast_data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine MPP_BROADCAST_2D_ - subroutine MPP_BROADCAST_3D_( data, length, from_pe, pelist ) + subroutine MPP_BROADCAST_3D_( broadcast_data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: data(:,:,:) + MPP_TYPE_, intent(inout) :: broadcast_data(:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) MPP_TYPE_ :: data1D(length) pointer( ptr, data1D ) - ptr = LOC(data) + ptr = LOC(broadcast_data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine MPP_BROADCAST_3D_ - subroutine MPP_BROADCAST_4D_( data, length, from_pe, pelist ) + subroutine MPP_BROADCAST_4D_( broadcast_data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: data(:,:,:,:) + MPP_TYPE_, intent(inout) :: broadcast_data(:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) MPP_TYPE_ :: data1D(length) pointer( ptr, data1D ) - ptr = LOC(data) + ptr = LOC(broadcast_data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine MPP_BROADCAST_4D_ - subroutine MPP_BROADCAST_5D_( data, length, from_pe, pelist ) + subroutine MPP_BROADCAST_5D_( broadcast_data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: data(:,:,:,:,:) + MPP_TYPE_, intent(inout) :: broadcast_data(:,:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) MPP_TYPE_ :: data1D(length) pointer( ptr, data1D ) - ptr = LOC(data) + ptr = LOC(broadcast_data) call mpp_broadcast( data1D, length, from_pe, pelist ) return diff --git a/mpp/include/mpp_transmit_mpi.fh b/mpp/include/mpp_transmit_mpi.fh index fa820300c1..e8eb68545f 100644 --- a/mpp/include/mpp_transmit_mpi.fh +++ b/mpp/include/mpp_transmit_mpi.fh @@ -164,11 +164,11 @@ ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> Broadcasts data to a pelist - subroutine MPP_BROADCAST_( data, length, from_pe, pelist ) + subroutine MPP_BROADCAST_( broadcast_data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: data(*) + MPP_TYPE_, intent(inout) :: broadcast_data(*) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer :: n, i, from_rank, stdout_unit @@ -193,7 +193,7 @@ exit endif enddo - if( mpp_npes().GT.1 )call MPI_BCAST( data, length, MPI_TYPE_, from_rank, peset(n)%id, error ) + if( mpp_npes().GT.1 )call MPI_BCAST( broadcast_data, length, MPI_TYPE_, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length*MPP_TYPE_BYTELEN_ ) return end subroutine MPP_BROADCAST_ diff --git a/mpp/include/mpp_unstruct_pass_data.fh b/mpp/include/mpp_unstruct_pass_data.fh index 656a7789d3..9dddff0f3d 100644 --- a/mpp/include/mpp_unstruct_pass_data.fh +++ b/mpp/include/mpp_unstruct_pass_data.fh @@ -50,10 +50,10 @@ SUBROUTINE mpp_pass_SG_to_UG_3D_(UG_domain, field_SG, field_UG) size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%compute%size) then ioff = 1 - UG_domain%SG_domain%x(1)%compute%begin joff = 1 - UG_domain%SG_domain%y(1)%compute%begin - else if(size(field_SG,1) .EQ. UG_domain%SG_domain%x(1)%data%size .AND. & - size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%data%size) then - ioff = 1 - UG_domain%SG_domain%x(1)%data%begin - joff = 1 - UG_domain%SG_domain%y(1)%data%begin + else if(size(field_SG,1) .EQ. UG_domain%SG_domain%x(1)%domain_data%size .AND. & + size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%domain_data%size) then + ioff = 1 - UG_domain%SG_domain%x(1)%domain_data%begin + joff = 1 - UG_domain%SG_domain%y(1)%domain_data%begin else call mpp_error( FATAL, 'mpp_pass_SG_to_UG_3D_: field_SG must match either compute domain or data domain.' ) endif @@ -154,10 +154,10 @@ SUBROUTINE mpp_pass_UG_to_SG_3D_(UG_domain, field_UG, field_SG) size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%compute%size) then ioff = 1 - UG_domain%SG_domain%x(1)%compute%begin joff = 1 - UG_domain%SG_domain%y(1)%compute%begin - else if(size(field_SG,1) .EQ. UG_domain%SG_domain%x(1)%data%size .AND. & - size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%data%size) then - ioff = 1 - UG_domain%SG_domain%x(1)%data%begin - joff = 1 - UG_domain%SG_domain%y(1)%data%begin + else if(size(field_SG,1) .EQ. UG_domain%SG_domain%x(1)%domain_data%size .AND. & + size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%domain_data%size) then + ioff = 1 - UG_domain%SG_domain%x(1)%domain_data%begin + joff = 1 - UG_domain%SG_domain%y(1)%domain_data%begin else call mpp_error( FATAL, 'mpp_pass_UG_to_SG_3D_: field_SG must match either compute domain or data domain.' ) endif diff --git a/mpp/include/mpp_update_domains2D_nonblock.fh b/mpp/include/mpp_update_domains2D_nonblock.fh index fc8c9df306..7549abb533 100644 --- a/mpp/include/mpp_update_domains2D_nonblock.fh +++ b/mpp/include/mpp_update_domains2D_nonblock.fh @@ -45,7 +45,7 @@ function MPP_START_UPDATE_DOMAINS_3D_( field, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(domain%x(1)%data%begin:,domain%y(1)%data%begin:,:) + MPP_TYPE_, intent(inout) :: field(domain%x(1)%domain_data%begin:,domain%y(1)%domain_data%begin:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. @@ -316,7 +316,7 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_( id_update, field, domain, flags, pos whalo, ehalo, shalo, nhalo, name, tile_count, complete ) integer, intent(in) :: id_update type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(domain%x(1)%data%begin:,domain%y(1)%data%begin:,:) + MPP_TYPE_, intent(inout) :: field(domain%x(1)%domain_data%begin:,domain%y(1)%domain_data%begin:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. diff --git a/mpp/include/mpp_util.inc b/mpp/include/mpp_util.inc index ee3e3dcc59..e6af1ba157 100644 --- a/mpp/include/mpp_util.inc +++ b/mpp/include/mpp_util.inc @@ -156,20 +156,20 @@ subroutine mpp_error_noargs() end subroutine mpp_error_noargs !##################################################################### -subroutine mpp_error_Is(errortype, errormsg1, value, errormsg2) +subroutine mpp_error_Is(errortype, errormsg1, mpp_ival, errormsg2) integer, intent(in) :: errortype - INTEGER, intent(in) :: value + INTEGER, intent(in) :: mpp_ival character(len=*), intent(in) :: errormsg1 character(len=*), intent(in), optional :: errormsg2 - call mpp_error( errortype, errormsg1, (/value/), errormsg2) + call mpp_error( errortype, errormsg1, (/mpp_ival/), errormsg2) end subroutine mpp_error_Is !##################################################################### -subroutine mpp_error_Rs(errortype, errormsg1, value, errormsg2) +subroutine mpp_error_Rs(errortype, errormsg1, mpp_rval, errormsg2) integer, intent(in) :: errortype - REAL, intent(in) :: value + REAL, intent(in) :: mpp_rval character(len=*), intent(in) :: errormsg1 character(len=*), intent(in), optional :: errormsg2 - call mpp_error( errortype, errormsg1, (/value/), errormsg2) + call mpp_error( errortype, errormsg1, (/mpp_rval/), errormsg2) end subroutine mpp_error_Rs !##################################################################### subroutine mpp_error_Ia(errortype, errormsg1, array, errormsg2) diff --git a/mpp/include/mpp_write_2Ddecomp.fh b/mpp/include/mpp_write_2Ddecomp.fh index aa5cc011a6..69cd0ec60d 100644 --- a/mpp/include/mpp_write_2Ddecomp.fh +++ b/mpp/include/mpp_write_2Ddecomp.fh @@ -130,8 +130,8 @@ !write time information if new time if( newtime )then if( KIND(time).EQ.r8_kind )then - error = NF_PUT_VAR1_DOUBLE( mpp_file(unit)%ncid, mpp_file(unit)%id, mpp_file(unit:unit)%time_level,& - & time ) + error = NF_PUT_VAR1_DOUBLE( mpp_file(unit)%ncid, mpp_file(unit)%id, & + & mpp_file(unit:unit)%time_level, time ) else if( KIND(time).EQ.r4_kind )then error = NF90_PUT_VAR ( mpp_file(unit)%ncid, mpp_file(unit)%id, time) end if diff --git a/mpp/mpp_domains.F90 b/mpp/mpp_domains.F90 index 02db652bc3..e46f424e38 100644 --- a/mpp/mpp_domains.F90 +++ b/mpp/mpp_domains.F90 @@ -628,7 +628,7 @@ module mpp_domains_mod type :: domain1D private type(domain_axis_spec) :: compute !< index limits for compute domain - type(domain_axis_spec) :: data !< index limits for data domain + type(domain_axis_spec) :: domain_data !< index limits for data domain type(domain_axis_spec) :: global !< index limits for global domain type(domain_axis_spec) :: memory !< index limits for memory domain logical :: cyclic !< true if domain is cyclic diff --git a/sat_vapor_pres/include/sat_vapor_pres.inc b/sat_vapor_pres/include/sat_vapor_pres.inc index 35a67fa8a2..4412fe28b8 100644 --- a/sat_vapor_pres/include/sat_vapor_pres.inc +++ b/sat_vapor_pres/include/sat_vapor_pres.inc @@ -1842,10 +1842,10 @@ subroutine TEMP_CHECK_1D_ ( temp ) real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:) !< temperature in degrees Kelvin (K) - integer :: i, unit + integer :: i, iunit - unit = stdoutunit - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) + iunit = stdoutunit + write(iunit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) end subroutine TEMP_CHECK_1D_ @@ -1853,11 +1853,11 @@ subroutine TEMP_CHECK_2D_ ( temp ) real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) - integer :: i, j, unit + integer :: i, j, iunit - unit = stdoutunit - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) + iunit = stdoutunit + write(iunit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) + write(iunit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) end subroutine TEMP_CHECK_2D_ @@ -1865,12 +1865,12 @@ subroutine TEMP_CHECK_3D_ ( temp ) real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) - integer :: i, j, k, unit + integer :: i, j, k, iunit - unit = stdoutunit - write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) - write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) + iunit = stdoutunit + write(iunit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1)) + write(iunit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) + write(iunit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) end subroutine TEMP_CHECK_3D_ @@ -1878,7 +1878,7 @@ subroutine SHOW_ALL_BAD_0D_ ( temp ) real(kind=FMS_SVP_KIND_) , intent(in) :: temp !< temperature in degrees Kelvin (K) - integer :: ind, unit + integer :: ind, iunit !> DTINV, TMIN, TEPS are module level variables declared in r8_kind !! Thus they need to be converted to FMS_SVP_KIND_ real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl @@ -1889,10 +1889,10 @@ tminll=real(tmin,FMS_SVP_KIND_) tepsll=real(teps,FMS_SVP_KIND_) - unit = stdoutunit + iunit = stdoutunit ind = int( dtinvll*(temp-tminll+tepsll) ) if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() + write(iunit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() endif end subroutine SHOW_ALL_BAD_0D_ @@ -1901,7 +1901,7 @@ subroutine SHOW_ALL_BAD_1D_ ( temp ) real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:) !< temperature in degrees Kelvin (K) - integer :: i, ind, unit + integer :: i, ind, iunit !> DTINV, TMIN, TEPS are module level variables declared in r8_kind !! Thus they need to be converted to FMS_SVP_KIND_ real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl @@ -1912,11 +1912,11 @@ tminll=real(tmin,FMS_SVP_KIND_) tepsll=real(teps,FMS_SVP_KIND_) - unit = stdoutunit + iunit = stdoutunit do i=1,size(temp) ind = int( dtinvll*(temp(i)-tminll+tepsll) ) if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe() + write(iunit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe() endif enddo @@ -1926,7 +1926,7 @@ subroutine SHOW_ALL_BAD_2D_ ( temp ) real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) - integer :: i, j, ind, unit + integer :: i, j, ind, iunit !> DTINV, TMIN, TEPS are module level variables declared in r8_kind !! Thus they need to be converted to FMS_SVP_KIND_ real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl @@ -1937,12 +1937,12 @@ tminll=real(tmin,FMS_SVP_KIND_) tepsll=real(teps,FMS_SVP_KIND_) - unit = stdoutunit + iunit = stdoutunit do j=1,size(temp,2) do i=1,size(temp,1) ind = int( dtinvll*(temp(i,j)-tminll+tepsll) ) if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe() + write(iunit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe() endif enddo enddo @@ -1953,7 +1953,7 @@ subroutine SHOW_ALL_BAD_3D_ ( temp ) real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) - integer :: i, j, k, ind, unit + integer :: i, j, k, ind, iunit !> DTINV, TMIN, TEPS are module level variables declared in r8_kind !! Thus they need to be converted to FMS_SVP_KIND_ real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl @@ -1964,13 +1964,13 @@ tminll=real(tmin,FMS_SVP_KIND_) tepsll=real(teps,FMS_SVP_KIND_) - unit = stdoutunit + iunit = stdoutunit do k=1,size(temp,3) do j=1,size(temp,2) do i=1,size(temp,1) ind = int( dtinvll*(temp(i,j,k)-tminll+tepsll) ) if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k, & + write(iunit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k, & & ' pe=',mpp_pe() endif enddo diff --git a/sat_vapor_pres/sat_vapor_pres.F90 b/sat_vapor_pres/sat_vapor_pres.F90 index b5591e99d4..727d2381bd 100644 --- a/sat_vapor_pres/sat_vapor_pres.F90 +++ b/sat_vapor_pres/sat_vapor_pres.F90 @@ -801,7 +801,7 @@ subroutine sat_vapor_pres_init(err_msg) character(len=*), intent(out), optional :: err_msg character(len=128) :: err_msg_local - integer :: unit, ierr, io + integer :: iunit, ierr, io ! return silently if this routine has already been called if (module_is_initialized) return @@ -812,9 +812,9 @@ subroutine sat_vapor_pres_init(err_msg) ! write version number and namelist to log file call write_version_number("SAT_VAPOR_PRES_MOD", version) - unit = stdlog() + iunit = stdlog() stdoutunit = stdout() - if (mpp_pe() == mpp_root_pe()) write (unit, nml=sat_vapor_pres_nml) + if (mpp_pe() == mpp_root_pe()) write (iunit, nml=sat_vapor_pres_nml) if(do_simple) then tcmin = -173 diff --git a/test_fms/data_override/Makefile.am b/test_fms/data_override/Makefile.am index f5c956c446..567f787434 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 @@ -69,10 +71,10 @@ TESTS_ENVIRONMENT= test_input_path="@TEST_INPUT_PATH@" \ parser_skip=${skipflag} # Run the test program. -TESTS = test_data_override2.sh +TESTS = test_data_override2.sh test_data_override_init.sh # Include these files with the distribution. -EXTRA_DIST = test_data_override2.sh +EXTRA_DIST = test_data_override2.sh test_data_override_init.sh # Clean up -CLEANFILES = input.nml *.nc* *.out diag_table data_table data_table.yaml INPUT/* *.dpi *.spi *.dyn *.spl +CLEANFILES = input.nml *.nc* *.out diag_table data_table data_table.yaml INPUT/* *.dpi *.spi *.dyn *.spl *-files/* diff --git a/test_fms/data_override/test_data_override2.sh b/test_fms/data_override/test_data_override2.sh index 35546b41d3..ffa42c05c6 100755 --- a/test_fms/data_override/test_data_override2.sh +++ b/test_fms/data_override/test_data_override2.sh @@ -24,30 +24,32 @@ # Set common test settings. . ../test-lib.sh -setup_test_dir () { - local halo_size - test "$#" = 1 && { halo_size=$1; } || - BUG "required parameter for halo size not present" - rm -rf data_table input.nml INPUT - cat <<_EOF > data_table -"OCN", "runoff", "runoff", "./INPUT/runoff.daitren.clim.1440x1080.v20180328.nc", "none" , 1.0 -_EOF +output_dir +rm -rf data_table data_table.yaml input.nml input_base.nml + +if [ ! -z $parser_skip ]; then + cat <<_EOF > input_base.nml +&data_override_nml +use_data_table_yaml=.False. +/ -cat <<_EOF > input.nml &test_data_override_ongrid_nml - nhalox=${halo_size} - nhaloy=${halo_size} + nhalox=halo_size + nhaloy=halo_size / _EOF - mkdir INPUT -} - -touch input.nml - -for KIND in r4 r8 -do + printf '"OCN", "runoff", "runoff", "./INPUT/runoff.daitren.clim.1440x1080.v20180328.nc", "none" , 1.0' | cat > data_table +else +cat <<_EOF > input_base.nml +&data_override_nml +use_data_table_yaml=.True. +/ -# Run the ongrid test case with 2 halos in x and y +&test_data_override_ongrid_nml + nhalox=halo_size + nhaloy=halo_size +/ +_EOF cat <<_EOF > data_table.yaml data_table: - gridname : OCN @@ -57,26 +59,27 @@ data_table: interpol_method : none factor : 1.0 _EOF +fi -printf '"OCN", "runoff", "runoff", "./INPUT/runoff.daitren.clim.1440x1080.v20180328.nc", "none" , 1.0' | cat > data_table [ ! -d "INPUT" ] && mkdir -p "INPUT" -setup_test_dir 2 - +for KIND in r4 r8 +do +sed 's/halo_size/2/g' input_base.nml > input.nml test_expect_success "data_override on grid with 2 halos in x and y (${KIND})" ' - mpirun -n 6 ./test_data_override_ongrid_${KIND} + mpirun -n 6 ../test_data_override_ongrid_${KIND} ' - -setup_test_dir 0 - -test_expect_success "data_override on grid with no halos (${KIND})" ' - mpirun -n 6 ./test_data_override_ongrid_${KIND} +sed 's/halo_size/0/g' input_base.nml > input.nml +test_expect_success "data_override on grid with 2 halos in x and y (${KIND})" ' + mpirun -n 6 ../test_data_override_ongrid_${KIND} ' -# Run the get_grid_v1 test: test_expect_success "data_override get_grid_v1 (${KIND})" ' - mpirun -n 1 ./test_get_grid_v1_${KIND} + mpirun -n 1 ../test_get_grid_v1_${KIND} ' +done +for KIND in r4 r8 +do # Run tests with input if enabled # skips if built with yaml parser(tests older behavior) if test ! -z "$test_input_path" && test ! -z "$parser_skip" ; then @@ -100,7 +103,7 @@ _EOF _EOF test_expect_success "data_override on cubic-grid with input (${KIND})" ' - mpirun -n 6 ./test_data_override_${KIND} + mpirun -n 6 ../test_data_override_${KIND} ' cat <<_EOF > input.nml @@ -110,11 +113,10 @@ cat <<_EOF > input.nml _EOF test_expect_success "data_override on latlon-grid with input (${KIND})" ' - mpirun -n 6 ./test_data_override_${KIND} + mpirun -n 6 ../test_data_override_${KIND} ' - rm -rf INPUT *.nc # remove any leftover files to reduce size fi - done +rm -rf INPUT *.nc # remove any leftover files to reduce size -test_done +test_done \ No newline at end of file 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/data_override/test_data_override_init.sh b/test_fms/data_override/test_data_override_init.sh new file mode 100755 index 0000000000..8598cb3039 --- /dev/null +++ b/test_fms/data_override/test_data_override_init.sh @@ -0,0 +1,71 @@ +#!/bin/sh + +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** +# +# Copyright (c) 2019-2021 Ed Hartnett, Uriel Ramirez, Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +output_dir + +# data_override with the default table (not setting namelist) +rm -rf input.nml data_table data_table.yaml +touch input.nml +touch data_table +test_expect_success "data_override_init with the default table" ' + mpirun -n 1 ../test_data_override_init +' + +cat <<_EOF > input.nml +&data_override_nml +use_data_table_yaml=.false. +/ +_EOF +test_expect_success "data_override_init setting use_data_table_yaml = .false." ' + mpirun -n 1 ../test_data_override_init +' + +touch data_table.yaml +test_expect_failure "data_override_init both tables present" ' + mpirun -n 1 ../test_data_override_init +' +if [ ! -z $parser_skip ]; then +rm -rf data_table.yaml +cat <<_EOF > input.nml +&data_override_nml +use_data_table_yaml=.true. +/ +_EOF + test_expect_failure "data_override_init setting use_data_table_yaml = .true. but no compiling with yaml" ' + mpirun -n 1 ../test_data_override_init + ' +else +rm -rf data_table +cat <<_EOF > input.nml +&data_override_nml +use_data_table_yaml=.true. +/ +_EOF +test_expect_success "data_override_init setting use_data_table_yaml = .true." ' + mpirun -n 1 ../test_data_override_init +' +fi +test_done \ No newline at end of file diff --git a/test_fms/mpp/fill_halo.F90 b/test_fms/mpp/fill_halo.F90 index bb8996ce38..63013ddbf8 100644 --- a/test_fms/mpp/fill_halo.F90 +++ b/test_fms/mpp/fill_halo.F90 @@ -90,285 +90,285 @@ module fill_halo contains !> fill the halo region of a 64-bit real array with zeros - subroutine fill_halo_zero_r8(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & + subroutine fill_halo_zero_r8(halo_data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & & jsd, jed) - real(kind=r8_kind), dimension(isd:,jsd:,:), intent(inout) :: data + real(kind=r8_kind), dimension(isd:,jsd:,:), intent(inout) :: halo_data integer, intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed integer, intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift if(whalo >=0) then - data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 - data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 + halo_data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 + halo_data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 else - data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 - data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 end if if(shalo>=0) then - data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 - data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 + halo_data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 + halo_data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 else - data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 - data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 end if end subroutine fill_halo_zero_r8 !> fill the halo region of a 32-bit real array with zeros - subroutine fill_halo_zero_r4(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & + subroutine fill_halo_zero_r4(halo_data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & & jsd, jed) - real(kind=r4_kind), dimension(isd:,jsd:,:), intent(inout) :: data + real(kind=r4_kind), dimension(isd:,jsd:,:), intent(inout) :: halo_data integer, intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed integer, intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift if(whalo >=0) then - data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 - data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 + halo_data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 + halo_data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 else - data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 - data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 end if if(shalo>=0) then - data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 - data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 + halo_data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 + halo_data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 else - data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 - data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 end if end subroutine fill_halo_zero_r4 !> fill the halo region of a 64-bit integer array with zeros - subroutine fill_halo_zero_i8(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & + subroutine fill_halo_zero_i8(halo_data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & & jsd, jed) - integer(kind=i8_kind), dimension(isd:,jsd:,:), intent(inout) :: data + integer(kind=i8_kind), dimension(isd:,jsd:,:), intent(inout) :: halo_data integer, intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed integer, intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift if(whalo >=0) then - data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 - data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 + halo_data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 + halo_data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 else - data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 - data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 end if if(shalo>=0) then - data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 - data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 + halo_data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 + halo_data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 else - data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 - data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 end if end subroutine fill_halo_zero_i8 !> fill the halo region of a 32-bit integer array with zeros - subroutine fill_halo_zero_i4(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & + subroutine fill_halo_zero_i4(halo_data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & & jsd, jed) - integer(kind=i4_kind), dimension(isd:,jsd:,:), intent(inout) :: data + integer(kind=i4_kind), dimension(isd:,jsd:,:), intent(inout) :: halo_data integer, intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed integer, intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift if(whalo >=0) then - data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 - data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 + halo_data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 + halo_data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 else - data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 - data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 end if if(shalo>=0) then - data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 - data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 + halo_data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 + halo_data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 else - data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 - data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 end if end subroutine fill_halo_zero_i4 !> fill the halo region of 64-bit array on a regular grid - subroutine fill_regular_refinement_halo_r8( data, data_all, ni, nj, tm, te, tse, ts, & + subroutine fill_regular_refinement_halo_r8( halo_data, data_all, ni, nj, tm, te, tse, ts, & tsw, tw, tnw, tn, tne, ioff, joff ) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real(kind=r8_kind), dimension(:,:,:,:), intent(in) :: data_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tm, te, tse, ts, tsw, tw, tnw, tn, tne integer, intent(in) :: ioff, joff - if(te>0) data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & + if(te>0) halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & data_all(1+ioff:ehalo+ioff, 1:nj(te)+joff, :,te) ! east - if(ts>0) data (1:ni(tm)+ioff, 1-shalo:0, :) = & + if(ts>0) halo_data (1:ni(tm)+ioff, 1-shalo:0, :) = & data_all(1:ni(ts)+ioff, nj(ts)-shalo+1:nj(ts), :,ts) ! south - if(tw>0) data (1-whalo:0, 1:nj(tm)+joff, :) = & + if(tw>0) halo_data (1-whalo:0, 1:nj(tm)+joff, :) = & data_all(ni(tw)-whalo+1:ni(tw), 1:nj(tw)+joff, :,tw) ! west - if(tn>0) data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tn>0) halo_data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1:ni(tn)+ioff, 1+joff:nhalo+joff, :,tn) ! north - if(tse>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & + if(tse>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & data_all(1+ioff:ehalo+ioff, nj(tse)-shalo+1:nj(tse), :,tse) ! southeast - if(tsw>0)data (1-whalo:0, 1-shalo:0, :) = & + if(tsw>0)halo_data (1-whalo:0, 1-shalo:0, :) = & data_all(ni(tsw)-whalo+1:ni(tsw), nj(tsw)-shalo+1:nj(tsw), :,tsw) ! southwest - if(tne>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tne>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff, :,tnw) ! northeast - if(tnw>0)data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tnw>0)halo_data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(ni(tnw)-whalo+1:ni(tnw), 1+joff:nhalo+joff, :,tne) ! northwest end subroutine fill_regular_refinement_halo_r8 !> fill the halo region of 32-bit array on a regular grid - subroutine fill_regular_refinement_halo_r4( data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, & + subroutine fill_regular_refinement_halo_r4( halo_data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, & & ioff, joff ) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real(kind=r4_kind), dimension(:,:,:,:), intent(in) :: data_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tm, te, tse, ts, tsw, tw, tnw, tn, tne integer, intent(in) :: ioff, joff - if(te>0) data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & + if(te>0) halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & data_all(1+ioff:ehalo+ioff, 1:nj(te)+joff, :,te) ! east - if(ts>0) data (1:ni(tm)+ioff, 1-shalo:0, :) = & + if(ts>0) halo_data (1:ni(tm)+ioff, 1-shalo:0, :) = & data_all(1:ni(ts)+ioff, nj(ts)-shalo+1:nj(ts), :,ts) ! south - if(tw>0) data (1-whalo:0, 1:nj(tm)+joff, :) = & + if(tw>0) halo_data (1-whalo:0, 1:nj(tm)+joff, :) = & data_all(ni(tw)-whalo+1:ni(tw), 1:nj(tw)+joff, :,tw) ! west - if(tn>0) data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tn>0) halo_data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1:ni(tn)+ioff, 1+joff:nhalo+joff, :,tn) ! north - if(tse>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & + if(tse>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & data_all(1+ioff:ehalo+ioff, nj(tse)-shalo+1:nj(tse), :,tse) ! southeast - if(tsw>0)data (1-whalo:0, 1-shalo:0, :) = & + if(tsw>0)halo_data (1-whalo:0, 1-shalo:0, :) = & data_all(ni(tsw)-whalo+1:ni(tsw), nj(tsw)-shalo+1:nj(tsw), :,tsw) ! southwest - if(tne>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tne>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff, :,tnw) ! northeast - if(tnw>0)data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tnw>0)halo_data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(ni(tnw)-whalo+1:ni(tnw), 1+joff:nhalo+joff, :,tne) ! northwest end subroutine fill_regular_refinement_halo_r4 !> fill the halo region of 64-bit integer array on a regular grid - subroutine fill_regular_refinement_halo_i8( data, data_all, ni, nj, tm, te, tse, ts, tsw, & + subroutine fill_regular_refinement_halo_i8( halo_data, data_all, ni, nj, tm, te, tse, ts, tsw, & tw, tnw, tn, tne, ioff, joff ) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer(kind=i8_kind), dimension(:,:,:,:), intent(in) :: data_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tm, te, tse, ts, tsw, tw, tnw, tn, tne integer, intent(in) :: ioff, joff - if(te>0) data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & + if(te>0) halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & data_all(1+ioff:ehalo+ioff, 1:nj(te)+joff, :,te) ! east - if(ts>0) data (1:ni(tm)+ioff, 1-shalo:0, :) = & + if(ts>0) halo_data (1:ni(tm)+ioff, 1-shalo:0, :) = & data_all(1:ni(ts)+ioff, nj(ts)-shalo+1:nj(ts), :,ts) ! south - if(tw>0) data (1-whalo:0, 1:nj(tm)+joff, :) = & + if(tw>0) halo_data (1-whalo:0, 1:nj(tm)+joff, :) = & data_all(ni(tw)-whalo+1:ni(tw), 1:nj(tw)+joff, :,tw) ! west - if(tn>0) data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tn>0) halo_data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1:ni(tn)+ioff, 1+joff:nhalo+joff, :,tn) ! north - if(tse>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & + if(tse>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & data_all(1+ioff:ehalo+ioff, nj(tse)-shalo+1:nj(tse), :,tse) ! southeast - if(tsw>0)data (1-whalo:0, 1-shalo:0, :) = & + if(tsw>0)halo_data (1-whalo:0, 1-shalo:0, :) = & data_all(ni(tsw)-whalo+1:ni(tsw), nj(tsw)-shalo+1:nj(tsw), :,tsw) ! southwest - if(tne>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tne>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff, :,tnw) ! northeast - if(tnw>0)data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tnw>0)halo_data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(ni(tnw)-whalo+1:ni(tnw), 1+joff:nhalo+joff, :,tne) ! northwest end subroutine fill_regular_refinement_halo_i8 !> fill the halo region of 32-bit integer array on a regular grid - subroutine fill_regular_refinement_halo_i4( data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, & + subroutine fill_regular_refinement_halo_i4( halo_data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, & & ioff, joff ) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer(kind=i4_kind), dimension(:,:,:,:), intent(in) :: data_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tm, te, tse, ts, tsw, tw, tnw, tn, tne integer, intent(in) :: ioff, joff - if(te>0) data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & + if(te>0) halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & data_all(1+ioff:ehalo+ioff, 1:nj(te)+joff, :,te) ! east - if(ts>0) data (1:ni(tm)+ioff, 1-shalo:0, :) = & + if(ts>0) halo_data (1:ni(tm)+ioff, 1-shalo:0, :) = & data_all(1:ni(ts)+ioff, nj(ts)-shalo+1:nj(ts), :,ts) ! south - if(tw>0) data (1-whalo:0, 1:nj(tm)+joff, :) = & + if(tw>0) halo_data (1-whalo:0, 1:nj(tm)+joff, :) = & data_all(ni(tw)-whalo+1:ni(tw), 1:nj(tw)+joff, :,tw) ! west - if(tn>0) data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tn>0) halo_data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1:ni(tn)+ioff, 1+joff:nhalo+joff, :,tn) ! north - if(tse>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & + if(tse>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & data_all(1+ioff:ehalo+ioff, nj(tse)-shalo+1:nj(tse), :,tse) ! southeast - if(tsw>0)data (1-whalo:0, 1-shalo:0, :) = & + if(tsw>0)halo_data (1-whalo:0, 1-shalo:0, :) = & data_all(ni(tsw)-whalo+1:ni(tsw), nj(tsw)-shalo+1:nj(tsw), :,tsw) ! southwest - if(tne>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tne>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff, :,tnw) ! northeast - if(tnw>0)data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tnw>0)halo_data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(ni(tnw)-whalo+1:ni(tnw), 1+joff:nhalo+joff, :,tne) ! northwest end subroutine fill_regular_refinement_halo_i4 ! Fill the halo points of a 64-bit real array on the regular mosaic grid - subroutine fill_regular_mosaic_halo_r8(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_mosaic_halo_r8(halo_data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real(kind=r8_kind), dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: te, tse, ts, tsw, tw, tnw, tn, tne - data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east - data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south - data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west - data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north - data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast - data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest - data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast - data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest + halo_data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east + halo_data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south + halo_data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west + halo_data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north + halo_data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast + halo_data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest + halo_data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast + halo_data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest end subroutine fill_regular_mosaic_halo_r8 !> Fill the halo points of a 32-bit real array on the regular mosaic grid - subroutine fill_regular_mosaic_halo_r4(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_mosaic_halo_r4(halo_data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real(kind=r4_kind), dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: te, tse, ts, tsw, tw, tnw, tn, tne - data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east - data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south - data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west - data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north - data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast - data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest - data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast - data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest + halo_data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east + halo_data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south + halo_data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west + halo_data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north + halo_data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast + halo_data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest + halo_data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast + halo_data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest end subroutine fill_regular_mosaic_halo_r4 ! Fill the halo points of a 64-bit integer array on the regular mosaic grid - subroutine fill_regular_mosaic_halo_i8(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_mosaic_halo_i8(halo_data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer(kind=i8_kind), dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: te, tse, ts, tsw, tw, tnw, tn, tne - data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east - data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south - data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west - data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north - data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast - data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest - data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast - data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest + halo_data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east + halo_data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south + halo_data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west + halo_data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north + halo_data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast + halo_data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest + halo_data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast + halo_data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest end subroutine fill_regular_mosaic_halo_i8 !> Fill the halo points of a 64-bit integer array on the regular mosaic grid - subroutine fill_regular_mosaic_halo_i4(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_mosaic_halo_i4(halo_data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer(kind=i4_kind), dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: te, tse, ts, tsw, tw, tnw, tn, tne - data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east - data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south - data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west - data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north - data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast - data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest - data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast - data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest + halo_data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east + halo_data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south + halo_data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west + halo_data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north + halo_data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast + halo_data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest + halo_data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast + halo_data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest end subroutine fill_regular_mosaic_halo_i4 !> Fill the halo region of a 64-bit array real on a domain with a folded north edge - subroutine fill_folded_north_halo_r8(data, ioff, joff, ishift, jshift, sign) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -378,18 +378,19 @@ subroutine fill_folded_north_halo_r8(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift,1:ny+jshift,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift,1:ny+jshift,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*halo_data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_r8 !> Fill the halo region of a 32-bit real array on a domain with a folded north edge - subroutine fill_folded_north_halo_r4(data, ioff, joff, ishift, jshift, sign) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -399,19 +400,20 @@ subroutine fill_folded_north_halo_r4(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift,1:ny+jshift,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift,1:ny+jshift,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*halo_data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_r4 !> Fill the halo region of a 64-bit integer array on a domain with a folded north edge - subroutine fill_folded_north_halo_i8(data, ioff, joff, ishift, jshift, sign) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_i8(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -421,18 +423,19 @@ subroutine fill_folded_north_halo_i8(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift,1:ny+jshift,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift,1:ny+jshift,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*halo_data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_i8 !> Fill the halo region of a 32-bit integer array on a domain with a folded north edge - subroutine fill_folded_north_halo_i4(data, ioff, joff, ishift, jshift, sign) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_i4(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -442,19 +445,20 @@ subroutine fill_folded_north_halo_i4(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift,1:ny+jshift,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift,1:ny+jshift,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*halo_data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_i4 !> Fill the halo region of a 64-bit real array on a domain with a folded south edge - subroutine fill_folded_south_halo_r8(data, ioff, joff, ishift, jshift, sign) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_south_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -464,19 +468,19 @@ subroutine fill_folded_south_halo_r8(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:nyp,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift, 1:nyp,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:nyp,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift, 1:nyp,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,1-shalo:0,:) = sign*data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) + halo_data(1-whalo:m1,1-shalo:0,:) = sign*halo_data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) - data(m1+1:nx+m2,1-shalo:0,:) = sign*data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) - data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(m1+1:nx+m2,1-shalo:0,:) = sign*halo_data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*halo_data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) end subroutine fill_folded_south_halo_r8 !> Fill the halo region of a 32-bit real array on a domain with a folded south edge - subroutine fill_folded_south_halo_r4(data, ioff, joff, ishift, jshift, sign) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_south_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -486,19 +490,19 @@ subroutine fill_folded_south_halo_r4(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:nyp,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift, 1:nyp,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:nyp,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift, 1:nyp,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,1-shalo:0,:) = sign*data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) + halo_data(1-whalo:m1,1-shalo:0,:) = sign*halo_data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) - data(m1+1:nx+m2,1-shalo:0,:) = sign*data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) - data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(m1+1:nx+m2,1-shalo:0,:) = sign*halo_data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*halo_data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) end subroutine fill_folded_south_halo_r4 !> Fill the halo region of a 64-bit intger array on a domain with a folded south edge - subroutine fill_folded_south_halo_i8(data, ioff, joff, ishift, jshift, sign) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_south_halo_i8(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -508,19 +512,19 @@ subroutine fill_folded_south_halo_i8(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:nyp,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift, 1:nyp,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:nyp,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift, 1:nyp,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,1-shalo:0,:) = sign*data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) + halo_data(1-whalo:m1,1-shalo:0,:) = sign*halo_data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) - data(m1+1:nx+m2,1-shalo:0,:) = sign*data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) - data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(m1+1:nx+m2,1-shalo:0,:) = sign*halo_data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*halo_data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) end subroutine fill_folded_south_halo_i8 !> Fill the halo region of a 32-bit integer array on a domain with a folded south edge - subroutine fill_folded_south_halo_i4(data, ioff, joff, ishift, jshift, sign) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_south_halo_i4(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -530,19 +534,19 @@ subroutine fill_folded_south_halo_i4(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:nyp,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift, 1:nyp,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:nyp,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift, 1:nyp,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,1-shalo:0,:) = sign*data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) + halo_data(1-whalo:m1,1-shalo:0,:) = sign*halo_data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) - data(m1+1:nx+m2,1-shalo:0,:) = sign*data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) - data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(m1+1:nx+m2,1-shalo:0,:) = sign*halo_data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*halo_data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) end subroutine fill_folded_south_halo_i4 !> Fill the halo region of a 64-bit real array on a domain with a folded west edge - subroutine fill_folded_west_halo_r8(data, ioff, joff, ishift, jshift, sign) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_west_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -552,18 +556,18 @@ subroutine fill_folded_west_halo_r8(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0,:) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo,:) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0,:) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo,:) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(1-whalo:0, 1-shalo:m1,:) = sign*data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) - data(1-whalo:0, m1+1:ny+m2,:) = sign*data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) - data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(1-whalo:0, 1-shalo:m1,:) = sign*halo_data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) + halo_data(1-whalo:0, m1+1:ny+m2,:) = sign*halo_data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) + halo_data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*halo_data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_west_halo_r8 !> Fill the halo region of a 32-bit real array on a domain with a folded west edge - subroutine fill_folded_west_halo_r4(data, ioff, joff, ishift, jshift, sign) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_west_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -573,18 +577,18 @@ subroutine fill_folded_west_halo_r4(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0,:) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo,:) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0,:) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo,:) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(1-whalo:0, 1-shalo:m1,:) = sign*data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) - data(1-whalo:0, m1+1:ny+m2,:) = sign*data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) - data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(1-whalo:0, 1-shalo:m1,:) = sign*halo_data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) + halo_data(1-whalo:0, m1+1:ny+m2,:) = sign*halo_data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) + halo_data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*halo_data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_west_halo_r4 !> Fill the halo region of a 64-bit integer array on a domain with a folded west edge - subroutine fill_folded_west_halo_i8(data, ioff, joff, ishift, jshift, sign) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_west_halo_i8(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -594,18 +598,18 @@ subroutine fill_folded_west_halo_i8(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0,:) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo,:) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0,:) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo,:) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(1-whalo:0, 1-shalo:m1,:) = sign*data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) - data(1-whalo:0, m1+1:ny+m2,:) = sign*data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) - data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(1-whalo:0, 1-shalo:m1,:) = sign*halo_data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) + halo_data(1-whalo:0, m1+1:ny+m2,:) = sign*halo_data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) + halo_data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*halo_data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_west_halo_i8 !> Fill the halo region of a 32-bit integer array on a domain with a folded west edge - subroutine fill_folded_west_halo_i4(data, ioff, joff, ishift, jshift, sign) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_west_halo_i4(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -615,18 +619,18 @@ subroutine fill_folded_west_halo_i4(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0,:) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo,:) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0,:) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo,:) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(1-whalo:0, 1-shalo:m1,:) = sign*data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) - data(1-whalo:0, m1+1:ny+m2,:) = sign*data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) - data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(1-whalo:0, 1-shalo:m1,:) = sign*halo_data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) + halo_data(1-whalo:0, m1+1:ny+m2,:) = sign*halo_data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) + halo_data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*halo_data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_west_halo_i4 !> Fill the halo region of a 64-bit real array on a domain with a folded east edge - subroutine fill_folded_east_halo_r8(data, ioff, joff, ishift, jshift, sign) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_east_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -636,19 +640,20 @@ subroutine fill_folded_east_halo_r8(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) + halo_data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) - data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) - data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) + halo_data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = & + sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_east_halo_r8 !> Fill the halo region of a 32-bit real array on a domain with a folded east edge - subroutine fill_folded_east_halo_r4(data, ioff, joff, ishift, jshift, sign) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_east_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -658,19 +663,20 @@ subroutine fill_folded_east_halo_r4(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) + halo_data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) - data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) - data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) + halo_data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = & + sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_east_halo_r4 !> Fill the halo region of a 64-bit integer array on a domain with a folded east edge - subroutine fill_folded_east_halo_i8(data, ioff, joff, ishift, jshift, sign) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_east_halo_i8(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -680,19 +686,20 @@ subroutine fill_folded_east_halo_i8(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) + halo_data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) - data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) - data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) + halo_data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = & + sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_east_halo_i8 !> Fill the halo region of a 32-bit integer array on a domain with a folded east edge - subroutine fill_folded_east_halo_i4(data, ioff, joff, ishift, jshift, sign) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_east_halo_i4(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -702,13 +709,14 @@ subroutine fill_folded_east_halo_i4(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) + halo_data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) - data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) - data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) + halo_data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = & + sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_east_halo_i4 diff --git a/test_fms/mpp/test_domains_utility_mod.F90 b/test_fms/mpp/test_domains_utility_mod.F90 index f88054b9f5..65926016ed 100644 --- a/test_fms/mpp/test_domains_utility_mod.F90 +++ b/test_fms/mpp/test_domains_utility_mod.F90 @@ -38,11 +38,11 @@ module test_domains_utility_mod contains -subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, nz, isd, jsd, nx, ny, & +subroutine fill_coarse_data_r8(coarse_data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, nz, isd, jsd, nx, ny, & ishift, jshift, x_add, y_add, sign1, sign2, x_cyclic, y_cyclic, ieg, jeg) integer, intent(in) :: rotate, is_c, ie_c, js_c, je_c, nz, isd, jsd, iadd, jadd, nx, ny, ishift, jshift integer, intent(in) :: sign1, sign2 - real(kind=r8_kind), intent(inout) :: data(isd:, jsd:, :) + real(kind=r8_kind), intent(inout) :: coarse_data(isd:, jsd:, :) real(kind=r8_kind), intent(in) :: x_add, y_add logical, intent(in) :: x_cyclic, y_cyclic integer, intent(in) :: ieg, jeg @@ -54,7 +54,7 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = dble(i+iadd)*1.d+6 + dble(j+jadd)*1.d+3 + dble(k) + x_add + coarse_data(i,j,k) = dble(i+iadd)*1.d+6 + dble(j+jadd)*1.d+3 + dble(k) + x_add enddo enddo enddo @@ -63,7 +63,7 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = sign1*( dble(nx-j+1+iadd+jshift)*1.d+6 + dble(i+jadd)*1.d+3 + dble(k) + y_add) + coarse_data(i,j,k) = sign1*( dble(nx-j+1+iadd+jshift)*1.d+6 + dble(i+jadd)*1.d+3 + dble(k) + y_add) enddo enddo enddo @@ -72,7 +72,7 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = sign2*( dble(j+iadd)*1.d+6 + dble(ny-i+1+jadd+ishift)*1.d+3 + dble(k) + y_add) + coarse_data(i,j,k) = sign2*( dble(j+iadd)*1.d+6 + dble(ny-i+1+jadd+ishift)*1.d+3 + dble(k) + y_add) enddo enddo enddo @@ -86,7 +86,7 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, i = ie_c+ishift do k = 1, nz do j = js_c, je_c+jshift - data(i,j,k) = dble(i)*1.d+6 + dble(j+jadd)*1.d+3 + dble(k) + x_add + coarse_data(i,j,k) = dble(i)*1.d+6 + dble(j+jadd)*1.d+3 + dble(k) + x_add enddo enddo endif @@ -98,7 +98,7 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, j = je_c+jshift do k = 1, nz do j = js_c, je_c+jshift - data(i,j,k) = dble(i+iadd)*1.d+6 + j*1.d+3 + dble(k) + x_add + coarse_data(i,j,k) = dble(i+iadd)*1.d+6 + j*1.d+3 + dble(k) + x_add enddo enddo endif @@ -107,11 +107,11 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, end subroutine fill_coarse_data_r8 -subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, nz, isd, jsd, nx, ny, & +subroutine fill_coarse_data_r4(coarse_data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, nz, isd, jsd, nx, ny, & ishift, jshift, x_add, y_add, sign1, sign2, x_cyclic, y_cyclic, ieg, jeg) integer, intent(in) :: rotate, is_c, ie_c, js_c, je_c, nz, isd, jsd, iadd, jadd, nx, ny, ishift, jshift integer, intent(in) :: sign1, sign2 - real(kind=r4_kind), intent(inout) :: data(isd:, jsd:, :) + real(kind=r4_kind), intent(inout) :: coarse_data(isd:, jsd:, :) real(kind=r4_kind), intent(in) :: x_add, y_add logical, intent(in) :: x_cyclic, y_cyclic integer, intent(in) :: ieg, jeg @@ -123,7 +123,7 @@ subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = (i+iadd)*1.e+6 + (j+jadd)*1.e+3 + k + x_add + coarse_data(i,j,k) = (i+iadd)*1.e+6 + (j+jadd)*1.e+3 + k + x_add enddo enddo enddo @@ -132,7 +132,7 @@ subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = sign1*((nx-j+1+iadd+jshift)*1.e+6 + (i+jadd)*1.e+3 + k + y_add) + coarse_data(i,j,k) = sign1*((nx-j+1+iadd+jshift)*1.e+6 + (i+jadd)*1.e+3 + k + y_add) enddo enddo enddo @@ -141,7 +141,7 @@ subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = sign2*((j+iadd)*1.e+6 + (ny-i+1+jadd+ishift)*1.e+3 + k + y_add) + coarse_data(i,j,k) = sign2*((j+iadd)*1.e+6 + (ny-i+1+jadd+ishift)*1.e+3 + k + y_add) enddo enddo enddo @@ -155,7 +155,7 @@ subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, i = ie_c+ishift do k = 1, nz do j = js_c, je_c+jshift - data(i,j,k) = i*1.e+6 + (j+jadd)*1.e+3 + k + x_add + coarse_data(i,j,k) = i*1.e+6 + (j+jadd)*1.e+3 + k + x_add enddo enddo endif @@ -167,7 +167,7 @@ subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, j = je_c+jshift do k = 1, nz do j = js_c, je_c+jshift - data(i,j,k) = (i+iadd)*1.e+6 + j*1.e+3 + k + x_add + coarse_data(i,j,k) = (i+iadd)*1.e+6 + j*1.e+3 + k + x_add enddo enddo endif diff --git a/test_fms/mpp/test_mpp_domains.F90 b/test_fms/mpp/test_mpp_domains.F90 index 3ca557788f..ffd9a45d26 100644 --- a/test_fms/mpp/test_mpp_domains.F90 +++ b/test_fms/mpp/test_mpp_domains.F90 @@ -3678,63 +3678,64 @@ subroutine test_unstruct_update( type ) end subroutine test_unstruct_update !################################################################################# - subroutine fill_halo_zero(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, jsd, jed) + subroutine fill_halo_zero(halo_data, whalo, ehalo, shalo, nhalo, xshift, yshift, & + isc, iec, jsc, jec, isd, ied, jsd, jed) integer, intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed integer, intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift - real, dimension(isd:,jsd:,:), intent(inout) :: data + real, dimension(isd:,jsd:,:), intent(inout) :: halo_data if(whalo >=0) then - data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 - data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 + halo_data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 + halo_data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 else - data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 - data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 end if if(shalo>=0) then - data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 - data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 + halo_data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 + halo_data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 else - data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 - data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 end if end subroutine fill_halo_zero !############################################################################## ! this routine fill the halo points for the regular mosaic. - subroutine fill_regular_mosaic_halo(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_mosaic_halo(halo_data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real, dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: te, tse, ts, tsw, tw, tnw, tn, tne - data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east - data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south - data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west - data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north - data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast - data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest - data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast - data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest + halo_data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east + halo_data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south + halo_data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west + halo_data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north + halo_data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast + halo_data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest + halo_data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast + halo_data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest end subroutine fill_regular_mosaic_halo - subroutine fill_folded_north_halo(data, ioff, joff, ishift, jshift, sign) - class(*), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo(halo_data, ioff, joff, ishift, jshift, sign) + class(*), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign - select type(data) + select type(halo_data) type is (real(r4_kind)) - call fill_folded_north_halo_r4(data, ioff, joff, ishift, jshift, sign) + call fill_folded_north_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) type is (real(r8_kind)) - call fill_folded_north_halo_r8(data, ioff, joff, ishift, jshift, sign) + call fill_folded_north_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) end select end subroutine !################################################################################ - subroutine fill_folded_north_halo_r4(data, ioff, joff, ishift, jshift, sign) - real(r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) + real(r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign integer :: nxp, nyp, m1, m2 @@ -3743,17 +3744,19 @@ subroutine fill_folded_north_halo_r4(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0, 1:nyp,:) = data(nx-whalo+1:nx, 1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift, 1:nyp,:) = data(1:ehalo+ishift, 1:ny+jshift,:) ! east - if(m1 .GE. 1-whalo) data(1-whalo:m1, nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1, & + halo_data(1-whalo:0, 1:nyp,:) = halo_data(nx-whalo+1:nx, 1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift, 1:nyp,:) = halo_data(1:ehalo+ishift, 1:ny+jshift,:) ! east + if(m1 .GE. 1-whalo) halo_data(1-whalo:m1, nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1, & & nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2, nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2, nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx+ishift:1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_r4 ! r8 version needed for mixed mode - subroutine fill_folded_north_halo_r8(data, ioff, joff, ishift, jshift, sign) - real(r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) + real(r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign integer :: nxp, nyp, m1, m2 @@ -3762,18 +3765,20 @@ subroutine fill_folded_north_halo_r8(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0, 1:nyp,:) = data(nx-whalo+1:nx, 1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift, 1:nyp,:) = data(1:ehalo+ishift, 1:ny+jshift,:) ! east + halo_data(1-whalo:0, 1:nyp,:) = halo_data(nx-whalo+1:nx, 1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift, 1:nyp,:) = halo_data(1:ehalo+ishift, 1:ny+jshift,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1, nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2, nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(1-whalo:m1, nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2, nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx+ishift:1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_r8 !################################################################################ - subroutine fill_folded_south_halo(data, ioff, joff, ishift, jshift, sign) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_south_halo(halo_data, ioff, joff, ishift, jshift, sign) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign integer :: nxp, nyp, m1, m2 @@ -3783,17 +3788,18 @@ subroutine fill_folded_south_halo(data, ioff, joff, ishift, jshift, sign) m2 = 2*ishift - ioff - data(1-whalo:0, 1:nyp,:) = data(nx-whalo+1:nx, 1:nyp,:) ! west - data(nx+1:nx+ehalo+ishift, 1:nyp,:) = data(1:ehalo+ishift, 1:nyp,:) ! east - if(m1 .GE. 1-whalo)data(1-whalo:m1, 1-shalo:0,:) = sign*data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) - data(m1+1:nx+m2, 1-shalo:0,:) = sign*data(nxp:1:-1, shalo+jshift:1+jshift:-1,:) - data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*data(nx:nx-ehalo+m1+1:-1, shalo+jshift:1+jshift:-1,:) + halo_data(1-whalo:0, 1:nyp,:) = halo_data(nx-whalo+1:nx, 1:nyp,:) ! west + halo_data(nx+1:nx+ehalo+ishift, 1:nyp,:) = halo_data(1:ehalo+ishift, 1:nyp,:) ! east + if(m1 .GE. 1-whalo)halo_data(1-whalo:m1, 1-shalo:0,:) = & + sign*halo_data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) + halo_data(m1+1:nx+m2, 1-shalo:0,:) = sign*halo_data(nxp:1:-1, shalo+jshift:1+jshift:-1,:) + halo_data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*halo_data(nx:nx-ehalo+m1+1:-1, shalo+jshift:1+jshift:-1,:) end subroutine fill_folded_south_halo !################################################################################ - subroutine fill_folded_west_halo(data, ioff, joff, ishift, jshift, sign) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_west_halo(halo_data, ioff, joff, ishift, jshift, sign) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign integer :: nxp, nyp, m1, m2 @@ -3802,17 +3808,18 @@ subroutine fill_folded_west_halo(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north - if(m1 .GE. 1-shalo) data(1-whalo:0, 1-shalo:m1, :) = sign*data(whalo+ishift:1+ishift:-1, shalo+m2:1+jshift:-1,:) - data(1-whalo:0, m1+1:ny+m2, :) = sign*data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) - data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north + if(m1 .GE. 1-shalo) halo_data(1-whalo:0, 1-shalo:m1, :) = & + sign*halo_data(whalo+ishift:1+ishift:-1, shalo+m2:1+jshift:-1,:) + halo_data(1-whalo:0, m1+1:ny+m2, :) = sign*halo_data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) + halo_data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*halo_data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_west_halo !################################################################################ - subroutine fill_folded_east_halo(data, ioff, joff, ishift, jshift, sign) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_east_halo(halo_data, ioff, joff, ishift, jshift, sign) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign integer :: nxp, nyp, m1, m2 @@ -3821,12 +3828,13 @@ subroutine fill_folded_east_halo(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north - if(m1 .GE. 1-shalo) data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, & + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north + if(m1 .GE. 1-shalo) halo_data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, & & shalo+m2:1+jshift:-1,:) - data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) - data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) + halo_data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = & + sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_east_halo @@ -4081,8 +4089,8 @@ end subroutine fill_cubic_grid_bound !############################################################################## ! this routine fill the halo points for the cubic grid. ioff and joff is used to distinguish ! T, C, E, or N-cell - subroutine fill_cubic_grid_halo(data, data1_all, data2_all, tile, ioff, joff, sign1, sign2) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_cubic_grid_halo(halo_data, data1_all, data2_all, tile, ioff, joff, sign1, sign2) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real, dimension(:,:,:,:), intent(in) :: data1_all, data2_all integer, intent(in) :: tile, ioff, joff, sign1, sign2 integer :: lw, le, ls, ln @@ -4092,26 +4100,26 @@ subroutine fill_cubic_grid_halo(data, data1_all, data2_all, tile, ioff, joff, si if(le > 6 ) le = le - 6 if(ls < 1 ) ls = ls + 6 if(ln > 6 ) ln = ln - 6 - data(1-whalo:0, 1:ny+joff, :) = data1_all(nx-whalo+1:nx, 1:ny+joff, :, lw) ! west + halo_data(1-whalo:0, 1:ny+joff, :) = data1_all(nx-whalo+1:nx, 1:ny+joff, :, lw) ! west do i = 1, ehalo - data(nx+i+ioff, 1:ny+joff, :) = sign1*data2_all(nx+joff:1:-1, i+ioff, :, le) ! east + halo_data(nx+i+ioff, 1:ny+joff, :) = sign1*data2_all(nx+joff:1:-1, i+ioff, :, le) ! east end do do i = 1, shalo - data(1:nx+ioff, 1-i, :) = sign2*data2_all(nx-i+1, ny+ioff:1:-1, :, ls) ! south + halo_data(1:nx+ioff, 1-i, :) = sign2*data2_all(nx-i+1, ny+ioff:1:-1, :, ls) ! south end do - data(1:nx+ioff, ny+1+joff:ny+nhalo+joff, :) = data1_all(1:nx+ioff, 1+joff:nhalo+joff, :, ln) ! north + halo_data(1:nx+ioff, ny+1+joff:ny+nhalo+joff, :) = data1_all(1:nx+ioff, 1+joff:nhalo+joff, :, ln) ! north else ! tile 1, 3, 5 lw = tile - 2; le = tile + 1; ls = tile - 1; ln = tile + 2 if(lw < 1 ) lw = lw + 6 if(ls < 1 ) ls = ls + 6 if(ln > 6 ) ln = ln - 6 do i = 1, whalo - data(1-i, 1:ny+joff, :) = sign1*data2_all(nx+joff:1:-1, ny-i+1, :, lw) ! west + halo_data(1-i, 1:ny+joff, :) = sign1*data2_all(nx+joff:1:-1, ny-i+1, :, lw) ! west end do - data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff, :) = data1_all(1+ioff:ehalo+ioff, 1:ny+joff, :, le) ! east - data(1:nx+ioff, 1-shalo:0, :) = data1_all(1:nx+ioff, ny-shalo+1:ny, :, ls) ! south + halo_data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff, :) = data1_all(1+ioff:ehalo+ioff, 1:ny+joff, :, le) ! east + halo_data(1:nx+ioff, 1-shalo:0, :) = data1_all(1:nx+ioff, ny-shalo+1:ny, :, ls) ! south do i = 1, nhalo - data(1:nx+ioff, ny+i+joff, :) = sign2*data2_all(i+joff, ny+ioff:1:-1, :, ln) ! north + halo_data(1:nx+ioff, ny+i+joff, :) = sign2*data2_all(i+joff, ny+ioff:1:-1, :, ln) ! north end do end if @@ -4456,8 +4464,8 @@ subroutine test_nonuniform_mosaic( type ) end subroutine test_nonuniform_mosaic - subroutine fill_five_tile_halo(data, data_all, tile, ioff, joff) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_five_tile_halo(halo_data, data_all, tile, ioff, joff) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real, dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: tile, ioff, joff integer :: nxm, nym @@ -4466,57 +4474,58 @@ subroutine fill_five_tile_halo(data, data_all, tile, ioff, joff) select case(tile) case(1) - data(nxm+1+ioff:nxm+ehalo+ioff, 1:ny,:) = data_all(1+ioff:ehalo+ioff, 1:ny,:,2) ! east - data(nxm+1+ioff:nxm+ehalo+ioff, ny+1:nym+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,4) ! east - data(1-whalo:0, 1:ny,:) = data_all(nx-whalo+1:nx, 1:ny,:,3) ! west - data(1-whalo:0, ny+1:nym+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,5) ! west - data(1:nxm+ioff, 1-shalo:0,:) = data_all(1:nxm+ioff, nym-shalo+1:nym,:,1) ! south - data(1:nxm+ioff, nym+1+joff:nym+nhalo+joff,:) = data_all(1:nxm+ioff, 1+joff:nhalo+joff,:,1) ! north - data(nxm+1+ioff:nxm+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,4) ! southeast - data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,5) ! southwest - data(nxm+1+ioff:nxm+ehalo+ioff,nym+1+joff:nym+nhalo+joff,:) = & + halo_data(nxm+1+ioff:nxm+ehalo+ioff, 1:ny,:) = data_all(1+ioff:ehalo+ioff, 1:ny,:,2) ! east + halo_data(nxm+1+ioff:nxm+ehalo+ioff, ny+1:nym+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,4) ! east + halo_data(1-whalo:0, 1:ny,:) = data_all(nx-whalo+1:nx, 1:ny,:,3) ! west + halo_data(1-whalo:0, ny+1:nym+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,5) ! west + halo_data(1:nxm+ioff, 1-shalo:0,:) = data_all(1:nxm+ioff, nym-shalo+1:nym,:,1) ! south + halo_data(1:nxm+ioff, nym+1+joff:nym+nhalo+joff,:) = data_all(1:nxm+ioff, 1+joff:nhalo+joff,:,1) ! north + halo_data(nxm+1+ioff:nxm+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,4) ! southeast + halo_data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,5) ! southwest + halo_data(nxm+1+ioff:nxm+ehalo+ioff,nym+1+joff:nym+nhalo+joff,:) = & & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff,:,2) ! northeast - data(1-whalo:0, nym+1+joff:nym+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,3) ! northwest + halo_data(1-whalo:0, nym+1+joff:nym+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,3) ! northwest case(2) - data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,3) ! east - data(1-whalo:0, 1:ny+joff,:) = data_all(nxm-whalo+1:nxm, 1:ny+joff,:,1) ! west - data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,4) ! south - data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,4) ! north - data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,5) ! southeast - data(1-whalo:0, 1-shalo:0,:) = data_all(nxm-whalo+1:nxm, nym-shalo+1:nym,:,1) ! southwest - data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & - & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff,:,5) ! northeast - data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nxm-whalo+1:nxm, ny+1+joff:ny+nhalo+joff,:,1) ! northwest + halo_data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,3) ! east + halo_data(1-whalo:0, 1:ny+joff,:) = data_all(nxm-whalo+1:nxm, 1:ny+joff,:,1) ! west + halo_data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,4) ! south + halo_data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,4) ! north + halo_data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,5) ! southeast + halo_data(1-whalo:0, 1-shalo:0,:) = data_all(nxm-whalo+1:nxm, nym-shalo+1:nym,:,1) ! southwest + halo_data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & + & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff,:,5) ! northeast + halo_data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = & + data_all(nxm-whalo+1:nxm, ny+1+joff:ny+nhalo+joff,:,1) ! northwest case(3) - data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,1) ! east - data(1-whalo:0, 1:ny+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,2) ! west - data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,5) ! south - data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,5) ! north - data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, nym-shalo+1:nym,:,1) ! southeast - data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,4) ! southwest - data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & - & data_all(1+ioff:ehalo+ioff,ny+1+joff:ny+nhalo+joff,:,1) ! northeast - data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,4) ! northwest + halo_data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,1) ! east + halo_data(1-whalo:0, 1:ny+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,2) ! west + halo_data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,5) ! south + halo_data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,5) ! north + halo_data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, nym-shalo+1:nym,:,1) ! southeast + halo_data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,4) ! southwest + halo_data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & + & data_all(1+ioff:ehalo+ioff,ny+1+joff:ny+nhalo+joff,:,1) ! northeast + halo_data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,4) ! northwest case(4) - data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,5) ! east - data(1-whalo:0, 1:ny+joff,:) = data_all(nxm-whalo+1:nxm, ny+1:2*ny+joff,:,1) ! west - data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,2) ! south - data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,2) ! north - data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,3) ! southeast - data(1-whalo:0, 1-shalo:0,:) = data_all(nxm-whalo+1:nxm, ny-shalo+1:ny,:,1) ! southwest - data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & + halo_data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,5) ! east + halo_data(1-whalo:0, 1:ny+joff,:) = data_all(nxm-whalo+1:nxm, ny+1:2*ny+joff,:,1) ! west + halo_data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,2) ! south + halo_data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,2) ! north + halo_data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,3) ! southeast + halo_data(1-whalo:0, 1-shalo:0,:) = data_all(nxm-whalo+1:nxm, ny-shalo+1:ny,:,1) ! southwest + halo_data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & & data_all(1+ioff:ehalo+ioff,1+joff:nhalo+joff,:,3) ! northeast - data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nxm-whalo+1:nxm, 1+joff:nhalo+joff,:,1) ! northwest + halo_data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nxm-whalo+1:nxm, 1+joff:nhalo+joff,:,1) ! northwest case(5) - data(nx+1+ioff:nx+ehalo+ioff, 1: ny+joff,:) = data_all(1+ioff:ehalo+ioff, ny+1:2*ny+joff,:,1) ! east - data(1-whalo:0, 1:ny+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,4) ! west - data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,3) ! south - data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,3) ! north - data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,1) ! southeast - data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,2) ! southwest - data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & + halo_data(nx+1+ioff:nx+ehalo+ioff, 1: ny+joff,:) = data_all(1+ioff:ehalo+ioff, ny+1:2*ny+joff,:,1) ! east + halo_data(1-whalo:0, 1:ny+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,4) ! west + halo_data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,3) ! south + halo_data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,3) ! north + halo_data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,1) ! southeast + halo_data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,2) ! southwest + halo_data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & & data_all(1+ioff:ehalo+ioff,1+joff:nhalo+joff,:,1) ! northeast - data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,2) ! northwest + halo_data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,2) ! northwest end select end subroutine fill_five_tile_halo @@ -5294,29 +5303,30 @@ subroutine test_get_boundary(type) end subroutine test_get_boundary !####################################################################################### - subroutine fill_regular_refinement_halo( data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, ioff, joff ) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_refinement_halo( halo_data, data_all, ni, nj, tm, te, tse, ts, & + tsw, tw, tnw, tn, tne, ioff, joff ) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real, dimension(:,:,:,:), intent(in) :: data_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tm, te, tse, ts, tsw, tw, tnw, tn, tne integer, intent(in) :: ioff, joff - if(te>0) data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & + if(te>0) halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & data_all(1+ioff:ehalo+ioff, 1:nj(te)+joff, :,te) ! east - if(ts>0) data (1:ni(tm)+ioff, 1-shalo:0, :) = & + if(ts>0) halo_data (1:ni(tm)+ioff, 1-shalo:0, :) = & data_all(1:ni(ts)+ioff, nj(ts)-shalo+1:nj(ts), :,ts) ! south - if(tw>0) data (1-whalo:0, 1:nj(tm)+joff, :) = & + if(tw>0) halo_data (1-whalo:0, 1:nj(tm)+joff, :) = & data_all(ni(tw)-whalo+1:ni(tw), 1:nj(tw)+joff, :,tw) ! west - if(tn>0) data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tn>0) halo_data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1:ni(tn)+ioff, 1+joff:nhalo+joff, :,tn) ! north - if(tse>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & + if(tse>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & data_all(1+ioff:ehalo+ioff, nj(tse)-shalo+1:nj(tse), :,tse) ! southeast - if(tsw>0)data (1-whalo:0, 1-shalo:0, :) = & + if(tsw>0)halo_data (1-whalo:0, 1-shalo:0, :) = & data_all(ni(tsw)-whalo+1:ni(tsw), nj(tsw)-shalo+1:nj(tsw), :,tsw) ! southwest - if(tne>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tne>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff, :,tnw) ! northeast - if(tnw>0)data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tnw>0)halo_data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(ni(tnw)-whalo+1:ni(tnw), 1+joff:nhalo+joff, :,tne) ! northwest end subroutine fill_regular_refinement_halo @@ -5324,8 +5334,8 @@ end subroutine fill_regular_refinement_halo !############################################################################## ! this routine fill the halo points for the refined cubic grid. ioff and joff is used to distinguish ! T, C, E, or N-cell - subroutine fill_cubicgrid_refined_halo(data, data1_all, data2_all, ni, nj, tile, ioff, joff, sign1, sign2) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_cubicgrid_refined_halo(halo_data, data1_all, data2_all, ni, nj, tile, ioff, joff, sign1, sign2) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real, dimension(:,:,:,:), intent(in) :: data1_all, data2_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tile, ioff, joff, sign1, sign2 @@ -5337,20 +5347,20 @@ subroutine fill_cubicgrid_refined_halo(data, data1_all, data2_all, ni, nj, tile, if(ls < 1 ) ls = ls + 6 if(ln > 6 ) ln = ln - 6 if( nj(tile) == nj(lw) ) then - data(1-whalo:0, 1:nj(tile)+joff, :) = data1_all(ni(lw)-whalo+1:ni(lw), 1:nj(lw)+joff, :, lw) ! west + halo_data(1-whalo:0, 1:nj(tile)+joff, :) = data1_all(ni(lw)-whalo+1:ni(lw), 1:nj(lw)+joff, :, lw) ! west end if if( nj(tile) == ni(le) ) then do i = 1, ehalo - data(ni(tile)+i+ioff, 1:nj(tile)+joff, :) = sign1*data2_all(ni(le)+joff:1:-1, i+ioff, :, le) ! east + halo_data(ni(tile)+i+ioff, 1:nj(tile)+joff, :) = sign1*data2_all(ni(le)+joff:1:-1, i+ioff, :, le) ! east end do end if if(ni(tile) == nj(ls) ) then do i = 1, shalo - data(1:ni(tile)+ioff, 1-i, :) = sign2*data2_all(ni(ls)-i+1, nj(ls)+ioff:1:-1, :, ls) ! south + halo_data(1:ni(tile)+ioff, 1-i, :) = sign2*data2_all(ni(ls)-i+1, nj(ls)+ioff:1:-1, :, ls) ! south end do end if if(ni(tile) == ni(ln) ) then - data(1:ni(tile)+ioff, nj(tile)+1+joff:nj(tile)+nhalo+joff, :) = & + halo_data(1:ni(tile)+ioff, nj(tile)+1+joff:nj(tile)+nhalo+joff, :) = & & data1_all(1:ni(ln)+ioff, 1+joff:nhalo+joff, :, ln) ! north end if else ! tile 1, 3, 5 @@ -5360,34 +5370,34 @@ subroutine fill_cubicgrid_refined_halo(data, data1_all, data2_all, ni, nj, tile, if(ln > 6 ) ln = ln - 6 if(nj(tile) == ni(lw) ) then do i = 1, whalo - data(1-i, 1:nj(tile)+joff, :) = sign1*data2_all(ni(lw)+joff:1:-1, nj(lw)-i+1, :, lw) ! west + halo_data(1-i, 1:nj(tile)+joff, :) = sign1*data2_all(ni(lw)+joff:1:-1, nj(lw)-i+1, :, lw) ! west end do end if if(nj(tile) == nj(le) ) then - data(ni(tile)+1+ioff:ni(tile)+ehalo+ioff, 1:nj(tile)+joff, :) = & + halo_data(ni(tile)+1+ioff:ni(tile)+ehalo+ioff, 1:nj(tile)+joff, :) = & & data1_all(1+ioff:ehalo+ioff, 1:nj(le)+joff, :, le) ! east end if if(ni(tile) == ni(ls) ) then - data(1:ni(tile)+ioff, 1-shalo:0, :) = data1_all(1:ni(ls)+ioff, nj(ls)-shalo+1:nj(ls), :, ls) ! south + halo_data(1:ni(tile)+ioff, 1-shalo:0, :) = data1_all(1:ni(ls)+ioff, nj(ls)-shalo+1:nj(ls), :, ls) ! south end if if(ni(tile) == nj(ln) ) then do i = 1, nhalo - data(1:ni(tile)+ioff, nj(tile)+i+joff, :) = sign2*data2_all(i+joff, nj(ln)+ioff:1:-1, :, ln) ! north + halo_data(1:ni(tile)+ioff, nj(tile)+i+joff, :) = sign2*data2_all(i+joff, nj(ln)+ioff:1:-1, :, ln) ! north end do end if end if end subroutine fill_cubicgrid_refined_halo - subroutine set_corner_zero( data, isd, ied, jsd, jed, isc, iec, jsc, jec ) + subroutine set_corner_zero( corner_data, isd, ied, jsd, jed, isc, iec, jsc, jec ) integer, intent(in) :: isd, ied, jsd, jed integer, intent(in) :: isc, iec, jsc, jec - real, dimension(isd:,jsd:,:), intent(inout) :: data + real, dimension(isd:,jsd:,:), intent(inout) :: corner_data - data (isd :isc-1, jsd :jsc-1,:) = 0 - data (isd :isc-1, jec+1:jed, :) = 0 - data (iec+1:ied , jsd :jsc-1,:) = 0 - data (iec+1:ied , jec+1:jed, :) = 0 + corner_data (isd :isc-1, jsd :jsc-1,:) = 0 + corner_data (isd :isc-1, jec+1:jed, :) = 0 + corner_data (iec+1:ied , jsd :jsc-1,:) = 0 + corner_data (iec+1:ied , jec+1:jed, :) = 0 end subroutine set_corner_zero diff --git a/test_fms/mpp/test_mpp_gatscat.F90 b/test_fms/mpp/test_mpp_gatscat.F90 index d5709b91c7..5e5646487b 100644 --- a/test_fms/mpp/test_mpp_gatscat.F90 +++ b/test_fms/mpp/test_mpp_gatscat.F90 @@ -121,7 +121,7 @@ subroutine test_scatter_2D_R4(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k - real(kind=r4_kind), allocatable, dimension(:,:) :: data !!Data to be scattered + real(kind=r4_kind), allocatable, dimension(:,:) :: scatter_data !!Data to be scattered real(kind=r4_kind), allocatable, dimension(:,:) :: segment integer :: DS, SS !!Source data size and segment size integer :: iz, jz !!The zeroth element to be scattered is at pos data(is+iz, js+jz) @@ -130,7 +130,7 @@ subroutine test_scatter_2D_R4(npes,pe,root,out_unit) DS = 7 !! DS should be less than 10 for the tests below to make sense. SS = 6 - allocate(data(DS, DS)) + allocate(scatter_data(DS, DS)) allocate(segment(SS, SS)) !!The full PE list [0, ...,npes-1] @@ -139,7 +139,7 @@ subroutine test_scatter_2D_R4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + scatter_data = -1 segment = -2.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula @@ -147,7 +147,7 @@ subroutine test_scatter_2D_R4(npes,pe,root,out_unit) if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10 + j + scatter_data(i,j) = i*10 + j enddo enddo !! And re-initalize segment on the root pe. @@ -170,9 +170,9 @@ subroutine test_scatter_2D_R4(npes,pe,root,out_unit) js = 2 je = 3 if(pe .eq. root) then - call mpp_scatter(is, ie, js, je, pelist(1:npes-1), segment, data, .true., iz, jz) + call mpp_scatter(is, ie, js, je, pelist(1:npes-1), segment, scatter_data, .true., iz, jz) else - call mpp_scatter(is, ie, js, je, pelist(1:npes -1), segment, data, .false., iz, jz) + call mpp_scatter(is, ie, js, je, pelist(1:npes -1), segment, scatter_data, .false., iz, jz) endif call mpp_sync() ! @@ -227,7 +227,7 @@ subroutine test_scatter_2D_R8(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k - real(kind=r8_kind), allocatable, dimension(:,:) :: data !!Data to be scattered + real(kind=r8_kind), allocatable, dimension(:,:) :: scatter_data !!Data to be scattered real(kind=r8_kind), allocatable, dimension(:,:) :: segment integer :: DS, SS !!Source data size and segment size integer :: iz, jz !!The zeroth element to be scattered is at pos data(is+iz, js+jz) @@ -237,7 +237,7 @@ subroutine test_scatter_2D_R8(npes,pe,root,out_unit) DS = 7 !! DS should be less than 10 for the tests below to make sense. SS = 6 - allocate(data(DS, DS)) + allocate(scatter_data(DS, DS)) allocate(segment(SS, SS)) !!The full PE list [0, ...,npes-1] @@ -246,7 +246,7 @@ subroutine test_scatter_2D_R8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + scatter_data = -1 segment = -2.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula @@ -254,7 +254,7 @@ subroutine test_scatter_2D_R8(npes,pe,root,out_unit) if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10 + j + scatter_data(i,j) = i*10 + j enddo enddo !! And re-initalize segment on the root pe. @@ -277,9 +277,9 @@ subroutine test_scatter_2D_R8(npes,pe,root,out_unit) js = 2 je = 3 if(pe .eq. root) then - call mpp_scatter(is, ie, js, je, pelist(1:npes-1), segment, data, .true., iz, jz) + call mpp_scatter(is, ie, js, je, pelist(1:npes-1), segment, scatter_data, .true., iz, jz) else - call mpp_scatter(is, ie, js, je, pelist(1:npes -1), segment, data, .false., iz, jz) + call mpp_scatter(is, ie, js, je, pelist(1:npes -1), segment, scatter_data, .false., iz, jz) endif call mpp_sync() @@ -334,7 +334,7 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k - real(kind=r4_kind), allocatable, dimension(:,:,:) :: data !!Data to be scattered + real(kind=r4_kind), allocatable, dimension(:,:,:) :: scatter_data !!Data to be scattered real(kind=r4_kind), allocatable, dimension(:,:,:) :: segment integer :: DS, SS !!Source data size and segment size integer :: iz, jz !!The zeroth element to be scattered is at pos data(is+iz, js+jz) @@ -346,7 +346,7 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) NZ = 11 !! Depth of the square tube to be scattered. DS = 6 !! DS should be less than 10 for the tests below to make sense. SS = 5 !! Can be different that DS, but see retrictions. - allocate(data(DS, DS, NZ)) + allocate(scatter_data(DS, DS, NZ)) allocate(segment(SS, SS, NZ)) !!The full PE list is [0, ...,npes-1] @@ -355,7 +355,7 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + scatter_data = -1 segment = -2.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula @@ -364,7 +364,7 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100 + j*10 + i + scatter_data(i,j, k) = k*100 + j*10 + i enddo enddo enddo @@ -372,7 +372,7 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) do i = 1,SS do j = 1,SS do k = 1,NZ - segment(i,j, k) = data(i,j, k) + segment(i,j, k) = scatter_data(i,j, k) enddo enddo enddo @@ -390,9 +390,9 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) js = 2 je = 3 if(pe .eq. root) then - call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes-1), segment, data, .true., iz, jz) + call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes-1), segment, scatter_data, .true., iz, jz) else - call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes -1), segment, data, .false., iz, jz) + call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes -1), segment, scatter_data, .false., iz, jz) endif call mpp_sync() @@ -464,7 +464,7 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k - real(kind=r8_kind), allocatable, dimension(:,:,:) :: data !!Data to be scattered + real(kind=r8_kind), allocatable, dimension(:,:,:) :: scatter_data !!Data to be scattered real(kind=r8_kind), allocatable, dimension(:,:,:) :: segment integer :: DS, SS !!Source data size and segment size integer :: iz, jz !!The zeroth element to be scattered is at pos data(is+iz, js+jz) @@ -476,7 +476,7 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) NZ = 11 !! Depth of the square tube to be scattered. DS = 6 !! DS should be less than 10 for the tests below to make sense. SS = 5 !! Can be different that DS, but see retrictions. - allocate(data(DS, DS, NZ)) + allocate(scatter_data(DS, DS, NZ)) allocate(segment(SS, SS, NZ)) !!The full PE list is [0, ...,npes-1] @@ -485,7 +485,7 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + scatter_data = -1 segment = -2.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula @@ -494,7 +494,7 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100 + j*10 + i + scatter_data(i,j, k) = k*100 + j*10 + i enddo enddo enddo @@ -502,7 +502,7 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) do i = 1,SS do j = 1,SS do k = 1,NZ - segment(i,j, k) = data(i,j, k) + segment(i,j, k) = scatter_data(i,j, k) enddo enddo enddo @@ -520,9 +520,9 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) js = 2 je = 3 if(pe .eq. root) then - call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes-1), segment, data, .true., iz, jz) + call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes-1), segment, scatter_data, .true., iz, jz) else - call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes -1), segment, data, .false., iz, jz) + call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes -1), segment, scatter_data, .false., iz, jz) endif call mpp_sync() @@ -787,7 +787,7 @@ subroutine test_gather2DV(npes,pe,root,out_unit) integer :: pelist(npes),rsize(npes) integer :: pelist2(npes),rsize2(npes) integer :: i,j,k,l,nz,ssize,nelems - real,allocatable,dimension(:,:) :: data, cdata, sbuff,rbuff + real,allocatable,dimension(:,:) :: gather_data, cdata, sbuff,rbuff real,allocatable :: ref(:,:) integer, parameter :: KSIZE=10 @@ -805,9 +805,9 @@ subroutine test_gather2DV(npes,pe,root,out_unit) write(out_unit,*) ssize = pe+1 - allocate(data(ssize,KSIZE)) + allocate(gather_data(ssize,KSIZE)) do k=1,KSIZE; do i=1,ssize - data(i,k) = 10000.0*k + pe + 0.0001*i + gather_data(i,k) = 10000.0*k + pe + 0.0001*i enddo; enddo do i=1,npes pelist(i) = i-1 @@ -834,7 +834,7 @@ subroutine test_gather2DV(npes,pe,root,out_unit) ! and a clear, concise unpack do j=1,ssize do i=1,nz - sbuff(i,j) = data(j,i) + sbuff(i,j) = gather_data(j,i) enddo; enddo ! Note that the gatherV implied here is asymmetric; only root needs to know the vector of recv size @@ -892,7 +892,7 @@ subroutine test_gather2DV(npes,pe,root,out_unit) endif call mpp_sync() write(out_unit,*) "Test gather2DV with reversed pelist successful" - deallocate(data,sbuff,rbuff,cdata,ref) + deallocate(gather_data,sbuff,rbuff,cdata,ref) end subroutine test_gather2DV end program test_mpp_gatscat diff --git a/test_fms/mpp/test_mpp_sendrecv.F90 b/test_fms/mpp/test_mpp_sendrecv.F90 index 5f82683e14..c90b7bbfcc 100644 --- a/test_fms/mpp/test_mpp_sendrecv.F90 +++ b/test_fms/mpp/test_mpp_sendrecv.F90 @@ -119,11 +119,11 @@ subroutine test_sendrecv_2D_R4(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j, p - real(kind=r4_kind), allocatable, dimension(:,:) :: data !!Data to be sendrecved + real(kind=r4_kind), allocatable, dimension(:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS DS = 9 - allocate(data(DS, DS)) + allocate(sendrecv_data (DS, DS)) !!The full PE list [0, ...,npes-1] do i=0,npes-1 @@ -131,14 +131,14 @@ subroutine test_sendrecv_2D_R4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1.0 + sendrecv_data = -1.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4) is 34.000, etc. if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10.0 + j*1.0 + sendrecv_data(i,j) = i*10.0 + j*1.0 enddo enddo endif @@ -147,10 +147,10 @@ subroutine test_sendrecv_2D_R4(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS, p ) + call mpp_send( sendrecv_data, DS* DS, p ) end do else - call mpp_recv( data, DS * DS, 0 ) + call mpp_recv( sendrecv_data, DS * DS, 0 ) end if call mpp_sync() ! Needed ? @@ -159,7 +159,7 @@ subroutine test_sendrecv_2D_R4(npes,pe,root,out_unit) if(ANY(pe == pelist(1:npes-1))) then do j = 1, DS do i = 1, DS - if (data(i,j) /= ( i*10.0 + j*1.0)) then + if (sendrecv_data(i,j) /= ( i*10.0 + j*1.0)) then call mpp_error(FATAL, "Test sendrecv 2D R4 failed - basic copy area.") endif enddo @@ -177,11 +177,11 @@ subroutine test_sendrecv_2D_R8(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j, p - real(kind=r8_kind), allocatable, dimension(:,:) :: data !!Data to be sendrecved + real(kind=r8_kind), allocatable, dimension(:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS DS = 9 - allocate(data(DS, DS)) + allocate(sendrecv_data(DS, DS)) !!The full PE list [0, ...,npes-1] do i=0,npes-1 @@ -189,14 +189,14 @@ subroutine test_sendrecv_2D_R8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1.0 + sendrecv_data = -1.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4) is 34.000, etc. if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10.0 + j*1.0 + sendrecv_data(i,j) = i*10.0 + j*1.0 enddo enddo endif @@ -205,10 +205,10 @@ subroutine test_sendrecv_2D_R8(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS, p ) + call mpp_send( sendrecv_data, DS* DS, p ) end do else - call mpp_recv( data, DS * DS, 0 ) + call mpp_recv( sendrecv_data, DS * DS, 0 ) end if call mpp_sync() ! Needed ? @@ -218,7 +218,7 @@ subroutine test_sendrecv_2D_R8(npes,pe,root,out_unit) if(ANY(pe == pelist(1:npes-1))) then do j = 1, DS do i = 1, DS - if (data(i,j) /= ( i*10.0 + j*1.0)) then + if (sendrecv_data(i,j) /= ( i*10.0 + j*1.0)) then call mpp_error(FATAL, "Test sendrecv 2D R8 failed - basic copy area.") endif enddo @@ -236,7 +236,7 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k, p - real(kind=r4_kind), allocatable, dimension(:,:,:) :: data !!Data to be sendrecved + real(kind=r4_kind), allocatable, dimension(:,:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS integer :: iz, jz !!The zeroth element to be sendrecved is at pos data(is+iz, js+jz) integer :: is, ie, js, je !!The amount of data to be sendrecved is (ie - is)*(je - js) @@ -245,7 +245,7 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) NZ = 9 !! Depth of the square tube to be sendrecved. DS = 8 !! DS should be less than 10 for the tests below to make sense. - allocate(data(DS, DS, NZ)) + allocate(sendrecv_data(DS, DS, NZ)) !!The full PE list is [0, ...,npes-1] do i=0,npes-1 @@ -253,7 +253,7 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1.0 + sendrecv_data = -1.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4,5) is 543.000, etc. @@ -261,7 +261,7 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100.0 + j*10.0 + i*1.0 + sendrecv_data(i,j, k) = k*100.0 + j*10.0 + i*1.0 enddo enddo enddo @@ -272,10 +272,10 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS* NZ, p ) + call mpp_send( sendrecv_data, DS* DS* NZ, p ) end do else - call mpp_recv( data, DS * DS * NZ, 0 ) + call mpp_recv( sendrecv_data, DS * DS * NZ, 0 ) end if call mpp_sync() ! Needed ? @@ -286,7 +286,7 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) do k = 1, NZ do j = 1, DS do i = 1, DS - if (data(i,j, k) /= ( k*100.0 + j*10.0 + i*1.0 )) then + if (sendrecv_data(i,j, k) /= ( k*100.0 + j*10.0 + i*1.0 )) then call mpp_error(FATAL, "Test sendrecv 3D R4 failed - basic copy area.") endif enddo @@ -307,7 +307,7 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k, p - real(kind=r8_kind), allocatable, dimension(:,:,:) :: data !!Data to be sendrecved + real(kind=r8_kind), allocatable, dimension(:,:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS integer :: iz, jz !!The zeroth element to be sendrecved is at pos data(is+iz, js+jz) integer :: is, ie, js, je !!The amount of data to be sendrecved is (ie - is)*(je - js) @@ -316,7 +316,7 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) NZ = 9 !! Depth of the square tube to be sendrecved. DS = 8 !! DS should be less than 10 for the tests below to make sense. - allocate(data(DS, DS, NZ)) + allocate(sendrecv_data(DS, DS, NZ)) !!The full PE list is [0, ...,npes-1] do i=0,npes-1 @@ -324,7 +324,7 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1.0 + sendrecv_data = -1.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4,5) is 543.000, etc. @@ -332,7 +332,7 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100.0 + j*10.0 + i*1.0 + sendrecv_data(i,j, k) = k*100.0 + j*10.0 + i*1.0 enddo enddo enddo @@ -343,10 +343,10 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS* NZ, p ) + call mpp_send( sendrecv_data, DS* DS* NZ, p ) end do else - call mpp_recv( data, DS * DS * NZ, 0 ) + call mpp_recv( sendrecv_data, DS * DS * NZ, 0 ) end if call mpp_sync() ! Needed ? @@ -357,7 +357,7 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) do k = 1, NZ do j = 1, DS do i = 1, DS - if (data(i,j, k) /= ( k*100.0 + j*10.0 + i*1.0 )) then + if (sendrecv_data(i,j, k) /= ( k*100.0 + j*10.0 + i*1.0 )) then call mpp_error(FATAL, "Test sendrecv 3D R8 failed - basic copy area.") endif enddo @@ -377,11 +377,11 @@ subroutine test_sendrecv_2D_I4(npes,pe,root,out_unit) integer :: pelist(npes) integer(kind=i4_kind) :: i,j - integer(kind=i4_kind), allocatable, dimension(:,:) :: data !!Data to be sendrecved + integer(kind=i4_kind), allocatable, dimension(:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS, p DS = 9 - allocate(data(DS, DS)) + allocate(sendrecv_data(DS, DS)) !!The full PE list [0, ...,npes-1] do i=0,npes-1 @@ -389,14 +389,14 @@ subroutine test_sendrecv_2D_I4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + sendrecv_data = -1 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4) is 34.000, etc. if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10 + j + sendrecv_data(i,j) = i*10 + j enddo enddo endif @@ -405,10 +405,10 @@ subroutine test_sendrecv_2D_I4(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS, p ) + call mpp_send( sendrecv_data, DS* DS, p ) end do else - call mpp_recv( data, DS * DS, 0 ) + call mpp_recv( sendrecv_data, DS * DS, 0 ) end if call mpp_sync() ! Needed ? @@ -417,7 +417,7 @@ subroutine test_sendrecv_2D_I4(npes,pe,root,out_unit) if(ANY(pe == pelist(1:npes-1))) then do j = 1, DS do i = 1, DS - if (data(i,j) /= ( i * 10 + j )) then + if (sendrecv_data(i,j) /= ( i * 10 + j )) then call mpp_error(FATAL, "Test sendrecv 2D I4 failed - basic copy area.") endif enddo @@ -435,11 +435,11 @@ subroutine test_sendrecv_2D_I8(npes,pe,root,out_unit) integer :: pelist(npes) integer(kind=i8_kind) :: i,j - integer(kind=i8_kind), allocatable, dimension(:,:) :: data !!Data to be sendrecved + integer(kind=i8_kind), allocatable, dimension(:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS, p DS = 9 - allocate(data(DS, DS)) + allocate(sendrecv_data(DS, DS)) !!The full PE list [0, ...,npes-1] do i=0,npes-1 @@ -447,14 +447,14 @@ subroutine test_sendrecv_2D_I8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + sendrecv_data = -1 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4) is 34.000, etc. if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10 + j + sendrecv_data(i,j) = i*10 + j enddo enddo endif @@ -463,10 +463,10 @@ subroutine test_sendrecv_2D_I8(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS, p ) + call mpp_send( sendrecv_data, DS* DS, p ) end do else - call mpp_recv( data, DS * DS, 0 ) + call mpp_recv( sendrecv_data, DS * DS, 0 ) end if call mpp_sync() ! Needed ? @@ -475,7 +475,7 @@ subroutine test_sendrecv_2D_I8(npes,pe,root,out_unit) if(ANY(pe == pelist(1:npes-1))) then do j = 1, DS do i = 1, DS - if (data(i,j) /= ( i * 10 + j )) then + if (sendrecv_data(i,j) /= ( i * 10 + j )) then call mpp_error(FATAL, "Test sendrecv 2D I8 failed - basic copy area.") endif enddo @@ -493,7 +493,7 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) integer :: pelist(npes) integer(kind=i4_kind) :: i,j,k - integer(kind=i4_kind), allocatable, dimension(:,:,:) :: data !!Data to be sendrecved + integer(kind=i4_kind), allocatable, dimension(:,:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS integer :: iz, jz !!The zeroth element to be sendrecved is at pos data(is+iz, js+jz) integer :: is, ie, js, je !!The amount of data to be sendrecved is (ie - is)*(je - js) @@ -502,7 +502,7 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) NZ = 9 !! Depth of the square tube to be sendrecved. DS = 8 !! DS should be less than 10 for the tests below to make sense. - allocate(data(DS, DS, NZ)) + allocate(sendrecv_data(DS, DS, NZ)) !!The full PE list is [0, ...,npes-1] do i=0,npes-1 @@ -510,7 +510,7 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + sendrecv_data = -1 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4,5) is 543.000, etc. @@ -518,7 +518,7 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100 + j*10 + i + sendrecv_data(i,j, k) = k*100 + j*10 + i enddo enddo enddo @@ -529,10 +529,10 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS* NZ, p ) + call mpp_send( sendrecv_data, DS* DS* NZ, p ) end do else - call mpp_recv( data, DS * DS * NZ, 0 ) + call mpp_recv( sendrecv_data, DS * DS * NZ, 0 ) end if call mpp_sync() ! Needed ? @@ -543,7 +543,7 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) do k = 1, NZ do j = 1, DS do i = 1, DS - if (data(i,j, k) /= ( k * 100 + j*10 + i )) then + if (sendrecv_data(i,j, k) /= ( k * 100 + j*10 + i )) then call mpp_error(FATAL, "Test sendrecv 3D I4 failed - basic copy area.") endif enddo @@ -563,7 +563,7 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) integer :: pelist(npes) integer(kind=i8_kind) :: i,j,k - integer(kind=i8_kind), allocatable, dimension(:,:,:) :: data !!Data to be sendrecved + integer(kind=i8_kind), allocatable, dimension(:,:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS integer :: iz, jz !!The zeroth element to be sendrecved is at pos data(is+iz, js+jz) integer :: is, ie, js, je !!The amount of data to be sendrecved is (ie - is)*(je - js) @@ -572,7 +572,7 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) NZ = 9 !! Depth of the square tube to be sendrecved. DS = 8 !! DS should be less than 10 for the tests below to make sense. - allocate(data(DS, DS, NZ)) + allocate(sendrecv_data(DS, DS, NZ)) !!The full PE list is [0, ...,npes-1] do i=0,npes-1 @@ -580,7 +580,7 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + sendrecv_data = -1 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4,5) is 543.000, etc. @@ -588,7 +588,7 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100 + j*10 + i + sendrecv_data(i,j, k) = k*100 + j*10 + i enddo enddo enddo @@ -599,10 +599,10 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS* NZ, p ) + call mpp_send( sendrecv_data, DS* DS* NZ, p ) end do else - call mpp_recv( data, DS * DS * NZ, 0 ) + call mpp_recv( sendrecv_data, DS * DS * NZ, 0 ) end if call mpp_sync() ! Needed ? @@ -613,7 +613,7 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) do k = 1, NZ do j = 1, DS do i = 1, DS - if (data(i,j, k) /= ( k * 100 + j*10 + i )) then + if (sendrecv_data(i,j, k) /= ( k * 100 + j*10 + i )) then call mpp_error(FATAL, "Test sendrecv 3D I8 failed - basic copy area.") endif enddo 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/time_interp/include/time_interp_external2.inc b/time_interp/include/time_interp_external2.inc index b4e6114e6d..863941df1d 100644 --- a/time_interp/include/time_interp_external2.inc +++ b/time_interp/include/time_interp_external2.inc @@ -52,13 +52,13 @@ !! 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. - subroutine TIME_INTERP_EXTERNAL_3D_(index, time, data, interp,verbose,horz_interp, mask_out, is_in, ie_in, & + subroutine TIME_INTERP_EXTERNAL_3D_(index, time, time_data, interp,verbose,horz_interp, mask_out, is_in, ie_in, & & js_in, je_in, window_id) integer, intent(in) :: index !< index of external field from previous call !! to init_external_field type(time_type), intent(in) :: time !< target time for data - real(FMS_TI_KIND_), dimension(:,:,:), intent(inout) :: data !< global or local data array + real(FMS_TI_KIND_), dimension(:,:,:), intent(inout) :: time_data !< global or local data array integer, intent(in), optional :: interp logical, intent(in), optional :: verbose !< flag for debugging type(horiz_interp_type), intent(in), optional :: horz_interp @@ -82,9 +82,9 @@ character(len=16) :: message1, message2 integer, parameter :: kindl = FMS_TI_KIND_ - nx = size(data,1) - ny = size(data,2) - nz = size(data,3) + nx = size(time_data,1) + ny = size(time_data,2) + nz = size(time_data,3) interp_method = LINEAR_TIME_INTERP if (PRESENT(interp)) interp_method = interp @@ -141,14 +141,16 @@ i1 = find_buf_index(1,loaded_fields(index)%ibuf) if( loaded_fields(index)%region_type == NO_REGION ) then where(loaded_fields(index)%mask(isc:iec,jsc:jec,:,i1)) - data(isw:iew,jsw:jew,:) = real( loaded_fields(index)%data(isc:iec,jsc:jec,:,i1), FMS_TI_KIND_) + time_data(isw:iew,jsw:jew,:) = real( loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i1),& + FMS_TI_KIND_) elsewhere - ! data(isw:iew,jsw:jew,:) = time_interp_missing !field(index)%missing? Balaji - data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%missing, FMS_TI_KIND_) + ! time_data(isw:iew,jsw:jew,:) = time_interp_missing !field(index)%missing? Balaji + time_data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%missing, FMS_TI_KIND_) end where else where(loaded_fields(index)%mask(isc:iec,jsc:jec,:,i1)) - data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%data(isc:iec,jsc:jec,:,i1), FMS_TI_KIND_) + time_data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i1),& + FMS_TI_KIND_) end where endif if(PRESENT(mask_out)) mask_out(isw:iew,jsw:jew,:) = loaded_fields(index)%mask(isc:iec,jsc:jec,:,i1) @@ -201,17 +203,17 @@ if( loaded_fields(index)%region_type == NO_REGION ) then where(loaded_fields(index)%mask(isc:iec,jsc:jec,:,i1) .and. & loaded_fields(index)%mask(isc:iec,jsc:jec,:,i2)) - data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%data(isc:iec,jsc:jec,:,i1), kindl) * w1 + & - real(loaded_fields(index)%data(isc:iec,jsc:jec,:,i2), kindl) * w2 + time_data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i1), kindl)& + * w1 + real(loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i2), kindl) * w2 elsewhere - ! data(isw:iew,jsw:jew,:) = time_interp_missing !loaded_fields(index)%missing? Balaji - data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%missing, kindl) + ! time_data(isw:iew,jsw:jew,:) = time_interp_missing !loaded_fields(index)%missing? Balaji + time_data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%missing, kindl) end where else where(loaded_fields(index)%mask(isc:iec,jsc:jec,:,i1) .and. & loaded_fields(index)%mask(isc:iec,jsc:jec,:,i2)) - data(isw:iew,jsw:jew,:) = real( loaded_fields(index)%data(isc:iec,jsc:jec,:,i1), kindl) * w1 + & - real(loaded_fields(index)%data(isc:iec,jsc:jec,:,i2), kindl) * w2 + time_data(isw:iew,jsw:jew,:) = real( loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i1), kindl)& + * w1 + real(loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i2), kindl) * w2 end where endif if(PRESENT(mask_out)) & @@ -224,11 +226,11 @@ ! NAME="time_interp_external" !> @brief Scalar interpolation for @ref time_interp_external - subroutine TIME_INTERP_EXTERNAL_0D_(index, time, data, verbose) + subroutine TIME_INTERP_EXTERNAL_0D_(index, time, time_data, verbose) integer, intent(in) :: index type(time_type), intent(in) :: time - real(FMS_TI_KIND_), intent(inout) :: data + real(FMS_TI_KIND_), intent(inout) :: time_data logical, intent(in), optional :: verbose integer :: t1, t2 @@ -252,7 +254,7 @@ ! only one record in the file => time-independent loaded_fields call load_record_0d(loaded_fields(index),1) i1 = find_buf_index(1,loaded_fields(index)%ibuf) - data = real(loaded_fields(index)%data(1,1,1,i1), FMS_TI_KIND_) + time_data = real(loaded_fields(index)%domain_data(1,1,1,i1), FMS_TI_KIND_) else if(loaded_fields(index)%have_modulo_times) then call time_interp(time,loaded_fields(index)%modulo_time_beg, loaded_fields(index)%modulo_time_end, & @@ -290,8 +292,8 @@ if(i1<0.or.i2<0) & call mpp_error(FATAL,'time_interp_external : records were not loaded correctly in memory') - data = real(loaded_fields(index)%data(1,1,1,i1), FMS_TI_KIND_)*w1 & - & + real(loaded_fields(index)%data(1,1,1,i2), FMS_TI_KIND_)*w2 + time_data = real(loaded_fields(index)%domain_data(1,1,1,i1), FMS_TI_KIND_)*w1 & + & + real(loaded_fields(index)%domain_data(1,1,1,i2), FMS_TI_KIND_)*w2 if (verb) then write(outunit,*) 'ibuf= ',loaded_fields(index)%ibuf write(outunit,*) 'i1,i2= ',i1, i2 diff --git a/time_interp/time_interp_external2.F90 b/time_interp/time_interp_external2.F90 index d5514a9462..67e5127188 100644 --- a/time_interp/time_interp_external2.F90 +++ b/time_interp/time_interp_external2.F90 @@ -102,7 +102,7 @@ module time_interp_external2_mod type(time_type), dimension(:), pointer :: start_time =>NULL(), end_time =>NULL() type(time_type), dimension(:), pointer :: period =>NULL() logical :: modulo_time !< denote climatological time axis - real(r8_kind), dimension(:,:,:,:), pointer :: data =>NULL() !< defined over data domain or global domain + real(r8_kind), dimension(:,:,:,:), pointer :: domain_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(r8_kind), dimension(:,:,:,:), pointer :: src_data =>NULL() !< input data buffer @@ -556,10 +556,10 @@ function init_external_field(file,fieldname,domain,desired_units,& allocate(loaded_fields(num_fields)%need_compute(nbuf, numwindows)) loaded_fields(num_fields)%need_compute = .true. - allocate(loaded_fields(num_fields)%data(isdata:iedata,jsdata:jedata,siz(3),nbuf),& + allocate(loaded_fields(num_fields)%domain_data(isdata:iedata,jsdata:jedata,siz(3),nbuf),& loaded_fields(num_fields)%mask(isdata:iedata,jsdata:jedata,siz(3),nbuf) ) loaded_fields(num_fields)%mask = .false. - loaded_fields(num_fields)%data = 0.0_r8_kind + loaded_fields(num_fields)%domain_data = 0.0_r8_kind slope=1.0_r8_kind;intercept=0.0_r8_kind ! if (units /= 'same') call convert_units(trim(field(num_fields)%units),trim(units),slope,intercept) ! if (verb.and.units /= 'same') then @@ -756,7 +756,7 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id integer :: window_id real(r8_kind) :: mask_in(size(field%src_data,1),size(field%src_data,2),size(field%src_data,3)) real(r8_kind), allocatable :: mask_out(:,:,:) - real(r4_kind), allocatable :: hi_tmp_data(:,:,:,:) !< used to hold a copy of field%data if using r4_kind + real(r4_kind), allocatable :: hi_tmp_data(:,:,:,:) !< used to hold a copy of field%domain_data if using r4_kind real(r4_kind), allocatable :: hi_tmp_msk_out(:,:,:) !< used return the field mask if using r4_kind real(r4_kind), allocatable :: hi_tmp_src_data(:,:,:,:) !< used return the field mask if using r4_kind @@ -773,7 +773,7 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id 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 + if(field%nbuf > size(field%domain_data,4).or.field%nbuf <= 0) field%nbuf = 1 ib = field%nbuf field%ibuf(ib) = rec field%need_compute(ib,:) = .true. @@ -834,22 +834,22 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id if (interp%horizInterpReals4_type%is_allocated) then ! allocate (there may be a better way to do this, had issues with gnu) allocate(hi_tmp_msk_out(isw:iew,jsw:jew, SIZE(field%src_data,3))) - allocate(hi_tmp_data(LBOUND(field%data,1):UBOUND(field%data,1), & - LBOUND(field%data,2):UBOUND(field%data,2), & - LBOUND(field%data,3):UBOUND(field%data,3), & - LBOUND(field%data,4):UBOUND(field%data,4))) + allocate(hi_tmp_data(LBOUND(field%domain_data,1):UBOUND(field%domain_data,1), & + LBOUND(field%domain_data,2):UBOUND(field%domain_data,2), & + LBOUND(field%domain_data,3):UBOUND(field%domain_data,3), & + LBOUND(field%domain_data,4):UBOUND(field%domain_data,4))) allocate(hi_tmp_src_data(LBOUND(field%src_data,1):UBOUND(field%src_data,1), & LBOUND(field%src_data,2):UBOUND(field%src_data,2), & LBOUND(field%src_data,3):UBOUND(field%src_data,3), & LBOUND(field%src_data,4):UBOUND(field%src_data,4))) ! assign if needed - hi_tmp_data = real(field%data, r4_kind) + hi_tmp_data = real(field%domain_data, r4_kind) hi_tmp_src_data = real(field%src_data, r4_kind) ! do interpolation call horiz_interp(interp, hi_tmp_src_data(:,:,:,ib), hi_tmp_data(isw:iew,jsw:jew,:,ib), & mask_in=real(mask_in,r4_kind), mask_out=hi_tmp_msk_out) ! assign any output - field%data = real(hi_tmp_data, r8_kind) + field%domain_data = real(hi_tmp_data, r8_kind) field%mask(isw:iew,jsw:jew,:,ib) = hi_tmp_msk_out(isw:iew,jsw:jew,:) > 0.0_r4_kind if(allocated(hi_tmp_data)) deallocate(hi_tmp_data) @@ -857,7 +857,7 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id if(allocated(hi_tmp_src_data)) deallocate(hi_tmp_src_data) else 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), & + call horiz_interp(interp, field%src_data(:,:,:,ib),field%domain_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.0_r8_kind @@ -868,12 +868,12 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id 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) = is_valid(field%data(isw:iew,jsw:jew,:,ib),field%valid) + field%domain_data(isw:iew,jsw:jew,:,ib) = field%src_data(isw:iew,jsw:jew,:,ib) + field%mask(isw:iew,jsw:jew,:,ib) = is_valid(field%domain_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 + where(field%mask(isw:iew,jsw:jew,:,ib)) field%domain_data(isw:iew,jsw:jew,:,ib) = & + field%domain_data(isw:iew,jsw:jew,:,ib)*field%slope + field%intercept field%need_compute(ib, window_id) = .false. endif @@ -895,7 +895,7 @@ subroutine load_record_0d(field, rec) 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 + if(field%nbuf > size(field%domain_data,4).or.field%nbuf <= 0) field%nbuf = 1 ib = field%nbuf field%ibuf(ib) = rec @@ -907,11 +907,11 @@ subroutine load_record_0d(field, rec) 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) = is_valid(field%data(1,1,:,ib),field%valid) + field%domain_data(1,1,:,ib) = field%src_data(1,1,:,ib) + field%mask(1,1,:,ib) = is_valid(field%domain_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 + where(field%mask(1,1,:,ib)) field%domain_data(1,1,:,ib) = & + field%domain_data(1,1,:,ib)*field%slope + field%intercept endif end subroutine load_record_0d @@ -1005,7 +1005,7 @@ subroutine realloc_fields(n) if (ASSOCIATED(ptr(i)%end_time)) DEALLOCATE(ptr(i)%end_time, stat=ier) 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)%domain_data)) DEALLOCATE(ptr(i)%domain_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 @@ -1103,7 +1103,7 @@ subroutine time_interp_external_exit() ! do i=1,num_fields deallocate(loaded_fields(i)%time,loaded_fields(i)%start_time,loaded_fields(i)%end_time,& - loaded_fields(i)%period,loaded_fields(i)%data,loaded_fields(i)%mask,loaded_fields(i)%ibuf) + loaded_fields(i)%period,loaded_fields(i)%domain_data,loaded_fields(i)%mask,loaded_fields(i)%ibuf) if (ASSOCIATED(loaded_fields(i)%src_data)) deallocate(loaded_fields(i)%src_data) loaded_fields(i)%domain = NULL_DOMAIN2D loaded_fields(i)%nbuf = 0 diff --git a/topography/gaussian_topog.F90 b/topography/gaussian_topog.F90 index f08156f6b4..e8ae51548a 100644 --- a/topography/gaussian_topog.F90 +++ b/topography/gaussian_topog.F90 @@ -123,7 +123,7 @@ module gaussian_topog_mod subroutine read_namelist - integer :: unit, ierr, io + integer :: iunit, ierr, io !> read namelist @@ -133,8 +133,8 @@ subroutine read_namelist !> write version and namelist to log file if (mpp_pe() == mpp_root_pe()) then - unit = stdlog() - write (unit, nml=gaussian_topog_nml) + iunit = stdlog() + write (iunit, nml=gaussian_topog_nml) endif do_nml = .false. diff --git a/topography/topography.F90 b/topography/topography.F90 index 1c4312d7fd..3ff1288fc9 100644 --- a/topography/topography.F90 +++ b/topography/topography.F90 @@ -343,7 +343,7 @@ end function open_water_file !! and initializes constants subroutine read_namelist -integer :: unit, ierr, io +integer :: iunit, ierr, io ! read namelist @@ -353,8 +353,8 @@ subroutine read_namelist ! write version and namelist to log file if (mpp_pe() == mpp_root_pe()) then - unit = stdlog() - write (unit, nml=topography_nml) + iunit = stdlog() + write (iunit, nml=topography_nml) endif end subroutine read_namelist