diff --git a/.github/workflows/build_parallelWorks_intel_tag.yml b/.github/workflows/build_parallelWorks_intel_tag.yml
new file mode 100644
index 0000000000..2d6fa94ea8
--- /dev/null
+++ b/.github/workflows/build_parallelWorks_intel_tag.yml
@@ -0,0 +1,43 @@
+name: Tag CI libFMS and AM4 regression
+
+on:
+ push:
+ tags:
+ - '*alpha*'
+ - '*beta*'
+ workflow_dispatch:
+jobs:
+ parallelWorks:
+ runs-on: [self-hosted, pw-platform]
+ strategy:
+ fail-fast: false
+ max-parallel: 3
+ matrix:
+ include:
+ - runname: FMS with intel 18
+ runscript: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/FMStestStartClusters.py azcluster_noaa
+ - runname: FMS with intel 2021 container
+ runscript: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/FMSintel21StartClusters.py azcluster_noaa_two
+ - runname: AM4 regression
+ runscript: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/AM4_intel21StartClusters.py azcluster_noaa
+
+ steps:
+ - name: FMS make check on paralellWorks
+ env:
+ RUNNAME: ${{ matrix.runname }}
+ RUNSCRIPT: ${{ matrix.runscript }}
+ run: $RUNSCRIPT
+ ShutDownCluster:
+ runs-on: [self-hosted, pw-platform]
+ if: always()
+ needs: [parallelWorks]
+ strategy:
+ matrix:
+ include:
+ - cluster: azcluster_noaa
+ - cluster: azcluster_noaa_two
+ steps:
+ - name: Turn off cluster
+ env:
+ CLUSTER: ${{ matrix.cluster }}
+ run: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/stopClusters.py $CLUSTER
diff --git a/.github/workflows/build_ubuntu_gnu.yml b/.github/workflows/build_ubuntu_gnu.yml
index 1583996531..11724aa412 100644
--- a/.github/workflows/build_ubuntu_gnu.yml
+++ b/.github/workflows/build_ubuntu_gnu.yml
@@ -30,3 +30,5 @@ jobs:
DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.distcheck-conf-flags }}"
- name: Build the library
run: make -j distcheck
+ env:
+ DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.distcheck-conf-flags }}"
diff --git a/.github/workflows/do-the-job.yml b/.github/workflows/do-the-job.yml
new file mode 100644
index 0000000000..e2f772919e
--- /dev/null
+++ b/.github/workflows/do-the-job.yml
@@ -0,0 +1,74 @@
+name: do-the-job
+on: pull_request
+jobs:
+ start-runner:
+ name: Start self-hosted EC2 runner
+ runs-on: ubuntu-latest
+ outputs:
+ label: ${{ steps.start-ec2-runner.outputs.label }}
+ ec2-instance-id: ${{ steps.start-ec2-runner.outputs.ec2-instance-id }}
+ steps:
+ - name: Configure AWS credentials
+ uses: aws-actions/configure-aws-credentials@v1
+ with:
+ aws-access-key-id: ${{ secrets.AWS_ACCESS_KEY_ID }}
+ aws-secret-access-key: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
+ aws-region: us-east-1
+ - name: Start EC2 runner
+ id: start-ec2-runner
+ uses: machulav/ec2-github-runner@v2
+ with:
+ mode: start
+ github-token: ${{ secrets.GH_PERSONAL_ACCESS_TOKEN }}
+ #ec2-image-id: ami-092a9e946def5be32
+ ec2-image-id: ami-02e136e904f3da870
+ ec2-instance-type: m5.4xlarge
+ subnet-id: subnet-02829d7b8c3522644
+ security-group-id: sg-09f60dd1eeea6d55f
+ #subnet-id: subnet-003faaf9f1e386979
+ #security-group-id: sg-05735797b251348e2
+ ## iam-role-name: arn:aws:iam::430073024411:user/fms_test
+ do-the-job:
+ name: Do the job on the runner
+ needs: start-runner # required to start the main job when the runner is ready
+ runs-on: ${{ needs.start-runner.outputs.label }} # run the job on the newly created runner
+ steps:
+ - name: Install epel
+ run: sudo amazon-linux-extras install epel -y
+ - name: config epel
+ run: sudo yum-config-manager --enable epel
+ - name: Install singularity
+ run: sudo yum install -y singularity git
+ - name: Clone from git
+ run: git clone https://github.com/thomas-robinson/build_fms_script.git
+ - name: Pull the container
+ run: singularity pull docker://thomasrobinson/model_environment:i2021.2
+ - name: Build FMS in the container
+ run: singularity exec model_environment_i2021.2.sif ./build_fms.sh
+ stop-runner:
+ name: Stop self-hosted EC2 runner
+ needs:
+ - start-runner # required to get output from the start-runner job
+ - do-the-job # required to wait when the main job is done
+ runs-on: ubuntu-latest
+ if: ${{ always() }} # required to stop the runner even if the error happened in the previous jobs
+ steps:
+ - name: Configure AWS credentials
+ uses: aws-actions/configure-aws-credentials@v1
+ with:
+ aws-access-key-id: ${{ secrets.AWS_ACCESS_KEY_ID }}
+ aws-secret-access-key: ${{ secrets.AWS_SECRET_ACCESS_KEY }}
+ aws-region: ${{ secrets.AWS_REGION }}
+ - name: Stop EC2 runner
+ uses: machulav/ec2-github-runner@v2
+ with:
+ mode: stop
+ github-token: ${{ secrets.GH_PERSONAL_ACCESS_TOKEN }}
+ label: ${{ needs.start-runner.outputs.label }}
+ ec2-instance-id: ${{ needs.start-runner.outputs.ec2-instance-id }}
+ ## optional, requires additional permissions
+ # aws-resource-tags: > # optional, requires additional permissions
+ # [
+ # {"Key": "Name", "Value": "ec2-github-runner"},
+ # {"Key": "GitHubRepository", "Value": "${{ github.repository }}"}
+ # ]
diff --git a/.github/workflows/parallelWorks_intel_pr.yml b/.github/workflows/parallelWorks_intel_pr.yml
new file mode 100644
index 0000000000..e3b5e0cb7a
--- /dev/null
+++ b/.github/workflows/parallelWorks_intel_pr.yml
@@ -0,0 +1,37 @@
+name: Pull Request CI libFMS with intel18 and intel21
+
+on: pull_request
+jobs:
+ parallelWorks:
+ runs-on: [self-hosted, pw-platform]
+ strategy:
+ fail-fast: false
+ max-parallel: 2
+ matrix:
+ include:
+# Turn this back on when fixed
+ - runname: FMS with intel 18
+ runscript: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/PRFMSintel18StartClusters.py $GITHUB_REF
+# Runs on FMS_CONTAINER_CI cluster
+ - runname: FMS with intel 2021 container
+ runscript: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/PRFMSintel21StartClusters.py $GITHUB_REF
+ steps:
+ - name: FMS make check on paralellWorks
+ env:
+ RUNNAME: ${{ matrix.runname }}
+ RUNSCRIPT: ${{ matrix.runscript }}
+ run: $RUNSCRIPT
+ ShutDownCluster:
+ runs-on: [self-hosted, pw-platform]
+ if: always()
+ needs: [parallelWorks]
+ strategy:
+ matrix:
+ include:
+ - cluster: FMS_CONTAINER_CI
+ - cluster: fms_intel18_ci
+ steps:
+ - name: Turn off cluster
+ env:
+ CLUSTER: ${{ matrix.cluster }}
+ run: python3 /home/Thomas.Robinson/pw/storage/pw_api_python/stopClusters.py $CLUSTER
diff --git a/CHANGELOG.md b/CHANGELOG.md
index c7aafc6484..1c6c906899 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -6,6 +6,28 @@ 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`).
+## [2021.03] - 2021-08-16
+### Known Issues
+- DIAG_MANAGER: 3D diurnal diagnostic variables are not supported in this version of FMS
+### Added
+- FMS2_IO: Documentation was added for FMS2_io to help users convert from fms_io/mpp_io
+### Changed
+- FMS2_IO: The error messages in FMS2_io were updated to give more useful information
+- TEST_FMS: The unit tests in mosaic, axis_utils, and time_interp_external were updated to use the FMS2_io version of these routines and are no longer skipped
+- DOCS: The doxygen generated documentation has been improved with more doxygen comments added and a more cohesive layout
+- TEST_FMS: Unit tests for time_manager were updated to use the new get/set_date_gregorian routines
+### Removed
+- MPP_IO: The namelist variable use_mpp_io was removed from interpolator, amip_interp, diag_manager, topography, xgrid, and data_override
+- MPP_IO: Any remaining fms_io/mpp_io calls from the source and test code were removed
+- FMS: Removes the hardcoded path for input.nml, path now may be specified in the call to `fms_init`
+### Fixed
+- MPP: Fixes algorithm used with nested grid updates to properly coalesce x-dir and y-dir pelists for vector quantities
+- CMAKE/AUTOTOOLS: Fixes for minor issues with filenames in both the CMake and autotools build systems
+- MPP: Restored deleted pset functionality needed by GFDL SCM by reinstating mpp_pset.F90
+- MPP: Fixed uninitialized variables for data domains in mpp domains broadcast routines
+- MPP: Minor memory leaks from deallocating domains
+- AXIS_UTILS: Fix PGI related error with string length sizes
+
## [2021.02] - 2021-05-20
### Added
- FMS2_IO: Added fms2_io support for boundary condition restarts. `register_restart_region_2d` and `register_restart_region_3d` were added to fms2_io’s `register_restart_field` interface and `read_restart_bc` and `write_restart_bc` subroutines were added to read and write boundary conditions restarts. See [test_fms/fms2_io/test_bc_restart.F90](https://github.com/NOAA-GFDL/FMS/blob/9d55115a331685e4c6e01f2dfb3b770a9f80fa37/test_fms/fms2_io/test_bc_restart.F90) for sample usage.
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 6d36ea5d11..11d0c3715e 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -19,11 +19,11 @@
# Copyright (c) GFDL, @underwoo
-cmake_minimum_required(VERSION 3.7...3.15 FATAL_ERROR)
+cmake_minimum_required(VERSION 3.12 FATAL_ERROR)
# Define the CMake project
project(FMS
- VERSION 2021.02.0
+ VERSION 2021.03.0
DESCRIPTION "GFDL FMS Library"
HOMEPAGE_URL "https://www.gfdl.noaa.gov/fms"
LANGUAGES C Fortran)
@@ -93,11 +93,11 @@ list(APPEND fms_fortran_src_files
block_control/block_control.F90
column_diagnostics/column_diagnostics.F90
constants/constants.F90
+ constants/fmsconstants.F90
coupler/atmos_ocean_fluxes.F90
coupler/coupler_types.F90
coupler/ensemble_manager.F90
- data_override/get_grid_version_fms2io.F90
- data_override/get_grid_version_mpp.F90
+ data_override/get_grid_version.F90
data_override/data_override.F90
diag_integral/diag_integral.F90
diag_manager/diag_axis.F90
diff --git a/Makefile.am b/Makefile.am
index 118b188d2a..5f414d5746 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -65,6 +65,7 @@ SUBDIRS = \
tracer_manager \
sat_vapor_pres \
random_numbers \
+ . \
libFMS \
test_fms \
${DOCS}
diff --git a/README.md b/README.md
index 53c01c7f79..411730a37a 100644
--- a/README.md
+++ b/README.md
@@ -63,6 +63,15 @@ infrastructural changes to enable such developments are within the scope of FMS.
The collaborative software review process of contributed models is therefore an
essential facet of FMS.
+## Documentation
+
+Source code documentation for the FMS code base is available at http://noaa-gfdl.github.io/FMS.
+The documentation is generated by doxygen and updated upon releases, and a copy of the site
+can be obtained through the `gh-pages` branch or generated manually with
+`./configure --enable-docs && make -C docs`. For more information on documentating the code
+with doxygen please see the
+[documentation style guide](http://noaa-gfdl.github.io/FMS/md_docs_doxygenGuide.html).
+
# Disclaimer
The United States Department of Commerce (DOC) GitHub project code is provided
diff --git a/amip_interp/amip_interp.F90 b/amip_interp/amip_interp.F90
index 62a531595b..219c7d16a2 100644
--- a/amip_interp/amip_interp.F90
+++ b/amip_interp/amip_interp.F90
@@ -94,11 +94,6 @@ module amip_interp_mod
use mpp_mod, only: input_nml_file
use fms2_io_mod, only: FmsNetcdfFile_t, fms2_io_file_exists=>file_exists, open_file, close_file, &
get_dimension_size, fms2_io_read_data=>read_data
-!! These are fms_io specific:
-use fms_io_mod, only: mpp_io_read_data=>read_data, field_size
-use mpp_io_mod, only : mpp_open, mpp_read, MPP_RDONLY, MPP_NETCDF, &
- MPP_MULTI, MPP_SINGLE, mpp_close, mpp_get_times
-use fms_mod, only: fms_io_file_exists=>file_exist
implicit none
private
@@ -533,15 +528,7 @@ subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model)
call horiz_interp_new ( Interp%Hintrp2, lon_bnd, lat_bnd, &
lon_model, lat_model, interp_method="bilinear" )
- if (use_mpp_io) then
- !! USE_MPP_IO_WARNING
- call mpp_error ('amip_interp_mod', &
- 'MPP_IO is no longer supported. Please remove from namelist',&
- WARNING)
- the_file_exists = fms_io_file_exists(ncfilename)
- else
- the_file_exists = fms2_io_file_exists(ncfilename)
- endif !if (use_mpp_io)
+ the_file_exists = fms2_io_file_exists(ncfilename)
if ( (.NOT. the_file_exists) ) then
call mpp_error ('amip_interp_mod', &
@@ -550,17 +537,6 @@ subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model)
if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', &
'Reading NetCDF formatted daily SST from: '//trim(ncfilename), NOTE)
- if (use_mpp_io) then
- call field_size(ncfilename, 'TIME', siz)
- nrecords = siz (1)
- if (nrecords < 1) call mpp_error('amip_interp_mod', &
- 'Invalid number of SST records in daily SST data file: '//trim(ncfilename), FATAL)
- allocate(timeval(nrecords), ryr(nrecords), rmo(nrecords), rdy(nrecords))
-
- call mpp_open( unit, ncfilename, MPP_RDONLY, MPP_NETCDF, MPP_MULTI, MPP_SINGLE )
- call mpp_get_times(unit, timeval)
- call mpp_close(unit)
- else
if(.not. open_file(fileobj, trim(ncfilename), 'read')) &
call error_mesg ('get_amip_sst', 'Error in opening file '//trim(ncfilename), FATAL)
@@ -569,7 +545,6 @@ subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model)
'Invalid number of SST records in daily SST data file: '//trim(ncfilename), FATAL)
allocate(timeval(nrecords), ryr(nrecords), rmo(nrecords), rdy(nrecords))
call fms2_io_read_data(fileobj, 'TIME', timeval)
- endif !if (use_mpp_io)
!!! DEBUG CODE
if(DEBUG) then
if (mpp_pe() == 0) then
@@ -607,12 +582,8 @@ subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model)
if ( .not. allocated(tempamip) ) allocate (tempamip(mobs_sst,nobs_sst))
if (the_file_exists) then
- if (use_mpp_io) then
- call mpp_io_read_data(ncfilename, 'SST', tempamip, timelevel=k, no_domain=.true.)
- else
- call fms2_io_read_data(fileobj, 'SST', tempamip, unlim_dim_level=k)
- call close_file(fileobj)
- endif !if (use_mpp_io)
+ call fms2_io_read_data(fileobj, 'SST', tempamip, unlim_dim_level=k)
+ call close_file(fileobj)
tempamip = tempamip + TFREEZE
!!! DEBUG CODE
@@ -910,6 +881,12 @@ subroutine amip_interp_init()
write (unit,nml=amip_interp_nml)
endif
+ if (use_mpp_io) then
+ !! USE_MPP_IO_WARNING
+ call mpp_error ('amip_interp_mod', &
+ 'MPP_IO is no longer supported. Please remove use_mpp_io from amip_interp_nml',&
+ FATAL)
+ endif
if ( .not. use_ncep_sst ) interp_oi_sst = .false.
! ---- freezing point of sea water in deg K ---
@@ -1005,30 +982,19 @@ subroutine amip_interp_init()
file_name_sst = trim(file_name_sst)//'.nc'
file_name_ice = trim(file_name_ice)//'.nc'
- if (use_mpp_io) then
- if (.not. fms_io_file_exists(trim(file_name_sst)) ) then
- call error_mesg ('amip_interp_init', &
- 'file '//trim(file_name_sst)//' does not exist', FATAL)
- endif
- if (.not. fms_io_file_exists(trim(file_name_ice)) ) then
- call error_mesg ('amip_interp_init', &
- 'file '//trim(file_name_ice)//' does not exist', FATAL)
- endif
- else
- if (.not. fms2_io_file_exists(trim(file_name_sst)) ) then
- call error_mesg ('amip_interp_init', &
- 'file '//trim(file_name_sst)//' does not exist', FATAL)
- endif
- if (.not. fms2_io_file_exists(trim(file_name_ice)) ) then
- call error_mesg ('amip_interp_init', &
- 'file '//trim(file_name_ice)//' does not exist', FATAL)
- endif
+ if (.not. fms2_io_file_exists(trim(file_name_sst)) ) then
+ call error_mesg ('amip_interp_init', &
+ 'file '//trim(file_name_sst)//' does not exist', FATAL)
+ endif
+ if (.not. fms2_io_file_exists(trim(file_name_ice)) ) then
+ call error_mesg ('amip_interp_init', &
+ 'file '//trim(file_name_ice)//' does not exist', FATAL)
+ endif
- if (.not. open_file(fileobj_sst, trim(file_name_sst), 'read')) &
- call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_sst), FATAL)
- if (.not. open_file(fileobj_ice, trim(file_name_ice), 'read')) &
- call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_ice), FATAL)
- endif !if (use_mpp_io)
+ if (.not. open_file(fileobj_sst, trim(file_name_sst), 'read')) &
+ call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_sst), FATAL)
+ if (.not. open_file(fileobj_ice, trim(file_name_ice), 'read')) &
+ call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_ice), FATAL)
module_is_initialized = .true.
end subroutine amip_interp_init
@@ -1326,10 +1292,10 @@ subroutine read_record (type, Date, Adate, dat)
ncfieldname = 'sst'
if(type(1:3) == 'sst') then
ncfilename = trim(file_name_sst)
- if (.not. use_mpp_io) fileobj => fileobj_sst
+ fileobj => fileobj_sst
else if(type(1:3) == 'ice') then
ncfilename = trim(file_name_ice)
- if (.not. use_mpp_io) fileobj => fileobj_ice
+ fileobj => fileobj_ice
if (lowercase(trim(data_set)) == 'amip2' .or. &
lowercase(trim(data_set)) == 'hurrell' .or. &
lowercase(trim(data_set)) == 'daily') ncfieldname = 'ice' ! modified by JHC
@@ -1344,15 +1310,6 @@ subroutine read_record (type, Date, Adate, dat)
if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', &
'Reading NetCDF formatted input data file: '//trim(ncfilename), NOTE)
- if (use_mpp_io) then
- call mpp_io_read_data (ncfilename, 'nrecords', nrecords, no_domain=.true.)
- if (nrecords < 1) call mpp_error('amip_interp_mod', &
- 'Invalid number of SST records in SST datafile: '//trim(ncfilename), FATAL)
- allocate(ryr(nrecords), rmo(nrecords), rdy(nrecords))
- call mpp_io_read_data(ncfilename, 'yr', ryr, no_domain=.true.)
- call mpp_io_read_data(ncfilename, 'mo', rmo, no_domain=.true.)
- call mpp_io_read_data(ncfilename, 'dy', rdy, no_domain=.true.)
- else
call fms2_io_read_data (fileobj, 'nrecords', nrecords)
if (nrecords < 1) call mpp_error('amip_interp_mod', &
'Invalid number of SST records in SST datafile: '//trim(ncfilename), FATAL)
@@ -1360,7 +1317,6 @@ subroutine read_record (type, Date, Adate, dat)
call fms2_io_read_data(fileobj, 'yr', ryr)
call fms2_io_read_data(fileobj, 'mo', rmo)
call fms2_io_read_data(fileobj, 'dy', rdy)
- endif !if (use_mpp_io)
ierr = 1
do k = 1, nrecords
@@ -1393,11 +1349,7 @@ subroutine read_record (type, Date, Adate, dat)
!---- read NETCDF data ----
if ( interp_oi_sst ) then
- if (use_mpp_io) then
- call mpp_io_read_data(ncfilename, ncfieldname, tmp_dat, timelevel=k, no_domain=.true.)
- else
- call fms2_io_read_data(fileobj, ncfieldname, tmp_dat, unlim_dim_level=k)
- endif !if (use_mpp_io)
+ call fms2_io_read_data(fileobj, ncfieldname, tmp_dat, unlim_dim_level=k)
! interpolate tmp_dat(360, 180) ---> dat(mobs,nobs) (to enable SST anom computation)
if ( mobs/=360 .or. nobs/=180 ) then
call a2a_bilinear(360, 180, tmp_dat, mobs, nobs, dat)
@@ -1405,17 +1357,9 @@ subroutine read_record (type, Date, Adate, dat)
dat(:,:) = tmp_dat(:,:)
endif
else
- if (use_mpp_io) then
- call mpp_io_read_data(ncfilename, ncfieldname, dat, timelevel=k, no_domain=.true.)
- else
- call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k)
- endif !if (use_mpp_io)
+ call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k)
endif
- if (use_mpp_io) then
- idat = nint(dat*100.) ! reconstruct packed data for reproducibility
- else
- idat = nint(dat) ! reconstruct packed data for reproducibility
- endif !(use_mpp_io)
+ idat = nint(dat) ! reconstruct packed data for reproducibility
!---- unpacking of data ----
diff --git a/axis_utils/axis_utils2.F90 b/axis_utils/axis_utils2.F90
index 37c948c905..da6f3c9d2c 100644
--- a/axis_utils/axis_utils2.F90
+++ b/axis_utils/axis_utils2.F90
@@ -181,7 +181,8 @@ subroutine axis_edges(fileobj, name, edge_data, reproduce_null_char_bug_flag)
buffer = ""
if (variable_att_exists(fileobj, name, "edges")) then
!! If the reproduce_null_char_bug flag is turned on fms2io will not remove the null character
- call get_variable_attribute(fileobj, name, "edges", buffer, reproduce_null_char_bug_flag=reproduce_null_char_bug)
+ call get_variable_attribute(fileobj, name, "edges", buffer(1:128), &
+ reproduce_null_char_bug_flag=reproduce_null_char_bug)
!! Check for a null character here, if it exists *_bnds will be calculated instead of read in
if (reproduce_null_char_bug) then
@@ -191,7 +192,8 @@ subroutine axis_edges(fileobj, name, edge_data, reproduce_null_char_bug_flag)
endif
elseif (variable_att_exists(fileobj, name, "bounds")) then
!! If the reproduce_null_char_bug flag is turned on fms2io will not remove the null character
- call get_variable_attribute(fileobj, name, "bounds", buffer, reproduce_null_char_bug_flag=reproduce_null_char_bug)
+ call get_variable_attribute(fileobj, name, "bounds", buffer(1:128), &
+ reproduce_null_char_bug_flag=reproduce_null_char_bug)
!! Check for a null character here, if it exists *_bnds will be calculated instead of read in
if (reproduce_null_char_bug) then
diff --git a/column_diagnostics/column_diagnostics.F90 b/column_diagnostics/column_diagnostics.F90
index d7d2908bdd..b27ef724bf 100644
--- a/column_diagnostics/column_diagnostics.F90
+++ b/column_diagnostics/column_diagnostics.F90
@@ -27,7 +27,6 @@
!> @{
module column_diagnostics_mod
-use mpp_io_mod, only: mpp_io_init
use fms_mod, only: fms_init, mpp_pe, mpp_root_pe, &
mpp_npes, check_nml_error, &
error_mesg, FATAL, NOTE, WARNING, &
@@ -35,7 +34,7 @@ module column_diagnostics_mod
use time_manager_mod, only: time_manager_init, month_name, &
get_date, time_type
use constants_mod, only: constants_init, PI, RADIAN
-use mpp_mod, only: input_nml_file, get_unit
+use mpp_mod, only: input_nml_file
!-------------------------------------------------------------------
@@ -143,7 +142,6 @@ subroutine column_diagnostics_init
!---------------------------------------------------------------------
! verify that all modules used by this module have been initialized.
!----------------------------------------------------------------------
- call mpp_io_init
call fms_init
call time_manager_init
call constants_init
@@ -431,8 +429,7 @@ subroutine initialize_diagnostic_columns &
else
write( filename,'(a,i4.4)' )trim(filename)//'.', mpp_pe()-mpp_root_pe()
endif
- diag_units(nn) = get_unit()
- open(diag_units(nn), file=trim(filename), action='WRITE', position='rewind', iostat=io)
+ open(newunit=diag_units(nn), file=trim(filename), action='WRITE', position='rewind', iostat=io)
if(io/=0) call error_mesg ('column_diagnostics_mod', 'Error in opening file '//trim(filename), FATAL)
endif ! (open_file)
endif
diff --git a/configure.ac b/configure.ac
index 1a890c8198..b340c72510 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],
- [2021.03.0-dev],
+ [2021.04.0-dev],
[gfdl.climate.model.info@noaa.gov],
[FMS],
[https://www.gfdl.noaa.gov/fms])
@@ -50,7 +50,7 @@ LT_INIT()
# is, then disable building shared libraries. Note, the user can still override
# this by using --enable-shared when running the configure script.
AS_IF([test x${CRAYPE_VERSION:+yes} = "xyes"],[
- AS_IF([test x${CRAYPE_LINK_TYP} = "xstatic"],
+ AS_IF([test x${CRAYPE_LINK_TYPE} = "xstatic"],
[AC_DISABLE_SHARED])])
@@ -273,25 +273,15 @@ if test -n "$fc_version_info"; then
fi
# Check if gcc is 11.1 for class(*) select type bug
-AC_MSG_CHECKING([if gcc 11 is loaded])
-if [ test -n "`$FC --version | grep GNU | grep 11\..\..`" ]; then
+AC_MSG_CHECKING([if gcc 11.1.0 is loaded])
+if [ test -n "`$FC --version | grep GNU | grep 11\.1\..`" ]; then
AC_MSG_RESULT([yes])
- AC_MSG_ERROR([Compilation with gcc and gfortran 11 is unsupported by this version\
- of FMS. Please use another compiler version])
+ AC_MSG_ERROR([Compilation with gcc and gfortran 11.1.0 is unsupported \
+by this version of FMS due to a bug in the compiler. Please use a different version of gcc/gfortran.])
else
AC_MSG_RESULT([no])
fi
-# Check if netcdf is version 4.7.4 to skip failing fms2_io tests
-AC_MSG_CHECKING([if netCDF 4.7.4 is loaded])
-if [ test "`nc-config --version`" == "netCDF 4.7.4" ]; then
- AM_CONDITIONAL([SKIP_FMS2_IO_TESTS], true )
- AC_MSG_RESULT([yes])
-else
- AM_CONDITIONAL([SKIP_FMS2_IO_TESTS], false )
- AC_MSG_RESULT([no])
-fi
-
#####
# Create output variables from various
# shell variables, for use in generating
@@ -371,8 +361,3 @@ AC_CONFIG_FILES([
])
AC_OUTPUT()
-
-## if tests are being skipped, output warning at end of output
-if [ test "`nc-config --version`" == "netCDF 4.7.4" ]; then
- AC_MSG_RESULT([Warning: netCDF v4.7.4 is loaded. Incompatible fms2_io tests will be skipped and there may be netCDF issues with model runs.])
-fi
diff --git a/data_override/Makefile.am b/data_override/Makefile.am
index 60112b7be3..2cffbe3493 100644
--- a/data_override/Makefile.am
+++ b/data_override/Makefile.am
@@ -32,17 +32,15 @@ noinst_LTLIBRARIES = libdata_override.la
# The convenience library depends on its source.
libdata_override_la_SOURCES = \
data_override.F90 \
- get_grid_version_mpp.F90 \
- get_grid_version_fms2io.F90
+ get_grid_version.F90
# Some mods are dependent on other mods in this dir.
-data_override_mod.$(FC_MODEXT): get_grid_version_mpp_mod.$(FC_MODEXT) get_grid_version_fms2io_mod.$(FC_MODEXT)
+data_override_mod.$(FC_MODEXT): get_grid_version_mod.$(FC_MODEXT)
# Mod files are built and then installed as headers.
MODFILES = \
data_override_mod.$(FC_MODEXT) \
- get_grid_version_mpp_mod.$(FC_MODEXT) \
- get_grid_version_fms2io_mod.$(FC_MODEXT)
+ get_grid_version_mod.$(FC_MODEXT)
nodist_include_HEADERS = $(MODFILES)
BUILT_SOURCES = $(MODFILES)
diff --git a/data_override/data_override.F90 b/data_override/data_override.F90
index 7fc4749855..013897aec6 100644
--- a/data_override/data_override.F90
+++ b/data_override/data_override.F90
@@ -41,38 +41,29 @@
module data_override_mod
use constants_mod, only: PI
-use mpp_io_mod, only: axistype, mpp_close, mpp_open, mpp_get_axis_data, MPP_RDONLY
use mpp_mod, only : mpp_error, FATAL, WARNING, stdout, stdlog, mpp_max
-use mpp_mod, only : input_nml_file, get_unit
+use mpp_mod, only : input_nml_file
use horiz_interp_mod, only : horiz_interp_init, horiz_interp_new, horiz_interp_type, &
assignment(=)
-use time_interp_external_mod, only:time_interp_external_init_classic=>time_interp_external_init, &
- time_interp_external_classic=>time_interp_external, &
- init_external_field_classic=>init_external_field, &
- get_external_field_size_classic=>get_external_field_size, &
- set_override_region_classic=>set_override_region, &
- reset_src_data_region_classic=>reset_src_data_region
-use time_interp_external2_mod, only:time_interp_external_init_fms2io=>time_interp_external_init, &
- time_interp_external_fms2io=>time_interp_external, &
- init_external_field_fms2io=>init_external_field, &
- get_external_field_size_fms2io=>get_external_field_size, &
- set_override_region_fms2io=>set_override_region, &
- reset_src_data_region_fms2io=>reset_src_data_region, &
+use time_interp_external2_mod, only:time_interp_external_init, &
+ time_interp_external, &
+ init_external_field, &
+ get_external_field_size, &
+ set_override_region, &
+ reset_src_data_region, &
NO_REGION, INSIDE_REGION, OUTSIDE_REGION, &
get_external_fileobj
use fms_mod, only: write_version_number, field_exist, lowercase, check_nml_error
use axis_utils_mod, only: get_axis_bounds
use axis_utils2_mod, only : nearest_index, axis_edges
-use fms_io_mod, only: fms_io_init, get_mosaic_tile_file_classic=>get_mosaic_tile_file
use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, NULL_DOMAIN2D,operator(.NE.),operator(.EQ.)
use mpp_domains_mod, only : mpp_get_global_domain, mpp_get_data_domain
use mpp_domains_mod, only : domainUG, mpp_pass_SG_to_UG, mpp_get_UG_SG_domain, NULL_DOMAINUG
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_fms2_io=>get_mosaic_tile_file
-use get_grid_version_mpp_mod, only: get_grid_version_classic_1, get_grid_version_classic_2
-use get_grid_version_fms2io_mod, only: get_grid_version_1, get_grid_version_2
+ get_mosaic_tile_file
+use get_grid_version_mod, only: get_grid_version_1, get_grid_version_2
implicit none
private
@@ -156,13 +147,12 @@ module data_override_mod
logical :: lndUG_on
logical :: debug_data_override
logical :: grid_center_bug = .false.
-logical :: use_mpp_bug = .false.
logical :: reproduce_null_char_bug = .false. !> Flag indicating
!! to reproduce the mpp_io bug where lat/lon_bnd were
!! not read correctly if null characters are present in
!! the netcdf file
-namelist /data_override_nml/ debug_data_override, grid_center_bug, use_mpp_bug, reproduce_null_char_bug
+namelist /data_override_nml/ debug_data_override, grid_center_bug, reproduce_null_char_bug
public :: data_override_init, data_override, data_override_unset_domains
@@ -250,15 +240,8 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan
enddo
! Read coupler_table
- if(use_mpp_bug) then
- call mpp_error(WARNING, 'data_override_mod:' &
- //'MPP_IO is no longer supported. Please remove "use_mpp_bug" from namelist')
- call mpp_open(iunit, 'data_table', action=MPP_RDONLY)
- else
- iunit = get_unit()
- open(iunit, file='data_table', action='READ', iostat=io_status)
- if(io_status/=0) call mpp_error(FATAL, 'data_override_mod: Error in opening file data_table')
- end if
+ open(newunit=iunit, file='data_table', action='READ', iostat=io_status)
+ if(io_status/=0) call mpp_error(FATAL, 'data_override_mod: Error in opening file data_table')
ntable = 0
ntable_lima = 0
@@ -369,12 +352,8 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan
table_size = ntable
if(ntable_new*ntable_lima /= 0) call mpp_error(FATAL, &
'data_override_mod: New and old formats together in same data_table not supported')
- if(use_mpp_bug) then
- call mpp_close(iunit)
- else
- close(iunit, iostat=io_status)
- if(io_status/=0) call mpp_error(FATAL, 'data_override_mod: Error in closing file data_table')
- end if
+ close(iunit, iostat=io_status)
+ if(io_status/=0) call mpp_error(FATAL, 'data_override_mod: Error in closing file data_table')
! Initialize override array
default_array%gridname = 'NONE'
@@ -385,153 +364,92 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan
do i = 1, max_array
override_array(i) = default_array
enddo
- if(use_mpp_bug) then
- call time_interp_external_init_classic
- else
- call time_interp_external_init_fms2io
- end if
+ call time_interp_external_init
end if
module_is_initialized = .TRUE.
if ( .NOT. (atm_on .or. ocn_on .or. lnd_on .or. ice_on .or. lndUG_on)) return
- call fms_io_init
- if (.not. use_mpp_bug) call fms2_io_init
+ call fms2_io_init
! Test if grid_file is already opened
inquire (file=trim(grid_file), opened=file_open)
if(file_open) call mpp_error(FATAL, trim(grid_file)//' already opened')
- if(.not. use_mpp_bug) then
- if(.not. open_file(fileobj, grid_file, 'read' )) then
- call mpp_error(FATAL, 'data_override_mod: Error in opening file '//trim(grid_file))
- endif
+ if(.not. open_file(fileobj, grid_file, 'read' )) then
+ call mpp_error(FATAL, 'data_override_mod: Error in opening file '//trim(grid_file))
endif
- if(use_mpp_bug) then
- if(field_exist(grid_file, "x_T" ) .OR. field_exist(grid_file, "geolon_t" ) ) then
- use_get_grid_version = 1
- else if(field_exist(grid_file, "ocn_mosaic_file" ) .OR. field_exist(grid_file, "gridfiles" ) ) then
- use_get_grid_version = 2
- if(field_exist(grid_file, "gridfiles" ) ) then
- if(count_ne_1((ocn_on .OR. ice_on), lnd_on, atm_on)) call mpp_error(FATAL, 'data_override_mod: the grid file ' // &
- 'is a solo mosaic, one and only one of atm_on, lnd_on or ice_on/ocn_on should be true')
- end if
- else
- call mpp_error(FATAL, 'data_override_mod: none of x_T, geolon_t, ocn_mosaic_file or gridfiles exist in '//trim(grid_file))
- endif
+ if(variable_exists(fileobj, "x_T" ) .OR. variable_exists(fileobj, "geolon_t" ) ) then
+ use_get_grid_version = 1
+ call close_file(fileobj)
+ else if(variable_exists(fileobj, "ocn_mosaic_file" ) .OR. variable_exists(fileobj, "gridfiles" ) ) then
+ use_get_grid_version = 2
+ if(variable_exists(fileobj, "gridfiles" ) ) then
+ if(count_ne_1((ocn_on .OR. ice_on), lnd_on, atm_on)) call mpp_error(FATAL, 'data_override_mod: the grid file ' // &
+ 'is a solo mosaic, one and only one of atm_on, lnd_on or ice_on/ocn_on should be true')
+ end if
else
- if(variable_exists(fileobj, "x_T" ) .OR. variable_exists(fileobj, "geolon_t" ) ) then
- use_get_grid_version = 1
- call close_file(fileobj)
- else if(variable_exists(fileobj, "ocn_mosaic_file" ) .OR. variable_exists(fileobj, "gridfiles" ) ) then
- use_get_grid_version = 2
- if(variable_exists(fileobj, "gridfiles" ) ) then
- if(count_ne_1((ocn_on .OR. ice_on), lnd_on, atm_on)) call mpp_error(FATAL, 'data_override_mod: the grid file ' // &
- 'is a solo mosaic, one and only one of atm_on, lnd_on or ice_on/ocn_on should be true')
- end if
- else
- call mpp_error(FATAL, 'data_override_mod: none of x_T, geolon_t, ocn_mosaic_file or gridfiles exist in '//trim(grid_file))
- endif
+ call mpp_error(FATAL, 'data_override_mod: none of x_T, geolon_t, ocn_mosaic_file or gridfiles exist in '//trim(grid_file))
endif
if(use_get_grid_version .EQ. 1) then
if (atm_on .and. .not. allocated(lon_local_atm) ) then
call mpp_get_compute_domain( atm_domain,is,ie,js,je)
allocate(lon_local_atm(is:ie,js:je), lat_local_atm(is:ie,js:je))
- if(use_mpp_bug) then
- call get_grid_version_classic_1(grid_file, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, &
- min_glo_lon_atm, max_glo_lon_atm, grid_center_bug )
- else
- call get_grid_version_1(grid_file, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, &
- min_glo_lon_atm, max_glo_lon_atm, grid_center_bug )
- endif
+ call get_grid_version_1(grid_file, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, &
+ min_glo_lon_atm, max_glo_lon_atm, grid_center_bug )
endif
if (ocn_on .and. .not. allocated(lon_local_ocn) ) then
call mpp_get_compute_domain( ocn_domain,is,ie,js,je)
allocate(lon_local_ocn(is:ie,js:je), lat_local_ocn(is:ie,js:je))
- if(use_mpp_bug) then
- call get_grid_version_classic_1(grid_file, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, &
- min_glo_lon_ocn, max_glo_lon_ocn, grid_center_bug )
- else
- call get_grid_version_1(grid_file, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, &
- min_glo_lon_ocn, max_glo_lon_ocn, grid_center_bug )
- endif
+ call get_grid_version_1(grid_file, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, &
+ min_glo_lon_ocn, max_glo_lon_ocn, grid_center_bug )
endif
if (lnd_on .and. .not. allocated(lon_local_lnd) ) then
call mpp_get_compute_domain( lnd_domain,is,ie,js,je)
allocate(lon_local_lnd(is:ie,js:je), lat_local_lnd(is:ie,js:je))
- if(use_mpp_bug) then
- call get_grid_version_classic_1(grid_file, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, &
- min_glo_lon_lnd, max_glo_lon_lnd, grid_center_bug )
- else
- call get_grid_version_1(grid_file, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, &
- min_glo_lon_lnd, max_glo_lon_lnd, grid_center_bug )
- endif
+ call get_grid_version_1(grid_file, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, &
+ min_glo_lon_lnd, max_glo_lon_lnd, grid_center_bug )
endif
if (ice_on .and. .not. allocated(lon_local_ice) ) then
call mpp_get_compute_domain( ice_domain,is,ie,js,je)
allocate(lon_local_ice(is:ie,js:je), lat_local_ice(is:ie,js:je))
- if(use_mpp_bug) then
- call get_grid_version_classic_1(grid_file, 'ice', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, &
- min_glo_lon_ice, max_glo_lon_ice, grid_center_bug )
- else
- call get_grid_version_1(grid_file, 'ice', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, &
- min_glo_lon_ice, max_glo_lon_ice, grid_center_bug )
- endif
+ call get_grid_version_1(grid_file, 'ice', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, &
+ min_glo_lon_ice, max_glo_lon_ice, grid_center_bug )
endif
else
if (atm_on .and. .not. allocated(lon_local_atm) ) then
call mpp_get_compute_domain(atm_domain,is,ie,js,je)
allocate(lon_local_atm(is:ie,js:je), lat_local_atm(is:ie,js:je))
- if(use_mpp_bug) then
- call get_grid_version_classic_2(grid_file, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, &
- min_glo_lon_atm, max_glo_lon_atm )
- else
- call get_grid_version_2(fileobj, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, &
- min_glo_lon_atm, max_glo_lon_atm )
- end if
+ call get_grid_version_2(fileobj, 'atm', atm_domain, is, ie, js, je, lon_local_atm, lat_local_atm, &
+ min_glo_lon_atm, max_glo_lon_atm )
endif
if (ocn_on .and. .not. allocated(lon_local_ocn) ) then
call mpp_get_compute_domain( ocn_domain,is,ie,js,je)
allocate(lon_local_ocn(is:ie,js:je), lat_local_ocn(is:ie,js:je))
- if(use_mpp_bug) then
- call get_grid_version_classic_2(grid_file, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, &
- min_glo_lon_ocn, max_glo_lon_ocn )
- else
- call get_grid_version_2(fileobj, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, &
- min_glo_lon_ocn, max_glo_lon_ocn )
- end if
+ call get_grid_version_2(fileobj, 'ocn', ocn_domain, is, ie, js, je, lon_local_ocn, lat_local_ocn, &
+ min_glo_lon_ocn, max_glo_lon_ocn )
endif
if (lnd_on .and. .not. allocated(lon_local_lnd) ) then
call mpp_get_compute_domain( lnd_domain,is,ie,js,je)
allocate(lon_local_lnd(is:ie,js:je), lat_local_lnd(is:ie,js:je))
- if(use_mpp_bug) then
- call get_grid_version_classic_2(grid_file, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, &
- min_glo_lon_lnd, max_glo_lon_lnd )
- else
- call get_grid_version_2(fileobj, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, &
- min_glo_lon_lnd, max_glo_lon_lnd )
- end if
+ call get_grid_version_2(fileobj, 'lnd', lnd_domain, is, ie, js, je, lon_local_lnd, lat_local_lnd, &
+ min_glo_lon_lnd, max_glo_lon_lnd )
endif
if (ice_on .and. .not. allocated(lon_local_ice) ) then
call mpp_get_compute_domain( ice_domain,is,ie,js,je)
allocate(lon_local_ice(is:ie,js:je), lat_local_ice(is:ie,js:je))
- if(use_mpp_bug) then
- call get_grid_version_classic_2(grid_file, 'ocn', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, &
- min_glo_lon_ice, max_glo_lon_ice )
- else
- call get_grid_version_2(fileobj, 'ocn', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, &
- min_glo_lon_ice, max_glo_lon_ice )
- end if
+ call get_grid_version_2(fileobj, 'ocn', ice_domain, is, ie, js, je, lon_local_ice, lat_local_ice, &
+ min_glo_lon_ice, max_glo_lon_ice )
endif
end if
- if(.not. use_mpp_bug .AND. use_get_grid_version .EQ. 2) then
+ if(use_get_grid_version .EQ. 2) then
call close_file(fileobj)
end if
@@ -685,7 +603,6 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde
integer :: id_time !< index for time interp in override array
integer :: axis_sizes(4)
character(len=32) :: axis_names(4)
- type(axistype) :: axis_centers(4), axis_bounds(4)
real, dimension(:,:), pointer :: lon_local =>NULL() !< of output (target) grid cells
real, dimension(:,:), pointer :: lat_local =>NULL() !< of output (target) grid cells
real, dimension(:), allocatable :: lon_tmp, lat_tmp
@@ -816,39 +733,22 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde
! Allow on-grid data_overrides on cubed sphere grid
inquire(file=trim(filename),EXIST=exists)
if (.not. exists) then
- if (use_mpp_bug) then
- call get_mosaic_tile_file_classic(filename,filename2,.false.,domain)
- else
- call get_mosaic_tile_file_fms2_io(filename,filename2,.false.,domain)
- endif
+ call get_mosaic_tile_file(filename,filename2,.false.,domain)
filename = filename2
endif
!--- we always only pass data on compute domain
- if (use_mpp_bug) then
- id_time = init_external_field_classic(filename,fieldname,domain=domain,verbose=.false., &
- use_comp_domain=use_comp_domain, nwindows=nwindows)
- dims = get_external_field_size_classic(id_time)
- else
- id_time = init_external_field_fms2io(filename,fieldname,domain=domain,verbose=.false., &
- use_comp_domain=use_comp_domain, nwindows=nwindows, ongrid=ongrid)
- dims = get_external_field_size_fms2io(id_time)
- end if
+ id_time = init_external_field(filename,fieldname,domain=domain,verbose=.false., &
+ use_comp_domain=use_comp_domain, nwindows=nwindows, ongrid=ongrid)
+ dims = get_external_field_size(id_time)
override_array(curr_position)%dims = dims
if(id_time<0) call mpp_error(FATAL,'data_override:field not found in init_external_field 1')
override_array(curr_position)%t_index = id_time
else !ongrid=false
- if (use_mpp_bug) then
- id_time = init_external_field_classic(filename,fieldname,domain=domain, axis_centers=axis_centers,&
- axis_sizes=axis_sizes, verbose=.false.,override=.true.,use_comp_domain=use_comp_domain, &
- nwindows = nwindows)
- dims = get_external_field_size_classic(id_time)
- else
- id_time = init_external_field_fms2io(filename,fieldname,domain=domain, axis_names=axis_names,&
- axis_sizes=axis_sizes, verbose=.false.,override=.true.,use_comp_domain=use_comp_domain, &
- nwindows = nwindows)
- dims = get_external_field_size_fms2io(id_time)
- end if
+ id_time = init_external_field(filename,fieldname,domain=domain, axis_names=axis_names,&
+ axis_sizes=axis_sizes, verbose=.false.,override=.true.,use_comp_domain=use_comp_domain, &
+ nwindows = nwindows)
+ dims = get_external_field_size(id_time)
override_array(curr_position)%dims = dims
if(id_time<0) call mpp_error(FATAL,'data_override:field not found in init_external_field 2')
override_array(curr_position)%t_index = id_time
@@ -859,21 +759,13 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde
allocate(override_array(curr_position)%horz_interp(nwindows))
allocate(override_array(curr_position)%lon_in(axis_sizes(1)+1))
allocate(override_array(curr_position)%lat_in(axis_sizes(2)+1))
- if (use_mpp_bug) then
- call get_axis_bounds(axis_centers(1),axis_bounds(1), axis_centers)
- call get_axis_bounds(axis_centers(2),axis_bounds(2), axis_centers)
-
- call mpp_get_axis_data(axis_bounds(1),override_array(curr_position)%lon_in)
- call mpp_get_axis_data(axis_bounds(2),override_array(curr_position)%lat_in)
+ if(get_external_fileobj(filename, fileobj)) then
+ call axis_edges(fileobj, axis_names(1), override_array(curr_position)%lon_in, &
+ reproduce_null_char_bug_flag=reproduce_null_char_bug)
+ call axis_edges(fileobj, axis_names(2), override_array(curr_position)%lat_in, &
+ reproduce_null_char_bug_flag=reproduce_null_char_bug)
else
- if(get_external_fileobj(filename, fileobj)) then
- call axis_edges(fileobj, axis_names(1), override_array(curr_position)%lon_in, &
- reproduce_null_char_bug_flag=reproduce_null_char_bug)
- call axis_edges(fileobj, axis_names(2), override_array(curr_position)%lat_in, &
- reproduce_null_char_bug_flag=reproduce_null_char_bug)
- else
- call mpp_error(FATAL,'data_override: file '//trim(filename)//' is not opened in time_interp_external')
- end if
+ call mpp_error(FATAL,'data_override: file '//trim(filename)//' is not opened in time_interp_external')
end if
! convert lon_in and lat_in from deg to radian
override_array(curr_position)%lon_in = override_array(curr_position)%lon_in * deg_to_radian
@@ -926,22 +818,13 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde
override_array(curr_position)%ie_src = ie_src
override_array(curr_position)%js_src = js_src
override_array(curr_position)%je_src = je_src
- if (use_mpp_bug) then
- call reset_src_data_region_classic(id_time, is_src, ie_src, js_src, je_src)
- else
- call reset_src_data_region_fms2io(id_time, is_src, ie_src, js_src, je_src)
- end if
+ call reset_src_data_region(id_time, is_src, ie_src, js_src, je_src)
! Find the index of lon_start, lon_end, lat_start and lat_end in the input grid (nearest points)
if( data_table(index1)%region_type .NE. NO_REGION ) then
allocate( lon_tmp(axis_sizes(1)), lat_tmp(axis_sizes(2)) )
- if (use_mpp_bug) then
- call mpp_get_axis_data(axis_centers(1), lon_tmp)
- call mpp_get_axis_data(axis_centers(2), lat_tmp)
- else
- call read_data(fileobj, axis_names(1), lon_tmp)
- call read_data(fileobj, axis_names(2), lat_tmp)
- end if
+ call read_data(fileobj, axis_names(1), lon_tmp)
+ call read_data(fileobj, axis_names(2), lat_tmp)
! limit lon_start, lon_end are inside lon_in
! lat_start, lat_end are inside lat_in
if( data_table(index1)%lon_start < lon_tmp(1) .OR. data_table(index1)%lon_start .GT. lon_tmp(axis_sizes(1))) &
@@ -961,11 +844,7 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde
iend = iend - is_src + 1
jstart = jstart - js_src + 1
jend = jend - js_src + 1
- if (use_mpp_bug) then
- call set_override_region_classic(id_time, data_table(index1)%region_type, istart, iend, jstart, jend)
- else
- call set_override_region_fms2io(id_time, data_table(index1)%region_type, istart, iend, jstart, jend)
- end if
+ call set_override_region(id_time, data_table(index1)%region_type, istart, iend, jstart, jend)
deallocate(lon_tmp, lat_tmp)
endif
@@ -973,10 +852,8 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde
else !curr_position >0
dims = override_array(curr_position)%dims
comp_domain = override_array(curr_position)%comp_domain
- if (.not. use_mpp_bug) then
- nxc = comp_domain(2)-comp_domain(1) + 1
- nyc = comp_domain(4)-comp_domain(3) + 1
- end if
+ nxc = comp_domain(2)-comp_domain(1) + 1
+ nyc = comp_domain(4)-comp_domain(3) + 1
is_src = override_array(curr_position)%is_src
ie_src = override_array(curr_position)%ie_src
js_src = override_array(curr_position)%js_src
@@ -1061,52 +938,40 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde
call mpp_error(FATAL, "data_override: dims(3) .NE. 1 and size(data,3) .NE. dims(3)")
if(ongrid) then
- if (.not. use_mpp_bug) 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
- end if
+ 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
end if
!10 do time interp to get data in compute_domain
if(data_file_is_2D) then
- if (use_mpp_bug) then
- call time_interp_external_classic(id_time,time,data(:,:,1),verbose=.false., &
+ if (use_comp_domain) then
+ call time_interp_external(id_time,time,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 (use_comp_domain) then
- call time_interp_external_fms2io(id_time,time,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_fms2io(id_time,time,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
+ !> 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., &
+ 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)
end do
else
- if (use_mpp_bug) then
- call time_interp_external_classic(id_time,time,data,verbose=.false., &
+ if (use_comp_domain) then
+ call time_interp_external(id_time,time,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 (use_comp_domain) then
- call time_interp_external_fms2io(id_time,time,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_fms2io(id_time,time,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)
- endif
+ !> 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., &
+ 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
endif
@@ -1114,15 +979,9 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde
! do time interp to get global data
if(data_file_is_2D) then
if( data_table(index1)%region_type == NO_REGION ) then
- if (use_mpp_bug) then
- call time_interp_external_classic(id_time,time,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)
- else
- call time_interp_external_fms2io(id_time,time,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)
- end if
+ call time_interp_external(id_time,time,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)
@@ -1130,17 +989,10 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde
else
allocate(mask_out(size(data,1), size(data,2),1))
mask_out = .false.
- if (use_mpp_bug) then
- call time_interp_external_classic(id_time,time,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)
- else
- call time_interp_external_fms2io(id_time,time,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)
- end if
+ call time_interp_external(id_time,time,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
end where
@@ -1153,30 +1005,17 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde
endif
else
if( data_table(index1)%region_type == NO_REGION ) then
- if (use_mpp_bug) then
- call time_interp_external_classic(id_time,time,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)
- else
- call time_interp_external_fms2io(id_time,time,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)
- end if
+ call time_interp_external(id_time,time,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
else
allocate(mask_out(size(data,1), size(data,2), size(data,3)) )
mask_out = .false.
- if (use_mpp_bug) then
- call time_interp_external_classic(id_time,time,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)
- else
- call time_interp_external_fms2io(id_time,time,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)
- end if
+ call time_interp_external(id_time,time,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
end where
@@ -1260,11 +1099,7 @@ subroutine data_override_0d(gridname,fieldname_code,data,time,override,data_inde
! record fieldname, gridname in override_array
override_array(curr_position)%fieldname = fieldname_code
override_array(curr_position)%gridname = gridname
- if (use_mpp_bug) then
- id_time = init_external_field_classic(filename,fieldname,verbose=.false.)
- else
- id_time = init_external_field_fms2io(filename,fieldname,verbose=.false.)
- end if
+ id_time = init_external_field(filename,fieldname,verbose=.false.)
if(id_time<0) call mpp_error(FATAL,'data_override:field not found in init_external_field 1')
override_array(curr_position)%t_index = id_time
else !curr_position >0
@@ -1273,11 +1108,7 @@ subroutine data_override_0d(gridname,fieldname_code,data,time,override,data_inde
endif !if curr_position < 0
!10 do time interp to get data in compute_domain
- if (use_mpp_bug) then
- call time_interp_external_classic(id_time, time, data, verbose=.false.)
- else
- call time_interp_external_fms2io(id_time, time, data, verbose=.false.)
- end if
+ call time_interp_external(id_time, time, data, verbose=.false.)
data = data*factor
!$OMP END SINGLE
diff --git a/data_override/get_grid_version_fms2io.F90 b/data_override/get_grid_version.F90
similarity index 98%
rename from data_override/get_grid_version_fms2io.F90
rename to data_override/get_grid_version.F90
index e112b30559..6c2dd6e93e 100644
--- a/data_override/get_grid_version_fms2io.F90
+++ b/data_override/get_grid_version.F90
@@ -21,11 +21,11 @@
!> @brief fms2_io implementations of grid routines for @ref data_override_mod
!> @file
-!> @brief File for @ref get_grid_version_fms2_io_mod
+!> @brief File for @ref get_grid_version_mod
-!> @addtogroup get_grid_version_fms2_io_mod
+!> @addtogroup get_grid_version_mod
!> @{
-module get_grid_version_fms2io_mod
+module get_grid_version_mod
use constants_mod, only: PI
use mpp_mod, only : mpp_error,FATAL,NOTE, mpp_min, mpp_max
use mpp_domains_mod, only : domain2d, operator(.NE.),operator(.EQ.)
@@ -310,6 +310,6 @@ subroutine get_grid_version_2(fileobj, mod_name, domain, isc, iec, jsc, jec, lon
end subroutine get_grid_version_2
-end module get_grid_version_fms2io_mod
+end module get_grid_version_mod
!> @}
! close documentation grouping
diff --git a/data_override/get_grid_version_mpp.F90 b/data_override/get_grid_version_mpp.F90
deleted file mode 100644
index cc95d6d2d4..0000000000
--- a/data_override/get_grid_version_mpp.F90
+++ /dev/null
@@ -1,281 +0,0 @@
-!***********************************************************************
-!* GNU Lesser General Public License
-!*
-!* This file is part of the GFDL Flexible Modeling System (FMS).
-!*
-!* FMS is free software: you can redistribute it and/or modify it under
-!* the terms of the GNU Lesser General Public License as published by
-!* the Free Software Foundation, either version 3 of the License, or (at
-!* your option) any later version.
-!*
-!* FMS is distributed in the hope that it will be useful, but WITHOUT
-!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
-!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-!* for more details.
-!*
-!* You should have received a copy of the GNU Lesser General Public
-!* License along with FMS. If not, see .
-!***********************************************************************
-!> @defgroup get_grid_version_mpp_mod get_grid_version_mpp_mod
-!> @ingroup data_override
-!! @brief mpp_io implementations of grid routines
-
-!> @file
-!> @brief File for @ref get_grid_version_mpp_mod
-
-!> @addtogroup get_grid_version_mpp_mod
-!> @{
-module get_grid_version_mpp_mod
-use constants_mod, only: PI
-use mpp_mod, only : mpp_error,FATAL,WARNING,NOTE, mpp_min, mpp_max
-use fms_io_mod, only: field_size, read_data, get_mosaic_tile_grid
-use fms_mod, only: field_exist
-use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, operator(.NE.),operator(.EQ.)
-use mpp_domains_mod, only : mpp_copy_domain, mpp_get_global_domain
-use mpp_domains_mod, only : mpp_get_data_domain, mpp_set_compute_domain, mpp_set_data_domain
-use mpp_domains_mod, only : mpp_set_global_domain, mpp_deallocate_domain
-
-implicit none
-
-real, parameter :: deg_to_radian=PI/180.
-contains
-
-!> Get lon and lat of three model (target) grids from grid_spec.nc
-subroutine check_grid_sizes(domain_name, Domain, nlon, nlat)
-character(len=12), intent(in) :: domain_name
-type (domain2d), intent(in) :: Domain
-integer, intent(in) :: nlon, nlat
-
-character(len=184) :: error_message
-integer :: xsize, ysize
-
-call mpp_get_global_domain(Domain, xsize=xsize, ysize=ysize)
-if(nlon .NE. xsize .OR. nlat .NE. ysize) then
- error_message = 'Error in data_override_init. Size of grid as specified by '// &
- ' does not conform to that specified by grid_spec.nc.'// &
- ' From : by From grid_spec.nc: by '
- error_message( 59: 70) = domain_name
- error_message(130:141) = domain_name
- write(error_message(143:146),'(i4)') xsize
- write(error_message(150:153),'(i4)') ysize
- write(error_message(174:177),'(i4)') nlon
- write(error_message(181:184),'(i4)') nlat
- call mpp_error(FATAL,error_message)
-endif
-end subroutine check_grid_sizes
-
-!> Get global lon and lat of three model (target) grids, with a given file name
-subroutine get_grid_version_classic_1(grid_file, mod_name, domain, isc, iec, jsc, jec, lon, lat, min_lon, max_lon, grid_center_bug)
- character(len=*), intent(in) :: grid_file !< Grid file name
- character(len=*), intent(in) :: mod_name !< module name
- type(domain2d), intent(in) :: domain !< 2D domain
- integer, intent(in) :: isc, iec, jsc, jec
- real, dimension(isc:,jsc:), intent(out) :: lon, lat
- real, intent(out) :: min_lon, max_lon
- logical, intent(in), optional :: grid_center_bug !< Enables legacy behaviour
-
- integer :: i, j, siz(4)
- integer :: nlon, nlat ! size of global lon and lat
- real, dimension(:,:,:), allocatable :: lon_vert, lat_vert !of OCN grid vertices
- real, dimension(:), allocatable :: glon, glat ! lon and lat of 1-D grid of atm/lnd
- logical :: is_new_grid
- integer :: is, ie, js, je
- integer :: isd, ied, jsd, jed
- integer :: isg, ieg, jsg, jeg
- type(domain2d) :: domain2
- character(len=3) :: xname, yname
-
- call mpp_get_data_domain(domain, isd, ied, jsd, jed)
- call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
-
- select case(mod_name)
- case('ocn', 'ice')
- is_new_grid = .FALSE.
- if(field_exist(grid_file, 'x_T')) then
- is_new_grid = .true.
- else if(field_exist(grid_file, 'geolon_t')) then
- is_new_grid = .FALSE.
- else
- call mpp_error(FATAL,'data_override: both x_T and geolon_t is not in the grid file '//trim(grid_file) )
- endif
-
- if(is_new_grid) then
- call field_size(grid_file, 'x_T', siz)
- nlon = siz(1); nlat = siz(2)
- call check_grid_sizes(trim(mod_name)//'_domain ', domain, nlon, nlat)
- allocate(lon_vert(isc:iec,jsc:jec,4), lat_vert(isc:iec,jsc:jec,4) )
- call read_data(trim(grid_file), 'x_vert_T', lon_vert, domain)
- call read_data(trim(grid_file), 'y_vert_T', lat_vert, domain)
-
-!2 Global lon and lat of ocean grid cell centers are determined from adjacent vertices
- lon(:,:) = (lon_vert(:,:,1) + lon_vert(:,:,2) + lon_vert(:,:,3) + lon_vert(:,:,4))*0.25
- lat(:,:) = (lat_vert(:,:,1) + lat_vert(:,:,2) + lat_vert(:,:,3) + lat_vert(:,:,4))*0.25
- else
- if(grid_center_bug) call mpp_error(NOTE, &
- 'data_override: grid_center_bug is set to true, the grid center location may be incorrect')
- call field_size(grid_file, 'geolon_vert_t', siz)
- nlon = siz(1) - 1; nlat = siz(2) - 1;
- call check_grid_sizes(trim(mod_name)//'_domain ', domain, nlon, nlat)
- call mpp_copy_domain(domain, domain2)
- call mpp_set_compute_domain(domain2, isc, iec+1, jsc, jec+1, iec-isc+2, jec-jsc+2 )
- call mpp_set_data_domain (domain2, isd, ied+1, jsd, jed+1, ied-isd+2, jed-jsd+2 )
- call mpp_set_global_domain (domain2, isg, ieg+1, jsg, jeg+1, ieg-isg+2, jeg-jsg+2 )
- allocate(lon_vert(isc:iec+1,jsc:jec+1,1))
- allocate(lat_vert(isc:iec+1,jsc:jec+1,1))
- call read_data(trim(grid_file), 'geolon_vert_t', lon_vert, domain2)
- call read_data(trim(grid_file), 'geolat_vert_t', lat_vert, domain2)
-
- if(grid_center_bug) then
- do j = jsc, jec
- do i = isc, iec
- lon(i,j) = (lon_vert(i,j,1) + lon_vert(i+1,j,1))/2.
- lat(i,j) = (lat_vert(i,j,1) + lat_vert(i,j+1,1))/2.
- enddo
- enddo
- else
- do j = jsc, jec
- do i = isc, iec
- lon(i,j) = (lon_vert(i,j,1) + lon_vert(i+1,j,1) + &
- lon_vert(i+1,j+1,1) + lon_vert(i,j+1,1))*0.25
- lat(i,j) = (lat_vert(i,j,1) + lat_vert(i+1,j,1) + &
- lat_vert(i+1,j+1,1) + lat_vert(i,j+1,1))*0.25
- enddo
- enddo
- end if
- call mpp_deallocate_domain(domain2)
- endif
- deallocate(lon_vert)
- deallocate(lat_vert)
- case('atm', 'lnd')
- if(trim(mod_name) == 'atm') then
- xname = 'xta'; yname = 'yta'
- else
- xname = 'xtl'; yname = 'ytl'
- endif
- call field_size(grid_file, xname, siz)
- nlon = siz(1); allocate(glon(nlon))
- call read_data(grid_file, xname, glon, no_domain = .true.)
-
- call field_size(grid_file, yname, siz)
- nlat = siz(1); allocate(glat(nlat))
- call read_data(grid_file, yname, glat, no_domain = .true.)
- call check_grid_sizes(trim(mod_name)//'_domain ', domain, nlon, nlat)
-
- is = isc - isg + 1; ie = iec - isg + 1
- js = jsc - jsg + 1; je = jec - jsg + 1
- do j = js, jec
- do i = is, ie
- lon(i,j) = glon(i)
- lat(i,j) = glat(j)
- enddo
- enddo
- deallocate(glon)
- deallocate(glat)
- case default
- call mpp_error(FATAL, "data_override_mod: mod_name should be 'atm', 'ocn', 'ice' or 'lnd' ")
- end select
-
- ! convert from degree to radian
- lon = lon * deg_to_radian
- lat = lat * deg_to_radian
- min_lon = minval(lon)
- max_lon = maxval(lon)
- call mpp_min(min_lon)
- call mpp_max(max_lon)
-
-
-end subroutine get_grid_version_classic_1
-
-!> Get global lon and lat of three model (target) grids from mosaic.nc.
-!! Currently we assume the refinement ratio is 2 and there is one tile on each pe.
-subroutine get_grid_version_classic_2(mosaic_file, mod_name, domain, isc, iec, jsc, jec, lon, lat, min_lon, max_lon)
- character(len=*), intent(in) :: mosaic_file !< Mosaic file name
- character(len=*), intent(in) :: mod_name !< module name
- type(domain2d), intent(in) :: domain !< 2D domain
- integer, intent(in) :: isc, iec, jsc, jec
- real, dimension(isc:,jsc:), intent(out) :: lon, lat
- real, intent(out) :: min_lon, max_lon
-
- integer :: i, j, siz(4)
- integer :: nlon, nlat ! size of global grid
- integer :: nlon_super, nlat_super ! size of global supergrid.
- integer :: isd, ied, jsd, jed
- integer :: isg, ieg, jsg, jeg
- integer :: isc2, iec2, jsc2, jec2
- character(len=256) :: solo_mosaic_file, grid_file
- real, allocatable :: tmpx(:,:), tmpy(:,:)
- type(domain2d) :: domain2
-
- if(trim(mod_name) .NE. 'atm' .AND. trim(mod_name) .NE. 'ocn' .AND. &
- trim(mod_name) .NE. 'ice' .AND. trim(mod_name) .NE. 'lnd' ) call mpp_error(FATAL, &
- "data_override_mod: mod_name should be 'atm', 'ocn', 'ice' or 'lnd' ")
-
- call mpp_get_data_domain(domain, isd, ied, jsd, jed)
- call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
-
- ! get the grid file to read
- if(field_exist(mosaic_file, trim(mod_name)//'_mosaic_file' )) then
- call read_data(mosaic_file, trim(mod_name)//'_mosaic_file', solo_mosaic_file)
- solo_mosaic_file = 'INPUT/'//trim(solo_mosaic_file)
- else
- solo_mosaic_file = mosaic_file
- end if
- call get_mosaic_tile_grid(grid_file, solo_mosaic_file, domain)
-
- call field_size(grid_file, 'area', siz)
- nlon_super = siz(1); nlat_super = siz(2)
- if( mod(nlon_super,2) .NE. 0) call mpp_error(FATAL, &
- 'data_override_mod: '//trim(mod_name)//' supergrid longitude size can not be divided by 2')
- if( mod(nlat_super,2) .NE. 0) call mpp_error(FATAL, &
- 'data_override_mod: '//trim(mod_name)//' supergrid latitude size can not be divided by 2')
- nlon = nlon_super/2;
- nlat = nlat_super/2;
- call check_grid_sizes(trim(mod_name)//'_domain ', domain, nlon, nlat)
-
- !--- setup the domain for super grid.
- call mpp_copy_domain(domain, domain2)
- call mpp_set_compute_domain(domain2, 2*isc-1, 2*iec+1, 2*jsc-1, 2*jec+1, 2*iec-2*isc+3, 2*jec-2*jsc+3 )
- call mpp_set_data_domain (domain2, 2*isd-1, 2*ied+1, 2*jsd-1, 2*jed+1, 2*ied-2*isd+3, 2*jed-2*jsd+3 )
- call mpp_set_global_domain (domain2, 2*isg-1, 2*ieg+1, 2*jsg-1, 2*jeg+1, 2*ieg-2*isg+3, 2*jeg-2*jsg+3 )
-
- call mpp_get_compute_domain(domain2, isc2, iec2, jsc2, jec2)
- if(isc2 .NE. 2*isc-1 .OR. iec2 .NE. 2*iec+1 .OR. jsc2 .NE. 2*jsc-1 .OR. jec2 .NE. 2*jec+1) then
- call mpp_error(FATAL, 'data_override_mod: '//trim(mod_name)//' supergrid domain is not set properly')
- endif
-
- allocate(tmpx(isc2:iec2, jsc2:jec2), tmpy(isc2:iec2, jsc2:jec2) )
- call read_data( grid_file, 'x', tmpx, domain2)
- call read_data( grid_file, 'y', tmpy, domain2)
- ! copy data onto model grid
- if(trim(mod_name) == 'ocn' .OR. trim(mod_name) == 'ice') then
- do j = jsc, jec
- do i = isc, iec
- lon(i,j) = (tmpx(i*2-1,j*2-1)+tmpx(i*2+1,j*2-1)+tmpx(i*2+1,j*2+1)+tmpx(i*2-1,j*2+1))*0.25
- lat(i,j) = (tmpy(i*2-1,j*2-1)+tmpy(i*2+1,j*2-1)+tmpy(i*2+1,j*2+1)+tmpy(i*2-1,j*2+1))*0.25
- end do
- end do
- else
- do j = jsc, jec
- do i = isc, iec
- lon(i,j) = tmpx(i*2,j*2)
- lat(i,j) = tmpy(i*2,j*2)
- end do
- end do
- endif
-
- ! convert to radian
- lon = lon * deg_to_radian
- lat = lat * deg_to_radian
-
- deallocate(tmpx, tmpy)
- min_lon = minval(lon)
- max_lon = maxval(lon)
- call mpp_min(min_lon)
- call mpp_max(max_lon)
-
- call mpp_deallocate_domain(domain2)
-
-end subroutine get_grid_version_classic_2
-
-end module get_grid_version_mpp_mod
-
diff --git a/diag_integral/diag_integral.F90 b/diag_integral/diag_integral.F90
index 4a1c0e31a7..12a45e0a26 100644
--- a/diag_integral/diag_integral.F90
+++ b/diag_integral/diag_integral.F90
@@ -69,7 +69,7 @@ module diag_integral_mod
operator(+), operator(-), &
operator(==), operator(>=), &
operator(/=)
-use mpp_mod, only: input_nml_file, get_unit
+use mpp_mod, only: input_nml_file
use fms_mod, only: open_file, error_mesg, &
check_nml_error, &
fms_init, &
@@ -326,10 +326,8 @@ subroutine diag_integral_init (Time_init, Time, blon, blat, area_in)
!-------------------------------------------------------------------------------
! read namelist.
!-------------------------------------------------------------------------------
- if ( file_exists('input.nml')) then
- read (input_nml_file, nml=diag_integral_nml, iostat=io)
- ierr = check_nml_error(io,'diag_integral_nml')
- endif
+ read (input_nml_file, nml=diag_integral_nml, iostat=io)
+ ierr = check_nml_error(io,'diag_integral_nml')
!-------------------------------------------------------------------------------
! write version number and namelist to logfile.
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 7b1f9c767c..1eabbc2a22 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -198,11 +198,7 @@ MODULE diag_manager_mod
USE mpp_io_mod, ONLY: mpp_open, mpp_close, mpp_get_maxunits
USE mpp_mod, ONLY: mpp_get_current_pelist, mpp_pe, mpp_npes, mpp_root_pe, mpp_sum
-#ifdef INTERNAL_FILE_NML
USE mpp_mod, ONLY: input_nml_file
-#else
- USE fms_mod, ONLY: open_namelist_file, close_file
-#endif
USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,&
& file_exist, fms_error_handler, check_nml_error, get_mosaic_tile_file, lowercase
@@ -3133,7 +3129,6 @@ INTEGER FUNCTION writing_field(out_num, at_diag_end, error_string, time)
INTEGER :: b1,b2,b3,b4 !< size of buffer along x,y,z,and diurnal axes
INTEGER :: i, j, k, m
REAL :: missvalue, num
- real,allocatable,dimension(:,:,:,:) :: diurnal_buffer
writing_field = 0
need_compute = output_fields(out_num)%need_compute
@@ -3233,17 +3228,6 @@ INTEGER FUNCTION writing_field(out_num, at_diag_end, error_string, time)
! Output field
IF ( at_diag_end .AND. freq == END_OF_RUN ) output_fields(out_num)%next_output = time
! if (time .eq. output_fields(out_num)%next_output) then
- if (output_fields(out_num)%n_diurnal_samples > 1) then
- !> allocate the buffer for diurnal data
- allocate(diurnal_buffer(size(output_fields(out_num)%buffer,1),size(output_fields(out_num)%buffer,2),&
- size(output_fields(out_num)%buffer,4),size(output_fields(out_num)%buffer,3)))
- !> swap the last 2 axes in the data buffer to match the netcdf output order
- do i = 1,size(output_fields(out_num)%buffer,4)
- do j = 1,size(output_fields(out_num)%buffer,3)
- diurnal_buffer(:,:,i,j) = output_fields(out_num)%buffer(:,:,j,i)
- enddo
- enddo
- endif
IF ( (output_fields(out_num)%time_ops) .AND. (.NOT. mix_snapshot_average_fields) ) THEN
middle_time = (output_fields(out_num)%last_output+output_fields(out_num)%next_output)/2
if (trim(files(file_num)%filename_time_bounds) == "begin") then
@@ -3254,22 +3238,11 @@ INTEGER FUNCTION writing_field(out_num, at_diag_end, error_string, time)
filename_time = output_fields(out_num)%next_output
endif
- if (output_fields(out_num)%n_diurnal_samples > 1) then
- CALL diag_data_out(file_num, out_num, diurnal_buffer, middle_time, &
- & use_mpp_io_arg=use_mpp_io, filename_time=filename_time)
- else
- CALL diag_data_out(file_num, out_num, output_fields(out_num)%buffer, middle_time, &
- & use_mpp_io_arg=use_mpp_io, filename_time=filename_time)
- endif
+ CALL diag_data_out(file_num, out_num, output_fields(out_num)%buffer, middle_time, &
+ & filename_time=filename_time)
ELSE
- if (output_fields(out_num)%n_diurnal_samples > 1) then
- CALL diag_data_out(file_num, out_num, &
- & diurnal_buffer, output_fields(out_num)%next_output, use_mpp_io_arg=use_mpp_io)
- else
- CALL diag_data_out(file_num, out_num, &
- & output_fields(out_num)%buffer, output_fields(out_num)%next_output,&
- & use_mpp_io_arg=use_mpp_io)
- endif
+ CALL diag_data_out(file_num, out_num, &
+ & output_fields(out_num)%buffer, output_fields(out_num)%next_output)
END IF
!output_fields(out_num)%last_output = output_fields(out_num)%next_output
! endif
@@ -3298,7 +3271,6 @@ INTEGER FUNCTION writing_field(out_num, at_diag_end, error_string, time)
END IF
IF ( input_fields(in_num)%mask_variant .AND. average ) output_fields(out_num)%counter = 0.0
END IF
- if (allocated(diurnal_buffer))deallocate(diurnal_buffer)
END FUNCTION writing_field
SUBROUTINE diag_manager_set_time_end(Time_end_in)
@@ -3333,8 +3305,7 @@ SUBROUTINE diag_send_complete_instant(time)
& (input_fields(in_num)%active_omp_level.LE.1) ) CYCLE
file_num = output_fields(out_num)%output_file
CALL diag_data_out(file_num, out_num, &
- & output_fields(out_num)%buffer, time, &
- & use_mpp_io_arg=use_mpp_io)
+ & output_fields(out_num)%buffer, time)
END DO
END IF
END DO
@@ -3417,12 +3388,10 @@ SUBROUTINE diag_manager_end(time)
DO file = 1, num_files
CALL closing_file(file, time)
END DO
- if (.not.use_mpp_io) then
if (allocated(fileobjU)) deallocate(fileobjU)
if (allocated(fileobj)) deallocate(fileobj)
if (allocated(fileobjND)) deallocate(fileobjND)
- if (allocated(fnum_for_domain)) deallocate(fnum_for_domain)
- endif
+ if (allocated(fnum_for_domain)) deallocate(fnum_for_domain)
END SUBROUTINE diag_manager_end
!> @brief Replaces diag_manager_end; close just one file: files(file)
@@ -3434,7 +3403,6 @@ SUBROUTINE closing_file(file, time)
INTEGER :: stdout_unit
LOGICAL :: reduced_k_range, need_compute, local_output
CHARACTER(len=128) :: message
- real,allocatable,dimension(:,:,:,:) :: diurnal_buffer
stdout_unit = stdout()
@@ -3485,25 +3453,11 @@ SUBROUTINE closing_file(file, time)
& TRIM(output_fields(i)%output_name)//' NOT available,'//&
& ' check if output interval > runlength. Netcdf fill_values are written', NOTE)
output_fields(i)%buffer = FILL_VALUE
- if (output_fields(i)%n_diurnal_samples > 1) then
- !> allocate the buffer for diurnal data
- if (.not. allocated(diurnal_buffer)) &
- allocate(diurnal_buffer(size(output_fields(i)%buffer,1),size(output_fields(i)%buffer,2),&
- size(output_fields(i)%buffer,4),size(output_fields(i)%buffer,3)))
- !> swap the last 2 axes in the data buffer to match the netcdf output order
- do loop1 = 1,size(output_fields(i)%buffer,4)
- do loop2 = 1,size(output_fields(i)%buffer,3)
- diurnal_buffer(:,:,loop1,loop2) = output_fields(i)%buffer(:,:,loop2,loop1)
- enddo
- enddo
- CALL diag_data_out(file, i, diurnal_buffer, time, .TRUE., use_mpp_io_arg=use_mpp_io)
- else
- CALL diag_data_out(file, i, output_fields(i)%buffer, time, .TRUE., use_mpp_io_arg=use_mpp_io)
- endif
+ CALL diag_data_out(file, i, output_fields(i)%buffer, time, .TRUE.)
END IF
END DO
! Now it's time to output static fields
- CALL write_static(file, use_mpp_io)
+ CALL write_static(file)
! Write out the number of bytes of data saved to this file
IF ( write_bytes_in_file ) THEN
@@ -3512,7 +3466,6 @@ SUBROUTINE closing_file(file, time)
& WRITE (stdout_unit,'(a,i12,a,a)') 'Diag_Manager: ',files(file)%bytes_written, &
& ' bytes of data written to file ',TRIM(files(file)%name)
END IF
- if (allocated(diurnal_buffer)) deallocate(diurnal_buffer)
END SUBROUTINE closing_file
!> @brief Initialize Diagnostics Manager.
@@ -3531,9 +3484,6 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
INTEGER, ALLOCATABLE, DIMENSION(:) :: pelist
INTEGER :: stdlog_unit, stdout_unit
integer :: j
-#ifndef INTERNAL_FILE_NML
- INTEGER :: nml_unit
-#endif
CHARACTER(len=256) :: err_msg_local
NAMELIST /diag_manager_nml/ append_pelist_name, mix_snapshot_average_fields, max_output_fields, &
@@ -3582,23 +3532,12 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
END IF
END IF
-#ifdef INTERNAL_FILE_NML
READ (input_nml_file, NML=diag_manager_nml, IOSTAT=mystat)
-#else
- IF ( file_exist('input.nml') ) THEN
- nml_unit = open_namelist_file()
- READ (nml_unit, diag_manager_nml, iostat=mystat)
- CALL close_file(nml_unit)
- ELSE
- ! Set mystat to an arbitrary positive number if input.nml does not exist.
- mystat = 100
- END IF
-#endif
! Check the status of reading the diag_manager_nml
IF ( check_nml_error(IOSTAT=mystat, NML_NAME='DIAG_MANAGER_NML') < 0 ) THEN
IF ( mpp_pe() == mpp_root_pe() ) THEN
- CALL error_mesg('diag_manager_mod::diag_manager_init', 'DIAG_MANAGER_NML not found in input.nml. Using defaults.',&
+ CALL error_mesg('diag_manager_mod::diag_manager_init', 'DIAG_MANAGER_NML not found in input nml file. Using defaults.',&
& WARNING)
END IF
END IF
@@ -3659,10 +3598,8 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg)
& 'diag_manager is using fms2_io', NOTE)
else
CALL error_mesg('diag_manager_mod::diag_manager_init',&
- & 'diag_manager is using mpp_io', NOTE)
- CALL error_mesg('diag_manager_mod::diag_manager_init',&
- &'MPP_IO is no longer supported. Please remove from namelist',&
- &WARNING)
+ &'MPP_IO is no longer supported. Please remove use_mpp_io from diag_manager_nml namelist',&
+ &FATAL)
endif
ALLOCATE(pelist(mpp_npes()))
CALL mpp_get_current_pelist(pelist, pelist_name)
diff --git a/diag_manager/diag_output.F90 b/diag_manager/diag_output.F90
index 60298e33f6..0913b256a8 100644
--- a/diag_manager/diag_output.F90
+++ b/diag_manager/diag_output.F90
@@ -39,10 +39,6 @@ MODULE diag_output_mod
& mpp_get_id, MPP_WRONLY, MPP_OVERWR,&
& MPP_NETCDF, MPP_MULTI, MPP_SINGLE, mpp_get_field_name, &
& fillin_fieldtype
-! use_mpp_io = .true.
- USE mpp_io_mod, ONLY: mpp_open,mpp_write_meta,&
- & mpp_write, mpp_flush, mpp_close, &
- & mpp_io_unstructured_write
USE mpp_domains_mod, ONLY: domain1d, domain2d, mpp_define_domains, mpp_get_pelist,&
& mpp_get_global_domain, mpp_get_compute_domains, null_domain1d, null_domain2d,&
& domainUG, null_domainUG, CENTER, EAST, NORTH, mpp_get_compute_domain,&
@@ -72,12 +68,9 @@ MODULE diag_output_mod
IMPLICIT NONE
PRIVATE
-!> 2020.03 use_mpp_io diag_output_init, write_axis_meta_data, write_field_meta_data, write_attribute_meta are
-!! interfaces for the two different routines supporting each IO
PUBLIC :: diag_output_init, write_axis_meta_data, write_field_meta_data, done_meta_data,&
& diag_fieldtype, get_diag_global_att, set_diag_global_att
- PUBLIC :: diag_field_write, diag_write_time !< use_mpp_io = .false.
- PUBLIC :: diag_field_out, done_meta_data_use_mpp_io !< use_mpp_io = .true.
+ PUBLIC :: diag_field_write, diag_write_time, diag_flush
TYPE(diag_global_att_type), SAVE :: diag_global_att
INTEGER, PARAMETER :: NETCDF1 = 1
@@ -106,27 +99,22 @@ MODULE diag_output_mod
module procedure diag_field_write_varname
end interface
- ! The following interfaces are used in conjuctions with use_mpp_io
-
!> Initialize output for writing.
!> @ingroup diag_output_mod
interface diag_output_init
module procedure diag_output_init_fms2_io
- module procedure diag_output_init_use_mpp_io
end interface
!> Writes axis metadata to a file.
!> @ingroup diag_output_mod
interface write_axis_meta_data
module procedure write_axis_meta_data_fms2_io
- module procedure write_axis_meta_data_use_mpp_io
end interface
!> Writes field metadata to a file.
!> @ingroup diag_output_mod
interface write_field_meta_data
module procedure write_field_meta_data_fms2_io
- module procedure write_field_meta_data_use_mpp_io
end interface
!> Private interface to write metadata for an attribute to a file.
@@ -135,7 +123,6 @@ MODULE diag_output_mod
!> @ingroup diag_output_mod
interface write_attribute_meta
module procedure write_attribute_meta_fms2_io
- module procedure write_attribute_meta_use_mpp_io
end interface
!> @addtogroup diag_output_mod
@@ -1185,7 +1172,6 @@ subroutine diag_field_write_field (field, buffer, static, fileob, file_num, file
character(len=2), intent(in), optional :: fnum_for_domain
INTEGER, OPTIONAL, INTENT(in) :: time_in
integer :: time
- real(kind=4),allocatable :: local_buffer(:,:,:,:)
if (present(static)) then
if (static) time = 0
elseif (present(time_in)) then
@@ -1207,31 +1193,29 @@ subroutine diag_field_write_field (field, buffer, static, fileob, file_num, file
call error_mesg("diag_field_write","fileob passed in is not one of the FmsNetcdfFile_t types",fatal)
end select
elseif (present(file_num) .and. present(fileobjU) .and. present(fileobjND) .and. present(fileobj) .and. present(fnum_for_domain)) then
- allocate(local_buffer(size(buffer,1),size(buffer,2),size(buffer,3),size(buffer,4)))
- local_buffer = real(buffer,4)
!> Figure out which file object to write output to
! if (fnum_for_domain == "2d" .or. fnum_for_domain == "nd") then
if (fnum_for_domain == "2d" ) then
if (check_if_open(fileobj(file_num))) then
if (time == 0) then
- call write_data (fileobj (file_num), trim(mpp_get_field_name(field%field)), local_buffer)
+ call write_data (fileobj (file_num), trim(mpp_get_field_name(field%field)), buffer)
else
- call write_data (fileobj (file_num), trim(mpp_get_field_name(field%field)), local_buffer, unlim_dim_level=time)
+ call write_data (fileobj (file_num), trim(mpp_get_field_name(field%field)), buffer, unlim_dim_level=time)
endif
endif
elseif (fnum_for_domain == "nd") then
if (check_if_open(fileobjND (file_num)) ) then
if (time == 0) then
- call write_data (fileobjND (file_num), trim(mpp_get_field_name(field%field)), local_buffer)
+ call write_data (fileobjND (file_num), trim(mpp_get_field_name(field%field)), buffer)
else
- call write_data (fileobjND (file_num), trim(mpp_get_field_name(field%field)), local_buffer, unlim_dim_level=time)
+ call write_data (fileobjND (file_num), trim(mpp_get_field_name(field%field)), buffer, unlim_dim_level=time)
endif
endif
elseif (fnum_for_domain == "ug") then
if (time == 0) then
- call write_data (fileobjU(file_num), trim(mpp_get_field_name(field%field)), local_buffer)
+ call write_data (fileobjU(file_num), trim(mpp_get_field_name(field%field)), buffer)
else
- call write_data (fileobjU(file_num), trim(mpp_get_field_name(field%field)), local_buffer, unlim_dim_level=time)
+ call write_data (fileobjU(file_num), trim(mpp_get_field_name(field%field)), buffer, unlim_dim_level=time)
endif
else
call error_mesg("diag_field_write","No file object is associated with this file number",fatal)
@@ -1243,7 +1227,6 @@ subroutine diag_field_write_field (field, buffer, static, fileob, file_num, file
else
call error_mesg("diag_field_write","You must include a fileob or a file_num.",fatal)
endif
- if (allocated(local_buffer)) deallocate(local_buffer)
end subroutine diag_field_write_field
!> \brief Writes diagnostic data out using fms2_io routine.
@@ -1260,7 +1243,8 @@ subroutine diag_field_write_varname (varname, buffer, static, fileob, file_num,
character(len=2), intent(in), optional :: fnum_for_domain
INTEGER, OPTIONAL, INTENT(in) :: time_in
integer :: time
- real(kind=4),allocatable :: local_buffer(:,:,:,:)
+ real,allocatable :: local_buffer(:,:,:,:) !< Buffer containing the data will be sent to fms2io
+
!> Set up the time. Static field and default time is 0
if (present(static) .and. static) then
time = 0
@@ -1270,31 +1254,40 @@ subroutine diag_field_write_varname (varname, buffer, static, fileob, file_num,
time = 0
endif
+ !> If the variable is 2D, switch the n_diurnal_samples and nz dimension, so local_buffer has
+ !! dimension (nx, ny, n_diurnal_samples, nz).
+ if (size(buffer,3) .eq. 1) then
+ allocate(local_buffer(size(buffer,1),size(buffer,2),size(buffer,4),size(buffer,3)))
+ local_buffer(:,:,:,1) = buffer(:,:,1,:)
+ else
+ allocate(local_buffer(size(buffer,1),size(buffer,2),size(buffer,3),size(buffer,4)))
+ local_buffer = buffer(:,:,:,:)
+ endif
+
if (present(fileob)) then !> Write output to the fileob file
fptr => fileob
select type (fptr)
type is (FmsNetcdfFile_t)
- call write_data (fptr,trim(varname),buffer)
+ call write_data (fptr,trim(varname),local_buffer)
type is (FmsNetcdfDomainFile_t)
- call write_data (fptr,trim(varname),buffer)
+ call write_data (fptr,trim(varname),local_buffer)
type is (FmsNetcdfUnstructuredDomainFile_t)
- call write_data (fptr,trim(varname),buffer)
+ call write_data (fptr,trim(varname),local_buffer)
class default
call error_mesg("diag_field_write","fileob passed in is not one of the FmsNetcdfFile_t types",fatal)
end select
- call write_data (fileob,trim(varname),buffer)
elseif (present(file_num) .and. present(fileobjU) .and. present(fileobj) .and. present(fileobjND) .and. present(fnum_for_domain)) then
!> Figure out which file object to write output to
if (fnum_for_domain == "2d" ) then
if (check_if_open(fileobj(file_num))) then
- call write_data (fileobj (file_num), trim(varname), buffer, unlim_dim_level=time )
+ call write_data (fileobj (file_num), trim(varname), local_buffer, unlim_dim_level=time )
endif
elseif (fnum_for_domain == "nd") then
if (check_if_open(fileobjND (file_num)) ) then
- call write_data (fileobjND (file_num), trim(varname), buffer, unlim_dim_level=time)
+ call write_data (fileobjND (file_num), trim(varname), local_buffer, unlim_dim_level=time)
endif
elseif (fnum_for_domain == "ug") then
- call write_data (fileobjU(file_num), trim(varname), buffer, unlim_dim_level=time)
+ call write_data (fileobjU(file_num), trim(varname), local_buffer, unlim_dim_level=time)
else
call error_mesg("diag_field_write","No file object is associated with this file number",fatal)
endif
@@ -1304,6 +1297,7 @@ subroutine diag_field_write_varname (varname, buffer, static, fileob, file_num,
else
call error_mesg("diag_field_write","You must include a fileob or a file_num.",fatal)
endif
+ deallocate(local_buffer)
end subroutine diag_field_write_varname
!> \brief Writes the time data to the history file
subroutine diag_write_time (fileob,rtime_value,time_index,time_name)
@@ -1328,755 +1322,69 @@ subroutine diag_write_time (fileob,rtime_value,time_index,time_name)
if (associated(fptr)) nullify(fptr)
end subroutine diag_write_time
- !> @brief Registers the time axis and opens the output file.
- SUBROUTINE diag_output_init_use_mpp_io(file_name, FORMAT, file_title, file_unit,&
- & all_scalar_or_1d, domain, domainU, attributes)
- CHARACTER(len=*), INTENT(in) :: file_name !< Output file name
- CHARACTER(len=*), INTENT(in) :: file_title !< Descriptive title for the file
- INTEGER , INTENT(in) :: FORMAT !< File format (currently only 'NETCDF' is valid)
- INTEGER , INTENT(out) :: file_unit !< file unit number for output file
- LOGICAL , INTENT(in) :: all_scalar_or_1d
- TYPE(domain2d) , INTENT(in) :: domain
- TYPE(diag_atttype), INTENT(in), DIMENSION(:), OPTIONAL :: attributes
- TYPE(domainUG), INTENT(in) :: domainU !< Unstructured domain
-
- INTEGER :: form, threading, fileset, i
- TYPE(diag_global_att_type) :: gAtt
-
- !---- initialize mpp_io ----
- IF ( .NOT.module_is_initialized ) THEN
- CALL mpp_io_init ()
- module_is_initialized = .TRUE.
- CALL write_version_number("DIAG_OUTPUT_MOD", version)
- END IF
-
- !---- set up output file ----
- SELECT CASE (FORMAT)
- CASE (NETCDF1)
- form = MPP_NETCDF
- threading = MPP_MULTI
- fileset = MPP_MULTI
- CASE default
- ! invalid format
- CALL error_mesg('diag_output_init', 'invalid format', FATAL)
- END SELECT
-
- IF(all_scalar_or_1d) THEN
- threading = MPP_SINGLE
- fileset = MPP_SINGLE
- END IF
-
-
-!> Check to make sure that only domain2D or domainUG is used. If both are not null, then FATAL
- if (domain .NE. NULL_DOMAIN2D .AND. domainU .NE. NULL_DOMAINUG)&
- & CALL error_mesg('diag_output_init', "Domain2D and DomainUG can not be used at the same time in "//&
- & trim(file_name), FATAL)
-
- !---- open output file (return file_unit id) -----
- IF ( domain .NE. NULL_DOMAIN2D ) THEN
- CALL mpp_open(file_unit, file_name, action=MPP_OVERWR, form=form,&
- & threading=threading, fileset=fileset, domain=domain)
- ELSE IF (domainU .NE. NULL_DOMAINUG) THEN
- CALL mpp_open(file_unit, file_name, action=MPP_OVERWR, form=form,&
- & threading=threading, fileset=fileset, domain_UG=domainU)
- ELSE
- CALL mpp_open(file_unit, file_name, action=MPP_OVERWR, form=form,&
- & threading=threading, fileset=fileset)
- END IF
-
- !---- write global attributes ----
- IF ( file_title(1:1) /= ' ' ) THEN
- CALL mpp_write_meta(file_unit, 'title', cval=TRIM(file_title))
- END IF
-
- IF ( PRESENT(attributes) ) THEN
- DO i=1, SIZE(attributes)
- SELECT CASE (attributes(i)%type)
- CASE (NF90_INT)
- CALL mpp_write_meta(file_unit, TRIM(attributes(i)%name), ival=attributes(i)%iatt)
- CASE (NF90_FLOAT)
- CALL mpp_write_meta(file_unit, TRIM(attributes(i)%name), rval=attributes(i)%fatt)
- CASE (NF90_CHAR)
- CALL mpp_write_meta(file_unit, TRIM(attributes(i)%name), cval=TRIM(attributes(i)%catt))
- CASE default
- !
- ! Unknown attribute type for attribute to module/input_field /.
- ! Contact the developers.
- !
- CALL error_mesg('diag_output_mod::diag_output_init', 'Unknown attribute type for global attribute "'&
- &//TRIM(attributes(i)%name)//'" in file "'//TRIM(file_name)//'". Contact the developers.', FATAL)
- END SELECT
- END DO
- END IF
- !---- write grid type (mosaic or regular)
- CALL get_diag_global_att(gAtt)
- CALL mpp_write_meta(file_unit, 'grid_type', cval=TRIM(gAtt%grid_type))
- CALL mpp_write_meta(file_unit, 'grid_tile', cval=TRIM(gAtt%tile_name))
-
- END SUBROUTINE diag_output_init_use_mpp_io
-
- !> @brief Write the axes meta data to file.
- SUBROUTINE write_axis_meta_data_use_mpp_io(file_unit, axes, time_ops)
- INTEGER, INTENT(in) :: file_unit !< File unit number
- INTEGER, INTENT(in) :: axes(:) !< Array of axis ID's, including the time axis
- LOGICAL, INTENT(in), OPTIONAL :: time_ops !< true if this file contains any min, max, time_rms,
- !! or time average
- TYPE(domain1d) :: Domain
-
- TYPE(domainUG) :: domainU
-
- CHARACTER(len=mxch) :: axis_name, axis_units
- CHARACTER(len=mxchl) :: axis_long_name
- CHARACTER(len=1) :: axis_cart_name
- INTEGER :: axis_direction, axis_edges
- REAL, ALLOCATABLE :: axis_data(:)
- INTEGER, ALLOCATABLE :: axis_extent(:), pelist(:)
- INTEGER :: num_attributes
- TYPE(diag_atttype), DIMENSION(:), ALLOCATABLE :: attributes
- INTEGER :: calendar, id_axis, id_time_axis
- INTEGER :: i, j, index, num, length, edges_index
- INTEGER :: gbegin, gend, gsize, ndivs
- LOGICAL :: time_ops1
- CHARACTER(len=2048) :: err_msg
- type(domainUG),pointer :: io_domain
- integer(I4_KIND) :: io_domain_npes
- integer(I4_KIND),dimension(:),allocatable :: io_pelist
- integer(I4_KIND),dimension(:),allocatable :: unstruct_axis_sizes
- real,dimension(:),allocatable :: unstruct_axis_data
-
- ! Make sure err_msg is initialized
- err_msg = ''
-
- IF ( PRESENT(time_ops) ) THEN
- time_ops1 = time_ops
- ELSE
- time_ops1 = .FALSE.
- END IF
-
- !---- save the current file_unit ----
- IF ( num_axis_in_file == 0 ) current_file_unit = file_unit
-
- !---- dummy checks ----
- num = SIZE(axes(:))
- ! number of axes < 1
- IF ( num < 1 ) CALL error_mesg('write_axis_meta_data', 'number of axes < 1.', FATAL)
+ !> @brief Return the axis index number.
+ !! @return Integer index
+ FUNCTION get_axis_index(num) RESULT ( index )
+ INTEGER, INTENT(in) :: num
- ! writing meta data out-of-order to different files.
- IF ( file_unit /= current_file_unit ) CALL error_mesg('write_axis_meta_data',&
- & 'writing meta data out-of-order to different files.', FATAL)
+ INTEGER :: index
+ INTEGER :: i
- !---- check all axes ----
+ !---- get the array index for this axis type ----
+ !---- set up pointers to axistypes ----
!---- write axis meta data for new axes ----
- DO i = 1, num
- id_axis = axes(i)
- index = get_axis_index ( id_axis )
-
- !---- skip axes already written -----
- IF ( index > 0 ) CYCLE
-
- !---- create new axistype (then point to) -----
- num_axis_in_file = num_axis_in_file + 1
- axis_in_file(num_axis_in_file) = id_axis
- edge_axis_flag(num_axis_in_file) = .FALSE.
- length = get_axis_global_length(id_axis)
- ALLOCATE(axis_data(length))
-
- CALL get_diag_axis(id_axis, axis_name, axis_units, axis_long_name,&
- & axis_cart_name, axis_direction, axis_edges, Domain, DomainU, axis_data,&
- & num_attributes, attributes)
-
- IF ( Domain .NE. null_domain1d ) THEN
- IF ( length > 0 ) THEN
- CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file),&
- & axis_name, axis_units, axis_long_name, axis_cart_name,&
- & axis_direction, Domain, axis_data )
- ELSE
- CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file), axis_name,&
- & axis_units, axis_long_name, axis_cart_name, axis_direction, Domain)
- END IF
- ELSE
- IF ( length > 0 ) THEN
-
- !For an unstructured dimension, only the root rank of the io_domain
- !pelist will perform the wirte, so a gather of the unstructured
- !axis size and axis data is required.
- if (uppercase(trim(axis_cart_name)) .eq. "U") then
- if (DomainU .eq. null_domainUG) then
- call error_mesg("diag_output_mod::write_axis_meta_data", &
- "A non-nul domainUG is required to" &
- //" write unstructured axis metadata.", &
- FATAL)
- endif
- io_domain => null()
- io_domain => mpp_get_UG_io_domain(DomainU)
- io_domain_npes = mpp_get_UG_domain_npes(io_domain)
- allocate(io_pelist(io_domain_npes))
- call mpp_get_UG_domain_pelist(io_domain, &
- io_pelist)
- allocate(unstruct_axis_sizes(io_domain_npes))
- unstruct_axis_sizes = 0
- call mpp_gather((/size(axis_data)/), &
- unstruct_axis_sizes, &
- io_pelist)
- if (mpp_pe() .eq. io_pelist(1)) then
- allocate(unstruct_axis_data(sum(unstruct_axis_sizes)))
- else
- allocate(unstruct_axis_data(1))
- endif
- unstruct_axis_data = 0.0
- call mpp_gather(axis_data, &
- size(axis_data), &
- unstruct_axis_data, &
- unstruct_axis_sizes, &
- io_pelist)
- call mpp_write_meta(file_unit, &
- Axis_types(num_axis_in_file), &
- axis_name, &
- axis_units, &
- axis_long_name, &
- axis_cart_name, &
- axis_direction, &
- data=unstruct_axis_data)
- deallocate(io_pelist)
- deallocate(unstruct_axis_sizes)
- deallocate(unstruct_axis_data)
- io_domain => null()
-
- else
- CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file), axis_name,&
- & axis_units, axis_long_name, axis_cart_name, axis_direction, DATA=axis_data)
- endif
-
- ELSE
- CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file), axis_name,&
- & axis_units, axis_long_name, axis_cart_name, axis_direction)
- END IF
- END IF
-
- ! Write axis attributes
- id_axis = mpp_get_id(Axis_types(num_axis_in_file))
- CALL write_attribute_meta(file_unit, id_axis, num_attributes, attributes, err_msg)
- IF ( LEN_TRIM(err_msg) .GT. 0 ) THEN
- CALL error_mesg('diag_output_mod::write_axis_meta_data', TRIM(err_msg), FATAL)
- END IF
-
- !---- write additional attribute (calendar_type) for time axis ----
- !---- NOTE: calendar attribute is compliant with CF convention
- !---- http://www.cgd.ucar.edu/cms/eaton/netcdf/CF-current.htm#cal
- IF ( axis_cart_name == 'T' ) THEN
- time_axis_flag(num_axis_in_file) = .TRUE.
- id_time_axis = mpp_get_id(Axis_types(num_axis_in_file))
- calendar = get_calendar_type()
- CALL mpp_write_meta(file_unit, id_time_axis, 'calendar_type', cval=TRIM(valid_calendar_types(calendar)))
- CALL mpp_write_meta(file_unit, id_time_axis, 'calendar', cval=TRIM(valid_calendar_types(calendar)))
- IF ( time_ops1 ) THEN
- CALL mpp_write_meta( file_unit, id_time_axis, 'bounds', cval = TRIM(axis_name)//'_bnds')
- END IF
- ELSE
- time_axis_flag(num_axis_in_file) = .FALSE.
+ index = 0
+ DO i = 1, num_axis_in_file
+ IF ( num == axis_in_file(i) ) THEN
+ index = i
+ EXIT
END IF
+ END DO
+ END FUNCTION get_axis_index
- DEALLOCATE(axis_data)
-
- ! Deallocate attributes
- IF ( ALLOCATED(attributes) ) THEN
- DO j=1, num_attributes
- IF ( allocated(attributes(j)%fatt ) ) THEN
- DEALLOCATE(attributes(j)%fatt)
- END IF
- IF ( allocated(attributes(j)%iatt ) ) THEN
- DEALLOCATE(attributes(j)%iatt)
- END IF
- END DO
- DEALLOCATE(attributes)
- END IF
+ !> @brief Return the global attribute type.
+ SUBROUTINE get_diag_global_att(gAtt)
+ TYPE(diag_global_att_type), INTENT(out) :: gAtt
- !------------- write axis containing edge information ---------------
+ gAtt=diag_global_att
+ END SUBROUTINE get_diag_global_att
- ! --- this axis has no edges -----
- IF ( axis_edges <= 0 ) CYCLE
+ !> @brief Set the global attribute type.
+ SUBROUTINE set_diag_global_att(component, gridType, tileName)
+ CHARACTER(len=*),INTENT(in) :: component, gridType, tileName
- ! --- was this axis edge previously defined? ---
- id_axis = axis_edges
- edges_index = get_axis_index(id_axis)
- IF ( edges_index > 0 ) CYCLE
+ ! The following two lines are set to remove compile time warnings
+ ! about 'only used once'.
+ CHARACTER(len=64) :: component_tmp
+ component_tmp = component
+ ! Don't know how to set these for specific component
+ ! Want to be able to say
+ ! if(output_file has component) then
+ diag_global_att%grid_type = gridType
+ diag_global_att%tile_name = tileName
+ ! endif
+ END SUBROUTINE set_diag_global_att
- ! ---- get data for axis edges ----
- length = get_axis_global_length ( id_axis )
- ALLOCATE(axis_data(length))
- CALL get_diag_axis(id_axis, axis_name, axis_units, axis_long_name, axis_cart_name,&
- & axis_direction, axis_edges, Domain, DomainU, axis_data, num_attributes, attributes)
-
- ! ---- write edges attribute to original axis ----
- CALL mpp_write_meta(file_unit, mpp_get_id(Axis_types(num_axis_in_file)),&
- & 'edges', cval=axis_name )
-
- ! ---- add edges index to axis list ----
- ! ---- assume this is not a time axis ----
- num_axis_in_file = num_axis_in_file + 1
- axis_in_file(num_axis_in_file) = id_axis
- edge_axis_flag(num_axis_in_file) = .TRUE.
- time_axis_flag (num_axis_in_file) = .FALSE.
-
- ! ---- write edges axis to file ----
- IF ( Domain .NE. null_domain1d ) THEN
- ! assume domain decomposition is irregular and loop through all prev and next
- ! domain pointers extracting domain extents. Assume all pes are used in
- ! decomposition
- CALL mpp_get_global_domain(Domain, begin=gbegin, END=gend, size=gsize)
- CALL mpp_get_layout(Domain, ndivs)
- IF ( ndivs .EQ. 1 ) THEN
- CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file), axis_name,&
- & axis_units, axis_long_name, axis_cart_name, axis_direction, DATA=axis_data )
- ELSE
- IF ( ALLOCATED(axis_extent) ) DEALLOCATE(axis_extent)
- ALLOCATE(axis_extent(0:ndivs-1))
- CALL mpp_get_compute_domains(Domain,size=axis_extent(0:ndivs-1))
- gend=gend+1
- axis_extent(ndivs-1)= axis_extent(ndivs-1)+1
- IF ( ALLOCATED(pelist) ) DEALLOCATE(pelist)
- ALLOCATE(pelist(0:ndivs-1))
- CALL mpp_get_pelist(Domain,pelist)
- CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file),&
- & axis_name, axis_units, axis_long_name, axis_cart_name,&
- & axis_direction, Domain, DATA=axis_data)
- END IF
- ELSE
- CALL mpp_write_meta(file_unit, Axis_types(num_axis_in_file), axis_name, axis_units,&
- & axis_long_name, axis_cart_name, axis_direction, DATA=axis_data)
- END IF
-
- ! Write edge axis attributes
- id_axis = mpp_get_id(Axis_types(num_axis_in_file))
- CALL write_attribute_meta(file_unit, id_axis, num_attributes, attributes, err_msg)
- IF ( LEN_TRIM(err_msg) .GT. 0 ) THEN
- CALL error_mesg('diag_output_mod::write_axis_meta_data', TRIM(err_msg), FATAL)
- END IF
-
- DEALLOCATE (axis_data)
- ! Deallocate attributes
- IF ( ALLOCATED(attributes) ) THEN
- DO j=1, num_attributes
- IF ( allocated(attributes(j)%fatt ) ) THEN
- DEALLOCATE(attributes(j)%fatt)
- END IF
- IF ( allocated(attributes(j)%iatt ) ) THEN
- DEALLOCATE(attributes(j)%iatt)
- END IF
- END DO
- DEALLOCATE(attributes)
- END IF
- END DO
- END SUBROUTINE write_axis_meta_data_use_mpp_io
-
- !> @brief Write the field meta data to file.
- !!
- !> The meta data for the field is written to the file indicated by file_unit
- FUNCTION write_field_meta_data_use_mpp_io ( file_unit, name, axes, units, long_name, range, pack, mval,&
- & avg_name, time_method, standard_name, interp_method, attributes, num_attributes, &
- & use_UGdomain) result ( Field )
- INTEGER, INTENT(in) :: file_unit !< Output file unit number
- INTEGER, INTENT(in) :: axes(:) !< Array of axis IDs
- CHARACTER(len=*), INTENT(in) :: name !< Field name
- CHARACTER(len=*), INTENT(in) :: units !< Field units
- CHARACTER(len=*), INTENT(in) :: long_name !< Long name of the field
- REAL, OPTIONAL, INTENT(in) :: RANGE(2) !< Valid range (min,max). Range will be ignored if min>max
- REAL, OPTIONAL, INTENT(in) :: mval !< Missing value, must be within valid range
- INTEGER, OPTIONAL, INTENT(in) :: pack !< packing flag. only valid when range specified. Valid
- !! values:
- !! - 1 = 64bit
- !! - 2 = 32bit
- !! - 4 = 16bit
- !! - 8 = 8bit
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: avg_name !< Name of variable containing time averaging info
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: time_method !< Name of transformation applied to the
- !! time-varying data i.e. avg, min, max
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard name of field
- CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method
- TYPE(diag_atttype), DIMENSION(:), ALLOCATABLE, OPTIONAL, INTENT(in) :: attributes
- INTEGER, OPTIONAL, INTENT(in) :: num_attributes
- LOGICAL, OPTIONAL, INTENT(in) :: use_UGdomain
-
- CHARACTER(len=256) :: standard_name2
- CHARACTER(len=1280) :: att_str
- TYPE(diag_fieldtype) :: Field
- LOGICAL :: coord_present
- CHARACTER(len=40) :: aux_axes(SIZE(axes))
- CHARACTER(len=160) :: coord_att
- CHARACTER(len=1024) :: err_msg
-
- REAL :: scale, add
- INTEGER :: i, indexx, num, ipack, np, att_len
- LOGICAL :: use_range
- INTEGER :: axis_indices(SIZE(axes))
- logical :: use_UGdomain_local
-
- !---- Initialize err_msg to bank ----
- err_msg = ''
-
- !---- dummy checks ----
- coord_present = .FALSE.
- IF( PRESENT(standard_name) ) THEN
- standard_name2 = standard_name
- ELSE
- standard_name2 = 'none'
- END IF
-
- use_UGdomain_local = .false.
- if(present(use_UGdomain)) use_UGdomain_local = use_UGdomain
-
- num = SIZE(axes(:))
- ! number of axes < 1
- IF ( num < 1 ) CALL error_mesg ( 'write_meta_data', 'number of axes < 1', FATAL)
- ! writing meta data out-of-order to different files
- IF ( file_unit /= current_file_unit ) CALL error_mesg ( 'write_meta_data', &
- & 'writing meta data out-of-order to different files', FATAL)
-
-
- !---- check all axes for this field ----
- !---- set up indexing to axistypes ----
- DO i = 1, num
- indexx = get_axis_index(axes(i))
- !---- point to existing axistype -----
- IF ( indexx > 0 ) THEN
- axis_indices(i) = indexx
- ELSE
- ! axis data not written for field
- CALL error_mesg ('write_field_meta_data',&
- & 'axis data not written for field '//TRIM(name), FATAL)
- END IF
- END DO
-
- ! Create coordinate attribute
- IF ( num >= 2 .OR. (num==1 .and. use_UGdomain_local) ) THEN
- coord_att = ' '
- DO i = 1, num
- aux_axes(i) = get_axis_aux(axes(i))
- IF( TRIM(aux_axes(i)) /= 'none' ) THEN
- IF(LEN_TRIM(coord_att) == 0) THEN
- coord_att = TRIM(aux_axes(i))
- ELSE
- coord_att = TRIM(coord_att)// ' '//TRIM(aux_axes(i))
- ENDIF
- coord_present = .TRUE.
- END IF
- END DO
- END IF
-
- !--------------------- write field meta data ---------------------------
-
- !---- select packing? ----
- !(packing option only valid with range option)
- IF ( PRESENT(pack) ) THEN
- ipack = pack
- ELSE
- ipack = 2
- END IF
-
- !---- check range ----
- use_range = .FALSE.
- add = 0.0
- scale = 1.0
- IF ( PRESENT(range) ) THEN
- IF ( RANGE(2) > RANGE(1) ) THEN
- use_range = .TRUE.
- !---- set packing parameters ----
- IF ( ipack > 2 ) THEN
- np = ipack/4
- add = 0.5*(RANGE(1)+RANGE(2))
- scale = (RANGE(2)-RANGE(1)) / real(max_range(2,np)-max_range(1,np))
- END IF
- END IF
- END IF
-
- !---- select packing? ----
- IF ( PRESENT(mval) ) THEN
- Field%miss = mval
- Field%miss_present = .TRUE.
- IF ( ipack > 2 ) THEN
- np = ipack/4
- Field%miss_pack = REAL(missval(np))*scale+add
- Field%miss_pack_present = .TRUE.
- ELSE
- Field%miss_pack = mval
- Field%miss_pack_present = .FALSE.
- END IF
- ELSE
- Field%miss_present = .FALSE.
- Field%miss_pack_present = .FALSE.
- END IF
-
- !------ write meta data and return fieldtype -------
- IF ( use_range ) THEN
- IF ( Field%miss_present ) THEN
- CALL mpp_write_meta(file_unit, Field%Field,&
- & Axis_types(axis_indices(1:num)),&
- & name, units, long_name,&
- & RANGE(1), RANGE(2),&
- & missing=Field%miss_pack,&
- & fill=Field%miss_pack,&
- & scale=scale, add=add, pack=ipack,&
- & time_method=time_method)
- ELSE
- CALL mpp_write_meta(file_unit, Field%Field,&
- & Axis_types(axis_indices(1:num)),&
- & name, units, long_name,&
- & RANGE(1), RANGE(2),&
- & missing=CMOR_MISSING_VALUE,&
- & fill=CMOR_MISSING_VALUE,&
- & scale=scale, add=add, pack=ipack,&
- & time_method=time_method)
- END IF
- ELSE
- IF ( Field%miss_present ) THEN
- CALL mpp_write_meta(file_unit, Field%Field,&
- & Axis_types(axis_indices(1:num)),&
- & name, units, long_name,&
- & missing=Field%miss_pack,&
- & fill=Field%miss_pack,&
- & pack=ipack, time_method=time_method)
- ELSE
- CALL mpp_write_meta(file_unit, Field%Field,&
- & Axis_types(axis_indices(1:num)),&
- & name, units, long_name,&
- & missing=CMOR_MISSING_VALUE,&
- & fill=CMOR_MISSING_VALUE,&
- & pack=ipack, time_method=time_method)
- END IF
- END IF
-
- !---- write user defined attributes -----
- IF ( PRESENT(num_attributes) ) THEN
- IF ( PRESENT(attributes) ) THEN
- IF ( num_attributes .GT. 0 .AND. allocated(attributes) ) THEN
- CALL write_attribute_meta(file_unit, mpp_get_id(Field%Field), num_attributes, attributes, time_method, err_msg)
- IF ( LEN_TRIM(err_msg) .GT. 0 ) THEN
- CALL error_mesg('diag_output_mod::write_field_meta_data',&
- & TRIM(err_msg)//" Contact the developers.", FATAL)
- END IF
- ELSE
- ! Catch some bad cases
- IF ( num_attributes .GT. 0 .AND. .NOT.allocated(attributes) ) THEN
- CALL error_mesg('diag_output_mod::write_field_meta_data',&
- & 'num_attributes > 0 but attributes is not allocated for attribute '&
- &//TRIM(attributes(i)%name)//' for field '//TRIM(name)//'. Contact the developers.', FATAL)
- ELSE IF ( num_attributes .EQ. 0 .AND. allocated(attributes) ) THEN
- CALL error_mesg('diag_output_mod::write_field_meta_data',&
- & 'num_attributes == 0 but attributes is allocated for attribute '&
- &//TRIM(attributes(i)%name)//' for field '//TRIM(name)//'. Contact the developers.', FATAL)
- END IF
- END IF
- ELSE
- ! More edge error cases
- CALL error_mesg('diag_output_mod::write_field_meta_data',&
- & 'num_attributes present but attributes missing for attribute '&
- &//TRIM(attributes(i)%name)//' for field '//TRIM(name)//'. Contact the developers.', FATAL)
- END IF
- ELSE IF ( PRESENT(attributes) ) THEN
- CALL error_mesg('diag_output_mod::write_field_meta_data',&
- & 'attributes present but num_attributes missing for attribute '&
- &//TRIM(attributes(i)%name)//' for field '//TRIM(name)//'. Contact the developers.', FATAL)
- END IF
-
-
- !---- write additional attribute for time averaging -----
- IF ( PRESENT(avg_name) ) THEN
- IF ( avg_name(1:1) /= ' ' ) THEN
- CALL mpp_write_meta(file_unit, mpp_get_id(Field%Field),&
- & 'time_avg_info',&
- & cval=trim(avg_name)//'_T1,'//trim(avg_name)//'_T2,'//trim(avg_name)//'_DT')
- END IF
- END IF
-
- ! write coordinates attribute for CF compliance
- IF ( coord_present ) &
- CALL mpp_write_meta(file_unit, mpp_get_id(Field%Field),&
- & 'coordinates', cval=TRIM(coord_att))
- IF ( TRIM(standard_name2) /= 'none' ) CALL mpp_write_meta(file_unit, mpp_get_id(Field%Field),&
- & 'standard_name', cval=TRIM(standard_name2))
-
- !---- write attribute for interp_method ----
- IF( PRESENT(interp_method) ) THEN
- CALL mpp_write_meta ( file_unit, mpp_get_id(Field%Field),&
- & 'interp_method', cval=TRIM(interp_method))
- END IF
-
- !---- get axis domain ----
- Field%Domain = get_domain2d ( axes )
- Field%tile_count = get_tile_count ( axes )
- Field%DomainU = get_domainUG ( axes(1) )
-
- END FUNCTION write_field_meta_data_use_mpp_io
-
- !> \brief Write out attribute meta data to file
- !!
- !> Write out the attribute meta data to file, for field and axes
- SUBROUTINE write_attribute_meta_use_mpp_io(file_unit, id, num_attributes, attributes, time_method, err_msg)
- INTEGER, INTENT(in) :: file_unit !< File unit number
- INTEGER, INTENT(in) :: id !< ID of field, file, axis to get attribute meta data
- INTEGER, INTENT(in) :: num_attributes !< Number of attributes to write
- TYPE(diag_atttype), DIMENSION(:), INTENT(in) :: attributes !< Array of attributes
- CHARACTER(len=*), INTENT(in), OPTIONAL :: time_method !< To include in cell_methods attribute if present
- CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< Return error message
-
- INTEGER :: i, att_len
- CHARACTER(len=1280) :: att_str
-
- ! Clear err_msg if present
- IF ( PRESENT(err_msg) ) err_msg = ''
-
- DO i = 1, num_attributes
- SELECT CASE (attributes(i)%type)
- CASE (NF90_INT)
- IF ( .NOT.allocated(attributes(i)%iatt) ) THEN
- IF ( fms_error_handler('diag_output_mod::write_attribute_meta',&
- & 'Integer attribute type indicated, but array not allocated for attribute '&
- &//TRIM(attributes(i)%name)//'.', err_msg) ) THEN
- RETURN
- END IF
- END IF
- CALL mpp_write_meta(file_unit, id, TRIM(attributes(i)%name),&
- & ival=attributes(i)%iatt)
- CASE (NF90_FLOAT)
- IF ( .NOT.allocated(attributes(i)%fatt) ) THEN
- IF ( fms_error_handler('diag_output_mod::write_attribute_meta',&
- & 'Real attribute type indicated, but array not allocated for attribute '&
- &//TRIM(attributes(i)%name)//'.', err_msg) ) THEN
- RETURN
- END IF
- END IF
- CALL mpp_write_meta(file_unit, id, TRIM(attributes(i)%name),&
- & rval=attributes(i)%fatt)
- CASE (NF90_CHAR)
- att_str = attributes(i)%catt
- att_len = attributes(i)%len
- IF ( TRIM(attributes(i)%name).EQ.'cell_methods' .AND. PRESENT(time_method) ) THEN
- ! Append ",time: time_method" if time_method present
- att_str = attributes(i)%catt(1:attributes(i)%len)//' time: '//time_method
- att_len = LEN_TRIM(att_str)
- END IF
- CALL mpp_write_meta(file_unit, id, TRIM(attributes(i)%name),&
- & cval=att_str(1:att_len))
- CASE default
- IF ( fms_error_handler('diag_output_mod::write_attribute_meta', 'Invalid type for attribute '&
- &//TRIM(attributes(i)%name)//'.', err_msg) ) THEN
- RETURN
- END IF
- END SELECT
- END DO
- END SUBROUTINE write_attribute_meta_use_mpp_io
-
- !> @brief Writes axis data to file
- !!
- !> This subroutine is to be called once per file
- !! after all write_meta_data calls, and before the first
- !! diag_field_out call.
- SUBROUTINE done_meta_data_use_mpp_io(file_unit)
- INTEGER, INTENT(in) :: file_unit
-
- INTEGER :: i
-
- !---- write data for all non-time axes ----
- DO i = 1, num_axis_in_file
- IF ( time_axis_flag(i) ) CYCLE
- CALL mpp_write(file_unit, Axis_types(i))
- END DO
-
- num_axis_in_file = 0
- END SUBROUTINE done_meta_data_use_mpp_io
-
- !> @brief Writes field data to an output file.
- SUBROUTINE diag_field_out(file_unit, Field, DATA, time)
- INTEGER, INTENT(in) :: file_unit !< Output file unit number
- TYPE(diag_fieldtype), INTENT(inout) :: Field
- REAL , INTENT(inout) :: data(:,:,:,:)
- REAL, OPTIONAL, INTENT(in) :: time
-
- !---- replace original missing value with (un)packed missing value ----
- !print *, 'PE,name,miss_pack_present=',mpp_pe(), &
- ! trim(Field%Field%name),Field%miss_pack_present
- IF ( Field%miss_pack_present ) THEN
- WHERE ( DATA == Field%miss ) DATA = Field%miss_pack
- END IF
-
- !---- output data ----
- IF ( Field%Domain .NE. null_domain2d ) THEN
- IF( Field%miss_present ) THEN
- CALL mpp_write(file_unit, Field%Field, Field%Domain, DATA, time, &
- tile_count=Field%tile_count, default_data=Field%miss_pack)
- ELSE
- CALL mpp_write(file_unit, Field%Field, Field%Domain, DATA, time, &
- tile_count=Field%tile_count, default_data=CMOR_MISSING_VALUE)
- END IF
- ELSEIF ( Field%DomainU .NE. null_domainUG ) THEN
- IF( Field%miss_present ) THEN
- CALL mpp_io_unstructured_write(file_unit, Field%Field, Field%DomainU, DATA, tstamp=time, &
- default_data=Field%miss_pack)
- ELSE
- CALL mpp_io_unstructured_write(file_unit, Field%Field, Field%DomainU, DATA, tstamp=time, &
- default_data=CMOR_MISSING_VALUE)
- END IF
-
- ELSE
- CALL mpp_write(file_unit, Field%Field, DATA, time)
- END IF
- END SUBROUTINE diag_field_out
-
- !> Flush buffer and insure data is not lost.
- !!
- !> This subroutine can be called periodically to flush the buffer, and
- !! insure that data is not lost if the execution fails.
- SUBROUTINE diag_flush(file_unit)
- INTEGER, INTENT(in) :: file_unit !< Output file unit number to flush
-
- CALL mpp_flush (file_unit)
- END SUBROUTINE diag_flush
-
-!> End of use_mpp_io = true routines/functions
-!! everything else is shared by both
-
- !> @brief Return the axis index number.
- !! @return Integer index
- FUNCTION get_axis_index(num) RESULT ( index )
- INTEGER, INTENT(in) :: num
-
- INTEGER :: index
- INTEGER :: i
-
- !---- get the array index for this axis type ----
- !---- set up pointers to axistypes ----
- !---- write axis meta data for new axes ----
- index = 0
- DO i = 1, num_axis_in_file
- IF ( num == axis_in_file(i) ) THEN
- index = i
- EXIT
- END IF
- END DO
- END FUNCTION get_axis_index
-
- !> @brief Return the global attribute type.
- SUBROUTINE get_diag_global_att(gAtt)
- TYPE(diag_global_att_type), INTENT(out) :: gAtt
-
- gAtt=diag_global_att
- END SUBROUTINE get_diag_global_att
-
- !> @brief Set the global attribute type.
- SUBROUTINE set_diag_global_att(component, gridType, tileName)
- CHARACTER(len=*),INTENT(in) :: component, gridType, tileName
-
- ! The following two lines are set to remove compile time warnings
- ! about 'only used once'.
- CHARACTER(len=64) :: component_tmp
- component_tmp = component
- ! Don't know how to set these for specific component
- ! Want to be able to say
- ! if(output_file has component) then
- diag_global_att%grid_type = gridType
- diag_global_att%tile_name = tileName
- ! endif
- END SUBROUTINE set_diag_global_att
+ !> @brief Flushes the file into disk
+ subroutine diag_flush(file_num, fileobjU, fileobj, fileobjND, fnum_for_domain)
+ integer, intent(in) :: file_num !< Index in the fileobj* types array
+ type(FmsNetcdfUnstructuredDomainFile_t),intent(inout) :: fileobjU(:) !< Array of non domain decomposed fileobj
+ type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj(:) !< Array of domain decomposed fileobj
+ type(FmsNetcdfFile_t), intent(inout) :: fileobjND(:) !< Array of unstructured domain fileobj
+ character(len=2), intent(in) :: fnum_for_domain !< String indicating the type of domain
+ !! "2d" domain decomposed
+ !! "ug" unstructured domain decomposed
+ !! "nd" no domain
+ if (fnum_for_domain == "2d" ) then
+ call flush_file (fileobj (file_num))
+ elseif (fnum_for_domain == "nd") then
+ call flush_file (fileobjND (file_num))
+ elseif (fnum_for_domain == "ug") then
+ call flush_file (fileobjU(file_num))
+ else
+ call error_mesg("diag_field_write","No file object is associated with this file number",fatal)
+ endif
+ end subroutine diag_flush
END MODULE diag_output_mod
!> @}
! close documentation grouping
diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90
index e9fa2cd69f..07ad463c03 100644
--- a/diag_manager/diag_util.F90
+++ b/diag_manager/diag_util.F90
@@ -58,10 +58,8 @@ MODULE diag_util_mod
& get_axes_shift, get_diag_axis_name, get_diag_axis_domain_name, get_domainUG, &
& get_axis_reqfld, axis_is_compressed, get_compressed_axes_ids
USE diag_output_mod, ONLY: diag_output_init, write_axis_meta_data,&
- & write_field_meta_data, done_meta_data
- USE diag_output_mod, ONLY: done_meta_data_use_mpp_io ! @brief Open file for output, and write the meta data.
- SUBROUTINE opening_file(file, time, use_mpp_io, filename_time)
+ SUBROUTINE opening_file(file, time, filename_time)
! WARNING: Assumes that all data structures are fully initialized
INTEGER, INTENT(in) :: file !< File ID.
TYPE(time_type), INTENT(in) :: time !< Time for the file time stamp
- logical :: use_mpp_io !< controls which IO is used for output
TYPE(time_type), INTENT(in), optional :: filename_time !< Time used in setting the filename when writting periodic files
TYPE(time_type) :: fname_time !< Time used in setting the filename when writting periodic files
@@ -1597,11 +1594,7 @@ SUBROUTINE opening_file(file, time, use_mpp_io, filename_time)
! Add ensemble ID to filename
fname=base_name
- if (use_mpp_io) then
- call mpp_io_get_instance_filename(fname, base_name)
- else
- call fms2_io_get_instance_filename(fname, base_name)
- endif
+ call fms2_io_get_instance_filename(fname, base_name)
! Set the filename
filename = TRIM(base_name)//TRIM(suffix)
@@ -1685,25 +1678,14 @@ SUBROUTINE opening_file(file, time, use_mpp_io, filename_time)
CALL get_mosaic_tile_file_ug(fname,filename,domainU)
ENDIF
IF ( allocated(files(file)%attributes) ) THEN
- if (.not.use_mpp_io) then
CALL diag_output_init(filename, files(file)%format, global_descriptor,&
& files(file)%file_unit, all_scalar_or_1d, domain2, domainU,&
& fileobj(file),fileobjU(file), fileobjND(file), fnum_for_domain(file),&
& attributes=files(file)%attributes(1:files(file)%num_attributes))
- else
- CALL diag_output_init(filename, files(file)%format, global_descriptor,&
- & files(file)%file_unit, all_scalar_or_1d, domain2, domainU,&
- & attributes=files(file)%attributes(1:files(file)%num_attributes))
- endif
ELSE
- if (.not.use_mpp_io) then
CALL diag_output_init(filename, files(file)%format, global_descriptor,&
& files(file)%file_unit, all_scalar_or_1d, domain2,domainU, &
& fileobj(file),fileobjU(file),fileobjND(file),fnum_for_domain(file))
- else
- CALL diag_output_init(filename, files(file)%format, global_descriptor,&
- & files(file)%file_unit, all_scalar_or_1d, domain2,domainU)
- endif
END IF
!> update fnum_for_domain with the correct domain
files(file)%bytes_written = 0
@@ -1773,7 +1755,6 @@ SUBROUTINE opening_file(file, time, use_mpp_io, filename_time)
END IF
axes(num_axes + 1) = files(file)%time_axis_id
- if (.not. use_mpp_io) then
!> Allocate the is_time_axis_registered field and set it to false for the first trip
if (.not. allocated(files(file)%is_time_axis_registered)) then
allocate(files(file)%is_time_axis_registered)
@@ -1820,22 +1801,6 @@ SUBROUTINE opening_file(file, time, use_mpp_io, filename_time)
DEALLOCATE(axesc)
ENDIF
ENDDO
- else !< use_mpp_io
- CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 1), time_ops)
- IF ( time_ops ) THEN
- axes(num_axes + 2) = files(file)%time_bounds_id
- CALL write_axis_meta_data(files(file)%file_unit, axes(1:num_axes + 2))
- END IF
- ! write metadata for axes used in compression-by-gathering, e.g. for unstructured
- ! grid
- DO k = 1, num_axes
- IF (axis_is_compressed(axes(k))) THEN
- CALL get_compressed_axes_ids(axes(k), axesc) ! returns allocatable array
- CALL write_axis_meta_data(files(file)%file_unit, axesc)
- DEALLOCATE(axesc)
- ENDIF
- ENDDO
- endif !< use_mpp_io
END DO
! Looking for the first NON-static field in a file
@@ -1907,7 +1872,6 @@ SUBROUTINE opening_file(file, time, use_mpp_io, filename_time)
ELSE
avg = " "
END IF
- if (.not.use_mpp_io) then
!> Use the correct file object
if (fnum_for_domain(file) == "2d") then
fileob => fileobj (file)
@@ -1979,66 +1943,7 @@ SUBROUTINE opening_file(file, time, use_mpp_io, filename_time)
END IF
END IF
- else !< use_mpp_io
- IF ( input_fields(input_field_num)%missing_value_present ) THEN
- IF ( LEN_TRIM(input_fields(input_field_num)%interp_method) > 0 ) THEN
- output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
- & output_fields(field_num)%output_name, axes(1:num_axes),&
- & input_fields(input_field_num)%units,&
- & input_fields(input_field_num)%long_name,&
- & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
- & input_fields(input_field_num)%missing_value, avg_name = avg,&
- & time_method=output_fields(field_num)%time_method,&
- & standard_name = input_fields(input_field_num)%standard_name,&
- & interp_method = input_fields(input_field_num)%interp_method,&
- & attributes=output_fields(field_num)%attributes,&
- & num_attributes=output_fields(field_num)%num_attributes,&
- & use_UGdomain=files(file)%use_domainUG)
- ELSE
- output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
- & output_fields(field_num)%output_name, axes(1:num_axes),&
- & input_fields(input_field_num)%units,&
- & input_fields(input_field_num)%long_name,&
- & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
- & input_fields(input_field_num)%missing_value, avg_name = avg,&
- & time_method=output_fields(field_num)%time_method,&
- & standard_name = input_fields(input_field_num)%standard_name,&
- & attributes=output_fields(field_num)%attributes,&
- & num_attributes=output_fields(field_num)%num_attributes,&
- & use_UGdomain=files(file)%use_domainUG)
- END IF
- ! NEED TO TAKE CARE OF TIME AVERAGING INFO TOO BOTH CASES
- ELSE
- IF ( LEN_TRIM(input_fields(input_field_num)%interp_method) > 0 ) THEN
- output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
- & output_fields(field_num)%output_name, axes(1:num_axes),&
- & input_fields(input_field_num)%units,&
- & input_fields(input_field_num)%long_name,&
- & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
- & avg_name = avg,&
- & time_method=output_fields(field_num)%time_method,&
- & standard_name = input_fields(input_field_num)%standard_name,&
- & interp_method = input_fields(input_field_num)%interp_method,&
- & attributes=output_fields(field_num)%attributes,&
- & num_attributes=output_fields(field_num)%num_attributes,&
- & use_UGdomain=files(file)%use_domainUG)
- ELSE
- output_fields(field_num)%f_type = write_field_meta_data(files(file)%file_unit,&
- & output_fields(field_num)%output_name, axes(1:num_axes),&
- & input_fields(input_field_num)%units,&
- & input_fields(input_field_num)%long_name,&
- & input_fields(input_field_num)%range, output_fields(field_num)%pack,&
- & avg_name = avg,&
- & time_method=output_fields(field_num)%time_method,&
- & standard_name = input_fields(input_field_num)%standard_name,&
- & attributes=output_fields(field_num)%attributes,&
- & num_attributes=output_fields(field_num)%num_attributes,&
- & use_UGdomain=files(file)%use_domainUG)
- END IF
- END IF
- endif !
@@ -2138,10 +2004,8 @@ SUBROUTINE opening_file(file, time, use_mpp_io, filename_time)
&'one axis has required fields ('//trim(req_fields)//') but the '// &
&'corresponding fields are NOT found in file '//TRIM(files(file)%name), FATAL)
END IF
- if (.not. use_mpp_io) then
! Clean up pointer
if (associated(fileob)) nullify(fileob)
- endif ! use_mpp_io
END SUBROUTINE opening_file
!> @brief This function determines a string based on current time.
@@ -2334,27 +2198,19 @@ REAL FUNCTION get_date_dif(t2, t1, units)
END FUNCTION get_date_dif
!> @brief Write data out to file, and if necessary flush the buffers.
- SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, use_mpp_io_arg, filename_time)
+ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, filename_time)
INTEGER, INTENT(in) :: file !< File ID.
INTEGER, INTENT(in) :: field !< Field ID.
REAL, DIMENSION(:,:,:,:), INTENT(inout) :: dat !< Data to write out.
TYPE(time_type), INTENT(in) :: time !< Current model time.
LOGICAL, OPTIONAL, INTENT(in):: final_call_in !< .TRUE. if this is the last write for file.
LOGICAL, OPTIONAL, INTENT(in):: static_write_in !< .TRUE. if static fields are to be written to file.
- logical,optional,intent(in) :: use_mpp_io_arg !< Switch for which IO to use for outputting data
type(time_type), intent(in), optional :: filename_time !< Time used in setting the filename when writting periodic files
LOGICAL :: final_call, do_write, static_write
INTEGER :: i, num
REAL :: dif, time_data(2, 1, 1, 1), dt_time(1, 1, 1, 1), start_dif, end_dif
- LOGICAL :: use_mpp_io
- if (present(use_mpp_io_arg)) then
- use_mpp_io = use_mpp_io_arg
- else
- call error_mesg("diag_util_mod::diag_data_out",&
- "diag_data_out must be called with the argument use_mpp_io_arg",FATAL)
- endif
do_write = .TRUE.
final_call = .FALSE.
IF ( PRESENT(final_call_in) ) final_call = final_call_in
@@ -2365,9 +2221,8 @@ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in,
! get file_unit, open new file and close curent file if necessary
IF ( .NOT.static_write .OR. files(file)%file_unit < 0 ) &
- CALL check_and_open(file, time, do_write, use_mpp_io, filename_time=filename_time)
+ CALL check_and_open(file, time, do_write, filename_time=filename_time)
IF ( .NOT.do_write ) RETURN ! no need to write data
- if( .not. use_mpp_io) then
!> Set up the time index and write the correct time value to the time array
if (dif > files(file)%rtime_current) then
files(file)%time_index = files(file)%time_index + 1
@@ -2436,44 +2291,6 @@ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in,
END IF
END IF
END DO
- else !< use_mpp_io
- CALL diag_field_out(files(file)%file_unit, output_fields(field)%f_type, dat, dif)
- ! record number of bytes written to this file
- files(file)%bytes_written = files(file)%bytes_written +&
- & (SIZE(dat,1)*SIZE(dat,2)*SIZE(dat,3))*(8/output_fields(field)%pack)
- IF ( .NOT.output_fields(field)%written_once ) output_fields(field)%written_once = .TRUE.
- ! *** inserted this line because start_dif < 0 for static fields ***
- IF ( .NOT.output_fields(field)%static ) THEN
- start_dif = get_date_dif(output_fields(field)%last_output, base_time,files(file)%time_units)
- IF ( .NOT.mix_snapshot_average_fields ) THEN
- end_dif = get_date_dif(output_fields(field)%next_output, base_time, files(file)%time_units)
- ELSE
- end_dif = dif
- END IF
- END IF
-
- ! Need to write average axes out;
- DO i = 1, files(file)%num_fields
- num = files(file)%fields(i)
- IF ( output_fields(num)%time_ops .AND. &
- input_fields(output_fields(num)%input_field)%register) THEN
- IF ( num == field ) THEN
- ! Output the axes if this is first time-averaged field
- time_data(1, 1, 1, 1) = start_dif
- CALL diag_field_out(files(file)%file_unit, files(file)%f_avg_start, time_data(1:1,:,:,:), dif)
- time_data(2, 1, 1, 1) = end_dif
- CALL diag_field_out(files(file)%file_unit, files(file)%f_avg_end, time_data(2:2,:,:,:), dif)
- ! Compute the length of the average
- dt_time(1, 1, 1, 1) = end_dif - start_dif
- CALL diag_field_out(files(file)%file_unit, files(file)%f_avg_nitems, dt_time(1:1,:,:,:), dif)
-
- ! Include boundary variable for CF compliance
- CALL diag_field_out(files(file)%file_unit, files(file)%f_bounds, time_data(1:2,:,:,:), dif)
- EXIT
- END IF
- END IF
- END DO
- endif !< use_mpp_io
! If write time is greater (equal for the last call) than last_flush for this file, flush it
IF ( final_call ) THEN
@@ -2482,6 +2299,7 @@ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in,
END IF
ELSE
IF ( time > files(file)%last_flush .AND. (flush_nc_files.OR.debug_diag_manager) ) THEN
+ call diag_flush(file, fileobjU, fileobj, fileobjND, fnum_for_domain(file))
files(file)%last_flush = time
END IF
END IF
@@ -2491,25 +2309,24 @@ END SUBROUTINE diag_data_out
!! @details Checks if it is time to open a new file. If yes, it first closes the
!! current file, opens a new file and returns file_unit
!! previous diag_manager_end is replaced by closing_file and output_setup by opening_file.
- SUBROUTINE check_and_open(file, time, do_write, use_mpp_io, filename_time)
+ SUBROUTINE check_and_open(file, time, do_write, filename_time)
INTEGER, INTENT(in) :: file !.TRUE. if file is expecting more data to write,
!! .FALSE. otherwise.
- LOGICAL, INTENT(in) :: use_mpp_io !< true=mpp_io, false=fms2_io
TYPE(time_type), INTENT(in), optional :: filename_time !< Time used in setting the filename when writting periodic files
IF ( time >= files(file)%start_time ) THEN
IF ( files(file)%file_unit < 0 ) THEN ! need to open a new file
- CALL opening_file(file, time, use_mpp_io, filename_time=filename_time)
+ CALL opening_file(file, time, filename_time=filename_time)
do_write = .TRUE.
ELSE
do_write = .TRUE.
IF ( time > files(file)%close_time .AND. time < files(file)%next_open ) THEN
do_write = .FALSE. ! file still open but receives NO MORE data
ELSE IF ( time > files(file)%next_open ) THEN ! need to close current file and open a new one
- CALL write_static(file, use_mpp_io) ! write all static fields and close this file
- CALL opening_file(file, time, use_mpp_io, filename_time=filename_time)
+ CALL write_static(file) ! write all static fields and close this file
+ CALL opening_file(file, time, filename_time=filename_time)
files(file)%time_index = 0 !< Reset the number of times in the files back to 0
files(file)%start_time = files(file)%next_open
files(file)%close_time =&
@@ -2533,10 +2350,8 @@ SUBROUTINE check_and_open(file, time, do_write, use_mpp_io, filename_time)
END SUBROUTINE check_and_open
!> @brief Output all static fields in this file
- SUBROUTINE write_static(file, use_mpp_io)
+ SUBROUTINE write_static(file)
INTEGER, INTENT(in) :: file !< File ID.
- logical :: use_mpp_io !< Switch to select which IO is used to output history files
-
INTEGER :: j, i, input_num
DO j = 1, files(file)%num_fields
@@ -2547,9 +2362,8 @@ SUBROUTINE write_static(file, use_mpp_io)
IF ( output_fields(i)%local_output .AND. .NOT. output_fields(i)%need_compute) CYCLE
! only output static fields here
IF ( .NOT.output_fields(i)%static ) CYCLE
- CALL diag_data_out(file, i, output_fields(i)%buffer, files(file)%last_flush, .TRUE., .TRUE., use_mpp_io_arg=use_mpp_io)
+ CALL diag_data_out(file, i, output_fields(i)%buffer, files(file)%last_flush, .TRUE., .TRUE.)
END DO
- if (.not. use_mpp_io) then
!! New FMS_IO close
! File is stil open. This is to protect when the diag_table has no Fields
! going to this file, and it was never opened (b/c diag_data_out was not
@@ -2564,16 +2378,6 @@ SUBROUTINE write_static(file, use_mpp_io)
if (check_if_open(fileobjU(file))) call close_file (fileobjU(file))
endif
files(file)%file_unit = -1
- else !< use_mpp_io
- ! Close up this file
- IF ( files(file)%file_unit.NE.-1 ) then
- ! File is stil open. This is to protect when the diag_table has no Fields
- ! going to this file, and it was never opened (b/c diag_data_out was not
- ! called)
- CALL mpp_close(files(file)%file_unit)
- files(file)%file_unit = -1
- END IF
- endif !< use_mpp_io
END SUBROUTINE write_static
!> @brief Checks to see if output_name and output_file are unique in output_fields.
diff --git a/docs/doxygenGuide.md b/docs/doxygenGuide.md
index 89ffb6cbee..76062fee07 100644
--- a/docs/doxygenGuide.md
+++ b/docs/doxygenGuide.md
@@ -7,7 +7,7 @@ Best practices for documenting FMS code with Doxygen.
For .F90 files:
- `!>` Starts or continues a multi-line doxygen comment
- `!!` Continues a comment
-- `!<` Starts a comment(usually used after variables/parameters)
+- `!<` Starts a same-line comment (used for documenting variable/parameter declarations)
- `@commandname` to use a given doxygen command
For .c files, javadoc-style comments are used (`///` or multi-line with `/**` and `*/`), and the command specifier is instead `\commandname`.
diff --git a/exchange/xgrid.F90 b/exchange/xgrid.F90
index ce22463b8f..75a903552d 100644
--- a/exchange/xgrid.F90
+++ b/exchange/xgrid.F90
@@ -100,7 +100,7 @@ module xgrid_mod
use fms_mod, only: check_nml_error, &
error_mesg, FATAL, NOTE, stdlog, &
- WARNING, & !!! use_mpp_io removal
+ WARNING, &
write_version_number, lowercase, string
use mpp_mod, only: mpp_npes, mpp_pe, mpp_root_pe, mpp_send, mpp_recv, &
mpp_sync_self, stdout, mpp_max, EVENT_RECV, &
@@ -136,21 +136,6 @@ module xgrid_mod
use fms2_io_mod, only: FmsNetcdfDomainFile_t, read_data, get_dimension_size
use fms2_io_mod, only: get_variable_units, dimension_exists
-use mpp_io_mod, only: mpp_open, MPP_MULTI, MPP_SINGLE, MPP_OVERWR !< use_mpp_io
-use fms_mod, only: read_data, file_exist, field_exist, field_size, & ! close_file !< use_mpp_io
-use fms_io_mod, only: get_var_att_value, & !< use_mpp_io
- get_mosaic_tile_grid_use_mpp_io => get_mosaic_tile_grid !< use_mpp_io
-!< Needed for use_mpp_io
-use mosaic_mod, only: get_mosaic_xgrid_use_mpp_io => get_mosaic_xgrid,&
- get_mosaic_xgrid_size_use_mpp_io => get_mosaic_xgrid_size, &
- get_mosaic_ntiles_use_mpp_io => get_mosaic_ntiles, &
- get_mosaic_ncontacts_use_mpp_io => get_mosaic_ncontacts, &
- get_mosaic_contact_use_mpp_io => get_mosaic_contact, &
- get_mosaic_grid_sizes_use_mpp_io => get_mosaic_grid_sizes
-!< \needed for use_mpp_io
-
-
implicit none
private
@@ -517,18 +502,13 @@ module xgrid_mod
public FIRST_ORDER, SECOND_ORDER, stock_move_ug
!> @ingroup xgrid_mod
- interface get_area_elements !< for use with use_mpp_io
+ interface get_area_elements
module procedure get_area_elements_fms2_io
- module procedure get_area_elements_use_mpp_io
end interface
!> @ingroup xgrid_mod
interface get_nest_contact
module procedure get_nest_contact_fms2_io
- module procedure get_nest_contact_use_mpp_io
end interface
-!< Set up private subroutines for use_mpp_io
-!! these routines are called if use_mpp_io is set to true
- private load_xgrid_use_mpp_io, get_grid, get_ocean_model_area_elements_use_mpp_io
contains
@@ -568,15 +548,10 @@ subroutine xgrid_init(remap_method)
if ( mpp_pe() == mpp_root_pe() ) write (unit,nml=xgrid_nml)
if (use_mpp_io) then
-! Tell user which IO they are using
- call error_mesg('xgrid_init', "Using mpp_io in xgrid_mod",NOTE)
+ ! FATAL error if trying to use mpp_io
call error_mesg('xgrid_init', &
- 'MPP_IO is no longer supported. Please remove from namelist',&
- WARNING)
- if ( mpp_pe() == mpp_root_pe() ) write (unit,'(a)')"Using mpp_io in xgrid_mod"
- else
- call error_mesg('xgrid_init',"Using fms2_io in xgrid_mod",NOTE)
- if ( mpp_pe() == mpp_root_pe() ) write (unit,'(a)')"Using fms2_io in xgrid_mod"
+ 'MPP_IO is no longer supported. Please remove use_mpp_io from namelists',&
+ FATAL)
endif
!--------- check interp_method has suitable value
!--- when monotonic_exchange is true, interp_method must be second order.
@@ -678,11 +653,6 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u
integer :: lll
type(FmsNetcdfFile_t) :: fileobj
- if (use_mpp_io) then
- call load_xgrid_use_mpp_io (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, use_higher_order)
- return
- endif
-
if(.not. open_file(fileobj, grid_file, 'read' )) then
call error_mesg('xgrid_mod(load_xgrid)', 'Error in opening file '//trim(grid_file), FATAL)
endif
@@ -1522,11 +1492,6 @@ subroutine get_ocean_model_area_elements(domain, grid_file)
integer :: is, ie, js, je
type(FmsNetcdfFile_t) :: fileobj
- if (use_mpp_io) then
- call get_ocean_model_area_elements_use_mpp_io(domain, grid_file)
- return
- endif
-
if(allocated(AREA_OCN_MODEL)) return
call mpp_get_compute_domain(domain, is, ie, js, je)
@@ -5373,1550 +5338,6 @@ logical function in_box_nbr(i, j, grid, p)
end function in_box_nbr
-
-!end module xgrid_mod
-
-
-!
-
-!
-! A guide to grid coupling in FMS.
-!
-!
-! A simple xgrid example.
-!
-
-!
-
-!#######################################################################
-
-subroutine load_xgrid_use_mpp_io (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, use_higher_order)
-type(xmap_type), intent(inout) :: xmap
-type(grid_type), intent(inout) :: grid
-character(len=*), intent(in) :: grid_file
-character(len=3), intent(in) :: grid1_id, grid_id
-integer, intent(in) :: tile1, tile2
-logical, intent(in) :: use_higher_order
-
- integer, pointer, dimension(:) :: i1=>NULL(), j1=>NULL()
- integer, pointer, dimension(:) :: i2=>NULL(), j2=>NULL()
- real, pointer, dimension(:) :: di=>NULL(), dj=>NULL()
- real, pointer, dimension(:) :: area =>NULL()
- integer, pointer, dimension(:) :: i1_tmp=>NULL(), j1_tmp=>NULL()
- integer, pointer, dimension(:) :: i2_tmp=>NULL(), j2_tmp=>NULL()
- real, pointer, dimension(:) :: di_tmp=>NULL(), dj_tmp=>NULL()
- real, pointer, dimension(:) :: area_tmp =>NULL()
- integer, pointer, dimension(:) :: i1_side1=>NULL(), j1_side1=>NULL()
- integer, pointer, dimension(:) :: i2_side1=>NULL(), j2_side1=>NULL()
- real, pointer, dimension(:) :: di_side1=>NULL(), dj_side1=>NULL()
- real, pointer, dimension(:) :: area_side1 =>NULL()
-
- real, allocatable, dimension(:,:) :: tmp
- real, allocatable, dimension(:) :: send_buffer, recv_buffer
- type (grid_type), pointer, save :: grid1 =>NULL()
- integer :: l, ll, ll_repro, p, siz(4), nxgrid, size_prev
- type(xcell_type), allocatable :: x_local(:)
- integer :: size_repro, out_unit
- logical :: scale_exist = .false.
- logical :: is_distribute = .false.
- real, allocatable, dimension(:) :: scale
- real :: garea
- integer :: npes, isc, iec, nxgrid_local, pe, nxgrid_local_orig
- integer :: nxgrid1, nxgrid2, nset1, nset2, ndivs, cur_ind
- integer :: pos, nsend, nrecv, l1, l2, n, mypos, m
- integer :: start(4), nread(4)
- logical :: found
- character(len=128) :: attvalue
- integer, dimension(0:xmap%npes-1) :: pelist
- logical, dimension(0:xmap%npes-1) :: subset_rootpe
- integer, dimension(0:xmap%npes-1) :: nsend1, nsend2, nrecv1, nrecv2
- integer, dimension(0:xmap%npes-1) :: send_cnt, recv_cnt
- integer, dimension(0:xmap%npes-1) :: send_buffer_pos, recv_buffer_pos
- integer, dimension(0:xmap%npes-1) :: ibegin, iend, pebegin, peend
- integer, dimension(2*xmap%npes) :: ibuf1, ibuf2
- integer, dimension(0:xmap%npes-1) :: pos_x, y2m1_size
- integer, allocatable, dimension(:) :: y2m1_pe
- integer, pointer, save :: iarray(:), jarray(:)
- integer, allocatable, save :: pos_s(:)
- integer, pointer, dimension(:) :: iarray2(:)=>NULL(), jarray2(:)=>NULL()
- logical :: last_grid
- integer :: nxgrid1_old
- integer :: lll
-
- scale_exist = .false.
- grid1 => xmap%grids(1)
- out_unit = stdout()
- npes = xmap%npes
- pe = mpp_pe()
- mypos = mpp_pe()-mpp_root_pe()
-
- call mpp_get_current_pelist(pelist)
- !--- make sure npes = pelist(npes-1) - pelist(0) + 1
- if( npes .NE. pelist(npes-1) - pelist(0) + 1 ) then
- print*, "npes =", npes, ", pelist(npes-1)=", pelist(npes-1), ", pelist(0)=", pelist(0)
- call error_mesg('xgrid_mod', 'npes .NE. pelist(npes-1) - pelist(0)', FATAL)
- endif
-
- select case(xmap%version)
- case(VERSION1)
- call field_size(grid_file, 'AREA_'//grid1_id//'x'//grid_id, siz)
- nxgrid = siz(1);
- if(nxgrid .LE. 0) return
- case(VERSION2)
- !--- max_size is the exchange grid size between super grid.
- nxgrid = get_mosaic_xgrid_size_use_mpp_io(grid_file)
- if(nxgrid .LE. 0) return
- end select
-
- !--- define a domain to read exchange grid.
- if(nxgrid > npes) then
- ndivs = npes
- if(nsubset >0 .AND. nsubset < npes) ndivs = nsubset
- call mpp_compute_extent( 1, nxgrid, ndivs, ibegin, iend)
- if(npes == ndivs) then
- p = mpp_pe()-mpp_root_pe()
- isc = ibegin(p)
- iec = iend(p)
- subset_rootpe(:) = .true.
- else
- isc = 0; iec = -1
- call mpp_compute_extent(pelist(0), pelist(npes-1), ndivs, pebegin, peend)
- do n = 0, ndivs-1
- if(pe == pebegin(n)) then
- isc = ibegin(n)
- iec = iend(n)
- exit
- endif
- enddo
- cur_ind = 0
- subset_rootpe(:) = .false.
-
- do n = 0, npes-1
- if(pelist(n) == pebegin(cur_ind)) then
- subset_rootpe(n) = .true.
- cur_ind = cur_ind+1
- if(cur_ind == ndivs) exit
- endif
- enddo
- endif
- is_distribute = .true.
- else
- is_distribute = .false.
- isc = 1; iec = nxgrid
- endif
-
- nset1 = 5
- nset2 = 5
- if(use_higher_order) then
- nset1 = nset1 + 2
- nset2 = nset2 + 2
- end if
- if(scale_exist) nset2 = nset1 + 1
-
- call mpp_clock_begin(id_load_xgrid1)
- if(iec .GE. isc) then
- nxgrid_local = iec - isc + 1
- allocate(i1_tmp(isc:iec), j1_tmp(isc:iec), i2_tmp(isc:iec), j2_tmp(isc:iec), area_tmp(isc:iec) )
- if(use_higher_order) allocate(di_tmp(isc:iec), dj_tmp(isc:iec))
-
- start = 1; nread = 1
-
- select case(xmap%version)
- case(VERSION1)
- start(1) = isc; nread(1) = nxgrid_local
- allocate(tmp(nxgrid_local,1))
- call read_data(grid_file, 'I_'//grid1_id//'_'//grid1_id//'x'//grid_id, tmp, start, nread, no_domain=.TRUE.)
- i1_tmp = tmp(:,1)
- call read_data(grid_file, 'J_'//grid1_id//'_'//grid1_id//'x'//grid_id, tmp, start, nread, no_domain=.TRUE.)
- j1_tmp = tmp(:,1)
- call read_data(grid_file, 'I_'//grid_id//'_'//grid1_id//'x'//grid_id, tmp, start, nread, no_domain=.TRUE.)
- i2_tmp = tmp(:,1)
- call read_data(grid_file, 'J_'//grid_id//'_'//grid1_id//'x'//grid_id, tmp, start, nread, no_domain=.TRUE.)
- j2_tmp = tmp(:,1)
- call read_data(grid_file, 'AREA_'//grid1_id//'x'//grid_id, tmp, start, nread, no_domain=.TRUE.)
- area_tmp = tmp(:,1)
- if(use_higher_order) then
- call read_data(grid_file, 'DI_'//grid1_id//'x'//grid_id, tmp, start, nread, no_domain=.TRUE.)
- di_tmp = tmp(:,1)
- call read_data(grid_file, 'DJ_'//grid1_id//'x'//grid_id, tmp, start, nread, no_domain=.TRUE.)
- dj_tmp = tmp(:,1)
- end if
- deallocate(tmp)
- case(VERSION2)
- nread(1) = 2; start(2) = isc; nread(2) = nxgrid_local
- allocate(tmp(2, isc:iec))
- call read_data(grid_file, "tile1_cell", tmp, start, nread, no_domain=.TRUE.)
- i1_tmp(isc:iec) = tmp(1, isc:iec)
- j1_tmp(isc:iec) = tmp(2, isc:iec)
- call read_data(grid_file, "tile2_cell", tmp, start, nread, no_domain=.TRUE.)
- i2_tmp(isc:iec) = tmp(1, isc:iec)
- j2_tmp(isc:iec) = tmp(2, isc:iec)
- if(use_higher_order) then
- call read_data(grid_file, "tile1_distance", tmp, start, nread, no_domain=.TRUE.)
- di_tmp(isc:iec) = tmp(1, isc:iec)
- dj_tmp(isc:iec) = tmp(2, isc:iec)
- end if
- start = 1; nread = 1
- start(1) = isc; nread(1) = nxgrid_local
- deallocate(tmp)
- allocate(tmp(isc:iec,1) )
- call read_data(grid_file, "xgrid_area", tmp(:,1:1), start, nread, no_domain=.TRUE.)
- ! check the units of "xgrid_area
- call get_var_att_value(grid_file, "xgrid_area", "units", attvalue)
- if( trim(attvalue) == 'm2' ) then
- garea = 4.0*PI*RADIUS*RADIUS;
- area_tmp = tmp(:,1)/garea
- else if( trim(attvalue) == 'none' ) then
- area_tmp = tmp(:,1)
- else
- call error_mesg('xgrid_mod', 'In file '//trim(grid_file)//', xgrid_area units = '// &
- trim(attvalue)//' should be "m2" or "none"', FATAL)
- endif
-
- !--- if field "scale" exist, read this field. Normally this
- !--- field only exist in landXocean exchange grid cell.
- if(grid1_id == 'LND' .AND. grid_id == 'OCN') then
- if(field_exist(grid_file, "scale")) then
- allocate(scale(isc:iec))
- write(out_unit, *)"NOTE from load_xgrid(xgrid_mod): field 'scale' exist in the file "// &
- trim(grid_file)//", this field will be read and the exchange grid cell area will be multiplied by scale"
- call read_data(grid_file, "scale", tmp, start, nread, no_domain=.TRUE.)
- scale = tmp(:,1)
- scale_exist = .true.
- endif
- endif
- deallocate(tmp)
- end select
-
- !---z1l: The following change is for the situation that some processor is masked out.
- !---loop through all the pe to see if side 1 and side of each exchange grid is on some processor
- nxgrid_local_orig = nxgrid_local
- allocate(i1(isc:iec), j1(isc:iec), i2(isc:iec), j2(isc:iec), area(isc:iec) )
- if(use_higher_order) allocate(di(isc:iec), dj(isc:iec))
- pos = isc-1
- do l = isc, iec
- found = .false.
- !--- first check if the exchange grid is on one of side 1 processor
- do p = 0, npes - 1
- if(grid1%tile(p) == tile1) then
- if(in_box_nbr(i1_tmp(l), j1_tmp(l), grid1, p)) then
- found = .true.
- exit
- endif
- endif
- enddo
- !--- Then check if the exchange grid is on one of side 2 processor
- if( found ) then
- do p = 0, npes - 1
- if(grid%tile(p) == tile2) then
- if (in_box_nbr(i2_tmp(l), j2_tmp(l), grid, p)) then
- pos = pos+1
- i1(pos) = i1_tmp(l)
- j1(pos) = j1_tmp(l)
- i2(pos) = i2_tmp(l)
- j2(pos) = j2_tmp(l)
- area(pos) = area_tmp(l)
- if(use_higher_order) then
- di(pos) = di_tmp(l)
- dj(pos) = dj_tmp(l)
- endif
- exit
- endif
- endif
- enddo
- endif
- enddo
-
- deallocate(i1_tmp, i2_tmp, j1_tmp, j2_tmp, area_tmp)
- if(use_higher_order) deallocate( di_tmp, dj_tmp)
- iec = pos
- if(iec .GE. isc) then
- nxgrid_local = iec - isc + 1
- else
- nxgrid_local = 0
- endif
- else
- nxgrid_local = 0
- nxgrid_local_orig = 0
- endif
-
- call mpp_clock_end(id_load_xgrid1)
-
- if(is_distribute) then
- !--- Since the xgrid is distributed according to side 2 grid. Send all the xgrid to its own side 2.
- !--- Also need to send the xgrid to its own side 1 for the reproducing ability between processor count.
- !--- first find out number of points need to send to other pe and fill the send buffer.
- nsend1(:) = 0; nrecv1(:) = 0
- nsend2(:) = 0; nrecv2(:) = 0
- ibuf1(:)= 0; ibuf2(:)= 0
-
- call mpp_clock_begin(id_load_xgrid2)
- if(nxgrid_local>0) then
- allocate( send_buffer(nxgrid_local * (nset1+nset2)) )
- pos = 0
- do p = 0, npes - 1
- send_buffer_pos(p) = pos
- if(grid%tile(p) == tile2) then
- do l = isc, iec
- if(in_box_nbr(i2(l), j2(l), grid, p) ) then
- nsend2(p) = nsend2(p) + 1
- send_buffer(pos+1) = i1(l)
- send_buffer(pos+2) = j1(l)
- send_buffer(pos+3) = i2(l)
- send_buffer(pos+4) = j2(l)
- send_buffer(pos+5) = area(l)
- if(use_higher_order) then
- send_buffer(pos+6) = di(l)
- send_buffer(pos+7) = dj(l)
- endif
- if(scale_exist) send_buffer(pos+nset2) = scale(l)
- pos = pos + nset2
- endif
- enddo
- endif
- if(grid1%tile(p) == tile1) then
- do l = isc, iec
- if(in_box_nbr(i1(l), j1(l), grid1, p)) then
- nsend1(p) = nsend1(p) + 1
- send_buffer(pos+1) = i1(l)
- send_buffer(pos+2) = j1(l)
- send_buffer(pos+3) = i2(l)
- send_buffer(pos+4) = j2(l)
- send_buffer(pos+5) = area(l)
- if(use_higher_order) then
- send_buffer(pos+6) = di(l)
- send_buffer(pos+7) = dj(l)
- endif
- pos = pos + nset1
- endif
- enddo
- endif
- enddo
- endif
- call mpp_clock_end(id_load_xgrid2)
-
- !--- send the size of the data on side 1 to be sent over.
- call mpp_clock_begin(id_load_xgrid3)
-
- if (do_alltoall) then
- do p = 0, npes-1
- ibuf1(2*p+1) = nsend1(p)
- ibuf1(2*p+2) = nsend2(p)
- enddo
- call mpp_alltoall(ibuf1, 2, ibuf2, 2)
- else
- do n = 0, npes-1
- p = mod(mypos+npes-n, npes)
- if(.not. subset_rootpe(p)) cycle
- call mpp_recv( ibuf2(2*p+1), glen=2, from_pe=pelist(p), block=.FALSE., tag=COMM_TAG_1)
- enddo
-
- if(nxgrid_local_orig>0) then
- do n = 0, npes-1
- p = mod(mypos+n, npes)
- ibuf1(2*p+1) = nsend1(p)
- ibuf1(2*p+2) = nsend2(p)
- call mpp_send( ibuf1(2*p+1), plen=2, to_pe=pelist(p), tag=COMM_TAG_1)
- enddo
- endif
- call mpp_sync_self(check=EVENT_RECV)
- endif
- do p = 0, npes-1
- nrecv1(p) = ibuf2(2*p+1)
- nrecv2(p) = ibuf2(2*p+2)
- enddo
-
- if(.not. do_alltoall) call mpp_sync_self()
- call mpp_clock_end(id_load_xgrid3)
- call mpp_clock_begin(id_load_xgrid4)
- pos = 0
- do p = 0, npes - 1
- recv_buffer_pos(p) = pos
- pos = pos + nrecv1(p) * nset1 + nrecv2(p) * nset2
- end do
-
- !--- now get the data
- nxgrid1 = sum(nrecv1)
- nxgrid2 = sum(nrecv2)
- if(nxgrid1>0 .OR. nxgrid2>0) allocate(recv_buffer(nxgrid1*nset1+nxgrid2*nset2))
-
- if (do_alltoallv) then
- ! Construct the send and receive counters
- send_cnt(:) = nset1 * nsend1(:) + nset2 * nsend2(:)
- recv_cnt(:) = nset1 * nrecv1(:) + nset2 * nrecv2(:)
-
- call mpp_alltoall(send_buffer, send_cnt, send_buffer_pos, &
- recv_buffer, recv_cnt, recv_buffer_pos)
- else
- do n = 0, npes-1
- p = mod(mypos+npes-n, npes)
- nrecv = nrecv1(p)*nset1+nrecv2(p)*nset2
- if(nrecv==0) cycle
- pos = recv_buffer_pos(p)
- call mpp_recv(recv_buffer(pos+1), glen=nrecv, from_pe=pelist(p), &
- block=.FALSE., tag=COMM_TAG_2)
- end do
-
- do n = 0, npes-1
- p = mod(mypos+n, npes)
- nsend = nsend1(p)*nset1 + nsend2(p)*nset2
- if(nsend==0) cycle
- pos = send_buffer_pos(p)
- call mpp_send(send_buffer(pos+1), plen=nsend, to_pe=pelist(p), &
- tag=COMM_TAG_2)
- end do
- call mpp_sync_self(check=EVENT_RECV)
- end if
- call mpp_clock_end(id_load_xgrid4)
- !--- unpack buffer.
- if( nxgrid_local>0) then
- deallocate(i1,j1,i2,j2,area)
- endif
-
- allocate(i1(nxgrid2), j1(nxgrid2))
- allocate(i2(nxgrid2), j2(nxgrid2))
- allocate(area(nxgrid2))
- allocate(i1_side1(nxgrid1), j1_side1(nxgrid1))
- allocate(i2_side1(nxgrid1), j2_side1(nxgrid1))
- allocate(area_side1(nxgrid1))
- if(use_higher_order) then
- if(nxgrid_local>0) deallocate(di,dj)
- allocate(di (nxgrid2), dj (nxgrid2))
- allocate(di_side1(nxgrid1), dj_side1(nxgrid1))
- endif
- if(scale_exist) then
- if(nxgrid_local>0)deallocate(scale)
- allocate(scale(nxgrid2))
- endif
- pos = 0
- l1 = 0; l2 = 0
- do p = 0,npes-1
- do n = 1, nrecv2(p)
- l2 = l2+1
- i1(l2) = recv_buffer(pos+1)
- j1(l2) = recv_buffer(pos+2)
- i2(l2) = recv_buffer(pos+3)
- j2(l2) = recv_buffer(pos+4)
- area(l2) = recv_buffer(pos+5)
- if(use_higher_order) then
- di(l2) = recv_buffer(pos+6)
- dj(l2) = recv_buffer(pos+7)
- endif
- if(scale_exist)scale(l2) = recv_buffer(pos+nset2)
- pos = pos + nset2
- enddo
- do n = 1, nrecv1(p)
- l1 = l1+1
- i1_side1(l1) = recv_buffer(pos+1)
- j1_side1(l1) = recv_buffer(pos+2)
- i2_side1(l1) = recv_buffer(pos+3)
- j2_side1(l1) = recv_buffer(pos+4)
- area_side1(l1) = recv_buffer(pos+5)
- if(use_higher_order) then
- di_side1(l1) = recv_buffer(pos+6)
- dj_side1(l1) = recv_buffer(pos+7)
- endif
- pos = pos + nset1
- enddo
- enddo
- call mpp_sync_self()
- if(allocated(send_buffer)) deallocate(send_buffer)
- if(allocated(recv_buffer)) deallocate(recv_buffer)
-
- else
- nxgrid1 = nxgrid
- nxgrid2 = nxgrid
- i1_side1 => i1; j1_side1 => j1
- i2_side1 => i2; j2_side1 => j2
- area_side1 => area
- if(use_higher_order) then
- di_side1 => di
- dj_side1 => dj
- endif
- endif
-
- call mpp_clock_begin(id_load_xgrid5)
-
-
- size_prev = grid%size
-
- if(grid%tile_me == tile2) then
- do l=1,nxgrid2
- if (in_box_me(i2(l), j2(l), grid) ) then
- grid%size = grid%size + 1
- ! exclude the area overlapped with parent grid
- if( grid1_id .NE. "ATM" .OR. tile1 .NE. tile_parent .OR. &
- .NOT. in_box(i1(l), j1(l), is_parent, ie_parent, js_parent, je_parent) ) then
- if(grid%is_ug) then
- lll = grid%l_index((j2(l)-1)*grid%im+i2(l))
- grid%area(lll,1) = grid%area(lll,1)+area(l)
- else
- grid%area(i2(l),j2(l)) = grid%area(i2(l),j2(l))+area(l)
- endif
- endif
- do p=0,xmap%npes-1
- if(grid1%tile(p) == tile1) then
- if (in_box_nbr(i1(l), j1(l), grid1, p)) then
- xmap%your1my2(p) = .true.
- end if
- end if
- end do
- end if
- end do
- end if
-
- if(grid%size > size_prev) then
- if(size_prev > 0) then ! need to extend data
- allocate(x_local(size_prev))
- x_local = grid%x
- if(ASSOCIATED(grid%x)) deallocate(grid%x)
- allocate( grid%x( grid%size ) )
- grid%x(1:size_prev) = x_local
- deallocate(x_local)
- else
- allocate( grid%x( grid%size ) )
- grid%x%di = 0.0; grid%x%dj = 0.0
- end if
- end if
-
- ll = size_prev
- if( grid%tile_me == tile2 ) then ! me is tile2
- do l=1,nxgrid2
- if (in_box_me(i2(l), j2(l), grid)) then
- ! insert in this grids cell pattern list and add area to side 2 area
- ll = ll + 1
- grid%x(ll)%i1 = i1(l); grid%x(ll)%i2 = i2(l)
- grid%x(ll)%j1 = j1(l); grid%x(ll)%j2 = j2(l)
- if(grid%is_ug) then
- grid%x(ll)%l2 = grid%l_index((j2(l)-1)*grid%im + i2(l))
- endif
-! if(grid1%is_ug) then
-! grid1%x(ll)%l1 = grid1%l_index((j1(l)-1)*grid1%im + i1(l))
-! endif
- grid%x(ll)%tile = tile1
- grid%x(ll)%area = area(l)
- if(scale_exist) then
- grid%x(ll)%scale = scale(l)
- else
- grid%x(ll)%scale = 1.0
- endif
- if(use_higher_order) then
- grid%x(ll)%di = di(l)
- grid%x(ll)%dj = dj(l)
- end if
-
- if (make_exchange_reproduce) then
- do p=0,xmap%npes-1
- if(grid1%tile(p) == tile1) then
- if (in_box_nbr(i1(l), j1(l), grid1, p)) then
- grid%x(ll)%pe = p + xmap%root_pe
- end if
- end if
- end do
- end if ! make_exchange reproduce
- end if
- end do
- end if
-
- if(grid%id == xmap%grids(size(xmap%grids(:)))%id) then
- last_grid = .true.
- else
- last_grid = .false.
- endif
-
- size_repro = 0
- if(grid1%tile_me == tile1) then
- if(associated(iarray)) then
- nxgrid1_old = size(iarray(:))
- else
- nxgrid1_old = 0
- endif
-
- allocate(y2m1_pe(nxgrid1))
- if(.not. last_grid ) allocate(pos_s(0:xmap%npes-1))
- y2m1_pe = -1
- if(nxgrid1_old > 0) then
- do p=0,xmap%npes-1
- y2m1_size(p) = xmap%your2my1_size(p)
- enddo
- else
- y2m1_size = 0
- endif
-
- do l=1,nxgrid1
- if (in_box_me(i1_side1(l), j1_side1(l), grid1) ) then
- if(grid1%is_ug) then
- lll = grid1%l_index((j1_side1(l)-1)*grid1%im+i1_side1(l))
- grid1%area(lll,1) = grid1%area(lll,1) + area_side1(l)
- else
- grid1%area(i1_side1(l),j1_side1(l)) = grid1%area(i1_side1(l),j1_side1(l))+area_side1(l)
- endif
- do p=0,xmap%npes-1
- if (grid%tile(p) == tile2) then
- if (in_box_nbr(i2_side1(l), j2_side1(l), grid, p)) then
- xmap%your2my1(p) = .true.
- y2m1_pe(l) = p
- y2m1_size(p) = y2m1_size(p) + 1
- endif
- endif
- enddo
- size_repro = size_repro + 1
- endif
- enddo
- pos_x = 0
- do p = 1, npes-1
- pos_x(p) = pos_x(p-1) + y2m1_size(p-1)
- enddo
-
- if(.not. last_grid) pos_s(:) = pos_x(:)
-
- if(nxgrid1_old > 0) then
- y2m1_size(:) = xmap%your2my1_size(:)
- iarray2 => iarray
- jarray2 => jarray
- allocate(iarray(nxgrid1+nxgrid1_old), jarray(nxgrid1+nxgrid1_old))
- ! copy the i-j index
- do p=0,xmap%npes-1
- do n = 1, xmap%your2my1_size(p)
- iarray(pos_x(p)+n) = iarray2(pos_s(p)+n)
- jarray(pos_x(p)+n) = jarray2(pos_s(p)+n)
- enddo
- enddo
- deallocate(iarray2, jarray2)
- else
- allocate(iarray(nxgrid1), jarray(nxgrid1))
- iarray(:) = 0
- jarray(:) = 0
- y2m1_size(:) = 0
- endif
-
- do l=1,nxgrid1
- p = y2m1_pe(l)
- if(p<0) cycle
- found = .false.
- if(y2m1_size(p) > 0) then
- pos = pos_x(p)+y2m1_size(p)
- if( i1_side1(l) == iarray(pos) .AND. j1_side1(l) == jarray(pos) ) then
- found = .true.
- else
- !---may need to replace with a fast search algorithm
- do n = 1, y2m1_size(p)
- pos = pos_x(p)+n
- if(i1_side1(l) == iarray(pos) .AND. j1_side1(l) == jarray(pos)) then
- found = .true.
- exit
- endif
- enddo
- endif
- endif
- if( (.NOT. found) .OR. monotonic_exchange ) then
- y2m1_size(p) = y2m1_size(p)+1
- pos = pos_x(p)+y2m1_size(p)
- iarray(pos) = i1_side1(l)
- jarray(pos) = j1_side1(l)
- endif
- end do
- xmap%your2my1_size(:) = y2m1_size(:)
- deallocate(y2m1_pe)
- if(last_grid) then
- deallocate(iarray, jarray)
- if(allocated(pos_s)) deallocate(pos_s)
- end if
- end if
-
- if (grid1%tile_me == tile1 .and. size_repro > 0) then
- ll_repro = grid%size_repro
- grid%size_repro = ll_repro + size_repro
- if(ll_repro > 0) then ! extend data
- allocate(x_local(ll_repro))
- x_local = grid%x_repro
- if(ASSOCIATED(grid%x_repro)) deallocate(grid%x_repro)
- allocate( grid%x_repro(grid%size_repro ) )
- grid%x_repro(1:ll_repro) = x_local
- deallocate(x_local)
- else
- allocate( grid%x_repro( grid%size_repro ) )
- grid%x_repro%di = 0.0; grid%x_repro%dj = 0.0
- end if
- do l=1,nxgrid1
- if (in_box_me(i1_side1(l),j1_side1(l), grid1) ) then
- ll_repro = ll_repro + 1
- grid%x_repro(ll_repro)%i1 = i1_side1(l); grid%x_repro(ll_repro)%i2 = i2_side1(l)
- grid%x_repro(ll_repro)%j1 = j1_side1(l); grid%x_repro(ll_repro)%j2 = j2_side1(l)
- if(grid1%is_ug) then
- grid%x_repro(ll_repro)%l1 = grid1%l_index((j1_side1(l)-1)*grid1%im+i1_side1(l))
- endif
- if(grid%is_ug) then
-! grid%x_repro(ll_repro)%l2 = grid%l_index((j2_side1(l)-1)*grid%im+i2_side1(l))
- endif
- grid%x_repro(ll_repro)%tile = tile1
- grid%x_repro(ll_repro)%area = area_side1(l)
- if(use_higher_order) then
- grid%x_repro(ll_repro)%di = di_side1(l)
- grid%x_repro(ll_repro)%dj = dj_side1(l)
- end if
-
- do p=0,xmap%npes-1
- if(grid%tile(p) == tile2) then
- if (in_box_nbr(i2_side1(l), j2_side1(l), grid, p)) then
- grid%x_repro(ll_repro)%pe = p + xmap%root_pe
- end if
- end if
- end do
- end if ! make_exchange_reproduce
- end do
- end if
-
- deallocate(i1, j1, i2, j2, area)
- if(use_higher_order) deallocate(di, dj)
- if(scale_exist) deallocate(scale)
- if(is_distribute) then
- deallocate(i1_side1, j1_side1, i2_side1, j2_side1, area_side1)
- if(use_higher_order) deallocate(di_side1, dj_side1)
- endif
-
- i1=>NULL(); j1=>NULL(); i2=>NULL(); j2=>NULL()
- call mpp_clock_end(id_load_xgrid5)
-
-
-
-end subroutine load_xgrid_use_mpp_io
-
-!#######################################################################
-!
-! get_grid - read the center point of the grid from grid_spec.nc.
-! - only the grid at the side 1 is needed, so we only read
-! - atm and land grid
-!
-!
-
-!> @brief Reads the center point of the grid from grid_spec.nc.
-!!
-!> Only the grid at side 1 is needed, so we only read atm and land grid.
-subroutine get_grid(grid, grid_id, grid_file, grid_version) !< use_mpp_io
- type(grid_type), intent(inout) :: grid
- character(len=3), intent(in) :: grid_id
- character(len=*), intent(in) :: grid_file
- integer, intent(in) :: grid_version
-
- real, dimension(grid%im) :: lonb
- real, dimension(grid%jm) :: latb
- real, allocatable :: tmpx(:,:), tmpy(:,:)
- real :: d2r
- integer :: is, ie, js, je, nlon, nlat, siz(4), i, j
- integer :: start(4), nread(4), isc2, iec2, jsc2, jec2
-
- d2r = PI/180.0
-
- call mpp_get_compute_domain(grid%domain, is, ie, js, je)
-
- select case(grid_version)
- case(VERSION1)
- allocate(grid%lon(grid%im), grid%lat(grid%jm))
- if(grid_id == 'ATM') then
- call read_data(grid_file, 'xta', lonb)
- call read_data(grid_file, 'yta', latb)
-
- if(.not. allocated(AREA_ATM_MODEL)) then
- allocate(AREA_ATM_MODEL(is:ie, js:je))
- call get_area_elements(grid_file, 'AREA_ATM_MODEL', grid%domain, AREA_ATM_MODEL)
- endif
- if(.not. allocated(AREA_ATM_SPHERE)) then
- allocate(AREA_ATM_SPHERE(is:ie, js:je))
- call get_area_elements(grid_file, 'AREA_ATM', grid%domain, AREA_ATM_SPHERE)
- endif
- else if(grid_id == 'LND') then
- call read_data(grid_file, 'xtl', lonb)
- call read_data(grid_file, 'ytl', latb)
- if(.not. allocated(AREA_LND_MODEL)) then
- allocate(AREA_LND_MODEL(is:ie, js:je))
- call get_area_elements(grid_file, 'AREA_LND_MODEL', grid%domain, AREA_LND_MODEL)
- endif
- if(.not. allocated(AREA_LND_SPHERE)) then
- allocate(AREA_LND_SPHERE(is:ie, js:je))
- call get_area_elements(grid_file, 'AREA_LND', grid%domain, AREA_LND_SPHERE)
- endif
- else if(grid_id == 'OCN' ) then
- if(.not. allocated(AREA_OCN_SPHERE)) then
- allocate(AREA_OCN_SPHERE(is:ie, js:je))
- call get_area_elements(grid_file, 'AREA_OCN', grid%domain, AREA_OCN_SPHERE)
- endif
- endif
- !--- second order remapping suppose second order
- if(grid_id == 'LND' .or. grid_id == 'ATM') then
- grid%lon = lonb * d2r
- grid%lat = latb * d2r
- endif
- grid%is_latlon = .true.
- case(VERSION2)
- call field_size(grid_file, 'area', siz)
- nlon = siz(1); nlat = siz(2)
- if( mod(nlon,2) .NE. 0) call error_mesg('xgrid_mod', &
- 'flux_exchange_mod: atmos supergrid longitude size can not be divided by 2', FATAL)
- if( mod(nlat,2) .NE. 0) call error_mesg('xgrid_mod', &
- 'flux_exchange_mod: atmos supergrid latitude size can not be divided by 2', FATAL)
- nlon = nlon/2
- nlat = nlat/2
- if(nlon .NE. grid%im .OR. nlat .NE. grid%jm) call error_mesg('xgrid_mod', &
- 'grid size in tile_file does not match the global grid size', FATAL)
-
- if( grid_id == 'LND' .or. grid_id == 'ATM' .or. grid_id == 'WAV' ) then
- isc2 = 2*grid%is_me-1; iec2 = 2*grid%ie_me+1
- jsc2 = 2*grid%js_me-1; jec2 = 2*grid%je_me+1
- allocate(tmpx(isc2:iec2, jsc2:jec2) )
- allocate(tmpy(isc2:iec2, jsc2:jec2) )
- start = 1; nread = 1
- start(1) = isc2; nread(1) = iec2 - isc2 + 1
- start(2) = jsc2; nread(2) = jec2 - jsc2 + 1
- call read_data(grid_file, 'x', tmpx, start, nread, no_domain=.TRUE.)
- call read_data(grid_file, 'y', tmpy, start, nread, no_domain=.TRUE.)
- if(is_lat_lon(tmpx, tmpy) ) then
- deallocate(tmpx, tmpy)
- start = 1; nread = 1
- start(2) = 2; nread(1) = nlon*2+1
- allocate(tmpx(nlon*2+1, 1), tmpy(1, nlat*2+1))
- call read_data(grid_file, "x", tmpx, start, nread, no_domain=.TRUE.)
- allocate(grid%lon(grid%im), grid%lat(grid%jm))
- do i = 1, grid%im
- grid%lon(i) = tmpx(2*i,1) * d2r
- end do
- start = 1; nread = 1
- start(1) = 2; nread(2) = nlat*2+1
- call read_data(grid_file, "y", tmpy, start, nread, no_domain=.TRUE.)
- do j = 1, grid%jm
- grid%lat(j) = tmpy(1, 2*j) * d2r
- end do
- grid%is_latlon = .true.
- else
- allocate(grid%geolon(grid%isd_me:grid%ied_me, grid%jsd_me:grid%jed_me))
- allocate(grid%geolat(grid%isd_me:grid%ied_me, grid%jsd_me:grid%jed_me))
- grid%geolon = 1e10
- grid%geolat = 1e10
- !--- area_ocn_sphere, area_lnd_sphere, area_atm_sphere is not been defined.
- do j = grid%js_me,grid%je_me
- do i = grid%is_me,grid%ie_me
- grid%geolon(i, j) = tmpx(i*2,j*2)*d2r
- grid%geolat(i, j) = tmpy(i*2,j*2)*d2r
- end do
- end do
- call mpp_update_domains(grid%geolon, grid%domain)
- call mpp_update_domains(grid%geolat, grid%domain)
- grid%is_latlon = .false.
- end if
- deallocate(tmpx, tmpy)
- end if
- end select
-
- return
-
-end subroutine get_grid !< use_mpp_io
-
-!#######################################################################
-! Read the area elements from NetCDF file
-subroutine get_area_elements_use_mpp_io(file, name, domain, data)
- character(len=*), intent(in) :: file
- character(len=*), intent(in) :: name
- type(domain2d), intent(in) :: domain
- real, intent(out) :: data(:,:)
-
- if(field_exist(file, name)) then
- call read_data(file, name, data, domain)
- else
- call error_mesg('xgrid_mod', 'no field named '//trim(name)//' in grid file '//trim(file)// &
- ' Will set data to negative values...', NOTE)
- ! area elements no present in grid_spec file, set to negative values....
- data = -1.0
- endif
-
-end subroutine get_area_elements_use_mpp_io
-
-!#######################################################################
-! Read the OCN model area elements from NetCDF file
-!
-
-!
-! Read Ocean area element data.
-!
-!
-! If available in the NetCDF file, this routine will read the
-! AREA_OCN_MODEL field and load the data into global AREA_OCN_MODEL.
-! If not available, then the array AREA_OCN_MODEL will be left
-! unallocated. Must be called by all PEs.
-!
-!
-! call get_ocean_model_area_elements(ocean_domain, grid_file)
-!
-
-!
-!
-subroutine get_ocean_model_area_elements_use_mpp_io(domain, grid_file)
-
- type(Domain2d), intent(in) :: domain
- character(len=*), intent(in) :: grid_file
- integer :: is, ie, js, je
-
- if(allocated(AREA_OCN_MODEL)) return
-
- call mpp_get_compute_domain(domain, is, ie, js, je)
- ! allocate even if ie
-!#######################################################################
-
-!
-
-!
-! Sets up exchange grid connectivity using grid specification file and
-! processor domain decomposition.
-!
-!
-! Sets up exchange grid connectivity using grid specification file and
-! processor domain decomposition. Initializes xmap.
-!
-!
-! call setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid)
-!
-
-!
-!
-!
-!
-!
-
-subroutine setup_xmap_use_mpp_io(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_domain)
- type (xmap_type), intent(inout) :: xmap
- character(len=3), dimension(:), intent(in ) :: grid_ids
- type(Domain2d), dimension(:), intent(in ) :: grid_domains
- character(len=*), intent(in ) :: grid_file
- type(grid_box_type), optional, intent(in ) :: atm_grid
- type(domainUG), optional, intent(in ) :: lnd_ug_domain
-
- integer :: g, p, send_size, recv_size, i, siz(4)
- integer :: unit, nxgrid_file, i1, i2, i3, tile1, tile2, j
- integer :: nxc, nyc, out_unit
- type (grid_type), pointer, save :: grid =>NULL(), grid1 =>NULL()
- real, dimension(3) :: xxx
- real, dimension(:,:), allocatable :: check_data
- real, dimension(:,:,:), allocatable :: check_data_3D
- real, allocatable :: tmp_2d(:,:), tmp_3d(:,:,:)
- character(len=256) :: xgrid_file, xgrid_name
- character(len=256) :: tile_file, mosaic_file
- character(len=256) :: mosaic1, mosaic2, contact
- character(len=256) :: tile1_name, tile2_name
- character(len=256), allocatable :: tile1_list(:), tile2_list(:)
- integer :: npes, npes2
- integer, allocatable :: pelist(:)
- type(domain2d), save :: domain2
- logical :: use_higher_order = .false.
- integer :: lnd_ug_id, l
- integer, allocatable :: grid_index(:)
-
- call mpp_clock_begin(id_setup_xmap)
-
- if(interp_method .ne. 'first_order') use_higher_order = .true.
-
- out_unit = stdout()
- xmap%me = mpp_pe ()
- xmap%npes = mpp_npes()
- xmap%root_pe = mpp_root_pe()
-
- allocate( xmap%grids(1:size(grid_ids(:))) )
-
- allocate ( xmap%your1my2(0:xmap%npes-1), xmap%your2my1(0:xmap%npes-1) )
- allocate ( xmap%your2my1_size(0:xmap%npes-1) )
-
- xmap%your1my2 = .false.; xmap%your2my1 = .false.;
- xmap%your2my1_size = 0
-
-! check the exchange grid file version to be used by checking the field in the file
- if(field_exist(grid_file, "AREA_ATMxOCN" ) ) then
- xmap%version = VERSION1
- else if(field_exist(grid_file, "ocn_mosaic_file" ) ) then
- xmap%version = VERSION2
- else
- call error_mesg('xgrid_mod', 'both AREA_ATMxOCN and ocn_mosaic_file does not exist in '//trim(grid_file), FATAL)
- end if
-
- if(xmap%version==VERSION1) then
- call error_mesg('xgrid_mod', 'reading exchange grid information from grid spec file', NOTE)
- else
- call error_mesg('xgrid_mod', 'reading exchange grid information from mosaic grid file', NOTE)
- end if
-
- ! check to see the id of lnd.
- lnd_ug_id = 0
- if(present(lnd_ug_domain)) then
- do g=1,size(grid_ids(:))
- if(grid_ids(g) == 'LND') lnd_ug_id = g
- enddo
- endif
-
- call mpp_clock_begin(id_load_xgrid)
- do g=1,size(grid_ids(:))
- grid => xmap%grids(g)
- if (g==1) grid1 => xmap%grids(g)
- grid%id = grid_ids (g)
- grid%domain = grid_domains(g)
- grid%on_this_pe = mpp_domain_is_initialized(grid_domains(g))
- allocate ( grid%is(0:xmap%npes-1), grid%ie(0:xmap%npes-1) )
- allocate ( grid%js(0:xmap%npes-1), grid%je(0:xmap%npes-1) )
- allocate ( grid%tile(0:xmap%npes-1) )
- grid%npes = 0
- grid%ni = 0
- grid%nj = 0
- grid%is = 0
- grid%ie = -1
- grid%js = 0
- grid%je = -1
- grid%tile = -1
-
- select case(xmap%version)
- case(VERSION1)
- grid%ntile = 1
- case(VERSION2)
- call read_data(grid_file, lowercase(grid_ids(g))//'_mosaic_file', mosaic_file)
- grid%ntile = get_mosaic_ntiles_use_mpp_io('INPUT/'//trim(mosaic_file))
- end select
-
- if( g == 1 .AND. grid_ids(1) == 'ATM' ) then
- if( .NOT. grid%on_this_pe ) call error_mesg('xgrid_mod', 'ATM domain is not defined on some processor' ,FATAL)
- endif
- grid%npes = mpp_get_domain_npes(grid%domain)
- if( xmap%npes > grid%npes .AND. g == 1 .AND. grid_ids(1) == 'ATM' ) then
- call mpp_broadcast_domain(grid%domain, domain2)
- else if(xmap%npes > grid%npes) then
- call mpp_broadcast_domain(grid%domain)
- grid%npes = mpp_get_domain_npes(grid%domain)
- endif
-
- npes = grid%npes
- allocate(grid%pelist(0:npes-1))
- call mpp_get_domain_pelist(grid%domain, grid%pelist)
- grid%root_pe = mpp_get_domain_root_pe(grid%domain)
-
- call mpp_get_data_domain(grid%domain, grid%isd_me, grid%ied_me, grid%jsd_me, grid%jed_me, &
- xsize=grid%nxd_me, ysize=grid%nyd_me)
- call mpp_get_global_domain(grid%domain, xsize=grid%ni, ysize=grid%nj)
-
- if( grid%root_pe == xmap%root_pe ) then
- call mpp_get_compute_domains(grid%domain, xbegin=grid%is(0:npes-1), xend=grid%ie(0:npes-1), &
- ybegin=grid%js(0:npes-1), yend=grid%je(0:npes-1) )
- call mpp_get_tile_list(grid%domain, grid%tile(0:npes-1))
- if( xmap%npes > npes .AND. g == 1 .AND. grid_ids(1) == 'ATM' ) then
- call mpp_get_compute_domains(domain2, xbegin=grid%is(npes:xmap%npes-1), xend=grid%ie(npes:xmap%npes-1), &
- ybegin=grid%js(npes:xmap%npes-1), yend=grid%je(npes:xmap%npes-1) )
- call mpp_get_tile_list(domain2, grid%tile(npes:xmap%npes-1))
- endif
- else
- npes2 = xmap%npes-npes
- call mpp_get_compute_domains(domain2, xbegin=grid%is(0:npes2-1), xend=grid%ie(0:npes2-1), &
- ybegin=grid%js(0:npes2-1), yend=grid%je(0:npes2-1) )
- call mpp_get_compute_domains(grid%domain, xbegin=grid%is(npes2:xmap%npes-1), xend=grid%ie(npes2:xmap%npes-1), &
- ybegin=grid%js(npes2:xmap%npes-1), yend=grid%je(npes2:xmap%npes-1) )
- call mpp_get_tile_list(domain2, grid%tile(0:npes2-1))
- call mpp_get_tile_list(grid%domain, grid%tile(npes2:xmap%npes-1))
- endif
- if( xmap%npes > grid%npes .AND. g == 1 .AND. grid_ids(1) == 'ATM' ) then
- call mpp_deallocate_domain(domain2)
- endif
- npes = grid%npes
- if( g == 1 .AND. grid_ids(1) == 'ATM' ) npes = xmap%npes
- do p = 0, npes-1
- if(grid%tile(p) > grid%ntile .or. grid%tile(p) < 1) call error_mesg('xgrid_mod', &
- 'tile id should between 1 and ntile', FATAL)
- end do
-
- grid%im = grid%ni
- grid%jm = grid%nj
- call mpp_max(grid%ni)
- call mpp_max(grid%nj)
-
- grid%is_me => grid%is(xmap%me-xmap%root_pe); grid%ie_me => grid%ie(xmap%me-xmap%root_pe)
- grid%js_me => grid%js(xmap%me-xmap%root_pe); grid%je_me => grid%je(xmap%me-xmap%root_pe)
- grid%nxc_me = grid%ie_me - grid%is_me + 1
- grid%nyc_me = grid%je_me - grid%js_me + 1
- grid%tile_me => grid%tile(xmap%me-xmap%root_pe)
-
- grid%km = 1
- grid%is_ug = .false.
- !--- setup for land unstructure grid
- if( g == lnd_ug_id ) then
- if(xmap%version == VERSION1) call error_mesg('xgrid_mod', &
- 'does not support unstructured grid for VERSION1 grid' ,FATAL)
- grid%is_ug = .true.
- grid%ug_domain = lnd_ug_domain
- allocate ( grid%ls(0:xmap%npes-1), grid%le(0:xmap%npes-1) )
- allocate ( grid%gs(0:xmap%npes-1), grid%ge(0:xmap%npes-1) )
- grid%ls = 0
- grid%le = -1
- grid%gs = 0
- grid%ge = -1
- if(xmap%npes > grid%npes) then
- call mpp_broadcast_domain(grid%ug_domain)
- endif
- call mpp_get_ug_compute_domains(grid%ug_domain, begin=grid%ls(0:npes-1), end=grid%le(0:npes-1) )
- call mpp_get_ug_domains_index(grid%ug_domain, grid%gs(0:npes-1), grid%ge(0:npes-1) )
- call mpp_get_ug_domain_tile_list(grid%ug_domain, grid%tile(0:npes-1))
- grid%ls_me => grid%ls(xmap%me-xmap%root_pe); grid%le_me => grid%le(xmap%me-xmap%root_pe)
- grid%gs_me => grid%gs(xmap%me-xmap%root_pe); grid%ge_me => grid%ge(xmap%me-xmap%root_pe)
- grid%tile_me => grid%tile(xmap%me-xmap%root_pe)
- grid%nxl_me = grid%le_me - grid%ls_me + 1
- allocate(grid%l_index(grid%gs_me:grid%ge_me))
- allocate(grid_index(grid%ls_me:grid%le_me))
- call mpp_get_UG_domain_grid_index(grid%ug_domain, grid_index)
-
- grid%l_index = 0
- do l = grid%ls_me,grid%le_me
- grid%l_index(grid_index(l)) = l
- enddo
-
- if( grid%on_this_pe ) then
- allocate( grid%area (grid%ls_me:grid%le_me,1) )
- allocate( grid%area_inv(grid%ls_me:grid%le_me,1) )
- grid%area = 0.0
- grid%size = 0
- grid%size_repro = 0
- endif
- else if( grid%on_this_pe ) then
- allocate( grid%area (grid%is_me:grid%ie_me, grid%js_me:grid%je_me) )
- allocate( grid%area_inv(grid%is_me:grid%ie_me, grid%js_me:grid%je_me) )
- grid%area = 0.0
- grid%size = 0
- grid%size_repro = 0
- endif
-
- ! get the center point of the grid box
- if(.not. grid%is_ug) then
- select case(xmap%version)
- case(VERSION1)
- if( grid%npes .NE. xmap%npes ) then
- call error_mesg('xgrid_mod', ' grid%npes .NE. xmap%npes ', FATAL)
- endif
- call get_grid(grid, grid_ids(g), grid_file, xmap%version)
- case(VERSION2)
- allocate(pelist(0:xmap%npes-1))
- call mpp_get_current_pelist(pelist)
- if( grid%on_this_pe ) then
- call mpp_set_current_pelist(grid%pelist)
- call get_mosaic_tile_grid_use_mpp_io(tile_file, 'INPUT/'//trim(mosaic_file), grid%domain)
- call get_grid(grid, grid_ids(g), tile_file, xmap%version)
- endif
- call mpp_set_current_pelist(pelist)
- deallocate(pelist)
- ! read the contact information from mosaic_file to check if atmosphere is nested model
- if( g == 1 .AND. grid_ids(1) == 'ATM' ) then
- nnest = get_nest_contact('INPUT/'//trim(mosaic_file), tile_nest, tile_parent, is_nest, &
- ie_nest, js_nest, je_nest, is_parent, ie_parent, js_parent, je_parent)
- endif
- end select
-
- if( use_higher_order .AND. grid%id == 'ATM') then
- if( nnest > 0 ) call error_mesg('xgrid_mod', 'second_order is not supported for nested coupler', FATAL)
- if( grid%is_latlon ) then
- call mpp_modify_domain(grid%domain, grid%domain_with_halo, whalo=1, ehalo=1, shalo=1, nhalo=1)
- call mpp_get_data_domain(grid%domain_with_halo, grid%isd_me, grid%ied_me, grid%jsd_me, grid%jed_me, &
- xsize=grid%nxd_me, ysize=grid%nyd_me)
- else
- if(.NOT. present(atm_grid)) call error_mesg('xgrid_mod', &
- 'when first grid is "ATM", atm_grid should be present', FATAL)
- if(grid%is_me-grid%isd_me .NE. 1 .or. grid%ied_me-grid%ie_me .NE. 1 .or. &
- grid%js_me-grid%jsd_me .NE. 1 .or. grid%jed_me-grid%je_me .NE. 1 ) call error_mesg( &
- 'xgrid_mod', 'for non-latlon grid (cubic grid), the halo size should be 1 in all four direction', FATAL)
- if(.NOT.( ASSOCIATED(atm_grid%dx) .AND. ASSOCIATED(atm_grid%dy) .AND. ASSOCIATED(atm_grid%edge_w) .AND. &
- ASSOCIATED(atm_grid%edge_e) .AND. ASSOCIATED(atm_grid%edge_s) .AND. ASSOCIATED(atm_grid%edge_n) .AND. &
- ASSOCIATED(atm_grid%en1) .AND. ASSOCIATED(atm_grid%en2) .AND. ASSOCIATED(atm_grid%vlon) .AND. &
- ASSOCIATED(atm_grid%vlat) ) ) call error_mesg( 'xgrid_mod', &
- 'for non-latlon grid (cubic grid), all the fields in atm_grid data type should be allocated', FATAL)
- nxc = grid%ie_me - grid%is_me + 1
- nyc = grid%je_me - grid%js_me + 1
- if(size(atm_grid%dx,1) .NE. nxc .OR. size(atm_grid%dx,2) .NE. nyc+1) &
- call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%dx', FATAL)
- if(size(atm_grid%dy,1) .NE. nxc+1 .OR. size(atm_grid%dy,2) .NE. nyc) &
- call error_mesg('xgrid_mod', 'incorrect dimension sizeof atm_grid%dy', FATAL)
- if(size(atm_grid%area,1) .NE. nxc .OR. size(atm_grid%area,2) .NE. nyc) &
- call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%area', FATAL)
- if(size(atm_grid%edge_w(:)) .NE. nyc+1 .OR. size(atm_grid%edge_e(:)) .NE. nyc+1) &
- call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%edge_w/edge_e', FATAL)
- if(size(atm_grid%edge_s(:)) .NE. nxc+1 .OR. size(atm_grid%edge_n(:)) .NE. nxc+1) &
- call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%edge_s/edge_n', FATAL)
- if(size(atm_grid%en1,1) .NE. 3 .OR. size(atm_grid%en1,2) .NE. nxc .OR. size(atm_grid%en1,3) .NE. nyc+1) &
- call error_mesg( 'xgrid_mod', 'incorrect dimension size of atm_grid%en1', FATAL)
- if(size(atm_grid%en2,1) .NE. 3 .OR. size(atm_grid%en2,2) .NE. nxc+1 .OR. size(atm_grid%en2,3) .NE. nyc) &
- call error_mesg( 'xgrid_mod', 'incorrect dimension size of atm_grid%en2', FATAL)
- if(size(atm_grid%vlon,1) .NE. 3 .OR. size(atm_grid%vlon,2) .NE. nxc .OR. size(atm_grid%vlon,3) .NE. nyc) &
- call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%vlon', FATAL)
- if(size(atm_grid%vlat,1) .NE. 3 .OR. size(atm_grid%vlat,2) .NE. nxc .OR. size(atm_grid%vlat,3) .NE. nyc) &
- call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%vlat', FATAL)
- allocate(grid%box%dx (grid%is_me:grid%ie_me, grid%js_me:grid%je_me+1 ))
- allocate(grid%box%dy (grid%is_me:grid%ie_me+1, grid%js_me:grid%je_me ))
- allocate(grid%box%area (grid%is_me:grid%ie_me, grid%js_me:grid%je_me ))
- allocate(grid%box%edge_w(grid%js_me:grid%je_me+1))
- allocate(grid%box%edge_e(grid%js_me:grid%je_me+1))
- allocate(grid%box%edge_s(grid%is_me:grid%ie_me+1))
- allocate(grid%box%edge_n(grid%is_me:grid%ie_me+1))
- allocate(grid%box%en1 (3, grid%is_me:grid%ie_me, grid%js_me:grid%je_me+1 ))
- allocate(grid%box%en2 (3, grid%is_me:grid%ie_me+1, grid%js_me:grid%je_me ))
- allocate(grid%box%vlon (3, grid%is_me:grid%ie_me, grid%js_me:grid%je_me ))
- allocate(grid%box%vlat (3, grid%is_me:grid%ie_me, grid%js_me:grid%je_me ))
- grid%box%dx = atm_grid%dx
- grid%box%dy = atm_grid%dy
- grid%box%area = atm_grid%area
- grid%box%edge_w = atm_grid%edge_w
- grid%box%edge_e = atm_grid%edge_e
- grid%box%edge_s = atm_grid%edge_s
- grid%box%edge_n = atm_grid%edge_n
- grid%box%en1 = atm_grid%en1
- grid%box%en2 = atm_grid%en2
- grid%box%vlon = atm_grid%vlon
- grid%box%vlat = atm_grid%vlat
- end if
- end if
- end if
-
- if (g>1) then
- if(grid%on_this_pe) then
- if(grid%is_ug) then
- allocate( grid%frac_area(grid%ls_me:grid%le_me, 1, grid%km) )
- else
- allocate( grid%frac_area(grid%is_me:grid%ie_me, grid%js_me:grid%je_me, grid%km) )
- endif
- grid%frac_area = 1.0
- endif
-
- ! load exchange cells, sum grid cell areas, set your1my2/your2my1
- select case(xmap%version)
- case(VERSION1)
- call load_xgrid (xmap, grid, grid_file, grid_ids(1), grid_ids(g), 1, 1, use_higher_order)
- case(VERSION2)
- select case(grid_ids(1))
- case( 'ATM' )
- xgrid_name = 'a'
- case( 'LND' )
- xgrid_name = 'l'
- case( 'WAV' )
- xgrid_name = 'w'
- case default
- call error_mesg('xgrid_mod', 'grid_ids(1) should be ATM, LND or WAV', FATAL)
- end select
- select case(grid_ids(g))
- case( 'LND' )
- xgrid_name = trim(xgrid_name)//'Xl_file'
- case( 'OCN' )
- xgrid_name = trim(xgrid_name)//'Xo_file'
- case( 'WAV' )
- xgrid_name = trim(xgrid_name)//'Xw_file'
- case default
- call error_mesg('xgrid_mod', 'grid_ids(g) should be LND, OCN or WAV', FATAL)
- end select
- ! get the tile list for each mosaic
- call read_data(grid_file, lowercase(grid_ids(1))//'_mosaic_file', mosaic1)
- call read_data(grid_file, lowercase(grid_ids(g))//'_mosaic_file', mosaic2)
- mosaic1 = 'INPUT/'//trim(mosaic1)
- mosaic2 = 'INPUT/'//trim(mosaic2)
- allocate(tile1_list(grid1%ntile), tile2_list(grid%ntile) )
- do j = 1, grid1%ntile
- call read_data(mosaic1, 'gridtiles', tile1_list(j), level=j)
- end do
- do j = 1, grid%ntile
- call read_data(mosaic2, 'gridtiles', tile2_list(j), level=j)
- end do
- if(field_exist(grid_file, xgrid_name)) then
- call field_size(grid_file, xgrid_name, siz)
- nxgrid_file = siz(2)
- ! loop through all the exchange grid file
- do i = 1, nxgrid_file
- call read_data(grid_file, xgrid_name, xgrid_file, level = i)
- xgrid_file = 'INPUT/'//trim(xgrid_file)
- if( .NOT. file_exist(xgrid_file) )call error_mesg('xgrid_mod', &
- 'file '//trim(xgrid_file)//' does not exist, check your xgrid file.', FATAL)
-
- ! find the tile number of side 1 and side 2 mosaic, which is contained in field contact
- call read_data(xgrid_file, "contact", contact)
- i1 = index(contact, ":")
- i2 = index(contact, "::")
- i3 = index(contact, ":", back=.true. )
- if(i1 == 0 .OR. i2 == 0) call error_mesg('xgrid_mod', &
- 'field contact in file '//trim(xgrid_file)//' should contains ":" and "::" ', FATAL)
- if(i1 == i3) call error_mesg('xgrid_mod', &
- 'field contact in file '//trim(xgrid_file)//' should contains two ":"', FATAL)
- tile1_name = contact(i1+1:i2-1)
- tile2_name = contact(i3+1:len_trim(contact))
- tile1 = 0; tile2 = 0
- do j = 1, grid1%ntile
- if( tile1_name == tile1_list(j) ) then
- tile1 = j
- exit
- end if
- end do
- do j = 1, grid%ntile
- if( tile2_name == tile2_list(j) ) then
- tile2 = j
- exit
- end if
- end do
- if(tile1 == 0) call error_mesg('xgrid_mod', &
- trim(tile1_name)//' is not a tile of mosaic '//trim(mosaic1), FATAL)
- if(tile2 == 0) call error_mesg('xgrid_mod', &
- trim(tile2_name)//' is not a tile of mosaic '//trim(mosaic2), FATAL)
-
- call load_xgrid (xmap, grid, xgrid_file, grid_ids(1), grid_ids(g), tile1, tile2, &
- use_higher_order)
- end do
- endif
- deallocate(tile1_list, tile2_list)
- end select
- if(grid%on_this_pe) then
- grid%area_inv = 0.0;
- where (grid%area>0.0) grid%area_inv = 1.0/grid%area
- endif
- end if
- end do
-
- call mpp_clock_end(id_load_xgrid)
-
- grid1%area_inv = 0.0;
- where (grid1%area>0.0)
- grid1%area_inv = 1.0/grid1%area
- end where
-
- xmap%your1my2(xmap%me-xmap%root_pe) = .false. ! this is not necessarily true but keeps
- xmap%your2my1(xmap%me-xmap%root_pe) = .false. ! a PE from communicating with itself
-
- if (make_exchange_reproduce) then
- allocate( xmap%send_count_repro(0:xmap%npes-1) )
- allocate( xmap%recv_count_repro(0:xmap%npes-1) )
- xmap%send_count_repro = 0
- xmap%recv_count_repro = 0
- do g=2,size(xmap%grids(:))
- do p=0,xmap%npes-1
- if(xmap%grids(g)%size >0) &
- xmap%send_count_repro(p) = xmap%send_count_repro(p) &
- +count(xmap%grids(g)%x (:)%pe==p+xmap%root_pe)
- if(xmap%grids(g)%size_repro >0) &
- xmap%recv_count_repro(p) = xmap%recv_count_repro(p) &
- +count(xmap%grids(g)%x_repro(:)%pe==p+xmap%root_pe)
- end do
- end do
- xmap%send_count_repro_tot = sum(xmap%send_count_repro)
- xmap%recv_count_repro_tot = sum(xmap%recv_count_repro)
- else
- xmap%send_count_repro_tot = 0
- xmap%recv_count_repro_tot = 0
- end if
-
- if (xgrid_log) then
- call mpp_open( unit, 'xgrid.out', action=MPP_OVERWR, threading=MPP_MULTI, &
- fileset=MPP_MULTI, nohdrs=.TRUE. )
-
- write( unit,* )xmap%grids(:)%id, ' GRID: PE ', xmap%me, ' #XCELLS=', &
- xmap%grids(2:size(xmap%grids(:)))%size, ' #COMM. PARTNERS=', &
- count(xmap%your1my2), '/', count(xmap%your2my1), &
- pack((/(p+xmap%root_pe,p=0,xmap%npes-1)/), xmap%your1my2), &
- '/', pack((/(p+xmap%root_pe,p=0,xmap%npes-1)/), xmap%your2my1)
- call close_file_use_mpp_io (unit)
- endif
-
- allocate( xmap%x1(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) )
- allocate( xmap%x2(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) )
- allocate( xmap%x1_put(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) )
- allocate( xmap%x2_get(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) )
-
- !--- The following will setup indx to be used in regen
- allocate(xmap%get1, xmap%put1)
- call mpp_clock_begin(id_set_comm)
-
- call set_comm_get1(xmap)
-
- call set_comm_put1(xmap)
-
- if(make_exchange_reproduce) then
- allocate(xmap%get1_repro)
- call set_comm_get1_repro(xmap)
- endif
-
- call mpp_clock_end(id_set_comm)
-
- call mpp_clock_begin(id_regen)
- call regen(xmap)
- call mpp_clock_end(id_regen)
-
- call mpp_clock_begin(id_conservation_check)
-
- if(lnd_ug_id ==0) then
- xxx = conservation_check(grid1%area*0.0+1.0, grid1%id, xmap)
- else
- allocate(tmp_2d(grid1%is_me:grid1%ie_me, grid1%js_me:grid1%je_me))
- tmp_2d = 1.0
- xxx = conservation_check_ug(tmp_2d, grid1%id, xmap)
- deallocate(tmp_2d)
- endif
- write(out_unit,* )"Checked data is array of constant 1"
- write(out_unit,* )grid1%id,'(',xmap%grids(:)%id,')=', xxx
-
- if(lnd_ug_id == 0) then
- do g=2,size(xmap%grids(:))
- xxx = conservation_check(xmap%grids(g)%frac_area*0.0+1.0, xmap%grids(g)%id, xmap )
- write( out_unit,* )xmap%grids(g)%id,'(',xmap%grids(:)%id,')=', xxx
- enddo
- else
- do g=2,size(xmap%grids(:))
- grid => xmap%grids(g)
- allocate(tmp_3d(grid%is_me:grid%ie_me, grid%js_me:grid%je_me,grid%km))
- tmp_3d = 1.0
- xxx = conservation_check_ug(tmp_3d, xmap%grids(g)%id, xmap )
- write( out_unit,* )xmap%grids(g)%id,'(',xmap%grids(:)%id,')=', xxx
- deallocate(tmp_3d)
- enddo
- endif
- ! create an random number 2d array
- if(grid1%id == "ATM") then
- allocate(check_data(size(grid1%area,1), size(grid1%area,2)))
- call random_number(check_data)
-
- !--- second order along both zonal and meridinal direction
- if(lnd_ug_id ==0) then
- xxx = conservation_check(check_data, grid1%id, xmap, remap_method = remapping_method )
- else
- xxx = conservation_check_ug(check_data, grid1%id, xmap, remap_method = remapping_method )
- endif
- write( out_unit,* ) &
- "Checked data is array of random number between 0 and 1 using "//trim(interp_method)
- write( out_unit,* )grid1%id,'(',xmap%grids(:)%id,')=', xxx
-
- deallocate(check_data)
- do g=2,size(xmap%grids(:))
- allocate(check_data_3d(xmap%grids(g)%is_me:xmap%grids(g)%ie_me, &
- xmap%grids(g)%js_me:xmap%grids(g)%je_me, grid1%km))
- call random_number(check_data_3d)
- if(lnd_ug_id ==0) then
- xxx = conservation_check(check_data_3d, xmap%grids(g)%id, xmap, remap_method = remapping_method )
- else
- xxx = conservation_check_ug(check_data_3d, xmap%grids(g)%id, xmap, remap_method = remapping_method )
- endif
- write( out_unit,* )xmap%grids(g)%id,'(',xmap%grids(:)%id,')=', xxx
- deallocate( check_data_3d)
- end do
- endif
- call mpp_clock_end(id_conservation_check)
-
- call mpp_clock_end(id_setup_xmap)
-
-end subroutine setup_xmap_use_mpp_io
-!
-
-!----------------------------------------------------------------------------
-! currently we are assuming there is only one nest region
-function get_nest_contact_use_mpp_io(mosaic_file, tile_nest_out, tile_parent_out, is_nest_out, &
- ie_nest_out, js_nest_out, je_nest_out, is_parent_out, &
- ie_parent_out, js_parent_out, je_parent_out) &
- result(get_nest_contact) !< This is needed for use_mpp_io
-
-character(len=*), intent(in) :: mosaic_file
-integer, intent(out) :: tile_nest_out, tile_parent_out
-integer, intent(out) :: is_nest_out, ie_nest_out
-integer, intent(out) :: js_nest_out, je_nest_out
-integer, intent(out) :: is_parent_out, ie_parent_out
-integer, intent(out) :: js_parent_out, je_parent_out
-integer :: get_nest_contact
-!--- local variables
-integer :: ntiles, ncontacts, n, t1, t2
-integer :: nx1_contact, ny1_contact
-integer :: nx2_contact, ny2_contact
-integer, allocatable, dimension(:) :: nx, ny
-integer, allocatable, dimension(:) :: tile1, tile2
-integer, allocatable, dimension(:) :: istart1, iend1, jstart1, jend1
-integer, allocatable, dimension(:) :: istart2, iend2, jstart2, jend2
-
- tile_nest_out = 0; tile_parent_out = 0
- is_nest_out = 0; ie_nest_out = 0
- js_nest_out = 0; je_nest_out = 0
- is_parent_out = 0; ie_parent_out = 0
- js_parent_out = 0; je_parent_out = 0
- get_nest_contact = 0
-
- ! first read the contact information
- ntiles = get_mosaic_ntiles_use_mpp_io(mosaic_file)
- if( ntiles == 1 ) return
- allocate(nx(ntiles), ny(ntiles))
- call get_mosaic_grid_sizes_use_mpp_io(mosaic_file, nx, ny)
-
- ncontacts = get_mosaic_ncontacts_use_mpp_io(mosaic_file)
- if(ncontacts == 0) return
- allocate(tile1(ncontacts), tile2(ncontacts))
- allocate(istart1(ncontacts), iend1(ncontacts))
- allocate(jstart1(ncontacts), jend1(ncontacts))
- allocate(istart2(ncontacts), iend2(ncontacts))
- allocate(jstart2(ncontacts), jend2(ncontacts))
-
- call get_mosaic_contact_use_mpp_io( mosaic_file, tile1, tile2, istart1, iend1, jstart1, jend1, &
- istart2, iend2, jstart2, jend2)
-
- do n = 1, ncontacts
- if( tile1(n) == tile2(n) ) cycle ! same tile could not be nested
-
- nx1_contact = iend1(n)-istart1(n)+1
- ny1_contact = jend1(n)-jstart1(n)+1
- nx2_contact = iend2(n)-istart2(n)+1
- ny2_contact = jend2(n)-jstart2(n)+1
- t1 = tile1(n);
- t2 = tile2(n);
- ! For nesting, the contact index of one tile must match its global domain
- if( (nx(t1) .NE. nx1_contact .OR. ny(t1) .NE. ny1_contact ) .AND. &
- (nx(t2) .NE. nx2_contact .OR. ny(t2) .NE. ny2_contact ) ) cycle
- if(nx1_contact == nx2_contact .AND. ny1_contact == ny2_contact) then
- call error_mesg('xgrid_mod', 'There is no refinement for the overlapping region', FATAL)
- endif
-
- get_nest_contact = get_nest_contact + 1
- if(get_nest_contact>1) then
- call error_mesg('xgrid_mod', 'only support one nest region, contact developer' ,FATAL)
- endif
- if(nx2_contact*ny2_contact > nx1_contact*ny1_contact) then
- is_nest_out = istart2(n);
- ie_nest_out = iend2 (n);
- js_nest_out = jstart2(n);
- je_nest_out = jend2 (n);
- tile_nest_out = tile2 (n);
- is_parent_out = istart1(n);
- ie_parent_out = iend1 (n);
- js_parent_out = jstart1(n);
- je_parent_out = jend1 (n);
- tile_parent_out = tile1 (n);
- else
- is_nest_out = istart1(n);
- ie_nest_out = iend1 (n);
- js_nest_out = jstart1(n);
- je_nest_out = jend1 (n);
- tile_nest_out = tile1 (n);
- is_parent_out = istart2(n);
- ie_parent_out = iend2 (n);
- js_parent_out = jstart2(n);
- je_parent_out = jend2 (n);
- tile_parent_out = tile2 (n);
- endif
- enddo
-
- deallocate(nx, ny, tile1, tile2)
- deallocate(istart1, iend1, jstart1, jend1)
- deallocate(istart2, iend2, jstart2, jend2)
-
-
- return
-
-end function get_nest_contact_use_mpp_io
-
end module xgrid_mod
!> @}
! close documentation grouping
diff --git a/field_manager/field_manager.F90 b/field_manager/field_manager.F90
index 686549886a..141d85cd8f 100644
--- a/field_manager/field_manager.F90
+++ b/field_manager/field_manager.F90
@@ -189,9 +189,7 @@ module field_manager_mod
mpp_pe, &
mpp_root_pe, &
stdlog, &
- stdout, &
- get_unit
-use mpp_io_mod, only : mpp_io_init
+ stdout
use fms_mod, only : lowercase, &
write_version_number
use fms2_io_mod, only: file_exists
@@ -275,7 +273,7 @@ module field_manager_mod
!> The length of a character string representing the field path.
integer, parameter, public :: fm_path_name_len = 512
!> The length of a character string representing character values for the field.
-integer, parameter, public :: fm_string_len = 128
+integer, parameter, public :: fm_string_len = 1024
!> The length of a character string representing the various types that the values of the field can take.
integer, parameter, public :: fm_type_name_len = 8
!> Number of models (ATMOS, OCEAN, LAND, ICE, COUPLER).
@@ -652,8 +650,6 @@ subroutine field_manager_init(nfields, table_name)
num_fields = 0
call initialize
-call mpp_io_init()
-
if (.not.PRESENT(table_name)) then
tbl_name = 'field_table'
else
@@ -673,8 +669,7 @@ subroutine field_manager_init(nfields, table_name)
return
endif
-iunit = get_unit()
-open(iunit, file=trim(tbl_name), action='READ', iostat=io_status)
+open(newunit=iunit, file=trim(tbl_name), action='READ', iostat=io_status)
if(io_status/=0) call mpp_error(FATAL, 'field_manager_mod: Error in opening file '//trim(tbl_name))
!write_version_number should precede all writes to stdlog from field_manager
call write_version_number("FIELD_MANAGER_MOD", version)
diff --git a/fms/fms.F90 b/fms/fms.F90
index 2755bcfd8e..61f5772e3a 100644
--- a/fms/fms.F90
+++ b/fms/fms.F90
@@ -165,6 +165,7 @@ module fms_mod
use memutils_mod, only: print_memuse_stats, memutils_init
use grid2_mod, only: grid_init, grid_end
+use, intrinsic :: iso_c_binding
implicit none
private
@@ -208,6 +209,7 @@ module fms_mod
public :: CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, &
CLOCK_MODULE_DRIVER, CLOCK_MODULE, &
CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA
+public :: fms_c2f_string
!public from the old fms_io but not exists here
public :: string
@@ -298,6 +300,19 @@ module fms_mod
module procedure string_from_integer
module procedure string_from_real
end interface
+!> C functions
+ interface
+ !> @brief Finds the length of a C-string
+ integer(c_size_t) pure function c_strlen(s) bind(c,name="strlen")
+ import c_size_t, c_ptr
+ type(c_ptr), intent(in), value :: s !< A C-string whose size is desired
+ end function
+ !> @brief Frees a C pointer
+ subroutine c_free(ptr) bind(c,name="free")
+ import c_ptr
+ type(c_ptr), value :: ptr !< A C-pointer to free
+ end subroutine
+ end interface
!> @addtogroup fms_mod
!> @{
@@ -321,23 +336,33 @@ module fms_mod
!! The namelist variable clock_grain must be one of the following values:
!! 'NONE', 'COMPONENT', 'SUBCOMPONENT', 'MODULE_DRIVER', 'MODULE', 'ROUTINE',
!! 'LOOP', or 'INFRA' (case-insensitive).
-subroutine fms_init (localcomm )
+subroutine fms_init (localcomm, alt_input_nml_path)
!--- needed to output the version number of constants_mod to the logfile ---
use constants_mod, only: constants_version=>version !pjp: PI not computed
use fms_io_mod, only: fms_io_version
integer, intent(in), optional :: localcomm
+ character(len=*), intent(in), optional :: alt_input_nml_path
integer :: unit, ierr, io
integer :: logunitnum
+ integer :: stdout_unit !< Unit number for the stdout file
if (module_is_initialized) return ! return silently if already called
module_is_initialized = .true.
!---- initialize mpp routines ----
if(present(localcomm)) then
- call mpp_init(localcomm=localcomm)
+ if(present(alt_input_nml_path)) then
+ call mpp_init(localcomm=localcomm, alt_input_nml_path=alt_input_nml_path)
+ else
+ call mpp_init(localcomm=localcomm)
+ endif
else
- call mpp_init()
+ if(present(alt_input_nml_path)) then
+ call mpp_init(alt_input_nml_path=alt_input_nml_path)
+ else
+ call mpp_init()
+ endif
endif
call mpp_domains_init()
call fms_io_init()
@@ -352,19 +377,8 @@ subroutine fms_init (localcomm )
call nml_error_init() ! first initialize namelist iostat error codes
-#ifdef INTERNAL_FILE_NML
- read (input_nml_file, fms_nml, iostat=io)
- ierr = check_nml_error(io,'fms_nml')
-#else
- if (file_exist('input.nml')) then
- unit = open_namelist_file ( )
- ierr=1; do while (ierr /= 0)
- read (unit, nml=fms_nml, iostat=io, end=10)
- ierr = check_nml_error(io,'fms_nml') ! also initializes nml error codes
- enddo
- 10 call mpp_close (unit)
- endif
-#endif
+ read (input_nml_file, fms_nml, iostat=io)
+ ierr = check_nml_error(io,'fms_nml')
!---- define mpp stack sizes if non-zero -----
@@ -423,9 +437,9 @@ subroutine fms_init (localcomm )
call write_version_number("FMS_MOD", version)
if (mpp_pe() == mpp_root_pe()) then
- unit = stdlog()
- write (unit, nml=fms_nml)
- write (unit,*) 'nml_error_codes=', nml_error_codes(1:num_nml_error_codes)
+ stdout_unit = stdlog()
+ write (stdout_unit, nml=fms_nml)
+ write (stdout_unit,*) 'nml_error_codes=', nml_error_codes(1:num_nml_error_codes)
endif
call memutils_init( print_memory_usage )
@@ -541,17 +555,10 @@ end function fms_error_handler
!! routine check_nml_error will return zero and the while loop will exit.
!! This code segment should be used to read namelist files.
!! @code{.F90}
- !! integer :: unit, ierr, io
+ !! integer :: ierr, io
!!
- !! if ( file_exist('input.nml') ) then
- !! unit = open_namelist_file ( )
- !! ierr=1
- !! do while (ierr > 0)
- !! read (unit, nml=moist_processes_nml, iostat=io)
- !! ierr = check_nml_error(io,'moist_processes_nml')
- !! enddo
- !! call close_file (unit)
- !! endif
+ !! read (input_nml_file, fms_nml, iostat=io)
+ !! ierr = check_nml_error(io,'fms_nml')
!! @endcode
!! @throws FATAL, Unknown error while reading namelist ...., (IOSTAT = ####)
!! There was an error reading the namelist specified. Carefully examine all namelist and variables
@@ -805,6 +812,27 @@ function string_from_real(a)
end function string_from_real
+!> \brief Converts a C-string returned from a TYPE(C_PTR) function to
+!! a fortran string with type character.
+function fms_c2f_string (cstring) result(fstring)
+ type (c_ptr) :: cstring
+ character(len=:), allocatable :: fstring !< The fortran string returned
+ character(len=:,kind=c_char), pointer :: string_buffer !< A temporary pointer to between C and Fortran
+ integer(c_size_t) :: length !< The string length
+ integer :: i
+
+ length = c_strlen(cstring)
+ allocate (character(len=length, kind=c_char) :: string_buffer)
+ block
+ character(len=length,kind=c_char), pointer :: s
+ call c_f_pointer(cstring,s) ! Recovers a view of the C string
+ string_buffer = s ! Copies the string contents
+ end block
+
+ allocate(character(len=length) :: fstring) !> Set the length of fstring
+fstring = string_buffer
+
+end function fms_c2f_string
!#######################################################################
!> @brief Prints to the log file (or a specified unit) the version id string and
!! tag name.
diff --git a/fms/fms_io.F90 b/fms/fms_io.F90
index b2f67c460f..f135e53730 100644
--- a/fms/fms_io.F90
+++ b/fms/fms_io.F90
@@ -137,7 +137,7 @@ module fms_io_mod
integer, parameter, private :: max_fields=400
integer, parameter, private :: max_axes=40
integer, parameter, private :: max_atts=20
-integer, parameter, private :: max_domains = 10
+integer, parameter, private :: max_domains = 100
integer, parameter, private :: MAX_TIME_LEVEL_REGISTER = 2
integer, parameter, private :: MAX_TIME_LEVEL_WRITE = 20
integer, parameter :: max_axis_size=10000
@@ -683,19 +683,10 @@ subroutine fms_io_init()
if (module_is_initialized) return
call mpp_io_init()
-#ifdef INTERNAL_FILE_NML
read (input_nml_file, fms_io_nml, iostat=io_status)
if (io_status > 0) then
- call mpp_error(FATAL,'=>fms_io_init: Error reading input.nml')
- endif
-#else
- call mpp_open(unit, 'input.nml',form=MPP_ASCII,action=MPP_RDONLY)
- read(unit,fms_io_nml,iostat=io_status)
- if (io_status > 0) then
- call mpp_error(FATAL,'=>fms_io_init: Error reading input.nml')
+ call mpp_error(FATAL,'=>fms_io_init: Error reading input nml file')
endif
- call mpp_close (unit)
-#endif
! take namelist options if present
@@ -721,8 +712,9 @@ subroutine fms_io_init()
end select
! Initially allocate files_write and files_read
- allocate(files_write(max_files_w),files_read(max_files_r))
- allocate(registered_file(max_files_w))
+ if (.not. allocated(files_write) ) allocate(files_write(max_files_w))
+ if (.not. allocated(files_read) ) allocate(files_read(max_files_r))
+ if (.not. allocated(registered_file)) allocate(registered_file(max_files_w))
do i = 1, max_domains
array_domain(i) = NULL_DOMAIN2D
@@ -7904,11 +7896,12 @@ end subroutine get_mosaic_tile_file_ug
!#############################################################################
- subroutine get_mosaic_tile_grid(grid_file, mosaic_file, domain, tile_count)
+ subroutine get_mosaic_tile_grid(grid_file, mosaic_file, domain, tile_count, custom_path)
character(len=*), intent(out) :: grid_file
character(len=*), intent(in) :: mosaic_file
type(domain2D), intent(in) :: domain
integer, intent(in), optional :: tile_count
+ character(len=*), intent(in), optional :: custom_path
integer :: tile, ntileMe
integer, dimension(:), allocatable :: tile_id
@@ -7918,7 +7911,11 @@ subroutine get_mosaic_tile_grid(grid_file, mosaic_file, domain, tile_count)
allocate(tile_id(ntileMe))
tile_id = mpp_get_tile_id(domain)
call read_data(mosaic_file, "gridfiles", grid_file, level=tile_id(tile) )
- grid_file = 'INPUT/'//trim(grid_file)
+ if (.not. present(custom_path)) then
+ grid_file = 'INPUT/'//trim(grid_file)
+ else
+ grid_file = trim(custom_path)//'/'//trim(grid_file)
+ endif
deallocate(tile_id)
end subroutine get_mosaic_tile_grid
diff --git a/fms2_io/Makefile.am b/fms2_io/Makefile.am
index 2e746a2f84..c186d76678 100644
--- a/fms2_io/Makefile.am
+++ b/fms2_io/Makefile.am
@@ -47,7 +47,6 @@ libfms2_io_la_SOURCES = \
include/array_utils.inc \
include/compressed_write.inc \
include/domain_read.inc \
- include/get_checksum.inc \
include/get_global_attribute.inc \
include/netcdf_add_restart_variable.inc \
include/netcdf_write_data.inc \
@@ -61,7 +60,7 @@ libfms2_io_la_SOURCES = \
fms2_io_mod.$(FC_MODEXT): fms_io_utils_mod.$(FC_MODEXT) netcdf_io_mod.$(FC_MODEXT) fms_netcdf_domain_io_mod.$(FC_MODEXT) \
fms_netcdf_unstructured_domain_io_mod.$(FC_MODEXT) blackboxio.$(FC_MODEXT)
fms_io_utils_mod.$(FC_MODEXT): include/array_utils.inc include/array_utils_char.inc \
- include/get_data_type_string.inc include/get_checksum.inc
+ include/get_data_type_string.inc
netcdf_io_mod.$(FC_MODEXT): fms_io_utils_mod.$(FC_MODEXT) include/netcdf_add_restart_variable.inc include/netcdf_read_data.inc \
include/netcdf_write_data.inc include/register_global_attribute.inc \
include/register_variable_attribute.inc include/get_global_attribute.inc \
diff --git a/fms2_io/blackboxio.F90 b/fms2_io/blackboxio.F90
index 04472555d8..dbe1cb4cb7 100644
--- a/fms2_io/blackboxio.F90
+++ b/fms2_io/blackboxio.F90
@@ -149,7 +149,7 @@ function create_diskless_netcdf_file(fileobj, pelist, path) &
fileobj%is_diskless = .true.
cmode = ior(nf90_noclobber, nf90_classic_model)
cmode = ior(cmode, nf90_diskless)
- if (fms2_ncchksz == -1) call error("create_diskless_netcdf_file :: fms2_ncchksz not set.")
+ if (fms2_ncchksz == -1) call error("create_diskless_netcdf_file :: fms2_ncchksz not set. Call fms2_io init first")
err = nf90_create(trim(fileobj%path), cmode, fileobj%ncid, chunksize=fms2_ncchksz)
success = err .eq. nf90_noerr
if (.not. success) then
@@ -190,48 +190,50 @@ subroutine copy_metadata(fileobj, new_fileobj)
integer(kind=i4_kind), dimension(:), allocatable :: buf_int
real(kind=r4_kind), dimension(:), allocatable :: buf_float
real(kind=r8_kind), dimension(:), allocatable :: buf_double
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+ append_error_msg = "copy_metadata: original file:"//trim(fileobj%path)//" new file:"//trim(new_fileobj%path)
if (fileobj%is_root .and. .not. new_fileobj%is_readonly) then
!Copy global attributes to the new file.
call set_netcdf_mode(fileobj%ncid, define_mode)
call set_netcdf_mode(new_fileobj%ncid, define_mode)
err = nf90_inquire(fileobj%ncid, nattributes=natt)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
do i = 1, natt
err = nf90_inq_attname(fileobj%ncid, nf90_global, i, n)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
err = nf90_copy_att(fileobj%ncid, nf90_global, n, new_fileobj%ncid, nf90_global)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
enddo
!Copy the dimensions to the new file.
err = nf90_inquire(fileobj%ncid, ndimensions=ndim)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
err = nf90_inquire(fileobj%ncid, unlimiteddimid=ulim_dimid)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
do i = 1, ndim
err = nf90_inquire_dimension(fileobj%ncid, i, dimnames(i), dimlens(i))
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
if (i .eq. ulim_dimid) then
err = nf90_def_dim(new_fileobj%ncid, dimnames(i), nf90_unlimited, dimids(i))
ulim_dimid = dimids(i)
else
err = nf90_def_dim(new_fileobj%ncid, dimnames(i), dimlens(i), dimids(i))
endif
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
enddo
!Copy the variables to the new file.
err = nf90_inquire(fileobj%ncid, nvariables=nvar)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
do i = 1, nvar
err = nf90_inquire_variable(fileobj%ncid, i, varname, xtype, varndim, d, natt)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
!Map to new dimension ids.
do j = 1, varndim
err = nf90_inquire_dimension(fileobj%ncid, d(j), n)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
do k = 1, ndim
if (string_compare(n, dimnames(k))) then
d(j) = dimids(k)
@@ -242,7 +244,7 @@ subroutine copy_metadata(fileobj, new_fileobj)
!Define variable in new file.
err = nf90_def_var(new_fileobj%ncid, varname, xtype, d(1:varndim), varid)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
!If the variable is an "axis", copy its data to the new file.
if (varndim .eq. 1 .and. d(1) .ne. ulim_dimid) then
@@ -253,25 +255,27 @@ subroutine copy_metadata(fileobj, new_fileobj)
if (xtype .eq. nf90_int) then
allocate(buf_int(dimlens(k)))
err = nf90_get_var(fileobj%ncid, i, buf_int)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
err = nf90_put_var(new_fileobj%ncid, varid, buf_int)
deallocate(buf_int)
elseif (xtype .eq. nf90_float) then
allocate(buf_float(dimlens(k)))
err = nf90_get_var(fileobj%ncid, i, buf_float)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
err = nf90_put_var(new_fileobj%ncid, varid, buf_float)
deallocate(buf_float)
elseif (xtype .eq. nf90_double) then
allocate(buf_double(dimlens(k)))
err = nf90_get_var(fileobj%ncid, i, buf_double)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
err = nf90_put_var(new_fileobj%ncid, varid, buf_double)
deallocate(buf_double)
else
- call error("this branch should not be reached.")
+ call error(append_error_msg//" "//trim(varname)//" has an unsupported type, "&
+ "only nf90_int, nf90_float, and nf90_double are currently supported")
+
endif
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
call set_netcdf_mode(fileobj%ncid, define_mode)
call set_netcdf_mode(new_fileobj%ncid, define_mode)
exit
@@ -282,9 +286,9 @@ subroutine copy_metadata(fileobj, new_fileobj)
!Copy variable attributes to the new file.
do j = 1, natt
err = nf90_inq_attname(fileobj%ncid, i, j, n)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
err = nf90_copy_att(fileobj%ncid, i, n, new_fileobj%ncid, varid)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
enddo
enddo
endif
@@ -462,7 +466,7 @@ function create_diskless_domain_file(fileobj, domain, path) &
io_domain => mpp_get_io_domain(domain)
if (.not. associated(io_domain)) then
- call error("input domain does not have an io_domain.")
+ call error("The domain associated with the file: "//trim(fileobj%path)//" does not have an io_domain.")
endif
pelist_size = mpp_get_domain_npes(io_domain)
allocate(pelist(pelist_size))
@@ -603,7 +607,7 @@ function create_diskless_unstructured_domain_file(fileobj, domain, path) &
io_domain => mpp_get_ug_io_domain(domain)
if (.not. associated(io_domain)) then
- call error("input domain does not have an io_domain.")
+ call error("The domain associated with the file: "//trim(fileobj%path)//" does have an io_domain.")
endif
pelist_size = mpp_get_ug_domain_npes(io_domain)
allocate(pelist(pelist_size))
diff --git a/fms2_io/fms2_io.F90 b/fms2_io/fms2_io.F90
index ce01f0739c..d82be39148 100644
--- a/fms2_io/fms2_io.F90
+++ b/fms2_io/fms2_io.F90
@@ -104,6 +104,7 @@ module fms2_io_mod
public :: get_instance_filename
public :: nullify_filename_appendix
public :: string2
+public :: flush_file
!> @}
!> @brief Opens a given netcdf or domain file.
diff --git a/fms2_io/fms_io_utils.F90 b/fms2_io/fms_io_utils.F90
index d7c911d1d5..5d8898c3af 100644
--- a/fms2_io/fms_io_utils.F90
+++ b/fms2_io/fms_io_utils.F90
@@ -55,7 +55,6 @@ module fms_io_utils_mod
public :: put_array_section
public :: get_array_section
public :: get_data_type_string
-public :: get_checksum
public :: string2
public :: open_check
public :: string_compare
@@ -188,16 +187,6 @@ module fms_io_utils_mod
module procedure get_data_type_string_5d
end interface get_data_type_string
-!> @ingroup fms_io_utils_mod
-interface get_checksum
- module procedure get_checksum_0d
- module procedure get_checksum_1d
- module procedure get_checksum_2d
- module procedure get_checksum_3d
- module procedure get_checksum_4d
- module procedure get_checksum_5d
-end interface get_checksum
-
!> @addtogroup fms_io_utils_mod
!> @{
contains
@@ -402,11 +391,11 @@ subroutine domain_tile_filepath_mangle(dest, source, domain_tile_id)
integer :: i
if (has_domain_tile_string(source)) then
- call error("this file has already had a domain tile id added.")
+ call error("The file "//trim(source)//" has a domain tile id (tileX) added. Check your open_file call")
endif
i = index(trim(source), ".nc", back=.true.)
if (i .eq. 0) then
- call error("file "//trim(source)//" does not contain .nc")
+ call error("The file "//trim(source)//" does not contain .nc. Check your open_file call")
endif
write(dest, '(a,i0,a)') source(1:i-1)//".tile", &
domain_tile_id, source(i:len_trim(source))
@@ -448,7 +437,7 @@ subroutine io_domain_tile_filepath_mangle(dest, source, io_domain_tile_id)
integer, intent(in) :: io_domain_tile_id !< I/O domain tile id.
if (has_io_domain_tile_string(source)) then
- call error("this file has already had a domain tile id added.")
+ call error("The file "//trim(source)//" has already had a domain tile id (.nc.XXXX) added. Check your open_file call.")
endif
write(dest,'(a,i4.4)') trim(source)//".", io_domain_tile_id
end subroutine io_domain_tile_filepath_mangle
@@ -483,7 +472,7 @@ subroutine restart_filepath_mangle(dest, source)
else
i = index(trim(source), ".nc", back=.true.)
if (i .eq. 0) then
- call error("file "//trim(source)//" does not contain .nc")
+ call error("The file "//trim(source)//" does not contain .nc. Check your open_file call")
endif
endif
call string_copy(dest, source(1:i-1)//".res"//source(i:len_trim(source)))
@@ -505,15 +494,20 @@ end subroutine open_check
!> @brief Read the ascii text from filename `ascii_filename`into string array
!! `ascii_var`
-subroutine ascii_read(ascii_filename, ascii_var)
+subroutine ascii_read(ascii_filename, ascii_var, num_lines, max_length)
character(len=*), intent(in) :: ascii_filename !< The file name to be read
character(len=:), dimension(:), allocatable, intent(out) :: ascii_var !< The
!! string
!! array
+ integer, optional, intent(out) :: num_lines !< Optional argument to return number of lines in file
+ integer, optional, intent(out) :: max_length !< Optional argument to return max_length of line in file
integer, dimension(2) :: lines_and_length !< lines = 1, length = 2
+ if(allocated(ascii_var)) deallocate(ascii_var)
lines_and_length = get_ascii_file_num_lines_and_length(ascii_filename)
allocate(character(len=lines_and_length(2))::ascii_var(lines_and_length(1)))
call read_ascii_file(ascii_filename, lines_and_length(2), ascii_var)
+ if(present(num_lines)) num_lines = lines_and_length(1)
+ if(present(max_length)) max_length = lines_and_length(2)
end subroutine ascii_read
!> @brief Populate 2D maskmap from mask_table given a model
@@ -735,7 +729,7 @@ subroutine get_mosaic_tile_file_sg(file_in, file_out, is_no_domain, domain, tile
else
lens = len_trim(file_in)
if(file_in(lens-2:lens) .NE. '.nc') call mpp_error(FATAL, &
- 'fms_io_mod: .nc should be at the end of file '//trim(file_in))
+ 'get_mosaic_tile_file_sg: .nc should be at the end of file '//trim(file_in))
basefile = file_in(1:lens-3)
end if
@@ -916,7 +910,6 @@ end function string_from_real2
include "array_utils.inc"
include "array_utils_char.inc"
include "get_data_type_string.inc"
-include "get_checksum.inc"
end module fms_io_utils_mod
diff --git a/fms2_io/fms_netcdf_domain_io.F90 b/fms2_io/fms_netcdf_domain_io.F90
index af8c870de9..e39cd9028e 100644
--- a/fms2_io/fms_netcdf_domain_io.F90
+++ b/fms2_io/fms_netcdf_domain_io.F90
@@ -376,7 +376,7 @@ function open_domain_file(fileobj, path, mode, domain, nc_format, is_restart, do
!Get the path of a "distributed" file.
io_domain => mpp_get_io_domain(domain)
if (.not. associated(io_domain)) then
- call error("input domain does not have an io_domain.")
+ call error("The domain associated with the file:"//trim(fileobj%path)//" does not have an io_domain.")
endif
if (io_layout(1)*io_layout(2) .gt. 1) then
tile_id = mpp_get_tile_id(io_domain)
@@ -400,7 +400,7 @@ function open_domain_file(fileobj, path, mode, domain, nc_format, is_restart, do
success2 = netcdf_file_open(fileobj2, combined_filepath, mode, nc_format, pelist, &
is_restart, dont_add_res_to_filename)
if (success2) then
- call error("you have both combined and distributed files.")
+ call error("The domain decomposed file:"//trim(fileobj%path)//" contains both combined (*.nc) and distributed files (*.nc.XXXX).")
endif
endif
else
@@ -467,23 +467,26 @@ subroutine register_domain_decomposed_dimension(fileobj, dim_name, xory, domain_
io_domain => mpp_get_io_domain(fileobj%domain)
if (string_compare(xory, x, .true.)) then
if (dpos .ne. center .and. dpos .ne. east) then
- call error("only center or east supported for x dimensions.")
+ call error("Only domain_position=center or domain_position=EAST is supported for x dimensions. Fix your register_axis call for file:"&
+ &//trim(fileobj%path)//" and dimension:"//trim(dim_name))
endif
call mpp_get_global_domain(io_domain, xsize=domain_size, position=dpos)
call append_domain_decomposed_dimension(dim_name, dpos, fileobj%xdims, fileobj%nx)
elseif (string_compare(xory, y, .true.)) then
if (dpos .ne. center .and. dpos .ne. north) then
- call error("only center or north supported for y dimensions.")
+ call error("Only domain_position=center or domain_position=NORTH is supported for y dimensions. Fix your register_axis call for file:"&
+ &//trim(fileobj%path)//" and dimension:"//trim(dim_name))
endif
call mpp_get_global_domain(io_domain, ysize=domain_size, position=dpos)
call append_domain_decomposed_dimension(dim_name, dpos, fileobj%ydims, fileobj%ny)
else
- call error("unrecognized xory flag value.")
+ call error("The register_axis call for file:"//trim(fileobj%path)//" and dimension:"//trim(dim_name)//" has an unrecognized xory flag value:"&
+ &//trim(xory)//" only 'x' and 'y' are allowed.")
endif
if (fileobj%is_readonly .or. (fileobj%mode_is_append .and. dimension_exists(fileobj, dim_name))) then
call get_dimension_size(fileobj, dim_name, dim_size, broadcast=.true.)
if (dim_size .lt. domain_size) then
- call error("dimension "//trim(dim_name)//" is smaller than the size of" &
+ call error("dimension "//trim(dim_name)//" in the file "//trim(fileobj%path)//" is smaller than the size of" &
//" the associated domain "//trim(xory)//" axis.")
endif
else
@@ -567,7 +570,7 @@ subroutine save_domain_restart(fileobj, unlim_dim_level)
logical :: is_decomposed
if (.not. fileobj%is_restart) then
- call error("file "//trim(fileobj%path)//" is not a restart file.")
+ call error("file "//trim(fileobj%path)//" is not a restart file. You must set is_restart=.true. in your open_file call.")
endif
! Calculate the variable's checksum and write it to the netcdf file
@@ -635,7 +638,7 @@ subroutine restore_domain_state(fileobj, unlim_dim_level)
logical :: is_decomposed
if (.not. fileobj%is_restart) then
- call error("file "//trim(fileobj%path)//" is not a restart file.")
+ call error("file "//trim(fileobj%path)//" is not a restart file. You must set is_restart=.true. in your open_file call.")
endif
do i = 1, fileobj%num_restart_vars
if (associated(fileobj%restart_vars(i)%data0d)) then
@@ -654,7 +657,9 @@ subroutine restore_domain_state(fileobj, unlim_dim_level)
call get_variable_attribute(fileobj, fileobj%restart_vars(i)%varname, &
"checksum", chksum_in_file)
if (.not. string_compare(trim(adjustl(chksum_in_file)), trim(adjustl(chksum)))) then
- call error("checksum attribute does not match data in file.")
+ call error("The checksum in the file:"//trim(fileobj%path)//" and variable:"//trim(fileobj%restart_vars(i)%varname)//&
+ &" does not match the checksum calculated from the data. file:"//trim(adjustl(chksum_in_file))//&
+ &" from data:"//trim(adjustl(chksum)))
endif
endif
elseif (associated(fileobj%restart_vars(i)%data3d)) then
@@ -667,7 +672,9 @@ subroutine restore_domain_state(fileobj, unlim_dim_level)
call get_variable_attribute(fileobj, fileobj%restart_vars(i)%varname, &
"checksum", chksum_in_file(1:len(chksum_in_file)))
if (.not. string_compare(trim(adjustl(chksum_in_file)), trim(adjustl(chksum)))) then
- call error("checksum attribute does not match data in file.")
+ call error("The checksum in the file:"//trim(fileobj%path)//" and variable:"//trim(fileobj%restart_vars(i)%varname)//&
+ &" does not match the checksum calculated from the data. file:"//trim(adjustl(chksum_in_file))//&
+ &" from data:"//trim(adjustl(chksum)))
endif
endif
elseif (associated(fileobj%restart_vars(i)%data4d)) then
@@ -680,11 +687,14 @@ subroutine restore_domain_state(fileobj, unlim_dim_level)
call get_variable_attribute(fileobj, fileobj%restart_vars(i)%varname, &
"checksum", chksum_in_file)
if (.not. string_compare(trim(adjustl(chksum_in_file)), trim(adjustl(chksum)))) then
- call error("checksum attribute does not match data in file.")
+ call error("The checksum in the file:"//trim(fileobj%path)//" and variable:"//trim(fileobj%restart_vars(i)%varname)//&
+ &" does not match the checksum calculated from the data. file:"//trim(adjustl(chksum_in_file))//&
+ &" from data:"//trim(adjustl(chksum)))
endif
endif
else
- call error("this branch should not be reached.")
+ call error("There is no data associated with the variable: "//trim(fileobj%restart_vars(i)%varname)//&
+ &" and the file: "//trim(fileobj%path)//". Check your register_restart_variable call")
endif
enddo
end subroutine restore_domain_state
@@ -714,7 +724,7 @@ subroutine get_compute_domain_dimension_indices(fileobj, dimname, indices)
dpos = fileobj%ydims(dpos)%pos
call mpp_get_compute_domain(io_domain, ybegin=s, yend=e, position=dpos)
else
- call error("input dimension is not associated with the domain.")
+ call error("get_compute_domain_dimension_indices: the input dimension:"//trim(dimname)//" is not domain decomposed.")
endif
endif
if (allocated(indices)) then
@@ -732,7 +742,7 @@ end subroutine get_compute_domain_dimension_indices
subroutine domain_offsets(data_xsize, data_ysize, domain, xpos, ypos, &
isd, isc, xc_size, jsd, jsc, yc_size, &
buffer_includes_halos, extra_x_point, &
- extra_y_point)
+ extra_y_point, msg)
integer, intent(in) :: data_xsize !< Size of buffer's domain "x" dimension.
integer, intent(in) :: data_ysize !< Size of buffer's domain "y" dimension.
@@ -746,8 +756,9 @@ subroutine domain_offsets(data_xsize, data_ysize, domain, xpos, ypos, &
integer, intent(out) :: jsc !< Starting index for y dimension of compute domain.
integer, intent(out) :: yc_size !< Size of y dimension of compute domain.
logical, intent(out) :: buffer_includes_halos !< Flag telling if input buffer includes space for halos.
- logical, intent(out), optional :: extra_x_point !<
- logical, intent(out), optional :: extra_y_point !<
+ logical, intent(out), optional :: extra_x_point !< Flag indicating if data_array has an extra point in x
+ logical, intent(out), optional :: extra_y_point !< Flag indicating if data_array has an extra point in y
+ character(len=*), intent(in), optional :: msg !< Message appended to fatal error
integer :: xd_size
integer :: yd_size
@@ -789,8 +800,10 @@ subroutine domain_offsets(data_xsize, data_ysize, domain, xpos, ypos, &
buffer_includes_halos = (data_xsize .eq. xd_size) .and. (data_ysize .eq. yd_size)
if (.not. buffer_includes_halos .and. data_xsize .ne. xc_size .and. data_ysize &
.ne. yc_size) then
- call error("size of x dimension of input buffer does not match size" &
- //" of x dimension of data or compute domain.")
+ print *, "buffer_includes_halos:", buffer_includes_halos, " data_xsize:", &
+ data_xsize, " xc_size:", xc_size, " data_ysize:", data_ysize, " yc_size:", &
+ yc_size
+ call error(trim(msg)//" The data is not on the compute domain or the data domain")
endif
end subroutine domain_offsets
@@ -820,7 +833,8 @@ subroutine get_global_io_domain_indices(fileobj, dimname, is, ie, indices)
dpos = fileobj%ydims(dpos)%pos
call mpp_get_global_domain(io_domain, ybegin=is, yend=ie, position=dpos)
else
- call error("input dimension is not associated with the domain.")
+ call error("get_global_io_domain_indices: the dimension "//trim(dimname)//" in the file: "//trim(fileobj%path)//&
+ &" is not domain decomposed. Check your register_axis call")
endif
endif
diff --git a/fms2_io/fms_netcdf_unstructured_domain_io.F90 b/fms2_io/fms_netcdf_unstructured_domain_io.F90
index a83a0ef227..fe52b3c953 100644
--- a/fms2_io/fms_netcdf_unstructured_domain_io.F90
+++ b/fms2_io/fms_netcdf_unstructured_domain_io.F90
@@ -105,7 +105,7 @@ function open_unstructured_domain_file(fileobj, path, mode, domain, nc_format, &
!Get the input domain's I/O domain pelist.
io_domain => mpp_get_ug_io_domain(domain)
if (.not. associated(io_domain)) then
- call error("input domain does not have an io_domain.")
+ call error("The input domain associated with the file:"//trim(fileobj%path)//" does not have an io_domain.")
endif
pelist_size = mpp_get_ug_domain_npes(io_domain)
allocate(pelist(pelist_size))
diff --git a/fms2_io/include/compressed_write.inc b/fms2_io/include/compressed_write.inc
index 4ee1620fc9..28a47ab47b 100644
--- a/fms2_io/include/compressed_write.inc
+++ b/fms2_io/include/compressed_write.inc
@@ -46,8 +46,6 @@ subroutine compressed_write_0d(fileobj, variable_name, cdata, unlim_dim_level, &
call netcdf_write_data(fileobj, variable_name, cdata, &
unlim_dim_level=unlim_dim_level, corner=corner)
return
- else
- call error("this branch should never be reached.")
endif
end subroutine compressed_write_0d
@@ -106,6 +104,10 @@ subroutine compressed_write_1d(fileobj, variable_name, cdata, unlim_dim_level, &
real(kind=r4_kind), dimension(:), allocatable :: buf_r4_kind
real(kind=r8_kind), dimension(:), allocatable :: buf_r8_kind
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "compressed_write_1d: file:"//trim(fileobj%path)//" variable:"//trim(variable_name)
+
compressed_dim_index = get_variable_compressed_dimension_index(fileobj, variable_name)
if (compressed_dim_index(1) .eq. dimension_not_found) then
@@ -157,7 +159,7 @@ subroutine compressed_write_1d(fileobj, variable_name, cdata, unlim_dim_level, &
edge_lengths=e)
deallocate(buf_r8_kind)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: "//trim(append_error_msg))
end select
endif
enddo
@@ -172,7 +174,7 @@ subroutine compressed_write_1d(fileobj, variable_name, cdata, unlim_dim_level, &
type is (real(kind=r8_kind))
call mpp_send(cdata, size(cdata), fileobj%io_root)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: "//trim(append_error_msg))
end select
call mpp_sync_self(check=EVENT_SEND)
endif
@@ -211,6 +213,9 @@ subroutine compressed_write_2d(fileobj, variable_name, cdata, unlim_dim_level, &
integer(kind=i8_kind), dimension(:,:), allocatable :: buf_i8_kind
real(kind=r4_kind), dimension(:,:), allocatable :: buf_r4_kind
real(kind=r8_kind), dimension(:,:), allocatable :: buf_r8_kind
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "compressed_write_2d: file:"//trim(fileobj%path)//" variable:"//trim(variable_name)
compressed_dim_index = get_variable_compressed_dimension_index(fileobj, variable_name)
if (compressed_dim_index(1) .eq. dimension_not_found) then
@@ -262,7 +267,7 @@ subroutine compressed_write_2d(fileobj, variable_name, cdata, unlim_dim_level, &
edge_lengths=e)
deallocate(buf_r8_kind)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: "//trim(append_error_msg))
end select
endif
enddo
@@ -277,7 +282,7 @@ subroutine compressed_write_2d(fileobj, variable_name, cdata, unlim_dim_level, &
type is (real(kind=r8_kind))
call mpp_send(cdata, size(cdata), fileobj%io_root)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: "//trim(append_error_msg))
end select
call mpp_sync_self(check=EVENT_SEND)
endif
@@ -316,6 +321,9 @@ subroutine compressed_write_3d(fileobj, variable_name, cdata, unlim_dim_level, &
integer(kind=i8_kind), dimension(:,:,:), allocatable :: buf_i8_kind
real(kind=r4_kind), dimension(:,:,:), allocatable :: buf_r4_kind
real(kind=r8_kind), dimension(:,:,:), allocatable :: buf_r8_kind
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "compressed_write_3d: file:"//trim(fileobj%path)//" variable:"//trim(variable_name)
compressed_dim_index = get_variable_compressed_dimension_index(fileobj, variable_name)
if (compressed_dim_index(1) .eq. dimension_not_found) then
@@ -367,7 +375,7 @@ subroutine compressed_write_3d(fileobj, variable_name, cdata, unlim_dim_level, &
edge_lengths=e)
deallocate(buf_r8_kind)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: "//trim(append_error_msg))
end select
endif
enddo
@@ -382,7 +390,7 @@ subroutine compressed_write_3d(fileobj, variable_name, cdata, unlim_dim_level, &
type is (real(kind=r8_kind))
call mpp_send(cdata, size(cdata), fileobj%io_root)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: "//trim(append_error_msg))
end select
call mpp_sync_self(check=EVENT_SEND)
endif
@@ -421,6 +429,9 @@ subroutine compressed_write_4d(fileobj, variable_name, cdata, unlim_dim_level, &
integer(kind=i8_kind), dimension(:,:,:,:), allocatable :: buf_i8_kind
real(kind=r4_kind), dimension(:,:,:,:), allocatable :: buf_r4_kind
real(kind=r8_kind), dimension(:,:,:,:), allocatable :: buf_r8_kind
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "compressed_write_4d: file:"//trim(fileobj%path)//" variable:"//trim(variable_name)
compressed_dim_index = get_variable_compressed_dimension_index(fileobj, variable_name)
if (compressed_dim_index(1) .eq. dimension_not_found) then
@@ -472,7 +483,7 @@ subroutine compressed_write_4d(fileobj, variable_name, cdata, unlim_dim_level, &
edge_lengths=e)
deallocate(buf_r8_kind)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: "//trim(append_error_msg))
end select
endif
enddo
@@ -487,7 +498,7 @@ subroutine compressed_write_4d(fileobj, variable_name, cdata, unlim_dim_level, &
type is (real(kind=r8_kind))
call mpp_send(cdata, size(cdata), fileobj%io_root)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: "//trim(append_error_msg))
end select
call mpp_sync_self(check=EVENT_SEND)
endif
@@ -526,6 +537,9 @@ subroutine compressed_write_5d(fileobj, variable_name, cdata, unlim_dim_level, &
integer(kind=i8_kind), dimension(:,:,:,:,:), allocatable :: buf_i8_kind
real(kind=r4_kind), dimension(:,:,:,:,:), allocatable :: buf_r4_kind
real(kind=r8_kind), dimension(:,:,:,:,:), allocatable :: buf_r8_kind
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "compressed_write_5d: file:"//trim(fileobj%path)//" variable:"//trim(variable_name)
compressed_dim_index = get_variable_compressed_dimension_index(fileobj, variable_name)
if (compressed_dim_index(1) .eq. dimension_not_found) then
@@ -577,7 +591,7 @@ subroutine compressed_write_5d(fileobj, variable_name, cdata, unlim_dim_level, &
edge_lengths=e)
deallocate(buf_r8_kind)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: "//trim(append_error_msg))
end select
endif
enddo
@@ -592,7 +606,7 @@ subroutine compressed_write_5d(fileobj, variable_name, cdata, unlim_dim_level, &
type is (real(kind=r8_kind))
call mpp_send(cdata, size(cdata), fileobj%io_root)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: "//trim(append_error_msg))
end select
call mpp_sync_self(check=EVENT_SEND)
endif
diff --git a/fms2_io/include/compute_global_checksum.inc b/fms2_io/include/compute_global_checksum.inc
index b90eb2c441..7b72b3db26 100644
--- a/fms2_io/include/compute_global_checksum.inc
+++ b/fms2_io/include/compute_global_checksum.inc
@@ -66,7 +66,8 @@ function compute_global_checksum_2d(fileobj, variable_name, variable_data, is_de
io_domain => mpp_get_io_domain(fileobj%domain)
call domain_offsets(size(variable_data, xdim), size(variable_data, ydim), fileobj%domain, &
xpos, ypos, isd, isc, xc_size, jsd, jsc, &
- yc_size, buffer_includes_halos, extra_x, extra_y)
+ yc_size, buffer_includes_halos, extra_x, extra_y, &
+ msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name))
c(:) = 1
if (buffer_includes_halos) then
!Adjust if the input buffer has room for halos.
@@ -127,7 +128,7 @@ function compute_global_checksum_2d(fileobj, variable_name, variable_data, is_de
endif
deallocate(buf_r8_kind)
class default
- call error("Compute_global_checksum: unsupported type.")
+ call error("unsupported variable type: compute_global_checksum_2d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
chksum = ""
write(chksum, "(Z16)") chksum_val
@@ -181,7 +182,8 @@ function compute_global_checksum_3d(fileobj, variable_name, variable_data, is_de
io_domain => mpp_get_io_domain(fileobj%domain)
call domain_offsets(size(variable_data, xdim), size(variable_data, ydim), fileobj%domain, &
xpos, ypos, isd, isc, xc_size, jsd, jsc, &
- yc_size, buffer_includes_halos, extra_x, extra_y)
+ yc_size, buffer_includes_halos, extra_x, extra_y, &
+ msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name))
c(:) = 1
if (buffer_includes_halos) then
!Adjust if the input buffer has room for halos.
@@ -241,7 +243,7 @@ function compute_global_checksum_3d(fileobj, variable_name, variable_data, is_de
endif
deallocate(buf_r8_kind)
class default
- call error("Compute_global_checksum: unsupported type.")
+ call error("unsupported variable type: compute_global_checksum_3d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
chksum = ""
write(chksum, "(Z16)") chksum_val
@@ -295,7 +297,8 @@ function compute_global_checksum_4d(fileobj, variable_name, variable_data, is_de
io_domain => mpp_get_io_domain(fileobj%domain)
call domain_offsets(size(variable_data, xdim), size(variable_data, ydim), fileobj%domain, &
xpos, ypos, isd, isc, xc_size, jsd, jsc, &
- yc_size, buffer_includes_halos, extra_x, extra_y)
+ yc_size, buffer_includes_halos, extra_x, extra_y, &
+ msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name))
c(:) = 1
if (buffer_includes_halos) then
!Adjust if the input buffer has room for halos.
@@ -356,7 +359,7 @@ function compute_global_checksum_4d(fileobj, variable_name, variable_data, is_de
endif
deallocate(buf_r8_kind)
class default
- call error("Compute_global_checksum: unsupported type.")
+ call error("unsupported variable type: compute_global_checksum_4d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
chksum = ""
write(chksum, "(Z16)") chksum_val
diff --git a/fms2_io/include/domain_read.inc b/fms2_io/include/domain_read.inc
index 9ac3fb8be8..6aad3628a7 100644
--- a/fms2_io/include/domain_read.inc
+++ b/fms2_io/include/domain_read.inc
@@ -135,7 +135,8 @@ subroutine domain_read_2d(fileobj, variable_name, vdata, unlim_dim_level, &
endif
io_domain => mpp_get_io_domain(fileobj%domain)
call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, &
- xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos)
+ xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos, &
+ msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name))
c(:) = 1
e(:) = shape(vdata)
@@ -252,7 +253,7 @@ subroutine domain_read_2d(fileobj, variable_name, vdata, unlim_dim_level, &
endif
deallocate(buf_r8_kind)
class default
- call error("domain_read_2d: Unsupported type for variable: "//variable_name//" in file: "//trim(fileobj%path)//"")
+ call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
enddo
deallocate(pe_isc)
@@ -288,7 +289,7 @@ subroutine domain_read_2d(fileobj, variable_name, vdata, unlim_dim_level, &
call put_array_section(buf_r8_kind, vdata, c, e)
deallocate(buf_r8_kind)
class default
- call error("domain_read_2d: Unsupported type for variable: "//variable_name//" in file: "//trim(fileobj%path)//"")
+ call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
endif
end subroutine domain_read_2d
@@ -353,7 +354,8 @@ subroutine domain_read_3d(fileobj, variable_name, vdata, unlim_dim_level, &
endif
io_domain => mpp_get_io_domain(fileobj%domain)
call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, &
- xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos)
+ xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos, &
+ msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name))
c(:) = 1
e(:) = shape(vdata)
@@ -470,7 +472,7 @@ subroutine domain_read_3d(fileobj, variable_name, vdata, unlim_dim_level, &
endif
deallocate(buf_r8_kind)
class default
- call error("domain_read_3d: Unsupported type for variable: "//variable_name//" in file: "//trim(fileobj%path)//"")
+ call error("unsupported variable type: domain_read_3d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
enddo
deallocate(pe_isc)
@@ -506,7 +508,7 @@ subroutine domain_read_3d(fileobj, variable_name, vdata, unlim_dim_level, &
call put_array_section(buf_r8_kind, vdata, c, e)
deallocate(buf_r8_kind)
class default
- call error("domain_read_3d: Unsupported type for variable: "//variable_name//" in file: "//trim(fileobj%path)//"")
+ call error("unsupported variable type: domain_read_3d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
endif
end subroutine domain_read_3d
@@ -571,7 +573,8 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, &
endif
io_domain => mpp_get_io_domain(fileobj%domain)
call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, &
- xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos)
+ xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos, &
+ msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name))
c(:) = 1
e(:) = shape(vdata)
@@ -688,7 +691,7 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, &
endif
deallocate(buf_r8_kind)
class default
- call error("domain_read_4d: Unsupported type for variable: "//variable_name//" in file: "//trim(fileobj%path)//"")
+ call error("unsupported variable type: domain_read_4d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
enddo
deallocate(pe_isc)
@@ -724,7 +727,7 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, &
call put_array_section(buf_r8_kind, vdata, c, e)
deallocate(buf_r8_kind)
class default
- call error("domain_read_4d: Unsupported type for variable: "//variable_name//" in file: "//trim(fileobj%path)//"")
+ call error("unsupported variable type: domain_read_4d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
endif
end subroutine domain_read_4d
@@ -789,7 +792,8 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, &
endif
io_domain => mpp_get_io_domain(fileobj%domain)
call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, &
- xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos)
+ xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos, &
+ msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name))
c(:) = 1
e(:) = shape(vdata)
@@ -908,7 +912,7 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, &
endif
deallocate(buf_r8_kind)
class default
- call error("domain_read_5d: Unsupported type for variable: "//variable_name//" in file: "//trim(fileobj%path)//"")
+ call error("unsupported variable type: domain_read_5d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
enddo
deallocate(pe_isc)
@@ -944,7 +948,7 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, &
call put_array_section(buf_r8_kind, vdata, c, e)
deallocate(buf_r8_kind)
class default
- call error("domain_read_5d: Unsupported type for variable: "//variable_name//" in file: "//trim(fileobj%path)//"")
+ call error("unsupported variable type: domain_read_5d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
endif
end subroutine domain_read_5d
diff --git a/fms2_io/include/domain_write.inc b/fms2_io/include/domain_write.inc
index 8540ad60f3..72be263ab4 100644
--- a/fms2_io/include/domain_write.inc
+++ b/fms2_io/include/domain_write.inc
@@ -144,7 +144,7 @@ subroutine domain_write_2d(fileobj, variable_name, vdata, unlim_dim_level, &
io_domain => mpp_get_io_domain(fileobj%domain)
call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, &
xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, &
- buffer_includes_halos)
+ buffer_includes_halos, msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name))
c(:) = 1
e(:) = shape(vdata)
@@ -198,7 +198,7 @@ subroutine domain_write_2d(fileobj, variable_name, vdata, unlim_dim_level, &
global_buf_r8_kind = fill_r8_kind
endif
class default
- call error("unsupported type.")
+ call error("unsupported variable type: domain_write_2d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
do i = 1, size(fileobj%pelist)
@@ -361,7 +361,7 @@ subroutine domain_write_2d(fileobj, variable_name, vdata, unlim_dim_level, &
call mpp_sync_self(check=event_send)
deallocate(buf_r8_kind)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: domain_write_2d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
endif
end subroutine domain_write_2d
@@ -438,7 +438,7 @@ subroutine domain_write_3d(fileobj, variable_name, vdata, unlim_dim_level, &
io_domain => mpp_get_io_domain(fileobj%domain)
call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, &
xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, &
- buffer_includes_halos)
+ buffer_includes_halos, msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name))
c(:) = 1
e(:) = shape(vdata)
@@ -492,7 +492,7 @@ subroutine domain_write_3d(fileobj, variable_name, vdata, unlim_dim_level, &
global_buf_r8_kind = fill_r8_kind
endif
class default
- call error("unsupported type.")
+ call error("unsupported variable type: domain_write_3d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
do i = 1, size(fileobj%pelist)
@@ -655,7 +655,7 @@ subroutine domain_write_3d(fileobj, variable_name, vdata, unlim_dim_level, &
call mpp_sync_self(check=event_send)
deallocate(buf_r8_kind)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: domain_write_3d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
endif
end subroutine domain_write_3d
@@ -732,7 +732,7 @@ subroutine domain_write_4d(fileobj, variable_name, vdata, unlim_dim_level, &
io_domain => mpp_get_io_domain(fileobj%domain)
call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, &
xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, &
- buffer_includes_halos)
+ buffer_includes_halos, msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name))
c(:) = 1
e(:) = shape(vdata)
@@ -786,7 +786,7 @@ subroutine domain_write_4d(fileobj, variable_name, vdata, unlim_dim_level, &
global_buf_r8_kind = fill_r8_kind
endif
class default
- call error("unsupported type.")
+ call error("unsupported variable type: domain_write_4d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
do i = 1, size(fileobj%pelist)
@@ -949,7 +949,7 @@ subroutine domain_write_4d(fileobj, variable_name, vdata, unlim_dim_level, &
call mpp_sync_self(check=event_send)
deallocate(buf_r8_kind)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: domain_write_4d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
endif
end subroutine domain_write_4d
@@ -1026,7 +1026,7 @@ subroutine domain_write_5d(fileobj, variable_name, vdata, unlim_dim_level, &
io_domain => mpp_get_io_domain(fileobj%domain)
call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, &
xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, &
- buffer_includes_halos)
+ buffer_includes_halos, msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name))
c(:) = 1
e(:) = shape(vdata)
@@ -1080,7 +1080,7 @@ subroutine domain_write_5d(fileobj, variable_name, vdata, unlim_dim_level, &
global_buf_r8_kind = fill_r8_kind
endif
class default
- call error("unsupported type.")
+ call error("unsupported variable type: domain_write_5d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
do i = 1, size(fileobj%pelist)
@@ -1243,7 +1243,7 @@ subroutine domain_write_5d(fileobj, variable_name, vdata, unlim_dim_level, &
call mpp_sync_self(check=event_send)
deallocate(buf_r8_kind)
class default
- call error("unsupported type.")
+ call error("unsupported variable type: domain_write_5d: file: "//trim(fileobj%path)//" variable:"//trim(variable_name))
end select
endif
end subroutine domain_write_5d
diff --git a/fms2_io/include/get_checksum.inc b/fms2_io/include/get_checksum.inc
deleted file mode 100644
index 12b2fb736d..0000000000
--- a/fms2_io/include/get_checksum.inc
+++ /dev/null
@@ -1,159 +0,0 @@
-!***********************************************************************
-!* GNU Lesser General Public License
-!*
-!* This file is part of the GFDL Flexible Modeling System (FMS).
-!*
-!* FMS is free software: you can redistribute it and/or modify it under
-!* the terms of the GNU Lesser General Public License as published by
-!* the Free Software Foundation, either version 3 of the License, or (at
-!* your option) any later version.
-!*
-!* FMS is distributed in the hope that it will be useful, but WITHOUT
-!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
-!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-!* for more details.
-!*
-!* You should have received a copy of the GNU Lesser General Public
-!* License along with FMS. If not, see .
-!***********************************************************************
-!> @file
-!> @ingroup fms_io_utils_mod
-
-!> @brief Given a data array, return a string containing the mpp_checksum
-!! in hex.
-function get_checksum_0d(data) result(chksum)
-
- class(*), intent(in) :: data !< Data to be checksummed.
- character(len=16) :: chksum
-
- integer,dimension(1) :: myrank
-
- myrank(1) = mpp_pe()
- chksum = ""
- select type(data)
- type is (integer(i4_kind))
-! write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (integer(i8_kind))
-! write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r4_kind))
-! write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r8_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- end select
-
-end function get_checksum_0d
-!> @brief Given a data array, return a string containing the mpp_checksum
-!! in hex.
-function get_checksum_1d(data) result(chksum)
-
- class(*), dimension(:), intent(in) :: data !< Data to be checksummed.
- character(len=16) :: chksum
-
- integer,dimension(1) :: myrank
-
- myrank(1) = mpp_pe()
- chksum = ""
- select type(data)
- type is (integer(i4_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (integer(i8_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r4_kind))
-! write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r8_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- end select
-
-end function get_checksum_1d
-!> @brief Given a data array, return a string containing the mpp_checksum
-!! in hex.
-function get_checksum_2d(data) result(chksum)
-
- class(*), dimension(:,:), intent(in) :: data !< Data to be checksummed.
- character(len=16) :: chksum
-
- integer,dimension(1) :: myrank
-
- myrank(1) = mpp_pe()
- chksum = ""
- select type(data)
- type is (integer(i4_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (integer(i8_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r4_kind))
-! write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r8_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- end select
-
-end function get_checksum_2d
-!> @brief Given a data array, return a string containing the mpp_checksum
-!! in hex.
-function get_checksum_3d(data) result(chksum)
-
- class(*), dimension(:,:,:), intent(in) :: data !< Data to be checksummed.
- character(len=16) :: chksum
-
- integer,dimension(1) :: myrank
-
- myrank(1) = mpp_pe()
- chksum = ""
- select type(data)
- type is (integer(i4_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (integer(i8_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r4_kind))
-! write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r8_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- end select
-
-end function get_checksum_3d
-!> @brief Given a data array, return a string containing the mpp_checksum
-!! in hex.
-function get_checksum_4d(data) result(chksum)
-
- class(*), dimension(:,:,:,:), intent(in) :: data !< Data to be checksummed.
- character(len=16) :: chksum
-
- integer,dimension(1) :: myrank
-
- myrank(1) = mpp_pe()
- chksum = ""
- select type(data)
- type is (integer(i4_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (integer(i8_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r4_kind))
-! write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r8_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- end select
-
-end function get_checksum_4d
-!> @brief Given a data array, return a string containing the mpp_checksum
-!! in hex.
-function get_checksum_5d(data) result(chksum)
-
- class(*), dimension(:,:,:,:,:), intent(in) :: data !< Data to be checksummed.
- character(len=16) :: chksum
-
- integer,dimension(1) :: myrank
-
- myrank(1) = mpp_pe()
- chksum = ""
- select type(data)
- type is (integer(i4_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (integer(i8_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r4_kind))
-! write(chksum, "(Z16)") mpp_chksum(data, myrank)
- type is (real(r8_kind))
- write(chksum, "(Z16)") mpp_chksum(data, myrank)
- end select
-
-end function get_checksum_5d
diff --git a/fms2_io/include/get_global_attribute.inc b/fms2_io/include/get_global_attribute.inc
index c7aaddd535..170571e1cb 100644
--- a/fms2_io/include/get_global_attribute.inc
+++ b/fms2_io/include/get_global_attribute.inc
@@ -50,6 +50,9 @@ subroutine get_global_attribute_0d(fileobj, &
trim(attribute_name), &
attribute_value)
type is (integer(kind=i8_kind))
+ if ( .not. fileobj%allow_int8) call error(trim(fileobj%path)//": 64 bit integers are only supported with 'netcdf4' file format"//&
+ &". Set netcdf_default_format='netcdf4' in the fms2_io namelist OR "//&
+ &"add nc_format='netcdf4' to your open_file call")
err = nf90_get_att(fileobj%ncid, &
nf90_global, &
trim(attribute_name), &
@@ -68,7 +71,7 @@ subroutine get_global_attribute_0d(fileobj, &
call error("get_global_attribute_0d: unsupported type for "//&
&trim(attribute_name)//" for file: "//trim(fileobj%path)//"")
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "get_global_attribute_0d: file:"//trim(fileobj%path)//"- attribute:"//trim(attribute_name))
endif
if (present(broadcast)) then
if (.not. broadcast) then
@@ -129,6 +132,9 @@ subroutine get_global_attribute_1d(fileobj, &
trim(attribute_name), &
attribute_value)
type is (integer(kind=i8_kind))
+ if ( .not. fileobj%allow_int8) call error(trim(fileobj%path)//": 64 bit integers are only supported with 'netcdf4' file format"//&
+ &". Set netcdf_default_format='netcdf4' in the fms2_io namelist OR "//&
+ &"add nc_format='netcdf4' to your open_file call")
err = nf90_get_att(fileobj%ncid, &
nf90_global, &
trim(attribute_name), &
@@ -147,7 +153,7 @@ subroutine get_global_attribute_1d(fileobj, &
call error("get_global_attribute_1d: unsupported type for "//&
&trim(attribute_name)//" for file: "//trim(fileobj%path)//"")
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "get_global_attribute_1d: file:"//trim(fileobj%path)//"- attribute:"//trim(attribute_name))
endif
if (present(broadcast)) then
if (.not. broadcast) then
diff --git a/fms2_io/include/get_variable_attribute.inc b/fms2_io/include/get_variable_attribute.inc
index 08b9e15d6e..c1fc5a2e47 100644
--- a/fms2_io/include/get_variable_attribute.inc
+++ b/fms2_io/include/get_variable_attribute.inc
@@ -39,6 +39,7 @@ subroutine get_variable_attribute_0d(fileobj, variable_name, attribute_name, &
integer :: varid
integer :: err
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
integer :: j
character(len=1024), dimension(1) :: charbuf !< 1D Character buffer
logical :: reproduce_null_char_bug !< Local flag indicating to reproduce the mpp_io bug where
@@ -48,8 +49,11 @@ subroutine get_variable_attribute_0d(fileobj, variable_name, attribute_name, &
reproduce_null_char_bug = .false.
if (present(reproduce_null_char_bug_flag)) reproduce_null_char_bug=reproduce_null_char_bug_flag
+ append_error_msg = "get_variable_attribute_0d: file:"//trim(fileobj%path)//"- variable:"//&
+ &trim(variable_name)//" attribute: "//trim(attribute_name)
+
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(attribute_value)
type is (character(len=*))
err = nf90_get_att(fileobj%ncid, varid, trim(attribute_name), charbuf(1))
@@ -61,15 +65,18 @@ subroutine get_variable_attribute_0d(fileobj, variable_name, attribute_name, &
type is (integer(kind=i4_kind))
err = nf90_get_att(fileobj%ncid, varid, trim(attribute_name), attribute_value)
type is (integer(kind=i8_kind))
+ if ( .not. fileobj%allow_int8) call error(trim(fileobj%path)//": 64 bit integers are only supported with 'netcdf4' file format"//&
+ &". Set netcdf_default_format='netcdf4' in the fms2_io namelist OR "//&
+ &"add nc_format='netcdf4' to your open_file call")
err = nf90_get_att(fileobj%ncid, varid, trim(attribute_name), attribute_value)
type is (real(kind=r4_kind))
err = nf90_get_att(fileobj%ncid, varid, trim(attribute_name), attribute_value)
type is (real(kind=r8_kind))
err = nf90_get_att(fileobj%ncid, varid, trim(attribute_name), attribute_value)
class default
- call error("unsupported type.")
+ call error("unsupported attribute type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
if (present(broadcast)) then
if (.not. broadcast) then
@@ -93,7 +100,7 @@ subroutine get_variable_attribute_0d(fileobj, variable_name, attribute_name, &
type is (real(kind=r8_kind))
call mpp_broadcast(attribute_value, fileobj%io_root, pelist=fileobj%pelist)
class default
- call error("unsupported type.")
+ call error("unsupported attribute type: "//trim(append_error_msg))
end select
end subroutine get_variable_attribute_0d
@@ -115,22 +122,29 @@ subroutine get_variable_attribute_1d(fileobj, variable_name, attribute_name, &
integer :: varid
integer :: err
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "get_variable_attribute_1d: file:"//trim(fileobj%path)//"- variable:"//&
+ &trim(variable_name)//" attribute: "//trim(attribute_name)
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(attribute_value)
type is (integer(kind=i4_kind))
err = nf90_get_att(fileobj%ncid, varid, trim(attribute_name), attribute_value)
type is (integer(kind=i8_kind))
+ if ( .not. fileobj%allow_int8) call error(trim(fileobj%path)//": 64 bit integers are only supported with 'netcdf4' file format"//&
+ &". Set netcdf_default_format='netcdf4' in the fms2_io namelist OR "//&
+ &"add nc_format='netcdf4' to your open_file call")
err = nf90_get_att(fileobj%ncid, varid, trim(attribute_name), attribute_value)
type is (real(kind=r4_kind))
err = nf90_get_att(fileobj%ncid, varid, trim(attribute_name), attribute_value)
type is (real(kind=r8_kind))
err = nf90_get_att(fileobj%ncid, varid, trim(attribute_name), attribute_value)
class default
- call error("unsupported type.")
+ call error("unsupported attribute type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
if (present(broadcast)) then
if (.not. broadcast) then
@@ -151,6 +165,6 @@ subroutine get_variable_attribute_1d(fileobj, variable_name, attribute_name, &
call mpp_broadcast(attribute_value, size(attribute_value), fileobj%io_root, &
pelist=fileobj%pelist)
class default
- call error("unsupported type.")
+ call error("unsupported attribute type: "//trim(append_error_msg))
end select
end subroutine get_variable_attribute_1d
diff --git a/fms2_io/include/netcdf_read_data.inc b/fms2_io/include/netcdf_read_data.inc
index dcbd8014ea..ece05d11c8 100644
--- a/fms2_io/include/netcdf_read_data.inc
+++ b/fms2_io/include/netcdf_read_data.inc
@@ -47,6 +47,9 @@ subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, &
integer, dimension(:), allocatable :: dimsizes
integer :: i
character(len=1024), dimension(1) :: buf1d
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_read_data_0d: file:"//trim(fileobj%path)//"- variable:"//trim(variable_name)
if (present(broadcast)) then
bcast = broadcast
@@ -58,12 +61,12 @@ subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, &
unlim_dim_index = get_variable_unlimited_dimension_index(fileobj, variable_name, &
broadcast=bcast)
if (unlim_dim_index .ne. 1) then
- call error("unlimited dimension must be the slowest varying dimension.")
+ call error("unlimited dimension must be the slowest varying dimension: "//trim(append_error_msg))
endif
c(unlim_dim_index) = unlim_dim_level
endif
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(buf)
type is (integer(kind=i4_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c)
@@ -86,11 +89,11 @@ subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, &
endif
dimsizes(2) = 1
elseif (ndims .gt. 2) then
- call error("Only scalar and 1d string values are currently supported.")
+ call error("Only scalar and 1d string values are currently supported: "//trim(append_error_msg))
endif
err = nf90_get_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes)
if (len(buf) .lt. dimsizes(1)) then
- call error("character buffer is too small; increase length.")
+ call error("character buffer is too small; increase length: "//trim(append_error_msg))
endif
buf = ""
do i = 1, dimsizes(1)
@@ -102,9 +105,9 @@ subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, &
deallocate(charbuf)
deallocate(dimsizes)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
if (bcast) then
select type(buf)
@@ -121,7 +124,7 @@ subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, &
call mpp_broadcast(buf1d, len(buf1d(1)), fileobj%io_root, pelist=fileobj%pelist)
call string_copy(buf, buf1d(1))
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
endif
end subroutine netcdf_read_data_0d
@@ -165,6 +168,9 @@ subroutine netcdf_read_data_1d(fileobj, variable_name, buf, unlim_dim_level, &
character(len=1024) :: sbuf
integer :: i
integer :: j
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_read_data_1d: file:"//trim(fileobj%path)//"- variable:"//trim(variable_name)
if (present(broadcast)) then
bcast = broadcast
@@ -185,12 +191,12 @@ subroutine netcdf_read_data_1d(fileobj, variable_name, buf, unlim_dim_level, &
unlim_dim_index = get_variable_unlimited_dimension_index(fileobj, variable_name, &
broadcast=bcast)
if (unlim_dim_index .ne. 2) then
- call error("unlimited dimension must be the slowest varying dimension.")
+ call error("unlimited dimension must be the slowest varying dimension: "//trim(append_error_msg))
endif
c(unlim_dim_index) = unlim_dim_level
endif
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(buf)
type is (integer(kind=i4_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
@@ -213,10 +219,10 @@ subroutine netcdf_read_data_1d(fileobj, variable_name, buf, unlim_dim_level, &
charbuf(:,:) = ""
err = nf90_get_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes)
if (len(buf(1)) .lt. dimsizes(1)) then
- call error("character buffer is too small; increase length.")
+ call error("character buffer is too small; increase length: "//trim(append_error_msg))
endif
if (size(buf) .lt. dimsizes(2)) then
- call error("incorrect buffer array size.")
+ call error("incorrect buffer array size:: "//trim(append_error_msg))
endif
do i = start(2), start(2)+dimsizes(2)-1
sbuf = ""
@@ -230,9 +236,9 @@ subroutine netcdf_read_data_1d(fileobj, variable_name, buf, unlim_dim_level, &
enddo
deallocate(charbuf)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
if (bcast) then
select type(buf)
@@ -247,7 +253,7 @@ subroutine netcdf_read_data_1d(fileobj, variable_name, buf, unlim_dim_level, &
type is (character(len=*))
call mpp_broadcast(buf, len(buf(1)), fileobj%io_root, pelist=fileobj%pelist)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
endif
end subroutine netcdf_read_data_1d
@@ -284,6 +290,9 @@ subroutine netcdf_read_data_2d(fileobj, variable_name, buf, unlim_dim_level, &
integer :: unlim_dim_index
integer, dimension(3) :: c
integer, dimension(3) :: e
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_read_data_2d: file:"//trim(fileobj%path)//"- variable:"//trim(variable_name)
if (present(broadcast)) then
bcast = broadcast
@@ -304,12 +313,12 @@ subroutine netcdf_read_data_2d(fileobj, variable_name, buf, unlim_dim_level, &
unlim_dim_index = get_variable_unlimited_dimension_index(fileobj, variable_name, &
broadcast=bcast)
if (unlim_dim_index .ne. 3) then
- call error("unlimited dimension must be the slowest varying dimension.")
+ call error("unlimited dimension must be the slowest varying dimension: "//trim(append_error_msg))
endif
c(unlim_dim_index) = unlim_dim_level
endif
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(buf)
type is (integer(kind=i4_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
@@ -320,9 +329,9 @@ subroutine netcdf_read_data_2d(fileobj, variable_name, buf, unlim_dim_level, &
type is (real(kind=r8_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
if (bcast) then
select type(buf)
@@ -335,7 +344,7 @@ subroutine netcdf_read_data_2d(fileobj, variable_name, buf, unlim_dim_level, &
type is (real(kind=r8_kind))
call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
endif
end subroutine netcdf_read_data_2d
@@ -372,6 +381,9 @@ subroutine netcdf_read_data_3d(fileobj, variable_name, buf, unlim_dim_level, &
integer :: unlim_dim_index
integer, dimension(4) :: c
integer, dimension(4) :: e
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_read_data_3d: file:"//trim(fileobj%path)//"- variable:"//trim(variable_name)
if (present(broadcast)) then
bcast = broadcast
@@ -392,12 +404,12 @@ subroutine netcdf_read_data_3d(fileobj, variable_name, buf, unlim_dim_level, &
unlim_dim_index = get_variable_unlimited_dimension_index(fileobj, variable_name, &
broadcast=bcast)
if (unlim_dim_index .ne. 4) then
- call error("unlimited dimension must be the slowest varying dimension.")
+ call error("unlimited dimension must be the slowest varying dimension: "//trim(append_error_msg))
endif
c(unlim_dim_index) = unlim_dim_level
endif
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(buf)
type is (integer(kind=i4_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
@@ -408,9 +420,9 @@ subroutine netcdf_read_data_3d(fileobj, variable_name, buf, unlim_dim_level, &
type is (real(kind=r8_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
if (bcast) then
select type(buf)
@@ -423,7 +435,7 @@ subroutine netcdf_read_data_3d(fileobj, variable_name, buf, unlim_dim_level, &
type is (real(kind=r8_kind))
call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
endif
end subroutine netcdf_read_data_3d
@@ -460,6 +472,9 @@ subroutine netcdf_read_data_4d(fileobj, variable_name, buf, unlim_dim_level, &
integer :: unlim_dim_index
integer, dimension(5) :: c
integer, dimension(5) :: e
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_read_data_4d: file:"//trim(fileobj%path)//"- variable:"//trim(variable_name)
if (present(broadcast)) then
bcast = broadcast
@@ -480,12 +495,12 @@ subroutine netcdf_read_data_4d(fileobj, variable_name, buf, unlim_dim_level, &
unlim_dim_index = get_variable_unlimited_dimension_index(fileobj, variable_name, &
broadcast=bcast)
if (unlim_dim_index .ne. 5) then
- call error("unlimited dimension must be the slowest varying dimension.")
+ call error("unlimited dimension must be the slowest varying dimension: "//trim(append_error_msg))
endif
c(unlim_dim_index) = unlim_dim_level
endif
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(buf)
type is (integer(kind=i4_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
@@ -496,9 +511,9 @@ subroutine netcdf_read_data_4d(fileobj, variable_name, buf, unlim_dim_level, &
type is (real(kind=r8_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
if (bcast) then
select type(buf)
@@ -511,7 +526,7 @@ subroutine netcdf_read_data_4d(fileobj, variable_name, buf, unlim_dim_level, &
type is (real(kind=r8_kind))
call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
endif
end subroutine netcdf_read_data_4d
@@ -548,6 +563,9 @@ subroutine netcdf_read_data_5d(fileobj, variable_name, buf, unlim_dim_level, &
integer :: unlim_dim_index
integer, dimension(6) :: c
integer, dimension(6) :: e
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_read_data_5d: file:"//trim(fileobj%path)//"- variable:"//trim(variable_name)
if (present(broadcast)) then
bcast = broadcast
@@ -568,12 +586,12 @@ subroutine netcdf_read_data_5d(fileobj, variable_name, buf, unlim_dim_level, &
unlim_dim_index = get_variable_unlimited_dimension_index(fileobj, variable_name, &
broadcast=bcast)
if (unlim_dim_index .ne. 6) then
- call error("unlimited dimension must be the slowest varying dimension.")
+ call error("unlimited dimension must be the slowest varying dimension: "//trim(append_error_msg))
endif
c(unlim_dim_index) = unlim_dim_level
endif
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(buf)
type is (integer(kind=i4_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
@@ -584,9 +602,9 @@ subroutine netcdf_read_data_5d(fileobj, variable_name, buf, unlim_dim_level, &
type is (real(kind=r8_kind))
err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
if (bcast) then
select type(buf)
@@ -599,7 +617,7 @@ subroutine netcdf_read_data_5d(fileobj, variable_name, buf, unlim_dim_level, &
type is (real(kind=r8_kind))
call mpp_broadcast(buf, size(buf), fileobj%io_root, pelist=fileobj%pelist)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
endif
end subroutine netcdf_read_data_5d
diff --git a/fms2_io/include/netcdf_write_data.inc b/fms2_io/include/netcdf_write_data.inc
index 2065ee37d0..865672b674 100644
--- a/fms2_io/include/netcdf_write_data.inc
+++ b/fms2_io/include/netcdf_write_data.inc
@@ -42,7 +42,9 @@ subroutine netcdf_write_data_0d(fileobj, variable_name, variable_data, unlim_dim
character, dimension(:), allocatable :: charbuf
integer :: i
integer :: tlen
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+ append_error_msg = "netcdf_write_data_0d: file:"//trim(fileobj%path)//" variable: "//trim(variable_name)
if (fileobj%is_root) then
c(:) = 1
if (present(corner)) then
@@ -52,12 +54,12 @@ subroutine netcdf_write_data_0d(fileobj, variable_name, variable_data, unlim_dim
unlim_dim_index = get_variable_unlimited_dimension_index(fileobj, variable_name, &
broadcast=.false.)
if (unlim_dim_index .ne. 1) then
- call error("unlimited dimension must be the slowest varying dimension.")
+ call error("unlimited dimension must be the slowest varying dimension: "//trim(append_error_msg))
endif
c(unlim_dim_index) = unlim_dim_level
endif
call set_netcdf_mode(fileobj%ncid, data_mode)
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(variable_data)
type is (integer(kind=i4_kind))
err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c)
@@ -70,7 +72,7 @@ subroutine netcdf_write_data_0d(fileobj, variable_name, variable_data, unlim_dim
type is (character(len=*))
ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.)
if (ndims .ne. 1) then
- call error("currently only scalar and 1d character writes are supported.")
+ call error("currently only scalar and 1d character writes are supported: "//trim(append_error_msg))
endif
allocate(start(ndims))
start(:) = 1
@@ -80,7 +82,7 @@ subroutine netcdf_write_data_0d(fileobj, variable_name, variable_data, unlim_dim
charbuf(:) = ""
tlen = len_trim(variable_data)
if (tlen .gt. dimsizes(1)) then
- call error("character buffer is too big; decrease length.")
+ call error("character buffer is too big; decrease length: "//trim(append_error_msg))
endif
do i = 1, tlen
charbuf(i) = variable_data(i:i)
@@ -90,9 +92,9 @@ subroutine netcdf_write_data_0d(fileobj, variable_name, variable_data, unlim_dim
deallocate(dimsizes)
deallocate(start)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
end subroutine netcdf_write_data_0d
@@ -127,6 +129,9 @@ subroutine netcdf_write_data_1d(fileobj, variable_name, variable_data, unlim_dim
integer :: i
integer :: j
integer :: tlen
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_write_data_1d: file:"//trim(fileobj%path)//" variable: "//trim(variable_name)
if (fileobj%is_root) then
c(:) = 1
@@ -143,12 +148,12 @@ subroutine netcdf_write_data_1d(fileobj, variable_name, variable_data, unlim_dim
unlim_dim_index = get_variable_unlimited_dimension_index(fileobj, variable_name, &
broadcast=.false.)
if (unlim_dim_index .ne. 2) then
- call error("unlimited dimension must be the slowest varying dimension.")
+ call error("unlimited dimension must be the slowest varying dimension: "//trim(append_error_msg))
endif
c(unlim_dim_index) = unlim_dim_level
endif
call set_netcdf_mode(fileobj%ncid, data_mode)
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(variable_data)
type is (integer(kind=i4_kind))
err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c, count=e)
@@ -161,7 +166,7 @@ subroutine netcdf_write_data_1d(fileobj, variable_name, variable_data, unlim_dim
type is (character(len=*))
ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.)
if (ndims .ne. 2) then
- call error("currently only scalar and 1d character writes are supported.")
+ call error("currently only scalar and 1d character writes are supported: "//trim(append_error_msg))
endif
allocate(start(ndims))
start(:) = 1
@@ -171,10 +176,10 @@ subroutine netcdf_write_data_1d(fileobj, variable_name, variable_data, unlim_dim
charbuf(:,:) = ""
tlen = len(variable_data(1))
if (tlen .gt. dimsizes(1)) then
- call error("character buffer is too big; decrease length.")
+ call error("character buffer is too big; decrease length: "//trim(append_error_msg))
endif
if (size(variable_data) .ne. dimsizes(2)) then
- call error("incorrect size of variable_data array.")
+ call error("incorrect size of variable_data array: "//trim(append_error_msg))
endif
do j = 1, dimsizes(2)
call string_copy(sbuf, variable_data(j))
@@ -187,9 +192,9 @@ subroutine netcdf_write_data_1d(fileobj, variable_name, variable_data, unlim_dim
deallocate(dimsizes)
deallocate(start)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
end subroutine netcdf_write_data_1d
@@ -216,6 +221,9 @@ subroutine netcdf_write_data_2d(fileobj, variable_name, variable_data, unlim_dim
integer :: unlim_dim_index
integer,dimension(3) :: c
integer, dimension(3) :: e
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_write_data_2d: file:"//trim(fileobj%path)//" variable: "//trim(variable_name)
if (fileobj%is_root) then
c(:) = 1
@@ -232,12 +240,12 @@ subroutine netcdf_write_data_2d(fileobj, variable_name, variable_data, unlim_dim
unlim_dim_index = get_variable_unlimited_dimension_index(fileobj, variable_name, &
broadcast=.false.)
if (unlim_dim_index .ne. 3) then
- call error("unlimited dimension must be the slowest varying dimension.")
+ call error("unlimited dimension must be the slowest varying dimension: "//trim(append_error_msg))
endif
c(unlim_dim_index) = unlim_dim_level
endif
call set_netcdf_mode(fileobj%ncid, data_mode)
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(variable_data)
type is (integer(kind=i4_kind))
err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c, count=e)
@@ -248,9 +256,9 @@ subroutine netcdf_write_data_2d(fileobj, variable_name, variable_data, unlim_dim
type is (real(kind=r8_kind))
err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c ,count=e)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
end subroutine netcdf_write_data_2d
@@ -278,6 +286,9 @@ subroutine netcdf_write_data_3d(fileobj, variable_name, variable_data, unlim_dim
integer :: unlim_dim_index
integer, dimension(4) :: c
integer, dimension(4) :: e
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_write_data_3d: file:"//trim(fileobj%path)//" variable: "//trim(variable_name)
if (fileobj%is_root) then
c(:) = 1
@@ -294,12 +305,12 @@ subroutine netcdf_write_data_3d(fileobj, variable_name, variable_data, unlim_dim
unlim_dim_index = get_variable_unlimited_dimension_index(fileobj, variable_name, &
broadcast=.false.)
if (unlim_dim_index .ne. 4) then
- call error("unlimited dimension must be the slowest varying dimension.")
+ call error("unlimited dimension must be the slowest varying dimension: "//trim(append_error_msg))
endif
c(unlim_dim_index) = unlim_dim_level
endif
call set_netcdf_mode(fileobj%ncid, data_mode)
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(variable_data)
type is (integer(kind=i4_kind))
err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c, count=e)
@@ -310,9 +321,9 @@ subroutine netcdf_write_data_3d(fileobj, variable_name, variable_data, unlim_dim
type is (real(kind=r8_kind))
err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c, count=e)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
end subroutine netcdf_write_data_3d
@@ -339,6 +350,9 @@ subroutine netcdf_write_data_4d(fileobj, variable_name, variable_data, unlim_dim
integer :: unlim_dim_index
integer,dimension(5) :: c
integer, dimension(5) :: e
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_write_data_4d: file:"//trim(fileobj%path)//" variable: "//trim(variable_name)
if (fileobj%is_root) then
c(:) = 1
@@ -359,7 +373,7 @@ subroutine netcdf_write_data_4d(fileobj, variable_name, variable_data, unlim_dim
endif
endif
call set_netcdf_mode(fileobj%ncid, data_mode)
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(variable_data)
type is (integer(kind=i4_kind))
err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c, count=e)
@@ -370,9 +384,9 @@ subroutine netcdf_write_data_4d(fileobj, variable_name, variable_data, unlim_dim
type is (real(kind=r8_kind))
err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c, count=e)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
end subroutine netcdf_write_data_4d
@@ -401,6 +415,9 @@ subroutine netcdf_write_data_5d(fileobj, variable_name, variable_data, unlim_dim
integer :: unlim_dim_index
integer,dimension(6) :: c
integer, dimension(6) :: e
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_write_data_5d: file:"//trim(fileobj%path)//" variable: "//trim(variable_name)
if (fileobj%is_root) then
c(:) = 1
@@ -417,12 +434,12 @@ subroutine netcdf_write_data_5d(fileobj, variable_name, variable_data, unlim_dim
unlim_dim_index = get_variable_unlimited_dimension_index(fileobj, variable_name, &
broadcast=.false.)
if (unlim_dim_index .ne. 6) then
- call error("unlimited dimension must be the slowest varying dimension.")
+ call error("unlimited dimension must be the slowest varying dimension: "//trim(append_error_msg))
endif
c(unlim_dim_index) = unlim_dim_level
endif
call set_netcdf_mode(fileobj%ncid, data_mode)
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(variable_data)
type is (integer(kind=i4_kind))
err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c, count=e)
@@ -433,8 +450,8 @@ subroutine netcdf_write_data_5d(fileobj, variable_name, variable_data, unlim_dim
type is (real(kind=r8_kind))
err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c, count=e)
class default
- call error("unsupported type.")
+ call error("Unsupported variable type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
end subroutine netcdf_write_data_5d
diff --git a/fms2_io/include/register_global_attribute.inc b/fms2_io/include/register_global_attribute.inc
index 88bb97bf88..d06b073f5c 100644
--- a/fms2_io/include/register_global_attribute.inc
+++ b/fms2_io/include/register_global_attribute.inc
@@ -44,6 +44,9 @@ subroutine register_global_attribute_0d(fileobj, &
trim(attribute_name), &
attribute_value)
type is (integer(kind=i8_kind))
+ if ( .not. fileobj%allow_int8) call error(trim(fileobj%path)//": 64 bit integers are only supported with 'netcdf4' file format"//&
+ &". Set netcdf_default_format='netcdf4' in the fms2_io namelist OR "//&
+ &"add nc_format='netcdf4' to your open_file call")
err = nf90_put_att(fileobj%ncid, &
nf90_global, &
trim(attribute_name), &
@@ -62,7 +65,7 @@ subroutine register_global_attribute_0d(fileobj, &
call error("register_global_attribute_0d: unsupported type for "//&
trim(attribute_name)//" for file: "//trim(fileobj%path)//"")
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "register_global_attribute_0d: file:"//trim(fileobj%path)//"- attribute:"//trim(attribute_name))
endif
end subroutine register_global_attribute_0d
!> @brief Add a global attribute.
@@ -85,6 +88,9 @@ subroutine register_global_attribute_1d(fileobj, &
trim(attribute_name), &
attribute_value)
type is (integer(kind=i8_kind))
+ if ( .not. fileobj%allow_int8) call error(trim(fileobj%path)//": 64 bit integers are only supported with 'netcdf4' file format"//&
+ &". Set netcdf_default_format='netcdf4' in the fms2_io namelist OR "//&
+ &"add nc_format='netcdf4' to your open_file call")
err = nf90_put_att(fileobj%ncid, &
nf90_global, &
trim(attribute_name), &
@@ -103,6 +109,6 @@ subroutine register_global_attribute_1d(fileobj, &
call error("register_global_attribute_1d: unsupported type for "//&
trim(attribute_name)//" for file: "//trim(fileobj%path)//"")
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "register_global_attribute_1d: file:"//trim(fileobj%path)//"- attribute:"//trim(attribute_name))
endif
end subroutine register_global_attribute_1d
diff --git a/fms2_io/include/register_variable_attribute.inc b/fms2_io/include/register_variable_attribute.inc
index d2decd7848..2bafb18bd0 100644
--- a/fms2_io/include/register_variable_attribute.inc
+++ b/fms2_io/include/register_variable_attribute.inc
@@ -37,19 +37,26 @@ subroutine register_variable_attribute_0d(fileobj, variable_name, attribute_name
integer(kind=i8_kind), dimension(2) :: i64_range
real(kind=r4_kind), dimension(2) :: r32_range
real(kind=r8_kind), dimension(2) :: r64_range
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "register_variable_attribute_0d: file:"//trim(fileobj%path)//"- variable:"//&
+ &trim(variable_name)//" attribute: "//trim(attribute_name)
if (fileobj%is_root) then
call set_netcdf_mode(fileobj%ncid, define_mode)
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(attribute_value)
type is (character(len=*))
- if (.not. present(str_len)) call error("register_variable_attribute_0d: Need to include str length")
+ if (.not. present(str_len)) call error("Need to include str length:"//trim(append_error_msg))
err = nf90_put_att(fileobj%ncid, varid, trim(attribute_name), &
trim(attribute_value(1:str_len)))
type is (integer(kind=i4_kind))
err = nf90_put_att(fileobj%ncid, varid, trim(attribute_name), &
attribute_value)
type is (integer(kind=i8_kind))
+ if ( .not. fileobj%allow_int8) call error(trim(fileobj%path)//": 64 bit integers are only supported with 'netcdf4' file format"//&
+ &". Set netcdf_default_format='netcdf4' in the fms2_io namelist OR "//&
+ &"add nc_format='netcdf4' to your open_file call")
err = nf90_put_att(fileobj%ncid, varid, trim(attribute_name), &
attribute_value)
type is (real(kind=r4_kind))
@@ -59,14 +66,14 @@ subroutine register_variable_attribute_0d(fileobj, variable_name, attribute_name
err = nf90_put_att(fileobj%ncid, varid, trim(attribute_name), &
attribute_value)
class default
- call error("unsupported type.")
+ call error("Unsupported attribute type:"//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
!The missing_value attribute is not NUG compliant, but is included here to support
!legacy model component code.
- axtype = get_attribute_type(fileobj%ncid, varid, attribute_name)
- xtype = get_variable_type(fileobj%ncid, varid)
+ axtype = get_attribute_type(fileobj%ncid, varid, attribute_name, append_error_msg)
+ xtype = get_variable_type(fileobj%ncid, varid, append_error_msg)
if (string_compare(attribute_name, "_FillValue") .or. &
string_compare(attribute_name, "valid_min") .or. &
string_compare(attribute_name, "valid_max") .or. &
@@ -74,49 +81,49 @@ subroutine register_variable_attribute_0d(fileobj, variable_name, attribute_name
string_compare(attribute_name, "add_offset") .or. &
string_compare(attribute_name, "missing_value")) then
if (axtype .ne. xtype) then
- call error("type mismatch for "//trim(attribute_name))
+ call error("The variable type does not match the attribute type: "//trim(append_error_msg))
endif
endif
if (string_compare(attribute_name, "_FillValue")) then
- if (attribute_exists(fileobj%ncid, varid, "valid_range")) then
+ if (attribute_exists(fileobj%ncid, varid, "valid_range", msg=append_error_msg)) then
select type(attribute_value)
type is (integer(kind=i4_kind))
call get_variable_attribute(fileobj, variable_name, "valid_range", &
i32_range, .false.)
if (attribute_value .lt. i32_range(1) .or. &
attribute_value .gt. i32_range(2)) then
- call error("_FillValue inside valid_range.")
+ call error("_FillValue inside valid_range: "//trim(append_error_msg))
endif
type is (integer(kind=i8_kind))
call get_variable_attribute(fileobj, variable_name, "valid_range", &
i64_range, .false.)
if (attribute_value .lt. i64_range(1) .or. &
attribute_value .gt. i64_range(2)) then
- call error("_FillValue inside valid_range.")
+ call error("_FillValue inside valid_range: "//trim(append_error_msg))
endif
type is (real(kind=r4_kind))
call get_variable_attribute(fileobj, variable_name, "valid_range", &
r32_range, .false.)
if (attribute_value .lt. r32_range(1) .or. &
attribute_value .gt. r32_range(2)) then
- call error("_FillValue inside valid_range.")
+ call error("_FillValue inside valid_range: "//trim(append_error_msg))
endif
type is (real(kind=r8_kind))
call get_variable_attribute(fileobj, variable_name, "valid_range", &
r64_range, .false.)
if (attribute_value .lt. r64_range(1) .or. &
attribute_value .gt. r64_range(2)) then
- call error("_FillValue inside valid_range.")
+ call error("_FillValue inside valid_range: "//trim(append_error_msg))
endif
class default
- call error("unsupported type.")
+ call error("unsupported attribute type: "//trim(append_error_msg))
end select
endif
elseif (string_compare(attribute_name, "valid_min") .or. &
string_compare(attribute_name, "valid_max")) then
- if (attribute_exists(fileobj%ncid, varid, "valid_range")) then
- call error("cannot have valid_range and valid_min/max.")
+ if (attribute_exists(fileobj%ncid, varid, "valid_range", msg=append_error_msg)) then
+ call error("cannot have attributes valid_range and valid_min/max: "//trim(append_error_msg))
endif
endif
endif
@@ -137,15 +144,22 @@ subroutine register_variable_attribute_1d(fileobj, variable_name, attribute_name
integer :: err
integer :: axtype
integer :: xtype
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "register_variable_attribute_0d: file:"//trim(fileobj%path)//"- variable:"//&
+ &trim(variable_name)//" attribute: "//trim(attribute_name)
if (fileobj%is_root) then
call set_netcdf_mode(fileobj%ncid, define_mode)
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
select type(attribute_value)
type is (integer(kind=i4_kind))
err = nf90_put_att(fileobj%ncid, varid, trim(attribute_name), &
attribute_value)
type is (integer(kind=i8_kind))
+ if ( .not. fileobj%allow_int8) call error(trim(fileobj%path)//": 64 bit integers are only supported with 'netcdf4' file format"//&
+ &". Set netcdf_default_format='netcdf4' in the fms2_io namelist OR "//&
+ &"add nc_format='netcdf4' to your open_file call")
err = nf90_put_att(fileobj%ncid, varid, trim(attribute_name), &
attribute_value)
type is (real(kind=r4_kind))
@@ -155,9 +169,9 @@ subroutine register_variable_attribute_1d(fileobj, variable_name, attribute_name
err = nf90_put_att(fileobj%ncid, varid, trim(attribute_name), &
attribute_value)
class default
- call error("unsupported type.")
+ call error("unsupported attribute type: "//trim(append_error_msg))
end select
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
if (string_compare(attribute_name, "_FillValue") .or. &
string_compare(attribute_name, "valid_min") .or. &
@@ -167,17 +181,17 @@ subroutine register_variable_attribute_1d(fileobj, variable_name, attribute_name
string_compare(attribute_name, "missing_value")) then
call error(trim(attribute_name)//" must be a scalar.")
elseif (string_compare(attribute_name, "valid_range")) then
- if (attribute_exists(fileobj%ncid, varid, "valid_min") .or. &
- attribute_exists(fileobj%ncid, varid, "valid_max")) then
- call error("cannot have valid_range and valid_min/max.")
+ if (attribute_exists(fileobj%ncid, varid, "valid_min", msg=append_error_msg) .or. &
+ attribute_exists(fileobj%ncid, varid, "valid_max", msg=append_error_msg)) then
+ call error("cannot have valid_range and valid_min/max: "//trim(append_error_msg))
endif
- axtype = get_attribute_type(fileobj%ncid, varid, attribute_name)
- xtype = get_variable_type(fileobj%ncid, varid)
+ axtype = get_attribute_type(fileobj%ncid, varid, attribute_name, append_error_msg)
+ xtype = get_variable_type(fileobj%ncid, varid, append_error_msg)
if (axtype .ne. xtype) then
- call error("type mismatch for valid_range.")
+ call error("The type of the variable is not the same as the type of the variable: "//trim(append_error_msg))
endif
if (size(attribute_value) .ne. 2) then
- call error("valid_range must be a vector with two values.")
+ call error("valid_range must be a vector with two values: "//trim(append_error_msg))
endif
endif
endif
diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90
index f8481b0f88..bf028d7819 100644
--- a/fms2_io/netcdf_io.F90
+++ b/fms2_io/netcdf_io.F90
@@ -126,6 +126,7 @@ module netcdf_io_mod
logical :: is_readonly !< Flag telling if the file is readonly.
integer :: ncid !< Netcdf file id.
character(len=256) :: nc_format !< Netcdf file format.
+ logical :: allow_int8 !< Flag indicating if int8 variables are allowed
integer, dimension(:), allocatable :: pelist !< List of ranks who will
!! communicate.
integer :: io_root !< I/O root rank of the pelist.
@@ -232,6 +233,7 @@ module netcdf_io_mod
public :: set_fileobj_time_name
public :: write_restart_bc
public :: read_restart_bc
+public :: flush_file
!> @ingroup netcdf_io_mod
interface netcdf_add_restart_variable
@@ -354,15 +356,16 @@ end subroutine netcdf_io_init
!> @brief Check for errors returned by netcdf.
!! @internal
-subroutine check_netcdf_code(err)
+subroutine check_netcdf_code(err, msg)
integer, intent(in) :: err !< Code returned by netcdf.
+ character(len=*), intent(in) :: msg !< Error message to be appended to the FATAL
character(len=80) :: buf
if (err .ne. nf90_noerr) then
buf = nf90_strerror(err)
- call error(trim(buf))
+ call error(trim(buf)//": "//trim(msg))
endif
end subroutine check_netcdf_code
@@ -390,21 +393,23 @@ subroutine set_netcdf_mode(ncid, mode)
else
call error("mode must be either define_mode or data_mode.")
endif
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "set_netcdf_mode")
end subroutine set_netcdf_mode
!> @brief Get the id of a dimension from its name.
!! @return Dimension id, or dimension_missing if it doesn't exist.
!! @internal
-function get_dimension_id(ncid, dimension_name, allow_failure) &
+function get_dimension_id(ncid, dimension_name, msg, allow_failure) &
result(dimid)
integer, intent(in) :: ncid !< Netcdf file id.
character(len=*), intent(in) :: dimension_name !< Dimension name.
+ character(len=*), intent(in) :: msg !< Error message
logical, intent(in), optional :: allow_failure !< Flag that prevents
!! crash if dimension
!! does not exist.
+
integer :: dimid
integer :: err
@@ -416,21 +421,23 @@ function get_dimension_id(ncid, dimension_name, allow_failure) &
return
endif
endif
- call check_netcdf_code(err)
+ call check_netcdf_code(err, msg)
end function get_dimension_id
!> @brief Get the id of a variable from its name.
!! @return Variable id, or variable_missing if it doesn't exist.
!! @internal
-function get_variable_id(ncid, variable_name, allow_failure) &
+function get_variable_id(ncid, variable_name, msg, allow_failure) &
result(varid)
integer, intent(in) :: ncid !< Netcdf file object.
character(len=*), intent(in) :: variable_name !< Variable name.
+ character(len=*), intent(in) :: msg !< Error message
logical, intent(in), optional :: allow_failure !< Flag that prevents
!! crash if variable does
!! not exist.
+
integer :: varid
integer :: err
@@ -442,19 +449,21 @@ function get_variable_id(ncid, variable_name, allow_failure) &
return
endif
endif
- call check_netcdf_code(err)
+ call check_netcdf_code(err, msg)
end function get_variable_id
!> @brief Determine if an attribute exists.
!! @return Flag telling if the attribute exists.
!! @internal
-function attribute_exists(ncid, varid, attribute_name) &
+function attribute_exists(ncid, varid, attribute_name, msg) &
result(att_exists)
integer, intent(in) :: ncid !< Netcdf file id.
integer, intent(in) :: varid !< Variable id.
character(len=*), intent(in) :: attribute_name !< Attribute name.
+ character(len=*), intent(in), optional :: msg !< Error message
+
logical :: att_exists
integer :: err
@@ -463,7 +472,7 @@ function attribute_exists(ncid, varid, attribute_name) &
if (err .eq. nf90_enotatt) then
att_exists = .false.
else
- call check_netcdf_code(err)
+ call check_netcdf_code(err, msg)
att_exists = .true.
endif
end function attribute_exists
@@ -472,35 +481,39 @@ end function attribute_exists
!> @brief Get the type of a netcdf attribute.
!! @return The netcdf type of the attribute.
!! @internal
-function get_attribute_type(ncid, varid, attname) &
+function get_attribute_type(ncid, varid, attname, msg) &
result(xtype)
integer, intent(in) :: ncid !< Netcdf file id.
integer, intent(in) :: varid !< Variable id.
character(len=*), intent(in) :: attname !< Attribute name.
+ character(len=*), intent(in), optional :: msg !< Error message
+
integer :: xtype
integer :: err
err = nf90_inquire_attribute(ncid, varid, attname, xtype=xtype)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, msg)
end function get_attribute_type
!> @brief Get the type of a netcdf variable.
!! @return The netcdf type of the variable.
!! @internal
-function get_variable_type(ncid, varid) &
+function get_variable_type(ncid, varid, msg) &
result(xtype)
integer, intent(in) :: ncid !< Netcdf file id.
integer, intent(in) :: varid !< Variable id.
+ character(len=*), intent(in), optional :: msg !< Error message to append to netcdf error code
+
integer :: xtype
integer :: err
err = nf90_inquire_variable(ncid, varid, xtype=xtype)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, msg)
end function get_variable_type
@@ -592,10 +605,11 @@ function netcdf_file_open(fileobj, path, mode, nc_format, pelist, is_restart, do
fileobj%io_root = fileobj%pelist(1)
fileobj%is_root = mpp_pe() .eq. fileobj%io_root
+ fileobj%allow_int8 = .false.
!Open the file with netcdf if this rank is the I/O root.
if (fileobj%is_root) then
- if (fms2_ncchksz == -1) call error("netcdf_file_open:: fms2_ncchksz not set.")
- if (fms2_nc_format_param == -1) call error("netcdf_file_open:: fms2_nc_format_param not set.")
+ if (fms2_ncchksz == -1) call error("netcdf_file_open:: fms2_ncchksz not set, call fms2_io_init")
+ if (fms2_nc_format_param == -1) call error("netcdf_file_open:: fms2_nc_format_param not set, call fms2_io_init")
if (present(nc_format)) then
if (string_compare(nc_format, "64bit", .true.)) then
@@ -603,9 +617,11 @@ function netcdf_file_open(fileobj, path, mode, nc_format, pelist, is_restart, do
elseif (string_compare(nc_format, "classic", .true.)) then
nc_format_param = nf90_classic_model
elseif (string_compare(nc_format, "netcdf4", .true.)) then
+ fileobj%allow_int8 = .true.
nc_format_param = nf90_netcdf4
else
- call error("unrecognized netcdf file format "//trim(nc_format)//".")
+ call error("unrecognized netcdf file format: '"//trim(nc_format)//"' for file:"//trim(fileobj%path)//&
+ &"Check your open_file call, the acceptable values are 64bit, classic, netcdf4")
endif
call string_copy(fileobj%nc_format, nc_format)
else
@@ -622,9 +638,10 @@ function netcdf_file_open(fileobj, path, mode, nc_format, pelist, is_restart, do
elseif (string_compare(mode,"overwrite",.true.)) then
err = nf90_create(trim(fileobj%path), ior(nf90_clobber, nc_format_param), fileobj%ncid, chunksize=fms2_ncchksz)
else
- call error("unrecognized file mode "//trim(mode)//".")
+ call error("unrecognized file mode: '"//trim(mode)//"' for file:"//trim(fileobj%path)//&
+ &"Check your open_file call, the acceptable values are read, append, write, overwrite")
endif
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "netcdf_file_open:"//trim(fileobj%path))
else
fileobj%ncid = missing_ncid
endif
@@ -663,7 +680,7 @@ subroutine netcdf_file_close(fileobj)
if (fileobj%is_root) then
err = nf90_close(fileobj%ncid)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "netcdf_file_close:"//trim(fileobj%path))
endif
if (allocated(fileobj%is_open)) fileobj%is_open = .false.
fileobj%path = missing_path
@@ -798,7 +815,7 @@ subroutine netcdf_add_dimension(fileobj, dimension_name, dimension_length, &
if (fileobj%is_root .and. .not. fileobj%is_readonly) then
call set_netcdf_mode(fileobj%ncid, define_mode)
err = nf90_def_dim(fileobj%ncid, trim(dimension_name), dim_len, dimid)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "Netcdf_add_dimension: file:"//trim(fileobj%path)//" dimension name:"//trim(dimension_name))
endif
end subroutine netcdf_add_dimension
@@ -847,12 +864,18 @@ subroutine netcdf_add_variable(fileobj, variable_name, variable_type, dimensions
integer :: vtype
integer :: varid
integer :: i
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
+ append_error_msg = "netcdf_add_variable: file:"//trim(fileobj%path)//"variable:"//trim(variable_name)
if (fileobj%is_root) then
call set_netcdf_mode(fileobj%ncid, define_mode)
if (string_compare(variable_type, "int", .true.)) then
vtype = nf90_int
elseif (string_compare(variable_type, "int64", .true.)) then
+ if ( .not. fileobj%allow_int8) call error(trim(fileobj%path)//": 64 bit integers are only supported with 'netcdf4' file format"//&
+ &". Set netcdf_default_format='netcdf4' in the fms2_io namelist OR "//&
+ &"add nc_format='netcdf4' to your open_file call")
vtype = nf90_int64
elseif (string_compare(variable_type, "float", .true.)) then
vtype = nf90_float
@@ -861,22 +884,22 @@ subroutine netcdf_add_variable(fileobj, variable_name, variable_type, dimensions
elseif (string_compare(variable_type, "char", .true.)) then
vtype = nf90_char
if (.not. present(dimensions)) then
- call error("string variables require a string length dimension.")
+ call error("String variables require a string length dimension:"//trim(append_error_msg))
endif
else
- call error("unsupported type.")
+ call error("Unsupported variable type:"//trim(append_error_msg))
endif
if (present(dimensions)) then
allocate(dimids(size(dimensions)))
do i = 1, size(dimids)
- dimids(i) = get_dimension_id(fileobj%ncid, trim(dimensions(i)))
+ dimids(i) = get_dimension_id(fileobj%ncid, trim(dimensions(i)),msg=append_error_msg)
enddo
err = nf90_def_var(fileobj%ncid, trim(variable_name), vtype, dimids, varid)
deallocate(dimids)
else
err = nf90_def_var(fileobj%ncid, trim(variable_name), vtype, varid)
endif
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
end subroutine netcdf_add_variable
@@ -1058,7 +1081,8 @@ function global_att_exists(fileobj, attribute_name, broadcast) &
logical :: att_exists
if (fileobj%is_root) then
- att_exists = attribute_exists(fileobj%ncid, nf90_global, trim(attribute_name))
+ att_exists = attribute_exists(fileobj%ncid, nf90_global, trim(attribute_name), &
+ & msg="global_att_exists: file:"//trim(fileobj%path)//" attribute name:"//trim(attribute_name))
endif
if (present(broadcast)) then
if (.not. broadcast) then
@@ -1090,8 +1114,12 @@ function variable_att_exists(fileobj, variable_name, attribute_name, &
att_exists = .false.
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
- att_exists = attribute_exists(fileobj%ncid, varid, trim(attribute_name))
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), &
+ & msg="variable_att_exists: file:"//trim(fileobj%path)//"- variable:"//&
+ &trim(variable_name))
+ att_exists = attribute_exists(fileobj%ncid, varid, trim(attribute_name), &
+ &msg="variable_att_exists: file:"//trim(fileobj%path)//" variable:"//trim(variable_name)//&
+ &" attribute name:"//trim(attribute_name))
endif
if (present(broadcast)) then
if (.not. broadcast) then
@@ -1120,7 +1148,7 @@ function get_num_dimensions(fileobj, broadcast) &
if (fileobj%is_root) then
err = nf90_inquire(fileobj%ncid, nDimensions=ndims)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "get_num_dimensions: file:"//trim(fileobj%path))
endif
if (present(broadcast)) then
if (.not. broadcast) then
@@ -1152,15 +1180,16 @@ subroutine get_dimension_names(fileobj, names, broadcast)
ndims = get_num_dimensions(fileobj, broadcast=.false.)
if (ndims .gt. 0) then
if (size(names) .ne. ndims) then
- call error("incorrect size of names array.")
+ call error("'names' has to be the same size of the number of dimensions."&
+ &" Check your get_dimension_names call for file "//trim(fileobj%path))
endif
else
- call error("there are no dimensions in this file.")
+ call error("get_dimension_names: the file "//trim(fileobj%path)//" does not have any dimensions")
endif
names(:) = ""
do i = 1, ndims
err = nf90_inquire_dimension(fileobj%ncid, i, name=names(i))
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "get_dimension_names: file:"//trim(fileobj%path))
enddo
endif
if (present(broadcast)) then
@@ -1172,10 +1201,11 @@ subroutine get_dimension_names(fileobj, names, broadcast)
if (.not. fileobj%is_root) then
if (ndims .gt. 0) then
if (size(names) .ne. ndims) then
- call error("incorrect size of names array.")
+ call error("'names' has to be the same size of the number of dimensions."&
+ &" Check your get_dimension_names call for file "//trim(fileobj%path))
endif
else
- call error("there are no dimensions in this file.")
+ call error("get_dimension_names: the file "//trim(fileobj%path)//" does not have any dimensions")
endif
names(:) = ""
endif
@@ -1203,6 +1233,7 @@ function dimension_exists(fileobj, dimension_name, broadcast) &
if (fileobj%is_root) then
dimid = get_dimension_id(fileobj%ncid, trim(dimension_name), &
+ msg="dimension_exists: file:"//trim(fileobj%path)//" dimension:"//trim(dimension_name), &
allow_failure=.true.)
if (dimid .eq. dimension_missing) then
dim_exists = .false.
@@ -1234,14 +1265,17 @@ function is_dimension_unlimited(fileobj, dimension_name, broadcast) &
!! by default.
logical :: is_unlimited
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
integer :: dimid
integer :: err
integer :: ulim_dimid
if (fileobj%is_root) then
- dimid = get_dimension_id(fileobj%ncid, trim(dimension_name))
+ append_error_msg="is_dimension_unlimited: file:"//trim(fileobj%path)//&
+ & " dimension_name:"//trim(dimension_name)
+ dimid = get_dimension_id(fileobj%ncid, trim(dimension_name), msg=append_error_msg)
err = nf90_inquire(fileobj%ncid, unlimitedDimId=ulim_dimid)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
is_unlimited = dimid .eq. ulim_dimid
endif
if (present(broadcast)) then
@@ -1272,9 +1306,9 @@ subroutine get_unlimited_dimension_name(fileobj, dimension_name, broadcast)
dimension_name = ""
if (fileobj%is_root) then
err = nf90_inquire(fileobj%ncid, unlimitedDimId=dimid)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "get_unlimited_dimension_name: file:"//trim(fileobj%path))
err = nf90_inquire_dimension(fileobj%ncid, dimid, dimension_name)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "get_unlimited_dimension_name: file:"//trim(fileobj%path))
call string_copy(buffer(1), dimension_name)
endif
if (present(broadcast)) then
@@ -1303,11 +1337,13 @@ subroutine get_dimension_size(fileobj, dimension_name, dim_size, broadcast)
integer :: dimid
integer :: err
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
if (fileobj%is_root) then
- dimid = get_dimension_id(fileobj%ncid, trim(dimension_name))
+ append_error_msg = "get_dimension_size: file:"//trim(fileobj%path)//" dimension_name: "//trim(dimension_name)
+ dimid = get_dimension_id(fileobj%ncid, trim(dimension_name), msg=append_error_msg)
err = nf90_inquire_dimension(fileobj%ncid, dimid, len=dim_size)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
if (present(broadcast)) then
if (.not. broadcast) then
@@ -1336,7 +1372,7 @@ function get_num_variables(fileobj, broadcast) &
if (fileobj%is_root) then
err = nf90_inquire(fileobj%ncid, nVariables=nvars)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "get_num_variables: file: "//trim(fileobj%path))
endif
if (present(broadcast)) then
if (.not. broadcast) then
@@ -1368,15 +1404,16 @@ subroutine get_variable_names(fileobj, names, broadcast)
nvars = get_num_variables(fileobj, broadcast=.false.)
if (nvars .gt. 0) then
if (size(names) .ne. nvars) then
- call error("names array has incorrect size.")
+ call error("'names' has to be the same size of the number of variables."&
+ &" Check your get_variable_names call for file "//trim(fileobj%path))
endif
else
- call error("there are no variables in this file.")
+ call error("get_variable_names: the file "//trim(fileobj%path)//" does not have any variables")
endif
names(:) = ""
do i = 1, nvars
err = nf90_inquire_variable(fileobj%ncid, i, name=names(i))
- call check_netcdf_code(err)
+ call check_netcdf_code(err, "get_variable_names: "//trim(fileobj%path))
enddo
endif
if (present(broadcast)) then
@@ -1388,10 +1425,11 @@ subroutine get_variable_names(fileobj, names, broadcast)
if (.not. fileobj%is_root) then
if (nvars .gt. 0) then
if (size(names) .ne. nvars) then
- call error("names array has incorrect size.")
+ call error("'names' has to be the same size of the number of variables."&
+ &" Check your get_variable_names call for file "//trim(fileobj%path))
endif
else
- call error("there are no variables in this file.")
+ call error("get_variable_names: the file "//trim(fileobj%path)//" does not have any variables")
endif
names(:) = ""
endif
@@ -1419,6 +1457,7 @@ function variable_exists(fileobj, variable_name, broadcast) &
if (fileobj%is_root) then
varid = get_variable_id(fileobj%ncid, trim(variable_name), &
+ msg="variable_exists: file:"//trim(fileobj%path)//" variable:"//trim(variable_name), &
allow_failure=.true.)
var_exists = varid .ne. variable_missing
endif
@@ -1448,11 +1487,14 @@ function get_variable_num_dimensions(fileobj, variable_name, broadcast) &
integer :: varid
integer :: err
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ append_error_msg = "get_variable_num_dimension: file:"//trim(fileobj%path)//" variable: "//trim(variable_name)
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
err = nf90_inquire_variable(fileobj%ncid, varid, ndims=ndims)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
endif
if (present(broadcast)) then
if (.not. broadcast) then
@@ -1484,23 +1526,30 @@ subroutine get_variable_dimension_names(fileobj, variable_name, dim_names, &
integer :: ndims
integer,dimension(nf90_max_var_dims) :: dimids
integer :: i
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ append_error_msg = "get_variable_dimension_names: file:"//trim(fileobj%path)//" variable: "//trim(variable_name)
+
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
err = nf90_inquire_variable(fileobj%ncid, varid, ndims=ndims, &
dimids=dimids)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
if (ndims .gt. 0) then
if (size(dim_names) .ne. ndims) then
- call error("incorrect size of dim_names array.")
+ call error("'names' has to be the same size of the number of dimensions for the variable."&
+ &" Check your get_variable_dimension_names call for file "//trim(fileobj%path)//&
+ &" and variable:"//trim(variable_name))
endif
else
- call error("this variable is a scalar.")
+ call error("get_variable_dimension_names: the variable: "//trim(variable_name)//" in file: "//trim(fileobj%path)//&
+ &" does not any dimensions. ")
endif
dim_names(:) = ""
do i = 1, ndims
err = nf90_inquire_dimension(fileobj%ncid, dimids(i), name=dim_names(i))
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
enddo
endif
if (present(broadcast)) then
@@ -1512,10 +1561,13 @@ subroutine get_variable_dimension_names(fileobj, variable_name, dim_names, &
if (.not. fileobj%is_root) then
if (ndims .gt. 0) then
if (size(dim_names) .ne. ndims) then
- call error("incorrect size of dim_names array.")
+ call error("'names' has to be the same size of the number of dimensions for the variable."&
+ &" Check your get_variable_dimension_names call for file "//trim(fileobj%path)//&
+ &" and variable:"//trim(variable_name))
endif
else
- call error("this variable is a scalar.")
+ call error("get_variable_dimension_names: the variable: "//trim(variable_name)//" in file: "//trim(fileobj%path)//&
+ &" does not any dimensions. ")
endif
dim_names(:) = ""
endif
@@ -1543,21 +1595,26 @@ subroutine get_variable_size(fileobj, variable_name, dim_sizes, broadcast)
integer :: ndims
integer,dimension(nf90_max_var_dims) :: dimids
integer :: i
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, trim(variable_name))
+ append_error_msg = "get_variable_size: file:"//trim(fileobj%path)//" variable:"//trim(variable_name)
+ varid = get_variable_id(fileobj%ncid, trim(variable_name), msg=append_error_msg)
err = nf90_inquire_variable(fileobj%ncid, varid, ndims=ndims, dimids=dimids)
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
if (ndims .gt. 0) then
if (size(dim_sizes) .ne. ndims) then
- call error("incorrect size of dim_sizes array.")
+ call error("'dim_sizes' has to be the same size of the number of dimensions for the variable."&
+ &" Check your get_variable_size call for file "//trim(fileobj%path)//&
+ &" and variable:"//trim(variable_name))
endif
else
- call error("this variable is a scalar.")
+ call error("get_variable_size: the variable: "//trim(variable_name)//" in file: "//trim(fileobj%path)//&
+ &" does not any dimensions. ")
endif
do i = 1, ndims
err = nf90_inquire_dimension(fileobj%ncid, dimids(i), len=dim_sizes(i))
- call check_netcdf_code(err)
+ call check_netcdf_code(err, append_error_msg)
enddo
endif
if (present(broadcast)) then
@@ -1569,10 +1626,13 @@ subroutine get_variable_size(fileobj, variable_name, dim_sizes, broadcast)
if (.not. fileobj%is_root) then
if (ndims .gt. 0) then
if (size(dim_sizes) .ne. ndims) then
- call error("incorrect size of dim_names array.")
+ call error("'dim_sizes' has to be the same size of the number of dimensions for the variable."&
+ &" Check your get_variable_size call for file "//trim(fileobj%path)//&
+ &" and variable:"//trim(variable_name))
endif
else
- call error("this variable is a scalar.")
+ call error("get_variable_size: the variable: "//trim(variable_name)//" in file: "//trim(fileobj%path)//&
+ &" does not any dimensions. ")
endif
endif
call mpp_broadcast(dim_sizes, ndims, fileobj%io_root, pelist=fileobj%pelist)
@@ -1638,9 +1698,11 @@ function get_valid(fileobj, variable_name) &
real(kind=r8_kind) :: add_offset
real(kind=r8_kind), dimension(2) :: buffer
integer :: xtype
+ character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message
+ append_error_msg = "get_valid: file:"//trim(fileobj%path)
if (fileobj%is_root) then
- varid = get_variable_id(fileobj%ncid, variable_name)
+ varid = get_variable_id(fileobj%ncid, variable_name, msg=append_error_msg)
valid%has_max = .false.
valid%has_min = .false.
valid%has_fill = .false.
@@ -1649,13 +1711,13 @@ function get_valid(fileobj, variable_name) &
!This routine makes use of netcdf's automatic type conversion to
!store all range information in double precision.
- if (attribute_exists(fileobj%ncid, varid, "scale_factor")) then
+ if (attribute_exists(fileobj%ncid, varid, "scale_factor", msg=append_error_msg)) then
call get_variable_attribute(fileobj, variable_name, "scale_factor", scale_factor, &
broadcast=.false.)
else
scale_factor = 1._r8_kind
endif
- if (attribute_exists(fileobj%ncid, varid, "add_offset")) then
+ if (attribute_exists(fileobj%ncid, varid, "add_offset", msg=append_error_msg)) then
call get_variable_attribute(fileobj, variable_name, "add_offset", add_offset, &
broadcast=.false.)
else
@@ -1666,7 +1728,7 @@ function get_valid(fileobj, variable_name) &
!"valid_max" variable attributes if they are present in the file. If either the maximum value
!or minimum value is defined, valid%has_range is set to .true. (i.e. open ended ranges
!are valid and should be tested within the is_valid function).
- if (attribute_exists(fileobj%ncid, varid, "valid_range")) then
+ if (attribute_exists(fileobj%ncid, varid, "valid_range", msg=append_error_msg)) then
call get_variable_attribute(fileobj, variable_name, "valid_range", buffer, &
broadcast=.false.)
valid%max_val = buffer(2)*scale_factor + add_offset
@@ -1674,13 +1736,13 @@ function get_valid(fileobj, variable_name) &
valid%min_val = buffer(1)*scale_factor + add_offset
valid%has_min = .true.
else
- if (attribute_exists(fileobj%ncid, varid, "valid_max")) then
+ if (attribute_exists(fileobj%ncid, varid, "valid_max", msg=append_error_msg)) then
call get_variable_attribute(fileobj, variable_name, "valid_max", buffer(1), &
broadcast=.false.)
valid%max_val = buffer(1)*scale_factor + add_offset
valid%has_max = .true.
endif
- if (attribute_exists(fileobj%ncid, varid, "valid_min")) then
+ if (attribute_exists(fileobj%ncid, varid, "valid_min", msg=append_error_msg)) then
call get_variable_attribute(fileobj, variable_name, "valid_min", buffer(1), &
broadcast=.false.)
valid%min_val = buffer(1)*scale_factor + add_offset
@@ -1691,7 +1753,7 @@ function get_valid(fileobj, variable_name) &
!Get the missing value from the file if it exists.
- if (attribute_exists(fileobj%ncid, varid, "missing_value")) then
+ if (attribute_exists(fileobj%ncid, varid, "missing_value", msg=append_error_msg)) then
call get_variable_attribute(fileobj, variable_name, "missing_value", buffer(1), &
broadcast=.false.)
valid%missing_val = buffer(1)*scale_factor + add_offset
@@ -1706,12 +1768,13 @@ function get_valid(fileobj, variable_name) &
!non-positive fill value will be the exclusive lower bound (i.e. valis
!values are greater than the fill value). As before, valid%has_range is true
!if either a maximum or minimum value is set.
- if (attribute_exists(fileobj%ncid, varid, "_FillValue")) then
+ if (attribute_exists(fileobj%ncid, varid, "_FillValue", msg=append_error_msg)) then
call get_variable_attribute(fileobj, variable_name, "_FillValue", buffer(1), &
broadcast=.false.)
valid%fill_val = buffer(1)*scale_factor + add_offset
valid%has_fill = .true.
- xtype = get_variable_type(fileobj%ncid, varid)
+ xtype = get_variable_type(fileobj%ncid, varid, msg=append_error_msg)
+
if (.not. valid%has_range) then
if (xtype .eq. nf90_short .or. xtype .eq. nf90_int) then
if (buffer(1) .gt. 0) then
@@ -1732,7 +1795,7 @@ function get_valid(fileobj, variable_name) &
valid%has_min = .true.
endif
else
- call error("unsupported type.")
+ call error("Unsupported variable type:"//trim(append_error_msg))
endif
valid%has_range = .true.
endif
@@ -2060,7 +2123,8 @@ function is_registered_to_restart(fileobj, variable_name) &
integer :: i
if (.not. fileobj%is_restart) then
- call error("file "//trim(fileobj%path)//" is not a restart file.")
+ call error("file "//trim(fileobj%path)//" is not a restart file. "&
+ "Add is_restart=.true. to your open_file call")
endif
is_registered = .false.
do i = 1, fileobj%num_restart_vars
@@ -2146,7 +2210,8 @@ subroutine write_restart_bc(fileobj, unlim_dim_level)
integer :: i !< No description
if (.not. fileobj%is_restart) then
- call error("file "//trim(fileobj%path)//" is not a restart file.")
+ call error("file "//trim(fileobj%path)//" is not a restart file. "&
+ &"Add is_restart=.true. to your open_file call")
endif
!> Loop through the variables, root pe gathers the data from the other pes and writes out the checksum.
@@ -2201,6 +2266,16 @@ subroutine write_restart_bc(fileobj, unlim_dim_level)
end subroutine write_restart_bc
+!> @brief flushes the netcdf file into disk
+subroutine flush_file(fileobj)
+ class(FmsNetcdfFile_t), intent(inout) :: fileobj !< FMS2_io fileobj
+
+ integer :: err !< Netcdf error code
+
+ err = nf90_sync(fileobj%ncid)
+ call check_netcdf_code(err, "Flush_file: File:"//trim(fileobj%path))
+end subroutine flush_file
+
end module netcdf_io_mod
!> @}
! close documentation grouping
diff --git a/interpolator/interpolator.F90 b/interpolator/interpolator.F90
index 4ae126491b..7fd704a554 100644
--- a/interpolator/interpolator.F90
+++ b/interpolator/interpolator.F90
@@ -35,23 +35,6 @@ module interpolator_mod
WARNING, &
NOTE, &
input_nml_file
-use mpp_io_mod, only : mpp_open, &
- mpp_close, &
- mpp_get_times, &
- mpp_get_atts, &
- mpp_get_info, &
- mpp_read, &
- mpp_get_axes, &
- mpp_get_axis_data, &
- mpp_get_fields, &
- fieldtype, &
- atttype, &
- axistype, &
- MPP_RDONLY, &
- MPP_NETCDF, &
- MPP_MULTI, &
- MPP_APPEND, &
- MPP_SINGLE
use mpp_domains_mod, only : mpp_domains_init, &
mpp_update_domains, &
mpp_define_domains, &
@@ -66,7 +49,6 @@ module interpolator_mod
fms_init, &
mpp_root_pe, stdlog, &
check_nml_error
-use fms_mod, only : fms_io_file_exist => file_exist
use fms2_io_mod, only : FmsNetcdfFile_t, fms2_io_file_exist => file_exists, dimension_exists, &
open_file, fms2_io_read_data=>read_data, &
variable_exists, get_variable_num_dimensions, &
@@ -260,10 +242,6 @@ module interpolator_mod
integer :: itaum !< No description
integer :: itaup !< No description
-!< These are fms_io specific
-integer :: unit !< Unit number on which file is being read.
-type(fieldtype), pointer :: field_type(:) =>NULL() !< NetCDF field type
-
end type interpolate_type
!> @addtogroup interpolator_mod
@@ -283,12 +261,6 @@ module interpolator_mod
integer :: nlevh !< No description
integer :: len, ntime_in, num_fields !< No description
-!< These are fms_io specific
-integer :: natt !< No description
-type(axistype), allocatable :: axes(:) !< No description
-type(axistype),save :: time_axis !< No description
-type(fieldtype), allocatable :: varfields(:) !< No description
-
! pletzer real, allocatable :: time_in(:)
! sjs real, allocatable :: climdata(:,:,:), climdata2(:,:,:)
@@ -401,10 +373,6 @@ subroutine interpolate_type_eq (Out, In)
Out%itaum = In%itaum
Out%itaup = In%itaup
- !< These are fms_io specific
- if(associated(Out%field_type)) Out%field_type => In%field_type
- Out%unit = In%unit
-
end subroutine interpolate_type_eq
@@ -468,12 +436,8 @@ subroutine interpolator_init( clim_type, file_name, lonb_mod, latb_mod, &
! namelist input
!--------------------------------------------------------------------
-the_file_exists = fms2_io_file_exist('input.nml')
-
-if (the_file_exists) then
- read (input_nml_file, nml=interpolator_nml, iostat=io)
- ierr = check_nml_error(io,'interpolator_nml')
-end if
+ read (input_nml_file, nml=interpolator_nml, iostat=io)
+ ierr = check_nml_error(io,'interpolator_nml')
!---------------------------------------------------------------------
! write version number and namelist to logfile.
@@ -485,18 +449,14 @@ subroutine interpolator_init( clim_type, file_name, lonb_mod, latb_mod, &
module_is_initialized = .true.
endif !> if (module_is_initilized)
-
if (use_mpp_io) then
- call mpp_error(WARNING, "Interpolator::nml=interpolator_nml " //&
- 'MPP_IO is no longer supported. Please remove from namelist')
- call mppio_interpolator_init(clim_type, file_name, lonb_mod, latb_mod, &
- data_names, data_out_of_bounds, &
- vert_interp, clim_units, single_year_file)
-else
- call fms2io_interpolator_init(clim_type, file_name, lonb_mod, latb_mod, &
+ call mpp_error(FATAL, "Interpolator::nml=interpolator_nml " //&
+ 'MPP_IO is no longer supported. Please remove from use_mpp_io from interpolator_nml')
+endif
+
+call fms2io_interpolator_init(clim_type, file_name, lonb_mod, latb_mod, &
data_names, data_out_of_bounds, &
vert_interp, clim_units, single_year_file)
-endif
end subroutine interpolator_init
@@ -1646,24 +1606,7 @@ subroutine obtain_interpolator_time_slices (clim_type, Time)
clim_type%indexm(:) = indexm
clim_type%indexp(:) = indexp
clim_type%climatology(:) = climatology
- if (use_mpp_io) then
- do i=1, size(clim_type%field_name(:))
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%pmon_pyear(:,:,:,i), &
- clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time)
-! Read the data for the next month in the previous climatology.
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%nmon_pyear(:,:,:,i), &
- clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time)
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%pmon_nyear(:,:,:,i), &
- clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time)
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%nmon_nyear(:,:,:,i), &
- clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
- end do
- else
- do i=1, size(clim_type%field_name(:))
+ do i=1, size(clim_type%field_name(:))
call read_data(clim_type,clim_type%field_name(i), &
clim_type%pmon_pyear(:,:,:,i), &
clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time)
@@ -1677,29 +1620,12 @@ subroutine obtain_interpolator_time_slices (clim_type, Time)
call read_data(clim_type,clim_type%field_name(i), &
clim_type%nmon_nyear(:,:,:,i), &
clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
- end do
- endif ! if (use_mpp_io)
+ end do
endif
else ! We are within a climatology data set
- if (use_mpp_io) then
- do i=1, size(clim_type%field_name(:))
- if (taum /= clim_type%time_init(i,1) .or. &
- taup /= clim_type%time_init(i,2) ) then
-
-
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%pmon_pyear(:,:,:,i), taum,i,Time)
-! Read the data for the next month in the previous climatology.
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%nmon_pyear(:,:,:,i), taup,i,Time)
- clim_type%time_init(i,1) = taum
- clim_type%time_init(i,2) = taup
- endif
- end do
- else
do i=1, size(clim_type%field_name(:))
if (taum /= clim_type%time_init(i,1) .or. &
taup /= clim_type%time_init(i,2) ) then
@@ -1714,7 +1640,6 @@ subroutine obtain_interpolator_time_slices (clim_type, Time)
clim_type%time_init(i,2) = taup
endif
end do
- endif !(use_mpp_io)
! clim_type%pmon_nyear = 0.0
! clim_type%nmon_nyear = 0.0
@@ -1748,25 +1673,14 @@ subroutine obtain_interpolator_time_slices (clim_type, Time)
!Set up
! field(:,:,:,1) as the previous time slice.
! field(:,:,:,2) as the next time slice.
- if (use_mpp_io) then
- do i=1, size(clim_type%field_name(:))
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time)
- clim_type%time_init(i,1) = taum
- clim_type%itaum = 1
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time)
- clim_type%time_init(i,2) = taup
- clim_type%itaup = 2
- end do
- else
- do i=1, size(clim_type%field_name(:))
+ do i=1, size(clim_type%field_name(:))
call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,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%data(:,:,:,2,i), taup,i,Time)
clim_type%time_init(i,2) = taup
clim_type%itaup = 2
- end do
- endif ! if (use_mpp_io)
+ end do
endif ! clim_type%itaum.eq.clim_type%itaup.eq.0
if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then
! Can't think of a situation where we would have the next time level but not the previous.
@@ -1777,17 +1691,10 @@ subroutine obtain_interpolator_time_slices (clim_type, Time)
!We have the previous time step but not the next time step data
clim_type%itaup = 1
if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2
- if (use_mpp_io) then
- do i=1, size(clim_type%field_name(:))
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
- clim_type%time_init(i,clim_type%itaup)=taup
- end do
- else
do i=1, size(clim_type%field_name(:))
call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
clim_type%time_init(i,clim_type%itaup)=taup
end do
- endif ! if (use_mpp_io)
endif
@@ -1934,12 +1841,7 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, &
i = 1
if(present(clim_units)) then
- if (use_mpp_io) then
- call mpp_get_atts(clim_type%field_type(i),units=clim_units)
- clim_units = chomp(clim_units)
- else
call get_variable_units(clim_type%fileobj, clim_type%field_name(i), clim_units)
- endif
endif
@@ -2066,23 +1968,6 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, &
clim_type%indexm(:) = indexm
clim_type%indexp(:) = indexp
clim_type%climatology(:) = climatology
- if (use_mpp_io) then
- do i=1, size(clim_type%field_name(:))
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%pmon_pyear(:,:,:,i), &
- clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time)
-! Read the data for the next month in the previous climatology.
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%nmon_pyear(:,:,:,i), &
- clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time)
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%pmon_nyear(:,:,:,i), &
- clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time)
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%nmon_nyear(:,:,:,i), &
- clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
- end do
- else
do i=1, size(clim_type%field_name(:))
call read_data(clim_type,clim_type%field_name(i), &
clim_type%pmon_pyear(:,:,:,i), &
@@ -2098,29 +1983,12 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, &
clim_type%nmon_nyear(:,:,:,i), &
clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
end do
- endif !if (use_mpp_io)
endif
else ! We are within a climatology data set
- if (use_mpp_io) then
- do i=1, size(clim_type%field_name(:))
- if (taum /= clim_type%time_init(i,1) .or. &
- taup /= clim_type%time_init(i,2) ) then
-
-
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%pmon_pyear(:,:,:,i), taum,i,Time)
-! Read the data for the next month in the previous climatology.
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%nmon_pyear(:,:,:,i), taup,i,Time)
- clim_type%time_init(i,1) = taum
- clim_type%time_init(i,2) = taup
- endif
- end do
- else
do i=1, size(clim_type%field_name(:))
if (taum /= clim_type%time_init(i,1) .or. &
taup /= clim_type%time_init(i,2) ) then
@@ -2135,7 +2003,6 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, &
clim_type%time_init(i,2) = taup
endif
end do
- endif
! clim_type%pmon_nyear = 0.0
! clim_type%nmon_nyear = 0.0
@@ -2169,16 +2036,6 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, &
!Set up
! field(:,:,:,1) as the previous time slice.
! field(:,:,:,2) as the next time slice.
- if (use_mpp_io) then
- do i=1, size(clim_type%field_name(:))
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time)
- clim_type%time_init(i,1) = taum
- clim_type%itaum = 1
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time)
- clim_type%time_init(i,2) = taup
- clim_type%itaup = 2
- end do
- else
do i=1, size(clim_type%field_name(:))
call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,1,i), taum,i,Time)
clim_type%time_init(i,1) = taum
@@ -2187,7 +2044,6 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, &
clim_type%time_init(i,2) = taup
clim_type%itaup = 2
end do
- endif !if (use_mpp_io)
endif ! clim_type%itaum.eq.clim_type%itaup.eq.0
if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then
! Can't think of a situation where we would have the next time level but not the previous.
@@ -2198,17 +2054,10 @@ subroutine interpolator_4D(clim_type, Time, phalf, interp_data, &
!We have the previous time step but not the next time step data
clim_type%itaup = 1
if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2
- if (use_mpp_io) then
- do i=1, size(clim_type%field_name(:))
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
- clim_type%time_init(i,clim_type%itaup)=taup
- end do
- else
do i=1, size(clim_type%field_name(:))
call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
clim_type%time_init(i,clim_type%itaup)=taup
end do
- endif !if (use_mpp_io)
endif
@@ -2574,21 +2423,6 @@ subroutine interpolator_3D(clim_type, Time, phalf, interp_data,field_name, is,js
clim_type%indexm(i) = indexm
clim_type%indexp(i) = indexp
clim_type%climatology(i) = climatology
- if (use_mpp_io) then
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%pmon_pyear(:,:,:,i), &
- clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time)
-! Read the data for the next month in the previous climatology.
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%nmon_pyear(:,:,:,i), &
- clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time)
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%pmon_nyear(:,:,:,i), &
- clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time)
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%nmon_nyear(:,:,:,i), &
- clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
- else
call read_data(clim_type,clim_type%field_name(i), &
clim_type%pmon_pyear(:,:,:,i), &
clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time)
@@ -2602,7 +2436,6 @@ subroutine interpolator_3D(clim_type, Time, phalf, interp_data,field_name, is,js
call read_data(clim_type,clim_type%field_name(i), &
clim_type%nmon_nyear(:,:,:,i), &
clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
- endif !if (use_mpp_io)
endif
@@ -2613,15 +2446,9 @@ subroutine interpolator_3D(clim_type, Time, phalf, interp_data,field_name, is,js
if (taum /= clim_type%time_init(i,1) .or. &
taup /= clim_type%time_init(i,2) ) then
- if (use_mpp_io) then
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%pmon_pyear(:,:,:,i), taum,i,Time)
-! Read the data for the next month in the previous climatology.
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%nmon_pyear(:,:,:,i), taup,i,Time)
- else
call read_data(clim_type,clim_type%field_name(i), clim_type%pmon_pyear(:,:,:,i), taum,i,Time)
! Read the data for the next month in the previous climatology.
call read_data(clim_type,clim_type%field_name(i), clim_type%nmon_pyear(:,:,:,i), taup,i,Time)
- endif !if (use_mpp_io)
!RSHbug clim_type%pmon_nyear = 0.0
!RSHbug clim_type%nmon_nyear = 0.0
@@ -2662,21 +2489,12 @@ subroutine interpolator_3D(clim_type, Time, phalf, interp_data,field_name, is,js
!Set up
! field(:,:,:,1) as the previous time slice.
! field(:,:,:,2) as the next time slice.
- if (use_mpp_io) then
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time)
- clim_type%time_init(i,1) = taum
- clim_type%itaum = 1
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time)
- clim_type%time_init(i,2) = taup
- clim_type%itaup = 2
- else
call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,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%data(:,:,:,2,i), taup,i,Time)
clim_type%time_init(i,2) = taup
clim_type%itaup = 2
- endif !if (use_mpp_io)
endif ! clim_type%itaum.eq.clim_type%itaup.eq.0
if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then
! Can't think of a situation where we would have the next time level but not the previous.
@@ -2687,11 +2505,7 @@ subroutine interpolator_3D(clim_type, Time, phalf, interp_data,field_name, is,js
!We have the previous time step but not the next time step data
clim_type%itaup = 1
if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2
- if (use_mpp_io) then
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
- else
call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
- endif !if (use_mpp_io)
clim_type%time_init(i,clim_type%itaup)=taup
endif
@@ -3054,21 +2868,6 @@ subroutine interpolator_2D(clim_type, Time, interp_data, field_name, is, js, cli
clim_type%indexm(i) = indexm
clim_type%indexp(i) = indexp
clim_type%climatology(i) = climatology
- if (use_mpp_io) then
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%pmon_pyear(:,:,:,i), &
- clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time)
-! Read the data for the next month in the previous climatology.
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%nmon_pyear(:,:,:,i), &
- clim_type%indexp(i)+(clim_type%climatology(i)-1)*12,i,Time)
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%pmon_nyear(:,:,:,i), &
- clim_type%indexm(i)+clim_type%climatology(i)*12,i,Time)
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), &
- clim_type%nmon_nyear(:,:,:,i), &
- clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
- else
call read_data(clim_type,clim_type%field_name(i), &
clim_type%pmon_pyear(:,:,:,i), &
clim_type%indexm(i)+(clim_type%climatology(i)-1)*12,i,Time)
@@ -3082,7 +2881,6 @@ subroutine interpolator_2D(clim_type, Time, interp_data, field_name, is, js, cli
call read_data(clim_type,clim_type%field_name(i), &
clim_type%nmon_nyear(:,:,:,i), &
clim_type%indexp(i)+clim_type%climatology(i)*12,i,Time)
- endif !if (use_mpp_io)
endif
@@ -3093,15 +2891,9 @@ subroutine interpolator_2D(clim_type, Time, interp_data, field_name, is, js, cli
if (taum /= clim_type%time_init(i,1) .or. &
taup /= clim_type%time_init(i,2) ) then
- if (use_mpp_io) then
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%pmon_pyear(:,:,:,i), taum,i,Time)
-! Read the data for the next month in the previous climatology.
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%nmon_pyear(:,:,:,i), taup,i,Time)
- else
call read_data(clim_type,clim_type%field_name(i), clim_type%pmon_pyear(:,:,:,i), taum,i,Time)
! Read the data for the next month in the previous climatology.
call read_data(clim_type,clim_type%field_name(i), clim_type%nmon_pyear(:,:,:,i), taup,i,Time)
- endif
!RSHbug clim_type%pmon_nyear = 0.0
!RSHbug clim_type%nmon_nyear = 0.0
@@ -3141,21 +2933,12 @@ subroutine interpolator_2D(clim_type, Time, interp_data, field_name, is, js, cli
!Set up
! field(:,:,:,1) as the previous time slice.
! field(:,:,:,2) as the next time slice.
- if (use_mpp_io) then
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,1,i), taum,i,Time)
- clim_type%time_init(i,1) = taum
- clim_type%itaum = 1
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,2,i), taup,i,Time)
- clim_type%time_init(i,2) = taup
- clim_type%itaup = 2
- else
call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,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%data(:,:,:,2,i), taup,i,Time)
clim_type%time_init(i,2) = taup
clim_type%itaup = 2
- endif !(use_mpp_io)
endif ! clim_type%itaum.eq.clim_type%itaup.eq.0
if (clim_type%itaum.eq.0 .and. clim_type%itaup.ne.0) then
! Can't think of a situation where we would have the next time level but not the previous.
@@ -3166,11 +2949,7 @@ subroutine interpolator_2D(clim_type, Time, interp_data, field_name, is, js, cli
!We have the previous time step but not the next time step data
clim_type%itaup = 1
if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2
- if (use_mpp_io) then
- call interp_read_data_mppio(clim_type,clim_type%field_type(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
- else
call read_data(clim_type,clim_type%field_name(i), clim_type%data(:,:,:,clim_type%itaup,i), taup,i, Time)
- endif
clim_type%time_init(i,clim_type%itaup)=taup
endif
endif! TIME_FLAG .eq. LINEAR .and. (.not. read_all_on_init)
@@ -3645,18 +3424,11 @@ subroutine interpolator_end(clim_type)
deallocate(clim_type%nmon_pyear)
endif
-!< These are fms_io specific
-if (associated (clim_type%field_type)) deallocate(clim_type%field_type)
-
!! RSH mod
if( .not. (clim_type%TIME_FLAG .eq. LINEAR .and. &
! read_all_on_init)) .or. clim_type%TIME_FLAG .eq. BILINEAR ) then
read_all_on_init) ) then
- if (use_mpp_io) then
- call mpp_close(clim_type%unit)
- else
call close_file(clim_type%fileobj)
- endif !if (use_mpp_io)
endif
@@ -4072,845 +3844,6 @@ subroutine interp_linear ( grdin, grdout, datin, datout )
end subroutine interp_linear
!
!########################################################################
-subroutine mppio_interpolator_init(clim_type, file_name, lonb_mod, latb_mod, &
- data_names, data_out_of_bounds, &
- vert_interp, clim_units, single_year_file)
-
-type(interpolate_type), intent(inout) :: clim_type
-character(len=*), intent(in) :: file_name
-real , intent(in) :: lonb_mod(:,:), latb_mod(:,:)
-character(len=*), intent(in) , optional :: data_names(:)
-!++lwh
-integer , intent(in) :: data_out_of_bounds(:)
-integer , intent(in), optional :: vert_interp(:)
-!--lwh
-character(len=*), intent(out), optional :: clim_units(:)
-logical, intent(out), optional :: single_year_file
-
-integer :: unit
-character(len=64) :: src_file
-!++lwh
-real :: dlat, dlon
-!--lwh
-type(time_type) :: base_time
-logical :: NAME_PRESENT
-real :: dtr,tpi
-integer :: fileday, filemon, fileyr, filehr, filemin,filesec, m,m1
-character(len= 20) :: fileunits
-real, dimension(:), allocatable :: alpha
-integer :: j, i
-logical :: non_monthly
-character(len=24) :: file_calendar
-character(len=256) :: error_mesg
-integer :: model_calendar
-integer :: yr, mo, dy, hr, mn, sc
-integer :: n
-type(time_type) :: Julian_time, Noleap_time
-real, allocatable :: time_in(:)
-real, allocatable, save :: agrid_mod(:,:,:)
-integer :: nx, ny
-
-clim_type%separate_time_vary_calc = .false.
-
-tpi = 2.0*PI ! 4.*acos(0.)
-dtr = tpi/360.
-
-num_fields = 0
-
-!--------------------------------------------------------------------
-! open source file containing fields to be interpolated
-!--------------------------------------------------------------------
-src_file = 'INPUT/'//trim(file_name)
-
-if(fms_io_file_exist(trim(src_file))) then
- call mpp_open( unit, trim(src_file), action=MPP_RDONLY, &
- form=MPP_NETCDF, threading=MPP_MULTI, fileset=MPP_SINGLE )
-else
-!Climatology file doesn't exist, so exit
- call mpp_error(FATAL,'Interpolator_init : Data file '//trim(src_file)//' does not exist')
-endif
-
-!Find the number of variables (nvar) in this file
-call mpp_get_info(unit, ndim, nvar, natt, ntime)
-clim_type%unit = unit
-clim_type%file_name = trim(file_name)
-
-num_fields = nvar
-if(present(data_names)) num_fields= size(data_names(:))
-
-! -------------------------------------------------------------------
-! Allocate space for the number of axes in the data file.
-! -------------------------------------------------------------------
-allocate(axes(ndim))
-call mpp_get_axes(unit, axes, time_axis)
-
-nlon=0 ! Number of longitudes (center-points) in the climatology.
-nlat=0 ! Number of latitudes (center-points) in the climatology.
-nlev=0 ! Number of levels (center-points) in the climatology.
-nlatb=0 ! Number of longitudes (boundaries) in the climatology.
-nlonb=0 ! Number of latitudes (boundaries) in the climatology.
-nlevh=0 ! Number of levels (boundaries) in the climatology.
-
-clim_type%level_type = 0 ! Default value
-
-!++lwh
-! -------------------------------------------------------------------
-! For 2-D fields, set a default value of nlev=nlevh=1
-! -------------------------------------------------------------------
-nlev = 1
-nlevh = 1
-!--lwh
- clim_type%vertical_indices = 0 ! initial value
-
-do i = 1, ndim
- call mpp_get_atts(axes(i), name=name,len=len,units=units, &
- calendar=file_calendar, sense=sense)
- select case(trim(name))
- case('lat')
- nlat=len
- allocate(clim_type%lat(nlat))
- call mpp_get_axis_data(axes(i),clim_type%lat)
- select case(units(1:6))
- case('degree')
- clim_type%lat = clim_type%lat*dtr
- case('radian')
- case default
- call mpp_error(FATAL, "interpolator_init : Units for lat not recognised in file "//file_name)
- end select
- case('lon')
- nlon=len
- allocate(clim_type%lon(nlon))
- call mpp_get_axis_data(axes(i),clim_type%lon)
- select case(units(1:6))
- case('degree')
- clim_type%lon = clim_type%lon*dtr
- case('radian')
- case default
- call mpp_error(FATAL, "interpolator_init : Units for lon not recognised in file "//file_name)
- end select
- case('latb')
- nlatb=len
- allocate(clim_type%latb(nlatb))
- call mpp_get_axis_data(axes(i),clim_type%latb)
- select case(units(1:6))
- case('degree')
- clim_type%latb = clim_type%latb*dtr
- case('radian')
- case default
- call mpp_error(FATAL, "interpolator_init : Units for latb not recognised in file "//file_name)
- end select
- case('lonb')
- nlonb=len
- allocate(clim_type%lonb(nlonb))
- call mpp_get_axis_data(axes(i),clim_type%lonb)
- select case(units(1:6))
- case('degree')
- clim_type%lonb = clim_type%lonb*dtr
- case('radian')
- case default
- call mpp_error(FATAL, "interpolator_init : Units for lonb not recognised in file "//file_name)
- end select
- case('pfull')
- nlev=len
- allocate(clim_type%levs(nlev))
- call mpp_get_axis_data(axes(i),clim_type%levs)
- clim_type%level_type = PRESSURE
- ! Convert to Pa
- if( trim(adjustl(lowercase(chomp(units)))) == "mb" .or. trim(adjustl(lowercase(chomp(units)))) == "hpa") then
- clim_type%levs = clim_type%levs * 100.
- end if
-! define the direction of the vertical data axis
-! switch index order if necessary so that indx 1 is at lowest pressure,
-! index nlev at highest pressure.
- if( sense == 1 ) then
- clim_type%vertical_indices = INCREASING_UPWARD
- allocate (alpha(nlev))
- do n = 1, nlev
- alpha(n) = clim_type%levs(nlev-n+1)
- end do
- do n = 1, nlev
- clim_type%levs(n) = alpha(n)
- end do
- deallocate (alpha)
- else
- clim_type%vertical_indices = INCREASING_DOWNWARD
- endif
-
- case('phalf')
- nlevh=len
- allocate(clim_type%halflevs(nlevh))
- call mpp_get_axis_data(axes(i),clim_type%halflevs)
- clim_type%level_type = PRESSURE
- ! Convert to Pa
- if( trim(adjustl(lowercase(chomp(units)))) == "mb" .or. trim(adjustl(lowercase(chomp(units)))) == "hpa") then
- clim_type%halflevs = clim_type%halflevs * 100.
- end if
-! define the direction of the vertical data axis
-! switch index order if necessary so that indx 1 is at lowest pressure,
-! index nlev at highest pressure.
- if( sense == 1 ) then
- clim_type%vertical_indices = INCREASING_UPWARD
- allocate (alpha(nlevh))
- do n = 1, nlevh
- alpha(n) = clim_type%halflevs(nlevh-n+1)
- end do
- do n = 1, nlevh
- clim_type%halflevs(n) = alpha(n)
- end do
- deallocate (alpha)
- else
- clim_type%vertical_indices = INCREASING_DOWNWARD
- endif
- case('sigma_full')
- nlev=len
- allocate(clim_type%levs(nlev))
- call mpp_get_axis_data(axes(i),clim_type%levs)
- clim_type%level_type = SIGMA
- case('sigma_half')
- nlevh=len
- allocate(clim_type%halflevs(nlevh))
- call mpp_get_axis_data(axes(i),clim_type%halflevs)
- clim_type%level_type = SIGMA
-
- case('time')
- model_calendar = get_calendar_type()
- fileday = 0
- filemon = 0
- fileyr = 0
- filehr = 0
- filemin= 0
- filesec = 0
- select case(units(:3))
- case('day')
- fileunits = units(12:) !Assuming "days since YYYY-MM-DD HH:MM:SS"
- if ( len_trim(fileunits) < 19 ) then
- write(error_mesg, '(A49,A,A49,A)' ) &
- 'Interpolator_init : Incorrect time units in file ', &
- trim(file_name), '. Expecting days since YYYY-MM-DD HH:MM:SS, found', &
- trim(units)
- call mpp_error(FATAL,error_mesg)
- endif
- read(fileunits(1:4) , *) fileyr
- read(fileunits(6:7) , *) filemon
- read(fileunits(9:10) , *) fileday
- read(fileunits(12:13), *) filehr
- read(fileunits(15:16), *) filemin
- read(fileunits(18:19), *) filesec
- case('mon')
- fileunits = units(14:) !Assuming "months since YYYY-MM-DD HH:MM:SS"
- if ( len_trim(fileunits) < 19 ) then
- write(error_mesg, '(A49,A,A51,A)' ) &
- 'Interpolator_init : Incorrect time units in file ', &
- trim(file_name), '. Expecting months since YYYY-MM-DD HH:MM:SS, found', &
- trim(units)
- call mpp_error(FATAL,error_mesg)
- endif
- read(fileunits(1:4) , *) fileyr
- read(fileunits(6:7) , *) filemon
- read(fileunits(9:10) , *) fileday
- read(fileunits(12:13), *) filehr
- read(fileunits(15:16), *) filemin
- read(fileunits(18:19), *) filesec
- case default
- call mpp_error(FATAL,'Interpolator_init : Time units not recognised in file '//file_name)
- end select
-
- clim_type%climatological_year = (fileyr == 0)
-
- if (.not. clim_type%climatological_year) then
-
-!----------------------------------------------------------------------
-! if file date has a non-zero year in the base time, determine that
-! base_time based on the netcdf info.
-!----------------------------------------------------------------------
- if ( (model_calendar == JULIAN .and. &
- & trim(adjustl(lowercase(file_calendar))) == 'julian') .or. &
- & (model_calendar == NOLEAP .and. &
- & trim(adjustl(lowercase(file_calendar))) == 'noleap') ) then
- call mpp_error (NOTE, 'interpolator[1]_mod: Model and file&
- & calendars are the same for file ' // &
- & trim(file_name) // '; no calendar conversion &
- &needed')
- base_time = set_date (fileyr, filemon, fileday, filehr, &
- filemin,filesec)
- else if ( (model_calendar == JULIAN .and. &
- & trim(adjustl(lowercase(file_calendar))) == 'noleap')) then
- call mpp_error (NOTE, 'interpolator[1]_mod: Using julian &
- &model calendar and noleap file calendar&
- & for file ' // trim(file_name) // &
- &'; calendar conversion needed')
- base_time = set_date_no_leap (fileyr, filemon, fileday, &
- & filehr, filemin, filesec)
- else if ( (model_calendar == NOLEAP .and. &
- & trim(adjustl(lowercase(file_calendar))) == 'julian')) then
- call mpp_error (NOTE, 'interpolator[1]_mod: Using noleap &
- &model calendar and julian file calendar&
- & for file ' // trim(file_name) // &
- &'; calendar conversion needed')
- base_time = set_date_julian (fileyr, filemon, fileday, &
- & filehr, filemin, filesec)
- else
- call mpp_error (FATAL , 'interpolator[1]_mod: Model and file&
- & calendars ( ' // trim(file_calendar) // ' ) differ &
- &for file ' // trim(file_name) // '; this calendar &
- &conversion not currently available')
- endif
- else
-!! if the year is specified as '0000', then the file is intended to
-!! apply to all years -- the time variables within the file refer to
-!! the displacement from the start of each year to the time of the
-!! associated data. Time interpolation is to be done with interface
-!! time_interp_list, with the optional argument modtime=YEAR. base_time
-!! is set to an arbitrary value here; it's only use will be as a
-!! timestamp for optionally generated diagnostics.
- base_time = get_base_time ()
- endif
- ntime_in = 1
- if (ntime > 0) then
- allocate(time_in(ntime), clim_type%time_slice(ntime))
- allocate(clim_type%clim_times(12,(ntime+11)/12))
- time_in = 0.0
- clim_type%time_slice = set_time(0,0) + base_time
- clim_type%clim_times = set_time(0,0) + base_time
- call mpp_get_times(clim_type%unit, time_in)
- ntime_in = ntime
-! determine whether the data is a continuous set of monthly values or
-! a series of annual cycles spread throughout the period of data
- non_monthly = .false.
- do n = 1, ntime-1
-! Assume that the times in the data file correspond to days only.
- if (time_in(n+1) > (time_in(n) + 32.)) then
- non_monthly = .true.
- exit
- endif
- end do
- if (clim_type%climatological_year) then
- call mpp_error (NOTE, 'interpolator[1]_mod :' // &
- trim(file_name) // ' is a year-independent climatology file')
- else
- call mpp_error (NOTE, 'interpolator[1]_mod :' // &
- trim(file_name) // ' is a timeseries file')
- endif
- do n = 1, ntime
-!Assume that the times in the data file correspond to days only.
- if (clim_type%climatological_year) then
-!! RSH NOTE:
-!! for this case, do not add base_time. time_slice will be sent to
-!! time_interp_list with the optional argument modtime=YEAR, so that
-!! the time that is needed in time_slice is the displacement into the
-!! year, not the displacement from a base_time.
- clim_type%time_slice(n) = &
- set_time(INT( ( time_in(n) - INT(time_in(n)) ) * SECONDS_PER_DAY), &
- INT(time_in(n)))
- else
-!--------------------------------------------------------------------
-! if fileyr /= 0 (i.e., climatological_year=F),
-! then define the times associated with each time-
-! slice. if calendar conversion between data file and model calendar
-! is needed, do it so that data from the file is associated with the
-! same calendar time in the model. here the time_slice needs to
-! include the base_time; values will be generated relative to the
-! "real" time.
-!--------------------------------------------------------------------
- if ( (model_calendar == JULIAN .and. &
- & trim(adjustl(lowercase(file_calendar))) == 'julian') .or. &
- & (model_calendar == NOLEAP .and. &
- & trim(adjustl(lowercase(file_calendar))) == 'noleap') ) then
-!---------------------------------------------------------------------
-! no calendar conversion needed.
-!---------------------------------------------------------------------
- clim_type%time_slice(n) = &
- set_time(INT( ( time_in(n) - INT(time_in(n)) ) * SECONDS_PER_DAY ),&
- INT(time_in(n))) &
- + base_time
-!---------------------------------------------------------------------
-! convert file times from noleap to julian.
-!---------------------------------------------------------------------
- else if ( (model_calendar == JULIAN .and. &
- & trim(adjustl(lowercase(file_calendar))) == 'noleap')) then
- Noleap_time = set_time (0, INT(time_in(n))) + base_time
- call get_date_no_leap (Noleap_time, yr, mo, dy, hr, &
- mn, sc)
- clim_type%time_slice(n) = set_date_julian (yr, mo, dy, &
- hr, mn, sc)
- if (n == 1) then
- call print_date (clim_type%time_slice(1), &
- str= 'for file ' // trim(file_name) // ', the &
- &first time slice is mapped to :')
- endif
- if (n == ntime) then
- call print_date (clim_type%time_slice(ntime), &
- str= 'for file ' // trim(file_name) // ', the &
- &last time slice is mapped to:')
- endif
-!---------------------------------------------------------------------
-! convert file times from julian to noleap.
-!---------------------------------------------------------------------
- else if ( (model_calendar == NOLEAP .and. &
- & trim(adjustl(lowercase(file_calendar))) == 'julian')) then
- Julian_time = set_time (0, INT(time_in(n))) + base_time
- call get_date_julian (Julian_time, yr, mo, dy, hr, mn, sc)
- clim_type%time_slice(n) = set_date_no_leap (yr, mo, dy, &
- hr, mn, sc)
- if (n == 1) then
- call print_date (clim_type%time_slice(1), &
- str= 'for file ' // trim(file_name) // ', the &
- &first time slice is mapped to :')
- endif
- if (n == ntime) then
- call print_date (clim_type%time_slice(ntime), &
- str= 'for file ' // trim(file_name) // ', the &
- &last time slice is mapped to:')
- endif
-!---------------------------------------------------------------------
-! any other calendar combinations would have caused a fatal error
-! above.
-!---------------------------------------------------------------------
- endif
- endif
- m = (n-1)/12 +1 ; m1 = n- (m-1)*12
- clim_type%clim_times(m1,m) = clim_type%time_slice(n)
- enddo
- else
- allocate(time_in(1), clim_type%time_slice(1))
- allocate(clim_type%clim_times(1,1))
- time_in = 0.0
- clim_type%time_slice = set_time(0,0) + base_time
- clim_type%clim_times(1,1) = set_time(0,0) + base_time
- endif
- deallocate(time_in)
- end select ! case(name)
-enddo
-! -------------------------------------------------------------------
-! For 2-D fields, allocate levs and halflevs here
-! code is still needed for case when only halflevs are in data file.
-! -------------------------------------------------------------------
- if( .not. associated(clim_type%levs) ) then
- allocate( clim_type%levs(nlev) )
- clim_type%levs = 0.0
- endif
- if( .not. associated(clim_type%halflevs) ) then
- allocate( clim_type%halflevs(nlev+1) )
- clim_type%halflevs(1) = 0.0
- if (clim_type%level_type == PRESSURE) then
- clim_type%halflevs(nlev+1) = 1013.25* 100.0 ! MKS
- else if (clim_type%level_type == SIGMA ) then
- clim_type%halflevs(nlev+1) = 1.0
- endif
- do n=2,nlev
- clim_type%halflevs(n) = 0.5*(clim_type%levs(n) + &
- clim_type%levs(n-1))
- end do
- endif
-deallocate(axes)
-! In the case where only the midpoints of the longitudes are defined we force
-! the definition
-! of the boundaries to be half-way between the midpoints.
-if (.not. associated(clim_type%lon) .and. .not. associated(clim_type%lonb)) &
- call mpp_error(FATAL,'Interpolator_init : There appears to be no longitude axis in file '//file_name)
-if (.not. associated(clim_type%lonb) ) then
- if (size(clim_type%lon(:)) /= 1) then
- allocate(clim_type%lonb(size(clim_type%lon(:))+1))
- dlon = (clim_type%lon(2)-clim_type%lon(1))/2.0
- clim_type%lonb(1) = clim_type%lon(1) - dlon
- clim_type%lonb(2:) = clim_type%lon(1:) + dlon
- else
-!! this is the case for zonal mean data, lon = 1, lonb not present
-!! in file.
- allocate(clim_type%lonb(2))
- clim_type%lonb(1) = -360.*dtr
- clim_type%lonb(2) = 360.0*dtr
- clim_type%lon(1) = 0.0
- endif
-endif
-!clim_type%lonb=clim_type%lonb*dtr
-! This assumes the lonb are in degrees in the NetCDF file!
-if (.not. associated(clim_type%lat) .and. .not. associated(clim_type%latb)) &
- call mpp_error(FATAL,'Interpolator_init : There appears to be no latitude axis in file '//file_name)
-! In the case where only the grid midpoints of the latitudes are defined we
-! force the
-! definition of the boundaries to be half-way between the midpoints.
-if (.not. associated(clim_type%latb) ) then
- allocate(clim_type%latb(nlat+1))
- dlat = (clim_type%lat(2)-clim_type%lat(1)) * 0.5
-! clim_type%latb(1) = min( 90., max(-90., clim_type%lat(1) - dlat) )
- clim_type%latb(1) = min( PI/2., max(-PI/2., clim_type%lat(1) - dlat) )
- clim_type%latb(2:nlat) = ( clim_type%lat(1:nlat-1) + clim_type%lat(2:nlat) )* 0.5
- dlat = ( clim_type%lat(nlat) - clim_type%lat(nlat-1) ) * 0.5
-! clim_type%latb(nlat+1) = min( 90., max(-90., clim_type%lat(nlat) + dlat) )
- clim_type%latb(nlat+1) = min( PI/2., max(-PI/2., clim_type%lat(nlat) + dlat))
-endif
-!clim_type%latb=clim_type%latb*dtr
-!Assume that the horizontal interpolation within a file is the same for each
-!variable.
- if (conservative_interp) then
- call horiz_interp_new (clim_type%interph, &
- clim_type%lonb, clim_type%latb, &
- lonb_mod, latb_mod)
- else
- call mpp_error(NOTE, "Using Bilinear interpolation")
- !!! DEBUG CODE
- if (.not. allocated(agrid_mod)) then
- nx = size(lonb_mod,1)-1
- ny = size(latb_mod,2)-1
- allocate(agrid_mod(nx,ny,2))
- do j=1,ny
- do i=1,nx
- call cell_center2((/lonb_mod(i,j),latb_mod(i,j)/), &
- (/lonb_mod(i+1,j),latb_mod(i+1,j)/), &
- (/lonb_mod(i,j+1),latb_mod(i,j+1)/), &
- (/lonb_mod(i+1,j+1),latb_mod(i+1,j+1)/), agrid_mod(i,j,:))
- enddo
- enddo
- endif
- !!! END DEBUG CODE
- call horiz_interp_new (clim_type%interph, &
- clim_type%lonb, clim_type%latb, &
- agrid_mod(:,:,1), agrid_mod(:,:,2), interp_method="bilinear")
- endif
-!--------------------------------------------------------------------
-! allocate the variable clim_type%data . This will be the climatology
-! data horizontally interpolated, so it will be on the model horizontal
-! grid, but it will still be on the climatology vertical grid.
-!--------------------------------------------------------------------
-select case(ntime)
- case (13:)
-! This may be data that does not have a continous time-line
-! i.e. IPCC data where decadal data is present but we wish to retain
-! the seasonal nature of the data.
-!! RSH: the following test will not always work; instead use the
-!! RSH: non-monthly variable to test on.
-!RSHlast_time = clim_type%time_slice(1) + ( ntime -1 ) * &
-!RSH ( clim_type%time_slice(2) - clim_type%time_slice(1) )
-!RSHif ( last_time < clim_type%time_slice(ntime)) then
- 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%pmon_pyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields))
- allocate(clim_type%pmon_nyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields))
- allocate(clim_type%nmon_nyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields))
- allocate(clim_type%nmon_pyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields))
- clim_type%pmon_pyear = 0.0
- clim_type%pmon_nyear = 0.0
- clim_type%nmon_nyear = 0.0
- clim_type%nmon_pyear = 0.0
- clim_type%TIME_FLAG = BILINEAR
-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%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields))
- else
- allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, &
- ntime, num_fields))
- endif
- clim_type%data = 0.0
- clim_type%TIME_FLAG = LINEAR
-endif
-!++lwh
- case (1:12)
-!--lwh
-! We have more than 4 timelevels
-! 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%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields))
- else
- allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, &
- ntime, num_fields))
- endif
- clim_type%data = 0.0
- 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
-! clim_type%TIME_FLAG = SEASONAL
-!--lwh
-! case (default)
- case(:0)
- clim_type%TIME_FLAG = NOTIME
- allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 1, num_fields))
-end select
-!------------------------------------------------------------------
-! Allocate space for the single time level of the climatology on its
-! grid size.
-!----------------------------------------------------------------------
- if(clim_type%TIME_FLAG .eq. LINEAR ) then
- allocate(clim_type%time_init(num_fields,2))
- else
- allocate(clim_type%time_init(num_fields,ntime))
- endif
- allocate (clim_type%indexm(num_fields), &
- clim_type%indexp(num_fields), &
- clim_type%climatology(num_fields))
- clim_type%time_init(:,:) = 0
- clim_type%indexm(:) = 0
- clim_type%indexp(:) = 0
- clim_type%climatology(:) = 0
-allocate(clim_type%field_name(num_fields))
-allocate(clim_type%field_type(num_fields))
-allocate(clim_type%mr(num_fields))
-allocate(clim_type%out_of_bounds(num_fields))
-clim_type%out_of_bounds(:)=0
-allocate(clim_type%vert_interp(num_fields))
-clim_type%vert_interp(:)=0
-!--------------------------------------------------------------------
-!Allocate the space for the fields within the climatology data file.
-allocate(varfields(nvar))
-!--------------------------------------------------------------------
-! Get the variable names out of the file.
-call mpp_get_fields(clim_type%unit, varfields)
-if(present(data_names)) then
-!++lwh
- if ( size(data_out_of_bounds(:)) /= size(data_names(:)) .and. size(data_out_of_bounds(:)) /= 1 ) &
- call mpp_error(FATAL,'interpolator_init : The size of the data_out_of_bounds array must be 1&
- & or size(data_names)')
- if (present(vert_interp)) then
- if( size(vert_interp(:)) /= size(data_names(:)) .and. size(vert_interp(:)) /= 1 ) &
- call mpp_error(FATAL,'interpolator_init : The size of the vert_interp array must be 1&
- & or size(data_names)')
- endif
-! Only read the fields named in data_names
- do j=1,size(data_names(:))
- NAME_PRESENT = .FALSE.
- do i=1,nvar
- call mpp_get_atts(varfields(i),name=name,ndim=ndim,units=units)
- if( trim(adjustl(lowercase(name))) == trim(adjustl(lowercase(data_names(j)))) ) then
- units=chomp(units)
- if (mpp_pe() == 0 ) write(*,*) 'Initializing src field : ',trim(name)
- clim_type%field_name(j) = name
- clim_type%field_type(j) = varfields(i)
- clim_type%mr(j) = check_climo_units(units)
- NAME_PRESENT = .TRUE.
- if (present(clim_units)) clim_units(j) = units
- clim_type%out_of_bounds(j) = data_out_of_bounds(MIN(j,SIZE(data_out_of_bounds(:))) )
- if( clim_type%out_of_bounds(j) /= CONSTANT .and. &
- clim_type%out_of_bounds(j) /= ZERO ) &
- call mpp_error(FATAL,"Interpolator_init: data_out_of_bounds must be&
- & set to ZERO or CONSTANT")
- if( present(vert_interp) ) then
- clim_type%vert_interp(j) = vert_interp(MIN(j,SIZE(vert_interp(:))) )
- if( clim_type%vert_interp(j) /= INTERP_WEIGHTED_P .and. &
- clim_type%vert_interp(j) /= INTERP_LINEAR_P ) &
- call mpp_error(FATAL,"Interpolator_init: vert_interp must be&
- & set to INTERP_WEIGHTED_P or INTERP_LINEAR_P")
- else
- clim_type%vert_interp(j) = INTERP_WEIGHTED_P
- end if
- endif
- enddo
- if(.not. NAME_PRESENT) &
- call mpp_error(FATAL,'interpolator_init : Check names of fields being passed. ' &
- //trim(data_names(j))//' does not exist.')
- enddo
-else
-
- if ( size(data_out_of_bounds(:)) /= nvar .and. size(data_out_of_bounds(:)) /= 1 ) &
- call mpp_error(FATAL,'interpolator_init : The size of the out of bounds array must be 1&
- & or the number of fields in the climatology dataset')
- if ( present(vert_interp) ) then
- if (size(vert_interp(:)) /= nvar .and. size(vert_interp(:)) /= 1 ) &
- call mpp_error(FATAL,'interpolator_init : The size of the vert_interp array must be 1&
- & or the number of fields in the climatology dataset')
- endif
-
-! Read all the fields within the climatology data file.
- do i=1,nvar
- call mpp_get_atts(varfields(i),name=name,ndim=ndim,units=units)
- if (mpp_pe() ==0 ) write(*,*) 'Initializing src field : ',trim(name)
- clim_type%field_name(i) = lowercase(trim(name))
- clim_type%field_type(i) = varfields(i)
- clim_type%mr(i) = check_climo_units(units)
- if (present(clim_units)) clim_units(i) = units
- clim_type%out_of_bounds(i) = data_out_of_bounds(MIN(i,SIZE(data_out_of_bounds(:))) )
- if( clim_type%out_of_bounds(i) /= CONSTANT .and. &
- clim_type%out_of_bounds(i) /= ZERO ) &
- call mpp_error(FATAL,"Interpolator_init: data_out_of_bounds must be&
- & set to ZERO or CONSTANT")
- if( present(vert_interp) ) then
- clim_type%vert_interp(i) = vert_interp( MIN(i,SIZE(vert_interp(:))))
- if( clim_type%vert_interp(i) /= INTERP_WEIGHTED_P .and. &
- clim_type%vert_interp(i) /= INTERP_LINEAR_P ) &
- call mpp_error(FATAL,"Interpolator_init: vert_interp must be&
- & set to INTERP_WEIGHTED_P or INTERP_LINEAR_P")
- else
- clim_type%vert_interp(i) = INTERP_WEIGHTED_P
- end if
- end do
-!--lwh
-endif
-
-deallocate(varfields)
-
-
-if( clim_type%TIME_FLAG .eq. SEASONAL ) then
-! Read all the data at this point.
- do i=1,num_fields
- do n = 1, ntime
- call interp_read_data_mppio( clim_type, clim_type%field_type(i), &
- clim_type%data(:,:,:,n,i), n, i, base_time )
- enddo
- enddo
-endif
-
-if( clim_type%TIME_FLAG .eq. LINEAR .and. read_all_on_init) then
-! Read all the data at this point.
- do i=1,num_fields
- do n = 1, ntime
- call interp_read_data_mppio( clim_type, clim_type%field_type(i), &
- clim_type%data(:,:,:,n,i), n, i, base_time )
- enddo
- enddo
-
- call mpp_close (unit)
-endif
-
-if( clim_type%TIME_FLAG .eq. NOTIME ) then
-! Read all the data at this point.
- do i=1,num_fields
- call interp_read_data_mppio_no_time_axis( clim_type, clim_type%field_type(i),&
- clim_type%data(:,:,:,1,i), i )
- enddo
- call mpp_close (unit)
-endif
-
-if (present (single_year_file)) then
- single_year_file = clim_type%climatological_year
-endif
-
-end subroutine mppio_interpolator_init
-
-!> @brief interp_read_data_mppio receives various climate data as inputs and
-!! returns a horizontally interpolated climatology field.
-!!
-!! @param [in] The interpolate type which contains the data
-!! @param [in] The field type
-!! @param [in] The index of the time slice of the climatology that you wish
-!to read
-!! @param [in] OPTIONAL: The index of the field name that you are trying to
-!read
-!! @param [in]
@@ -1616,9 +1592,7 @@ end function get_ticks_per_second
!
!> @brief Gets the date for different calendar types.
- !! The added optional argument old_method allows user to choose either the new or old version
- !! of get_date_gregorian. The variable old_method is only useful if the calendar type is Gregorian
- subroutine get_date(time, year, month, day, hour, minute, second, tick, err_msg, old_method)
+ subroutine get_date(time, year, month, day, hour, minute, second, tick, err_msg)
! Given a time, computes the corresponding date given the selected calendar
@@ -1626,32 +1600,21 @@ subroutine get_date(time, year, month, day, hour, minute, second, tick, err_msg,
integer, intent(out) :: second, minute, hour, day, month, year
integer, intent(out), optional :: tick
character(len=*), intent(out), optional :: err_msg
- logical, intent(in), optional :: old_method !< option to choose betw the new and old ver of get_date_gregorian subroutine.
- !! When .true., call get_date_gregorian_old to retrieve the date
- !! from the array coded_date. When .false., call get_date_gregorian to
- !! compute the date on the fly.
character(len=128) :: err_msg_local
integer :: tick1
- logical :: old_method_local !< set as .false.. Takes on the value of old_method if old_method is present.
if(.not.module_is_initialized) call time_manager_init
if(present(err_msg)) err_msg = ''
select case(calendar_type)
case(THIRTY_DAY_MONTHS)
- call get_date_thirty (time, year, month, day, hour, minute, second, tick1)
+ call get_date_thirty(time, year, month, day, hour, minute, second, tick1)
case(GREGORIAN)
- old_method_local=.false.
- if(present(old_method)) old_method_local=old_method
- if(old_method_local) then
- call get_date_gregorian_old(time, year, month, day, hour, minute, second, tick1)
- else
- call get_date_gregorian(time, year, month, day, hour, minute, second, tick1)
- end if
+ call get_date_gregorian(time, year, month, day, hour, minute, second, tick1)
case(JULIAN)
- call get_date_julian_private (time, year, month, day, hour, minute, second, tick1)
+ call get_date_julian_private(time, year, month, day, hour, minute, second, tick1)
case(NOLEAP)
- call get_date_no_leap_private (time, year, month, day, hour, minute, second, tick1)
+ call get_date_no_leap_private(time, year, month, day, hour, minute, second, tick1)
case(NO_CALENDAR)
err_msg_local = 'Cannot produce a date when the calendar type is NO_CALENDAR'
if(error_handler('subroutine get_date', err_msg_local, err_msg)) return
@@ -1753,39 +1716,6 @@ subroutine get_date_gregorian(time, year, month, day, hour, minute, second, tick
end subroutine get_date_gregorian
!------------------------------------------------------------------------
-!> @brief Gets the date on a Gregorian calendar. This is the original/old subroutine.
-!! Looks up the year, month, day from the coded_date array
-!! This subroutine is kept in order to test the new get_date_gregorian
- subroutine get_date_gregorian_old(time, year, month, day, hour, minute, second, tick)
-
-! Computes date corresponding to time for gregorian calendar
-
- type(time_type), intent(in) :: time
- integer, intent(out) :: year, month, day, hour, minute, second
- integer, intent(out) :: tick
- integer :: iday, isec
-
- if(Time%seconds >= 86400) then ! This check appears to be unecessary.
- call error_mesg('get_date','Time%seconds .ge. 86400 in subroutine get_date_gregorian_old',FATAL)
- endif
-
- iday = mod(Time%days+1,days_in_400_year_period)
- if(iday == 0) iday = days_in_400_year_period
-
- year = coded_date(iday)/512
- day = mod(coded_date(iday),32)
- month = coded_date(iday)/32 - 16*year
-
- year = year + 400*((Time%days)/days_in_400_year_period)
-
- hour = Time%seconds / 3600
- isec = Time%seconds - 3600*hour
- minute = isec / 60
- second = isec - 60*minute
- tick = time%ticks
-
- end subroutine get_date_gregorian_old
-!------------------------------------------------------------------------
function cut0(string)
character(len=256) :: cut0
character(len=*), intent(in) :: string
@@ -1992,9 +1922,7 @@ end subroutine get_date_no_leap
! A time interval.
!> @brief Sets days for different calendar types.
-!! The added optional argument old_method allows user to choose either the new or old version
-!! of set_date_gregorian. The variable old_method is only useful if the calendar type is Gregorian
- function set_date_private(year, month, day, hour, minute, second, tick, Time_out, err_msg, old_method)
+ function set_date_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
! Given a date, computes the corresponding time given the selected
! date time mapping algorithm. Note that it is possible to specify
@@ -2005,11 +1933,6 @@ function set_date_private(year, month, day, hour, minute, second, tick, Time_out
integer, intent(in) :: year, month, day, hour, minute, second, tick
type(time_type) :: Time_out
character(len=*), intent(out) :: err_msg
- logical, intent(in), optional ::old_method !< option to choose betw the new and old ver of get_date_gregorian subroutine.
- !! When .true., call set_date_gregorian_old to retrieve the time%days
- !! from the array date_to_day. When .false., call set_date_gregorian to
- !! compute the time%days on the fly.
- logical :: old_method_local !< set as .false.. Takes on the value of old_method if old_method is present.
if(.not.module_is_initialized) call time_manager_init
@@ -2017,19 +1940,13 @@ function set_date_private(year, month, day, hour, minute, second, tick, Time_out
select case(calendar_type)
case(THIRTY_DAY_MONTHS)
- set_date_private = set_date_thirty (year, month, day, hour, minute, second, tick, Time_out, err_msg)
+ set_date_private = set_date_thirty (year, month, day, hour, minute, second, tick, Time_out, err_msg)
case(GREGORIAN)
- old_method_local = .false.
- if( present(old_method) ) old_method_local=old_method
- if( old_method_local ) then
- set_date_private = set_date_gregorian_old(year, month, day, hour, minute, second, tick, Time_out, err_msg)
- else
- set_date_private = set_date_gregorian(year, month, day, hour, minute, second, tick, Time_out, err_msg)
- end if
+ set_date_private = set_date_gregorian (year, month, day, hour, minute, second, tick, Time_out, err_msg)
case(JULIAN)
- set_date_private = set_date_julian_private (year, month, day, hour, minute, second, tick, Time_out, err_msg)
+ set_date_private = set_date_julian_private (year, month, day, hour, minute, second, tick, Time_out, err_msg)
case(NOLEAP)
- set_date_private = set_date_no_leap_private (year, month, day, hour, minute, second, tick, Time_out, err_msg)
+ set_date_private = set_date_no_leap_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
case (NO_CALENDAR)
err_msg = 'Cannot produce a date when calendar type is NO_CALENDAR'
set_date_private = .false.
@@ -2044,20 +1961,13 @@ end function set_date_private
!------------------------------------------------------------------------
!> @brief Calls set_date_private to set days for different calendar types.
- !! The added optional argument old_method allows user to choose either the new or old version
- !! of set_date_gregorian. The variable old_method is only useful if the calendar type is Gregorian
- function set_date_i(year, month, day, hour, minute, second, tick, err_msg, old_method)
+ function set_date_i(year, month, day, hour, minute, second, tick, err_msg)
type(time_type) :: set_date_i
integer, intent(in) :: day, month, year
integer, intent(in), optional :: second, minute, hour, tick
- logical, intent(in), optional :: old_method !< option to choose betw the new and old ver of get_date_gregorian subroutine.
- !! When .true., call set_date_gregorian_old to retrieve the time%days
- !! from the array date_to_day. When .false., call set_date_gregorian to
- !! compute the time%days on the fly.
character(len=*), intent(out), optional :: err_msg
integer :: osecond, ominute, ohour, otick
character(len=128) :: err_msg_local
- logical :: old_method_local !< set as .false.. Takes on the value of old_method if old_method is present.
if(.not.module_is_initialized) call time_manager_init
if(present(err_msg)) err_msg = ''
@@ -2068,9 +1978,7 @@ function set_date_i(year, month, day, hour, minute, second, tick, err_msg, old_m
ohour = 0; if(present(hour)) ohour = hour
otick = 0; if(present(tick)) otick = tick
- old_method_local = .false.
- if( present(old_method) ) old_method_local=old_method
- if(.not.set_date_private(year, month, day, ohour, ominute, osecond, otick, set_date_i, err_msg_local, old_method=old_method_local)) then
+ if(.not.set_date_private(year, month, day, ohour, ominute, osecond, otick, set_date_i, err_msg_local)) then
if(error_handler('function set_date_i', err_msg_local, err_msg)) return
end if
@@ -2078,9 +1986,7 @@ end function set_date_i
!------------------------------------------------------------------------
!> @brief Calls set_date_private for different calendar types when given a string input.
- !! The added optional argument old_method allows user to choose either the new or old version
- !! of set_date_gregorian. The variable old_method is only useful if the calendar type is Gregorian
- function set_date_c(string, zero_year_warning, err_msg, allow_rounding, old_method)
+ function set_date_c(string, zero_year_warning, err_msg, allow_rounding)
! Examples of acceptable forms of string:
@@ -2106,13 +2012,8 @@ function set_date_c(string, zero_year_warning, err_msg, allow_rounding, old_meth
logical, intent(in), optional :: zero_year_warning
character(len=*), intent(out), optional :: err_msg
logical, intent(in), optional :: allow_rounding
- logical, intent(in), optional :: old_method !< option to choose betw the new and old ver of set_date_gregorian.
- !! When .true., call set_date_gregorian_old to retrieve the days
- !! from the array date_to_day. When .false., call set_date_gregorian to
- !! compute the days on the fly.
character(len=4) :: formt='(i )'
logical :: correct_form, zero_year_warning_local, allow_rounding_local
- logical :: old_method_local !< set as .false.. Takes on the value of old_method if old_method is present.
integer :: i1, i2, i3, i4, i5, i6, i7
character(len=32) :: string_sifted_left
integer :: year, month, day, hour, minute, second, tick
@@ -2199,9 +2100,7 @@ function set_date_c(string, zero_year_warning, err_msg, allow_rounding, old_meth
endif
endif
- old_method_local = .false.
- if( present(old_method) ) old_method_local = old_method
- if(.not.set_date_private(year, month, day, hour, minute, second, tick, set_date_c, err_msg_local,old_method=old_method_local)) then
+ if(.not.set_date_private(year, month, day, hour, minute, second, tick, set_date_c, err_msg_local)) then
if(error_handler('function set_date_c', err_msg_local, err_msg)) return
end if
@@ -2256,9 +2155,9 @@ function set_date_gregorian(year, month, day, hour, minute, second, tick, Time_o
select case( month )
case(1) ; dayx = dayx
- case(2) ; dayx = dayx + 31
- case(3) ; dayx = dayx + 59 + l
- case(4) ; dayx = dayx + 90 + l
+ case(2) ; dayx = dayx + 31
+ case(3) ; dayx = dayx + 59 + l
+ case(4) ; dayx = dayx + 90 + l
case(5) ; dayx = dayx + 120 + l
case(6) ; dayx = dayx + 151 + l
case(7) ; dayx = dayx + 181 + l
@@ -2294,43 +2193,6 @@ end function set_date_gregorian
!------------------------------------------------------------------------
-!> @brief Sets Time_out%days on a Gregorian calendar. This is the original/old subroutine.
-!! Look up the total number of days between 1/1/0001 to the current month/day/year in the array date_to_day
-!! This function is kept in order to test the new set_date_gregorian
- function set_date_gregorian_old(year, month, day, hour, minute, second, tick, Time_out, err_msg)
- logical :: set_date_gregorian_old
-
-! Computes time corresponding to date for gregorian calendar.
-
- integer, intent(in) :: year, month, day, hour, minute, second, tick
- type(time_type), intent(out) :: Time_out
- character(len=*), intent(out) :: err_msg
- integer :: yr1, day1
-
- if( .not.valid_increments(year,month,day,hour,minute,second,tick,err_msg) ) then
- set_date_gregorian_old = .false.
- return
- endif
-
- Time_out%seconds = second + 60*(minute + 60*hour)
-
- yr1 = mod(year,400)
- if(yr1 == 0) yr1 = 400
- day1 = date_to_day(yr1,month,day)
- if(day1 == invalid_date) then
- err_msg = 'Invalid_date. Date='//convert_integer_date_to_char(year,month,day,hour,minute,second)
- set_date_gregorian_old = .false.
- return
- endif
-
- Time_out%days = day1 + days_in_400_year_period*((year-1)/400)
- Time_out%ticks = tick
- err_msg = ''
- set_date_gregorian_old = .true.
-
- end function set_date_gregorian_old
-
-!------------------------------------------------------------------------
function set_date_julian_private(year, month, day, hour, minute, second, tick, Time_out, err_msg)
logical :: set_date_julian_private
diff --git a/topography/topography.F90 b/topography/topography.F90
index 68e614a382..8e17af5762 100644
--- a/topography/topography.F90
+++ b/topography/topography.F90
@@ -50,9 +50,6 @@ module topography_mod
mpp_error
! required for fms2_io
use fms2_io_mod, only: read_data, FmsNetcdfFile_t, file_exists, open_file
-! required for mpp_io
-use fms_io_mod, only: read_data_mpp_io=>read_data, file_exist, open_ieee32_file
-use fms_mod, only: close_file
!-----------------------------------------------------------------------
use constants_mod, only: PI
@@ -193,7 +190,7 @@ module topography_mod
!> @addtogroup topography_mod
!> @{
- logical :: use_mpp_io=.false.!>@var Namelist flag to enable usage of mpp_io subroutines if true
+ logical :: use_mpp_io=.false.!>@var deprecated namelist variable for using mpp_io in this module
character(len=128) :: topog_file = 'DATA/navy_topography.data', &
water_file = 'DATA/navy_pctwater.data'
namelist /topography_nml/ topog_file, water_file, use_mpp_io
@@ -248,21 +245,13 @@ module topography_mod
!#######################################################################
subroutine topography_init ()
- integer :: std_log !> @var standard log unit number to output which io is being used
if ( module_is_initialized ) return
-
call write_version_number("TOPOGRAPHY_MOD", version)
call read_namelist
module_is_initialized = .TRUE.
- std_log = stdlog()
- if ( use_mpp_io ) then
- call error_mesg('topography_init',"Using mpp_io in topography_mod",NOTE)
- if( mpp_pe() == mpp_root_pe()) write(std_log, '(a)')"Using mpp_io in topography_mod"
- if( mpp_pe() == mpp_root_pe()) write(std_log, '(a)')&
- 'WARNING:: MPP_IO is no longer supported. Please remove from namelist'
- else
- call error_mesg('topography_init',"Using fms2_io in topography_mod",NOTE)
- if( mpp_pe() == mpp_root_pe()) write(std_log, '(a)')"Using fms2_io in topography_mod"
+ if (use_mpp_io) then
+ call mpp_error('topography_mod', &
+ 'MPP_IO is no longer supported. Please remove use_mpp_io from topography_nml', FATAL)
endif
end subroutine topography_init
@@ -295,11 +284,7 @@ function get_topog_mean_1d(blon, blat, zmean)
call error_mesg('get_topog_mean_1d','shape(zmean) is not&
& equal to (/size(blon)-1,size(blat)-1/))', FATAL)
- if( use_mpp_io ) then
- get_topog_mean_1d = open_topog_file_mpp_io(topog_file)
- else
- get_topog_mean_1d = open_topog_file()
- endif
+ get_topog_mean_1d = open_topog_file()
if ( get_topog_mean_1d ) call interp_topog_1d ( blon, blat, zmean)
@@ -322,11 +307,7 @@ function get_topog_mean_2d (blon, blat, zmean)
call error_mesg('get_topog_mean_2d','shape(zmean) is not&
& equal to (/size(blon,1)-1,size(blon,2)-1/))', FATAL)
- if( use_mpp_io ) then
- get_topog_mean_2d = open_topog_file_mpp_io(topog_file)
- else
- get_topog_mean_2d = open_topog_file()
- endif
+ get_topog_mean_2d = open_topog_file()
if ( get_topog_mean_2d ) call interp_topog_2d ( blon, blat, zmean)
!-----------------------------------------------------------------------
@@ -359,11 +340,8 @@ function get_topog_stdev_1d (blon, blat, stdev)
call error_mesg('get_topog_stdev','shape(stdev) is not&
& equal to (/size(blon)-1,size(blat)-1/))', FATAL)
- if( use_mpp_io ) then
- get_topog_stdev_1d = open_topog_file_mpp_io(topog_file)
- else
- get_topog_stdev_1d = open_topog_file()
- endif
+ get_topog_stdev_1d = open_topog_file()
+
if ( get_topog_stdev_1d ) call interp_topog_1d ( blon, blat, &
stdev, flag=COMPUTE_STDEV)
@@ -386,11 +364,8 @@ function get_topog_stdev_2d (blon, blat, stdev)
call error_mesg('get_topog_stdev_2d','shape(stdev) is not&
& equal to (/size(blon,1)-1,size(blon,2)-1/))', FATAL)
- if( use_mpp_io ) then
- get_topog_stdev_2d = open_topog_file_mpp_io(topog_file)
- else
- get_topog_stdev_2d = open_topog_file()
- endif
+ get_topog_stdev_2d = open_topog_file()
+
if ( get_topog_stdev_2d ) call interp_topog_2d ( blon, blat, &
stdev, flag=COMPUTE_STDEV)
!-----------------------------------------------------------------------
@@ -416,15 +391,9 @@ function get_ocean_frac_1d (blon, blat, ocean_frac)
call error_mesg('get_ocean_frac','shape(ocean_frac) is not&
& equal to (/size(blon)-1,size(blat)-1/))', FATAL)
- if( use_mpp_io) then
- get_ocean_frac_1d = open_topog_file_mpp_io(water_file)
- if( get_ocean_frac_1d) call interp_water_1d_mpp_io ( blon, blat, &
- ocean_frac, do_ocean=.true. )
- else
- get_ocean_frac_1d = open_water_file()
- if( get_ocean_frac_1d ) call interp_water_1d ( blon, blat, &
- ocean_frac, do_ocean=.true. )
- endif
+ get_ocean_frac_1d = open_water_file()
+ if( get_ocean_frac_1d ) call interp_water_1d ( blon, blat, &
+ ocean_frac, do_ocean=.true. )
!-----------------------------------------------------------------------
@@ -445,15 +414,9 @@ function get_ocean_frac_2d (blon, blat, ocean_frac)
call error_mesg('get_ocean_frac_2d','shape(ocean_frac) is not&
& equal to (/size(blon,1)-1,size(blon,2)-1/))', FATAL)
- if( use_mpp_io) then
- get_ocean_frac_2d = open_topog_file_mpp_io(water_file)
- if( get_ocean_frac_2d) call interp_water_2d_mpp_io ( blon, blat, &
- ocean_frac, do_ocean=.true. )
- else
- get_ocean_frac_2d = open_water_file()
- if( get_ocean_frac_2d ) call interp_water_2d ( blon, blat, &
- ocean_frac, do_ocean=.true. )
- endif
+ get_ocean_frac_2d = open_water_file()
+ if( get_ocean_frac_2d ) call interp_water_2d ( blon, blat, &
+ ocean_frac, do_ocean=.true. )
!-----------------------------------------------------------------------
@@ -535,13 +498,8 @@ function get_water_frac_1d (blon, blat, water_frac)
call error_mesg('get_water_frac_1d','shape(water_frac) is not&
& equal to (/size(blon)-1,size(blat)-1/))', FATAL)
- if(use_mpp_io) then
- get_water_frac_1d = open_topog_file_mpp_io(water_file)
- if( get_water_frac_1d ) call interp_water_1d_mpp_io ( blon, blat, water_frac )
- else
- get_water_frac_1d = open_water_file()
- if(get_water_frac_1d) call interp_water_1d ( blon, blat, water_frac )
- endif
+ get_water_frac_1d = open_water_file()
+ if(get_water_frac_1d) call interp_water_1d ( blon, blat, water_frac )
!-----------------------------------------------------------------------
@@ -565,13 +523,8 @@ function get_water_frac_2d (blon, blat, water_frac)
call error_mesg('get_water_frac_2d','shape(water_frac) is not&
& equal to (/size(blon,1)-1,size(blon,2)-1/))', FATAL)
- if(use_mpp_io) then
- get_water_frac_2d = open_topog_file_mpp_io(water_file)
- if( get_water_frac_2d ) call interp_water_2d_mpp_io ( blon, blat, water_frac )
- else
- get_water_frac_2d = open_water_file()
- if(get_water_frac_2d) call interp_water_2d ( blon, blat, water_frac )
- endif
+ get_water_frac_2d = open_water_file()
+ if(get_water_frac_2d) call interp_water_2d ( blon, blat, water_frac )
!-----------------------------------------------------------------------
@@ -595,28 +548,15 @@ function get_water_mask_1d (blon, blat, water_mask)
!-----------------------------------------------------------------------
if (.not. module_is_initialized) call topography_init()
- if(use_mpp_io) then
- if ( get_water_frac_1d_mpp_io(blon, blat, water_frac) ) then
- where (water_frac > 0.50)
- water_mask = .true.
- elsewhere
- water_mask = .false.
- end where
- get_water_mask_1d = .true.
- else
- get_water_mask_1d = .false.
- endif
+ if ( get_water_frac_1d(blon, blat, water_frac) ) then
+ where (water_frac > 0.50)
+ water_mask = .true.
+ elsewhere
+ water_mask = .false.
+ end where
+ get_water_mask_1d = .true.
else
- if ( get_water_frac_1d(blon, blat, water_frac) ) then
- where (water_frac > 0.50)
- water_mask = .true.
- elsewhere
- water_mask = .false.
- end where
- get_water_mask_1d = .true.
- else
- get_water_mask_1d = .false.
- endif
+ get_water_mask_1d = .false.
endif
!-----------------------------------------------------------------------
@@ -635,28 +575,15 @@ function get_water_mask_2d (blon, blat, water_mask)
!-----------------------------------------------------------------------
if (.not. module_is_initialized) call topography_init()
- if(use_mpp_io) then
- if ( get_water_frac_2d_mpp_io(blon, blat, water_frac) ) then
- where (water_frac > 0.50)
- water_mask = .true.
- elsewhere
- water_mask = .false.
- end where
- get_water_mask_2d = .true.
- else
- get_water_mask_2d = .false.
- endif
+ if ( get_water_frac_2d(blon, blat, water_frac) ) then
+ where (water_frac > 0.50)
+ water_mask = .true.
+ elsewhere
+ water_mask = .false.
+ end where
+ get_water_mask_2d = .true.
else
- if ( get_water_frac_2d(blon, blat, water_frac) ) then
- where (water_frac > 0.50)
- water_mask = .true.
- elsewhere
- water_mask = .false.
- end where
- get_water_mask_2d = .true.
- else
- get_water_mask_2d = .false.
- endif
+ get_water_mask_2d = .false.
endif
!-----------------------------------------------------------------------
@@ -733,11 +660,7 @@ subroutine interp_topog_1d ( blon, blat, zout, flag)
real :: zdat(ipts,jpts)
real :: zout2(size(zout,1),size(zout,2))
- if(use_mpp_io) then
- call input_data_mpp_io( topog_file, xdat, ydat, zdat )
- else
- call input_data( TOPOG_INDEX, xdat, ydat, zdat)
- endif
+ call input_data( TOPOG_INDEX, xdat, ydat, zdat)
call horiz_interp ( zdat, xdat, ydat, blon, blat, zout )
@@ -770,11 +693,7 @@ subroutine interp_topog_2d ( blon, blat, zout, flag )
integer :: js, je
type (horiz_interp_type) :: Interp
- if( use_mpp_io) then
- call input_data_mpp_io(topog_file, xdat, ydat, zdat)
- else
- call input_data( TOPOG_INDEX, xdat, ydat, zdat)
- endif
+ call input_data( TOPOG_INDEX, xdat, ydat, zdat)
call find_indices ( minval(blat), maxval(blat), ydat, js, je )
@@ -954,154 +873,6 @@ subroutine read_namelist
end subroutine read_namelist
-!!-------- functions added for mpp_io --------
-
- function get_water_frac_1d_mpp_io (blon, blat, water_frac)
-
- real, intent(in), dimension(:) :: blon, blat
- real, intent(out), dimension(:,:) :: water_frac
- logical :: get_water_frac_1d_mpp_io
-
-!-----------------------------------------------------------------------
- if (.not. module_is_initialized) call topography_init()
-
- if ( any(shape(water_frac(:,:)) /= (/size(blon(:))-1,size(blat(:))-1/)) ) &
- call error_mesg('get_water_frac_1d_mpp_io','shape(water_frac) is not&
- & equal to (/size(blon)-1,size(blat)-1/))', FATAL)
-
- if ( open_topog_file_mpp_io(water_file) ) then
- call interp_water_1d_mpp_io ( blon, blat, water_frac )
- get_water_frac_1d_mpp_io = .true.
- else
- get_water_frac_1d_mpp_io = .false.
- endif
-
-!-----------------------------------------------------------------------
-
- end function get_water_frac_1d_mpp_io
-
-!#######################################################################
-
- function get_water_frac_2d_mpp_io (blon, blat, water_frac)
-
- real, intent(in), dimension(:,:) :: blon, blat
- real, intent(out), dimension(:,:) :: water_frac
- logical :: get_water_frac_2d_mpp_io
-
-!-----------------------------------------------------------------------
- if (.not. module_is_initialized) call topography_init()
-
- if ( any(shape(water_frac(:,:)) /= (/size(blon,1)-1,size(blon,2)-1/)) .or. &
- any(shape(water_frac(:,:)) /= (/size(blat,1)-1,size(blat,2)-1/)) ) &
- call error_mesg('get_water_frac_2d_mpp_io','shape(water_frac) is not&
- & equal to (/size(blon,1)-1,size(blon,2)-1/))', FATAL)
-
- if ( open_topog_file_mpp_io(water_file) ) then
- call interp_water_2d_mpp_io ( blon, blat, water_frac )
- get_water_frac_2d_mpp_io = .true.
- else
- get_water_frac_2d_mpp_io = .false.
- endif
- end function get_water_frac_2d_mpp_io
-
-!#######################################################################
-
- function open_topog_file_mpp_io ( filename )
- character(len=*), intent(in) :: filename
- logical :: open_topog_file_mpp_io
- real :: r_ipts, r_jpts
- integer :: namelen
- integer :: unit
-
- namelen = len(trim(filename))
- if ( file_exist(filename) .AND. filename(namelen-2:namelen) == '.nc') then
- if (mpp_pe() == mpp_root_pe()) call mpp_error ('topography_mod', &
- 'Reading NetCDF formatted input data file: '//filename, NOTE)
- call read_data_mpp_io(filename, 'ipts', r_ipts, no_domain=.true.)
- call read_data_mpp_io(filename, 'jpts', r_jpts, no_domain=.true.)
- ipts = nint(r_ipts)
- jpts = nint(r_jpts)
- open_topog_file_mpp_io = .true.
- else
- if ( file_exist(filename) ) then
- if (mpp_pe() == mpp_root_pe()) call mpp_error ('topography_mod', &
- 'Reading native formatted input data file: '//filename, NOTE)
- unit = open_ieee32_file(trim(filename), 'read')
- read (unit) ipts, jpts
- open_topog_file_mpp_io = .true.
- else
- open_topog_file_mpp_io = .false.
- endif
- endif
-
- end function open_topog_file_mpp_io
-
-
- subroutine input_data_mpp_io ( ifile, xdat, ydat, zdat )
- character(len=*), intent(in) :: ifile
- real, intent(out) :: xdat(ipts+1), ydat(jpts+1), zdat(ipts,jpts)
- integer :: nc
- integer :: unit
- nc = len_trim(ifile)
-
-! note: ipts,jpts,unit are global
-
- if ( file_exist(trim(ifile)) .AND. ifile(nc-2:nc) == '.nc') then
- call read_data_mpp_io(trim(ifile), 'xdat', xdat, no_domain=.true.)
- call read_data_mpp_io(trim(ifile), 'ydat', ydat, no_domain=.true.)
- call read_data_mpp_io(trim(ifile), 'zdat', zdat, no_domain=.true.)
- else
- read (unit) xdat, ydat ! read lon/lat edges in radians
- read (unit) zdat ! read land surface height in meters
- call close_file (unit)
- endif
-
- end subroutine input_data_mpp_io
-
-!#######################################################################
-
- subroutine interp_water_1d_mpp_io ( blon, blat, zout, do_ocean )
- real , intent(in) :: blon(:), blat(:)
- real , intent(out) :: zout(:,:)
- logical, intent(in), optional :: do_ocean
-
- real :: xdat(ipts+1), ydat(jpts+1), zdat(ipts,jpts)
-
- call input_data_mpp_io ( water_file, xdat, ydat, zdat )
-
-! only use designated ocean points
- if (present(do_ocean)) then
- if (do_ocean) call determine_ocean_points (zdat)
- endif
-
-! interpolate onto output grid
- call horiz_interp ( zdat, xdat, ydat, blon, blat, zout )
-
- end subroutine interp_water_1d_mpp_io
-
-!#######################################################################
-
- subroutine interp_water_2d_mpp_io ( blon, blat, zout, do_ocean )
- real , intent(in) :: blon(:,:), blat(:,:)
- real , intent(out) :: zout(:,:)
- logical, intent(in), optional :: do_ocean
-
- real :: xdat(ipts+1), ydat(jpts+1), zdat(ipts,jpts)
-
- call input_data_mpp_io ( water_file, xdat, ydat, zdat )
-
-! only use designated ocean points
- if (present(do_ocean)) then
- if (do_ocean) call determine_ocean_points (zdat)
- endif
-
-! interpolate onto output grid
- call horiz_interp ( zdat, xdat, ydat, blon, blat, zout )
-
- end subroutine interp_water_2d_mpp_io
-
-!#######################################################################
-
end module topography_mod
!
@@ -1109,7 +880,7 @@ end module topography_mod
!
!
! To run this program you will need the topography and percent water
-! data sets and use the following namelist (in file input.nml).
+! data sets and use the following namelist (in the input nml file).
!
! &gaussian_topog_nml
! height = 5000., 3000., 3000., 3000.,
diff --git a/tracer_manager/tracer_manager.F90 b/tracer_manager/tracer_manager.F90
index 7534f5d6a5..79ea8ac623 100644
--- a/tracer_manager/tracer_manager.F90
+++ b/tracer_manager/tracer_manager.F90
@@ -159,7 +159,7 @@ module tracer_manager_mod
!> @{
integer :: num_tracer_fields = 0
-integer, parameter :: MAX_TRACER_FIELDS = 150
+integer, parameter :: MAX_TRACER_FIELDS = 250
integer, parameter :: MAX_TRACER_METHOD = 20
integer, parameter :: NO_TRACER = 1-HUGE(1)
integer, parameter :: NOTRACER = -HUGE(1)