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. -! -! - -! -! -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. -! -! - -! -! -! -! -! - -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)