diff --git a/.github/workflows/Intel1.yml b/.github/workflows/Intel1.yml new file mode 100644 index 000000000..0cf71f245 --- /dev/null +++ b/.github/workflows/Intel1.yml @@ -0,0 +1,202 @@ +# UFS_UTILS test workflow. +# +# This workflow tests UFS_UTILS with the Intel compiler. +# +# Ed Hartnett 12/14/22 +name: Intel1 +on: + push: + branches: + - develop + paths-ignore: + - README.md + pull_request: + branches: + - develop + paths-ignore: + - README.md + +# Use custom shell with -l so .bash_profile is sourced which loads intel/oneapi/setvars.sh +# without having to do it in manually every step. +defaults: + run: + shell: bash -leo pipefail {0} + +jobs: + Intel: + runs-on: ubuntu-latest + env: + CC: icc + FC: ifort + + steps: + + # See https://software.intel.com/content/www/us/en/develop/articles/oneapi-repo-instructions.html + - name: install-intel + run: | + cd /tmp + wget https://apt.repos.intel.com/intel-gpg-keys/GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB + sudo apt-key add GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB + rm GPG-PUB-KEY-INTEL-SW-PRODUCTS.PUB + echo "deb https://apt.repos.intel.com/oneapi all main" | sudo tee /etc/apt/sources.list.d/oneAPI.list + sudo apt-get update + sudo apt-get install intel-oneapi-dev-utilities intel-oneapi-mpi-devel intel-oneapi-openmp intel-oneapi-compiler-fortran intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic + echo "source /opt/intel/oneapi/setvars.sh" >> ~/.bash_profile + + - name: cache-netcdf + id: cache-netcdf + uses: actions/cache@v2 + with: + path: ~/netcdf + key: Intel-netcdf-c-$4.7.4-{{ runner.os }}-intel3 + + - name: build-hdf5 + if: steps.cache-netcdf.outputs.cache-hit != 'true' + run: | + export CC=mpiicc + wget https://support.hdfgroup.org/ftp/HDF5/releases/hdf5-1.10/hdf5-1.10.7/src/hdf5-1.10.7.tar.gz &> /dev/null + tar -xzf hdf5-1.10.7.tar.gz + pushd hdf5-1.10.7 + ./configure --prefix=${HOME}/netcdf --enable-parallel --disable-tools --disable-fortran --disable-cxx --enable-parallel-tests --disable-shared --disable-shared --enable-static + make -j2 + make install + + - name: build-netcdf-c + if: steps.cache-netcdf.outputs.cache-hit != 'true' + run: | + export CC=mpiicc + export CPPFLAGS=-I${HOME}/netcdf/include + export LDFLAGS=-L${HOME}/netcdf/lib + wget https://github.com/Unidata/netcdf-c/archive/refs/tags/v4.7.4.tar.gz &> /dev/null + tar -xzf v4.7.4.tar.gz + pushd netcdf-c-4.7.4 + ./configure --prefix=${HOME}/netcdf --disable-dap --disable-utilities --disable-shared + make -j2 + make install + + - name: build-netcdf-fortran + if: steps.cache-netcdf.outputs.cache-hit != 'true' + run: | + export LD_LIBRARY_PATH="$LD_LIBRARY_PATH:${HOME}/netcdf/lib" + export PATH="${HOME}/netcdf/bin:$PATH" + export CC=mpiicc + export FC=mpiifort + export CPPFLAGS=-I${HOME}/netcdf/include + export LDFLAGS=-L${HOME}/netcdf/lib + export LIBS=`nc-config --libs` + wget https://github.com/Unidata/netcdf-fortran/archive/v4.5.3.tar.gz &> /dev/null + tar -xzf v4.5.3.tar.gz + pushd netcdf-fortran-4.5.3 + ./configure --prefix=${HOME}/netcdf --disable-shared + make -j2 + make install + + - name: cache-esmf + id: cache-esmf + uses: actions/cache@v2 + with: + path: ~/esmf + key: Intel-esmf-8.2.0-${{ runner.os }}-intel3 + + - name: build-esmf + if: steps.cache-esmf.outputs.cache-hit != 'true' + run: | + pushd ~ + export ESMF_DIR=~/esmf-ESMF_8_2_0 + wget https://github.com/esmf-org/esmf/archive/ESMF_8_2_0.tar.gz &> /dev/null + tar zxf ESMF_8_2_0.tar.gz + cd esmf-ESMF_8_2_0 + export ESMF_COMM=intelmpi + export ESMF_INSTALL_BINDIR=bin + export ESMF_INSTALL_LIBDIR=lib + export ESMF_INSTALL_MODDIR=mod + export ESMF_COMPILER=intel + export ESMF_INSTALL_PREFIX=~/esmf + export ESMF_NETCDF=split + export ESMF_NETCDF_INCLUDE=${HOME}/netcdf/include + export ESMF_NETCDF_LIBPATH=${HOME}/netcdf/lib + export ESMF_NETCDF_LIBS="-lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz" + make -j2 + make install + + - name: cache-jasper + id: cache-jasper + uses: actions/cache@v2 + with: + path: ~/jasper + key: Intel-jasper-2.0.25-${{ runner.os }}-intel3 + + - name: build-jasper + if: steps.cache-jasper.outputs.cache-hit != 'true' + run: | + wget https://github.com/jasper-software/jasper/archive/version-2.0.25.tar.gz &> /dev/null + tar zxf version-2.0.25.tar.gz + cd jasper-version-2.0.25 + mkdir build-jasper && cd build-jasper + cmake .. -DCMAKE_INSTALL_PREFIX=~/jasper -DJAS_ENABLE_SHARED=OFF + make -j2 + make install + + - name: checkout-nceplibs + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS + path: nceplibs + + - name: cache-nceplibs + id: cache-nceplibs + uses: actions/cache@v2 + with: + path: ~/nceplibs + key: Intel-nceplibs-1.4.0-${{ runner.os }}-intel3 + + - name: build-nceplibs + if: steps.cache-nceplibs.outputs.cache-hit != 'true' + run: | + export ESMFMKFILE=~/esmf/lib/esmf.mk + wget https://github.com/NOAA-EMC/NCEPLIBS/archive/v1.4.0.tar.gz &> /dev/null + tar zxf v1.4.0.tar.gz + cd NCEPLIBS-1.4.0 + mkdir build && cd build + cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper;~/netcdf' -DCMAKE_INSTALL_PREFIX='~/nceplibs' -DFLAT=ON + make -j2 + + - name: checkout-ufs-utils + uses: actions/checkout@v2 + with: + path: ufs_utils + submodules: recursive + + - name: cache-data + id: cache-data + uses: actions/cache@v2 + with: + path: ~/data + key: data-1 + + - name: build + run: | + export ESMFMKFILE=~/esmf/lib/esmf.mk + cd ufs_utils + mkdir build && cd build + export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:~/jasper/lib;~/jasper/lib64" + cmake -DTEST_FILE_DIR=/home/runner/data -DCMAKE_PREFIX_PATH='~;~/jasper;~/nceplibs;~/netcdf' .. + make -j2 + + - name: test + run: | + cd ufs_utils/build + ctest --rerun-failed --output-on-failure + + - name: cache-data + if: steps.cache-data.outputs.cache-hit != 'true' + run: | + mkdir ~/data + cp ufs_utils/build/tests/chgres_cube/data/* ~/data + cp ufs_utils/build/tests/sfc_climo_gen/data/* ~/data + cp ufs_utils/build/tests/cpld_gridgen/data/* ~/data + cp ufs_utils/tests/filter_topo/data/* ~/data + cp ufs_utils/tests/emcsfc_snow2mdl/data/* ~/data + cp ufs_utils/tests/chgres_cube/data/* ~/data + ls -l ~/data + diff --git a/.github/workflows/intel.yml b/.github/workflows/Intel_nceplibs.yml similarity index 97% rename from .github/workflows/intel.yml rename to .github/workflows/Intel_nceplibs.yml index e7f7c4388..e15059809 100644 --- a/.github/workflows/intel.yml +++ b/.github/workflows/Intel_nceplibs.yml @@ -1,4 +1,4 @@ -name: intel +name: Intel_nceplibs on: push: branches: @@ -18,15 +18,11 @@ defaults: shell: bash -leo pipefail {0} jobs: - intel-build-and-test: - runs-on: ${{ matrix.os }} + Intel_nceplibs: + runs-on: ubuntu-latest env: CC: icc FC: ifort - CXX: icpc - strategy: - matrix: - os: [ubuntu-latest] steps: diff --git a/.github/workflows/Linux_versions.yml b/.github/workflows/Linux_versions.yml index 8d44f5a0d..a67abe615 100644 --- a/.github/workflows/Linux_versions.yml +++ b/.github/workflows/Linux_versions.yml @@ -30,6 +30,7 @@ jobs: strategy: fail-fast: true matrix: + esmf_version: [8_2_0, 8.3.0, 8.4.0] bacio_version: [2.4.1] g2_version: [3.4.3] sp_version: [2.3.3] @@ -46,22 +47,31 @@ jobs: sudo apt-get update sudo apt-get install libpng-dev zlib1g-dev libjpeg-dev libmpich-dev sudo apt-get install libnetcdf-dev libnetcdff-dev netcdf-bin pkg-config - - - name: cache-esmf + sudo apt-get install autoconf automake libtool + + - name: checkout-esmf id: cache-esmf uses: actions/cache@v2 with: path: ~/esmf - key: Linux_versions-esmf-8.2.0-${{ runner.os }}3 + key: Linux_versions-esmf-${{ matrix.esmf_version }}-${{ runner.os }} - name: build-esmf if: steps.cache-esmf.outputs.cache-hit != 'true' run: | pushd ~ - export ESMF_DIR=~/esmf-ESMF_8_2_0 - wget https://github.com/esmf-org/esmf/archive/ESMF_8_2_0.tar.gz &> /dev/null - tar zxf ESMF_8_2_0.tar.gz - cd esmf-ESMF_8_2_0 + if [[ ${{ matrix.esmf_version }} == "8_2_0" ]]; then + wget https://github.com/esmf-org/esmf/archive/ESMF_${{ matrix.esmf_version }}.tar.gz &> /dev/null + tar zxf ESMF_${{ matrix.esmf_version }}.tar.gz + cd esmf-ESMF_${{ matrix.esmf_version }} + export ESMF_DIR=~/esmf-ESMF_${{ matrix.esmf_version }} + else + wget https://github.com/esmf-org/esmf/archive/refs/tags/v${{ matrix.esmf_version }}.tar.gz &> /dev/null + ls -l + tar zxf v${{ matrix.esmf_version }}.tar.gz + cd esmf-${{ matrix.esmf_version }} + export ESMF_DIR=~/esmf-${{ matrix.esmf_version }} + fi export ESMF_COMM=mpich3 export ESMF_INSTALL_BINDIR=bin export ESMF_INSTALL_LIBDIR=lib @@ -71,6 +81,9 @@ jobs: export ESMF_NETCDF=split export ESMF_NETCDF_INCLUDE=/usr/include export ESMF_NETCDF_LIBPATH=/usr/x86_64-linux-gnu + export ESMF_PIO=OFF + export ESMF_MOAB=OFF + export ESMF_ARRAY_LITE=TRUE make -j2 make install @@ -368,8 +381,3 @@ jobs: cp ufs_utils/tests/emcsfc_snow2mdl/data/* ~/data cp ufs_utils/tests/chgres_cube/data/* ~/data ls -l ~/data - - - - - diff --git a/.github/workflows/Linux_versions_ext.yml b/.github/workflows/Linux_versions_ext.yml new file mode 100644 index 000000000..98dac4d95 --- /dev/null +++ b/.github/workflows/Linux_versions_ext.yml @@ -0,0 +1,383 @@ +# UFS_UTILS test workflow. +# +# Check different versions of the external libraries that are used by UFS_UTILS. +# +# Ed Hartnett 12/16/22 +name: Linux_versions_ext +on: + push: + branches: + - develop + paths-ignore: + - README.md + pull_request: + branches: + - develop + paths-ignore: + - README.md + +defaults: + run: + shell: bash -exo pipefail {0} + +jobs: + Linux_versions_ext: + runs-on: ubuntu-latest + env: + FC: mpifort + CC: mpicc + FCFLAGS: -fallow-argument-mismatch + strategy: + fail-fast: true + matrix: + esmf_version: [8_2_0, 8.3.1, 8.4.0] + bacio_version: [2.4.1] + g2_version: [3.4.3] + sp_version: [2.3.3] + ip_version: [3.3.3] + w3nco_version: [2.4.0] + nemsio_version: [2.5.0] + sfcio_version: [1.4.0] + sigio_version: [2.3.0] + + steps: + + - name: install-dependencies + run: | + sudo apt-get update + sudo apt-get install libpng-dev zlib1g-dev libjpeg-dev libmpich-dev + sudo apt-get install libnetcdf-dev libnetcdff-dev netcdf-bin pkg-config + sudo apt-get install autoconf automake libtool + + - name: checkout-esmf + id: cache-esmf + uses: actions/cache@v2 + with: + path: ~/esmf + key: Linux_versions-esmf-${{ matrix.esmf_version }}-${{ runner.os }} + + - name: build-esmf + if: steps.cache-esmf.outputs.cache-hit != 'true' + run: | + pushd ~ + if [[ ${{ matrix.esmf_version }} == "8_2_0" ]]; then + wget https://github.com/esmf-org/esmf/archive/ESMF_${{ matrix.esmf_version }}.tar.gz &> /dev/null + tar zxf ESMF_${{ matrix.esmf_version }}.tar.gz + cd esmf-ESMF_${{ matrix.esmf_version }} + export ESMF_DIR=~/esmf-ESMF_${{ matrix.esmf_version }} + else + wget https://github.com/esmf-org/esmf/archive/refs/tags/v${{ matrix.esmf_version }}.tar.gz &> /dev/null + ls -l + tar zxf v${{ matrix.esmf_version }}.tar.gz + cd esmf-${{ matrix.esmf_version }} + export ESMF_DIR=~/esmf-${{ matrix.esmf_version }} + fi + export ESMF_COMM=mpich3 + export ESMF_INSTALL_BINDIR=bin + export ESMF_INSTALL_LIBDIR=lib + export ESMF_INSTALL_MODDIR=mod + export ESMF_COMPILER=gfortran + export ESMF_INSTALL_PREFIX=~/esmf + export ESMF_NETCDF=split + export ESMF_NETCDF_INCLUDE=/usr/include + export ESMF_NETCDF_LIBPATH=/usr/x86_64-linux-gnu + export ESMF_PIO=OFF + export ESMF_MOAB=OFF + export ESMF_ARRAY_LITE=TRUE + make -j2 + make install + + - name: cache-jasper + id: cache-jasper + uses: actions/cache@v2 + with: + path: ~/jasper + key: Linux_versions-jasper-${{ runner.os }}-2.0.33-1 + + - name: checkout-jasper + if: steps.cache-jasper.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: jasper-software/jasper + path: jasper + ref: version-2.0.33 + + - name: build-jasper + if: steps.cache-jasper.outputs.cache-hit != 'true' + run: | + cd jasper + mkdir build-jasper && cd build-jasper + cmake .. -DCMAKE_INSTALL_PREFIX=~/jasper + make -j2 + make install + + - name: cache-bacio + id: cache-bacio + uses: actions/cache@v2 + with: + path: ~/bacio + key: Linux_versions-bacio-${{ runner.os }}-${{ matrix.bacio_version }} + + - name: checkout-bacio + if: steps.cache-bacio.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-bacio + path: bacio + ref: v${{ matrix.bacio_version }} + + - name: build-bacio + if: steps.cache-bacio.outputs.cache-hit != 'true' + run: | + cd bacio + mkdir build && cd build + cmake .. -DCMAKE_INSTALL_PREFIX=~/bacio + make -j2 + make install + + - name: cache-g2 + id: cache-g2 + uses: actions/cache@v2 + with: + path: ~/g2 + key: Linux_versions-g2-${{ runner.os }}-${{ matrix.g2_version }} + + - name: checkout-g2 + if: steps.cache-g2.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-g2 + path: g2 + ref: v${{ matrix.g2_version }} + + - name: build-g2 + if: steps.cache-g2.outputs.cache-hit != 'true' + run: | + cd g2 + mkdir build + cd build + cmake -DCMAKE_INSTALL_PREFIX=~/g2 -DCMAKE_PREFIX_PATH="~/bacio;~/jasper" .. + make -j2 + make install + + - name: cache-sp + id: cache-sp + uses: actions/cache@v2 + with: + path: ~/sp + key: Linux_versions-sp-${{ runner.os }}-${{ matrix.sp_version }} + + - name: checkout-sp + if: steps.cache-sp.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-sp + path: sp + ref: v${{ matrix.sp_version }} + + - name: build-sp + if: steps.cache-sp.outputs.cache-hit != 'true' + run: | + cd sp + mkdir build + cd build + cmake .. -DCMAKE_INSTALL_PREFIX=~/sp + make -j2 + make install + + - name: cache-ip + id: cache-ip + uses: actions/cache@v2 + with: + path: ~/ip + key: Linux_versions-ip-${{ runner.os }}-${{ matrix.ip_version }} + + - name: checkout-ip + if: steps.cache-ip.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-ip + path: ip + ref: v${{ matrix.ip_version }} + + - name: build-ip + if: steps.cache-ip.outputs.cache-hit != 'true' + run: | + cd ip + mkdir build + cd build + cmake -DCMAKE_INSTALL_PREFIX=~/ip -DCMAKE_PREFIX_PATH=~/sp .. + make -j2 + make install + + # - name: checkout-w3emc + # uses: actions/checkout@v2 + # with: + # repository: NOAA-EMC/NCEPLIBS-w3emc + # path: w3emc + # ref: develop + + # - name: build-w3emc + # run: | + # cd w3emc + # mkdir build + # cd build + # cmake -DCMAKE_PREFIX_PATH=~/bacio -DCMAKE_INSTALL_PREFIX=~/w3emc .. + # make -j2 + # make install + + # - name: checkout-g2c + # uses: actions/checkout@v2 + # with: + # repository: NOAA-EMC/NCEPLIBS-g2c + # path: g2c + # ref: develop + + # - name: build-g2c + # run: | + # cd g2c + # mkdir build + # cd build + # cmake .. -DCMAKE_INSTALL_PREFIX=~/g2c -DJasper_ROOT=~/jasper + # make -j2 + # make install + + - name: cache-sfcio + id: cache-sfcio + uses: actions/cache@v2 + with: + path: ~/sfcio + key: Linux_versions-sfcio-${{ runner.os }}-${{ matrix.sfcio_version }} + + - name: checkout-sfcio + if: steps.cache-sfcio.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-sfcio + path: sfcio + ref: v${{ matrix.sfcio_version }} + + - name: build-sfcio + if: steps.cache-sfcio.outputs.cache-hit != 'true' + run: | + cd sfcio + mkdir build + cd build + cmake .. -DCMAKE_INSTALL_PREFIX=~/sfcio + make -j2 + make install + + - name: cache-w3nco + id: cache-w3nco + uses: actions/cache@v2 + with: + path: ~/w3nco + key: Linux_versions-w3nco-${{ runner.os }}-${{ matrix.w3nco_version }} + + - name: checkout-w3nco + if: steps.cache-w3nco.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-w3nco + path: w3nco + ref: v${{ matrix.w3nco_version }} + + - name: build-w3nco + if: steps.cache-w3nco.outputs.cache-hit != 'true' + run: | + cd w3nco + mkdir build + cd build + cmake .. -DCMAKE_INSTALL_PREFIX=~/w3nco + make -j2 + make install + + - name: cache-nemsio + id: cache-nemsio + uses: actions/cache@v2 + with: + path: ~/nemsio + key: Linux_versions-nemsio-${{ runner.os }}-${{ matrix.nemsio_version }} + + - name: checkout-nemsio + if: steps.cache-nemsio.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-nemsio + path: nemsio + ref: v${{ matrix.nemsio_version }} + + - name: build-nemsio + if: steps.cache-nemsio.outputs.cache-hit != 'true' + run: | + cd nemsio + mkdir build + cd build + cmake -DCMAKE_INSTALL_PREFIX=~/nemsio -DCMAKE_PREFIX_PATH="~/bacio;~/w3nco" .. + make -j2 + make install + + - name: cache-sigio + id: cache-sigio + uses: actions/cache@v2 + with: + path: ~/sigio + key: Linux_versions-sigio-${{ runner.os }}-${{ matrix.sigio_version }} + + - name: checkout-sigio + if: steps.cache-sigio.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-sigio + path: sigio + ref: v${{ matrix.sigio_version }} + + - name: build-sigio + if: steps.cache-sigio.outputs.cache-hit != 'true' + run: | + cd sigio + mkdir build + cd build + cmake .. -DCMAKE_INSTALL_PREFIX=~/sigio + make -j2 + make install + + - name: checkout + uses: actions/checkout@v2 + with: + path: ufs_utils + submodules: true + + - name: cache-data + id: cache-data + uses: actions/cache@v2 + with: + path: ~/data + key: data-1 + + - name: build + run: | + set -x + cd ufs_utils + mkdir build + cd build + export ESMFMKFILE=~/esmf/lib/esmf.mk + cmake -DTEST_FILE_DIR=/home/runner/data -DCMAKE_PREFIX_PATH="~/jasper;~/g2c;~/bacio;~/g2;~/w3nco;~/sfcio;~/sigio;~/nemsio;~/sp;~/ip" .. + make -j2 VERBOSE=1 + + - name: test + run: | + cd ufs_utils/build + ctest --verbose --rerun-failed --output-on-failure + + - name: cache-data + if: steps.cache-data.outputs.cache-hit != 'true' + run: | + mkdir ~/data + cp ufs_utils/build/tests/chgres_cube/data/* ~/data + cp ufs_utils/build/tests/sfc_climo_gen/data/* ~/data + cp ufs_utils/build/tests/cpld_gridgen/data/* ~/data + cp ufs_utils/tests/filter_topo/data/* ~/data + cp ufs_utils/tests/emcsfc_snow2mdl/data/* ~/data + cp ufs_utils/tests/chgres_cube/data/* ~/data + ls -l ~/data diff --git a/.github/workflows/developer.yml b/.github/workflows/developer.yml index d17f9ef4d..151ab1e53 100644 --- a/.github/workflows/developer.yml +++ b/.github/workflows/developer.yml @@ -3,6 +3,7 @@ # This workflow tests all developer options including # documentation check, and test code coverage. # +# # Ed Hartnett 12/11/22 name: developer on: diff --git a/.github/workflows/netcdf-versions.yml b/.github/workflows/netcdf-versions.yml index 0909cb8ee..c9a0a6f9c 100644 --- a/.github/workflows/netcdf-versions.yml +++ b/.github/workflows/netcdf-versions.yml @@ -28,17 +28,14 @@ jobs: - name: install-dependencies run: | sudo apt-get update - sudo apt-get install libmpich-dev - sudo apt-get install doxygen - sudo apt-get install libpng-dev - sudo apt-get install libjpeg-dev + sudo apt-get install libmpich-dev libpng-dev libjpeg-dev - name: cache-netcdf id: cache-netcdf uses: actions/cache@v2 with: path: ~/netcdf - key: netcdf-c-${{ matrix.netcdf_version }}-${{ runner.os }}3 + key: netcdf-c-${{ matrix.netcdf_version }}-${{ runner.os }}4 - name: build-hdf5 if: steps.cache-netcdf.outputs.cache-hit != 'true' @@ -47,7 +44,7 @@ jobs: wget https://support.hdfgroup.org/ftp/HDF5/releases/hdf5-1.10/hdf5-1.10.7/src/hdf5-1.10.7.tar.gz &> /dev/null tar -xzf hdf5-1.10.7.tar.gz pushd hdf5-1.10.7 - ./configure --prefix=${HOME}/netcdf --enable-parallel --disable-tools --disable-fortran --disable-cxx --enable-parallel-tests --disable-shared --enable-static + ./configure --prefix=${HOME}/netcdf --enable-parallel --disable-tools --disable-fortran --disable-cxx --disable-shared make -j2 make install @@ -167,7 +164,7 @@ jobs: export CXX=mpicxx export FC=mpifort export LD_LIBRARY_PATH="${LD_LIBRARY_PATH}:~/jasper/lib;~/jasper/lib64" - cmake -DTEST_FILE_DIR=/home/runner/work/UFS_UTILS/UFS_UTILS/data -DCMAKE_PREFIX_PATH='~/jasper;~/nceplibs;~/netcdf' -DCMAKE_BUILD_TYPE=Debug .. + cmake -DTEST_FILE_DIR=/home/runner/work/UFS_UTILS/UFS_UTILS/data -DCMAKE_PREFIX_PATH='~/jasper;~/nceplibs;~/netcdf' .. make -j2 - name: test run: | diff --git a/CMakeLists.txt b/CMakeLists.txt index f8e33a472..3629ec68a 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -45,7 +45,8 @@ elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") endif() set(CMAKE_Fortran_FLAGS_RELEASE "-O3") # set(CMAKE_Fortran_FLAGS_DEBUG "-ggdb -Wall") - set(CMAKE_Fortran_FLAGS_DEBUG "-O1 -ggdb -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans -ffpe-trap=invalid,zero,overflow -fbounds-check -fno-omit-frame-pointer -fno-optimize-sibling-calls") + set(CMAKE_Fortran_FLAGS_DEBUG "-O1 -ggdb -Wall -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans -ffpe-trap=invalid,zero,overflow -fbounds-check -fno-omit-frame-pointer -fno-optimize-sibling-calls") +# set(CMAKE_Fortran_FLAGS_DEBUG "-ggdb -Wall -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans -ffpe-trap=invalid,zero,overflow -fbounds-check -fno-omit-frame-pointer -fno-optimize-sibling-calls") endif() if(CMAKE_C_COMPILER_ID MATCHES "^(Intel)$") diff --git a/VERSION b/VERSION index 27f9cd322..f8e233b27 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -1.8.0 +1.9.0 diff --git a/build_all.sh b/build_all.sh index 549bb839d..9f9f090ae 100755 --- a/build_all.sh +++ b/build_all.sh @@ -3,6 +3,7 @@ # This build script is only used on officially supported machines. All other # users should set module files as needed, and build directly with CMake. # +# # George Gayno set -eux @@ -31,7 +32,7 @@ fi # Those with access to the EMC ftp site are: Orion and Hera. if [[ "$target" == "hera" || "$target" == "orion" || "$target" == "wcoss2" ]]; then - CMAKE_FLAGS="-DCMAKE_INSTALL_PREFIX=../ -DCMAKE_INSTALL_BINDIR=exec -DBUILD_TESTING=OFF" + CMAKE_FLAGS="-DCMAKE_INSTALL_PREFIX=../ -DCMAKE_INSTALL_BINDIR=exec -DBUILD_TESTING=OFF" #CMAKE_FLAGS="-DCMAKE_INSTALL_PREFIX=../ -DCMAKE_INSTALL_BINDIR=exec -DBUILD_TESTING=ON" #CMAKE_FLAGS="-DCMAKE_INSTALL_PREFIX=../ -DCMAKE_INSTALL_BINDIR=exec -DENABLE_DOCS=ON -DBUILD_TESTING=ON" else @@ -47,7 +48,7 @@ cmake .. ${CMAKE_FLAGS} make -j 8 VERBOSE=1 make install -#make test +#ctest #ctest -I 4,5 exit diff --git a/docs/source/chgres_cube.rst b/docs/source/chgres_cube.rst index a6e2cbb38..38c48e491 100644 --- a/docs/source/chgres_cube.rst +++ b/docs/source/chgres_cube.rst @@ -21,7 +21,9 @@ The program assumes Noah/Noah-MP LSM coefficients for certain soil thresholds. I * model_grid.F90 - Sets up the ESMF grid objects for the input data grid and target FV3 grid. * static_data.F90 - Reads static surface climatological data for the target FV3 grid (such as soil type and vegetation type). Time interpolates time-varying fields, such as monthly plant greenness, to the model run time. Set path to these files via the fix_dir_target_grid namelist variable. * write_data.F90 - Writes the tiled and header files expected by the forecast model. - * input_data.F90 - Contains routines to read atmospheric and surface data from GRIB2, NEMSIO and NetCDF files. + * atm_input_data.F90 - Contains routines to read input atmospheric data from GRIB2, NEMSIO and NetCDF files. + * nst_input_data.F90 - Contains routines to read input NSST data from NEMSIO and NetCDF files. + * sfc_input_data.F90 - Contains routines to read input surface data from GRIB2, NEMSIO and NetCDF files. * utils.F90 - Contains utility routines, such as error handling. * grib2_util.F90 - Routines to (1) convert from RH to specific humidity; (2) convert from omega to dzdt. Required for GRIB2 input data. * atmosphere.F90 - Process atmospheric fields. Horizontally interpolate from input to target FV3 grid using ESMF regridding. Adjust surface pressure according to terrain differences between input and target grid. Vertically interpolate to target FV3 grid vertical levels. Description of main routines: diff --git a/docs/source/ufs_utils.rst b/docs/source/ufs_utils.rst index 6ae0ae5ae..48515443d 100644 --- a/docs/source/ufs_utils.rst +++ b/docs/source/ufs_utils.rst @@ -502,6 +502,7 @@ Program execution is controlled via a namelist. The namelist variables are: * input_snowfree_albedo_file - path/name of input snow-free albedo data * input_slope_type_file - path/name of input global slope type data * input_soil_type_file - path/name of input soil type data + * input_soil_color_file - path/name of input soil color data * input_vegetation_type_file - path/name of vegetation type data * input_vegetation_greenness_file - path/name of monthly vegetation greenness data * mosaic_file_mdl - path/name of the model mosaic file @@ -524,6 +525,7 @@ The surface climatological data is located here `./fix/fix_sfc_climo @file +!! @brief Read atmospheric data from GRIB2, NEMSIO and NetCDF files. +!! @author George Gayno NCEP/EMC + +!> Read atmospheric data on the input grid. +!! Supported formats include fv3 tiled 'restart' files, fv3 tiled +!! 'history' files, fv3 gaussian history files, spectral gfs +!! gaussian nemsio files, and spectral gfs sigio/sfcio files. +!! +!! Public variables are defined below: "input" indicates field +!! associated with the input grid. +!! +!! @author George Gayno NCEP/EMC + +module atm_input_data + use esmf + use netcdf + use nemsio_module + + use program_setup, only : data_dir_input_grid, & + atm_files_input_grid, & + grib2_file_input_grid, & + atm_core_files_input_grid, & + atm_tracer_files_input_grid, & + tracers_input, num_tracers_input, & + tracers, & + get_var_cond, & + external_model, & + read_from_input, & + input_type + use model_grid, only : input_grid, & + i_input, j_input, & + ip1_input, jp1_input, & + num_tiles_input_grid, & + latitude_input_grid, & + longitude_input_grid + use utilities, only : error_handler, & + netcdf_err, & + handle_grib_error, & + quicksort, & + dint2p +implicit none + + private + +! Fields associated with the atmospheric model. + + type(esmf_field), public :: dzdt_input_grid !< vert velocity + type(esmf_field) :: dpres_input_grid !< pressure thickness + type(esmf_field), public :: pres_input_grid !< 3-d pressure + type(esmf_field), public :: ps_input_grid !< surface pressure + type(esmf_field), public :: terrain_input_grid !< terrain height + type(esmf_field), public :: temp_input_grid !< temperature + + type(esmf_field), public :: u_input_grid !< u/v wind at grid + type(esmf_field), public :: v_input_grid !< box center + type(esmf_field), public :: wind_input_grid !< 3-component wind + type(esmf_field), allocatable, public :: tracers_input_grid(:) !< tracers + + integer, public :: lev_input !< number of atmospheric layers + integer, public :: levp1_input !< number of atmos layer interfaces + + character(len=50), private, allocatable :: slevs(:) !< The atmospheric levels in the GRIB2 input file. + + public :: read_input_atm_data + public :: cleanup_input_atm_data + public :: convert_winds + + contains + + !> Read input grid atmospheric data driver. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_atm_data(localpet) + + implicit none + + integer, intent(in) :: localpet + +!------------------------------------------------------------------------------- +! Read the tiled 'warm' restart files. +!------------------------------------------------------------------------------- + + if (trim(input_type) == "restart") then + + call read_input_atm_restart_file(localpet) + +!------------------------------------------------------------------------------- +! Read the gaussian history files in netcdf format. +!------------------------------------------------------------------------------- + + elseif (trim(input_type) == "gaussian_netcdf") then + + call read_input_atm_gaussian_netcdf_file(localpet) + +!------------------------------------------------------------------------------- +! Read the tiled history files in netcdf format. +!------------------------------------------------------------------------------- + + elseif (trim(input_type) == "history") then + + call read_input_atm_tiled_history_file(localpet) + +!------------------------------------------------------------------------------- +! Read the gaussian history files in nemsio format. +!------------------------------------------------------------------------------- + + elseif (trim(input_type) == "gaussian_nemsio") then ! fv3gfs gaussian nemsio + + call read_input_atm_gaussian_nemsio_file(localpet) + +!------------------------------------------------------------------------------- +! Read the spectral gfs gaussian history files in nemsio format. +!------------------------------------------------------------------------------- + + elseif (trim(input_type) == "gfs_gaussian_nemsio") then ! spectral gfs gaussian + ! nemsio. + call read_input_atm_gfs_gaussian_nemsio_file(localpet) + +!------------------------------------------------------------------------------- +! Read the spectral gfs gaussian history files in sigio format. +!------------------------------------------------------------------------------- + + elseif (trim(input_type) == "gfs_sigio") then ! spectral gfs sigio format. + + call read_input_atm_gfs_sigio_file(localpet) + +!------------------------------------------------------------------------------- +! Read fv3gfs data in grib2 format. +!------------------------------------------------------------------------------- + + elseif (trim(input_type) == "grib2") then + + call read_input_atm_grib2_file(localpet) + + endif + + end subroutine read_input_atm_data + + +!> Create atmospheric esmf fields. +!! +!! @author George Gayno NCEP/EMC + subroutine init_atm_esmf_fields + + implicit none + + integer :: i, rc + + print*,"- INITIALIZE ATMOSPHERIC ESMF FIELDS." + + print*,"- CALL FieldCreate FOR INPUT GRID 3-D WIND." + wind_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1,1/), & + ungriddedUBound=(/lev_input,3/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID SURFACE PRESSURE." + ps_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID TERRAIN." + terrain_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID TEMPERATURE." + temp_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lev_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + allocate(tracers_input_grid(num_tracers_input)) + + do i = 1, num_tracers_input + print*,"- CALL FieldCreate FOR INPUT GRID TRACER ", trim(tracers_input(i)) + tracers_input_grid(i) = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lev_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + enddo + + print*,"- CALL FieldCreate FOR INPUT GRID DZDT." + dzdt_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lev_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID U." + u_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lev_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID V." + v_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lev_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID PRESSURE." + pres_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lev_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + end subroutine init_atm_esmf_fields + +!> Read input atmospheric data from spectral gfs (old sigio format). +!! +!! @note Format used prior to July 19, 2017. +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_atm_gfs_sigio_file(localpet) + + use sigio_module + + implicit none + + integer, intent(in) :: localpet + + character(len=300) :: the_file + + integer(sigio_intkind) :: iret + integer :: rc, i, j, k + integer :: clb(3), cub(3) + + real(esmf_kind_r8) :: ak, bk + real(esmf_kind_r8), allocatable :: dummy2d(:,:) + real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) + real(esmf_kind_r8), allocatable :: dummy3d2(:,:,:) + real(esmf_kind_r8), pointer :: pptr(:,:,:), psptr(:,:) + real(esmf_kind_r8), allocatable :: pi(:,:,:) + + type(sigio_head) :: sighead + type(sigio_dbta) :: sigdata + + the_file = trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(1)) + + print*,"- ATMOSPHERIC DATA IN SIGIO FORMAT." + print*,"- OPEN AND READ: ", trim(the_file) + + call sigio_sropen(21, trim(the_file), iret) + if (iret /= 0) then + rc = iret + call error_handler("OPENING SPECTRAL GFS SIGIO FILE.", rc) + endif + call sigio_srhead(21, sighead, iret) + if (iret /= 0) then + rc = iret + call error_handler("READING SPECTRAL GFS SIGIO FILE.", rc) + endif + + lev_input = sighead%levs + levp1_input = lev_input + 1 + + if (num_tracers_input /= sighead%ntrac) then + call error_handler("WRONG NUMBER OF TRACERS EXPECTED.", 99) + endif + + if (sighead%idvt == 0 .or. sighead%idvt == 21) then + if (trim(tracers_input(1)) /= 'spfh' .or. & + trim(tracers_input(2)) /= 'o3mr' .or. & + trim(tracers_input(3)) /= 'clwmr') then + call error_handler("TRACERS SELECTED DO NOT MATCH FILE CONTENTS.", 99) + endif + else + print*,'- UNRECOGNIZED IDVT: ', sighead%idvt + call error_handler("UNRECOGNIZED IDVT", 99) + endif + +!--------------------------------------------------------------------------- +! Initialize esmf atmospheric fields. +!--------------------------------------------------------------------------- + + call init_atm_esmf_fields + + if (localpet == 0) then + allocate(dummy2d(i_input,j_input)) + allocate(dummy3d(i_input,j_input,lev_input)) + allocate(dummy3d2(i_input,j_input,lev_input)) + else + allocate(dummy2d(0,0)) + allocate(dummy3d(0,0,0)) + allocate(dummy3d2(0,0,0)) + endif + + if (localpet == 0) then + call sigio_aldbta(sighead, sigdata, iret) + if (iret /= 0) then + rc = iret + call error_handler("ALLOCATING SIGDATA.", rc) + endif + call sigio_srdbta(21, sighead, sigdata, iret) + if (iret /= 0) then + rc = iret + call error_handler("READING SIGDATA.", rc) + endif + call sptez(0,sighead%jcap,4,i_input, j_input, sigdata%ps, dummy2d, 1) + dummy2d = exp(dummy2d) * 1000.0 + print*,'surface pres ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR SURFACE PRESSURE." + call ESMF_FieldScatter(ps_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call sptez(0,sighead%jcap,4,i_input, j_input, sigdata%hs, dummy2d, 1) + print*,'terrain ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + do k = 1, num_tracers_input + + if (localpet == 0) then + call sptezm(0,sighead%jcap,4,i_input, j_input, lev_input, sigdata%q(:,:,k), dummy3d, 1) + print*,trim(tracers_input(k)),maxval(dummy3d),minval(dummy3d) + endif + + print*,"- CALL FieldScatter FOR INPUT ", trim(tracers_input(k)) + call ESMF_FieldScatter(tracers_input_grid(k), dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + enddo + + if (localpet == 0) then + call sptezm(0,sighead%jcap,4,i_input, j_input, lev_input, sigdata%t, dummy3d, 1) + print*,'temp ',maxval(dummy3d),minval(dummy3d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." + call ESMF_FieldScatter(temp_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +!--------------------------------------------------------------------------- +! The spectral gfs files have omega, not vertical velocity. Set to +! zero for now. Convert from omega to vv in the future? +!--------------------------------------------------------------------------- + + if (localpet == 0) then + print*,"- NO VERTICAL VELOCITY RECORD. SET TO ZERO." + dummy3d = 0.0 + endif + + print*,"- CALL FieldScatter FOR INPUT DZDT." + call ESMF_FieldScatter(dzdt_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call sptezmv(0, sighead%jcap, 4, i_input, j_input, lev_input, sigdata%d, sigdata%z, dummy3d, dummy3d2, 1) + print*,'u ',maxval(dummy3d),minval(dummy3d) + print*,'v ',maxval(dummy3d2),minval(dummy3d2) + endif + + print*,"- CALL FieldScatter FOR INPUT U-WIND." + call ESMF_FieldScatter(u_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + print*,"- CALL FieldScatter FOR INPUT V-WIND." + call ESMF_FieldScatter(v_input_grid, dummy3d2, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + deallocate(dummy2d, dummy3d, dummy3d2) + + if (localpet == 0) call sigio_axdbta(sigdata, iret) + + call sigio_sclose(21, iret) + +!--------------------------------------------------------------------------- +! Convert from 2-d to 3-d component winds. +!--------------------------------------------------------------------------- + + call convert_winds + +!--------------------------------------------------------------------------- +! Compute 3-d pressure from 'ak' and 'bk'. +!--------------------------------------------------------------------------- + + print*,"- COMPUTE 3-D PRESSURE." + + print*,"- CALL FieldGet FOR 3-D PRES." + nullify(pptr) + call ESMF_FieldGet(pres_input_grid, & + computationalLBound=clb, & + computationalUBound=cub, & + farrayPtr=pptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR SURFACE PRESSURE." + nullify(psptr) + call ESMF_FieldGet(ps_input_grid, & + farrayPtr=psptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + +!--------------------------------------------------------------------------- +! First, compute interface pressure. +!--------------------------------------------------------------------------- + + allocate(pi(clb(1):cub(1),clb(2):cub(2),1:levp1_input),stat=rc) + + do k=1,levp1_input + ak = sighead%vcoord(k,1) + bk = sighead%vcoord(k,2) + do i= clb(1), cub(1) + do j= clb(2), cub(2) + pi(i,j,k) = ak + bk*psptr(i,j) + enddo + enddo + enddo + + if (localpet == 0) then + print*,'pres int ',psptr(clb(1),clb(2)),pi(clb(1),clb(2),:) + endif + +!--------------------------------------------------------------------------- +! Now comput mid-layer pressure from interface pressure. +!--------------------------------------------------------------------------- + + do k=1,lev_input + do i= clb(1), cub(1) + do j= clb(2), cub(2) + pptr(i,j,k) = (pi(i,j,k)+pi(i,j,k+1))/2.0_esmf_kind_r8 + enddo + enddo + enddo + + deallocate(pi) + + if (localpet == 0) then + print*,'pres ',psptr(clb(1),clb(2)),pptr(clb(1),clb(2),:) + endif + + end subroutine read_input_atm_gfs_sigio_file + +!> Read input atmospheric data from spectral gfs (global gaussian in +!! nemsio format. Starting July 19, 2017). +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_atm_gfs_gaussian_nemsio_file(localpet) + + implicit none + + integer, intent(in) :: localpet + + character(len=300) :: the_file + character(len=20) :: vlevtyp, vname + + integer(nemsio_intkind) :: vlev, iret + integer :: i, j, k, n, rc + integer :: clb(3), cub(3) + + real(nemsio_realkind), allocatable :: vcoord(:,:,:) + real(nemsio_realkind), allocatable :: dummy(:) + real(esmf_kind_r8), allocatable :: dummy2d(:,:) + real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) + real(esmf_kind_r8) :: ak, bk + real(esmf_kind_r8), allocatable :: pi(:,:,:) + real(esmf_kind_r8), pointer :: pptr(:,:,:), psptr(:,:) + + type(nemsio_gfile) :: gfile + + the_file = trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(1)) + + print*,"- READ ATMOS DATA FROM SPECTRAL GFS NEMSIO FILE: ", trim(the_file) + + print*,"- OPEN FILE." + call nemsio_open(gfile, the_file, "read", iret=iret) + if (iret /= 0) call error_handler("OPENING SPECTRAL GFS NEMSIO ATM FILE.", iret) + + print*,"- READ NUMBER OF VERTICAL LEVELS." + call nemsio_getfilehead(gfile, iret=iret, dimz=lev_input) + if (iret /= 0) call error_handler("READING NUMBER OF VERTICAL LEVLES.", iret) + + levp1_input = lev_input + 1 + + allocate(vcoord(levp1_input,3,2)) + + print*,"- READ VERTICAL COORDINATE INFO." + call nemsio_getfilehead(gfile, iret=iret, vcoord=vcoord) + if (iret /= 0) call error_handler("READING VERTICAL COORDINATE INFO.", iret) + +!--------------------------------------------------------------------------- +! Initialize esmf atmospheric fields. +!--------------------------------------------------------------------------- + + call init_atm_esmf_fields + + if (localpet == 0) then + allocate(dummy(i_input*j_input)) + allocate(dummy2d(i_input,j_input)) + allocate(dummy3d(i_input,j_input,lev_input)) + else + allocate(dummy(0)) + allocate(dummy2d(0,0)) + allocate(dummy3d(0,0,0)) + endif + +!----------------------------------------------------------------------- +! 3-d fields in gaussian files increment from bottom to model top. +! That is what is expected by this program, so no need to flip indices. +!----------------------------------------------------------------------- + + if (localpet == 0) then + print*,"- READ TEMPERATURE." + vname = "tmp" + vlevtyp = "mid layer" + do vlev = 1, lev_input + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING TEMPERATURE RECORD.", iret) + dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) +! print*,'temp check after read ',vlev, dummy3d(1,1,vlev) + enddo + endif + + print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." + call ESMF_FieldScatter(temp_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + do n = 1, num_tracers_input + + if (localpet == 0) then + print*,"- READ ", trim(tracers_input(n)) + vname = trim(tracers_input(n)) + vlevtyp = "mid layer" + do vlev = 1, lev_input + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING TRACER RECORD.", iret) +! print*,'tracer ',vlev, maxval(dummy),minval(dummy) + dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) + enddo + endif + + print*,"- CALL FieldScatter FOR INPUT ", trim(tracers_input(n)) + call ESMF_FieldScatter(tracers_input_grid(n), dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + enddo + + if (localpet == 0) then + print*,"- READ U-WINDS." + vname = "ugrd" + vlevtyp = "mid layer" + do vlev = 1, lev_input + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING U-WIND RECORD.", iret) +! print*,'ugrd ',vlev, maxval(dummy),minval(dummy) + dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) + enddo + endif + + print*,"- CALL FieldScatter FOR INPUT U-WIND." + call ESMF_FieldScatter(u_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ V-WINDS." + vname = "vgrd" + vlevtyp = "mid layer" + do vlev = 1, lev_input + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING V-WIND RECORD.", iret) +! print*,'vgrd ',vlev, maxval(dummy),minval(dummy) + dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) + enddo + endif + + print*,"- CALL FieldScatter FOR INPUT V-WIND." + call ESMF_FieldScatter(v_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +!--------------------------------------------------------------------------- +! The spectral gfs nemsio files do not have a vertical velocity or +! omega record. So set to zero for now. +!--------------------------------------------------------------------------- + + if (localpet == 0) then + print*,"- NO VERTICAL VELOCITY RECORD. SET TO ZERO." + dummy3d = 0.0 + endif + + print*,"- CALL FieldScatter FOR INPUT DZDT." + call ESMF_FieldScatter(dzdt_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ HGT." + vname = "hgt" + vlevtyp = "sfc" + vlev = 1 + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING HGT RECORD.", iret) +! print*,'hgt ',vlev, maxval(dummy),minval(dummy) + dummy2d = reshape(dummy, (/i_input,j_input/)) + endif + + print*,"- CALL FieldScatter FOR TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ PRES." + vname = "pres" + vlevtyp = "sfc" + vlev = 1 + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING PRES RECORD.", iret) +! print*,'pres ',vlev, maxval(dummy),minval(dummy) + dummy2d = reshape(dummy, (/i_input,j_input/)) + endif + + print*,"- CALL FieldScatter FOR SURFACE PRESSURE." + call ESMF_FieldScatter(ps_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + call nemsio_close(gfile) + + deallocate(dummy, dummy2d, dummy3d) + +!--------------------------------------------------------------------------- +! Convert from 2-d to 3-d component winds. +!--------------------------------------------------------------------------- + + call convert_winds + +!--------------------------------------------------------------------------- +! Compute 3-d pressure from 'ak' and 'bk'. +!--------------------------------------------------------------------------- + + print*,"- COMPUTE 3-D PRESSURE." + + print*,"- CALL FieldGet FOR 3-D PRES." + nullify(pptr) + call ESMF_FieldGet(pres_input_grid, & + computationalLBound=clb, & + computationalUBound=cub, & + farrayPtr=pptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR SURFACE PRESSURE." + nullify(psptr) + call ESMF_FieldGet(ps_input_grid, & + farrayPtr=psptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + +!--------------------------------------------------------------------------- +! First, compute interface pressure. +!--------------------------------------------------------------------------- + + allocate(pi(clb(1):cub(1),clb(2):cub(2),1:levp1_input)) + + do k=1,levp1_input + ak = vcoord(k,1,1) + bk = vcoord(k,2,1) + do i= clb(1), cub(1) + do j= clb(2), cub(2) + pi(i,j,k) = ak + bk*psptr(i,j) + enddo + enddo + enddo + + deallocate(vcoord) + +!--------------------------------------------------------------------------- +! Now comput mid-layer pressure from interface pressure. +!--------------------------------------------------------------------------- + + do k=1,lev_input + do i= clb(1), cub(1) + do j= clb(2), cub(2) + pptr(i,j,k) = (pi(i,j,k)+pi(i,j,k+1))/2.0 + enddo + enddo + enddo + + deallocate(pi) + + end subroutine read_input_atm_gfs_gaussian_nemsio_file + +!> Read input grid atmospheric fv3 gaussian nemsio files. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_atm_gaussian_nemsio_file(localpet) + + implicit none + + integer, intent(in) :: localpet + + character(len=300) :: the_file + character(len=20) :: vlevtyp, vname + + integer :: i, j, k, n + integer :: rc, clb(3), cub(3) + integer(nemsio_intkind) :: vlev, iret + + real(nemsio_realkind), allocatable :: vcoord(:,:,:) + real(nemsio_realkind), allocatable :: dummy(:) + real(esmf_kind_r8), allocatable :: dummy2d(:,:) + real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) + real(esmf_kind_r8), pointer :: presptr(:,:,:), psptr(:,:) + real(esmf_kind_r8), pointer :: dpresptr(:,:,:) + real(esmf_kind_r8), allocatable :: pres_interface(:) + + type(nemsio_gfile) :: gfile + + the_file = trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(1)) + + print*,"- READ ATMOS DATA FROM GAUSSIAN NEMSIO FILE: ", trim(the_file) + + print*,"- OPEN FILE." + call nemsio_open(gfile, the_file, "read", iret=iret) + if (iret /= 0) call error_handler("OPENING GAUSSIAN NEMSIO ATM FILE.", iret) + + print*,"- READ NUMBER OF VERTICAL LEVELS." + call nemsio_getfilehead(gfile, iret=iret, dimz=lev_input) + if (iret /= 0) call error_handler("READING NUMBER OF VERTICAL LEVLES.", iret) + + levp1_input = lev_input + 1 + + allocate(vcoord(levp1_input,3,2)) + + print*,"- READ VERTICAL COORDINATE INFO." + call nemsio_getfilehead(gfile, iret=iret, vcoord=vcoord) + if (iret /= 0) call error_handler("READING VERTICAL COORDINATE INFO.", iret) + +!--------------------------------------------------------------------------- +! Initialize esmf atmospheric fields. +!--------------------------------------------------------------------------- + + call init_atm_esmf_fields + + print*,"- CALL FieldCreate FOR INPUT DPRES." + dpres_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lev_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + if (localpet == 0) then + allocate(dummy(i_input*j_input)) + allocate(dummy2d(i_input,j_input)) + allocate(dummy3d(i_input,j_input,lev_input)) + else + allocate(dummy(0)) + allocate(dummy2d(0,0)) + allocate(dummy3d(0,0,0)) + endif + +!----------------------------------------------------------------------- +! 3-d fields in gaussian files increment from bottom to model top. +! That is what is expected by this program, so no need to flip indices. +!----------------------------------------------------------------------- + + if (localpet == 0) then + print*,"- READ TEMPERATURE." + vname = "tmp" + vlevtyp = "mid layer" + do vlev = 1, lev_input + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING TEMPERATURE RECORD.", iret) + dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) + print*,'temp check after read ',vlev, dummy3d(1,1,vlev) + enddo + endif + + print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." + call ESMF_FieldScatter(temp_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + do n = 1, num_tracers_input + + if (localpet == 0) then + print*,"- READ ", trim(tracers_input(n)) + vname = trim(tracers_input(n)) + vlevtyp = "mid layer" + do vlev = 1, lev_input + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING TRACER RECORD.", iret) + print*,'tracer ',vlev, maxval(dummy),minval(dummy) + dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) + enddo + endif + + print*,"- CALL FieldScatter FOR INPUT ", trim(tracers_input(n)) + call ESMF_FieldScatter(tracers_input_grid(n), dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + enddo + + if (localpet == 0) then + print*,"- READ U-WINDS." + vname = "ugrd" + vlevtyp = "mid layer" + do vlev = 1, lev_input + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING U-WIND RECORD.", iret) + print*,'ugrd ',vlev, maxval(dummy),minval(dummy) + dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) + enddo + endif + + print*,"- CALL FieldScatter FOR INPUT U-WIND." + call ESMF_FieldScatter(u_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ V-WINDS." + vname = "vgrd" + vlevtyp = "mid layer" + do vlev = 1, lev_input + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING V-WIND RECORD.", iret) + print*,'vgrd ',vlev, maxval(dummy),minval(dummy) + dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) + enddo + endif + + print*,"- CALL FieldScatter FOR INPUT V-WIND." + call ESMF_FieldScatter(v_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ DPRES." + vname = "dpres" + vlevtyp = "mid layer" + do vlev = 1, lev_input + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING DPRES RECORD.", iret) + print*,'dpres ',vlev, maxval(dummy),minval(dummy) + dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) + enddo + endif + + print*,"- CALL FieldScatter FOR INPUT DPRES." + call ESMF_FieldScatter(dpres_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ DZDT." + vname = "dzdt" + vlevtyp = "mid layer" + do vlev = 1, lev_input + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING DZDT RECORD.", iret) + print*,'dzdt ',vlev, maxval(dummy),minval(dummy) + dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) + enddo + endif + + print*,"- CALL FieldScatter FOR INPUT DZDT." + call ESMF_FieldScatter(dzdt_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ HGT." + vname = "hgt" + vlevtyp = "sfc" + vlev = 1 + call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) + if (iret /= 0) call error_handler("READING HGT RECORD.", iret) + print*,'hgt ',vlev, maxval(dummy),minval(dummy) + dummy2d = reshape(dummy, (/i_input,j_input/)) + endif + + print*,"- CALL FieldScatter FOR TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + call nemsio_close(gfile) + + deallocate(dummy, dummy2d, dummy3d) + +!--------------------------------------------------------------------------- +! Convert from 2-d to 3-d component winds. +!--------------------------------------------------------------------------- + + call convert_winds + +!--------------------------------------------------------------------------- +! Compute 3-d pressure. Mid-layer and surface pressure are computed +! from delta p. The surface pressure in the file is not used. After +! the model's write component interpolates from the cubed-sphere grid +! to the gaussian grid, the surface pressure is no longer consistent +! with the delta p (per Jun Wang). +!--------------------------------------------------------------------------- + + print*,"- COMPUTE 3-D PRESSURE." + + print*,"- CALL FieldGet FOR DELTA PRESSURE." + nullify(dpresptr) + call ESMF_FieldGet(dpres_input_grid, & + computationalLBound=clb, & + computationalUBound=cub, & + farrayPtr=dpresptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR 3-D PRESSURE." + nullify(presptr) + call ESMF_FieldGet(pres_input_grid, & + farrayPtr=presptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR SURFACE PRESSURE." + nullify(psptr) + call ESMF_FieldGet(ps_input_grid, & + farrayPtr=psptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + allocate(pres_interface(levp1_input)) + + if (localpet == 0) then + do k = clb(3), cub(3) + print*,'dpres is ',cub(1),cub(2),k, dpresptr(cub(1),cub(2),k) + enddo + endif + + do i = clb(1), cub(1) + do j = clb(2), cub(2) + pres_interface(levp1_input) = vcoord(levp1_input,1,1) + do k = lev_input, 1, -1 + pres_interface(k) = pres_interface(k+1) + dpresptr(i,j,k) + enddo + psptr(i,j) = pres_interface(1) + do k = 1, lev_input + presptr(i,j,k) = (pres_interface(k) + pres_interface(k+1)) / 2.0_8 + enddo + enddo + enddo + + deallocate(vcoord) + + if (localpet == 0) then + print*,'psfc is ',clb(1),clb(2),psptr(clb(1),clb(2)) + print*,'pres is ',clb(1),clb(2),presptr(clb(1),clb(2),:) + endif + + print*,'pres check 1',localpet,maxval(presptr(:,:,1)),minval(presptr(:,:,1)) + print*,'pres check lev',localpet,maxval(presptr(:,:,lev_input)),minval(presptr(:,:,lev_input)) + + deallocate(pres_interface) + + call ESMF_FieldDestroy(dpres_input_grid, rc=rc) + + end subroutine read_input_atm_gaussian_nemsio_file + +!> Read input grid fv3 atmospheric data 'warm' restart files. +!! +!! @note Routine reads tiled files in parallel. Tile 1 is read by +!! localpet 0; tile 2 by localpet 1, etc. The number of pets +!! must be equal to or greater than the number of tiled files. +!! Logic only tested with global input data of six tiles. +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_atm_restart_file(localpet) + + implicit none + + integer, intent(in) :: localpet + + character(len=500) :: tilefile + + integer :: i, j, k + integer :: clb(3), cub(3) + integer :: rc, tile, ncid, id_var + integer :: error, id_dim + + real(esmf_kind_r8), allocatable :: ak(:) + real(esmf_kind_r8), pointer :: presptr(:,:,:), psptr(:,:) + real(esmf_kind_r8), pointer :: dpresptr(:,:,:) + real(esmf_kind_r8), allocatable :: data_one_tile(:,:) + real(esmf_kind_r8), allocatable :: data_one_tile_3d(:,:,:) + real(esmf_kind_r8), allocatable :: pres_interface(:) + +!--------------------------------------------------------------------------- +! Get number of vertical levels and model top pressure. +!--------------------------------------------------------------------------- + + tilefile = trim(data_dir_input_grid) // "/" // trim(atm_core_files_input_grid(7)) + print*,"- READ ATM VERTICAL LEVELS FROM: ", trim(tilefile) + error=nf90_open(trim(tilefile),nf90_nowrite,ncid) + call netcdf_err(error, 'opening: '//trim(tilefile) ) + + error=nf90_inq_dimid(ncid, 'xaxis_1', id_dim) + call netcdf_err(error, 'reading xaxis_1 id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=levp1_input) + call netcdf_err(error, 'reading xaxis_1 value' ) + + lev_input = levp1_input - 1 + + allocate(ak(levp1_input)) + + error=nf90_inq_varid(ncid, 'ak', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, ak) + call netcdf_err(error, 'reading ak' ) + + error = nf90_close(ncid) + +!--------------------------------------------------------------------------- +! Initialize esmf atmospheric fields. +!--------------------------------------------------------------------------- + + call init_atm_esmf_fields + + print*,"- CALL FieldCreate FOR INPUT GRID DELTA PRESSURE." + dpres_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lev_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + if (localpet < num_tiles_input_grid) then + allocate(data_one_tile_3d(i_input,j_input,lev_input)) + allocate(data_one_tile(i_input,j_input)) + else + allocate(data_one_tile_3d(0,0,0)) + allocate(data_one_tile(0,0)) + endif + + if (localpet < num_tiles_input_grid) then + tile = localpet+1 + tilefile= trim(data_dir_input_grid) // "/" // trim(atm_core_files_input_grid(tile)) + print*,"- READ ATMOSPHERIC CORE FILE: ", trim(tilefile) + error=nf90_open(trim(tilefile),nf90_nowrite,ncid) + call netcdf_err(error, 'opening: '//trim(tilefile) ) + endif + + if (localpet < num_tiles_input_grid) then + error=nf90_inq_varid(ncid, 'phis', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile) + call netcdf_err(error, 'reading field' ) + data_one_tile = data_one_tile / 9.806_8 ! geopotential height + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID TERRAIN for tile ",tile + call ESMF_FieldScatter(terrain_input_grid, data_one_tile, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) then +! error=nf90_inq_varid(ncid, 'W', id_var) +! call netcdf_err(error, 'reading field id' ) +! error=nf90_get_var(ncid, id_var, data_one_tile_3d) +! call netcdf_err(error, 'reading field' ) +! data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + +! Using 'w' from restart files has caused problems. Set to zero. + data_one_tile_3d = 0.0_8 + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID VERTICAL VELOCITY for tile ",tile + call ESMF_FieldScatter(dzdt_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) then + error=nf90_inq_varid(ncid, 'T', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile_3d) + call netcdf_err(error, 'reading field' ) + data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." + call ESMF_FieldScatter(temp_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) then + error=nf90_inq_varid(ncid, 'delp', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile_3d) + call netcdf_err(error, 'reading field' ) + data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT DELTA PRESSURE." + call ESMF_FieldScatter(dpres_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) then + error=nf90_inq_varid(ncid, 'ua', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile_3d) + call netcdf_err(error, 'reading field' ) + data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID U." + call ESMF_FieldScatter(u_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) then + error=nf90_inq_varid(ncid, 'va', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile_3d) + call netcdf_err(error, 'reading field' ) + data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID V." + call ESMF_FieldScatter(v_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) error = nf90_close(ncid) + + if (localpet < num_tiles_input_grid) then + tile = localpet+1 + tilefile= trim(data_dir_input_grid) // "/" // trim(atm_tracer_files_input_grid(tile)) + print*,"- READ ATMOSPHERIC TRACER FILE: ", trim(tilefile) + error=nf90_open(trim(tilefile),nf90_nowrite,ncid) + call netcdf_err(error, 'opening: '//trim(tilefile) ) + endif + + do i = 1, num_tracers_input + + if (localpet < num_tiles_input_grid) then + error=nf90_inq_varid(ncid, tracers_input(i), id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile_3d) + call netcdf_err(error, 'reading field' ) + data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT ", trim(tracers_input(i)) + call ESMF_FieldScatter(tracers_input_grid(i), data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + enddo + + if (localpet < num_tiles_input_grid) error=nf90_close(ncid) + +!--------------------------------------------------------------------------- +! Convert from 2-d to 3-d cartesian winds. +!--------------------------------------------------------------------------- + + call convert_winds + +!--------------------------------------------------------------------------- +! Compute pressures +!--------------------------------------------------------------------------- + + print*,"- CALL FieldGet FOR SURFACE PRESSURE." + call ESMF_FieldGet(ps_input_grid, & + farrayPtr=psptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR PRESSURE." + call ESMF_FieldGet(pres_input_grid, & + computationalLBound=clb, & + computationalUBound=cub, & + farrayPtr=presptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR DELTA PRESSURE." + call ESMF_FieldGet(dpres_input_grid, & + farrayPtr=dpresptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + allocate(pres_interface(levp1_input)) + + do i = clb(1), cub(1) + do j = clb(2), cub(2) + pres_interface(levp1_input) = ak(1) ! model top in Pa + do k = (levp1_input-1), 1, -1 + pres_interface(k) = pres_interface(k+1) + dpresptr(i,j,k) + enddo + do k = 1, lev_input + presptr(i,j,k) = (pres_interface(k) + pres_interface(k+1)) / 2.0_8 + enddo + psptr(i,j) = pres_interface(1) + enddo + enddo + + deallocate(ak) + deallocate(pres_interface) + + call ESMF_FieldDestroy(dpres_input_grid, rc=rc) + + deallocate(data_one_tile_3d, data_one_tile) + + end subroutine read_input_atm_restart_file + +!> Read fv3 netcdf gaussian history file. Each task reads a horizontal +!! slice. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_atm_gaussian_netcdf_file(localpet) + + use mpi + + implicit none + + integer, intent(in) :: localpet + + character(len=500) :: tilefile + + integer :: start(3), count(3), iscnt + integer :: error, ncid, num_tracers_file + integer :: id_dim, idim_input, jdim_input + integer :: id_var, rc, nprocs, max_procs + integer :: kdim, remainder, myrank, i, j, k, n + integer :: clb(3), cub(3) + integer, allocatable :: kcount(:), startk(:), displ(:) + integer, allocatable :: ircnt(:) + + real(esmf_kind_r8), allocatable :: phalf(:) + real(esmf_kind_r8), allocatable :: pres_interface(:) + real(kind=4), allocatable :: dummy3d(:,:,:) + real(kind=4), allocatable :: dummy3dall(:,:,:) + real(esmf_kind_r8), allocatable :: dummy3dflip(:,:,:) + real(esmf_kind_r8), allocatable :: dummy(:,:) + real(esmf_kind_r8), pointer :: presptr(:,:,:), dpresptr(:,:,:) + real(esmf_kind_r8), pointer :: psptr(:,:) + + print*,"- READ INPUT ATMOS DATA FROM GAUSSIAN NETCDF FILE." + + tilefile = trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(1)) + error=nf90_open(trim(tilefile),nf90_nowrite,ncid) + call netcdf_err(error, 'opening: '//trim(tilefile) ) + + error=nf90_inq_dimid(ncid, 'grid_xt', id_dim) + call netcdf_err(error, 'reading grid_xt id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=idim_input) + call netcdf_err(error, 'reading grid_xt value' ) + + error=nf90_inq_dimid(ncid, 'grid_yt', id_dim) + call netcdf_err(error, 'reading grid_yt id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=jdim_input) + call netcdf_err(error, 'reading grid_yt value' ) + + if (idim_input /= i_input .or. jdim_input /= j_input) then + call error_handler("DIMENSION MISMATCH BETWEEN SFC AND OROG FILES.", 2) + endif + + error=nf90_inq_dimid(ncid, 'pfull', id_dim) + call netcdf_err(error, 'reading pfull id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=lev_input) + call netcdf_err(error, 'reading pfull value' ) + + error=nf90_inq_dimid(ncid, 'phalf', id_dim) + call netcdf_err(error, 'reading phalf id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=levp1_input) + call netcdf_err(error, 'reading phalf value' ) + allocate(phalf(levp1_input)) + error=nf90_inq_varid(ncid, 'phalf', id_var) + call netcdf_err(error, 'getting phalf varid' ) + error=nf90_get_var(ncid, id_var, phalf) + call netcdf_err(error, 'reading phalf varid' ) + + error=nf90_get_att(ncid, nf90_global, 'ncnsto', num_tracers_file) + call netcdf_err(error, 'reading ntracer value' ) + + call mpi_comm_size(mpi_comm_world, nprocs, error) + print*,'- Running with ', nprocs, ' processors' + + call mpi_comm_rank(mpi_comm_world, myrank, error) + print*,'- myrank/localpet is ',myrank,localpet + + max_procs = nprocs + if (nprocs > lev_input) then + max_procs = lev_input + endif + + kdim = lev_input / max_procs + remainder = lev_input - (max_procs*kdim) + + allocate(kcount(0:nprocs-1)) + kcount=0 + allocate(startk(0:nprocs-1)) + startk=0 + allocate(displ(0:nprocs-1)) + displ=0 + allocate(ircnt(0:nprocs-1)) + ircnt=0 + + do k = 0, max_procs-2 + kcount(k) = kdim + enddo + kcount(max_procs-1) = kdim + remainder + + startk(0) = 1 + do k = 1, max_procs-1 + startk(k) = startk(k-1) + kcount(k-1) + enddo + + ircnt(:) = idim_input * jdim_input * kcount(:) + + displ(0) = 0 + do k = 1, max_procs-1 + displ(k) = displ(k-1) + ircnt(k-1) + enddo + + iscnt=idim_input*jdim_input*kcount(myrank) + +! Account for case if number of tasks exceeds the number of vert levels. + + if (myrank <= max_procs-1) then + allocate(dummy3d(idim_input,jdim_input,kcount(myrank))) + else + allocate(dummy3d(0,0,0)) + endif + + if (myrank == 0) then + allocate(dummy3dall(idim_input,jdim_input,lev_input)) + dummy3dall = 0.0 + allocate(dummy3dflip(idim_input,jdim_input,lev_input)) + dummy3dflip = 0.0 + allocate(dummy(idim_input,jdim_input)) + dummy = 0.0 + else + allocate(dummy3dall(0,0,0)) + allocate(dummy3dflip(0,0,0)) + allocate(dummy(0,0)) + endif + +!--------------------------------------------------------------------------- +! Initialize esmf atmospheric fields. +!--------------------------------------------------------------------------- + + call init_atm_esmf_fields + + print*,"- CALL FieldCreate FOR INPUT GRID DELTA PRESSURE." + dpres_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lev_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + +! Temperature + + if (myrank <= max_procs-1) then + start = (/1,1,startk(myrank)/) + count = (/idim_input,jdim_input,kcount(myrank)/) + error=nf90_inq_varid(ncid, 'tmp', id_var) + call netcdf_err(error, 'reading tmp field id' ) + error=nf90_get_var(ncid, id_var, dummy3d, start=start, count=count) + call netcdf_err(error, 'reading tmp field' ) + endif + + call mpi_gatherv(dummy3d, iscnt, mpi_real, & + dummy3dall, ircnt, displ, mpi_real, & + 0, mpi_comm_world, error) + if (error /= 0) call error_handler("IN mpi_gatherv of temperature", error) + + if (myrank == 0) then + dummy3dflip(:,:,1:lev_input) = dummy3dall(:,:,lev_input:1:-1) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE " + call ESMF_FieldScatter(temp_input_grid, dummy3dflip, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! dpres + + if (myrank <= max_procs-1) then + error=nf90_inq_varid(ncid, 'dpres', id_var) + call netcdf_err(error, 'reading dpres field id' ) + error=nf90_get_var(ncid, id_var, dummy3d, start=start, count=count) + call netcdf_err(error, 'reading dpres field' ) + endif + + call mpi_gatherv(dummy3d, iscnt, mpi_real, & + dummy3dall, ircnt, displ, mpi_real, & + 0, mpi_comm_world, error) + if (error /= 0) call error_handler("IN mpi_gatherv of dpres", error) + + if (myrank == 0) then + dummy3dflip(:,:,1:lev_input) = dummy3dall(:,:,lev_input:1:-1) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID DPRES " + call ESMF_FieldScatter(dpres_input_grid, dummy3dflip, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! ugrd + + if (myrank <= max_procs-1) then + error=nf90_inq_varid(ncid, 'ugrd', id_var) + call netcdf_err(error, 'reading ugrd field id' ) + error=nf90_get_var(ncid, id_var, dummy3d, start=start, count=count) + call netcdf_err(error, 'reading ugrd field' ) + endif + + call mpi_gatherv(dummy3d, iscnt, mpi_real, & + dummy3dall, ircnt, displ, mpi_real, & + 0, mpi_comm_world, error) + if (error /= 0) call error_handler("IN mpi_gatherv of ugrd", error) + + if (myrank == 0) then + dummy3dflip(:,:,1:lev_input) = dummy3dall(:,:,lev_input:1:-1) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID UGRD " + call ESMF_FieldScatter(u_input_grid, dummy3dflip, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! vgrd + + if (myrank <= max_procs-1) then + error=nf90_inq_varid(ncid, 'vgrd', id_var) + call netcdf_err(error, 'reading vgrd field id' ) + error=nf90_get_var(ncid, id_var, dummy3d, start=start, count=count) + call netcdf_err(error, 'reading vgrd field' ) + endif + + call mpi_gatherv(dummy3d, iscnt, mpi_real, & + dummy3dall, ircnt, displ, mpi_real, & + 0, mpi_comm_world, error) + if (error /= 0) call error_handler("IN mpi_gatherv of vgrd", error) + + if (myrank == 0) then + dummy3dflip(:,:,1:lev_input) = dummy3dall(:,:,lev_input:1:-1) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID VGRD " + call ESMF_FieldScatter(v_input_grid, dummy3dflip, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! tracers + + do n = 1, num_tracers_input + + if (myrank <= max_procs-1) then + error=nf90_inq_varid(ncid, tracers_input(n), id_var) + call netcdf_err(error, 'reading tracer field id' ) + error=nf90_get_var(ncid, id_var, dummy3d, start=start, count=count) + call netcdf_err(error, 'reading tracer field' ) + endif + + call mpi_gatherv(dummy3d, iscnt, mpi_real, & + dummy3dall, ircnt, displ, mpi_real, & + 0, mpi_comm_world, error) + if (error /= 0) call error_handler("IN mpi_gatherv of tracer", error) + + if (myrank == 0) then + dummy3dflip(:,:,1:lev_input) = dummy3dall(:,:,lev_input:1:-1) + where(dummy3dflip < 0.0) dummy3dflip = 0.0 + endif + + print*,"- CALL FieldScatter FOR INPUT GRID ", tracers_input(n) + call ESMF_FieldScatter(tracers_input_grid(n), dummy3dflip, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + enddo + +! dzdt set to zero for now. + + if (myrank == 0) then + dummy3dflip = 0.0 + endif + + print*,"- CALL FieldScatter FOR INPUT GRID DZDT" + call ESMF_FieldScatter(dzdt_input_grid, dummy3dflip, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + deallocate(dummy3dflip, dummy3dall, dummy3d) + +! terrain + + if (myrank==0) then + print*,"- READ TERRAIN." + error=nf90_inq_varid(ncid, 'hgtsfc', id_var) + call netcdf_err(error, 'reading hgtsfc field id' ) + error=nf90_get_var(ncid, id_var, dummy) + call netcdf_err(error, 'reading hgtsfc field' ) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, dummy, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! surface pressure + + if (myrank==0) then + print*,"- READ SURFACE P." + error=nf90_inq_varid(ncid, 'pressfc', id_var) + call netcdf_err(error, 'reading pressfc field id' ) + error=nf90_get_var(ncid, id_var, dummy) + call netcdf_err(error, 'reading pressfc field' ) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SURFACE P." + call ESMF_FieldScatter(ps_input_grid, dummy, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + deallocate(kcount, startk, displ, ircnt, dummy) + +!--------------------------------------------------------------------------- +! Convert from 2-d to 3-d cartesian winds. +!--------------------------------------------------------------------------- + + call convert_winds + +!--------------------------------------------------------------------------- +! Compute pressure. +!--------------------------------------------------------------------------- + + print*,"- CALL FieldGet FOR PRESSURE." + call ESMF_FieldGet(pres_input_grid, & + computationalLBound=clb, & + computationalUBound=cub, & + farrayPtr=presptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR DELTA PRESSURE." + call ESMF_FieldGet(dpres_input_grid, & + farrayPtr=dpresptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR SURFACE PRESSURE." + call ESMF_FieldGet(ps_input_grid, & + farrayPtr=psptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + allocate(pres_interface(levp1_input)) + +!--------------------------------------------------------------------------- +! Compute 3-d pressure. +!--------------------------------------------------------------------------- + +!--------------------------------------------------------------------------- +! When ingesting gaussian netcdf files, the mid-layer +! surface pressure are computed top down from delta-p +! The surface pressure in the file is not used. According +! to Jun Wang, after the model's write component interpolates from the +! cubed-sphere grid to the gaussian grid, the surface pressure is +! no longer consistent with the delta p. +!--------------------------------------------------------------------------- + + do i = clb(1), cub(1) + do j = clb(2), cub(2) + pres_interface(levp1_input) = phalf(1) * 100.0_8 + do k = lev_input, 1, -1 + pres_interface(k) = pres_interface(k+1) + dpresptr(i,j,k) + enddo + psptr(i,j) = pres_interface(1) + do k = 1, lev_input + presptr(i,j,k) = (pres_interface(k) + pres_interface(k+1)) / 2.0_8 + enddo + enddo + enddo + + deallocate(pres_interface, phalf) + + call ESMF_FieldDestroy(dpres_input_grid, rc=rc) + + end subroutine read_input_atm_gaussian_netcdf_file + +!> Read input grid fv3 atmospheric tiled history files in netcdf +!! format. +!! +!! @note Routine reads tiled files in parallel. Tile 1 is read by +!! localpet 0; tile 2 by localpet 1, etc. The number of pets +!! must be equal to or greater than the number of tiled files. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_atm_tiled_history_file(localpet) + + use mpi + + implicit none + + integer, intent(in) :: localpet + + character(len=500) :: tilefile + + integer :: error, ncid, rc, tile + integer :: id_dim, idim_input, jdim_input + integer :: id_var, i, j, k, n + integer :: clb(3), cub(3), num_tracers_file + + real(esmf_kind_r8), allocatable :: data_one_tile(:,:) + real(esmf_kind_r8), allocatable :: data_one_tile_3d(:,:,:) + real(esmf_kind_r8), pointer :: presptr(:,:,:), dpresptr(:,:,:) + real(esmf_kind_r8), pointer :: psptr(:,:) + real(esmf_kind_r8), allocatable :: pres_interface(:), phalf(:) + + print*,"- READ INPUT ATMOS DATA FROM TILED HISTORY FILES." + + tilefile = trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(1)) + error=nf90_open(trim(tilefile),nf90_nowrite,ncid) + call netcdf_err(error, 'opening: '//trim(tilefile) ) + + error=nf90_inq_dimid(ncid, 'grid_xt', id_dim) + call netcdf_err(error, 'reading grid_xt id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=idim_input) + call netcdf_err(error, 'reading grid_xt value' ) + + error=nf90_inq_dimid(ncid, 'grid_yt', id_dim) + call netcdf_err(error, 'reading grid_yt id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=jdim_input) + call netcdf_err(error, 'reading grid_yt value' ) + + if (idim_input /= i_input .or. jdim_input /= j_input) then + call error_handler("DIMENSION MISMATCH BETWEEN SFC AND OROG FILES.", 2) + endif + + error=nf90_inq_dimid(ncid, 'pfull', id_dim) + call netcdf_err(error, 'reading pfull id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=lev_input) + call netcdf_err(error, 'reading pfull value' ) + + error=nf90_inq_dimid(ncid, 'phalf', id_dim) + call netcdf_err(error, 'reading phalf id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=levp1_input) + call netcdf_err(error, 'reading phalf value' ) + allocate(phalf(levp1_input)) + error=nf90_inq_varid(ncid, 'phalf', id_var) + call netcdf_err(error, 'getting phalf varid' ) + error=nf90_get_var(ncid, id_var, phalf) + call netcdf_err(error, 'reading phalf varid' ) + + error=nf90_get_att(ncid, nf90_global, 'ncnsto', num_tracers_file) + call netcdf_err(error, 'reading ntracer value' ) + + error = nf90_close(ncid) + + print*,'- FILE HAS ', num_tracers_file, ' TRACERS.' + print*,'- WILL PROCESS ', num_tracers_input, ' TRACERS.' + +!--------------------------------------------------------------------------- +! Initialize esmf atmospheric fields. +!--------------------------------------------------------------------------- + + call init_atm_esmf_fields + + print*,"- CALL FieldCreate FOR INPUT GRID DELTA PRESSURE." + dpres_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lev_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + if (localpet < num_tiles_input_grid) then + allocate(data_one_tile(i_input,j_input)) + allocate(data_one_tile_3d(i_input,j_input,lev_input)) + else + allocate(data_one_tile(0,0)) + allocate(data_one_tile_3d(0,0,0)) + endif + + if (localpet < num_tiles_input_grid) then + tile = localpet+1 + tilefile= trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(tile)) + print*,"- READ ATMOSPHERIC DATA FROM: ", trim(tilefile) + error=nf90_open(trim(tilefile),nf90_nowrite,ncid) + call netcdf_err(error, 'opening: '//trim(tilefile) ) + endif + + if (localpet < num_tiles_input_grid) then +! print*,"- READ VERTICAL VELOCITY." +! error=nf90_inq_varid(ncid, 'dzdt', id_var) +! call netcdf_err(error, 'reading field id' ) +! error=nf90_get_var(ncid, id_var, data_one_tile_3d) +! call netcdf_err(error, 'reading field' ) +! data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + +! Using w from the tiled history files has caused problems. +! Set to zero. + data_one_tile_3d = 0.0_8 + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID VERTICAL VELOCITY." + call ESMF_FieldScatter(dzdt_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + do n = 1, num_tracers_input + + if (localpet < num_tiles_input_grid) then + print*,"- READ ", trim(tracers_input(n)) + error=nf90_inq_varid(ncid, tracers_input(n), id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile_3d) + call netcdf_err(error, 'reading field' ) + data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID TRACER ", trim(tracers_input(n)) + call ESMF_FieldScatter(tracers_input_grid(n), data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + enddo + + if (localpet < num_tiles_input_grid) then + print*,"- READ TEMPERATURE." + error=nf90_inq_varid(ncid, 'tmp', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile_3d) + call netcdf_err(error, 'reading field' ) + data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." + call ESMF_FieldScatter(temp_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) then + print*,"- READ U-WIND." + error=nf90_inq_varid(ncid, 'ugrd', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile_3d) + call netcdf_err(error, 'reading field' ) + data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID U." + call ESMF_FieldScatter(u_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) then + print*,"- READ V-WIND." + error=nf90_inq_varid(ncid, 'vgrd', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile_3d) + call netcdf_err(error, 'reading field' ) + data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID V." + call ESMF_FieldScatter(v_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) then + print*,"- READ SURFACE PRESSURE." + error=nf90_inq_varid(ncid, 'pressfc', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile) + call netcdf_err(error, 'reading field' ) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID SURFACE PRESSURE." + call ESMF_FieldScatter(ps_input_grid, data_one_tile, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) then + print*,"- READ TERRAIN." + error=nf90_inq_varid(ncid, 'hgtsfc', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile) + call netcdf_err(error, 'reading field' ) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT GRID TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, data_one_tile, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) then + print*,"- READ DELTA PRESSURE." + error=nf90_inq_varid(ncid, 'dpres', id_var) + call netcdf_err(error, 'reading field id' ) + error=nf90_get_var(ncid, id_var, data_one_tile_3d) + call netcdf_err(error, 'reading field' ) + data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) + endif + + do tile = 1, num_tiles_input_grid + print*,"- CALL FieldScatter FOR INPUT DELTA PRESSURE." + call ESMF_FieldScatter(dpres_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + enddo + + if (localpet < num_tiles_input_grid) error = nf90_close(ncid) + + deallocate(data_one_tile_3d, data_one_tile) + +!--------------------------------------------------------------------------- +! Convert from 2-d to 3-d cartesian winds. +!--------------------------------------------------------------------------- + + call convert_winds + +!--------------------------------------------------------------------------- +! Compute pressure. +!--------------------------------------------------------------------------- + + print*,"- CALL FieldGet FOR PRESSURE." + call ESMF_FieldGet(pres_input_grid, & + computationalLBound=clb, & + computationalUBound=cub, & + farrayPtr=presptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR DELTA PRESSURE." + call ESMF_FieldGet(dpres_input_grid, & + farrayPtr=dpresptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR SURFACE PRESSURE." + call ESMF_FieldGet(ps_input_grid, & + farrayPtr=psptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + allocate(pres_interface(levp1_input)) + +!--------------------------------------------------------------------------- +! Compute 3-d pressure. +!--------------------------------------------------------------------------- + + do i = clb(1), cub(1) + do j = clb(2), cub(2) + pres_interface(1) = psptr(i,j) + do k = 2, levp1_input + pres_interface(k) = pres_interface(k-1) - dpresptr(i,j,k-1) + enddo + do k = 1, lev_input + presptr(i,j,k) = (pres_interface(k) + pres_interface(k+1)) / 2.0_8 + enddo + enddo + enddo + + deallocate(pres_interface, phalf) + + call ESMF_FieldDestroy(dpres_input_grid, rc=rc) + + end subroutine read_input_atm_tiled_history_file + +!> Read input grid atmospheric fv3gfs grib2 files. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_atm_grib2_file(localpet) + + use mpi + use grib_mod + + use grib2_util, only : rh2spfh, rh2spfh_gfs, convert_omega + + implicit none + + integer, intent(in) :: localpet + + integer, parameter :: ntrac_max=14 + integer, parameter :: max_levs=1000 + + character(len=300) :: the_file + character(len=20) :: vname, & + trac_names_vmap(ntrac_max), & + tmpstr, & + method, tracers_input_vmap(num_tracers_input), & + tracers_default(ntrac_max) + + integer :: i, j, k, n + integer :: ii,jj + integer :: rc, clb(3), cub(3) + integer :: vlev, iret,varnum, o3n, pdt_num + integer :: intrp_ier, done_print + integer :: trac_names_oct10(ntrac_max) + integer :: tracers_input_oct10(num_tracers_input) + integer :: trac_names_oct11(ntrac_max) + integer :: tracers_input_oct11(num_tracers_input) + integer :: lugb, lugi, jdisc, jpdt(200), jgdt(200), iscale + integer :: jids(200), jpdtn, jgdtn, octet_23, octet_29 + integer :: count_spfh, count_rh, count_icmr, count_scliwc + integer :: count_cice, count_rwmr, count_scllwc, count + + logical :: conv_omega=.false., & + hasspfh=.true., & + isnative=.false., & + use_rh=.false. , unpack, & + all_empty, is_missing + + real(esmf_kind_r8), allocatable :: dum2d_1(:,:) + + + real(esmf_kind_r8) :: rlevs_hold(max_levs) + real(esmf_kind_r8), allocatable :: rlevs(:) + real(esmf_kind_r4), allocatable :: dummy2d(:,:) + real(esmf_kind_r8), allocatable :: dummy3d(:,:,:), dummy2d_8(:,:),& + u_tmp_3d(:,:,:), v_tmp_3d(:,:,:) + real(esmf_kind_r8), pointer :: presptr(:,:,:), psptr(:,:),tptr(:,:,:), & + qptr(:,:,:), wptr(:,:,:), & + uptr(:,:,:), vptr(:,:,:) + real(esmf_kind_r4) :: value + real(esmf_kind_r8), parameter :: p0 = 100000.0 + real(esmf_kind_r8), allocatable :: dummy3d_col_in(:),dummy3d_col_out(:) + real(esmf_kind_r8), parameter :: intrp_missing = -999.0 + real(esmf_kind_r4), parameter :: lev_no_tr_fill = 20000.0 + real(esmf_kind_r4), parameter :: lev_no_o3_fill = 40000.0 + + type(gribfield) :: gfld + + tracers(:) = "NULL" + + trac_names_oct10 = (/1, 1, 14, 1, 1, 1, 1, 6, 6, 1, 6, 13, 13, 2 /) + trac_names_oct11 = (/0, 22, 192, 23, 24, 25, 32, 1, 29, 100, 28, 193, 192, 2 /) + + trac_names_vmap = (/"sphum ", "liq_wat ", "o3mr ", "ice_wat ", & + "rainwat ", "snowwat ", "graupel ", "cld_amt ", "ice_nc ", & + "rain_nc ", "water_nc", "liq_aero", "ice_aero", & + "sgs_tke "/) + + tracers_default = (/"sphum ", "liq_wat ", "o3mr ", "ice_wat ", & + "rainwat ", "snowwat ", "graupel ", "cld_amt ", "ice_nc ", & + "rain_nc ", "water_nc", "liq_aero", "ice_aero", & + "sgs_tke "/) + + the_file = trim(data_dir_input_grid) // "/" // trim(grib2_file_input_grid) + + print*,"- READ ATMOS DATA FROM GRIB2 FILE: ", trim(the_file) + + if (localpet == 0) then + + lugb=14 + lugi=0 + call baopenr(lugb,the_file,iret) + if (iret /= 0) call error_handler("ERROR OPENING GRIB2 FILE.", iret) + + jdisc = 0 ! Search for discipline - meteorological products + j = 0 ! Search at beginning of file. + jpdt = -9999 ! Array of values in product definition template, set to wildcard + jids = -9999 ! Array of values in identification section, set to wildcard + jgdt = -9999 ! Array of values in grid definition template, set to wildcard + jgdtn = -1 ! Search for any grid definition number. + jpdtn = -1 ! Search for any product definition template number. + unpack =.false. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + +!---------------------------------------------------------------------- +! Read first record and check if this is NCEP GEFS data. +! This will determine what product definition template number to +! search for (Section 4/Octets 8-9). +! +! Section 1/Octets 6-7 is '7' (NCEP) +! Section 1/Octets 8-9 is '2' (NCEP Ensemble products). +!---------------------------------------------------------------------- + + if (iret == 0) then + if (gfld%idsect(1) == 7 .and. gfld%idsect(2) == 2) then + print*,'- THIS IS NCEP GEFS DATA.' + pdt_num = 1 ! Search for product definition template number 1. + ! Individual ensember forecast. + else + pdt_num = 0 ! Search for product definition template number 0. + ! Analysis or forecast. + endif + else + call error_handler("READING GRIB2 FILE", iret) + endif + +!---------------------------------------------------------------------- +! First, check for the vertical coordinate. If temperture at the 10 hybrid +! level is found, hybrid coordinates are assumed. Otherwise, data is on +! isobaric levels. +!---------------------------------------------------------------------- + + j = 0 + jpdtn = pdt_num ! Search for the specific product definition template number. + jpdt(1) = 0 ! Sect4/oct 10 - Parameter category - temperature field + jpdt(2) = 0 ! Sect4/oct 11 - Parameter number - temperature + jpdt(10) = 105 ! Sect4/oct 23 - Type of level - hybrid + jpdt(12) = 10 ! Sect4/octs 25/28 - Value of hybrid level + unpack=.false. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret == 0) then + print*,'- DATA IS ON HYBRID LEVELS.' + octet_23 = 105 ! Section 4/Oct 23 - type of first fixed surface. + octet_29 = 255 ! Section 4/Oct 29 - type of second fixed surface (N/A). + isnative=.true. + else + print*,'- DATA IS ON ISOBARIC LEVELS.' + octet_23 = 100 ! Section 4/Oct 23 - type of first fixed surface. + octet_29 = 255 ! Section 4/Oct 29 - type of second fixed surface (N/A). + isnative=.false. + endif + +! Now count the number of vertical levels by searching for u-wind. +! Store the value of each level. + + rlevs_hold = -999.9 + lev_input = 0 + iret = 0 + j = 0 + jpdtn = -1 + jpdt = -9999 + + do + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret /= 0) exit + + if (gfld%discipline == 0) then ! Discipline - meteorological products + if (gfld%ipdtnum == pdt_num) then ! Product definition template number. + if (gfld%ipdtmpl(1) == 2 .and. gfld%ipdtmpl(2) == 2) then ! u-wind + ! Sect4/octs 10 and 11. + if (gfld%ipdtmpl(10) == octet_23 .and. gfld%ipdtmpl(13) == octet_29) then + ! Sect4 octs 23 and 29. + ! Hybrid or isobaric. + lev_input = lev_input + 1 + iscale = 10 ** gfld%ipdtmpl(11) + rlevs_hold(lev_input) = float(gfld%ipdtmpl(12))/float(iscale) + endif + endif + endif + endif + + j = k + enddo + + endif ! read file on task 0. + + call mpi_barrier(MPI_COMM_WORLD, iret) + call MPI_BCAST(isnative,1,MPI_LOGICAL,0,MPI_COMM_WORLD,iret) + call MPI_BCAST(lev_input,1,MPI_INTEGER,0,MPI_COMM_WORLD,iret) + call MPI_BCAST(pdt_num,1,MPI_INTEGER,0,MPI_COMM_WORLD,iret) + call MPI_BCAST(rlevs_hold, max_levs, MPI_INTEGER,0,MPI_COMM_WORLD,iret) + + allocate(slevs(lev_input)) + allocate(rlevs(lev_input)) + allocate(dummy3d_col_in(lev_input)) + allocate(dummy3d_col_out(lev_input)) + + levp1_input = lev_input + 1 + +! Jili Dong add sort to re-order isobaric levels. + + do i = 1, lev_input + rlevs(i) = rlevs_hold(i) + enddo + + call quicksort(rlevs,1,lev_input) + + do i = 1, lev_input + if (isnative) then + write(slevs(i), '(i6)') nint(rlevs(i)) + slevs(i) = trim(slevs(i)) // " hybrid" + if (i>1) then + if (any(slevs(1:i-1)==slevs(i))) call error_handler("Duplicate vertical level entries found.",1) + endif + else + write(slevs(i), '(f11.2)') rlevs(i) + slevs(i) = trim(slevs(i)) // " Pa" + if (i>1) then + if (any(slevs(1:i-1)==slevs(i))) call error_handler("Duplicate vertical level entries found.",1) + endif + endif + enddo + + if(localpet == 0) then + do i = 1,lev_input + print*, "- LEVEL AFTER SORT = ",trim(slevs(i)) + enddo + endif + +! Check to see if specfic humidity exists at all the same levels as ugrd. + + if (localpet == 0) then + + jpdtn = pdt_num ! Product definition template number. + jpdt = -9999 + jpdt(1) = 1 ! Sect4/oct 10 - Parameter category - moisture + jpdt(2) = 0 ! Sect4/oct 11 - Parameter number - specific humidity + jpdt(10) = octet_23 ! Sect4/oct 23 - type of level. + unpack=.false. + + count_spfh=0 + + do vlev = 1, lev_input + j = 0 + jpdt(12) = nint(rlevs(vlev)) + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret == 0) then + count_spfh = count_spfh + 1 + endif + enddo + + jpdt(1) = 1 ! Sec4/oct 10 - Parameter category - moisture + jpdt(2) = 1 ! Sec4/oct 11 - Parameter number - rel humidity + count_rh=0 + + do vlev = 1, lev_input + j = 0 + jpdt(12) = nint(rlevs(vlev)) + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret == 0) then + count_rh = count_rh + 1 + endif + enddo + + if (count_spfh /= lev_input) then + use_rh = .true. + endif + + if (count_spfh == 0 .or. use_rh) then + if (count_rh == 0) then + call error_handler("READING ATMOSPHERIC WATER VAPOR VARIABLE.", 2) + endif + hasspfh = .false. ! Will read rh and convert to specific humidity. + trac_names_oct10(1) = 1 + trac_names_oct11(1) = 1 + print*,"- FILE CONTAINS RH." + else + print*,"- FILE CONTAINS SPFH." + endif + + endif + + call MPI_BARRIER(MPI_COMM_WORLD, rc) + call MPI_BCAST(hasspfh,1,MPI_LOGICAL,0,MPI_COMM_WORLD,rc) + +! Search for and count the number of tracers in the file. + + if (localpet == 0) then + + jpdtn = pdt_num ! Product definition template number. + jpdt = -9999 + jpdt(10) = octet_23 ! Sect4/oct 23 - type of level. + unpack=.false. + + count_icmr=0 + count_scliwc=0 + count_cice=0 + count_rwmr=0 + count_scllwc=0 + + do vlev = 1, lev_input + + j = 0 + jpdt(1) = 1 ! Sect4/oct 10 - Parameter category - moisture + jpdt(2) = 23 ! Sect4/oct 11 - Parameter number - ice water mixing ratio + jpdt(12) = nint(rlevs(vlev)) + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret == 0) then + count_icmr = count_icmr + 1 + endif + + j = 0 + jpdt(1) = 1 ! Sect4/oct 10 - Parameter category - moisture + jpdt(2) = 84 ! Sect4/oct 11 - Parameter number - cloud ice water content. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret == 0) then + count_scliwc = count_scliwc + 1 + endif + + j = 0 + jpdt(1) = 6 ! Sect4/oct 10 - Parameter category - clouds + jpdt(2) = 0 ! Sect4/oct 11 - Parameter number - cloud ice + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret == 0) then + count_cice = count_cice + 1 + endif + + j = 0 + jpdt(1) = 1 ! Sect4/oct 10 - Parameter category - moisture + jpdt(2) = 24 ! Sect4/oct 11 - Parameter number - rain mixing ratio + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret == 0) then + count_rwmr = count_rwmr + 1 + endif + + j = 0 + jpdt(1) = 1 ! Sect4/oct 10 - Parameter category - moisture + jpdt(2) = 83 ! Sect4/oct 11 - Parameter number - specific cloud liquid + ! water content. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret == 0) then + count_scllwc = count_scllwc + 1 + endif + + enddo + + if (count_icmr == 0) then + if (count_scliwc == 0) then + if (count_cice == 0) then + print*,'- FILE DOES NOT CONTAIN CICE.' + else + trac_names_oct10(4) = 6 ! Sect4/oct 10 - Parameter category - clouds + trac_names_oct11(4) = 0 ! Sect4/oct 11 - Parameter number - cloud ice + print*,"- FILE CONTAINS CICE." + endif + else + trac_names_oct10(4) = 1 ! Sect4/oct 10 - Parameter category - moisture + trac_names_oct11(4) = 84 ! Sect4/oct 11 - Parameter number - cloud ice water content. + print*,"- FILE CONTAINS SCLIWC." + endif + else + print*,"- FILE CONTAINS ICMR." + endif ! count of icmr + + if (count_rwmr == 0) then + if (count_scllwc == 0) then + print*,"- FILE DOES NOT CONTAIN SCLLWC." + else + trac_names_oct10(4) = 1 ! Sect4/oct 10 - Parameter category - moisture + trac_names_oct11(4) = 83 ! Sect4/oct 11 - Parameter number - specific cloud liquid + ! water content. + print*,"- FILE CONTAINS SCLLWC." + endif + else + print*,"- FILE CONTAINS CLWMR." + endif + + endif ! count of tracers/localpet = 0 + + call MPI_BARRIER(MPI_COMM_WORLD, rc) + call MPI_BCAST(trac_names_oct10,ntrac_max,MPI_INTEGER,0,MPI_COMM_WORLD,rc) + call MPI_BCAST(trac_names_oct11,ntrac_max,MPI_INTEGER,0,MPI_COMM_WORLD,rc) + + print*,"- COUNT NUMBER OF TRACERS TO BE READ IN BASED ON PHYSICS SUITE TABLE" + do n = 1, num_tracers_input + + vname = tracers_input(n) + + i = maxloc(merge(1.,0.,trac_names_vmap == vname),dim=1) + + tracers_input_vmap(n)=trac_names_vmap(i) + tracers(n)=tracers_default(i) + if(trim(tracers(n)) .eq. "o3mr") o3n = n + + tracers_input_oct10(n) = trac_names_oct10(i) + tracers_input_oct11(n) = trac_names_oct11(i) + + enddo + +!--------------------------------------------------------------------------- +! Initialize esmf atmospheric fields. +!--------------------------------------------------------------------------- + + call init_atm_esmf_fields + + if (localpet == 0) then + allocate(dummy2d(i_input,j_input)) + allocate(dummy2d_8(i_input,j_input)) + allocate(dummy3d(i_input,j_input,lev_input)) + allocate(dum2d_1(i_input,j_input)) + else + allocate(dummy2d(0,0)) + allocate(dummy2d_8(0,0)) + allocate(dummy3d(0,0,0)) + allocate(dum2d_1(0,0)) + endif + +!---------------------------------------------------------------------------------- +! This program expects field levels from bottom to top. Fields in non-native +! files read in from top to bottom. We will flip indices later. Fields on +! native vertical coordinates read from bottom to top so those need no adjustments. +!---------------------------------------------------------------------------------- + + if (localpet == 0) then + + print*,"- READ TEMPERATURE." + + jdisc = 0 ! search for discipline - meteorological products + j = 0 ! search at beginning of file. + jpdt = -9999 ! array of values in product definition template, set to wildcard + jids = -9999 ! array of values in identification section, set to wildcard + jgdt = -9999 ! array of values in grid definition template, set to wildcard + jgdtn = -1 ! search for any grid definition number. + jpdtn = pdt_num ! Search for specific product definition template number. + jpdt(1) = 0 ! Sect 4/oct 10 - parameter category - temperature + jpdt(2) = 0 ! Sect 4/oct 11 - parameter number - temperature + jpdt(10) = octet_23 ! Sect4/oct 23 - type of level. + + unpack=.true. + + do vlev = 1, lev_input + + jpdt(12) = nint(rlevs(vlev)) + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + if (iret /= 0) then + call error_handler("READING IN TEMPERATURE AT LEVEL "//trim(slevs(vlev)),iret) + endif + + dum2d_1 = reshape(gfld%fld, (/i_input,j_input/) ) + + dummy3d(:,:,vlev) = dum2d_1 + + enddo + + endif ! Read of temperature + + if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." + call ESMF_FieldScatter(temp_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Read tracers + + do n = 1, num_tracers_input + + if (localpet == 0) print*,"- READ ", trim(tracers_input_vmap(n)) + + vname = tracers_input_vmap(n) + call get_var_cond(vname,this_miss_var_method=method, this_miss_var_value=value, & + this_field_var_name=tmpstr,loc=varnum) + + if (n==1 .and. .not. hasspfh) then + print*,"- CALL FieldGather TEMPERATURE." + call ESMF_FieldGather(temp_input_grid,dummy3d,rootPet=0, tile=1, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + endif + + if (localpet == 0) then + + jdisc = 0 ! search for discipline - meteorological products + jpdt = -9999 ! array of values in product definition template, set to wildcard + jids = -9999 ! array of values in identification section, set to wildcard + jgdt = -9999 ! array of values in grid definition template, set to wildcard + jgdtn = -1 ! search for any grid definition number. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt(10) = octet_23 ! Sect4/oct 23 - type of level. + unpack = .false. + + count = 0 + + do vlev = 1, lev_input + + j = 0 + jpdt(1) = tracers_input_oct10(n) + jpdt(2) = tracers_input_oct11(n) + jpdt(12) = nint(rlevs(vlev)) + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret == 0) then + count = count + 1 + endif + + enddo + iret=count + + ! Check to see if file has any data for this tracer + if (iret == 0) then + all_empty = .true. + else + all_empty = .false. + endif + + is_missing = .false. + + do vlev = 1, lev_input + + unpack=.true. + j = 0 + jpdt(1) = tracers_input_oct10(n) + jpdt(2) = tracers_input_oct11(n) + jpdt(12) = nint(rlevs(vlev) ) + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret == 0) then ! found data + dummy2d = real((reshape(gfld%fld, (/i_input,j_input/) )), kind=esmf_kind_r4) + else ! did not find data. + if (trim(method) .eq. 'intrp' .and. .not.all_empty) then + dummy2d = intrp_missing + is_missing = .true. + else + ! Abort if input data has some data for current tracer, but has + ! missing data below 200 mb/ above 400mb + if (.not.all_empty .and. n == o3n) then + if (rlevs(vlev) .lt. lev_no_o3_fill) & + call error_handler("TRACER "//trim(tracers(n))//" HAS MISSING DATA AT "//trim(slevs(vlev))//& + ". SET MISSING VARIABLE CONDITION TO 'INTRP' TO AVOID THIS ERROR", 1) + elseif (.not.all_empty .and. n .ne. o3n) then + if (rlevs(vlev) .gt. lev_no_tr_fill) & + call error_handler("TRACER "//trim(tracers(n))//" HAS MISSING DATA AT "//trim(slevs(vlev))//& + ". SET MISSING VARIABLE CONDITION TO 'INTRP' TO AVOID THIS ERROR.", 1) + endif + ! If entire array is empty and method is set to intrp, switch method to fill + if (trim(method) .eq. 'intrp' .and. all_empty) method='set_to_fill' + + call handle_grib_error(vname, slevs(vlev),method,value,varnum,read_from_input,iret,var=dummy2d) + if (iret==1) then ! missing_var_method == skip or no entry + if ( (tracers_input_oct10(n) == 1 .and. tracers_input_oct11(n) == 0) .or. & ! spec humidity + (tracers_input_oct10(n) == 1 .and. tracers_input_oct11(n) == 1) .or. & ! rel humidity + (tracers_input_oct10(n) == 14 .and. tracers_input_oct11(n) == 192) ) then ! ozone + call error_handler("READING IN "//trim(tracers(n))//" AT LEVEL "//trim(slevs(vlev))& + //". SET A FILL VALUE IN THE VARMAP TABLE IF THIS ERROR IS NOT DESIRABLE.",iret) + endif + endif + endif ! method intrp + endif !iret<=0 + + if (n==1 .and. .not. hasspfh) then + if (trim(external_model) .eq. 'GFS') then + print *,'- CALL CALRH GFS' + call rh2spfh_gfs(dummy2d,rlevs(vlev),dummy3d(:,:,vlev)) + else + print *,'- CALL CALRH non-GFS' + call rh2spfh(dummy2d,rlevs(vlev),dummy3d(:,:,vlev)) + end if + endif + + dummy3d(:,:,vlev) = real(dummy2d,esmf_kind_r8) + + enddo !vlev + +! Jili Dong interpolation for missing levels + if (is_missing .and. trim(method) .eq. 'intrp') then + print *,'- INTERPOLATE TRACER '//trim(tracers(n)) + done_print = 0 + do jj = 1, j_input + do ii = 1, i_input + dummy3d_col_in=dummy3d(ii,jj,:) + call dint2p(rlevs,dummy3d_col_in,lev_input,rlevs,dummy3d_col_out, & + lev_input, 2, intrp_missing, intrp_ier) + if (intrp_ier .gt. 0) call error_handler("Interpolation failed.",intrp_ier) + dummy3d(ii,jj,:)=dummy3d_col_out + enddo + enddo + do vlev=1,lev_input + dummy2d = real(dummy3d(:,:,n) , kind=esmf_kind_r4) + if (any(dummy2d .eq. intrp_missing)) then + ! If we're outside the appropriate region, don't fill but error instead + if (n == o3n .and. rlevs(vlev) .lt. lev_no_o3_fill) then + call error_handler("TRACER "//trim(tracers(n))//" HAS MISSING DATA AT "//trim(slevs(vlev)),1) + elseif (n .ne. o3n .and. rlevs(vlev) .gt. lev_no_tr_fill) then + call error_handler("TRACER "//trim(tracers(n))//" HAS MISSING DATA AT "//trim(slevs(vlev)),1) + else ! we're okay to fill missing data with provided fill value + if (done_print .eq. 0) then + print*, "Pressure out of range of existing data. Defaulting to fill value." + done_print = 1 + end if !done print + where(dummy2d .eq. intrp_missing) dummy2d = value + dummy3d(:,:,vlev) = dummy2d + end if !n & lev + endif ! intrp_missing + ! zero out negative tracers from interpolation/extrapolation + where(dummy3d(:,:,vlev) .lt. 0.0) dummy3d(:,:,vlev) = 0.0 +! print*,'tracer af intrp',vlev, maxval(dummy3d(:,:,vlev)),minval(dummy3d(:,:,vlev)) + end do !nlevs do + end if !if intrp + endif !localpet == 0 + + if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT ", trim(tracers_input_vmap(n)) + call ESMF_FieldScatter(tracers_input_grid(n), dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + enddo + + deallocate(dummy3d_col_in, dummy3d_col_out) + + call read_winds(u_tmp_3d,v_tmp_3d,localpet,octet_23,rlevs,lugb,pdt_num) + + if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT U-WIND." + call ESMF_FieldScatter(u_input_grid, u_tmp_3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT V-WIND." + call ESMF_FieldScatter(v_input_grid, v_tmp_3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ SURFACE PRESSURE." + jdisc = 0 ! search for discipline - meteorological products + j = 0 ! search at beginning of file. + jpdt = -9999 ! array of values in product definition template, set to wildcard + jids = -9999 ! array of values in identification section, set to wildcard + jgdt = -9999 ! array of values in grid definition template, set to wildcard + jgdtn = -1 ! search for any grid definition number. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt(1) = 3 ! Sect4/oct 10 - param category - mass + jpdt(2) = 0 ! Sect4/oct 11 - param number - pressure + jpdt(10) = 1 ! Sect4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + if (iret /= 0) call error_handler("READING SURFACE PRESSURE RECORD.", iret) + + dummy2d_8 = reshape(gfld%fld, (/i_input,j_input/) ) + + endif ! Read surface pressure + + if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT GRID SURFACE PRESSURE." + call ESMF_FieldScatter(ps_input_grid, dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Read dzdt. + + if (localpet == 0) then + + print*,"- READ DZDT." + vname = "dzdt" + call get_var_cond(vname,this_miss_var_method=method, this_miss_var_value=value, & + loc=varnum) + + jdisc = 0 ! search for discipline - meteorological products + j = 0 ! search at beginning of file. + jpdt = -9999 ! array of values in product definition template, set to wildcard + jids = -9999 ! array of values in identification section, set to wildcard + jgdt = -9999 ! array of values in grid definition template, set to wildcard + jgdtn = -1 ! search for any grid definition number. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt(1) = 2 ! Sect4/oct 10 - param category - momentum + jpdt(2) = 9 ! Sect4/oct 11 - param number - dzdt + jpdt(10) = octet_23 ! Sect4/oct 23 - type of level + + unpack=.true. + + do vlev = 1, lev_input + + jpdt(12) = nint(rlevs(vlev)) + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret /= 0) then ! dzdt not found, look for omega. + print*,"DZDT not available at level ", trim(slevs(vlev)), " so checking for VVEL" + jpdt(2) = 8 ! Sect4/oct 11 - parameter number - omega + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + if (iret /= 0) then + call handle_grib_error(vname, slevs(vlev),method,value,varnum,read_from_input,iret,var8=dum2d_1) + if (iret==1) then ! missing_var_method == skip + cycle + endif + else + conv_omega = .true. + dum2d_1 = reshape(gfld%fld, (/i_input,j_input/) ) + endif + else ! found dzdt + dum2d_1 = reshape(gfld%fld, (/i_input,j_input/) ) + endif + + dummy3d(:,:,vlev) = dum2d_1 + + enddo + + endif ! Read of dzdt + + call mpi_bcast(conv_omega,1,MPI_LOGICAL,0,MPI_COMM_WORLD,rc) + + if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT DZDT." + call ESMF_FieldScatter(dzdt_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Read terrain + + if (localpet == 0) then + + print*,"- READ TERRAIN." + jdisc = 0 ! search for discipline - meteorological products + j = 0 ! search at beginning of file. + jpdt = -9999 ! array of values in product definition template, set to wildcard + jids = -9999 ! array of values in identification section, set to wildcard + jgdt = -9999 ! array of values in grid definition template, set to wildcard + jgdtn = -1 ! search for any grid definition number. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt(1) = 3 ! Sect4/oct 10 - param category - mass + jpdt(2) = 5 ! Sect4/oct 11 - param number - geopotential height + jpdt(10) = 1 ! Sect4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + if (iret /= 0) call error_handler("READING TERRAIN HEIGHT RECORD.", iret) + + dummy2d_8 = reshape(gfld%fld, (/i_input,j_input/) ) + + endif ! read of terrain. + + if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT GRID TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + deallocate(dummy2d, dummy2d_8) + +if (.not. isnative) then + + !--------------------------------------------------------------------------- + ! Flip 'z' indices to all 3-d variables. Data is read in from model + ! top to surface. This program expects surface to model top. + !--------------------------------------------------------------------------- + + if (localpet == 0) print*,"- CALL FieldGet FOR SURFACE PRESSURE." + nullify(psptr) + call ESMF_FieldGet(ps_input_grid, & + farrayPtr=psptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + nullify(presptr) + if (localpet == 0) print*,"- CALL FieldGet FOR 3-D PRESSURE." + call ESMF_FieldGet(pres_input_grid, & + computationalLBound=clb, & + computationalUBound=cub, & + farrayPtr=presptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + nullify(tptr) + if (localpet == 0) print*,"- CALL FieldGet TEMPERATURE." + call ESMF_FieldGet(temp_input_grid, & + farrayPtr=tptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + nullify(uptr) + if (localpet == 0) print*,"- CALL FieldGet FOR U" + call ESMF_FieldGet(u_input_grid, & + farrayPtr=uptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + nullify(vptr) + if (localpet == 0) print*,"- CALL FieldGet FOR V" + call ESMF_FieldGet(v_input_grid, & + farrayPtr=vptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + nullify(wptr) + if (localpet == 0) print*,"- CALL FieldGet FOR W" + call ESMF_FieldGet(dzdt_input_grid, & + farrayPtr=wptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + if (localpet == 0) print*,"- CALL FieldGet FOR TRACERS." + do n=1,num_tracers_input + nullify(qptr) + call ESMF_FieldGet(tracers_input_grid(n), & + farrayPtr=qptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + do i = clb(1),cub(1) + do j = clb(2),cub(2) + qptr(i,j,:) = qptr(i,j,lev_input:1:-1) + end do + end do + end do + + do i = clb(1),cub(1) + do j = clb(2),cub(2) + presptr(i,j,:) = rlevs(lev_input:1:-1) + tptr(i,j,:) = tptr(i,j,lev_input:1:-1) + uptr(i,j,:) = uptr(i,j,lev_input:1:-1) + vptr(i,j,:) = vptr(i,j,lev_input:1:-1) + wptr(i,j,:) = wptr(i,j,lev_input:1:-1) + end do + end do + + if (localpet == 0) then + print*,'psfc is ',clb(1),clb(2),psptr(clb(1),clb(2)) + print*,'pres is ',cub(1),cub(2),presptr(cub(1),cub(2),:) + + print*,'pres check 1',localpet,maxval(presptr(clb(1):cub(1),clb(2):cub(2),1)), & + minval(presptr(clb(1):cub(1),clb(2):cub(2),1)) + print*,'pres check lev',localpet,maxval(presptr(clb(1):cub(1),clb(2):cub(2), & + lev_input)),minval(presptr(clb(1):cub(1),clb(2):cub(2),lev_input)) + endif + +else ! is native coordinate (hybrid). + +! For native files, read in pressure field directly from file but don't flip levels + + if (localpet == 0) then + + print*,"- READ PRESSURE." + + jdisc = 0 ! search for discipline - meteorological products + j = 0 ! search at beginning of file. + jpdt = -9999 ! array of values in product definition template, set to wildcard + jids = -9999 ! array of values in identification section, set to wildcard + jgdt = -9999 ! array of values in grid definition template, set to wildcard + jgdtn = -1 ! search for any grid definition number. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt(1) = 3 ! Sect4/oct 10 - parameter category - mass + jpdt(2) = 0 ! Sect4/oct 11 - parameter number - pressure + jpdt(10) = octet_23 ! Sect4/oct 23 - type of level. + unpack=.true. + + do vlev = 1, lev_input + + jpdt(12) = nint(rlevs(vlev)) + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + if (iret /= 0) then + call error_handler("READING IN PRESSURE AT LEVEL "//trim(slevs(vlev)),iret) + endif + + dum2d_1 = reshape(gfld%fld, (/i_input,j_input/) ) + + dummy3d(:,:,vlev) = dum2d_1 + + enddo + + endif ! localpet == 0 + + if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT GRID PRESSURE." + call ESMF_FieldScatter(pres_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + endif + + deallocate(dummy3d, dum2d_1) + +!--------------------------------------------------------------------------- +! Convert from 2-d to 3-d component winds. +!--------------------------------------------------------------------------- + + call convert_winds + +!--------------------------------------------------------------------------- +! Convert dpdt to dzdt if needed +!--------------------------------------------------------------------------- + + if (conv_omega) then + + if (localpet == 0) print*,"- CONVERT FROM OMEGA TO DZDT." + + nullify(tptr) + if (localpet == 0) print*,"- CALL FieldGet TEMPERATURE." + call ESMF_FieldGet(temp_input_grid, & + farrayPtr=tptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + nullify(qptr) + if (localpet == 0) print*,"- CALL FieldGet SPECIFIC HUMIDITY." + call ESMF_FieldGet(tracers_input_grid(1), & + computationalLBound=clb, & + computationalUBound=cub, & + farrayPtr=qptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + nullify(wptr) + if (localpet == 0) print*,"- CALL FieldGet DZDT." + call ESMF_FieldGet(dzdt_input_grid, & + computationalLBound=clb, & + computationalUBound=cub, & + farrayPtr=wptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + nullify(presptr) + call ESMF_FieldGet(pres_input_grid, & + farrayPtr=presptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + call convert_omega(wptr,presptr,tptr,qptr,clb,cub) + + endif + + if (localpet == 0) call baclose(lugb, rc) + + end subroutine read_input_atm_grib2_file + + !> Read winds from a grib2 file. Rotate winds +!! to be earth relative if necessary. +!! +!! @param [inout] u u-component wind +!! @param [inout] v v-component wind +!! @param[in] localpet ESMF local persistent execution thread +!! @param[in] octet_23 Section 4/Octet 23 - Type of first fixed surface. +!! @param[in] rlevs Array of atmospheric level values +!! @param[in] lugb Logical unit number of GRIB2 file. +!! @param[in] pdt_num Product definition template number. +!! @author Larissa Reames + subroutine read_winds(u,v,localpet,octet_23,rlevs,lugb,pdt_num) + + use grib_mod + use program_setup, only : get_var_cond + + implicit none + + integer, intent(in) :: localpet, lugb + integer, intent(in) :: pdt_num, octet_23 + + real(esmf_kind_r8), intent(inout), allocatable :: u(:,:,:),v(:,:,:) + real(esmf_kind_r8), intent(in), dimension(lev_input) :: rlevs + + real(esmf_kind_r4), dimension(i_input,j_input) :: alpha + real(esmf_kind_r8), dimension(i_input,j_input) :: lon, lat + real(esmf_kind_r4), allocatable :: u_tmp(:,:),v_tmp(:,:) + real(esmf_kind_r8), allocatable :: dum2d(:,:) + real(esmf_kind_r4), dimension(i_input,j_input) :: ws,wd + real(esmf_kind_r4) :: value_u, value_v,lov,latin1,latin2 + real(esmf_kind_r8) :: d2r + + integer :: varnum_u, varnum_v, vlev, & + error, iret + integer :: j, k, lugi, jgdtn, jpdtn + integer :: jdisc, jids(200), jgdt(200), jpdt(200) + + character(len=20) :: vname + character(len=50) :: method_u, method_v + + logical :: unpack + + type(gribfield) :: gfld + + d2r=acos(-1.0_esmf_kind_r8) / 180.0_esmf_kind_r8 + if (localpet==0) then + allocate(u(i_input,j_input,lev_input)) + allocate(v(i_input,j_input,lev_input)) + else + allocate(u(0,0,0)) + allocate(v(0,0,0)) + endif + + vname = "u" + call get_var_cond(vname,this_miss_var_method=method_u, this_miss_var_value=value_u, & + loc=varnum_u) + vname = "v" + call get_var_cond(vname,this_miss_var_method=method_v, this_miss_var_value=value_v, & + loc=varnum_v) + + print*,"- CALL FieldGather FOR INPUT GRID LONGITUDE" + call ESMF_FieldGather(longitude_input_grid, lon, rootPet=0, tile=1, rc=error) + if(ESMF_logFoundError(rcToCheck=error,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGather", error) + + print*,"- CALL FieldGather FOR INPUT GRID LATITUDE" + call ESMF_FieldGather(latitude_input_grid, lat, rootPet=0, tile=1, rc=error) + if(ESMF_logFoundError(rcToCheck=error,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGather", error) + + if (localpet==0) then + + lugi = 0 ! index file unit number + jdisc = 0 ! search for discipline - meteorological products + j = 0 ! search at beginning of file. + jpdt = -9999 ! array of values in product definition template, set to wildcard + jids = -9999 ! array of values in identification section, set to wildcard + jgdt = -9999 ! array of values in grid definition template, set to wildcard + jgdtn = -1 ! search for any grid definition number. + jpdtn = pdt_num ! Search for the product definition template number. + unpack=.false. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret /= 0) call error_handler("ERROR READING GRIB2 FILE.", iret) + + if (gfld%igdtnum == 32769) then ! grid definition template number - rotated lat/lon grid + + latin1 = real(float(gfld%igdtmpl(15))/1.0E6, kind=esmf_kind_r4) + lov = real(float(gfld%igdtmpl(16))/1.0E6, kind=esmf_kind_r4) + + print*, "- CALL CALCALPHA_ROTLATLON with center lat,lon = ",latin1,lov + call calcalpha_rotlatlon(lat,lon,latin1,lov,alpha) + + elseif (gfld%igdtnum == 30) then ! grid definition template number - lambert conformal grid. + + lov = real(float(gfld%igdtmpl(14))/1.0E6, kind=esmf_kind_r4) + latin1 = real(float(gfld%igdtmpl(19))/1.0E6, kind=esmf_kind_r4) + latin2 = real(float(gfld%igdtmpl(20))/1.0E6, kind=esmf_kind_r4) + + print*, "- CALL GRIDROT for LC grid with lov,latin1/2 = ",lov,latin1,latin2 + call gridrot(lov,latin1,latin2,lon,alpha) + + endif + + jpdt(10) = octet_23 ! Sec4/oct 23 - type of level. + + unpack=.true. + + allocate(dum2d(i_input,j_input)) + allocate(u_tmp(i_input,j_input)) + allocate(v_tmp(i_input,j_input)) + + do vlev = 1, lev_input + + vname = ":UGRD:" + + jpdt(1) = 2 ! Sec4/oct 10 - parameter category - momentum + jpdt(2) = 2 ! Sec4/oct 11 - parameter number - u-wind + jpdt(12) = nint(rlevs(vlev)) ! Sect4/octs 25-28 - scaled value of fixed surface. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret /= 0) then + call handle_grib_error(vname, slevs(vlev),method_u,value_u,varnum_u,read_from_input,iret,var=u_tmp) + if (iret==1) then ! missing_var_method == skip + call error_handler("READING IN U AT LEVEL "//trim(slevs(vlev))//". SET A FILL "// & + "VALUE IN THE VARMAP TABLE IF THIS ERROR IS NOT DESIRABLE.",iret) + endif + else + dum2d = reshape(gfld%fld, (/i_input,j_input/) ) + u_tmp(:,:) = real(dum2d, kind=esmf_kind_r4) + endif + + vname = ":VGRD:" + + jpdt(2) = 3 ! Sec4/oct 11 - parameter number - v-wind + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, iret) + + if (iret /= 0) then + call handle_grib_error(vname, slevs(vlev),method_v,value_v,varnum_v,read_from_input,iret,var=v_tmp) + if (iret==1) then ! missing_var_method == skip + call error_handler("READING IN V AT LEVEL "//trim(slevs(vlev))//". SET A FILL "// & + "VALUE IN THE VARMAP TABLE IF THIS ERROR IS NOT DESIRABLE.",iret) + endif + else + dum2d = reshape(gfld%fld, (/i_input,j_input/) ) + v_tmp(:,:) = real(dum2d, kind=esmf_kind_r4) + endif + + deallocate(dum2d) + + if (gfld%igdtnum == 0) then ! grid definition template number - lat/lon grid + if (external_model == 'UKMET') then + u(:,:,vlev) = u_tmp + v(:,:,vlev) = (v_tmp(:,2:jp1_input) + v_tmp(:,1:j_input))/2 + else + u(:,:,vlev) = u_tmp + v(:,:,vlev) = v_tmp + endif + else if (gfld%igdtnum == 32769) then ! grid definition template number - rotated lat/lon grid + ws = sqrt(u_tmp**2 + v_tmp**2) + wd = real((atan2(-u_tmp,-v_tmp) / d2r), kind=esmf_kind_r4) ! calculate grid-relative wind direction + wd = real((wd + alpha + 180.0), kind=esmf_kind_r4) ! Rotate from grid- to earth-relative direction + wd = real((270.0 - wd), kind=esmf_kind_r4) ! Convert from meteorological (true N) to mathematical direction + u(:,:,vlev) = -ws*cos(wd*d2r) + v(:,:,vlev) = -ws*sin(wd*d2r) + else + u(:,:,vlev) = real(u_tmp * cos(alpha) + v_tmp * sin(alpha),esmf_kind_r8) + v(:,:,vlev) = real(v_tmp * cos(alpha) - u_tmp * sin(alpha),esmf_kind_r8) + endif + + print*, 'max, min U ', minval(u(:,:,vlev)), maxval(u(:,:,vlev)) + print*, 'max, min V ', minval(v(:,:,vlev)), maxval(v(:,:,vlev)) + enddo + endif + +end subroutine read_winds + +!> Convert winds from 2-d to 3-d components. +!! +!! @author George Gayno NCEP/EMC + subroutine convert_winds + + implicit none + + integer :: clb(4), cub(4) + integer :: i, j, k, rc + + real(esmf_kind_r8) :: latrad, lonrad + real(esmf_kind_r8), pointer :: windptr(:,:,:,:) + real(esmf_kind_r8), pointer :: uptr(:,:,:) + real(esmf_kind_r8), pointer :: vptr(:,:,:) + real(esmf_kind_r8), pointer :: latptr(:,:) + real(esmf_kind_r8), pointer :: lonptr(:,:) + + print*,"- CALL FieldGet FOR 3-D WIND." + call ESMF_FieldGet(wind_input_grid, & + computationalLBound=clb, & + computationalUBound=cub, & + farrayPtr=windptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR U." + call ESMF_FieldGet(u_input_grid, & + farrayPtr=uptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR V." + call ESMF_FieldGet(v_input_grid, & + farrayPtr=vptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR LATITUDE." + call ESMF_FieldGet(latitude_input_grid, & + farrayPtr=latptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + print*,"- CALL FieldGet FOR LONGITUDE." + call ESMF_FieldGet(longitude_input_grid, & + farrayPtr=lonptr, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGet", rc) + + do i = clb(1), cub(1) + do j = clb(2), cub(2) + latrad = latptr(i,j) * acos(-1.) / 180.0 + lonrad = lonptr(i,j) * acos(-1.) / 180.0 + do k = clb(3), cub(3) + windptr(i,j,k,1) = uptr(i,j,k) * cos(lonrad) - vptr(i,j,k) * sin(latrad) * sin(lonrad) + windptr(i,j,k,2) = uptr(i,j,k) * sin(lonrad) + vptr(i,j,k) * sin(latrad) * cos(lonrad) + windptr(i,j,k,3) = vptr(i,j,k) * cos(latrad) + enddo + enddo + enddo + + call ESMF_FieldDestroy(u_input_grid, rc=rc) + call ESMF_FieldDestroy(v_input_grid, rc=rc) + + end subroutine convert_winds + +!> Compute grid rotation angle for non-latlon grids. +!! +!! @note The original gridrot subroutine was specific to polar +!! stereographic grids. We need to compute it for Lambert Conformal +!! grids. So we need lat1,lat2. This follows the ncl_ncarg source +!! code: ncl_ncarg-6.6.2/ni/src/ncl/GetGrids.c +!! +!! @param [in] lov orientation angle +!! @param [in] latin1 first tangent latitude +!! @param [in] latin2 second tangent latitude +!! @param [in] lon longitude +!! @param [inout] rot rotation angle +!! @author Larissa Reames +subroutine gridrot(lov,latin1,latin2,lon,rot) + + use model_grid, only : i_input,j_input + implicit none + + + real(esmf_kind_r4), intent(in) :: lov,latin1,latin2 + real(esmf_kind_r4), intent(inout) :: rot(i_input,j_input) + real(esmf_kind_r8), intent(in) :: lon(i_input,j_input) + + real(esmf_kind_r4) :: trot(i_input,j_input), tlon(i_input,j_input) + real(esmf_kind_r4) :: dtor = 3.14159265359_esmf_kind_r4/180.0_esmf_kind_r4 + real(esmf_kind_r4) :: an + !trot_tmp = real(lon,esmf_kind_r4)-lov + !trot = trot_tmp + !where(trot_tmp > 180.0) trot = trot-360.0_esmf_kind_r4 + !where(trot_tmp < -180.0) trot = trot-360.0_esmf_kind_r4 + + if ( (latin1 - latin2) .lt. 0.000001 ) then + an = sin(latin1*dtor) + else + an = real(log( cos(latin1*dtor) / cos(latin2*dtor) ) / & + log( tan(dtor*(90.0-latin1)/2.) / tan(dtor*(90.0-latin2)/2.)), kind=esmf_kind_r4) + end if + + tlon = real((mod(lon - lov + 180. + 3600., 360.) - 180.), kind=esmf_kind_r4) + trot = an * tlon + + rot = trot * dtor + +end subroutine gridrot + +!> Calculate rotation angle for rotated latlon grids. +!! Needed to convert to earth-relative winds. +!! +!! @param [in] latgrid grid latitudes +!! @param [in] longrid grid longitudes +!! @param [in] cenlat center latitude +!! @param [in] cenlon center longitude +!! @param [out] alpha grid rotation angle +!! @author Larissa Reames +subroutine calcalpha_rotlatlon(latgrid,longrid,cenlat,cenlon,alpha) + + use model_grid, only : i_input,j_input + implicit none + + real(esmf_kind_r8), intent(in) :: latgrid(i_input,j_input), & + longrid(i_input,j_input) + real(esmf_kind_r4), intent(in) :: cenlat, cenlon + real(esmf_kind_r4), intent(out) :: alpha(i_input,j_input) + + ! Variables local to subroutine + real(esmf_kind_r8) :: D2R,lon0_r,lat0_r,sphi0,cphi0 + real(esmf_kind_r8), DIMENSION(i_input,j_input) :: tlat,tlon,tph,sinalpha + + D2R = acos(-1.0_esmf_kind_r8) / 180.0_esmf_kind_r8 + if (cenlon .lt. 0) then + lon0_r = (cenlon + 360.0)*D2R + else + lon0_r = cenlon*D2R + end if + lat0_r=cenlat*D2R + sphi0=sin(lat0_r) + cphi0=cos(lat0_r) + + ! deal with input lat/lon + tlat = latgrid * D2R + tlon = longrid * D2R + + ! Calculate alpha (rotation angle) + tlon = -tlon + lon0_r + tph = asin(cphi0*sin(tlat) - sphi0*cos(tlat)*cos(tlon)) + sinalpha = sphi0 * sin(tlon) / cos(tph) + alpha = real((-asin(sinalpha)/D2R), kind=esmf_kind_r4) + ! returns alpha in degrees +end subroutine calcalpha_rotlatlon + +!> Free up memory associated with atm data. +!! +!! @author George Gayno NCEP/EMC +subroutine cleanup_input_atm_data + + implicit none + + integer :: rc, n + + print*,'- DESTROY ATMOSPHERIC INPUT DATA.' + + call ESMF_FieldDestroy(terrain_input_grid, rc=rc) + call ESMF_FieldDestroy(pres_input_grid, rc=rc) + call ESMF_FieldDestroy(dzdt_input_grid, rc=rc) + call ESMF_FieldDestroy(temp_input_grid, rc=rc) + call ESMF_FieldDestroy(wind_input_grid, rc=rc) + call ESMF_FieldDestroy(ps_input_grid, rc=rc) + + do n = 1, num_tracers_input + call ESMF_FieldDestroy(tracers_input_grid(n), rc=rc) + enddo + deallocate(tracers_input_grid) + + end subroutine cleanup_input_atm_data + +end module atm_input_data diff --git a/sorc/chgres_cube.fd/atmosphere.F90 b/sorc/chgres_cube.fd/atmosphere.F90 index 12d117fd4..46be52c90 100644 --- a/sorc/chgres_cube.fd/atmosphere.F90 +++ b/sorc/chgres_cube.fd/atmosphere.F90 @@ -29,7 +29,7 @@ module atmosphere zh_target_grid, qnwfa_climo_target_grid, & qnifa_climo_target_grid - use input_data, only : lev_input, & + use atm_input_data, only : lev_input, & levp1_input, & tracers_input_grid, & dzdt_input_grid, & @@ -69,6 +69,7 @@ module atmosphere write_fv3_atm_bndy_data_netcdf, & write_fv3_atm_data_netcdf + use utilities, only : error_handler implicit none private diff --git a/sorc/chgres_cube.fd/chgres.F90 b/sorc/chgres_cube.fd/chgres.F90 index faf7a0d23..8b01656f2 100644 --- a/sorc/chgres_cube.fd/chgres.F90 +++ b/sorc/chgres_cube.fd/chgres.F90 @@ -39,6 +39,7 @@ program chgres use surface, only : surface_driver + use utilities, only : error_handler implicit none integer :: ierr, localpet, npets diff --git a/sorc/chgres_cube.fd/grib2_util.F90 b/sorc/chgres_cube.fd/grib2_util.F90 index 7bd6e7c78..92479e840 100644 --- a/sorc/chgres_cube.fd/grib2_util.F90 +++ b/sorc/chgres_cube.fd/grib2_util.F90 @@ -56,7 +56,7 @@ subroutine rh2spfh(rh_sphum,p,t) !print *, 'es = ', es e = rh * es / 100.0 !print *, 'e = ', e - rh_sphum = 0.622 * e / p + rh_sphum = real((0.622 * e / p),kind=esmf_kind_r4) !print *, 'q = ', sphum !if (P .eq. 100000.0) THEN @@ -110,7 +110,7 @@ subroutine rh2spfh_gfs(rh_sphum,p,t) do i=1,i_input ES = MIN(FPVSNEW(T(I,J)),P) QC(i,j) = CON_EPS*ES/(P+CON_EPSM1*ES) - rh_sphum(i,j) = rh(i,j)*QC(i,j)/100.0 + rh_sphum(i,j) = real((rh(i,j)*QC(i,j)/100.0),kind=esmf_kind_r4) end do end do @@ -169,7 +169,7 @@ elemental function fpvsnew(t) c1xpvs=1.-xmin*c2xpvs ! xj=min(max(c1xpvs+c2xpvs*t,1.0),real(nxpvs,krealfp)) xj=min(max(c1xpvs+c2xpvs*t,1.0),float(nxpvs)) - jx=min(xj,float(nxpvs)-1.0) + jx=int(min(xj,float(nxpvs)-1.0)) x=xmin+(jx-1)*xinc tr=con_ttp/x diff --git a/sorc/chgres_cube.fd/input_data.F90 b/sorc/chgres_cube.fd/input_data.F90 deleted file mode 100644 index 193d295de..000000000 --- a/sorc/chgres_cube.fd/input_data.F90 +++ /dev/null @@ -1,7730 +0,0 @@ -!> @file -!! @brief Read atmospheric and surface data from GRIB2, NEMSIO and NetCDF files. -!! @author George Gayno NCEP/EMC - -!> Read atmospheric, surface and nst data on the input grid. -!! Supported formats include fv3 tiled 'restart' files, fv3 tiled -!! 'history' files, fv3 gaussian history files, spectral gfs -!! gaussian nemsio files, and spectral gfs sigio/sfcio files. -!! -!! Public variables are defined below: "input" indicates field -!! associated with the input grid. -!! -!! @author George Gayno NCEP/EMC - module input_data - - use esmf - use netcdf - use nemsio_module - - use program_setup, only : data_dir_input_grid, & - nst_files_input_grid, & - sfc_files_input_grid, & - atm_files_input_grid, & - grib2_file_input_grid, & - atm_core_files_input_grid, & - atm_tracer_files_input_grid, & - convert_nst, & - orog_dir_input_grid, & - orog_files_input_grid, & - tracers_input, num_tracers_input, & - input_type, tracers, & - get_var_cond, read_from_input, & - geogrid_file_input_grid, & - external_model, & - vgfrc_from_climo, & - minmax_vgfrc_from_climo, & - lai_from_climo - - use model_grid, only : input_grid, & - i_input, j_input, & - ip1_input, jp1_input, & - num_tiles_input_grid, & - latitude_input_grid, & - longitude_input_grid - - implicit none - - private - -! Fields associated with the atmospheric model. - - type(esmf_field), public :: dzdt_input_grid !< vert velocity - type(esmf_field) :: dpres_input_grid !< pressure thickness - type(esmf_field), public :: pres_input_grid !< 3-d pressure - type(esmf_field), public :: ps_input_grid !< surface pressure - type(esmf_field), public :: terrain_input_grid !< terrain height - type(esmf_field), public :: temp_input_grid !< temperature - - type(esmf_field), public :: u_input_grid !< u/v wind at grid - type(esmf_field), public :: v_input_grid !< box center - type(esmf_field), public :: wind_input_grid !< 3-component wind - type(esmf_field), allocatable, public :: tracers_input_grid(:) !< tracers - - integer, public :: lev_input !< number of atmospheric layers - integer, public :: levp1_input !< number of atmos layer interfaces - -! Fields associated with the land-surface model. - - integer, public :: veg_type_landice_input = 15 !< NOAH land ice option - !< defined at this veg type. - !< Default is igbp. - integer, parameter :: ICET_DEFAULT = 265.0 !< Default value of soil and skin - !< temperature (K) over ice. - type(esmf_field), public :: canopy_mc_input_grid !< canopy moist content - type(esmf_field), public :: f10m_input_grid !< log((z0+10)*1/z0) - type(esmf_field), public :: ffmm_input_grid !< log((z0+z1)*1/z0) - !! See sfc_diff.f for details. - type(esmf_field), public :: landsea_mask_input_grid !< land sea mask; - !! 0-water, 1-land, 2-ice - type(esmf_field), public :: q2m_input_grid !< 2-m spec hum - type(esmf_field), public :: seaice_depth_input_grid !< sea ice depth - type(esmf_field), public :: seaice_fract_input_grid !< sea ice fraction - type(esmf_field), public :: seaice_skin_temp_input_grid !< sea ice skin temp - type(esmf_field), public :: skin_temp_input_grid !< skin temp/sst - type(esmf_field), public :: snow_depth_input_grid !< snow dpeth - type(esmf_field), public :: snow_liq_equiv_input_grid !< snow liq equiv depth - type(esmf_field), public :: soil_temp_input_grid !< 3-d soil temp - type(esmf_field), public :: soil_type_input_grid !< soil type - type(esmf_field), public :: soilm_liq_input_grid !< 3-d liquid soil moisture - type(esmf_field), public :: soilm_tot_input_grid !< 3-d total soil moisture - type(esmf_field), public :: srflag_input_grid !< snow/rain flag - type(esmf_field), public :: t2m_input_grid !< 2-m temperature - type(esmf_field), public :: tprcp_input_grid !< precip - type(esmf_field), public :: ustar_input_grid !< fric velocity - type(esmf_field), public :: veg_type_input_grid !< vegetation type - type(esmf_field), public :: z0_input_grid !< roughness length - type(esmf_field), public :: veg_greenness_input_grid !< vegetation fraction - type(esmf_field), public :: lai_input_grid !< leaf area index - type(esmf_field), public :: max_veg_greenness_input_grid !< shdmax - type(esmf_field), public :: min_veg_greenness_input_grid !< shdmin - - integer, public :: lsoil_input=4 !< number of soil layers, no longer hardwired to allow - !! for 7 layers of soil for the RUC LSM - - character(len=50), private, allocatable :: slevs(:) !< The atmospheric levels in the GRIB2 input file. - -! Fields associated with the nst model. - - type(esmf_field), public :: c_d_input_grid !< Coefficient 2 to calculate d(tz)/d(ts) - type(esmf_field), public :: c_0_input_grid !< Coefficient 1 to calculate d(tz)/d(ts) - type(esmf_field), public :: d_conv_input_grid !< Thickness of free convection layer - type(esmf_field), public :: dt_cool_input_grid !< Sub-layer cooling amount - type(esmf_field), public :: ifd_input_grid !< Model mode index. 0-diurnal model not - !< started; 1-diurnal model started. - type(esmf_field), public :: qrain_input_grid !< Sensible heat flux due to rainfall - type(esmf_field), public :: tref_input_grid !< Reference temperature - type(esmf_field), public :: w_d_input_grid !< Coefficient 4 to calculate d(tz)/d(ts) - type(esmf_field), public :: w_0_input_grid !< Coefficient 3 to calculate d(tz)/d(ts) - type(esmf_field), public :: xs_input_grid !< Salinity content in diurnal thermocline layer - type(esmf_field), public :: xt_input_grid !< Heat content in diurnal thermocline layer - type(esmf_field), public :: xu_input_grid !< u-current content in diurnal thermocline layer - type(esmf_field), public :: xv_input_grid !< v-current content in diurnal thermocline layer - type(esmf_field), public :: xz_input_grid !< Diurnal thermocline layer thickness - type(esmf_field), public :: xtts_input_grid !< d(xt)/d(ts) - type(esmf_field), public :: xzts_input_grid !< d(xz)/d(ts) - type(esmf_field), public :: z_c_input_grid !< Sub-layer cooling thickness - type(esmf_field), public :: zm_input_grid !< Oceanic mixed layer depth - - public :: read_input_atm_data - public :: cleanup_input_atm_data - public :: read_input_sfc_data - public :: cleanup_input_sfc_data - public :: read_input_nst_data - public :: cleanup_input_nst_data - public :: check_soilt - public :: check_cnwat - public :: quicksort - public :: convert_winds - public :: init_sfc_esmf_fields - public :: dint2p - - contains - -!> Read input grid atmospheric data driver. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_atm_data(localpet) - - implicit none - - integer, intent(in) :: localpet - -!------------------------------------------------------------------------------- -! Read the tiled 'warm' restart files. -!------------------------------------------------------------------------------- - - if (trim(input_type) == "restart") then - - call read_input_atm_restart_file(localpet) - -!------------------------------------------------------------------------------- -! Read the gaussian history files in netcdf format. -!------------------------------------------------------------------------------- - - elseif (trim(input_type) == "gaussian_netcdf") then - - call read_input_atm_gaussian_netcdf_file(localpet) - -!------------------------------------------------------------------------------- -! Read the tiled history files in netcdf format. -!------------------------------------------------------------------------------- - - elseif (trim(input_type) == "history") then - - call read_input_atm_tiled_history_file(localpet) - -!------------------------------------------------------------------------------- -! Read the gaussian history files in nemsio format. -!------------------------------------------------------------------------------- - - elseif (trim(input_type) == "gaussian_nemsio") then ! fv3gfs gaussian nemsio - - call read_input_atm_gaussian_nemsio_file(localpet) - -!------------------------------------------------------------------------------- -! Read the spectral gfs gaussian history files in nemsio format. -!------------------------------------------------------------------------------- - - elseif (trim(input_type) == "gfs_gaussian_nemsio") then ! spectral gfs gaussian - ! nemsio. - call read_input_atm_gfs_gaussian_nemsio_file(localpet) - -!------------------------------------------------------------------------------- -! Read the spectral gfs gaussian history files in sigio format. -!------------------------------------------------------------------------------- - - elseif (trim(input_type) == "gfs_sigio") then ! spectral gfs sigio format. - - call read_input_atm_gfs_sigio_file(localpet) - -!------------------------------------------------------------------------------- -! Read fv3gfs data in grib2 format. -!------------------------------------------------------------------------------- - - elseif (trim(input_type) == "grib2") then - - call read_input_atm_grib2_file(localpet) - - endif - - end subroutine read_input_atm_data - -!> Driver to read input grid nst data. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_nst_data(localpet) - - implicit none - - integer, intent(in) :: localpet - - integer :: rc - - print*,"- READ INPUT GRID NST DATA." - - print*,"- CALL FieldCreate FOR INPUT GRID C_D." - c_d_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID C_0." - c_0_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID D_CONV." - d_conv_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID DT_COOL." - dt_cool_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID IFD." - ifd_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID QRAIN." - qrain_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID TREF." - tref_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID W_D." - w_d_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID W_0." - w_0_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID XS." - xs_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID XT." - xt_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID XU." - xu_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID XV." - xv_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID XZ." - xz_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID XTTS." - xtts_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID XZTS." - xzts_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID Z_C." - z_c_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID ZM." - zm_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - -!-------------------------------------------------------------------------- -! Read input grid nst data from a fv3 gaussian nemsio history file or -! spectral GFS nemsio file. -!-------------------------------------------------------------------------- - - if (trim(input_type) == "gaussian_nemsio" .or. trim(input_type) == "gfs_gaussian_nemsio") then - - call read_input_nst_nemsio_file(localpet) - -!--------------------------------------------------------------------------- -! Read nst data from these netcdf formatted fv3 files: tiled history, -! tiled warm restart, and gaussian history. -!--------------------------------------------------------------------------- - - else - - call read_input_nst_netcdf_file(localpet) - - endif - - end subroutine read_input_nst_data - -!> Driver to read input grid surface data. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_sfc_data(localpet) - - implicit none - - integer, intent(in) :: localpet - - call init_sfc_esmf_fields() - -!------------------------------------------------------------------------------- -! Read the tiled 'warm' restart files. -!------------------------------------------------------------------------------- - - if (trim(input_type) == "restart") then - - call read_input_sfc_restart_file(localpet) - -!------------------------------------------------------------------------------- -! Read the tiled or gaussian history files in netcdf format. -!------------------------------------------------------------------------------- - - elseif (trim(input_type) == "history" .or. trim(input_type) == & - "gaussian_netcdf") then - - call read_input_sfc_netcdf_file(localpet) - -!------------------------------------------------------------------------------- -! Read the gaussian history files in nemsio format. -!------------------------------------------------------------------------------- - - elseif (trim(input_type) == "gaussian_nemsio") then - - call read_input_sfc_gaussian_nemsio_file(localpet) - -!------------------------------------------------------------------------------- -! Read the spectral gfs gaussian history files in nemsio format. -!------------------------------------------------------------------------------- - - elseif (trim(input_type) == "gfs_gaussian_nemsio") then - - call read_input_sfc_gfs_gaussian_nemsio_file(localpet) - -!------------------------------------------------------------------------------- -! Read the spectral gfs gaussian history files in sfcio format. -!------------------------------------------------------------------------------- - - elseif (trim(input_type) == "gfs_sigio") then - - call read_input_sfc_gfs_sfcio_file(localpet) - -!------------------------------------------------------------------------------- -! Read fv3gfs surface data in grib2 format. -!------------------------------------------------------------------------------- - - elseif (trim(input_type) == "grib2") then - - call read_input_sfc_grib2_file(localpet) - - endif - - end subroutine read_input_sfc_data - -!> Create atmospheric esmf fields. -!! -!! @author George Gayno NCEP/EMC - subroutine init_atm_esmf_fields - - implicit none - - integer :: i, rc - - print*,"- INITIALIZE ATMOSPHERIC ESMF FIELDS." - - print*,"- CALL FieldCreate FOR INPUT GRID 3-D WIND." - wind_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1,1/), & - ungriddedUBound=(/lev_input,3/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID SURFACE PRESSURE." - ps_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID TERRAIN." - terrain_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID TEMPERATURE." - temp_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lev_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - allocate(tracers_input_grid(num_tracers_input)) - - do i = 1, num_tracers_input - print*,"- CALL FieldCreate FOR INPUT GRID TRACER ", trim(tracers_input(i)) - tracers_input_grid(i) = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lev_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - enddo - - print*,"- CALL FieldCreate FOR INPUT GRID DZDT." - dzdt_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lev_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID U." - u_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lev_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID V." - v_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lev_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID PRESSURE." - pres_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lev_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - end subroutine init_atm_esmf_fields - -!> Create surface input grid esmf fields -!! -!! @author George Gayno NCEP/EMC - subroutine init_sfc_esmf_fields - - implicit none - - integer :: rc - - print*,"- CALL FieldCreate FOR INPUT GRID LANDSEA MASK." - landsea_mask_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID Z0." - z0_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID VEGETATION TYPE." - veg_type_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID CANOPY MOISTURE CONTENT." - canopy_mc_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID SEAICE FRACTION." - seaice_fract_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID SEAICE DEPTH." - seaice_depth_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID SEAICE SKIN TEMPERATURE." - seaice_skin_temp_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID SNOW DEPTH." - snow_depth_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID SNOW LIQUID EQUIVALENT." - snow_liq_equiv_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID T2M." - t2m_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID Q2M." - q2m_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID TPRCP." - tprcp_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID F10M." - f10m_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID USTAR." - ustar_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID FFMM." - ffmm_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT GRID SRFLAG." - srflag_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT SKIN TEMPERATURE." - skin_temp_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT SOIL TYPE." - soil_type_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT TERRAIN." - terrain_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT SOIL TEMPERATURE." - soil_temp_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lsoil_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT TOTAL SOIL MOISTURE." - soilm_tot_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lsoil_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT LIQUID SOIL MOISTURE." - soilm_liq_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lsoil_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - - - if (.not. vgfrc_from_climo) then - print*,"- CALL FieldCreate FOR INPUT VEGETATION GREENNESS." - veg_greenness_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - endif - - if (.not. minmax_vgfrc_from_climo) then - print*,"- CALL FieldCreate FOR INPUT MIN VEGETATION GREENNESS." - min_veg_greenness_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT MAX VEGETATION GREENNESS." - max_veg_greenness_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldCreate", rc) - endif - - if (.not. lai_from_climo) then - print*,"- CALL FieldCreate FOR INPUT LEAF AREA INDEX." - lai_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldCreate", rc) - endif - end subroutine init_sfc_esmf_fields - -!> Read input atmospheric data from spectral gfs (old sigio format). -!! -!! @note Format used prior to July 19, 2017. -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_atm_gfs_sigio_file(localpet) - - use sigio_module - - implicit none - - integer, intent(in) :: localpet - - character(len=300) :: the_file - - integer(sigio_intkind) :: iret - integer :: rc, i, j, k - integer :: clb(3), cub(3) - - real(esmf_kind_r8) :: ak, bk - real(esmf_kind_r8), allocatable :: dummy2d(:,:) - real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) - real(esmf_kind_r8), allocatable :: dummy3d2(:,:,:) - real(esmf_kind_r8), pointer :: pptr(:,:,:), psptr(:,:) - real(esmf_kind_r8), allocatable :: pi(:,:,:) - - type(sigio_head) :: sighead - type(sigio_dbta) :: sigdata - - the_file = trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(1)) - - print*,"- ATMOSPHERIC DATA IN SIGIO FORMAT." - print*,"- OPEN AND READ: ", trim(the_file) - - call sigio_sropen(21, trim(the_file), iret) - if (iret /= 0) then - rc = iret - call error_handler("OPENING SPECTRAL GFS SIGIO FILE.", rc) - endif - call sigio_srhead(21, sighead, iret) - if (iret /= 0) then - rc = iret - call error_handler("READING SPECTRAL GFS SIGIO FILE.", rc) - endif - - lev_input = sighead%levs - levp1_input = lev_input + 1 - - if (num_tracers_input /= sighead%ntrac) then - call error_handler("WRONG NUMBER OF TRACERS EXPECTED.", 99) - endif - - if (sighead%idvt == 0 .or. sighead%idvt == 21) then - if (trim(tracers_input(1)) /= 'spfh' .or. & - trim(tracers_input(2)) /= 'o3mr' .or. & - trim(tracers_input(3)) /= 'clwmr') then - call error_handler("TRACERS SELECTED DO NOT MATCH FILE CONTENTS.", 99) - endif - else - print*,'- UNRECOGNIZED IDVT: ', sighead%idvt - call error_handler("UNRECOGNIZED IDVT", 99) - endif - -!--------------------------------------------------------------------------- -! Initialize esmf atmospheric fields. -!--------------------------------------------------------------------------- - - call init_atm_esmf_fields - - if (localpet == 0) then - allocate(dummy2d(i_input,j_input)) - allocate(dummy3d(i_input,j_input,lev_input)) - allocate(dummy3d2(i_input,j_input,lev_input)) - else - allocate(dummy2d(0,0)) - allocate(dummy3d(0,0,0)) - allocate(dummy3d2(0,0,0)) - endif - - if (localpet == 0) then - call sigio_aldbta(sighead, sigdata, iret) - if (iret /= 0) then - rc = iret - call error_handler("ALLOCATING SIGDATA.", rc) - endif - call sigio_srdbta(21, sighead, sigdata, iret) - if (iret /= 0) then - rc = iret - call error_handler("READING SIGDATA.", rc) - endif - call sptez(0,sighead%jcap,4,i_input, j_input, sigdata%ps, dummy2d, 1) - dummy2d = exp(dummy2d) * 1000.0 - print*,'surface pres ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR SURFACE PRESSURE." - call ESMF_FieldScatter(ps_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call sptez(0,sighead%jcap,4,i_input, j_input, sigdata%hs, dummy2d, 1) - print*,'terrain ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - do k = 1, num_tracers_input - - if (localpet == 0) then - call sptezm(0,sighead%jcap,4,i_input, j_input, lev_input, sigdata%q(:,:,k), dummy3d, 1) - print*,trim(tracers_input(k)),maxval(dummy3d),minval(dummy3d) - endif - - print*,"- CALL FieldScatter FOR INPUT ", trim(tracers_input(k)) - call ESMF_FieldScatter(tracers_input_grid(k), dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - enddo - - if (localpet == 0) then - call sptezm(0,sighead%jcap,4,i_input, j_input, lev_input, sigdata%t, dummy3d, 1) - print*,'temp ',maxval(dummy3d),minval(dummy3d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." - call ESMF_FieldScatter(temp_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -!--------------------------------------------------------------------------- -! The spectral gfs files have omega, not vertical velocity. Set to -! zero for now. Convert from omega to vv in the future? -!--------------------------------------------------------------------------- - - if (localpet == 0) then - print*,"- NO VERTICAL VELOCITY RECORD. SET TO ZERO." - dummy3d = 0.0 - endif - - print*,"- CALL FieldScatter FOR INPUT DZDT." - call ESMF_FieldScatter(dzdt_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call sptezmv(0, sighead%jcap, 4, i_input, j_input, lev_input, sigdata%d, sigdata%z, dummy3d, dummy3d2, 1) - print*,'u ',maxval(dummy3d),minval(dummy3d) - print*,'v ',maxval(dummy3d2),minval(dummy3d2) - endif - - print*,"- CALL FieldScatter FOR INPUT U-WIND." - call ESMF_FieldScatter(u_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - print*,"- CALL FieldScatter FOR INPUT V-WIND." - call ESMF_FieldScatter(v_input_grid, dummy3d2, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - deallocate(dummy2d, dummy3d, dummy3d2) - - if (localpet == 0) call sigio_axdbta(sigdata, iret) - - call sigio_sclose(21, iret) - -!--------------------------------------------------------------------------- -! Convert from 2-d to 3-d component winds. -!--------------------------------------------------------------------------- - - call convert_winds - -!--------------------------------------------------------------------------- -! Compute 3-d pressure from 'ak' and 'bk'. -!--------------------------------------------------------------------------- - - print*,"- COMPUTE 3-D PRESSURE." - - print*,"- CALL FieldGet FOR 3-D PRES." - nullify(pptr) - call ESMF_FieldGet(pres_input_grid, & - computationalLBound=clb, & - computationalUBound=cub, & - farrayPtr=pptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR SURFACE PRESSURE." - nullify(psptr) - call ESMF_FieldGet(ps_input_grid, & - farrayPtr=psptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - -!--------------------------------------------------------------------------- -! First, compute interface pressure. -!--------------------------------------------------------------------------- - - allocate(pi(clb(1):cub(1),clb(2):cub(2),1:levp1_input),stat=rc) - - do k=1,levp1_input - ak = sighead%vcoord(k,1) - bk = sighead%vcoord(k,2) - do i= clb(1), cub(1) - do j= clb(2), cub(2) - pi(i,j,k) = ak + bk*psptr(i,j) - enddo - enddo - enddo - - if (localpet == 0) then - print*,'pres int ',psptr(clb(1),clb(2)),pi(clb(1),clb(2),:) - endif - -!--------------------------------------------------------------------------- -! Now comput mid-layer pressure from interface pressure. -!--------------------------------------------------------------------------- - - do k=1,lev_input - do i= clb(1), cub(1) - do j= clb(2), cub(2) - pptr(i,j,k) = (pi(i,j,k)+pi(i,j,k+1))/2.0_esmf_kind_r8 - enddo - enddo - enddo - - deallocate(pi) - - if (localpet == 0) then - print*,'pres ',psptr(clb(1),clb(2)),pptr(clb(1),clb(2),:) - endif - - end subroutine read_input_atm_gfs_sigio_file - -!> Read input atmospheric data from spectral gfs (global gaussian in -!! nemsio format. Starting July 19, 2017). -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_atm_gfs_gaussian_nemsio_file(localpet) - - implicit none - - integer, intent(in) :: localpet - - character(len=300) :: the_file - character(len=20) :: vlevtyp, vname - - integer(nemsio_intkind) :: vlev, iret - integer :: i, j, k, n, rc - integer :: clb(3), cub(3) - - real(nemsio_realkind), allocatable :: vcoord(:,:,:) - real(nemsio_realkind), allocatable :: dummy(:) - real(esmf_kind_r8), allocatable :: dummy2d(:,:) - real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) - real(esmf_kind_r8) :: ak, bk - real(esmf_kind_r8), allocatable :: pi(:,:,:) - real(esmf_kind_r8), pointer :: pptr(:,:,:), psptr(:,:) - - type(nemsio_gfile) :: gfile - - the_file = trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(1)) - - print*,"- READ ATMOS DATA FROM SPECTRAL GFS NEMSIO FILE: ", trim(the_file) - - print*,"- OPEN FILE." - call nemsio_open(gfile, the_file, "read", iret=iret) - if (iret /= 0) call error_handler("OPENING SPECTRAL GFS NEMSIO ATM FILE.", iret) - - print*,"- READ NUMBER OF VERTICAL LEVELS." - call nemsio_getfilehead(gfile, iret=iret, dimz=lev_input) - if (iret /= 0) call error_handler("READING NUMBER OF VERTICAL LEVLES.", iret) - - levp1_input = lev_input + 1 - - allocate(vcoord(levp1_input,3,2)) - - print*,"- READ VERTICAL COORDINATE INFO." - call nemsio_getfilehead(gfile, iret=iret, vcoord=vcoord) - if (iret /= 0) call error_handler("READING VERTICAL COORDINATE INFO.", iret) - -!--------------------------------------------------------------------------- -! Initialize esmf atmospheric fields. -!--------------------------------------------------------------------------- - - call init_atm_esmf_fields - - if (localpet == 0) then - allocate(dummy(i_input*j_input)) - allocate(dummy2d(i_input,j_input)) - allocate(dummy3d(i_input,j_input,lev_input)) - else - allocate(dummy(0)) - allocate(dummy2d(0,0)) - allocate(dummy3d(0,0,0)) - endif - -!----------------------------------------------------------------------- -! 3-d fields in gaussian files increment from bottom to model top. -! That is what is expected by this program, so no need to flip indices. -!----------------------------------------------------------------------- - - if (localpet == 0) then - print*,"- READ TEMPERATURE." - vname = "tmp" - vlevtyp = "mid layer" - do vlev = 1, lev_input - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING TEMPERATURE RECORD.", iret) - dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) -! print*,'temp check after read ',vlev, dummy3d(1,1,vlev) - enddo - endif - - print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." - call ESMF_FieldScatter(temp_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - do n = 1, num_tracers_input - - if (localpet == 0) then - print*,"- READ ", trim(tracers_input(n)) - vname = trim(tracers_input(n)) - vlevtyp = "mid layer" - do vlev = 1, lev_input - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING TRACER RECORD.", iret) -! print*,'tracer ',vlev, maxval(dummy),minval(dummy) - dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) - enddo - endif - - print*,"- CALL FieldScatter FOR INPUT ", trim(tracers_input(n)) - call ESMF_FieldScatter(tracers_input_grid(n), dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - enddo - - if (localpet == 0) then - print*,"- READ U-WINDS." - vname = "ugrd" - vlevtyp = "mid layer" - do vlev = 1, lev_input - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING U-WIND RECORD.", iret) -! print*,'ugrd ',vlev, maxval(dummy),minval(dummy) - dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) - enddo - endif - - print*,"- CALL FieldScatter FOR INPUT U-WIND." - call ESMF_FieldScatter(u_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ V-WINDS." - vname = "vgrd" - vlevtyp = "mid layer" - do vlev = 1, lev_input - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING V-WIND RECORD.", iret) -! print*,'vgrd ',vlev, maxval(dummy),minval(dummy) - dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) - enddo - endif - - print*,"- CALL FieldScatter FOR INPUT V-WIND." - call ESMF_FieldScatter(v_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -!--------------------------------------------------------------------------- -! The spectral gfs nemsio files do not have a vertical velocity or -! omega record. So set to zero for now. -!--------------------------------------------------------------------------- - - if (localpet == 0) then - print*,"- NO VERTICAL VELOCITY RECORD. SET TO ZERO." - dummy3d = 0.0 - endif - - print*,"- CALL FieldScatter FOR INPUT DZDT." - call ESMF_FieldScatter(dzdt_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ HGT." - vname = "hgt" - vlevtyp = "sfc" - vlev = 1 - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING HGT RECORD.", iret) -! print*,'hgt ',vlev, maxval(dummy),minval(dummy) - dummy2d = reshape(dummy, (/i_input,j_input/)) - endif - - print*,"- CALL FieldScatter FOR TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ PRES." - vname = "pres" - vlevtyp = "sfc" - vlev = 1 - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING PRES RECORD.", iret) -! print*,'pres ',vlev, maxval(dummy),minval(dummy) - dummy2d = reshape(dummy, (/i_input,j_input/)) - endif - - print*,"- CALL FieldScatter FOR SURFACE PRESSURE." - call ESMF_FieldScatter(ps_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - call nemsio_close(gfile) - - deallocate(dummy, dummy2d, dummy3d) - -!--------------------------------------------------------------------------- -! Convert from 2-d to 3-d component winds. -!--------------------------------------------------------------------------- - - call convert_winds - -!--------------------------------------------------------------------------- -! Compute 3-d pressure from 'ak' and 'bk'. -!--------------------------------------------------------------------------- - - print*,"- COMPUTE 3-D PRESSURE." - - print*,"- CALL FieldGet FOR 3-D PRES." - nullify(pptr) - call ESMF_FieldGet(pres_input_grid, & - computationalLBound=clb, & - computationalUBound=cub, & - farrayPtr=pptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR SURFACE PRESSURE." - nullify(psptr) - call ESMF_FieldGet(ps_input_grid, & - farrayPtr=psptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - -!--------------------------------------------------------------------------- -! First, compute interface pressure. -!--------------------------------------------------------------------------- - - allocate(pi(clb(1):cub(1),clb(2):cub(2),1:levp1_input)) - - do k=1,levp1_input - ak = vcoord(k,1,1) - bk = vcoord(k,2,1) - do i= clb(1), cub(1) - do j= clb(2), cub(2) - pi(i,j,k) = ak + bk*psptr(i,j) - enddo - enddo - enddo - - deallocate(vcoord) - -!--------------------------------------------------------------------------- -! Now comput mid-layer pressure from interface pressure. -!--------------------------------------------------------------------------- - - do k=1,lev_input - do i= clb(1), cub(1) - do j= clb(2), cub(2) - pptr(i,j,k) = (pi(i,j,k)+pi(i,j,k+1))/2.0 - enddo - enddo - enddo - - deallocate(pi) - - end subroutine read_input_atm_gfs_gaussian_nemsio_file - -!> Read input grid atmospheric fv3 gaussian nemsio files. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_atm_gaussian_nemsio_file(localpet) - - implicit none - - integer, intent(in) :: localpet - - character(len=300) :: the_file - character(len=20) :: vlevtyp, vname - - integer :: i, j, k, n - integer :: rc, clb(3), cub(3) - integer(nemsio_intkind) :: vlev, iret - - real(nemsio_realkind), allocatable :: vcoord(:,:,:) - real(nemsio_realkind), allocatable :: dummy(:) - real(esmf_kind_r8), allocatable :: dummy2d(:,:) - real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) - real(esmf_kind_r8), pointer :: presptr(:,:,:), psptr(:,:) - real(esmf_kind_r8), pointer :: dpresptr(:,:,:) - real(esmf_kind_r8), allocatable :: pres_interface(:) - - type(nemsio_gfile) :: gfile - - the_file = trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(1)) - - print*,"- READ ATMOS DATA FROM GAUSSIAN NEMSIO FILE: ", trim(the_file) - - print*,"- OPEN FILE." - call nemsio_open(gfile, the_file, "read", iret=iret) - if (iret /= 0) call error_handler("OPENING GAUSSIAN NEMSIO ATM FILE.", iret) - - print*,"- READ NUMBER OF VERTICAL LEVELS." - call nemsio_getfilehead(gfile, iret=iret, dimz=lev_input) - if (iret /= 0) call error_handler("READING NUMBER OF VERTICAL LEVLES.", iret) - - levp1_input = lev_input + 1 - - allocate(vcoord(levp1_input,3,2)) - - print*,"- READ VERTICAL COORDINATE INFO." - call nemsio_getfilehead(gfile, iret=iret, vcoord=vcoord) - if (iret /= 0) call error_handler("READING VERTICAL COORDINATE INFO.", iret) - -!--------------------------------------------------------------------------- -! Initialize esmf atmospheric fields. -!--------------------------------------------------------------------------- - - call init_atm_esmf_fields - - print*,"- CALL FieldCreate FOR INPUT DPRES." - dpres_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lev_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - if (localpet == 0) then - allocate(dummy(i_input*j_input)) - allocate(dummy2d(i_input,j_input)) - allocate(dummy3d(i_input,j_input,lev_input)) - else - allocate(dummy(0)) - allocate(dummy2d(0,0)) - allocate(dummy3d(0,0,0)) - endif - -!----------------------------------------------------------------------- -! 3-d fields in gaussian files increment from bottom to model top. -! That is what is expected by this program, so no need to flip indices. -!----------------------------------------------------------------------- - - if (localpet == 0) then - print*,"- READ TEMPERATURE." - vname = "tmp" - vlevtyp = "mid layer" - do vlev = 1, lev_input - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING TEMPERATURE RECORD.", iret) - dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) - print*,'temp check after read ',vlev, dummy3d(1,1,vlev) - enddo - endif - - print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." - call ESMF_FieldScatter(temp_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - do n = 1, num_tracers_input - - if (localpet == 0) then - print*,"- READ ", trim(tracers_input(n)) - vname = trim(tracers_input(n)) - vlevtyp = "mid layer" - do vlev = 1, lev_input - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING TRACER RECORD.", iret) - print*,'tracer ',vlev, maxval(dummy),minval(dummy) - dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) - enddo - endif - - print*,"- CALL FieldScatter FOR INPUT ", trim(tracers_input(n)) - call ESMF_FieldScatter(tracers_input_grid(n), dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - enddo - - if (localpet == 0) then - print*,"- READ U-WINDS." - vname = "ugrd" - vlevtyp = "mid layer" - do vlev = 1, lev_input - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING U-WIND RECORD.", iret) - print*,'ugrd ',vlev, maxval(dummy),minval(dummy) - dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) - enddo - endif - - print*,"- CALL FieldScatter FOR INPUT U-WIND." - call ESMF_FieldScatter(u_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ V-WINDS." - vname = "vgrd" - vlevtyp = "mid layer" - do vlev = 1, lev_input - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING V-WIND RECORD.", iret) - print*,'vgrd ',vlev, maxval(dummy),minval(dummy) - dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) - enddo - endif - - print*,"- CALL FieldScatter FOR INPUT V-WIND." - call ESMF_FieldScatter(v_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ DPRES." - vname = "dpres" - vlevtyp = "mid layer" - do vlev = 1, lev_input - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING DPRES RECORD.", iret) - print*,'dpres ',vlev, maxval(dummy),minval(dummy) - dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) - enddo - endif - - print*,"- CALL FieldScatter FOR INPUT DPRES." - call ESMF_FieldScatter(dpres_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ DZDT." - vname = "dzdt" - vlevtyp = "mid layer" - do vlev = 1, lev_input - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING DZDT RECORD.", iret) - print*,'dzdt ',vlev, maxval(dummy),minval(dummy) - dummy3d(:,:,vlev) = reshape(dummy, (/i_input,j_input/)) - enddo - endif - - print*,"- CALL FieldScatter FOR INPUT DZDT." - call ESMF_FieldScatter(dzdt_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ HGT." - vname = "hgt" - vlevtyp = "sfc" - vlev = 1 - call nemsio_readrecv(gfile, vname, vlevtyp, vlev, dummy, 0, iret) - if (iret /= 0) call error_handler("READING HGT RECORD.", iret) - print*,'hgt ',vlev, maxval(dummy),minval(dummy) - dummy2d = reshape(dummy, (/i_input,j_input/)) - endif - - print*,"- CALL FieldScatter FOR TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - call nemsio_close(gfile) - - deallocate(dummy, dummy2d, dummy3d) - -!--------------------------------------------------------------------------- -! Convert from 2-d to 3-d component winds. -!--------------------------------------------------------------------------- - - call convert_winds - -!--------------------------------------------------------------------------- -! Compute 3-d pressure. Mid-layer and surface pressure are computed -! from delta p. The surface pressure in the file is not used. After -! the model's write component interpolates from the cubed-sphere grid -! to the gaussian grid, the surface pressure is no longer consistent -! with the delta p (per Jun Wang). -!--------------------------------------------------------------------------- - - print*,"- COMPUTE 3-D PRESSURE." - - print*,"- CALL FieldGet FOR DELTA PRESSURE." - nullify(dpresptr) - call ESMF_FieldGet(dpres_input_grid, & - computationalLBound=clb, & - computationalUBound=cub, & - farrayPtr=dpresptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR 3-D PRESSURE." - nullify(presptr) - call ESMF_FieldGet(pres_input_grid, & - farrayPtr=presptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR SURFACE PRESSURE." - nullify(psptr) - call ESMF_FieldGet(ps_input_grid, & - farrayPtr=psptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - allocate(pres_interface(levp1_input)) - - if (localpet == 0) then - do k = clb(3), cub(3) - print*,'dpres is ',cub(1),cub(2),k, dpresptr(cub(1),cub(2),k) - enddo - endif - - do i = clb(1), cub(1) - do j = clb(2), cub(2) - pres_interface(levp1_input) = vcoord(levp1_input,1,1) - do k = lev_input, 1, -1 - pres_interface(k) = pres_interface(k+1) + dpresptr(i,j,k) - enddo - psptr(i,j) = pres_interface(1) - do k = 1, lev_input - presptr(i,j,k) = (pres_interface(k) + pres_interface(k+1)) / 2.0_8 - enddo - enddo - enddo - - deallocate(vcoord) - - if (localpet == 0) then - print*,'psfc is ',clb(1),clb(2),psptr(clb(1),clb(2)) - print*,'pres is ',clb(1),clb(2),presptr(clb(1),clb(2),:) - endif - - print*,'pres check 1',localpet,maxval(presptr(:,:,1)),minval(presptr(:,:,1)) - print*,'pres check lev',localpet,maxval(presptr(:,:,lev_input)),minval(presptr(:,:,lev_input)) - - deallocate(pres_interface) - - call ESMF_FieldDestroy(dpres_input_grid, rc=rc) - - end subroutine read_input_atm_gaussian_nemsio_file - -!> Read input grid fv3 atmospheric data 'warm' restart files. -!! -!! @note Routine reads tiled files in parallel. Tile 1 is read by -!! localpet 0; tile 2 by localpet 1, etc. The number of pets -!! must be equal to or greater than the number of tiled files. -!! Logic only tested with global input data of six tiles. -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_atm_restart_file(localpet) - - implicit none - - integer, intent(in) :: localpet - - character(len=500) :: tilefile - - integer :: i, j, k - integer :: clb(3), cub(3) - integer :: rc, tile, ncid, id_var - integer :: error, id_dim - - real(esmf_kind_r8), allocatable :: ak(:) - real(esmf_kind_r8), pointer :: presptr(:,:,:), psptr(:,:) - real(esmf_kind_r8), pointer :: dpresptr(:,:,:) - real(esmf_kind_r8), allocatable :: data_one_tile(:,:) - real(esmf_kind_r8), allocatable :: data_one_tile_3d(:,:,:) - real(esmf_kind_r8), allocatable :: pres_interface(:) - -!--------------------------------------------------------------------------- -! Get number of vertical levels and model top pressure. -!--------------------------------------------------------------------------- - - tilefile = trim(data_dir_input_grid) // "/" // trim(atm_core_files_input_grid(7)) - print*,"- READ ATM VERTICAL LEVELS FROM: ", trim(tilefile) - error=nf90_open(trim(tilefile),nf90_nowrite,ncid) - call netcdf_err(error, 'opening: '//trim(tilefile) ) - - error=nf90_inq_dimid(ncid, 'xaxis_1', id_dim) - call netcdf_err(error, 'reading xaxis_1 id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=levp1_input) - call netcdf_err(error, 'reading xaxis_1 value' ) - - lev_input = levp1_input - 1 - - allocate(ak(levp1_input)) - - error=nf90_inq_varid(ncid, 'ak', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, ak) - call netcdf_err(error, 'reading ak' ) - - error = nf90_close(ncid) - -!--------------------------------------------------------------------------- -! Initialize esmf atmospheric fields. -!--------------------------------------------------------------------------- - - call init_atm_esmf_fields - - print*,"- CALL FieldCreate FOR INPUT GRID DELTA PRESSURE." - dpres_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lev_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - if (localpet < num_tiles_input_grid) then - allocate(data_one_tile_3d(i_input,j_input,lev_input)) - allocate(data_one_tile(i_input,j_input)) - else - allocate(data_one_tile_3d(0,0,0)) - allocate(data_one_tile(0,0)) - endif - - if (localpet < num_tiles_input_grid) then - tile = localpet+1 - tilefile= trim(data_dir_input_grid) // "/" // trim(atm_core_files_input_grid(tile)) - print*,"- READ ATMOSPHERIC CORE FILE: ", trim(tilefile) - error=nf90_open(trim(tilefile),nf90_nowrite,ncid) - call netcdf_err(error, 'opening: '//trim(tilefile) ) - endif - - if (localpet < num_tiles_input_grid) then - error=nf90_inq_varid(ncid, 'phis', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile) - call netcdf_err(error, 'reading field' ) - data_one_tile = data_one_tile / 9.806_8 ! geopotential height - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID TERRAIN for tile ",tile - call ESMF_FieldScatter(terrain_input_grid, data_one_tile, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) then -! error=nf90_inq_varid(ncid, 'W', id_var) -! call netcdf_err(error, 'reading field id' ) -! error=nf90_get_var(ncid, id_var, data_one_tile_3d) -! call netcdf_err(error, 'reading field' ) -! data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - -! Using 'w' from restart files has caused problems. Set to zero. - data_one_tile_3d = 0.0_8 - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID VERTICAL VELOCITY for tile ",tile - call ESMF_FieldScatter(dzdt_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) then - error=nf90_inq_varid(ncid, 'T', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile_3d) - call netcdf_err(error, 'reading field' ) - data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." - call ESMF_FieldScatter(temp_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) then - error=nf90_inq_varid(ncid, 'delp', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile_3d) - call netcdf_err(error, 'reading field' ) - data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT DELTA PRESSURE." - call ESMF_FieldScatter(dpres_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) then - error=nf90_inq_varid(ncid, 'ua', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile_3d) - call netcdf_err(error, 'reading field' ) - data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID U." - call ESMF_FieldScatter(u_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) then - error=nf90_inq_varid(ncid, 'va', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile_3d) - call netcdf_err(error, 'reading field' ) - data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID V." - call ESMF_FieldScatter(v_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) error = nf90_close(ncid) - - if (localpet < num_tiles_input_grid) then - tile = localpet+1 - tilefile= trim(data_dir_input_grid) // "/" // trim(atm_tracer_files_input_grid(tile)) - print*,"- READ ATMOSPHERIC TRACER FILE: ", trim(tilefile) - error=nf90_open(trim(tilefile),nf90_nowrite,ncid) - call netcdf_err(error, 'opening: '//trim(tilefile) ) - endif - - do i = 1, num_tracers_input - - if (localpet < num_tiles_input_grid) then - error=nf90_inq_varid(ncid, tracers_input(i), id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile_3d) - call netcdf_err(error, 'reading field' ) - data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT ", trim(tracers_input(i)) - call ESMF_FieldScatter(tracers_input_grid(i), data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - enddo - - if (localpet < num_tiles_input_grid) error=nf90_close(ncid) - -!--------------------------------------------------------------------------- -! Convert from 2-d to 3-d cartesian winds. -!--------------------------------------------------------------------------- - - call convert_winds - -!--------------------------------------------------------------------------- -! Compute pressures -!--------------------------------------------------------------------------- - - print*,"- CALL FieldGet FOR SURFACE PRESSURE." - call ESMF_FieldGet(ps_input_grid, & - farrayPtr=psptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR PRESSURE." - call ESMF_FieldGet(pres_input_grid, & - computationalLBound=clb, & - computationalUBound=cub, & - farrayPtr=presptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR DELTA PRESSURE." - call ESMF_FieldGet(dpres_input_grid, & - farrayPtr=dpresptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - allocate(pres_interface(levp1_input)) - - do i = clb(1), cub(1) - do j = clb(2), cub(2) - pres_interface(levp1_input) = ak(1) ! model top in Pa - do k = (levp1_input-1), 1, -1 - pres_interface(k) = pres_interface(k+1) + dpresptr(i,j,k) - enddo - do k = 1, lev_input - presptr(i,j,k) = (pres_interface(k) + pres_interface(k+1)) / 2.0_8 - enddo - psptr(i,j) = pres_interface(1) - enddo - enddo - - deallocate(ak) - deallocate(pres_interface) - - call ESMF_FieldDestroy(dpres_input_grid, rc=rc) - - deallocate(data_one_tile_3d, data_one_tile) - - end subroutine read_input_atm_restart_file - -!> Read fv3 netcdf gaussian history file. Each task reads a horizontal -!! slice. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_atm_gaussian_netcdf_file(localpet) - - use mpi - - implicit none - - integer, intent(in) :: localpet - - character(len=500) :: tilefile - - integer :: start(3), count(3), iscnt - integer :: error, ncid, num_tracers_file - integer :: id_dim, idim_input, jdim_input - integer :: id_var, rc, nprocs, max_procs - integer :: kdim, remainder, myrank, i, j, k, n - integer :: clb(3), cub(3) - integer, allocatable :: kcount(:), startk(:), displ(:) - integer, allocatable :: ircnt(:) - - real(esmf_kind_r8), allocatable :: phalf(:) - real(esmf_kind_r8), allocatable :: pres_interface(:) - real(kind=4), allocatable :: dummy3d(:,:,:) - real(kind=4), allocatable :: dummy3dall(:,:,:) - real(esmf_kind_r8), allocatable :: dummy3dflip(:,:,:) - real(esmf_kind_r8), allocatable :: dummy(:,:) - real(esmf_kind_r8), pointer :: presptr(:,:,:), dpresptr(:,:,:) - real(esmf_kind_r8), pointer :: psptr(:,:) - - print*,"- READ INPUT ATMOS DATA FROM GAUSSIAN NETCDF FILE." - - tilefile = trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(1)) - error=nf90_open(trim(tilefile),nf90_nowrite,ncid) - call netcdf_err(error, 'opening: '//trim(tilefile) ) - - error=nf90_inq_dimid(ncid, 'grid_xt', id_dim) - call netcdf_err(error, 'reading grid_xt id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=idim_input) - call netcdf_err(error, 'reading grid_xt value' ) - - error=nf90_inq_dimid(ncid, 'grid_yt', id_dim) - call netcdf_err(error, 'reading grid_yt id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=jdim_input) - call netcdf_err(error, 'reading grid_yt value' ) - - if (idim_input /= i_input .or. jdim_input /= j_input) then - call error_handler("DIMENSION MISMATCH BETWEEN SFC AND OROG FILES.", 2) - endif - - error=nf90_inq_dimid(ncid, 'pfull', id_dim) - call netcdf_err(error, 'reading pfull id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=lev_input) - call netcdf_err(error, 'reading pfull value' ) - - error=nf90_inq_dimid(ncid, 'phalf', id_dim) - call netcdf_err(error, 'reading phalf id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=levp1_input) - call netcdf_err(error, 'reading phalf value' ) - allocate(phalf(levp1_input)) - error=nf90_inq_varid(ncid, 'phalf', id_var) - call netcdf_err(error, 'getting phalf varid' ) - error=nf90_get_var(ncid, id_var, phalf) - call netcdf_err(error, 'reading phalf varid' ) - - error=nf90_get_att(ncid, nf90_global, 'ncnsto', num_tracers_file) - call netcdf_err(error, 'reading ntracer value' ) - - call mpi_comm_size(mpi_comm_world, nprocs, error) - print*,'- Running with ', nprocs, ' processors' - - call mpi_comm_rank(mpi_comm_world, myrank, error) - print*,'- myrank/localpet is ',myrank,localpet - - max_procs = nprocs - if (nprocs > lev_input) then - max_procs = lev_input - endif - - kdim = lev_input / max_procs - remainder = lev_input - (max_procs*kdim) - - allocate(kcount(0:nprocs-1)) - kcount=0 - allocate(startk(0:nprocs-1)) - startk=0 - allocate(displ(0:nprocs-1)) - displ=0 - allocate(ircnt(0:nprocs-1)) - ircnt=0 - - do k = 0, max_procs-2 - kcount(k) = kdim - enddo - kcount(max_procs-1) = kdim + remainder - - startk(0) = 1 - do k = 1, max_procs-1 - startk(k) = startk(k-1) + kcount(k-1) - enddo - - ircnt(:) = idim_input * jdim_input * kcount(:) - - displ(0) = 0 - do k = 1, max_procs-1 - displ(k) = displ(k-1) + ircnt(k-1) - enddo - - iscnt=idim_input*jdim_input*kcount(myrank) - -! Account for case if number of tasks exceeds the number of vert levels. - - if (myrank <= max_procs-1) then - allocate(dummy3d(idim_input,jdim_input,kcount(myrank))) - else - allocate(dummy3d(0,0,0)) - endif - - if (myrank == 0) then - allocate(dummy3dall(idim_input,jdim_input,lev_input)) - dummy3dall = 0.0 - allocate(dummy3dflip(idim_input,jdim_input,lev_input)) - dummy3dflip = 0.0 - allocate(dummy(idim_input,jdim_input)) - dummy = 0.0 - else - allocate(dummy3dall(0,0,0)) - allocate(dummy3dflip(0,0,0)) - allocate(dummy(0,0)) - endif - -!--------------------------------------------------------------------------- -! Initialize esmf atmospheric fields. -!--------------------------------------------------------------------------- - - call init_atm_esmf_fields - - print*,"- CALL FieldCreate FOR INPUT GRID DELTA PRESSURE." - dpres_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lev_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - -! Temperature - - if (myrank <= max_procs-1) then - start = (/1,1,startk(myrank)/) - count = (/idim_input,jdim_input,kcount(myrank)/) - error=nf90_inq_varid(ncid, 'tmp', id_var) - call netcdf_err(error, 'reading tmp field id' ) - error=nf90_get_var(ncid, id_var, dummy3d, start=start, count=count) - call netcdf_err(error, 'reading tmp field' ) - endif - - call mpi_gatherv(dummy3d, iscnt, mpi_real, & - dummy3dall, ircnt, displ, mpi_real, & - 0, mpi_comm_world, error) - if (error /= 0) call error_handler("IN mpi_gatherv of temperature", error) - - if (myrank == 0) then - dummy3dflip(:,:,1:lev_input) = dummy3dall(:,:,lev_input:1:-1) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE " - call ESMF_FieldScatter(temp_input_grid, dummy3dflip, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! dpres - - if (myrank <= max_procs-1) then - error=nf90_inq_varid(ncid, 'dpres', id_var) - call netcdf_err(error, 'reading dpres field id' ) - error=nf90_get_var(ncid, id_var, dummy3d, start=start, count=count) - call netcdf_err(error, 'reading dpres field' ) - endif - - call mpi_gatherv(dummy3d, iscnt, mpi_real, & - dummy3dall, ircnt, displ, mpi_real, & - 0, mpi_comm_world, error) - if (error /= 0) call error_handler("IN mpi_gatherv of dpres", error) - - if (myrank == 0) then - dummy3dflip(:,:,1:lev_input) = dummy3dall(:,:,lev_input:1:-1) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID DPRES " - call ESMF_FieldScatter(dpres_input_grid, dummy3dflip, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! ugrd - - if (myrank <= max_procs-1) then - error=nf90_inq_varid(ncid, 'ugrd', id_var) - call netcdf_err(error, 'reading ugrd field id' ) - error=nf90_get_var(ncid, id_var, dummy3d, start=start, count=count) - call netcdf_err(error, 'reading ugrd field' ) - endif - - call mpi_gatherv(dummy3d, iscnt, mpi_real, & - dummy3dall, ircnt, displ, mpi_real, & - 0, mpi_comm_world, error) - if (error /= 0) call error_handler("IN mpi_gatherv of ugrd", error) - - if (myrank == 0) then - dummy3dflip(:,:,1:lev_input) = dummy3dall(:,:,lev_input:1:-1) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID UGRD " - call ESMF_FieldScatter(u_input_grid, dummy3dflip, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! vgrd - - if (myrank <= max_procs-1) then - error=nf90_inq_varid(ncid, 'vgrd', id_var) - call netcdf_err(error, 'reading vgrd field id' ) - error=nf90_get_var(ncid, id_var, dummy3d, start=start, count=count) - call netcdf_err(error, 'reading vgrd field' ) - endif - - call mpi_gatherv(dummy3d, iscnt, mpi_real, & - dummy3dall, ircnt, displ, mpi_real, & - 0, mpi_comm_world, error) - if (error /= 0) call error_handler("IN mpi_gatherv of vgrd", error) - - if (myrank == 0) then - dummy3dflip(:,:,1:lev_input) = dummy3dall(:,:,lev_input:1:-1) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID VGRD " - call ESMF_FieldScatter(v_input_grid, dummy3dflip, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! tracers - - do n = 1, num_tracers_input - - if (myrank <= max_procs-1) then - error=nf90_inq_varid(ncid, tracers_input(n), id_var) - call netcdf_err(error, 'reading tracer field id' ) - error=nf90_get_var(ncid, id_var, dummy3d, start=start, count=count) - call netcdf_err(error, 'reading tracer field' ) - endif - - call mpi_gatherv(dummy3d, iscnt, mpi_real, & - dummy3dall, ircnt, displ, mpi_real, & - 0, mpi_comm_world, error) - if (error /= 0) call error_handler("IN mpi_gatherv of tracer", error) - - if (myrank == 0) then - dummy3dflip(:,:,1:lev_input) = dummy3dall(:,:,lev_input:1:-1) - where(dummy3dflip < 0.0) dummy3dflip = 0.0 - endif - - print*,"- CALL FieldScatter FOR INPUT GRID ", tracers_input(n) - call ESMF_FieldScatter(tracers_input_grid(n), dummy3dflip, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - enddo - -! dzdt set to zero for now. - - if (myrank == 0) then - dummy3dflip = 0.0 - endif - - print*,"- CALL FieldScatter FOR INPUT GRID DZDT" - call ESMF_FieldScatter(dzdt_input_grid, dummy3dflip, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - deallocate(dummy3dflip, dummy3dall, dummy3d) - -! terrain - - if (myrank==0) then - print*,"- READ TERRAIN." - error=nf90_inq_varid(ncid, 'hgtsfc', id_var) - call netcdf_err(error, 'reading hgtsfc field id' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'reading hgtsfc field' ) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, dummy, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! surface pressure - - if (myrank==0) then - print*,"- READ SURFACE P." - error=nf90_inq_varid(ncid, 'pressfc', id_var) - call netcdf_err(error, 'reading pressfc field id' ) - error=nf90_get_var(ncid, id_var, dummy) - call netcdf_err(error, 'reading pressfc field' ) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SURFACE P." - call ESMF_FieldScatter(ps_input_grid, dummy, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - deallocate(kcount, startk, displ, ircnt, dummy) - -!--------------------------------------------------------------------------- -! Convert from 2-d to 3-d cartesian winds. -!--------------------------------------------------------------------------- - - call convert_winds - -!--------------------------------------------------------------------------- -! Compute pressure. -!--------------------------------------------------------------------------- - - print*,"- CALL FieldGet FOR PRESSURE." - call ESMF_FieldGet(pres_input_grid, & - computationalLBound=clb, & - computationalUBound=cub, & - farrayPtr=presptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR DELTA PRESSURE." - call ESMF_FieldGet(dpres_input_grid, & - farrayPtr=dpresptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR SURFACE PRESSURE." - call ESMF_FieldGet(ps_input_grid, & - farrayPtr=psptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - allocate(pres_interface(levp1_input)) - -!--------------------------------------------------------------------------- -! Compute 3-d pressure. -!--------------------------------------------------------------------------- - -!--------------------------------------------------------------------------- -! When ingesting gaussian netcdf files, the mid-layer -! surface pressure are computed top down from delta-p -! The surface pressure in the file is not used. According -! to Jun Wang, after the model's write component interpolates from the -! cubed-sphere grid to the gaussian grid, the surface pressure is -! no longer consistent with the delta p. -!--------------------------------------------------------------------------- - - do i = clb(1), cub(1) - do j = clb(2), cub(2) - pres_interface(levp1_input) = phalf(1) * 100.0_8 - do k = lev_input, 1, -1 - pres_interface(k) = pres_interface(k+1) + dpresptr(i,j,k) - enddo - psptr(i,j) = pres_interface(1) - do k = 1, lev_input - presptr(i,j,k) = (pres_interface(k) + pres_interface(k+1)) / 2.0_8 - enddo - enddo - enddo - - deallocate(pres_interface, phalf) - - call ESMF_FieldDestroy(dpres_input_grid, rc=rc) - - end subroutine read_input_atm_gaussian_netcdf_file - -!> Read input grid fv3 atmospheric tiled history files in netcdf -!! format. -!! -!! @note Routine reads tiled files in parallel. Tile 1 is read by -!! localpet 0; tile 2 by localpet 1, etc. The number of pets -!! must be equal to or greater than the number of tiled files. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_atm_tiled_history_file(localpet) - - use mpi - - implicit none - - integer, intent(in) :: localpet - - character(len=500) :: tilefile - - integer :: error, ncid, rc, tile - integer :: id_dim, idim_input, jdim_input - integer :: id_var, i, j, k, n - integer :: clb(3), cub(3), num_tracers_file - - real(esmf_kind_r8), allocatable :: data_one_tile(:,:) - real(esmf_kind_r8), allocatable :: data_one_tile_3d(:,:,:) - real(esmf_kind_r8), pointer :: presptr(:,:,:), dpresptr(:,:,:) - real(esmf_kind_r8), pointer :: psptr(:,:) - real(esmf_kind_r8), allocatable :: pres_interface(:), phalf(:) - - print*,"- READ INPUT ATMOS DATA FROM TILED HISTORY FILES." - - tilefile = trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(1)) - error=nf90_open(trim(tilefile),nf90_nowrite,ncid) - call netcdf_err(error, 'opening: '//trim(tilefile) ) - - error=nf90_inq_dimid(ncid, 'grid_xt', id_dim) - call netcdf_err(error, 'reading grid_xt id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=idim_input) - call netcdf_err(error, 'reading grid_xt value' ) - - error=nf90_inq_dimid(ncid, 'grid_yt', id_dim) - call netcdf_err(error, 'reading grid_yt id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=jdim_input) - call netcdf_err(error, 'reading grid_yt value' ) - - if (idim_input /= i_input .or. jdim_input /= j_input) then - call error_handler("DIMENSION MISMATCH BETWEEN SFC AND OROG FILES.", 2) - endif - - error=nf90_inq_dimid(ncid, 'pfull', id_dim) - call netcdf_err(error, 'reading pfull id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=lev_input) - call netcdf_err(error, 'reading pfull value' ) - - error=nf90_inq_dimid(ncid, 'phalf', id_dim) - call netcdf_err(error, 'reading phalf id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=levp1_input) - call netcdf_err(error, 'reading phalf value' ) - allocate(phalf(levp1_input)) - error=nf90_inq_varid(ncid, 'phalf', id_var) - call netcdf_err(error, 'getting phalf varid' ) - error=nf90_get_var(ncid, id_var, phalf) - call netcdf_err(error, 'reading phalf varid' ) - - error=nf90_get_att(ncid, nf90_global, 'ncnsto', num_tracers_file) - call netcdf_err(error, 'reading ntracer value' ) - - error = nf90_close(ncid) - - print*,'- FILE HAS ', num_tracers_file, ' TRACERS.' - print*,'- WILL PROCESS ', num_tracers_input, ' TRACERS.' - -!--------------------------------------------------------------------------- -! Initialize esmf atmospheric fields. -!--------------------------------------------------------------------------- - - call init_atm_esmf_fields - - print*,"- CALL FieldCreate FOR INPUT GRID DELTA PRESSURE." - dpres_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lev_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - if (localpet < num_tiles_input_grid) then - allocate(data_one_tile(i_input,j_input)) - allocate(data_one_tile_3d(i_input,j_input,lev_input)) - else - allocate(data_one_tile(0,0)) - allocate(data_one_tile_3d(0,0,0)) - endif - - if (localpet < num_tiles_input_grid) then - tile = localpet+1 - tilefile= trim(data_dir_input_grid) // "/" // trim(atm_files_input_grid(tile)) - print*,"- READ ATMOSPHERIC DATA FROM: ", trim(tilefile) - error=nf90_open(trim(tilefile),nf90_nowrite,ncid) - call netcdf_err(error, 'opening: '//trim(tilefile) ) - endif - - if (localpet < num_tiles_input_grid) then -! print*,"- READ VERTICAL VELOCITY." -! error=nf90_inq_varid(ncid, 'dzdt', id_var) -! call netcdf_err(error, 'reading field id' ) -! error=nf90_get_var(ncid, id_var, data_one_tile_3d) -! call netcdf_err(error, 'reading field' ) -! data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - -! Using w from the tiled history files has caused problems. -! Set to zero. - data_one_tile_3d = 0.0_8 - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID VERTICAL VELOCITY." - call ESMF_FieldScatter(dzdt_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - do n = 1, num_tracers_input - - if (localpet < num_tiles_input_grid) then - print*,"- READ ", trim(tracers_input(n)) - error=nf90_inq_varid(ncid, tracers_input(n), id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile_3d) - call netcdf_err(error, 'reading field' ) - data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID TRACER ", trim(tracers_input(n)) - call ESMF_FieldScatter(tracers_input_grid(n), data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - enddo - - if (localpet < num_tiles_input_grid) then - print*,"- READ TEMPERATURE." - error=nf90_inq_varid(ncid, 'tmp', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile_3d) - call netcdf_err(error, 'reading field' ) - data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." - call ESMF_FieldScatter(temp_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) then - print*,"- READ U-WIND." - error=nf90_inq_varid(ncid, 'ugrd', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile_3d) - call netcdf_err(error, 'reading field' ) - data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID U." - call ESMF_FieldScatter(u_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) then - print*,"- READ V-WIND." - error=nf90_inq_varid(ncid, 'vgrd', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile_3d) - call netcdf_err(error, 'reading field' ) - data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID V." - call ESMF_FieldScatter(v_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) then - print*,"- READ SURFACE PRESSURE." - error=nf90_inq_varid(ncid, 'pressfc', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile) - call netcdf_err(error, 'reading field' ) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID SURFACE PRESSURE." - call ESMF_FieldScatter(ps_input_grid, data_one_tile, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) then - print*,"- READ TERRAIN." - error=nf90_inq_varid(ncid, 'hgtsfc', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile) - call netcdf_err(error, 'reading field' ) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT GRID TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, data_one_tile, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) then - print*,"- READ DELTA PRESSURE." - error=nf90_inq_varid(ncid, 'dpres', id_var) - call netcdf_err(error, 'reading field id' ) - error=nf90_get_var(ncid, id_var, data_one_tile_3d) - call netcdf_err(error, 'reading field' ) - data_one_tile_3d(:,:,1:lev_input) = data_one_tile_3d(:,:,lev_input:1:-1) - endif - - do tile = 1, num_tiles_input_grid - print*,"- CALL FieldScatter FOR INPUT DELTA PRESSURE." - call ESMF_FieldScatter(dpres_input_grid, data_one_tile_3d, rootpet=tile-1, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - enddo - - if (localpet < num_tiles_input_grid) error = nf90_close(ncid) - - deallocate(data_one_tile_3d, data_one_tile) - -!--------------------------------------------------------------------------- -! Convert from 2-d to 3-d cartesian winds. -!--------------------------------------------------------------------------- - - call convert_winds - -!--------------------------------------------------------------------------- -! Compute pressure. -!--------------------------------------------------------------------------- - - print*,"- CALL FieldGet FOR PRESSURE." - call ESMF_FieldGet(pres_input_grid, & - computationalLBound=clb, & - computationalUBound=cub, & - farrayPtr=presptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR DELTA PRESSURE." - call ESMF_FieldGet(dpres_input_grid, & - farrayPtr=dpresptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR SURFACE PRESSURE." - call ESMF_FieldGet(ps_input_grid, & - farrayPtr=psptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - allocate(pres_interface(levp1_input)) - -!--------------------------------------------------------------------------- -! Compute 3-d pressure. -!--------------------------------------------------------------------------- - - do i = clb(1), cub(1) - do j = clb(2), cub(2) - pres_interface(1) = psptr(i,j) - do k = 2, levp1_input - pres_interface(k) = pres_interface(k-1) - dpresptr(i,j,k-1) - enddo - do k = 1, lev_input - presptr(i,j,k) = (pres_interface(k) + pres_interface(k+1)) / 2.0_8 - enddo - enddo - enddo - - deallocate(pres_interface, phalf) - - call ESMF_FieldDestroy(dpres_input_grid, rc=rc) - - end subroutine read_input_atm_tiled_history_file - -!> Read input grid atmospheric fv3gfs grib2 files. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_atm_grib2_file(localpet) - - use mpi - use grib_mod - - use grib2_util, only : rh2spfh, rh2spfh_gfs, convert_omega - - implicit none - - integer, intent(in) :: localpet - - integer, parameter :: ntrac_max=14 - integer, parameter :: max_levs=1000 - - character(len=300) :: the_file - character(len=20) :: vname, & - trac_names_vmap(ntrac_max), & - tmpstr, & - method, tracers_input_vmap(num_tracers_input), & - tracers_default(ntrac_max) - - integer :: i, j, k, n - integer :: ii,jj - integer :: rc, clb(3), cub(3) - integer :: vlev, iret,varnum, o3n, pdt_num - integer :: intrp_ier, done_print - integer :: trac_names_oct10(ntrac_max) - integer :: tracers_input_oct10(num_tracers_input) - integer :: trac_names_oct11(ntrac_max) - integer :: tracers_input_oct11(num_tracers_input) - integer :: lugb, lugi, jdisc, jpdt(200), jgdt(200), iscale - integer :: jids(200), jpdtn, jgdtn, octet_23, octet_29 - integer :: count_spfh, count_rh, count_icmr, count_scliwc - integer :: count_cice, count_rwmr, count_scllwc, count - - logical :: conv_omega=.false., & - hasspfh=.true., & - isnative=.false., & - use_rh=.false. , unpack, & - all_empty, is_missing - - real(esmf_kind_r8), allocatable :: dum2d_1(:,:) - - - real(esmf_kind_r8) :: rlevs_hold(max_levs) - real(esmf_kind_r8), allocatable :: rlevs(:) - real(esmf_kind_r4), allocatable :: dummy2d(:,:) - real(esmf_kind_r8), allocatable :: dummy3d(:,:,:), dummy2d_8(:,:),& - u_tmp_3d(:,:,:), v_tmp_3d(:,:,:) - real(esmf_kind_r8), pointer :: presptr(:,:,:), psptr(:,:),tptr(:,:,:), & - qptr(:,:,:), wptr(:,:,:), & - uptr(:,:,:), vptr(:,:,:) - real(esmf_kind_r4) :: value - real(esmf_kind_r8), parameter :: p0 = 100000.0 - real(esmf_kind_r8), allocatable :: dummy3d_col_in(:),dummy3d_col_out(:) - real(esmf_kind_r8), parameter :: intrp_missing = -999.0 - real(esmf_kind_r4), parameter :: lev_no_tr_fill = 20000.0 - real(esmf_kind_r4), parameter :: lev_no_o3_fill = 40000.0 - - type(gribfield) :: gfld - - tracers(:) = "NULL" - - trac_names_oct10 = (/1, 1, 14, 1, 1, 1, 1, 6, 6, 1, 6, 13, 13, 2 /) - trac_names_oct11 = (/0, 22, 192, 23, 24, 25, 32, 1, 29, 100, 28, 193, 192, 2 /) - - trac_names_vmap = (/"sphum ", "liq_wat ", "o3mr ", "ice_wat ", & - "rainwat ", "snowwat ", "graupel ", "cld_amt ", "ice_nc ", & - "rain_nc ", "water_nc", "liq_aero", "ice_aero", & - "sgs_tke "/) - - tracers_default = (/"sphum ", "liq_wat ", "o3mr ", "ice_wat ", & - "rainwat ", "snowwat ", "graupel ", "cld_amt ", "ice_nc ", & - "rain_nc ", "water_nc", "liq_aero", "ice_aero", & - "sgs_tke "/) - - the_file = trim(data_dir_input_grid) // "/" // trim(grib2_file_input_grid) - - print*,"- READ ATMOS DATA FROM GRIB2 FILE: ", trim(the_file) - - if (localpet == 0) then - - lugb=14 - lugi=0 - call baopenr(lugb,the_file,iret) - if (iret /= 0) call error_handler("ERROR OPENING GRIB2 FILE.", iret) - - jdisc = 0 ! Search for discipline - meteorological products - j = 0 ! Search at beginning of file. - jpdt = -9999 ! Array of values in product definition template, set to wildcard - jids = -9999 ! Array of values in identification section, set to wildcard - jgdt = -9999 ! Array of values in grid definition template, set to wildcard - jgdtn = -1 ! Search for any grid definition number. - jpdtn = -1 ! Search for any product definition template number. - unpack =.false. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - -!---------------------------------------------------------------------- -! Read first record and check if this is NCEP GEFS data. -! This will determine what product definition template number to -! search for (Section 4/Octets 8-9). -! -! Section 1/Octets 6-7 is '7' (NCEP) -! Section 1/Octets 8-9 is '2' (NCEP Ensemble products). -!---------------------------------------------------------------------- - - if (iret == 0) then - if (gfld%idsect(1) == 7 .and. gfld%idsect(2) == 2) then - print*,'- THIS IS NCEP GEFS DATA.' - pdt_num = 1 ! Search for product definition template number 1. - ! Individual ensember forecast. - else - pdt_num = 0 ! Search for product definition template number 0. - ! Analysis or forecast. - endif - else - call error_handler("READING GRIB2 FILE", iret) - endif - -!---------------------------------------------------------------------- -! First, check for the vertical coordinate. If temperture at the 10 hybrid -! level is found, hybrid coordinates are assumed. Otherwise, data is on -! isobaric levels. -!---------------------------------------------------------------------- - - j = 0 - jpdtn = pdt_num ! Search for the specific product definition template number. - jpdt(1) = 0 ! Sect4/oct 10 - Parameter category - temperature field - jpdt(2) = 0 ! Sect4/oct 11 - Parameter number - temperature - jpdt(10) = 105 ! Sect4/oct 23 - Type of level - hybrid - jpdt(12) = 10 ! Sect4/octs 25/28 - Value of hybrid level - unpack=.false. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret == 0) then - print*,'- DATA IS ON HYBRID LEVELS.' - octet_23 = 105 ! Section 4/Oct 23 - type of first fixed surface. - octet_29 = 255 ! Section 4/Oct 29 - type of second fixed surface (N/A). - isnative=.true. - else - print*,'- DATA IS ON ISOBARIC LEVELS.' - octet_23 = 100 ! Section 4/Oct 23 - type of first fixed surface. - octet_29 = 255 ! Section 4/Oct 29 - type of second fixed surface (N/A). - isnative=.false. - endif - -! Now count the number of vertical levels by searching for u-wind. -! Store the value of each level. - - rlevs_hold = -999.9 - lev_input = 0 - iret = 0 - j = 0 - jpdtn = -1 - jpdt = -9999 - - do - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret /= 0) exit - - if (gfld%discipline == 0) then ! Discipline - meteorological products - if (gfld%ipdtnum == pdt_num) then ! Product definition template number. - if (gfld%ipdtmpl(1) == 2 .and. gfld%ipdtmpl(2) == 2) then ! u-wind - ! Sect4/octs 10 and 11. - if (gfld%ipdtmpl(10) == octet_23 .and. gfld%ipdtmpl(13) == octet_29) then - ! Sect4 octs 23 and 29. - ! Hybrid or isobaric. - lev_input = lev_input + 1 - iscale = 10 ** gfld%ipdtmpl(11) - rlevs_hold(lev_input) = float(gfld%ipdtmpl(12))/float(iscale) - endif - endif - endif - endif - - j = k - enddo - - endif ! read file on task 0. - - call mpi_barrier(MPI_COMM_WORLD, iret) - call MPI_BCAST(isnative,1,MPI_LOGICAL,0,MPI_COMM_WORLD,iret) - call MPI_BCAST(lev_input,1,MPI_INTEGER,0,MPI_COMM_WORLD,iret) - call MPI_BCAST(pdt_num,1,MPI_INTEGER,0,MPI_COMM_WORLD,iret) - call MPI_BCAST(rlevs_hold, max_levs, MPI_INTEGER,0,MPI_COMM_WORLD,iret) - - allocate(slevs(lev_input)) - allocate(rlevs(lev_input)) - allocate(dummy3d_col_in(lev_input)) - allocate(dummy3d_col_out(lev_input)) - - levp1_input = lev_input + 1 - -! Jili Dong add sort to re-order isobaric levels. - - do i = 1, lev_input - rlevs(i) = rlevs_hold(i) - enddo - - call quicksort(rlevs,1,lev_input) - - do i = 1, lev_input - if (isnative) then - write(slevs(i), '(i6)') nint(rlevs(i)) - slevs(i) = trim(slevs(i)) // " hybrid" - else - write(slevs(i), '(f11.2)') rlevs(i) - slevs(i) = trim(slevs(i)) // " Pa" - endif - enddo - - if(localpet == 0) then - do i = 1,lev_input - print*, "- LEVEL AFTER SORT = ",trim(slevs(i)) - enddo - endif - -! Check to see if specfic humidity exists at all the same levels as ugrd. - - if (localpet == 0) then - - jpdtn = pdt_num ! Product definition template number. - jpdt = -9999 - jpdt(1) = 1 ! Sect4/oct 10 - Parameter category - moisture - jpdt(2) = 0 ! Sect4/oct 11 - Parameter number - specific humidity - jpdt(10) = octet_23 ! Sect4/oct 23 - type of level. - unpack=.false. - - count_spfh=0 - - do vlev = 1, lev_input - j = 0 - jpdt(12) = nint(rlevs(vlev)) - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret == 0) then - count_spfh = count_spfh + 1 - endif - enddo - - jpdt(1) = 1 ! Sec4/oct 10 - Parameter category - moisture - jpdt(2) = 1 ! Sec4/oct 11 - Parameter number - rel humidity - count_rh=0 - - do vlev = 1, lev_input - j = 0 - jpdt(12) = nint(rlevs(vlev)) - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret == 0) then - count_rh = count_rh + 1 - endif - enddo - - if (count_spfh /= lev_input) then - use_rh = .true. - endif - - if (count_spfh == 0 .or. use_rh) then - if (count_rh == 0) then - call error_handler("READING ATMOSPHERIC WATER VAPOR VARIABLE.", 2) - endif - hasspfh = .false. ! Will read rh and convert to specific humidity. - trac_names_oct10(1) = 1 - trac_names_oct11(1) = 1 - print*,"- FILE CONTAINS RH." - else - print*,"- FILE CONTAINS SPFH." - endif - - endif - - call MPI_BARRIER(MPI_COMM_WORLD, rc) - call MPI_BCAST(hasspfh,1,MPI_LOGICAL,0,MPI_COMM_WORLD,rc) - -! Search for and count the number of tracers in the file. - - if (localpet == 0) then - - jpdtn = pdt_num ! Product definition template number. - jpdt = -9999 - jpdt(10) = octet_23 ! Sect4/oct 23 - type of level. - unpack=.false. - - count_icmr=0 - count_scliwc=0 - count_cice=0 - count_rwmr=0 - count_scllwc=0 - - do vlev = 1, lev_input - - j = 0 - jpdt(1) = 1 ! Sect4/oct 10 - Parameter category - moisture - jpdt(2) = 23 ! Sect4/oct 11 - Parameter number - ice water mixing ratio - jpdt(12) = nint(rlevs(vlev)) - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret == 0) then - count_icmr = count_icmr + 1 - endif - - j = 0 - jpdt(1) = 1 ! Sect4/oct 10 - Parameter category - moisture - jpdt(2) = 84 ! Sect4/oct 11 - Parameter number - cloud ice water content. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret == 0) then - count_scliwc = count_scliwc + 1 - endif - - j = 0 - jpdt(1) = 6 ! Sect4/oct 10 - Parameter category - clouds - jpdt(2) = 0 ! Sect4/oct 11 - Parameter number - cloud ice - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret == 0) then - count_cice = count_cice + 1 - endif - - j = 0 - jpdt(1) = 1 ! Sect4/oct 10 - Parameter category - moisture - jpdt(2) = 24 ! Sect4/oct 11 - Parameter number - rain mixing ratio - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret == 0) then - count_rwmr = count_rwmr + 1 - endif - - j = 0 - jpdt(1) = 1 ! Sect4/oct 10 - Parameter category - moisture - jpdt(2) = 83 ! Sect4/oct 11 - Parameter number - specific cloud liquid - ! water content. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret == 0) then - count_scllwc = count_scllwc + 1 - endif - - enddo - - if (count_icmr == 0) then - if (count_scliwc == 0) then - if (count_cice == 0) then - print*,'- FILE DOES NOT CONTAIN CICE.' - else - trac_names_oct10(4) = 6 ! Sect4/oct 10 - Parameter category - clouds - trac_names_oct11(4) = 0 ! Sect4/oct 11 - Parameter number - cloud ice - print*,"- FILE CONTAINS CICE." - endif - else - trac_names_oct10(4) = 1 ! Sect4/oct 10 - Parameter category - moisture - trac_names_oct11(4) = 84 ! Sect4/oct 11 - Parameter number - cloud ice water content. - print*,"- FILE CONTAINS SCLIWC." - endif - else - print*,"- FILE CONTAINS ICMR." - endif ! count of icmr - - if (count_rwmr == 0) then - if (count_scllwc == 0) then - print*,"- FILE DOES NOT CONTAIN SCLLWC." - else - trac_names_oct10(4) = 1 ! Sect4/oct 10 - Parameter category - moisture - trac_names_oct11(4) = 83 ! Sect4/oct 11 - Parameter number - specific cloud liquid - ! water content. - print*,"- FILE CONTAINS SCLLWC." - endif - else - print*,"- FILE CONTAINS CLWMR." - endif - - endif ! count of tracers/localpet = 0 - - call MPI_BARRIER(MPI_COMM_WORLD, rc) - call MPI_BCAST(trac_names_oct10,ntrac_max,MPI_INTEGER,0,MPI_COMM_WORLD,rc) - call MPI_BCAST(trac_names_oct11,ntrac_max,MPI_INTEGER,0,MPI_COMM_WORLD,rc) - - print*,"- COUNT NUMBER OF TRACERS TO BE READ IN BASED ON PHYSICS SUITE TABLE" - do n = 1, num_tracers_input - - vname = tracers_input(n) - - i = maxloc(merge(1.,0.,trac_names_vmap == vname),dim=1) - - tracers_input_vmap(n)=trac_names_vmap(i) - tracers(n)=tracers_default(i) - if(trim(tracers(n)) .eq. "o3mr") o3n = n - - tracers_input_oct10(n) = trac_names_oct10(i) - tracers_input_oct11(n) = trac_names_oct11(i) - - enddo - -!--------------------------------------------------------------------------- -! Initialize esmf atmospheric fields. -!--------------------------------------------------------------------------- - - call init_atm_esmf_fields - - if (localpet == 0) then - allocate(dummy2d(i_input,j_input)) - allocate(dummy2d_8(i_input,j_input)) - allocate(dummy3d(i_input,j_input,lev_input)) - allocate(dum2d_1(i_input,j_input)) - else - allocate(dummy2d(0,0)) - allocate(dummy2d_8(0,0)) - allocate(dummy3d(0,0,0)) - allocate(dum2d_1(0,0)) - endif - -!---------------------------------------------------------------------------------- -! This program expects field levels from bottom to top. Fields in non-native -! files read in from top to bottom. We will flip indices later. Fields on -! native vertical coordinates read from bottom to top so those need no adjustments. -!---------------------------------------------------------------------------------- - - if (localpet == 0) then - - print*,"- READ TEMPERATURE." - - jdisc = 0 ! search for discipline - meteorological products - j = 0 ! search at beginning of file. - jpdt = -9999 ! array of values in product definition template, set to wildcard - jids = -9999 ! array of values in identification section, set to wildcard - jgdt = -9999 ! array of values in grid definition template, set to wildcard - jgdtn = -1 ! search for any grid definition number. - jpdtn = pdt_num ! Search for specific product definition template number. - jpdt(1) = 0 ! Sect 4/oct 10 - parameter category - temperature - jpdt(2) = 0 ! Sect 4/oct 11 - parameter number - temperature - jpdt(10) = octet_23 ! Sect4/oct 23 - type of level. - - unpack=.true. - - do vlev = 1, lev_input - - jpdt(12) = nint(rlevs(vlev)) - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - if (iret /= 0) then - call error_handler("READING IN TEMPERATURE AT LEVEL "//trim(slevs(vlev)),iret) - endif - - dum2d_1 = reshape(gfld%fld, (/i_input,j_input/) ) - - dummy3d(:,:,vlev) = dum2d_1 - - enddo - - endif ! Read of temperature - - if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT GRID TEMPERATURE." - call ESMF_FieldScatter(temp_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Read tracers - - do n = 1, num_tracers_input - - if (localpet == 0) print*,"- READ ", trim(tracers_input_vmap(n)) - - vname = tracers_input_vmap(n) - call get_var_cond(vname,this_miss_var_method=method, this_miss_var_value=value, & - this_field_var_name=tmpstr,loc=varnum) - - if (n==1 .and. .not. hasspfh) then - print*,"- CALL FieldGather TEMPERATURE." - call ESMF_FieldGather(temp_input_grid,dummy3d,rootPet=0, tile=1, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - endif - - if (localpet == 0) then - - jdisc = 0 ! search for discipline - meteorological products - jpdt = -9999 ! array of values in product definition template, set to wildcard - jids = -9999 ! array of values in identification section, set to wildcard - jgdt = -9999 ! array of values in grid definition template, set to wildcard - jgdtn = -1 ! search for any grid definition number. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt(10) = octet_23 ! Sect4/oct 23 - type of level. - unpack = .false. - - count = 0 - - do vlev = 1, lev_input - - j = 0 - jpdt(1) = tracers_input_oct10(n) - jpdt(2) = tracers_input_oct11(n) - jpdt(12) = nint(rlevs(vlev)) - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret == 0) then - count = count + 1 - endif - - enddo - iret=count - - ! Check to see if file has any data for this tracer - if (iret == 0) then - all_empty = .true. - else - all_empty = .false. - endif - - is_missing = .false. - - do vlev = 1, lev_input - - unpack=.true. - j = 0 - jpdt(1) = tracers_input_oct10(n) - jpdt(2) = tracers_input_oct11(n) - jpdt(12) = nint(rlevs(vlev) ) - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret == 0) then ! found data - dummy2d = reshape(gfld%fld, (/i_input,j_input/) ) - else ! did not find data. - if (trim(method) .eq. 'intrp' .and. .not.all_empty) then - dummy2d = intrp_missing - is_missing = .true. - else - ! Abort if input data has some data for current tracer, but has - ! missing data below 200 mb/ above 400mb - if (.not.all_empty .and. n == o3n) then - if (rlevs(vlev) .lt. lev_no_o3_fill) & - call error_handler("TRACER "//trim(tracers(n))//" HAS MISSING DATA AT "//trim(slevs(vlev))//& - ". SET MISSING VARIABLE CONDITION TO 'INTRP' TO AVOID THIS ERROR", 1) - elseif (.not.all_empty .and. n .ne. o3n) then - if (rlevs(vlev) .gt. lev_no_tr_fill) & - call error_handler("TRACER "//trim(tracers(n))//" HAS MISSING DATA AT "//trim(slevs(vlev))//& - ". SET MISSING VARIABLE CONDITION TO 'INTRP' TO AVOID THIS ERROR.", 1) - endif - ! If entire array is empty and method is set to intrp, switch method to fill - if (trim(method) .eq. 'intrp' .and. all_empty) method='set_to_fill' - - call handle_grib_error(vname, slevs(vlev),method,value,varnum,iret,var=dummy2d) - if (iret==1) then ! missing_var_method == skip or no entry - if ( (tracers_input_oct10(n) == 1 .and. tracers_input_oct11(n) == 0) .or. & ! spec humidity - (tracers_input_oct10(n) == 1 .and. tracers_input_oct11(n) == 1) .or. & ! rel humidity - (tracers_input_oct10(n) == 14 .and. tracers_input_oct11(n) == 192) ) then ! ozone - call error_handler("READING IN "//trim(tracers(n))//" AT LEVEL "//trim(slevs(vlev))& - //". SET A FILL VALUE IN THE VARMAP TABLE IF THIS ERROR IS NOT DESIRABLE.",iret) - endif - endif - endif ! method intrp - endif !iret<=0 - - if (n==1 .and. .not. hasspfh) then - if (trim(external_model) .eq. 'GFS') then - print *,'- CALL CALRH GFS' - call rh2spfh_gfs(dummy2d,rlevs(vlev),dummy3d(:,:,vlev)) - else - print *,'- CALL CALRH non-GFS' - call rh2spfh(dummy2d,rlevs(vlev),dummy3d(:,:,vlev)) - end if - endif - - dummy3d(:,:,vlev) = real(dummy2d,esmf_kind_r8) - - enddo !vlev - -! Jili Dong interpolation for missing levels - if (is_missing .and. trim(method) .eq. 'intrp') then - print *,'- INTERPOLATE TRACER '//trim(tracers(n)) - done_print = 0 - do jj = 1, j_input - do ii = 1, i_input - dummy3d_col_in=dummy3d(ii,jj,:) - call dint2p(rlevs,dummy3d_col_in,lev_input,rlevs,dummy3d_col_out, & - lev_input, 2, intrp_missing, intrp_ier) - if (intrp_ier .gt. 0) call error_handler("Interpolation failed.",intrp_ier) - dummy3d(ii,jj,:)=dummy3d_col_out - enddo - enddo - do vlev=1,lev_input - dummy2d = dummy3d(:,:,n) - if (any(dummy2d .eq. intrp_missing)) then - ! If we're outside the appropriate region, don't fill but error instead - if (n == o3n .and. rlevs(vlev) .lt. lev_no_o3_fill) then - call error_handler("TRACER "//trim(tracers(n))//" HAS MISSING DATA AT "//trim(slevs(vlev)),1) - elseif (n .ne. o3n .and. rlevs(vlev) .gt. lev_no_tr_fill) then - call error_handler("TRACER "//trim(tracers(n))//" HAS MISSING DATA AT "//trim(slevs(vlev)),1) - else ! we're okay to fill missing data with provided fill value - if (done_print .eq. 0) then - print*, "Pressure out of range of existing data. Defaulting to fill value." - done_print = 1 - end if !done print - where(dummy2d .eq. intrp_missing) dummy2d = value - dummy3d(:,:,vlev) = dummy2d - end if !n & lev - endif ! intrp_missing - ! zero out negative tracers from interpolation/extrapolation - where(dummy3d(:,:,vlev) .lt. 0.0) dummy3d(:,:,vlev) = 0.0 -! print*,'tracer af intrp',vlev, maxval(dummy3d(:,:,vlev)),minval(dummy3d(:,:,vlev)) - end do !nlevs do - end if !if intrp - endif !localpet == 0 - - if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT ", trim(tracers_input_vmap(n)) - call ESMF_FieldScatter(tracers_input_grid(n), dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - enddo - - deallocate(dummy3d_col_in, dummy3d_col_out) - - call read_winds(u_tmp_3d,v_tmp_3d,localpet,octet_23,rlevs,lugb,pdt_num) - - if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT U-WIND." - call ESMF_FieldScatter(u_input_grid, u_tmp_3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT V-WIND." - call ESMF_FieldScatter(v_input_grid, v_tmp_3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ SURFACE PRESSURE." - jdisc = 0 ! search for discipline - meteorological products - j = 0 ! search at beginning of file. - jpdt = -9999 ! array of values in product definition template, set to wildcard - jids = -9999 ! array of values in identification section, set to wildcard - jgdt = -9999 ! array of values in grid definition template, set to wildcard - jgdtn = -1 ! search for any grid definition number. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt(1) = 3 ! Sect4/oct 10 - param category - mass - jpdt(2) = 0 ! Sect4/oct 11 - param number - pressure - jpdt(10) = 1 ! Sect4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - if (iret /= 0) call error_handler("READING SURFACE PRESSURE RECORD.", iret) - - dummy2d_8 = reshape(gfld%fld, (/i_input,j_input/) ) - - endif ! Read surface pressure - - if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT GRID SURFACE PRESSURE." - call ESMF_FieldScatter(ps_input_grid, dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Read dzdt. - - if (localpet == 0) then - - print*,"- READ DZDT." - vname = "dzdt" - call get_var_cond(vname,this_miss_var_method=method, this_miss_var_value=value, & - loc=varnum) - - jdisc = 0 ! search for discipline - meteorological products - j = 0 ! search at beginning of file. - jpdt = -9999 ! array of values in product definition template, set to wildcard - jids = -9999 ! array of values in identification section, set to wildcard - jgdt = -9999 ! array of values in grid definition template, set to wildcard - jgdtn = -1 ! search for any grid definition number. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt(1) = 2 ! Sect4/oct 10 - param category - momentum - jpdt(2) = 9 ! Sect4/oct 11 - param number - dzdt - jpdt(10) = octet_23 ! Sect4/oct 23 - type of level - - unpack=.true. - - do vlev = 1, lev_input - - jpdt(12) = nint(rlevs(vlev)) - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret /= 0) then ! dzdt not found, look for omega. - print*,"DZDT not available at level ", trim(slevs(vlev)), " so checking for VVEL" - jpdt(2) = 8 ! Sect4/oct 11 - parameter number - omega - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - if (iret /= 0) then - call handle_grib_error(vname, slevs(vlev),method,value,varnum,iret,var8=dum2d_1) - if (iret==1) then ! missing_var_method == skip - cycle - endif - else - conv_omega = .true. - dum2d_1 = reshape(gfld%fld, (/i_input,j_input/) ) - endif - else ! found dzdt - dum2d_1 = reshape(gfld%fld, (/i_input,j_input/) ) - endif - - dummy3d(:,:,vlev) = dum2d_1 - - enddo - - endif ! Read of dzdt - - call mpi_bcast(conv_omega,1,MPI_LOGICAL,0,MPI_COMM_WORLD,rc) - - if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT DZDT." - call ESMF_FieldScatter(dzdt_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Read terrain - - if (localpet == 0) then - - print*,"- READ TERRAIN." - jdisc = 0 ! search for discipline - meteorological products - j = 0 ! search at beginning of file. - jpdt = -9999 ! array of values in product definition template, set to wildcard - jids = -9999 ! array of values in identification section, set to wildcard - jgdt = -9999 ! array of values in grid definition template, set to wildcard - jgdtn = -1 ! search for any grid definition number. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt(1) = 3 ! Sect4/oct 10 - param category - mass - jpdt(2) = 5 ! Sect4/oct 11 - param number - geopotential height - jpdt(10) = 1 ! Sect4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - if (iret /= 0) call error_handler("READING TERRAIN HEIGHT RECORD.", iret) - - dummy2d_8 = reshape(gfld%fld, (/i_input,j_input/) ) - - endif ! read of terrain. - - if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT GRID TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - deallocate(dummy2d, dummy2d_8) - -if (.not. isnative) then - - !--------------------------------------------------------------------------- - ! Flip 'z' indices to all 3-d variables. Data is read in from model - ! top to surface. This program expects surface to model top. - !--------------------------------------------------------------------------- - - if (localpet == 0) print*,"- CALL FieldGet FOR SURFACE PRESSURE." - nullify(psptr) - call ESMF_FieldGet(ps_input_grid, & - farrayPtr=psptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - nullify(presptr) - if (localpet == 0) print*,"- CALL FieldGet FOR 3-D PRESSURE." - call ESMF_FieldGet(pres_input_grid, & - computationalLBound=clb, & - computationalUBound=cub, & - farrayPtr=presptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - nullify(tptr) - if (localpet == 0) print*,"- CALL FieldGet TEMPERATURE." - call ESMF_FieldGet(temp_input_grid, & - farrayPtr=tptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - nullify(uptr) - if (localpet == 0) print*,"- CALL FieldGet FOR U" - call ESMF_FieldGet(u_input_grid, & - farrayPtr=uptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - nullify(vptr) - if (localpet == 0) print*,"- CALL FieldGet FOR V" - call ESMF_FieldGet(v_input_grid, & - farrayPtr=vptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - nullify(wptr) - if (localpet == 0) print*,"- CALL FieldGet FOR W" - call ESMF_FieldGet(dzdt_input_grid, & - farrayPtr=wptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - if (localpet == 0) print*,"- CALL FieldGet FOR TRACERS." - do n=1,num_tracers_input - nullify(qptr) - call ESMF_FieldGet(tracers_input_grid(n), & - farrayPtr=qptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - do i = clb(1),cub(1) - do j = clb(2),cub(2) - qptr(i,j,:) = qptr(i,j,lev_input:1:-1) - end do - end do - end do - - do i = clb(1),cub(1) - do j = clb(2),cub(2) - presptr(i,j,:) = rlevs(lev_input:1:-1) - tptr(i,j,:) = tptr(i,j,lev_input:1:-1) - uptr(i,j,:) = uptr(i,j,lev_input:1:-1) - vptr(i,j,:) = vptr(i,j,lev_input:1:-1) - wptr(i,j,:) = wptr(i,j,lev_input:1:-1) - end do - end do - - if (localpet == 0) then - print*,'psfc is ',clb(1),clb(2),psptr(clb(1),clb(2)) - print*,'pres is ',cub(1),cub(2),presptr(cub(1),cub(2),:) - - print*,'pres check 1',localpet,maxval(presptr(clb(1):cub(1),clb(2):cub(2),1)), & - minval(presptr(clb(1):cub(1),clb(2):cub(2),1)) - print*,'pres check lev',localpet,maxval(presptr(clb(1):cub(1),clb(2):cub(2), & - lev_input)),minval(presptr(clb(1):cub(1),clb(2):cub(2),lev_input)) - endif - -else ! is native coordinate (hybrid). - -! For native files, read in pressure field directly from file but don't flip levels - - if (localpet == 0) then - - print*,"- READ PRESSURE." - - jdisc = 0 ! search for discipline - meteorological products - j = 0 ! search at beginning of file. - jpdt = -9999 ! array of values in product definition template, set to wildcard - jids = -9999 ! array of values in identification section, set to wildcard - jgdt = -9999 ! array of values in grid definition template, set to wildcard - jgdtn = -1 ! search for any grid definition number. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt(1) = 3 ! Sect4/oct 10 - parameter category - mass - jpdt(2) = 0 ! Sect4/oct 11 - parameter number - pressure - jpdt(10) = octet_23 ! Sect4/oct 23 - type of level. - unpack=.true. - - do vlev = 1, lev_input - - jpdt(12) = nint(rlevs(vlev)) - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - if (iret /= 0) then - call error_handler("READING IN PRESSURE AT LEVEL "//trim(slevs(vlev)),iret) - endif - - dum2d_1 = reshape(gfld%fld, (/i_input,j_input/) ) - - dummy3d(:,:,vlev) = dum2d_1 - - enddo - - endif ! localpet == 0 - - if (localpet == 0) print*,"- CALL FieldScatter FOR INPUT GRID PRESSURE." - call ESMF_FieldScatter(pres_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - endif - - deallocate(dummy3d, dum2d_1) - -!--------------------------------------------------------------------------- -! Convert from 2-d to 3-d component winds. -!--------------------------------------------------------------------------- - - call convert_winds - -!--------------------------------------------------------------------------- -! Convert dpdt to dzdt if needed -!--------------------------------------------------------------------------- - - if (conv_omega) then - - if (localpet == 0) print*,"- CONVERT FROM OMEGA TO DZDT." - - nullify(tptr) - if (localpet == 0) print*,"- CALL FieldGet TEMPERATURE." - call ESMF_FieldGet(temp_input_grid, & - farrayPtr=tptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - nullify(qptr) - if (localpet == 0) print*,"- CALL FieldGet SPECIFIC HUMIDITY." - call ESMF_FieldGet(tracers_input_grid(1), & - computationalLBound=clb, & - computationalUBound=cub, & - farrayPtr=qptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - nullify(wptr) - if (localpet == 0) print*,"- CALL FieldGet DZDT." - call ESMF_FieldGet(dzdt_input_grid, & - computationalLBound=clb, & - computationalUBound=cub, & - farrayPtr=wptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - nullify(presptr) - call ESMF_FieldGet(pres_input_grid, & - farrayPtr=presptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - call convert_omega(wptr,presptr,tptr,qptr,clb,cub) - - endif - - if (localpet == 0) call baclose(lugb, rc) - - end subroutine read_input_atm_grib2_file - -!> Read input grid surface data from a spectral gfs gaussian sfcio -!! file. -!! -!! @note Prior to July 19, 2017. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_sfc_gfs_sfcio_file(localpet) - - use sfcio_module - - implicit none - - integer, intent(in) :: localpet - - character(len=300) :: the_file - - integer(sfcio_intkind) :: iret - integer :: rc - - real(esmf_kind_r8), allocatable :: dummy2d(:,:) - real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) - - type(sfcio_head) :: sfchead - type(sfcio_dbta) :: sfcdata - - the_file = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) - - print*,"- READ SURFACE DATA IN SFCIO FORMAT." - print*,"- OPEN AND READ: ",trim(the_file) - call sfcio_sropen(23, trim(the_file), iret) - if (iret /= 0) then - rc=iret - call error_handler("OPENING FILE", rc) - endif - - call sfcio_srhead(23, sfchead, iret) - if (iret /= 0) then - rc=iret - call error_handler("READING HEADER", rc) - endif - - if (localpet == 0) then - call sfcio_aldbta(sfchead, sfcdata, iret) - if (iret /= 0) then - rc=iret - call error_handler("ALLOCATING DATA.", rc) - endif - call sfcio_srdbta(23, sfchead, sfcdata, iret) - if (iret /= 0) then - rc=iret - call error_handler("READING DATA.", rc) - endif - allocate(dummy2d(i_input,j_input)) - allocate(dummy3d(i_input,j_input,lsoil_input)) - else - allocate(dummy2d(0,0)) - allocate(dummy3d(0,0,0)) - endif - - if (localpet == 0) dummy2d = sfcdata%slmsk - - print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." - call ESMF_FieldScatter(landsea_mask_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%zorl - - print*,"- CALL FieldScatter FOR INPUT Z0." - call ESMF_FieldScatter(z0_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = nint(sfcdata%vtype) - - print*,"- CALL FieldScatter FOR INPUT VEG TYPE." - call ESMF_FieldScatter(veg_type_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Prior to July, 2017, gfs used zobler soil types. '13' indicates permanent land ice. - veg_type_landice_input = 13 - - if (localpet == 0) dummy2d = sfcdata%canopy - - print*,"- CALL FieldScatter FOR INPUT CANOPY MC." - call ESMF_FieldScatter(canopy_mc_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%fice - - print*,"- CALL FieldScatter FOR INPUT ICE FRACTION." - call ESMF_FieldScatter(seaice_fract_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%hice - - print*,"- CALL FieldScatter FOR INPUT ICE DEPTH." - call ESMF_FieldScatter(seaice_depth_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%tisfc - - print*,"- CALL FieldScatter FOR INPUT ICE SKIN TEMP." - call ESMF_FieldScatter(seaice_skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%snwdph ! mm (expected by program) - - print*,"- CALL FieldScatter FOR INPUT SNOW DEPTH." - call ESMF_FieldScatter(snow_depth_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%sheleg - - print*,"- CALL FieldScatter FOR INPUT SNOW LIQUID EQUIV." - call ESMF_FieldScatter(snow_liq_equiv_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%t2m - - print*,"- CALL FieldScatter FOR INPUT T2M." - call ESMF_FieldScatter(t2m_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%q2m - - print*,"- CALL FieldScatter FOR INPUT Q2M." - call ESMF_FieldScatter(q2m_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%tprcp - - print*,"- CALL FieldScatter FOR INPUT TPRCP." - call ESMF_FieldScatter(tprcp_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%f10m - - print*,"- CALL FieldScatter FOR INPUT F10M." - call ESMF_FieldScatter(f10m_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%uustar - - print*,"- CALL FieldScatter FOR INPUT USTAR." - call ESMF_FieldScatter(ustar_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%ffmm - - print*,"- CALL FieldScatter FOR INPUT FFMM." - call ESMF_FieldScatter(ffmm_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%srflag - - print*,"- CALL FieldScatter FOR INPUT SRFLAG." - call ESMF_FieldScatter(srflag_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%tsea - - print*,"- CALL FieldScatter FOR INPUT SKIN TEMP." - call ESMF_FieldScatter(skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = nint(sfcdata%stype) - - print*,"- CALL FieldScatter FOR INPUT SOIL TYPE." - call ESMF_FieldScatter(soil_type_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = sfcdata%orog - - print*,"- CALL FieldScatter FOR INPUT TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy3d = sfcdata%slc - - print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." - call ESMF_FieldScatter(soilm_liq_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy3d = sfcdata%smc - - print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." - call ESMF_FieldScatter(soilm_tot_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy3d = sfcdata%stc - - print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." - call ESMF_FieldScatter(soil_temp_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - deallocate(dummy2d, dummy3d) - call sfcio_axdbta(sfcdata, iret) - - call sfcio_sclose(23, iret) - - end subroutine read_input_sfc_gfs_sfcio_file - -!> Read input grid surface data from a spectral gfs gaussian nemsio -!! file. -!! -!! @note Format used by gfs starting July 19, 2017. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_sfc_gfs_gaussian_nemsio_file(localpet) - - implicit none - - integer, intent(in) :: localpet - - character(len=300) :: the_file - - integer :: rc - - real(nemsio_realkind), allocatable :: dummy(:) - real(esmf_kind_r8), allocatable :: dummy2d(:,:) - real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) - - type(nemsio_gfile) :: gfile - - the_file = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) - - if (localpet == 0) then - allocate(dummy3d(i_input,j_input,lsoil_input)) - allocate(dummy2d(i_input,j_input)) - allocate(dummy(i_input*j_input)) - print*,"- OPEN FILE ", trim(the_file) - call nemsio_open(gfile, the_file, "read", iret=rc) - if (rc /= 0) call error_handler("OPENING FILE.", rc) - else - allocate(dummy3d(0,0,0)) - allocate(dummy2d(0,0)) - allocate(dummy(0)) - endif - - if (localpet == 0) then - print*,"- READ TERRAIN." - call nemsio_readrecv(gfile, "orog", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING TERRAIN.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'orog ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ LANDSEA MASK." - call nemsio_readrecv(gfile, "land", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LANDSEA MASK.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'landmask ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." - call ESMF_FieldScatter(landsea_mask_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SEAICE FRACTION." - call nemsio_readrecv(gfile, "icec", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SEAICE FRACTION.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'icec ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE FRACTION." - call ESMF_FieldScatter(seaice_fract_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SEAICE DEPTH." - call nemsio_readrecv(gfile, "icetk", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SEAICE DEPTH.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'icetk ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE DEPTH." - call ESMF_FieldScatter(seaice_depth_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SEAICE SKIN TEMPERATURE." - call nemsio_readrecv(gfile, "tisfc", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SEAICE SKIN TEMP.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'ti ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE SKIN TEMPERATURE." - call ESMF_FieldScatter(seaice_skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SNOW LIQUID EQUIVALENT." - call nemsio_readrecv(gfile, "weasd", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SNOW LIQUID EQUIVALENT.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'weasd ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SNOW LIQUID EQUIVALENT." - call ESMF_FieldScatter(snow_liq_equiv_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SNOW DEPTH." - call nemsio_readrecv(gfile, "snod", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SNOW DEPTH.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'snod ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SNOW DEPTH." - call ESMF_FieldScatter(snow_depth_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ VEG TYPE." - call nemsio_readrecv(gfile, "vtype", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING VEG TYPE", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'vtype ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID VEG TYPE." - call ESMF_FieldScatter(veg_type_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SOIL TYPE." - call nemsio_readrecv(gfile, "sotyp", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SOIL TYPE.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'sotype ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SOIL TYPE." - call ESMF_FieldScatter(soil_type_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ T2M." - call nemsio_readrecv(gfile, "tmp", "2 m above gnd", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING T2M.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'t2m ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID T2M." - call ESMF_FieldScatter(t2m_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ Q2M." - call nemsio_readrecv(gfile, "spfh", "2 m above gnd", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING Q2M.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'q2m ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID Q2M." - call ESMF_FieldScatter(q2m_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ TPRCP." - call nemsio_readrecv(gfile, "tprcp", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING TPRCP.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'tprcp ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID TPRCP." - call ESMF_FieldScatter(tprcp_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ FFMM." - call nemsio_readrecv(gfile, "ffmm", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING FFMM.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'ffmm ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID FFMM" - call ESMF_FieldScatter(ffmm_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ USTAR." - call nemsio_readrecv(gfile, "fricv", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING USTAR.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'fricv ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID USTAR" - call ESMF_FieldScatter(ustar_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = 0.0 - print*,"- CALL FieldScatter FOR INPUT GRID SRFLAG" - call ESMF_FieldScatter(srflag_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SKIN TEMPERATURE." - call nemsio_readrecv(gfile, "tmp", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SKIN TEMPERATURE.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'tmp ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SKIN TEMPERATURE" - call ESMF_FieldScatter(skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ F10M." - call nemsio_readrecv(gfile, "f10m", "10 m above gnd", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING F10M.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'f10m ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID F10M." - call ESMF_FieldScatter(f10m_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ CANOPY MOISTURE CONTENT." - call nemsio_readrecv(gfile, "cnwat", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING CANOPY MOISTURE CONTENT.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'cnwat ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID CANOPY MOISTURE CONTENT." - call ESMF_FieldScatter(canopy_mc_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ Z0." - call nemsio_readrecv(gfile, "sfcr", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING Z0.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'sfcr ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID Z0." - call ESMF_FieldScatter(z0_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - deallocate(dummy2d) - - if (localpet == 0) then - print*,"- READ LIQUID SOIL MOISTURE." - call nemsio_readrecv(gfile, "slc", "soil layer", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 1 LIQUID SOIL MOIST.", rc) - dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "slc", "soil layer", 2, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 2 LIQUID SOIL MOIST.", rc) - dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "slc", "soil layer", 3, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 3 LIQUID SOIL MOIST.", rc) - dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "slc", "soil layer", 4, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 4 LIQUID SOIL MOIST.", rc) - dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) - print*,'slc ',maxval(dummy3d),minval(dummy3d) - endif - - print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." - call ESMF_FieldScatter(soilm_liq_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ TOTAL SOIL MOISTURE." - call nemsio_readrecv(gfile, "smc", "soil layer", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 1 TOTAL SOIL MOIST.", rc) - dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "smc", "soil layer", 2, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 2 TOTAL SOIL MOIST.", rc) - dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "smc", "soil layer", 3, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 3 TOTAL SOIL MOIST.", rc) - dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "smc", "soil layer", 4, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 4 TOTAL SOIL MOIST.", rc) - dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) - print*,'smc ',maxval(dummy3d),minval(dummy3d) - endif - - print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." - call ESMF_FieldScatter(soilm_tot_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SOIL TEMPERATURE." - call nemsio_readrecv(gfile, "stc", "soil layer", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 1 SOIL TEMP.", rc) - dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "stc", "soil layer", 2, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 2 SOIL TEMP.", rc) - dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "stc", "soil layer", 3, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 3 SOIL TEMP.", rc) - dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "stc", "soil layer", 4, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 4 SOIL TEMP.", rc) - dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) - print*,'stc ',maxval(dummy3d),minval(dummy3d) - endif - - print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." - call ESMF_FieldScatter(soil_temp_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - deallocate(dummy3d, dummy) - - if (localpet == 0) call nemsio_close(gfile) - - end subroutine read_input_sfc_gfs_gaussian_nemsio_file - -!> Read input grid surface data from an fv3 gaussian nemsio file. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_sfc_gaussian_nemsio_file(localpet) - - implicit none - - integer, intent(in) :: localpet - - character(len=250) :: the_file - - integer :: rc - - real(nemsio_realkind), allocatable :: dummy(:) - real(esmf_kind_r8), allocatable :: dummy2d(:,:) - real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) - - type(nemsio_gfile) :: gfile - - the_file = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) - - if (localpet == 0) then - allocate(dummy3d(i_input,j_input,lsoil_input)) - allocate(dummy2d(i_input,j_input)) - allocate(dummy(i_input*j_input)) - print*,"- OPEN FILE ", trim(the_file) - call nemsio_open(gfile, the_file, "read", iret=rc) - if (rc /= 0) call error_handler("OPENING FILE.", rc) - else - allocate(dummy3d(0,0,0)) - allocate(dummy2d(0,0)) - allocate(dummy(0)) - endif - - if (localpet == 0) then - print*,"- READ TERRAIN." - call nemsio_readrecv(gfile, "orog", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING TERRAIN.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'orog ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ LANDSEA MASK." - call nemsio_readrecv(gfile, "land", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LANDSEA MASK.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'landmask ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." - call ESMF_FieldScatter(landsea_mask_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SEAICE FRACTION." - call nemsio_readrecv(gfile, "icec", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SEAICE FRACTION.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'icec ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE FRACTION." - call ESMF_FieldScatter(seaice_fract_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SEAICE DEPTH." - call nemsio_readrecv(gfile, "icetk", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SEAICE DEPTH.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'icetk ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE DEPTH." - call ESMF_FieldScatter(seaice_depth_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SEAICE SKIN TEMPERATURE." - call nemsio_readrecv(gfile, "ti", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SEAICE SKIN TEMP.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'ti ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE SKIN TEMPERATURE." - call ESMF_FieldScatter(seaice_skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SNOW LIQUID EQUIVALENT." - call nemsio_readrecv(gfile, "weasd", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SNOW LIQUID EQUIVALENT.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'weasd ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SNOW LIQUID EQUIVALENT." - call ESMF_FieldScatter(snow_liq_equiv_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SNOW DEPTH." - call nemsio_readrecv(gfile, "snod", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SNOW DEPTH.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) * 1000.0_8 - print*,'snod ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SNOW DEPTH." - call ESMF_FieldScatter(snow_depth_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ VEG TYPE." - call nemsio_readrecv(gfile, "vtype", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING VEG TYPE", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'vtype ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID VEG TYPE." - call ESMF_FieldScatter(veg_type_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SOIL TYPE." - call nemsio_readrecv(gfile, "sotyp", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SOIL TYPE.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'sotype ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SOIL TYPE." - call ESMF_FieldScatter(soil_type_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ T2M." - call nemsio_readrecv(gfile, "tmp", "2 m above gnd", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING T2M.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'t2m ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID T2M." - call ESMF_FieldScatter(t2m_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ Q2M." - call nemsio_readrecv(gfile, "spfh", "2 m above gnd", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING Q2M.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'q2m ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID Q2M." - call ESMF_FieldScatter(q2m_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ TPRCP." - call nemsio_readrecv(gfile, "tprcp", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING TPRCP.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'tprcp ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID TPRCP." - call ESMF_FieldScatter(tprcp_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ FFMM." - call nemsio_readrecv(gfile, "ffmm", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING FFMM.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'ffmm ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID FFMM" - call ESMF_FieldScatter(ffmm_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ USTAR." - call nemsio_readrecv(gfile, "fricv", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING USTAR.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'fricv ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID USTAR" - call ESMF_FieldScatter(ustar_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) dummy2d = 0.0 - print*,"- CALL FieldScatter FOR INPUT GRID SRFLAG" - call ESMF_FieldScatter(srflag_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SKIN TEMPERATURE." - call nemsio_readrecv(gfile, "tmp", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING SKIN TEMPERATURE.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'tmp ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SKIN TEMPERATURE" - call ESMF_FieldScatter(skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ F10M." - call nemsio_readrecv(gfile, "f10m", "10 m above gnd", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING F10M.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'f10m ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID F10M." - call ESMF_FieldScatter(f10m_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ CANOPY MOISTURE CONTENT." - call nemsio_readrecv(gfile, "cnwat", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING CANOPY MOISTURE CONTENT.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'cnwat ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID CANOPY MOISTURE CONTENT." - call ESMF_FieldScatter(canopy_mc_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ Z0." - call nemsio_readrecv(gfile, "sfcr", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING Z0.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) * 100.0_8 ! convert to cm - print*,'sfcr ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID Z0." - call ESMF_FieldScatter(z0_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - deallocate(dummy2d) - - if (localpet == 0) then - print*,"- READ LIQUID SOIL MOISTURE." - call nemsio_readrecv(gfile, "soill", "0-10 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 1 LIQUID SOIL MOIST.", rc) - dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "soill", "10-40 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 2 LIQUID SOIL MOIST.", rc) - dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "soill", "40-100 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 3 LIQUID SOIL MOIST.", rc) - dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "soill", "100-200 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 4 LIQUID SOIL MOIST.", rc) - dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) - print*,'soill ',maxval(dummy3d),minval(dummy3d) - endif - - print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." - call ESMF_FieldScatter(soilm_liq_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ TOTAL SOIL MOISTURE." - call nemsio_readrecv(gfile, "soilw", "0-10 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 1 TOTAL SOIL MOIST.", rc) - dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "soilw", "10-40 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 2 TOTAL SOIL MOIST.", rc) - dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "soilw", "40-100 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 3 TOTAL SOIL MOIST.", rc) - dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "soilw", "100-200 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 4 TOTAL SOIL MOIST.", rc) - dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) - print*,'soilm ',maxval(dummy3d),minval(dummy3d) - endif - - print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." - call ESMF_FieldScatter(soilm_tot_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ SOIL TEMPERATURE." - call nemsio_readrecv(gfile, "tmp", "0-10 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 1 SOIL TEMP.", rc) - dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "tmp", "10-40 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 2 SOIL TEMP.", rc) - dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "tmp", "40-100 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 3 SOIL TEMP.", rc) - dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) - call nemsio_readrecv(gfile, "tmp", "100-200 cm down", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING LAYER 4 SOIL TEMP.", rc) - dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) - print*,'soilt ',maxval(dummy3d),minval(dummy3d) - endif - - print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." - call ESMF_FieldScatter(soil_temp_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - deallocate(dummy3d, dummy) - - if (localpet == 0) call nemsio_close(gfile) - - end subroutine read_input_sfc_gaussian_nemsio_file - -!> Read input grid surface data from fv3 tiled warm 'restart' files. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_sfc_restart_file(localpet) - - implicit none - - integer, intent(in) :: localpet - - character(len=500) :: tilefile - - integer :: error, rc - integer :: id_dim, idim_input, jdim_input - integer :: ncid, tile, id_var - - real(esmf_kind_r8), allocatable :: data_one_tile(:,:) - real(esmf_kind_r8), allocatable :: data_one_tile_3d(:,:,:) - -!--------------------------------------------------------------------------- -! Get i/j dimensions and number of soil layers from first surface file. -! Do dimensions match those from the orography file? -!--------------------------------------------------------------------------- - - tilefile = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) - print*,"- READ GRID DIMENSIONS FROM: ", trim(tilefile) - error=nf90_open(trim(tilefile),nf90_nowrite,ncid) - call netcdf_err(error, 'opening: '//trim(tilefile) ) - - error=nf90_inq_dimid(ncid, 'xaxis_1', id_dim) - call netcdf_err(error, 'reading xaxis_1 id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=idim_input) - call netcdf_err(error, 'reading xaxis_1 value' ) - - error=nf90_inq_dimid(ncid, 'yaxis_1', id_dim) - call netcdf_err(error, 'reading yaxis_1 id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=jdim_input) - call netcdf_err(error, 'reading yaxis_1 value' ) - - if (idim_input /= i_input .or. jdim_input /= j_input) then - call error_handler("DIMENSION MISMATCH BETWEEN SFC AND OROG FILES.", 1) - endif - - error = nf90_close(ncid) - - if (localpet == 0) then - allocate(data_one_tile(idim_input,jdim_input)) - allocate(data_one_tile_3d(idim_input,jdim_input,lsoil_input)) - else - allocate(data_one_tile(0,0)) - allocate(data_one_tile_3d(0,0,0)) - endif - - TERRAIN_LOOP: do tile = 1, num_tiles_input_grid - - if (localpet == 0) then - tilefile = trim(orog_dir_input_grid) // trim(orog_files_input_grid(tile)) - print*,'- OPEN OROGRAPHY FILE: ', trim(tilefile) - error=nf90_open(tilefile,nf90_nowrite,ncid) - call netcdf_err(error, 'OPENING OROGRAPHY FILE' ) - error=nf90_inq_varid(ncid, 'orog_raw', id_var) - call netcdf_err(error, 'READING OROG RECORD ID' ) - error=nf90_get_var(ncid, id_var, data_one_tile) - call netcdf_err(error, 'READING OROG RECORD' ) - print*,'terrain check ',tile, maxval(data_one_tile) - error=nf90_close(ncid) - endif - - print*,"- CALL FieldScatter FOR INPUT TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - enddo TERRAIN_LOOP - - TILE_LOOP : do tile = 1, num_tiles_input_grid - -! liquid soil moisture - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('slc', tile, idim_input, jdim_input, & - lsoil_input, sfcdata_3d=data_one_tile_3d) - endif - - print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." - call ESMF_FieldScatter(soilm_liq_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('smc', tile, idim_input, jdim_input, & - lsoil_input, sfcdata_3d=data_one_tile_3d) - endif - - print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." - call ESMF_FieldScatter(soilm_tot_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('stc', tile, idim_input, jdim_input, & - lsoil_input, sfcdata_3d=data_one_tile_3d) - endif - - print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." - call ESMF_FieldScatter(soil_temp_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! land mask - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('slmsk', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." - call ESMF_FieldScatter(landsea_mask_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! sea ice fraction - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('fice', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE FRACTION." - call ESMF_FieldScatter(seaice_fract_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! sea ice depth - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('hice', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE DEPTH." - call ESMF_FieldScatter(seaice_depth_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! sea ice skin temperature - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('tisfc', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE SKIN TEMPERATURE." - call ESMF_FieldScatter(seaice_skin_temp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! liquid equivalent snow depth - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('sheleg', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SNOW LIQUID EQUIVALENT." - call ESMF_FieldScatter(snow_liq_equiv_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! physical snow depth - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('snwdph', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile = data_one_tile - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SNOW DEPTH." - call ESMF_FieldScatter(snow_depth_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Vegetation type - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('vtype', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID VEG TYPE." - call ESMF_FieldScatter(veg_type_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Soil type - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('stype', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SOIL TYPE." - call ESMF_FieldScatter(soil_type_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Two-meter temperature - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('t2m', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID T2M." - call ESMF_FieldScatter(t2m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Two-meter q - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('q2m', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID Q2M." - call ESMF_FieldScatter(q2m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('tprcp', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID TPRCP." - call ESMF_FieldScatter(tprcp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('f10m', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID F10M" - call ESMF_FieldScatter(f10m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('ffmm', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID FFMM" - call ESMF_FieldScatter(ffmm_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('uustar', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID USTAR" - call ESMF_FieldScatter(ustar_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('srflag', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SRFLAG" - call ESMF_FieldScatter(srflag_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('tsea', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SKIN TEMPERATURE" - call ESMF_FieldScatter(skin_temp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('canopy', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID CANOPY MOISTURE CONTENT." - call ESMF_FieldScatter(canopy_mc_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('zorl', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID Z0." - call ESMF_FieldScatter(z0_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - enddo TILE_LOOP - - deallocate(data_one_tile, data_one_tile_3d) - - end subroutine read_input_sfc_restart_file - -!> Read input grid surface data from tiled 'history' files (netcdf) or -!! gaussian netcdf files. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_sfc_netcdf_file(localpet) - - implicit none - - integer, intent(in) :: localpet - - character(len=500) :: tilefile - - integer :: error, id_var - integer :: id_dim, idim_input, jdim_input - integer :: ncid, rc, tile - - real(esmf_kind_r8), allocatable :: data_one_tile(:,:) - real(esmf_kind_r8), allocatable :: data_one_tile_3d(:,:,:) - -!--------------------------------------------------------------------------- -! Get i/j dimensions and number of soil layers from first surface file. -! Do dimensions match those from the orography file? -!--------------------------------------------------------------------------- - - tilefile = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) - print*,"- READ GRID DIMENSIONS FROM: ", trim(tilefile) - error=nf90_open(trim(tilefile),nf90_nowrite,ncid) - call netcdf_err(error, 'opening: '//trim(tilefile) ) - - error=nf90_inq_dimid(ncid, 'grid_xt', id_dim) - call netcdf_err(error, 'reading grid_xt id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=idim_input) - call netcdf_err(error, 'reading grid_xt value' ) - - error=nf90_inq_dimid(ncid, 'grid_yt', id_dim) - call netcdf_err(error, 'reading grid_yt id' ) - error=nf90_inquire_dimension(ncid,id_dim,len=jdim_input) - call netcdf_err(error, 'reading grid_yt value' ) - - if (idim_input /= i_input .or. jdim_input /= j_input) then - call error_handler("DIMENSION MISMATCH BETWEEN SFC AND OROG FILES.", 3) - endif - - error = nf90_close(ncid) - - if (localpet == 0) then - allocate(data_one_tile(idim_input,jdim_input)) - allocate(data_one_tile_3d(idim_input,jdim_input,lsoil_input)) - else - allocate(data_one_tile(0,0)) - allocate(data_one_tile_3d(0,0,0)) - endif - - TERRAIN_LOOP: do tile = 1, num_tiles_input_grid - - if (trim(input_type) == "gaussian_netcdf") then - if (localpet == 0) then - call read_fv3_grid_data_netcdf('orog', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - else - - if (localpet == 0) then - tilefile = trim(orog_dir_input_grid) // trim(orog_files_input_grid(tile)) - print*,'- OPEN OROGRAPHY FILE: ', trim(tilefile) - error=nf90_open(tilefile,nf90_nowrite,ncid) - call netcdf_err(error, 'OPENING OROGRAPHY FILE.' ) - error=nf90_inq_varid(ncid, 'orog_raw', id_var) - call netcdf_err(error, 'READING OROGRAPHY RECORD ID.' ) - error=nf90_get_var(ncid, id_var, data_one_tile) - call netcdf_err(error, 'READING OROGRAPHY RECORD.' ) - print*,'terrain check history ',tile, maxval(data_one_tile) - error=nf90_close(ncid) - endif - - endif - - print*,"- CALL FieldScatter FOR INPUT TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - enddo TERRAIN_LOOP - - TILE_LOOP : do tile = 1, num_tiles_input_grid - -! liquid soil moisture - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('soill1', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,1) = data_one_tile - call read_fv3_grid_data_netcdf('soill2', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,2) = data_one_tile - call read_fv3_grid_data_netcdf('soill3', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,3) = data_one_tile - call read_fv3_grid_data_netcdf('soill4', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,4) = data_one_tile - endif - - print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." - call ESMF_FieldScatter(soilm_liq_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! total soil moisture - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('soilw1', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,1) = data_one_tile - call read_fv3_grid_data_netcdf('soilw2', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,2) = data_one_tile - call read_fv3_grid_data_netcdf('soilw3', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,3) = data_one_tile - call read_fv3_grid_data_netcdf('soilw4', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,4) = data_one_tile - endif - - print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." - call ESMF_FieldScatter(soilm_tot_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! soil tempeature (ice temp at land ice points) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('soilt1', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,1) = data_one_tile - call read_fv3_grid_data_netcdf('soilt2', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,2) = data_one_tile - call read_fv3_grid_data_netcdf('soilt3', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,3) = data_one_tile - call read_fv3_grid_data_netcdf('soilt4', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile_3d(:,:,4) = data_one_tile - endif - - print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." - call ESMF_FieldScatter(soil_temp_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! land mask - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('land', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." - call ESMF_FieldScatter(landsea_mask_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! sea ice fraction - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('icec', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE FRACTION." - call ESMF_FieldScatter(seaice_fract_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! sea ice depth - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('icetk', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE DEPTH." - call ESMF_FieldScatter(seaice_depth_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! sea ice skin temperature - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('tisfc', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE SKIN TEMPERATURE." - call ESMF_FieldScatter(seaice_skin_temp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! liquid equivalent snow depth - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('weasd', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SNOW LIQUID EQUIVALENT." - call ESMF_FieldScatter(snow_liq_equiv_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! physical snow depth - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('snod', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - data_one_tile = data_one_tile * 1000.0 ! convert from meters to mm. - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SNOW DEPTH." - call ESMF_FieldScatter(snow_depth_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Vegetation type - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('vtype', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID VEG TYPE." - call ESMF_FieldScatter(veg_type_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Soil type - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('sotyp', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SOIL TYPE." - call ESMF_FieldScatter(soil_type_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Two-meter temperature - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('tmp2m', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID T2M." - call ESMF_FieldScatter(t2m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! Two-meter q - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('spfh2m', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID Q2M." - call ESMF_FieldScatter(q2m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('tprcp', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID TPRCP." - call ESMF_FieldScatter(tprcp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('f10m', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID F10M" - call ESMF_FieldScatter(f10m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('ffmm', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID FFMM" - call ESMF_FieldScatter(ffmm_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('fricv', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID USTAR" - call ESMF_FieldScatter(ustar_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then -! call read_fv3_grid_data_netcdf('srflag', tile, idim_input, jdim_input, & -! lsoil_input, sfcdata=data_one_tile) - data_one_tile = 0.0 - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SRFLAG" - call ESMF_FieldScatter(srflag_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('tmpsfc', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SKIN TEMPERATURE" - call ESMF_FieldScatter(skin_temp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('cnwat', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID CANOPY MOISTURE CONTENT." - call ESMF_FieldScatter(canopy_mc_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('sfcr', tile, idim_input, jdim_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT GRID Z0." - call ESMF_FieldScatter(z0_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - enddo TILE_LOOP - - deallocate(data_one_tile, data_one_tile_3d) - - end subroutine read_input_sfc_netcdf_file - -!> Read input grid surface data from a grib2 file. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author Larissa Reames - subroutine read_input_sfc_grib2_file(localpet) - - use mpi - use grib_mod - use program_setup, only : vgtyp_from_climo, sotyp_from_climo - use model_grid, only : input_grid_type - use search_util - - implicit none - - integer, intent(in) :: localpet - - character(len=250) :: the_file - character(len=250) :: geo_file - character(len=20) :: vname, vname_file, slev - character(len=50) :: method - character(len=20) :: to_upper - - integer :: rc, varnum, iret, i, j,k - integer :: ncid2d, varid, varsize - integer :: lugb, lugi - integer :: jdisc, jgdtn, jpdtn, pdt_num - integer :: jids(200), jgdt(200), jpdt(200) - - logical :: rap_latlon, unpack - - real(esmf_kind_r4) :: value - real(esmf_kind_r4), allocatable :: dummy2d(:,:) - real(esmf_kind_r8), allocatable :: icec_save(:,:) - real(esmf_kind_r4), allocatable :: dummy1d(:) - real(esmf_kind_r8), allocatable :: dummy2d_8(:,:),dummy2d_82(:,:),tsk_save(:,:) - real(esmf_kind_r8), allocatable :: dummy3d(:,:,:), dummy3d_stype(:,:,:) - integer(esmf_kind_i4), allocatable :: slmsk_save(:,:) - integer(esmf_kind_i8), allocatable :: dummy2d_i(:,:) - - type(gribfield) :: gfld - - rap_latlon = trim(to_upper(external_model))=="RAP" .and. trim(input_grid_type) == "rotated_latlon" - - the_file = trim(data_dir_input_grid) // "/" // trim(grib2_file_input_grid) - geo_file = trim(geogrid_file_input_grid) - - print*,"- READ SFC DATA FROM GRIB2 FILE: ", trim(the_file) - -! Determine the number of soil layers in file. - - if (localpet == 0) then - - lugb=12 - call baopenr(lugb,the_file,rc) - if (rc /= 0) call error_handler("ERROR OPENING GRIB2 FILE.", rc) - - j = 0 ! search at beginning of file - lugi = 0 ! no grib index file - jdisc = -1 ! search for any discipline - jpdtn = -1 ! search for any product definition template number - jgdtn = -1 ! search for any grid definition template number - jids = -9999 ! array of values in identification section, set to wildcard - jgdt = -9999 ! array of values in grid definition template, set to wildcard - jpdt = -9999 ! array of values in product definition template, set to wildcard - unpack = .false. ! unpack data - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc == 0) then - if (gfld%idsect(1) == 7 .and. gfld%idsect(2) == 2) then - print*,'- THIS IS NCEP GEFS DATA.' - pdt_num = 1 - else - pdt_num = 0 - endif - else - if (rc /= 0) call error_handler("ERROR READING GRIB2 FILE.", rc) - endif - - j = 0 - lsoil_input = 0 - - do - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc /= 0) exit - - if (gfld%discipline == 2) then ! discipline - land products - if (gfld%ipdtnum == pdt_num) then ! prod template number - analysis or forecast at single level. - if (gfld%ipdtmpl(1) == 0 .and. gfld%ipdtmpl(2) == 2) then ! soil temp - ! Sect4/octs 10 and 11 - if (gfld%ipdtmpl(10) == 106 .and. gfld%ipdtmpl(13) == 106) then ! Sect4/octs 23/29. - ! Layer below ground. - lsoil_input = lsoil_input + 1 - endif - endif - endif - endif - - j = k - - enddo - - print*, "- FILE HAS ", lsoil_input, " SOIL LEVELS." - if (lsoil_input == 0) call error_handler("COUNTING SOIL LEVELS.", rc) - - endif ! localpet == 0 - - call MPI_BARRIER(MPI_COMM_WORLD, rc) - call MPI_BCAST(lsoil_input,1,MPI_INTEGER,0,MPI_COMM_WORLD,rc) - - ! We need to recreate the soil fields if we have something other than 4 levels - - if (lsoil_input /= 4) then - - call ESMF_FieldDestroy(soil_temp_input_grid, rc=rc) - call ESMF_FieldDestroy(soilm_tot_input_grid, rc=rc) - call ESMF_FieldDestroy(soilm_liq_input_grid, rc=rc) - - print*,"- CALL FieldCreate FOR INPUT SOIL TEMPERATURE." - soil_temp_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lsoil_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT TOTAL SOIL MOISTURE." - soilm_tot_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lsoil_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - print*,"- CALL FieldCreate FOR INPUT LIQUID SOIL MOISTURE." - soilm_liq_input_grid = ESMF_FieldCreate(input_grid, & - typekind=ESMF_TYPEKIND_R8, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - ungriddedLBound=(/1/), & - ungriddedUBound=(/lsoil_input/), rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldCreate", rc) - - endif - - if (localpet == 0) then - allocate(dummy2d(i_input,j_input)) - allocate(slmsk_save(i_input,j_input)) - allocate(tsk_save(i_input,j_input)) - allocate(icec_save(i_input,j_input)) - allocate(dummy2d_8(i_input,j_input)) - allocate(dummy2d_82(i_input,j_input)) - allocate(dummy3d(i_input,j_input,lsoil_input)) - else - allocate(dummy3d(0,0,0)) - allocate(dummy2d_8(0,0)) - allocate(dummy2d_82(0,0)) - allocate(dummy2d(0,0)) - allocate(slmsk_save(0,0)) - endif - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! These variables are always in grib files, or are required, so no need to check for them - ! in the varmap table. If they can't be found in the input file, then stop the program. - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if (localpet == 0) then - - print*,"- READ TERRAIN." - - j = 0 - jdisc = 0 ! Search for discipline 0 - meteorological products - jpdt = -9999 ! array of values in product definition template, set to wildcard. - jpdtn = pdt_num ! search for product definition template number 0 - anl or fcst. - jpdt(1) = 3 ! Sec4/oct 10 - param cat - mass field - jpdt(2) = 5 ! Sec4/oct 11 - param number - geopotential height - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc /= 0) call error_handler("READING TERRAIN.", rc) - - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) -! print*,'orog ', maxval(dummy2d_8),minval(dummy2d_8) - - endif - - print*,"- CALL FieldScatter FOR INPUT TERRAIN." - call ESMF_FieldScatter(terrain_input_grid, dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ SEAICE FRACTION." - - jdisc = 10 ! Search for discipline - ocean products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for product def template number 0 - anl or fcst. - jpdt = -9999 ! Array of values in Sec 4 product definition template; - ! Initialize to wildcard. - jpdt(1) = 2 ! Sec4/oct 10 - parameter category - ice - jpdt(2) = 0 ! Sec4/oct 11 - parameter number - ice cover - unpack=.true. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc /= 0) call error_handler("READING SEAICE FRACTION.", rc) - - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) -! print*,'icec ', maxval(dummy2d_8),minval(dummy2d_8) - - icec_save = dummy2d_8 - - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE FRACTION." - call ESMF_FieldScatter(seaice_fract_input_grid, dummy2d_8 ,rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - -!---------------------------------------------------------------------------------- -! GFS v14 and v15.2 grib data has two land masks. LANDN is created by -! nearest neighbor interpolation. LAND is created by bilinear interpolation. -! LANDN matches the bitmap. So use it first. For other GFS versions or other models, -! use LAND. Mask in grib file is '1' (land), '0' (not land). Add sea/lake ice category -! '2' based on ice concentration. -!---------------------------------------------------------------------------------- - - if (localpet == 0) then - - print*,"- READ LANDSEA MASK." - - jdisc = 2 ! Search for discipline - land products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for product definition template number 0 - anl or fcst. - jpdt = -9999 ! Initialize array of values in product definition template - Sec 4. - jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass - jpdt(2) = 218 ! Sec4/oct 11 - parameter number - land nearest neighbor - unpack=.true. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc == 0) then - - print*,'landnn ', maxval(gfld%fld),minval(gfld%fld) - - else - - jdisc = 2 ! Search for discipline - land products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for product def template number 0 - anl or fcst. - jpdt = -9999 ! Initialize array of values in product definition template - Sec 4. - jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass - jpdt(2) = 0 ! Sec4/oct 11 - parameter number - land cover (fraction) - unpack=.true. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc /= 0) call error_handler("READING LANDSEA MASK.", rc) - -! print*,'land ', maxval(gfld%fld),minval(gfld%fld) - - endif - - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - - do j = 1, j_input - do i = 1, i_input - if(dummy2d_8(i,j) < 0.5_esmf_kind_r8) dummy2d_8(i,j)=0.0 - if(icec_save(i,j) > 0.15_esmf_kind_r8) then - dummy2d_8(i,j) = 2.0_esmf_kind_r8 - endif - enddo - enddo - - slmsk_save = nint(dummy2d_8) - - deallocate(icec_save) - - endif ! read land mask - - print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." - call ESMF_FieldScatter(landsea_mask_input_grid, dummy2d_8 ,rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ SEAICE SKIN TEMPERATURE." - - jdisc = 0 ! Search for discipline - meteorological products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for product definition template number 0 - anl or fcst. - jpdt = -9999 ! Initialize array of values in product definition template - Sec4 - jpdt(1) = 0 ! Sec4/oct 10 - parameter category - temperature - jpdt(2) = 0 ! Sec4/oct 11 - parameter number - temperature - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc /= 0) call error_handler("READING SEAICE SKIN TEMP.", rc) - -! print*,'ti ',maxval(gfld%fld),minval(gfld%fld) - - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE SKIN TEMPERATURE." - call ESMF_FieldScatter(seaice_skin_temp_input_grid, dummy2d_8 ,rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - -!---------------------------------------------------------------------------------- -! Read snow fields. Zero out at non-land points and undefined points (points -! removed using the bitmap). Program expects depth and liquid equivalent -! in mm. -!---------------------------------------------------------------------------------- - - if (localpet == 0) then - - print*,"- READ SNOW LIQUID EQUIVALENT." - - jdisc = 0 ! Search for discipline - meteorological products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template - Sec4 - jpdt(1) = 1 ! Sec4/oct 10 - parameter category - moisture - jpdt(2) = 13 ! Sec4/oct 11 - parameter number - liquid equiv snow depth - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc /= 0) call error_handler("READING SNOW LIQUID EQUIVALENT.", rc) - -! print*,'weasd ', maxval(gfld%fld),minval(gfld%fld) - - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - - do j = 1, j_input - do i = 1, i_input - if(slmsk_save(i,j) == 0) dummy2d_8(i,j) = 0.0 - enddo - enddo - - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SNOW LIQUID EQUIVALENT." - call ESMF_FieldScatter(snow_liq_equiv_input_grid, dummy2d_8 ,rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ SNOW DEPTH." - - jdisc = 0 ! Search for discipline - meteorological products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template - Sec4 - jpdt(1) = 1 ! Sec4/oct 10 - parameter category - moisture - jpdt(2) = 11 ! Sec4/oct 11 - parameter number - snow depth - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc /= 0) then - call error_handler("READING SNOW DEPTH.", rc) - else - gfld%fld = gfld%fld * 1000.0 -! print*,'snod ', maxval(gfld%fld),minval(gfld%fld) - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - endif - - do j = 1, j_input - do i = 1, i_input - if(slmsk_save(i,j) == 0) dummy2d_8(i,j) = 0.0 - enddo - enddo - - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SNOW DEPTH." - call ESMF_FieldScatter(snow_depth_input_grid,dummy2d_8,rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ T2M." - - jdisc = 0 ! Search for discipline - meteorological products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template - Sec4 - jpdt(1) = 0 ! Sec4/oct 10 - parameter category - temperature - jpdt(2) = 0 ! Sec4/oct 11 - parameter number - temperature - jpdt(10) = 103 ! Sec4/oct 23 - type of level - height above ground surface - jpdt(12) = 2 ! Sec4/octs 25-28 - 2 meters above ground. - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc /= 0) call error_handler("READING T2M.", rc) -! print*,'t2m ', maxval(gfld%fld),minval(gfld%fld) - - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - - endif - - print*,"- CALL FieldScatter FOR INPUT GRID T2M." - call ESMF_FieldScatter(t2m_input_grid, dummy2d_8, rootpet=0,rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ Q2M." - - jdisc = 0 ! Search for discipline - meteorological products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template - Sec4 - jpdt(1) = 1 ! Sec4/oct 10 - parameter category - moisture - jpdt(2) = 0 ! Sec4/oct 11 - parameter number - specific humidity - jpdt(10) = 103 ! Sec4/oct 23 - type of level - height above ground surface - jpdt(12) = 2 ! Sec4/octs 25-28 - 2 meters above ground. - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc /=0) call error_handler("READING Q2M.", rc) - -! print*,'q2m ',maxval(gfld%fld),minval(gfld%fld) - - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - - endif - - print*,"- CALL FieldScatter FOR INPUT GRID Q2M." - call ESMF_FieldScatter(q2m_input_grid,dummy2d_8, rootpet=0,rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ SKIN TEMPERATURE." - - jdisc = 0 ! Search for discipline - meteorological products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template - Sec4 - jpdt(1) = 0 ! Sec4/oct 10 - parameter category - temperature - jpdt(2) = 0 ! Sec4/oct 11 - parameter number - temperature - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc /= 0 ) call error_handler("READING SKIN TEMPERATURE.", rc) -! print*,'skint ', maxval(gfld%fld),minval(gfld%fld) - - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - - tsk_save(:,:) = dummy2d_8 - - do j = 1, j_input - do i = 1, i_input - if(slmsk_save(i,j) == 0 .and. dummy2d_8(i,j) < 271.2) then -! print*,'too cool SST ',i,j,dummy2d_8(i,j) - dummy2d_8(i,j) = 271.2 - endif - if(slmsk_save(i,j) == 0 .and. dummy2d_8(i,j) > 310.) then -! print*,'too hot SST ',i,j,dummy2d_8(i,j) - dummy2d_8(i,j) = 310.0 - endif - enddo - enddo - - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SKIN TEMPERATURE" - call ESMF_FieldScatter(skin_temp_input_grid,dummy2d_8,rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - -! srflag not in files. Set to zero. - - if (localpet == 0) dummy2d_8 = 0.0 - - print*,"- CALL FieldScatter FOR INPUT GRID SRFLAG" - call ESMF_FieldScatter(srflag_input_grid,dummy2d_8, rootpet=0,rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ SOIL TYPE." - - jdisc = 2 ! Search for discipline - land products - j = 0 ! Search at beginning of file - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template - Sec4 - jpdt(1) = 3 ! Sec4/oct 10 - parameter category - soil products - jpdt(2) = 0 ! Sec4/oct 11 - parameter number - soil type - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc == 0 ) then -! print*,'soil type ', maxval(gfld%fld),minval(gfld%fld) - dummy2d = reshape(gfld%fld , (/i_input,j_input/)) - - endif - - if (rc /= 0 .and. (trim(to_upper(external_model))=="HRRR" .or. rap_latlon) .and. geo_file .ne. "NULL") then - ! Some HRRR and RAP files don't have dominant soil type in the output, but the geogrid files - ! do, so this gives users the option to provide the geogrid file and use input soil - ! type - print*, "OPEN GEOGRID FILE ", trim(geo_file) - rc = nf90_open(geo_file,NF90_NOWRITE,ncid2d) - call netcdf_err(rc,"READING GEOGRID FILE") - - print*, "INQURE ABOUT DIM IDS" - rc = nf90_inq_dimid(ncid2d,"west_east",varid) - call netcdf_err(rc,"READING west_east DIMENSION FROM GEOGRID FILE") - - rc = nf90_inquire_dimension(ncid2d,varid,len=varsize) - call netcdf_err(rc,"READING west_east DIMENSION SIZE") - if (varsize .ne. i_input) call error_handler ("GEOGRID FILE GRID SIZE DIFFERS FROM INPUT DATA.", -1) - - print*, "INQUIRE ABOUT SOIL TYPE FROM GEOGRID FILE" - rc = nf90_inq_varid(ncid2d,"SCT_DOM",varid) - call netcdf_err(rc,"FINDING SCT_DOM IN GEOGRID FILE") - - print*, "READ SOIL TYPE FROM GEOGRID FILE " - rc = nf90_get_var(ncid2d,varid,dummy2d) - call netcdf_err(rc,"READING SCT_DOM FROM FILE") - - print*, "INQUIRE ABOUT SOIL TYPE FRACTIONS FROM GEOGRID FILE" - rc = nf90_inq_varid(ncid2d,"SOILCTOP",varid) - call netcdf_err(rc,"FINDING SOILCTOP IN GEOGRID FILE") - - allocate(dummy3d_stype(i_input,j_input,16)) - print*, "READ SOIL TYPE FRACTIONS FROM GEOGRID FILE " - rc = nf90_get_var(ncid2d,varid,dummy3d_stype) - call netcdf_err(rc,"READING SCT_DOM FROM FILE") - - print*, "CLOSE GEOGRID FILE " - iret = nf90_close(ncid2d) - - ! There's an issue with the geogrid file containing soil type water at land points. - ! This correction replaces the soil type at these points with the soil type with - ! the next highest fractional coverage. - allocate(dummy1d(16)) - do j = 1, j_input - do i = 1, i_input - if(dummy2d(i,j) == 14.0_esmf_kind_r4 .and. slmsk_save(i,j) == 1) then - dummy1d(:) = dummy3d_stype(i,j,:) - dummy1d(14) = 0.0_esmf_kind_r4 - dummy2d(i,j) = real(MAXLOC(dummy1d, 1),esmf_kind_r4) - endif - enddo - enddo - deallocate(dummy1d) - deallocate(dummy3d_stype) - endif ! failed - - if ((rc /= 0 .and. trim(to_upper(external_model)) /= "HRRR" .and. .not. rap_latlon) & - .or. (rc /= 0 .and. (trim(to_upper(external_model)) == "HRRR" .or. rap_latlon))) then - if (.not. sotyp_from_climo) then - call error_handler("COULD NOT FIND SOIL TYPE IN FILE. PLEASE SET SOTYP_FROM_CLIMO=.TRUE. . EXITING", rc) - else - vname = "sotyp" - slev = "surface" - call get_var_cond(vname,this_miss_var_method=method, this_miss_var_value=value, & - loc=varnum) - call handle_grib_error(vname, slev ,method,value,varnum,rc, var= dummy2d) - if (rc == 1) then ! missing_var_method == skip or no entry in varmap table - print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. WILL NOT "//& - "SCALE SOIL MOISTURE FOR DIFFERENCES IN SOIL TYPE. " - dummy2d(:,:) = -99999.0_esmf_kind_r4 - endif - endif - endif - - ! In the event that the soil type on the input grid still contains mismatches between - ! soil type and landmask, this correction is a last-ditch effort to replace these points - ! with soil type from a nearby land point. - - if (.not. sotyp_from_climo) then - do j = 1, j_input - do i = 1, i_input - if(dummy2d(i,j) == 14.0_esmf_kind_r4 .and. slmsk_save(i,j) == 1) dummy2d(i,j) = -99999.9 - enddo - enddo - - allocate(dummy2d_i(i_input,j_input)) - dummy2d_8 = real(dummy2d,esmf_kind_r8) - dummy2d_i(:,:) = 0 - where(slmsk_save == 1) dummy2d_i = 1 - - call search(dummy2d_8,dummy2d_i,i_input,j_input,1,230) - deallocate(dummy2d_i) - else - dummy2d_8=real(dummy2d,esmf_kind_r8) - endif - - print*,'sotype ',maxval(dummy2d_8),minval(dummy2d_8) - - endif ! read of soil type - - print*,"- CALL FieldScatter FOR INPUT GRID SOIL TYPE." - call ESMF_FieldScatter(soil_type_input_grid,dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - deallocate(dummy2d) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Begin variables whose presence in grib2 files varies, but no climatological - ! data is available, so we have to account for values in the varmap table - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if (.not. vgfrc_from_climo) then - - if (localpet == 0) then - - print*,"- READ VEG FRACTION." - - jdisc = 2 ! Search for discipline - land products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template Sec4. - jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass - jpdt(2) = 4 ! Sec4/oct 11 - parameter number - vegetation - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc /= 0 )then - call error_handler("COULD NOT FIND VEGETATION FRACTION IN FILE. & - PLEASE SET VGFRC_FROM_CLIMO=.TRUE. EXITING", rc) - else - if (maxval(gfld%fld) > 2.0) gfld%fld = gfld%fld / 100.0 -! print*,'vfrac ', maxval(gfld%fld),minval(gfld%fld) - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - - endif - - endif ! localpet 0 - - print*,"- CALL FieldScatter FOR INPUT GRID VEG GREENNESS." - call ESMF_FieldScatter(veg_greenness_input_grid,dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - endif - - if (.not. minmax_vgfrc_from_climo) then - - if (localpet == 0) then - - print*,"- READ MIN VEG FRACTION." - - jdisc = 2 ! Search for discipline - land products - j = 1105 ! grib2 file does not distinguish between the various veg - ! fractions. Need to search using record number. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template Sec4. - jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass - jpdt(2) = 4 ! Sec4/oct 11 - parameter number - vegetation - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc /= 0) then - j = 1101 ! Have to search by record number. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc /= 0) then - j = 1151 ! Have to search by record number. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc/=0) call error_handler("COULD NOT FIND MIN VEGETATION FRACTION IN FILE. & - PLEASE SET MINMAX_VGFRC_FROM_CLIMO=.TRUE. . EXITING",rc) - endif - endif - - if (maxval(gfld%fld) > 2.0) gfld%fld = gfld%fld / 100.0 - print*,'vfrac min ', maxval(gfld%fld),minval(gfld%fld) - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - - endif ! localpet == 0 - - print*,"- CALL FieldScatter FOR INPUT GRID MIN VEG GREENNESS." - call ESMF_FieldScatter(min_veg_greenness_input_grid,dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ MAX VEG FRACTION." - - jdisc = 2 ! Search for discipline - land products - j = 1106 ! Have to search by record number. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template Sec4. - jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass - jpdt(2) = 4 ! Sec4/oct 11 - parameter number - vegetation - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc /= 0) then - j = 1102 ! Have to search by record number. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc /= 0) then - j = 1152 ! Have to search by record number. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc <= 0) call error_handler("COULD NOT FIND MAX VEGETATION FRACTION IN FILE. & - PLEASE SET MINMAX_VGFRC_FROM_CLIMO=.TRUE. . EXITING",rc) - endif - endif - - if (maxval(gfld%fld) > 2.0) gfld%fld = gfld%fld / 100.0 -! print*,'vfrac max ', maxval(gfld%fld),minval(gfld%fld) - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - - endif !localpet==0 - - print*,"- CALL FieldScatter FOR INPUT GRID MAX VEG GREENNESS." - call ESMF_FieldScatter(max_veg_greenness_input_grid,dummy2d_8,rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - endif !minmax_vgfrc_from_climo - - if (.not. lai_from_climo) then - - if (localpet == 0) then - - print*,"- READ LAI." - - jdisc = 0 ! Search for discipline - meteorological products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template Sec4. - jpdt(1) = 7 ! Sec4/oct 10 - parameter category - thermo stability indices - jpdt(2) = 198 ! Sec4/oct 11 - parameter number - leaf area index - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc /= 0) call error_handler("COULD NOT FIND LAI IN FILE. & - PLEASE SET LAI_FROM_CLIMO=.TRUE. . EXITING",rc) - -! print*,'lai ', maxval(gfld%fld),minval(gfld%fld) - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - - endif !localpet==0 - - print*,"- CALL FieldScatter FOR INPUT GRID LAI." - call ESMF_FieldScatter(lai_input_grid,dummy2d_8,rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - endif ! lai - - if (localpet == 0) then - - print*,"- READ SEAICE DEPTH." - vname="hice" - slev=":surface:" - call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & - loc=varnum) - - jdisc = 10 ! Search for discipline - ocean products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template Sec4. - jpdt(1) = 2 ! Sec4/oct 10 - parameter category - ice - jpdt(2) = 1 ! Sec4/oct 11 - parameter number - thickness - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc /= 0 ) then - call handle_grib_error(vname, slev ,method,value,varnum,rc,var8=dummy2d_8) - if (rc==1) then ! missing_var_method == skip or no entry in varmap table - print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL BE"//& - " REPLACED WITH CLIMO. SET A FILL "// & - "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." - dummy2d_8(:,:) = 0.0 - endif - else -! print*,'hice ', maxval(gfld%fld),minval(gfld%fld) - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - endif - - endif - - print*,"- CALL FieldScatter FOR INPUT GRID SEAICE DEPTH." - call ESMF_FieldScatter(seaice_depth_input_grid,dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ TPRCP." - vname="tprcp" - slev=":surface:" - call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & - loc=varnum) - -! No test data contained this field. So could not test with g2 library. - rc = 1 - if (rc /= 0) then - call handle_grib_error(vname, slev ,method,value,varnum,rc, var8=dummy2d_8) - if (rc==1) then ! missing_var_method == skip or no entry in varmap table - print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL NOT"//& - " BE WRITTEN TO THE INPUT FILE. SET A FILL "// & - "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." - dummy2d_8 = 0.0 - endif - endif - print*,'tprcp ',maxval(dummy2d_8),minval(dummy2d_8) - - endif ! tprcp - - print*,"- CALL FieldScatter FOR INPUT GRID TPRCP." - call ESMF_FieldScatter(tprcp_input_grid,dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ FFMM." - vname="ffmm" - slev=":surface:" - call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & - loc=varnum) - -! No sample data contained this field, so could not test g2lib. - rc = 1 - if (rc /= 0) then - call handle_grib_error(vname, slev ,method,value,varnum,rc, var8=dummy2d_8) - if (rc==1) then ! missing_var_method == skip or no entry in varmap table - print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL NOT"//& - " BE WRITTEN TO THE INPUT FILE. SET A FILL "// & - "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." - dummy2d_8(:,:) = 0.0 - endif - endif - print*,'ffmm ',maxval(dummy2d_8),minval(dummy2d_8) - - endif ! ffmm - - print*,"- CALL FieldScatter FOR INPUT GRID FFMM" - call ESMF_FieldScatter(ffmm_input_grid,dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ USTAR." - vname="fricv" - slev=":surface:" - call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & - loc=varnum) - - jdisc = 0 ! Search for discipline - meteorological products - j = 0 ! Search at beginning of file. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template Sec4. - jpdt(1) = 2 ! Sec4/oct 10 - parameter category - momentum - jpdt(2) = 30 ! Sec4/oct 11 - parameter number - friction velocity - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - if (rc /= 0) then - jpdt(2) = 197 ! oct 11 - param number - friction vel. - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - endif - - if (rc == 0) then -! print*,'fricv ', maxval(gfld%fld),minval(gfld%fld) - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - else - call handle_grib_error(vname, slev ,method,value,varnum,rc, var8=dummy2d_8) - if (rc==1) then ! missing_var_method == skip or no entry in varmap table - print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL "//& - "REPLACED WITH CLIMO. SET A FILL "// & - "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." - dummy2d_8(:,:) = 0.0 - endif - endif - - endif ! ustar - - print*,"- CALL FieldScatter FOR INPUT GRID USTAR" - call ESMF_FieldScatter(ustar_input_grid,dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ F10M." - vname="f10m" - slev=":10 m above ground:" - call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & - loc=varnum) - - rc = -1 ! None of the test cases have this record. Can't test with g2lib. - if (rc /= 0) then - call handle_grib_error(vname, slev ,method,value,varnum,rc, var8=dummy2d_8) - if (rc==1) then ! missing_var_method == skip or no entry in varmap table - print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL NOT"//& - " BE WRITTEN TO THE INPUT FILE. SET A FILL "// & - "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." - dummy2d_8(:,:) = 0.0 - endif - endif - print*,'f10m ',maxval(dummy2d_8),minval(dummy2d_8) - - endif - - print*,"- CALL FieldScatter FOR INPUT GRID F10M." - call ESMF_FieldScatter(f10m_input_grid,dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ CANOPY MOISTURE CONTENT." - vname="cnwat" - slev=":surface:" - call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & - loc=varnum) - - jdisc = 2 ! Search for discipline - land products - j = 0 ! Search from beginning of file - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template Sec4. - jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass - jpdt(2) = 13 ! Sec4/oct 11 - parameter number - canopy water - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc /= 0 ) then - jpdt(2) = 196 ! Sec4/oct 11 - param number - canopy water - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - endif - - if (rc == 0 ) then - print*,'cnwat ', maxval(gfld%fld),minval(gfld%fld) - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - call check_cnwat(dummy2d_8) - else - call handle_grib_error(vname, slev ,method,value,varnum,rc, var8=dummy2d_8) - if (rc==1) then ! missing_var_method == skip or no entry in varmap table - print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL"//& - " REPLACED WITH CLIMO. SET A FILL "// & - "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." - dummy2d_8 = 0.0 - endif - endif - - endif - - print*,"- CALL FieldScatter FOR INPUT GRID CANOPY MOISTURE CONTENT." - call ESMF_FieldScatter(canopy_mc_input_grid,dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - - print*,"- READ Z0." - vname="sfcr" - slev=":surface:" - call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & - loc=varnum) - - jdisc = 2 ! Search for discipline - land products - j = 0 ! Search from beginning of file. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template Sec4. - jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass - jpdt(2) = 1 ! Sec4/oct 11 - parameter number - surface roughness - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc /= 0 ) then - call handle_grib_error(vname, slev ,method,value,varnum,rc, var8= dummy2d_8) - if (rc==1) then ! missing_var_method == skip or no entry in varmap table - print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL BE"//& - " REPLACED WITH CLIMO. SET A FILL "// & - "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." - dummy2d_8(:,:) = 0.0 - endif - else - gfld%fld = gfld%fld * 10.0 ! Grib files have z0 (m), but fv3 expects z0(cm) -! print*,'sfcr ', maxval(gfld%fld),minval(gfld%fld) - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - endif - - endif - - print*,"- CALL FieldScatter FOR INPUT GRID Z0." - call ESMF_FieldScatter(z0_input_grid,dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ LIQUID SOIL MOISTURE." - vname = "soill" - vname_file = ":SOILL:" - call read_grib_soil(vname,vname_file,lugb, pdt_num,dummy3d) !!! NEED TO HANDLE - !!! SOIL LEVELS - endif - - print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." - call ESMF_FieldScatter(soilm_liq_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ TOTAL SOIL MOISTURE." - vname = "soilw" - vname_file = "var2_2_1_" ! the var number instead - call read_grib_soil(vname,vname_file,lugb, pdt_num,dummy3d) - endif - - print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." - call ESMF_FieldScatter(soilm_tot_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - -!---------------------------------------------------------------------------------------- -! Vegetation type is not available in some files. However, it is needed to identify -! permanent land ice points. At land ice, the total soil moisture is a flag value of -! '1'. Use this flag as a temporary solution. -!---------------------------------------------------------------------------------------- - - print*, "- CALL FieldGather for INPUT SOIL TYPE." - call ESMF_FieldGather(soil_type_input_grid, dummy2d_82, rootPet=0, tile=1, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGather", rc) - - if (localpet == 0) then - - print*,"- READ VEG TYPE." - - jdisc = 2 ! Search for discipline - land products - j = 0 ! Search from beginning of file. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt = -9999 ! Initialize array of values in product definition template Sec4. - jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass - jpdt(2) = 198 ! Sec4/oct 11 - parameter number - vegetation type - jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface - unpack=.true. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc) - - if (rc /= 0 ) then - if (.not. vgtyp_from_climo) then - call error_handler("COULD NOT FIND VEGETATION TYPE IN FILE. PLEASE SET VGTYP_FROM_CLIMO=.TRUE. . EXITING", rc) - else ! Set input veg type at land ice from soil moisture flag (1.0). - do j = 1, j_input - do i = 1, i_input - dummy2d_8(i,j) = 0.0 - if(slmsk_save(i,j) == 1 .and. dummy3d(i,j,1) > 0.99) & ! land ice indicated by - ! soil moisture flag of '1'. - dummy2d_8(i,j) = real(veg_type_landice_input,esmf_kind_r8) - enddo - enddo - endif - else ! found vtype in file. - dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) - endif - - if (trim(external_model) .ne. "GFS") then - do j = 1, j_input - do i = 1,i_input - if (dummy2d_8(i,j) == 15.0_esmf_kind_r8 .and. slmsk_save(i,j) == 1) then - if (dummy3d(i,j,1) < 0.6) then - dummy2d_8(i,j) = real(veg_type_landice_input,esmf_kind_r8) - elseif (dummy3d(i,j,1) > 0.99) then - slmsk_save(i,j) = 0 - dummy2d_8(i,j) = 0.0_esmf_kind_r8 - dummy2d_82(i,j) = 0.0_esmf_kind_r8 - endif - elseif (dummy2d_8(i,j) == 17.0_esmf_kind_r8 .and. slmsk_save(i,j)==0) then - dummy2d_8(i,j) = 0.0_esmf_kind_r8 - endif - enddo - enddo - endif - -! print*,'vgtyp ',maxval(dummy2d_8),minval(dummy2d_8) - - endif ! read veg type - - print*,"- CALL FieldScatter FOR INPUT VEG TYPE." - call ESMF_FieldScatter(veg_type_input_grid, dummy2d_8, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - print*,"- CALL FieldScatter FOR INPUT SOIL TYPE." - call ESMF_FieldScatter(soil_type_input_grid, dummy2d_82, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - deallocate(dummy2d_82) - - print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." - call ESMF_FieldScatter(landsea_mask_input_grid,real(slmsk_save,esmf_kind_r8),rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - -!--------------------------------------------------------------------------------- -! At open water (slmsk==0), the soil temperature array is not used and set -! to the filler value of SST. At lake/sea ice points (slmsk=2), the soil -! temperature array holds ice column temperature. This field is not available -! in the grib data, so set to a default value. -!--------------------------------------------------------------------------------- - - if (localpet == 0) then - print*,"- READ SOIL TEMPERATURE." - vname = "soilt" - vname_file = ":TSOIL:" - call read_grib_soil(vname,vname_file,lugb,pdt_num,dummy3d) - call check_soilt(dummy3d,slmsk_save,tsk_save) - deallocate(tsk_save) - endif - - deallocate(slmsk_save) - - print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." - call ESMF_FieldScatter(soil_temp_input_grid, dummy3d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& - call error_handler("IN FieldScatter", rc) - - deallocate(dummy3d) - deallocate(dummy2d_8) - - if (localpet == 0) call baclose(lugb, rc) - - end subroutine read_input_sfc_grib2_file - -!> Read nst data from these netcdf formatted fv3 files: tiled history, -!! tiled warm restart, and gaussian history. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_nst_netcdf_file(localpet) - - implicit none - - integer, intent(in) :: localpet - - character(len=10) :: field - - integer :: rc, tile - - real(esmf_kind_r8), allocatable :: data_one_tile(:,:) - - if (localpet == 0) then - allocate(data_one_tile(i_input,j_input)) - else - allocate(data_one_tile(0,0)) - endif - - TILE_LOOP : do tile = 1, num_tiles_input_grid - -! c_d - - if (localpet == 0) then - if (trim(input_type) == "restart") then - field='c_d' - else - field='cd' - endif - call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT C_D" - call ESMF_FieldScatter(c_d_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! c_0 - - if (localpet == 0) then - if (trim(input_type) == "restart") then - field='c_0' - else - field='c0' - endif - call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT C_0" - call ESMF_FieldScatter(c_0_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! d_conv - - if (localpet == 0) then - if (trim(input_type) == "restart") then - field='d_conv' - else - field='dconv' - endif - call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT D_CONV." - call ESMF_FieldScatter(d_conv_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! dt_cool - - if (localpet == 0) then - if (trim(input_type) == "restart") then - field='dt_cool' - else - field='dtcool' - endif - call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT DT_COOL." - call ESMF_FieldScatter(dt_cool_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! ifd - xu li said initialize to '1'. - - if (localpet == 0) then - data_one_tile = 1.0 - endif - - print*,"- CALL FieldScatter FOR INPUT IFD." - call ESMF_FieldScatter(ifd_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! qrain - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('qrain', tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT QRAIN." - call ESMF_FieldScatter(qrain_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! tref - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('tref', tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT TREF" - call ESMF_FieldScatter(tref_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! w_d - - if (localpet == 0) then - if (trim(input_type) == "restart") then - field='w_d' - else - field='wd' - endif - call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT W_D" - call ESMF_FieldScatter(w_d_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! w_0 - - if (localpet == 0) then - if (trim(input_type) == "restart") then - field='w_0' - else - field='w0' - endif - call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT W_0" - call ESMF_FieldScatter(w_0_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! xs - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('xs', tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT XS" - call ESMF_FieldScatter(xs_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! xt - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('xt', tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT XT" - call ESMF_FieldScatter(xt_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! xu - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('xu', tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT XU" - call ESMF_FieldScatter(xu_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! xv - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('xv', tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT XV" - call ESMF_FieldScatter(xv_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! xz - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('xz', tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT XZ" - call ESMF_FieldScatter(xz_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! xtts - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('xtts', tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT XTTS" - call ESMF_FieldScatter(xtts_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! xzts - - if (localpet == 0) then - call read_fv3_grid_data_netcdf('xzts', tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT XZTS" - call ESMF_FieldScatter(xzts_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! z_c - - if (localpet == 0) then - if (trim(input_type) == "restart") then - field='z_c' - else - field='zc' - endif - call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & - lsoil_input, sfcdata=data_one_tile) - endif - - print*,"- CALL FieldScatter FOR INPUT Z_C" - call ESMF_FieldScatter(z_c_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - -! zm - Not used yet. Xu li said set to '0'. - - if (localpet == 0) then - data_one_tile = 0.0 - endif - - print*,"- CALL FieldScatter FOR INPUT ZM" - call ESMF_FieldScatter(zm_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - enddo TILE_LOOP - - deallocate(data_one_tile) - - end subroutine read_input_nst_netcdf_file - -!> Read input grid nst data from fv3 gaussian nemsio history file or -!! spectral GFS nemsio file. -!! -!! @note The spectral GFS nst data is in a separate file from -!! the surface data. The fv3 surface and nst data are in a -!! single file. -!! -!! @param[in] localpet ESMF local persistent execution thread -!! @author George Gayno NCEP/EMC - subroutine read_input_nst_nemsio_file(localpet) - - implicit none - - integer, intent(in) :: localpet - - character(len=300) :: the_file - - integer :: rc - - real(nemsio_realkind), allocatable :: dummy(:) - real(esmf_kind_r8), allocatable :: dummy2d(:,:) - - type(nemsio_gfile) :: gfile - - if (trim(input_type) == "gfs_gaussian_nemsio") then ! spectral gfs nemsio in - ! separate file. - the_file = trim(data_dir_input_grid) // "/" // trim(nst_files_input_grid) - else - the_file = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) - endif - - print*,"- READ NST DATA FROM: ", trim(the_file) - - if (localpet == 0) then - allocate(dummy(i_input*j_input)) - allocate(dummy2d(i_input,j_input)) - call nemsio_open(gfile, the_file, "read", iret=rc) - else - allocate(dummy(0)) - allocate(dummy2d(0,0)) - endif - - if (localpet == 0) then - print*,"- READ TREF" - call nemsio_readrecv(gfile, "tref", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING TREF.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'tref ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT TREF." - call ESMF_FieldScatter(tref_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ CD" - call nemsio_readrecv(gfile, "cd", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING CD.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'cd ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT C_D." - call ESMF_FieldScatter(c_d_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ C0" - call nemsio_readrecv(gfile, "c0", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING C0.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'c0 ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT C_0." - call ESMF_FieldScatter(c_0_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ DCONV" - call nemsio_readrecv(gfile, "dconv", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING DCONV.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'dconv ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT D_CONV." - call ESMF_FieldScatter(d_conv_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ DTCOOL" - call nemsio_readrecv(gfile, "dtcool", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING DTCOOL.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'dtcool ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT DT_COOL." - call ESMF_FieldScatter(dt_cool_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - dummy2d = 1.0 ! IFD not in file. Set to '1' per Xu Li. - endif - - print*,"- CALL FieldScatter FOR INPUT IFD." - call ESMF_FieldScatter(ifd_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ QRAIN" - call nemsio_readrecv(gfile, "qrain", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING QRAIN.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'qrain ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT QRAIN." - call ESMF_FieldScatter(qrain_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ WD" - call nemsio_readrecv(gfile, "wd", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING WD.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'wd ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT WD." - call ESMF_FieldScatter(w_d_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ W0" - call nemsio_readrecv(gfile, "w0", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING W0.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'w0 ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT W0." - call ESMF_FieldScatter(w_0_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ XS" - call nemsio_readrecv(gfile, "xs", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING XS.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'xs ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT XS." - call ESMF_FieldScatter(xs_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ XT" - call nemsio_readrecv(gfile, "xt", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING XT.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'xt ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT XT." - call ESMF_FieldScatter(xt_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ XU" - call nemsio_readrecv(gfile, "xu", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING XU.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'xu ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT XU." - call ESMF_FieldScatter(xu_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ XV" - call nemsio_readrecv(gfile, "xv", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING XV.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'xv ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT XV." - call ESMF_FieldScatter(xv_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ XZ" - call nemsio_readrecv(gfile, "xz", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING XZ.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'xz ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT XZ." - call ESMF_FieldScatter(xz_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ XTTS" - call nemsio_readrecv(gfile, "xtts", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING XTTS.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'xtts ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT XTTS." - call ESMF_FieldScatter(xtts_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ XZTS" - call nemsio_readrecv(gfile, "xzts", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING XZTS.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'xzts ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT XZTS." - call ESMF_FieldScatter(xzts_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - print*,"- READ ZC" - call nemsio_readrecv(gfile, "zc", "sfc", 1, dummy, 0, iret=rc) - if (rc /= 0) call error_handler("READING ZC.", rc) - dummy2d = reshape(dummy, (/i_input,j_input/)) - print*,'zc ',maxval(dummy2d),minval(dummy2d) - endif - - print*,"- CALL FieldScatter FOR INPUT Z_C." - call ESMF_FieldScatter(z_c_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - if (localpet == 0) then - dummy2d = 0.0 ! zm not used yet. Set to zero per Xu Li. - endif - - print*,"- CALL FieldScatter FOR INPUT ZM." - call ESMF_FieldScatter(zm_input_grid, dummy2d, rootpet=0, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldScatter", rc) - - deallocate(dummy, dummy2d) - - if (localpet == 0) call nemsio_close(gfile) - - end subroutine read_input_nst_nemsio_file - -!> Read a record from a netcdf file -!! -!! @param [in] field name of field to be read -!! @param [in] tile_num grid tile number -!! @param [in] imo i-dimension of field -!! @param [in] jmo j-dimension of field -!! @param [in] lmo number of vertical levels of field -!! @param [out] sfcdata 1-d array containing field data -!! @param [out] sfcdata_3d 3-d array containing field data -!! @author George Gayno NCEP/EMC - SUBROUTINE READ_FV3_GRID_DATA_NETCDF(FIELD,TILE_NUM,IMO,JMO,LMO, & - SFCDATA, SFCDATA_3D) - - IMPLICIT NONE - - CHARACTER(LEN=*),INTENT(IN) :: FIELD - - INTEGER, INTENT(IN) :: IMO, JMO, LMO, TILE_NUM - - REAL(ESMF_KIND_R8), INTENT(OUT), OPTIONAL :: SFCDATA(IMO,JMO) - REAL(ESMF_KIND_R8), INTENT(OUT), OPTIONAL :: SFCDATA_3D(IMO,JMO,LMO) - - CHARACTER(LEN=256) :: TILEFILE - - INTEGER :: ERROR, NCID, ID_VAR - - TILEFILE = TRIM(DATA_DIR_INPUT_GRID) // "/" // TRIM(SFC_FILES_INPUT_GRID(TILE_NUM)) - - PRINT*,'WILL READ ',TRIM(FIELD), ' FROM: ', TRIM(TILEFILE) - - ERROR=NF90_OPEN(TRIM(TILEFILE),NF90_NOWRITE,NCID) - CALL NETCDF_ERR(ERROR, 'OPENING: '//TRIM(TILEFILE) ) - - ERROR=NF90_INQ_VARID(NCID, FIELD, ID_VAR) - CALL NETCDF_ERR(ERROR, 'READING FIELD ID' ) - - IF (PRESENT(SFCDATA_3D)) THEN - ERROR=NF90_GET_VAR(NCID, ID_VAR, SFCDATA_3D) - CALL NETCDF_ERR(ERROR, 'READING FIELD' ) - ELSE - ERROR=NF90_GET_VAR(NCID, ID_VAR, SFCDATA) - CALL NETCDF_ERR(ERROR, 'READING FIELD' ) - ENDIF - - ERROR = NF90_CLOSE(NCID) - - END SUBROUTINE READ_FV3_GRID_DATA_NETCDF - -!> Read winds from a grib2 file. Rotate winds -!! to be earth relative if necessary. -!! -!! @param [inout] u u-component wind -!! @param [inout] v v-component wind -!! @param[in] localpet ESMF local persistent execution thread -!! @param[in] octet_23 Section 4/Octet 23 - Type of first fixed surface. -!! @param[in] rlevs Array of atmospheric level values -!! @param[in] lugb Logical unit number of GRIB2 file. -!! @param[in] pdt_num Product definition template number. -!! @author Larissa Reames - subroutine read_winds(u,v,localpet,octet_23,rlevs,lugb,pdt_num) - - use grib_mod - use program_setup, only : get_var_cond - - implicit none - - integer, intent(in) :: localpet, lugb - integer, intent(in) :: pdt_num, octet_23 - - real(esmf_kind_r8), intent(inout), allocatable :: u(:,:,:),v(:,:,:) - real(esmf_kind_r8), intent(in), dimension(lev_input) :: rlevs - - real(esmf_kind_r4), dimension(i_input,j_input) :: alpha - real(esmf_kind_r8), dimension(i_input,j_input) :: lon, lat - real(esmf_kind_r4), allocatable :: u_tmp(:,:),v_tmp(:,:) - real(esmf_kind_r8), allocatable :: dum2d(:,:) - real(esmf_kind_r4), dimension(i_input,j_input) :: ws,wd - real(esmf_kind_r4) :: value_u, value_v,lov,latin1,latin2 - real(esmf_kind_r8) :: d2r - - integer :: varnum_u, varnum_v, vlev, & - error, iret - integer :: j, k, lugi, jgdtn, jpdtn - integer :: jdisc, jids(200), jgdt(200), jpdt(200) - - character(len=20) :: vname - character(len=50) :: method_u, method_v - - logical :: unpack - - type(gribfield) :: gfld - - d2r=acos(-1.0_esmf_kind_r8) / 180.0_esmf_kind_r8 - if (localpet==0) then - allocate(u(i_input,j_input,lev_input)) - allocate(v(i_input,j_input,lev_input)) - else - allocate(u(0,0,0)) - allocate(v(0,0,0)) - endif - - vname = "u" - call get_var_cond(vname,this_miss_var_method=method_u, this_miss_var_value=value_u, & - loc=varnum_u) - vname = "v" - call get_var_cond(vname,this_miss_var_method=method_v, this_miss_var_value=value_v, & - loc=varnum_v) - - print*,"- CALL FieldGather FOR INPUT GRID LONGITUDE" - call ESMF_FieldGather(longitude_input_grid, lon, rootPet=0, tile=1, rc=error) - if(ESMF_logFoundError(rcToCheck=error,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGather", error) - - print*,"- CALL FieldGather FOR INPUT GRID LATITUDE" - call ESMF_FieldGather(latitude_input_grid, lat, rootPet=0, tile=1, rc=error) - if(ESMF_logFoundError(rcToCheck=error,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGather", error) - - if (localpet==0) then - - lugi = 0 ! index file unit number - jdisc = 0 ! search for discipline - meteorological products - j = 0 ! search at beginning of file. - jpdt = -9999 ! array of values in product definition template, set to wildcard - jids = -9999 ! array of values in identification section, set to wildcard - jgdt = -9999 ! array of values in grid definition template, set to wildcard - jgdtn = -1 ! search for any grid definition number. - jpdtn = pdt_num ! Search for the product definition template number. - unpack=.false. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret /= 0) call error_handler("ERROR READING GRIB2 FILE.", iret) - - if (gfld%igdtnum == 32769) then ! grid definition template number - rotated lat/lon grid - - latin1 = float(gfld%igdtmpl(15))/1.0E6 - lov = float(gfld%igdtmpl(16))/1.0E6 - - print*, "- CALL CALCALPHA_ROTLATLON with center lat,lon = ",latin1,lov - call calcalpha_rotlatlon(lat,lon,latin1,lov,alpha) - - elseif (gfld%igdtnum == 30) then ! grid definition template number - lambert conformal grid. - - lov = float(gfld%igdtmpl(14))/1.0E6 - latin1 = float(gfld%igdtmpl(19))/1.0E6 - latin2 = float(gfld%igdtmpl(20))/1.0E6 - - print*, "- CALL GRIDROT for LC grid with lov,latin1/2 = ",lov,latin1,latin2 - call gridrot(lov,latin1,latin2,lon,alpha) - - endif - - jpdt(10) = octet_23 ! Sec4/oct 23 - type of level. - - unpack=.true. - - allocate(dum2d(i_input,j_input)) - allocate(u_tmp(i_input,j_input)) - allocate(v_tmp(i_input,j_input)) - - do vlev = 1, lev_input - - vname = ":UGRD:" - - jpdt(1) = 2 ! Sec4/oct 10 - parameter category - momentum - jpdt(2) = 2 ! Sec4/oct 11 - parameter number - u-wind - jpdt(12) = nint(rlevs(vlev)) ! Sect4/octs 25-28 - scaled value of fixed surface. - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret /= 0) then - call handle_grib_error(vname, slevs(vlev),method_u,value_u,varnum_u,iret,var=u_tmp) - if (iret==1) then ! missing_var_method == skip - call error_handler("READING IN U AT LEVEL "//trim(slevs(vlev))//". SET A FILL "// & - "VALUE IN THE VARMAP TABLE IF THIS ERROR IS NOT DESIRABLE.",iret) - endif - else - dum2d = reshape(gfld%fld, (/i_input,j_input/) ) - u_tmp(:,:) = dum2d - endif - - vname = ":VGRD:" - - jpdt(2) = 3 ! Sec4/oct 11 - parameter number - v-wind - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, iret) - - if (iret /= 0) then - call handle_grib_error(vname, slevs(vlev),method_v,value_v,varnum_v,iret,var=v_tmp) - if (iret==1) then ! missing_var_method == skip - call error_handler("READING IN V AT LEVEL "//trim(slevs(vlev))//". SET A FILL "// & - "VALUE IN THE VARMAP TABLE IF THIS ERROR IS NOT DESIRABLE.",iret) - endif - else - dum2d = reshape(gfld%fld, (/i_input,j_input/) ) - v_tmp(:,:) = dum2d - endif - - deallocate(dum2d) - - if (gfld%igdtnum == 0) then ! grid definition template number - lat/lon grid - if (external_model == 'UKMET') then - u(:,:,vlev) = u_tmp - v(:,:,vlev) = (v_tmp(:,2:jp1_input) + v_tmp(:,1:j_input))/2 - else - u(:,:,vlev) = u_tmp - v(:,:,vlev) = v_tmp - endif - else if (gfld%igdtnum == 32769) then ! grid definition template number - rotated lat/lon grid - ws = sqrt(u_tmp**2 + v_tmp**2) - wd = atan2(-u_tmp,-v_tmp) / d2r ! calculate grid-relative wind direction - wd = wd + alpha + 180.0 ! Rotate from grid- to earth-relative direction - wd = 270.0 - wd ! Convert from meteorological (true N) to mathematical direction - u(:,:,vlev) = -ws*cos(wd*d2r) - v(:,:,vlev) = -ws*sin(wd*d2r) - else - u(:,:,vlev) = real(u_tmp * cos(alpha) + v_tmp * sin(alpha),esmf_kind_r8) - v(:,:,vlev) = real(v_tmp * cos(alpha) - u_tmp * sin(alpha),esmf_kind_r8) - endif - - print*, 'max, min U ', minval(u(:,:,vlev)), maxval(u(:,:,vlev)) - print*, 'max, min V ', minval(v(:,:,vlev)), maxval(v(:,:,vlev)) - enddo - endif - -end subroutine read_winds - -!> Convert winds from 2-d to 3-d components. -!! -!! @author George Gayno NCEP/EMC - subroutine convert_winds - - implicit none - - integer :: clb(4), cub(4) - integer :: i, j, k, rc - - real(esmf_kind_r8) :: latrad, lonrad - real(esmf_kind_r8), pointer :: windptr(:,:,:,:) - real(esmf_kind_r8), pointer :: uptr(:,:,:) - real(esmf_kind_r8), pointer :: vptr(:,:,:) - real(esmf_kind_r8), pointer :: latptr(:,:) - real(esmf_kind_r8), pointer :: lonptr(:,:) - - print*,"- CALL FieldGet FOR 3-D WIND." - call ESMF_FieldGet(wind_input_grid, & - computationalLBound=clb, & - computationalUBound=cub, & - farrayPtr=windptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR U." - call ESMF_FieldGet(u_input_grid, & - farrayPtr=uptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR V." - call ESMF_FieldGet(v_input_grid, & - farrayPtr=vptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR LATITUDE." - call ESMF_FieldGet(latitude_input_grid, & - farrayPtr=latptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - print*,"- CALL FieldGet FOR LONGITUDE." - call ESMF_FieldGet(longitude_input_grid, & - farrayPtr=lonptr, rc=rc) - if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & - call error_handler("IN FieldGet", rc) - - do i = clb(1), cub(1) - do j = clb(2), cub(2) - latrad = latptr(i,j) * acos(-1.) / 180.0 - lonrad = lonptr(i,j) * acos(-1.) / 180.0 - do k = clb(3), cub(3) - windptr(i,j,k,1) = uptr(i,j,k) * cos(lonrad) - vptr(i,j,k) * sin(latrad) * sin(lonrad) - windptr(i,j,k,2) = uptr(i,j,k) * sin(lonrad) + vptr(i,j,k) * sin(latrad) * cos(lonrad) - windptr(i,j,k,3) = vptr(i,j,k) * cos(latrad) - enddo - enddo - enddo - - call ESMF_FieldDestroy(u_input_grid, rc=rc) - call ESMF_FieldDestroy(v_input_grid, rc=rc) - - end subroutine convert_winds - -!> Compute grid rotation angle for non-latlon grids. -!! -!! @note The original gridrot subroutine was specific to polar -!! stereographic grids. We need to compute it for Lambert Conformal -!! grids. So we need lat1,lat2. This follows the ncl_ncarg source -!! code: ncl_ncarg-6.6.2/ni/src/ncl/GetGrids.c -!! -!! @param [in] lov orientation angle -!! @param [in] latin1 first tangent latitude -!! @param [in] latin2 second tangent latitude -!! @param [in] lon longitude -!! @param [inout] rot rotation angle -!! @author Larissa Reames -subroutine gridrot(lov,latin1,latin2,lon,rot) - - use model_grid, only : i_input,j_input - implicit none - - - real(esmf_kind_r4), intent(in) :: lov,latin1,latin2 - real(esmf_kind_r4), intent(inout) :: rot(i_input,j_input) - real(esmf_kind_r8), intent(in) :: lon(i_input,j_input) - - real(esmf_kind_r4) :: trot(i_input,j_input), tlon(i_input,j_input) - real(esmf_kind_r4) :: dtor = 3.14159265359/180.0_esmf_kind_r4 - real(esmf_kind_r4) :: an - !trot_tmp = real(lon,esmf_kind_r4)-lov - !trot = trot_tmp - !where(trot_tmp > 180.0) trot = trot-360.0_esmf_kind_r4 - !where(trot_tmp < -180.0) trot = trot-360.0_esmf_kind_r4 - - if ( (latin1 - latin2) .lt. 0.000001 ) then - an = sin(latin1*dtor) - else - an = log( cos(latin1*dtor) / cos(latin2*dtor) ) / & - log( tan(dtor*(90.0-latin1)/2.) / tan(dtor*(90.0-latin2)/2.)) - end if - - tlon = mod(lon - lov + 180. + 3600., 360.) - 180. - trot = an * tlon - - rot = trot * dtor - -end subroutine gridrot - -!> Calculate rotation angle for rotated latlon grids. -!! Needed to convert to earth-relative winds. -!! -!! @param [in] latgrid grid latitudes -!! @param [in] longrid grid longitudes -!! @param [in] cenlat center latitude -!! @param [in] cenlon center longitude -!! @param [out] alpha grid rotation angle -!! @author Larissa Reames -subroutine calcalpha_rotlatlon(latgrid,longrid,cenlat,cenlon,alpha) - - use model_grid, only : i_input,j_input - implicit none - - real(esmf_kind_r8), intent(in) :: latgrid(i_input,j_input), & - longrid(i_input,j_input) - real(esmf_kind_r4), intent(in) :: cenlat, cenlon - real(esmf_kind_r4), intent(out) :: alpha(i_input,j_input) - - ! Variables local to subroutine - real(esmf_kind_r8) :: D2R,lon0_r,lat0_r,sphi0,cphi0 - real(esmf_kind_r8), DIMENSION(i_input,j_input) :: tlat,tlon,tph,sinalpha - - D2R = acos(-1.0_esmf_kind_r8) / 180.0_esmf_kind_r8 - if (cenlon .lt. 0) then - lon0_r = (cenlon + 360.0)*D2R - else - lon0_r = cenlon*D2R - end if - lat0_r=cenlat*D2R - sphi0=sin(lat0_r) - cphi0=cos(lat0_r) - - ! deal with input lat/lon - tlat = latgrid * D2R - tlon = longrid * D2R - - ! Calculate alpha (rotation angle) - tlon = -tlon + lon0_r - tph = asin(cphi0*sin(tlat) - sphi0*cos(tlat)*cos(tlon)) - sinalpha = sphi0 * sin(tlon) / cos(tph) - alpha = -asin(sinalpha)/D2R - ! returns alpha in degrees -end subroutine calcalpha_rotlatlon - -!> Handle GRIB2 read error based on the user selected -!! method in the varmap file. -!! -!! @param [in] vname grib2 variable name -!! @param [in] lev grib2 variable level -!! @param [in] method how missing data is handled -!! @param [in] value fill value for missing data -!! @param [in] varnum grib2 variable number -!! @param [inout] iret return status code -!! @param [inout] var 4-byte array of corrected data -!! @param [inout] var8 8-byte array of corrected data -!! @param [inout] var3d 3-d array of corrected data -!! @author Larissa Reames -subroutine handle_grib_error(vname,lev,method,value,varnum, iret,var,var8,var3d) - - use, intrinsic :: ieee_arithmetic - - implicit none - - real(esmf_kind_r4), intent(in) :: value - real(esmf_kind_r4), intent(inout), optional :: var(:,:) - real(esmf_kind_r8), intent(inout), optional :: var8(:,:) - real(esmf_kind_r8), intent(inout), optional :: var3d(:,:,:) - - character(len=20), intent(in) :: vname, lev, method - - integer, intent(in) :: varnum - integer, intent(inout) :: iret - - iret = 0 - if (varnum == 9999) then - print*, "WARNING: ", trim(vname), " NOT FOUND AT LEVEL ", lev, " IN EXTERNAL FILE ", & - "AND NO ENTRY EXISTS IN VARMAP TABLE. VARIABLE WILL NOT BE USED." - iret = 1 - - return - endif - - if (trim(method) == "skip" ) then - print*, "WARNING: SKIPPING ", trim(vname), " IN FILE" - read_from_input(varnum) = .false. - iret = 1 - elseif (trim(method) == "set_to_fill") then - print*, "WARNING: ,", trim(vname), " NOT AVAILABLE AT LEVEL ", trim(lev), & - ". SETTING EQUAL TO FILL VALUE OF ", value - if(present(var)) var(:,:) = value - if(present(var8)) var8(:,:) = value - if(present(var3d)) var3d(:,:,:) = value - elseif (trim(method) == "set_to_NaN") then - print*, "WARNING: ,", trim(vname), " NOT AVAILABLE AT LEVEL ", trim(lev), & - ". SETTING EQUAL TO NaNs" - if(present(var)) var(:,:) = ieee_value(var,IEEE_QUIET_NAN) - if(present(var8)) var8(:,:) = ieee_value(var8,IEEE_QUIET_NAN) - if(present(var3d)) var3d(:,:,:) = ieee_value(var3d,IEEE_QUIET_NAN) - elseif (trim(method) == "stop") then - call error_handler("READING "//trim(vname)// " at level "//lev//". TO MAKE THIS NON- & - FATAL, CHANGE STOP TO SKIP FOR THIS VARIABLE IN YOUR VARMAP & - FILE.", iret) - elseif (trim(method) == "intrp") then - print*, "WARNING: ,"//trim(vname)//" NOT AVAILABLE AT LEVEL "//trim(lev)// & - ". WILL INTERPOLATE INTERSPERSED MISSING LEVELS AND/OR FILL MISSING"//& - " LEVELS AT EDGES." - else - call error_handler("ERROR USING MISSING_VAR_METHOD. PLEASE SET VALUES IN" // & - " VARMAP TABLE TO ONE OF: set_to_fill, set_to_NaN,"// & - " , intrp, skip, or stop.", 1) - endif - -end subroutine handle_grib_error - -!> Read soil temperature and soil moisture fields from a GRIB2 file. -!! -!! @param [in] vname variable name in varmap table -!! @param [in] vname_file variable name in grib2 file -!! @param [in] lugb logical unit number for surface grib2 file -!! @param [in] pdt_num product definition template number. -!! @param [inout] dummy3d array of soil data -!! @author George Gayno NCEP/EMC - subroutine read_grib_soil(vname, vname_file, lugb, pdt_num, dummy3d) - - use grib_mod - - implicit none - - character(len=20), intent(in) :: vname,vname_file - - integer, intent(in) :: lugb, pdt_num - - real(esmf_kind_r8), intent(inout) :: dummy3d(:,:,:) - - character(len=50) :: slevs(lsoil_input) - character(len=50) :: method - - integer :: varnum, i, j, k, rc, rc2 - integer :: jdisc, jgdtn, jpdtn, lugi - integer :: jids(200), jgdt(200), jpdt(200) - integer :: iscale1, iscale2 - - logical :: unpack - - real(esmf_kind_r4), allocatable :: dummy2d(:,:) - real(esmf_kind_r4) :: value - - type(gribfield) :: gfld - - allocate(dummy2d(i_input,j_input)) - - if(lsoil_input == 4) then - slevs = (/character(24)::':0-0.1 m below ground:', ':0.1-0.4 m below ground:', & - ':0.4-1 m below ground:', ':1-2 m below ground:'/) - elseif(lsoil_input == 9) then - slevs = (/character(26)::':0-0 m below ground',':0.01-0.01 m below ground:',':0.04-0.04 m below ground:', & - ':0.1-0.1 m below ground:',':0.3-0.3 m below ground:',':0.6-0.6 m below ground:', & - ':1-1 m below ground:',':1.6-1.6 m below ground:',':3-3 m below ground:'/) - else - rc = -1 - call error_handler("reading soil levels. File must have 4 or 9 soil levels.", rc) - endif - - call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & - loc=varnum) - - lugi = 0 ! unit number for index file - jdisc = 2 ! search for discipline - land products - j = 0 ! search at beginning of file. - jpdt = -9999 ! array of values in product definition template 4.n - jids = -9999 ! array of values in identification section, set to wildcard - jgdt = -9999 ! array of values in grid definition template 3.m - jgdtn = -1 ! search for any grid definition number. - jpdtn = pdt_num ! Search for the product definition template number. - jpdt(1) = 0 ! Section 4/Octet 10 - parameter category - veg/biomass - if (trim(vname) == 'soilt') jpdt(2) = 2 ! Section 4/Octet 11 - parameter number - soil temp - if (trim(vname) == 'soilw') jpdt(2) = 192 ! Section 4/Octet 11 - parameter number - total soilm - if (trim(vname) == 'soill') then - jpdt(1) = 3 ! Section 4/Octet 10 - soil products - jpdt(2) = 192 ! Section 4/Octet 11 - parameter number - liquid soilm - endif - jpdt(10) = 106 ! Section 4/Octet 23 - depth below ground - jpdt(13) = 106 ! Section 4/Octet 29 - depth below ground - unpack=.true. - - do i = 1,lsoil_input - - call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & - unpack, k, gfld, rc2) - - if (rc2 /= 0) then ! record not found. - call handle_grib_error(vname_file, slevs(i),method,value,varnum,rc,var=dummy2d) - if (rc==1 .and. trim(vname) /= "soill") then - ! missing_var_method == skip or no entry in varmap table - call error_handler("READING IN "//trim(vname)//". SET A FILL "// & - "VALUE IN THE VARMAP TABLE IF THIS ERROR IS NOT DESIRABLE.",rc) - elseif (rc==1) then - dummy3d(:,:,:) = 0.0_esmf_kind_r8 - return - endif - endif - - if (rc2 == 0) then ! record found. - iscale1 = 10 ** gfld%ipdtmpl(11) - iscale2 = 10 ** gfld%ipdtmpl(14) -! print*,'getgb2 top of soil layer in m ', float(gfld%ipdtmpl(12))/float(iscale1) -! print*,'getgb2 bot of soil layer in m ', float(gfld%ipdtmpl(15))/float(iscale2) - dummy2d = reshape(gfld%fld, (/i_input,j_input/) ) - endif - - j = k - - dummy3d(:,:,i) = real(dummy2d,esmf_kind_r8) - - enddo - - deallocate(dummy2d) - - end subroutine read_grib_soil - -!> Free up memory associated with atm data. -!! -!! @author George Gayno NCEP/EMC - subroutine cleanup_input_atm_data - - implicit none - - integer :: rc, n - - print*,'- DESTROY ATMOSPHERIC INPUT DATA.' - - call ESMF_FieldDestroy(terrain_input_grid, rc=rc) - call ESMF_FieldDestroy(pres_input_grid, rc=rc) - call ESMF_FieldDestroy(dzdt_input_grid, rc=rc) - call ESMF_FieldDestroy(temp_input_grid, rc=rc) - call ESMF_FieldDestroy(wind_input_grid, rc=rc) - call ESMF_FieldDestroy(ps_input_grid, rc=rc) - - do n = 1, num_tracers_input - call ESMF_FieldDestroy(tracers_input_grid(n), rc=rc) - enddo - deallocate(tracers_input_grid) - - end subroutine cleanup_input_atm_data - -!> Free up memory associated with nst data. -!! -!! @author George Gayno NCEP/EMC - subroutine cleanup_input_nst_data - - implicit none - - integer :: rc - - print*,'- DESTROY NST INPUT DATA.' - - call ESMF_FieldDestroy(landsea_mask_input_grid, rc=rc) - call ESMF_FieldDestroy(c_d_input_grid, rc=rc) - call ESMF_FieldDestroy(c_0_input_grid, rc=rc) - call ESMF_FieldDestroy(d_conv_input_grid, rc=rc) - call ESMF_FieldDestroy(dt_cool_input_grid, rc=rc) - call ESMF_FieldDestroy(ifd_input_grid, rc=rc) - call ESMF_FieldDestroy(qrain_input_grid, rc=rc) - call ESMF_FieldDestroy(tref_input_grid, rc=rc) - call ESMF_FieldDestroy(w_d_input_grid, rc=rc) - call ESMF_FieldDestroy(w_0_input_grid, rc=rc) - call ESMF_FieldDestroy(xs_input_grid, rc=rc) - call ESMF_FieldDestroy(xt_input_grid, rc=rc) - call ESMF_FieldDestroy(xu_input_grid, rc=rc) - call ESMF_FieldDestroy(xv_input_grid, rc=rc) - call ESMF_FieldDestroy(xz_input_grid, rc=rc) - call ESMF_FieldDestroy(xtts_input_grid, rc=rc) - call ESMF_FieldDestroy(xzts_input_grid, rc=rc) - call ESMF_FieldDestroy(z_c_input_grid, rc=rc) - call ESMF_FieldDestroy(zm_input_grid, rc=rc) - - end subroutine cleanup_input_nst_data - -!> Free up memory associated with sfc data. -!! -!! @author George Gayno NCEP/EMC - subroutine cleanup_input_sfc_data - - implicit none - - integer :: rc - - print*,"- CALL FieldDestroy FOR INPUT GRID FIELDS." - - call ESMF_FieldDestroy(canopy_mc_input_grid, rc=rc) - call ESMF_FieldDestroy(f10m_input_grid, rc=rc) - call ESMF_FieldDestroy(ffmm_input_grid, rc=rc) - if (.not. convert_nst) then - call ESMF_FieldDestroy(landsea_mask_input_grid, rc=rc) - endif - call ESMF_FieldDestroy(q2m_input_grid, rc=rc) - call ESMF_FieldDestroy(seaice_depth_input_grid, rc=rc) - call ESMF_FieldDestroy(seaice_fract_input_grid, rc=rc) - call ESMF_FieldDestroy(seaice_skin_temp_input_grid, rc=rc) - call ESMF_FieldDestroy(skin_temp_input_grid, rc=rc) - call ESMF_FieldDestroy(snow_depth_input_grid, rc=rc) - call ESMF_FieldDestroy(snow_liq_equiv_input_grid, rc=rc) - call ESMF_FieldDestroy(soil_temp_input_grid, rc=rc) - call ESMF_FieldDestroy(soil_type_input_grid, rc=rc) - call ESMF_FieldDestroy(soilm_liq_input_grid, rc=rc) - call ESMF_FieldDestroy(soilm_tot_input_grid, rc=rc) - call ESMF_FieldDestroy(srflag_input_grid, rc=rc) - call ESMF_FieldDestroy(t2m_input_grid, rc=rc) - call ESMF_FieldDestroy(tprcp_input_grid, rc=rc) - call ESMF_FieldDestroy(ustar_input_grid, rc=rc) - call ESMF_FieldDestroy(veg_type_input_grid, rc=rc) - call ESMF_FieldDestroy(z0_input_grid, rc=rc) - call ESMF_FieldDestroy(terrain_input_grid, rc=rc) - if (.not. vgfrc_from_climo) then - call ESMF_FieldDestroy(veg_greenness_input_grid, rc=rc) - endif - if (.not. minmax_vgfrc_from_climo) then - call ESMF_FieldDestroy(min_veg_greenness_input_grid, rc=rc) - call ESMF_FieldDestroy(max_veg_greenness_input_grid, rc=rc) - endif - if (.not. lai_from_climo) then - call ESMF_FieldDestroy(lai_input_grid, rc=rc) - endif - - end subroutine cleanup_input_sfc_data - -!> Sort an array of values. -!! -!! @param a the sorted array -!! @param first the first value of sorted array -!! @param last the last value of sorted array -!! @author Jili Dong NOAA/EMC -recursive subroutine quicksort(a, first, last) - implicit none - real*8 a(*), x, t - integer first, last - integer i, j - - x = a( (first+last) / 2 ) - i = first - j = last - do - do while (a(i) < x) - i=i+1 - end do - do while (x < a(j)) - j=j-1 - end do - if (i >= j) exit - t = a(i); a(i) = a(j); a(j) = t - i=i+1 - j=j-1 - end do - if (first < i-1) call quicksort(a, first, i-1) - if (j+1 < last) call quicksort(a, j+1, last) -end subroutine quicksort - -!> Check for and replace certain values in soil temperature. -!> At open water points (landmask=0) use skin temperature as -!> a filler value. At land points (landmask=1) with excessive -!> soil temperature, replace soil temperature with skin temperature. -!> In GEFSv12.0 data there are some erroneous missing values at -!> land points which this corrects. At sea ice points (landmask=2), -!> store a default ice column temperature because grib2 files do not -!> have ice column temperature which FV3 expects at these points. -!! -!! @param soilt [inout] 3-dimensional soil temperature arrray -!! @param landmask [in] landmask of the input grid -!! @param skint [in] 2-dimensional skin temperature array -!! @author Larissa Reames CIMMS/NSSL - -subroutine check_soilt(soilt, landmask, skint) - implicit none - real(esmf_kind_r8), intent(inout) :: soilt(i_input,j_input,lsoil_input) - real(esmf_kind_r8), intent(in) :: skint(i_input,j_input) - integer(esmf_kind_i4), intent(in) :: landmask(i_input,j_input) - - integer :: i, j, k - - do k=1,lsoil_input - do j = 1, j_input - do i = 1, i_input - if (landmask(i,j) == 0_esmf_kind_i4 ) then - soilt(i,j,k) = skint(i,j) - else if (landmask(i,j) == 1_esmf_kind_i4 .and. soilt(i,j,k) > 350.0_esmf_kind_r8) then - soilt(i,j,k) = skint(i,j) - else if (landmask(i,j) == 2_esmf_kind_i4 ) then - soilt(i,j,k) = ICET_DEFAULT - endif - enddo - enddo - enddo -end subroutine check_soilt - -!> When using GEFS data, some points on the target grid have -!> unreasonable canpy moisture content, so zero out any -!> locations with unrealistic canopy moisture values (>0.5). -!! -!! @param cnwat [input] 2-dimensional canopy moisture content -!! @author Larissa Reames CIMMS/NSSL - -subroutine check_cnwat(cnwat) - implicit none - real(esmf_kind_r8), intent(inout) :: cnwat(i_input,j_input) - - real(esmf_kind_r8) :: max_cnwat = 0.5 - - integer :: i, j - - do i = 1,i_input - do j = 1,j_input - if (cnwat(i,j) .gt. max_cnwat) cnwat(i,j) = 0.0_esmf_kind_r8 - enddo - enddo -end subroutine check_cnwat - - - - -!> Pressure to presure vertical interpolation for tracers with linear or lnP -!> interpolation. Input tracers on pres levels are interpolated -!> to the target output pressure levels. The matching levels of input and -!> output will keep the same. Extrapolation is also allowed but needs -!> caution. The routine is mostly for GFSV16 combined grib2 input when spfh has -!> missing levels in low and mid troposphere from U/T/HGT/DZDT. -!! -!! @param [in] ppin 1d input pres levs -!! @param [in] xxin 1d input tracer -!! @param [in] npin number of input levs -!! @param [in] ppout 1d target pres levs -!! @param [out] xxout 1d interpolated tracer -!! @param [in] npout number of target levs -!! @param [in] linlog interp method.1:linear;not 1:log;neg:extrp allowed -!! @param [in] xmsg fill values of missing levels (-999.0) -!! @param [out] ier error status. non 0: failed interpolation -!! @author Jili Dong NCEP/EMC -!! @date 2021/07/30 - -SUBROUTINE DINT2P(PPIN,XXIN,NPIN,PPOUT,XXOUT,NPOUT & - ,LINLOG,XMSG,IER) - IMPLICIT NONE - -! NCL code for pressure level interpolation -! -! This code was designed for one simple task. It has since -! been mangled and abused for assorted reasons. For example, -! early gfortran compilers had some issues with automatic arrays. -! Hence, the C-Wrapper was used to create 'work' arrays which -! were then passed to this code. The original focused (non-NCL) -! task was to handle PPIN & PPOUT that had the same 'monotonicity.' -! Extra code was added to handle the more general case. -! Blah-Blah: Punch line: it is embarrassingly convoluted!!! -! -! ! input types - INTEGER NPIN,NPOUT,LINLOG,IER - real*8 PPIN(NPIN),XXIN(NPIN),PPOUT(NPOUT),XMSG - ! output - real*8 XXOUT(NPOUT) - ! work - real*8 PIN(NPIN),XIN(NPIN),P(NPIN),X(NPIN) - real*8 POUT(NPOUT),XOUT(NPOUT) - -! local - INTEGER J1,NP,NL,NIN,NLMAX,NPLVL,NLSAVE,NP1,NO1,N1,N2,LOGLIN, & - NLSTRT - real*8 SLOPE,PA,PB,PC - - LOGLIN = ABS(LINLOG) - -! error check: enough points: pressures consistency? - - IER = 0 - IF (NPOUT.GT.0) THEN - DO NP = 1,NPOUT - XXOUT(NP) = XMSG - END DO - END IF -! Jili Dong input levels have to be the same as output levels: -! we only interpolate for levels with missing variables -! IF (.not. all(PPIN .eq. PPOUT)) IER = IER+1 - - IF (NPIN.LT.2 .OR. NPOUT.LT.1) IER = IER + 1 - - IF (IER.NE.0) THEN -! PRINT *,'INT2P: error exit: ier=',IER - RETURN - END IF - -! should *input arrays* be reordered? want p(1) > p(2) > p(3) etc -! so that it will match order for which code was originally designed -! copy to 'work' arrays - - NP1 = 0 - NO1 = 0 - IF (PPIN(1).LT.PPIN(2)) THEN - NP1 = NPIN + 1 - END IF - IF (PPOUT(1).LT.PPOUT(2)) THEN - NO1 = NPOUT + 1 - END IF - - DO NP = 1,NPIN - PIN(NP) = PPIN(ABS(NP1-NP)) - XIN(NP) = XXIN(ABS(NP1-NP)) - END DO - - DO NP = 1,NPOUT - POUT(NP) = PPOUT(ABS(NO1-NP)) - END DO - -! eliminate XIN levels with missing data. -! . This can happen with observational data. - - NL = 0 - DO NP = 1,NPIN - IF (XIN(NP).NE.XMSG .AND. PIN(NP).NE.XMSG) THEN - NL = NL + 1 - P(NL) = PIN(NP) - X(NL) = XIN(NP) - END IF - END DO - NLMAX = NL - - ! all missing data - IF (NLMAX.LT.2) THEN - IER = IER + 1000 - PRINT *,'INT2P: ier=',IER - RETURN - END IF - -! ===============> pressure in decreasing order <================ -! perform the interpolation [pin(1)>pin(2)>...>pin(npin)] -! ( p ,x) -! ------------------------- p(nl+1), x(nl+1) example (200,5) -! . -! ------------------------- pout(np), xout(np) (250,?) -! . -! ------------------------- p(nl) , x(nl) (300,10) - - -! exact p-level matches - NLSTRT = 1 - NLSAVE = 1 - DO NP = 1,NPOUT - XOUT(NP) = XMSG - DO NL = NLSTRT,NLMAX - IF (POUT(NP).EQ.P(NL)) THEN - XOUT(NP) = X(NL) - NLSAVE = NL + 1 - GO TO 10 - END IF - END DO - 10 NLSTRT = NLSAVE - END DO - - IF (LOGLIN.EQ.1) THEN - DO NP = 1,NPOUT - DO NL = 1,NLMAX - 1 - IF (POUT(NP).LT.P(NL) .AND. POUT(NP).GT.P(NL+1)) THEN - SLOPE = (X(NL)-X(NL+1))/ (P(NL)-P(NL+1)) - XOUT(NP) = X(NL+1) + SLOPE* (POUT(NP)-P(NL+1)) - END IF - END DO - END DO - ELSE - DO NP = 1,NPOUT - DO NL = 1,NLMAX - 1 - IF (POUT(NP).LT.P(NL) .AND. POUT(NP).GT.P(NL+1)) THEN - PA = LOG(P(NL)) - PB = LOG(POUT(NP)) -! special case: In case someome inadvertently enter p=0. - if (p(nl+1).gt.0.d0) then - PC = LOG(P(NL+1)) - else - PC = LOG(1.d-4) - end if - - SLOPE = (X(NL)-X(NL+1))/ (PA-PC) - XOUT(NP) = X(NL+1) + SLOPE* (PB-PC) - END IF - END DO - END DO - END IF - -! extrapolate? -! . use the 'last' valid slope for extrapolating - - IF (LINLOG.LT.0) THEN - DO NP = 1,NPOUT - DO NL = 1,NLMAX - IF (POUT(NP).GT.P(1)) THEN - IF (LOGLIN.EQ.1) THEN - SLOPE = (X(2)-X(1))/ (P(2)-P(1)) - XOUT(NP) = X(1) + SLOPE* (POUT(NP)-P(1)) - ELSE - PA = LOG(P(2)) - PB = LOG(POUT(NP)) - PC = LOG(P(1)) - SLOPE = (X(2)-X(1))/ (PA-PC) - XOUT(NP) = X(1) + SLOPE* (PB-PC) - END IF - ELSE IF (POUT(NP).LT.P(NLMAX)) THEN - N1 = NLMAX - N2 = NLMAX - 1 - IF (LOGLIN.EQ.1) THEN - SLOPE = (X(N1)-X(N2))/ (P(N1)-P(N2)) - XOUT(NP) = X(N1) + SLOPE* (POUT(NP)-P(N1)) - ELSE - PA = LOG(P(N1)) - PB = LOG(POUT(NP)) - PC = LOG(P(N2)) - SLOPE = (X(N1)-X(N2))/ (PA-PC) - !XOUT(NP) = X(N1) + SLOPE* (PB-PC) !bug fixed below - XOUT(NP) = X(N1) + SLOPE* (PB-PA) - END IF - END IF - END DO - END DO - END IF - -! place results in the return array; -! . possibly .... reverse to original order - - if (NO1.GT.0) THEN - DO NP = 1,NPOUT - n1 = ABS(NO1-NP) - PPOUT(NP) = POUT(n1) - XXOUT(NP) = XOUT(n1) - END DO - ELSE - DO NP = 1,NPOUT - PPOUT(NP) = POUT(NP) - XXOUT(NP) = XOUT(NP) - END DO - END IF - - - RETURN - END SUBROUTINE DINT2P - - - end module input_data diff --git a/sorc/chgres_cube.fd/model_grid.F90 b/sorc/chgres_cube.fd/model_grid.F90 index cdd91336b..be52b4c64 100644 --- a/sorc/chgres_cube.fd/model_grid.F90 +++ b/sorc/chgres_cube.fd/model_grid.F90 @@ -11,6 +11,7 @@ module model_grid use esmf use ESMF_LogPublicMod + use utilities, only : error_handler, netcdf_err implicit none private @@ -124,9 +125,9 @@ subroutine define_input_grid(localpet, npets) trim(input_type) == "gfs_gaussian_nemsio" .or. & trim(input_type) == "gfs_sigio" .or. & trim(input_type) == "gaussian_netcdf") then - call define_input_grid_gaussian(localpet, npets) + call define_input_grid_gaussian(npets) elseif (trim(input_type) == "grib2") then - call define_input_grid_grib2(localpet,npets) + call define_input_grid_grib2(npets) else call define_input_grid_mosaic(localpet, npets) endif @@ -141,10 +142,9 @@ end subroutine define_input_grid !! - spectral gfs sigio (prior to July 19, 2017) !! - spectral gfs sfcio (prior to July 19, 2017) !! -!! @param [in] localpet ESMF local persistent execution thread !! @param [in] npets Number of persistent execution threads. !! @author George Gayno NCEP/EMC - subroutine define_input_grid_gaussian(localpet, npets) + subroutine define_input_grid_gaussian(npets) use nemsio_module @@ -160,7 +160,7 @@ subroutine define_input_grid_gaussian(localpet, npets) implicit none - integer, intent(in) :: localpet, npets + integer, intent(in) :: npets character(len=250) :: the_file @@ -607,12 +607,11 @@ end subroutine define_input_grid_mosaic !> Define input grid object for grib2 input data. !! -!! @param [in] localpet ESMF local persistent execution thread !! @param [in] npets Number of persistent execution threads !! @author Larissa Reames !! @author Jeff Beck !! @author George Gayno - subroutine define_input_grid_grib2(localpet,npets) + subroutine define_input_grid_grib2(npets) use grib_mod use gdswzd_mod @@ -620,7 +619,7 @@ subroutine define_input_grid_grib2(localpet,npets) implicit none - integer, intent(in) :: localpet, npets + integer, intent(in) :: npets character(len=500) :: the_file diff --git a/sorc/chgres_cube.fd/nst_input_data.F90 b/sorc/chgres_cube.fd/nst_input_data.F90 new file mode 100644 index 000000000..121e14360 --- /dev/null +++ b/sorc/chgres_cube.fd/nst_input_data.F90 @@ -0,0 +1,812 @@ +module nst_input_data +!> @file +!! @brief Read NST surface data from NEMSIO and NetCDF files. +!! @author George Gayno NCEP/EMC + +!> Read nst data on the input grid. +!! Supported formats include fv3 tiled 'restart' files, fv3 tiled +!! 'history' files, fv3 gaussian history files, and spectral gfs +!! gaussian nemsio files. +!! +!! Public variables are defined below: "input" indicates field +!! associated with the input grid. +!! +!! @author George Gayno NCEP/EMC + use esmf + use netcdf + use nemsio_module + + use program_setup, only : data_dir_input_grid, & + sfc_files_input_grid, & + nst_files_input_grid, & + input_type + + use model_grid, only : input_grid, & + i_input, j_input, & + ip1_input, jp1_input, & + num_tiles_input_grid + + use sfc_input_data, only : lsoil_input, & + read_fv3_grid_data_netcdf, & + landsea_mask_input_grid + + use utilities, only : error_handler + implicit none + +! Fields associated with the nst model. + + type(esmf_field), public :: c_d_input_grid !< Coefficient 2 to calculate d(tz)/d(ts) + type(esmf_field), public :: c_0_input_grid !< Coefficient 1 to calculate d(tz)/d(ts) + type(esmf_field), public :: d_conv_input_grid !< Thickness of free convectionlayer + type(esmf_field), public :: dt_cool_input_grid !< Sub-layer cooling amount + type(esmf_field), public :: ifd_input_grid !< Model mode index. 0-diurnalmodel not + !< started; 1-diurnal model + !started. + type(esmf_field), public :: qrain_input_grid !< Sensible heat flux due torainfall + type(esmf_field), public :: tref_input_grid !< Reference temperature + type(esmf_field), public :: w_d_input_grid !< Coefficient 4 to calculated(tz)/d(ts) + type(esmf_field), public :: w_0_input_grid !< Coefficient 3 to calculated(tz)/d(ts) + type(esmf_field), public :: xs_input_grid !< Salinity content in diurnalthermocline layer + type(esmf_field), public :: xt_input_grid !< Heat content in diurnalthermocline layer + type(esmf_field), public :: xu_input_grid !< u-current content in diurnalthermocline layer + type(esmf_field), public :: xv_input_grid !< v-current content in diurnalthermocline layer + type(esmf_field), public :: xz_input_grid !< Diurnal thermocline layerthickness + type(esmf_field), public :: xtts_input_grid !< d(xt)/d(ts) + type(esmf_field), public :: xzts_input_grid !< d(xz)/d(ts) + type(esmf_field), public :: z_c_input_grid !< Sub-layer cooling thickness + type(esmf_field), public :: zm_input_grid !< Oceanic mixed layer depth + + public :: read_input_nst_data + public :: cleanup_input_nst_data + + contains +!> Driver to read input grid nst data. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_nst_data(localpet) + + implicit none + + integer, intent(in) :: localpet + + integer :: rc + + print*,"- READ INPUT GRID NST DATA." + + print*,"- CALL FieldCreate FOR INPUT GRID C_D." + c_d_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID C_0." + c_0_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID D_CONV." + d_conv_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID DT_COOL." + dt_cool_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID IFD." + ifd_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID QRAIN." + qrain_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID TREF." + tref_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID W_D." + w_d_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID W_0." + w_0_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID XS." + xs_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID XT." + xt_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID XU." + xu_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID XV." + xv_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID XZ." + xz_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID XTTS." + xtts_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID XZTS." + xzts_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID Z_C." + z_c_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID ZM." + zm_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + +!-------------------------------------------------------------------------- +! Read input grid nst data from a fv3 gaussian nemsio history file or +! spectral GFS nemsio file. +!-------------------------------------------------------------------------- + + if (trim(input_type) == "gaussian_nemsio" .or. trim(input_type) == "gfs_gaussian_nemsio") then + + call read_input_nst_nemsio_file(localpet) + +!--------------------------------------------------------------------------- +! Read nst data from these netcdf formatted fv3 files: tiled history, +! tiled warm restart, and gaussian history. +!--------------------------------------------------------------------------- + + else + + call read_input_nst_netcdf_file(localpet) + + endif + + end subroutine read_input_nst_data + + !> Read nst data from these netcdf formatted fv3 files: tiled history, +!! tiled warm restart, and gaussian history. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_nst_netcdf_file(localpet) + + implicit none + + integer, intent(in) :: localpet + + character(len=10) :: field + + integer :: rc, tile + + real(esmf_kind_r8), allocatable :: data_one_tile(:,:) + + if (localpet == 0) then + allocate(data_one_tile(i_input,j_input)) + else + allocate(data_one_tile(0,0)) + endif + + TILE_LOOP : do tile = 1, num_tiles_input_grid + +! c_d + + if (localpet == 0) then + if (trim(input_type) == "restart") then + field='c_d' + else + field='cd' + endif + call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT C_D" + call ESMF_FieldScatter(c_d_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! c_0 + + if (localpet == 0) then + if (trim(input_type) == "restart") then + field='c_0' + else + field='c0' + endif + call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT C_0" + call ESMF_FieldScatter(c_0_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! d_conv + + if (localpet == 0) then + if (trim(input_type) == "restart") then + field='d_conv' + else + field='dconv' + endif + call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT D_CONV." + call ESMF_FieldScatter(d_conv_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! dt_cool + + if (localpet == 0) then + if (trim(input_type) == "restart") then + field='dt_cool' + else + field='dtcool' + endif + call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT DT_COOL." + call ESMF_FieldScatter(dt_cool_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! ifd - xu li said initialize to '1'. + + if (localpet == 0) then + data_one_tile = 1.0 + endif + + print*,"- CALL FieldScatter FOR INPUT IFD." + call ESMF_FieldScatter(ifd_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! qrain + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('qrain', tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT QRAIN." + call ESMF_FieldScatter(qrain_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! tref + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('tref', tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT TREF" + call ESMF_FieldScatter(tref_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! w_d + + if (localpet == 0) then + if (trim(input_type) == "restart") then + field='w_d' + else + field='wd' + endif + call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT W_D" + call ESMF_FieldScatter(w_d_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! w_0 + + if (localpet == 0) then + if (trim(input_type) == "restart") then + field='w_0' + else + field='w0' + endif + call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT W_0" + call ESMF_FieldScatter(w_0_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! xs + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('xs', tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT XS" + call ESMF_FieldScatter(xs_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! xt + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('xt', tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT XT" + call ESMF_FieldScatter(xt_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! xu + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('xu', tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT XU" + call ESMF_FieldScatter(xu_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! xv + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('xv', tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT XV" + call ESMF_FieldScatter(xv_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! xz + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('xz', tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT XZ" + call ESMF_FieldScatter(xz_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! xtts + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('xtts', tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT XTTS" + call ESMF_FieldScatter(xtts_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! xzts + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('xzts', tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT XZTS" + call ESMF_FieldScatter(xzts_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! z_c + + if (localpet == 0) then + if (trim(input_type) == "restart") then + field='z_c' + else + field='zc' + endif + call read_fv3_grid_data_netcdf(trim(field), tile, i_input, j_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT Z_C" + call ESMF_FieldScatter(z_c_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! zm - Not used yet. Xu li said set to '0'. + + if (localpet == 0) then + data_one_tile = 0.0 + endif + + print*,"- CALL FieldScatter FOR INPUT ZM" + call ESMF_FieldScatter(zm_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + enddo TILE_LOOP + + deallocate(data_one_tile) + + end subroutine read_input_nst_netcdf_file + +!> Read input grid nst data from fv3 gaussian nemsio history file or +!! spectral GFS nemsio file. +!! +!! @note The spectral GFS nst data is in a separate file from +!! the surface data. The fv3 surface and nst data are in a +!! single file. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_nst_nemsio_file(localpet) + + implicit none + + integer, intent(in) :: localpet + + character(len=300) :: the_file + + integer :: rc + + real(nemsio_realkind), allocatable :: dummy(:) + real(esmf_kind_r8), allocatable :: dummy2d(:,:) + + type(nemsio_gfile) :: gfile + + if (trim(input_type) == "gfs_gaussian_nemsio") then ! spectral gfs nemsio in + ! separate file. + the_file = trim(data_dir_input_grid) // "/" // trim(nst_files_input_grid) + else + the_file = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) + endif + + print*,"- READ NST DATA FROM: ", trim(the_file) + + if (localpet == 0) then + allocate(dummy(i_input*j_input)) + allocate(dummy2d(i_input,j_input)) + call nemsio_open(gfile, the_file, "read", iret=rc) + else + allocate(dummy(0)) + allocate(dummy2d(0,0)) + endif + + if (localpet == 0) then + print*,"- READ TREF" + call nemsio_readrecv(gfile, "tref", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING TREF.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'tref ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT TREF." + call ESMF_FieldScatter(tref_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ CD" + call nemsio_readrecv(gfile, "cd", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING CD.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'cd ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT C_D." + call ESMF_FieldScatter(c_d_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ C0" + call nemsio_readrecv(gfile, "c0", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING C0.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'c0 ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT C_0." + call ESMF_FieldScatter(c_0_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ DCONV" + call nemsio_readrecv(gfile, "dconv", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING DCONV.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'dconv ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT D_CONV." + call ESMF_FieldScatter(d_conv_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ DTCOOL" + call nemsio_readrecv(gfile, "dtcool", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING DTCOOL.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'dtcool ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT DT_COOL." + call ESMF_FieldScatter(dt_cool_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + dummy2d = 1.0 ! IFD not in file. Set to '1' per Xu Li. + endif + + print*,"- CALL FieldScatter FOR INPUT IFD." + call ESMF_FieldScatter(ifd_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ QRAIN" + call nemsio_readrecv(gfile, "qrain", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING QRAIN.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'qrain ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT QRAIN." + call ESMF_FieldScatter(qrain_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ WD" + call nemsio_readrecv(gfile, "wd", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING WD.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'wd ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT WD." + call ESMF_FieldScatter(w_d_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ W0" + call nemsio_readrecv(gfile, "w0", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING W0.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'w0 ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT W0." + call ESMF_FieldScatter(w_0_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ XS" + call nemsio_readrecv(gfile, "xs", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING XS.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'xs ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT XS." + call ESMF_FieldScatter(xs_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ XT" + call nemsio_readrecv(gfile, "xt", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING XT.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'xt ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT XT." + call ESMF_FieldScatter(xt_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ XU" + call nemsio_readrecv(gfile, "xu", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING XU.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'xu ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT XU." + call ESMF_FieldScatter(xu_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ XV" + call nemsio_readrecv(gfile, "xv", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING XV.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'xv ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT XV." + call ESMF_FieldScatter(xv_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ XZ" + call nemsio_readrecv(gfile, "xz", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING XZ.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'xz ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT XZ." + call ESMF_FieldScatter(xz_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ XTTS" + call nemsio_readrecv(gfile, "xtts", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING XTTS.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'xtts ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT XTTS." + call ESMF_FieldScatter(xtts_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ XZTS" + call nemsio_readrecv(gfile, "xzts", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING XZTS.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'xzts ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT XZTS." + call ESMF_FieldScatter(xzts_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ ZC" + call nemsio_readrecv(gfile, "zc", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING ZC.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'zc ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT Z_C." + call ESMF_FieldScatter(z_c_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + dummy2d = 0.0 ! zm not used yet. Set to zero per Xu Li. + endif + + print*,"- CALL FieldScatter FOR INPUT ZM." + call ESMF_FieldScatter(zm_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + deallocate(dummy, dummy2d) + + if (localpet == 0) call nemsio_close(gfile) + + end subroutine read_input_nst_nemsio_file + + !> Free up memory associated with nst data. +!! +!! @author George Gayno NCEP/EMC + subroutine cleanup_input_nst_data + + implicit none + + integer :: rc + + print*,'- DESTROY NST INPUT DATA.' + + call ESMF_FieldDestroy(landsea_mask_input_grid, rc=rc) + call ESMF_FieldDestroy(c_d_input_grid, rc=rc) + call ESMF_FieldDestroy(c_0_input_grid, rc=rc) + call ESMF_FieldDestroy(d_conv_input_grid, rc=rc) + call ESMF_FieldDestroy(dt_cool_input_grid, rc=rc) + call ESMF_FieldDestroy(ifd_input_grid, rc=rc) + call ESMF_FieldDestroy(qrain_input_grid, rc=rc) + call ESMF_FieldDestroy(tref_input_grid, rc=rc) + call ESMF_FieldDestroy(w_d_input_grid, rc=rc) + call ESMF_FieldDestroy(w_0_input_grid, rc=rc) + call ESMF_FieldDestroy(xs_input_grid, rc=rc) + call ESMF_FieldDestroy(xt_input_grid, rc=rc) + call ESMF_FieldDestroy(xu_input_grid, rc=rc) + call ESMF_FieldDestroy(xv_input_grid, rc=rc) + call ESMF_FieldDestroy(xz_input_grid, rc=rc) + call ESMF_FieldDestroy(xtts_input_grid, rc=rc) + call ESMF_FieldDestroy(xzts_input_grid, rc=rc) + call ESMF_FieldDestroy(z_c_input_grid, rc=rc) + call ESMF_FieldDestroy(zm_input_grid, rc=rc) + + end subroutine cleanup_input_nst_data + + end module nst_input_data diff --git a/sorc/chgres_cube.fd/program_setup.F90 b/sorc/chgres_cube.fd/program_setup.F90 index 722e701a7..1dcb4d22e 100644 --- a/sorc/chgres_cube.fd/program_setup.F90 +++ b/sorc/chgres_cube.fd/program_setup.F90 @@ -8,6 +8,9 @@ !! @author George Gayno NCEP/EMC module program_setup + use esmf + use utilities, only : error_handler, to_lower + implicit none private @@ -131,10 +134,9 @@ module program_setup real, allocatable, public :: wltsmc_target(:) !< Plant wilting point soil moisture content target grid. real, allocatable, public :: bb_target(:) !< Soil 'b' parameter, target grid real, allocatable, public :: satpsi_target(:) !< Saturated soil potential, target grid - real, allocatable, public :: missing_var_values(:) !< If input GRIB2 record is missing, the variable - !! is set to this value. + real(kind=esmf_kind_r4), allocatable, public :: missing_var_values(:) !< If input GRIB2 record is missing, the variable + !! is set to this value. - public :: read_setup_namelist public :: calc_soil_params_driver public :: read_varmap @@ -144,15 +146,14 @@ module program_setup !> Reads program configuration namelist. !! -!! @param filename the name of the configuration file (defaults to +!! @param filename The name of the configuration file (defaults to !! ./fort.41). !! @author George Gayno NCEP/EMC subroutine read_setup_namelist(filename) implicit none character(len=*), intent(in), optional :: filename - character(:), allocatable :: filename_to_use - + character(len=250), allocatable :: filename_to_use integer :: is, ie, ierr @@ -195,12 +196,12 @@ subroutine read_setup_namelist(filename) print*,"- READ SETUP NAMELIST" if (present(filename)) then - filename_to_use = filename + filename_to_use = filename else - filename_to_use = "./fort.41" + filename_to_use = "./fort.41" endif - open(41, file=filename_to_use, iostat=ierr) + open(41, file=trim(filename_to_use), iostat=ierr) if (ierr /= 0) call error_handler("OPENING SETUP NAMELIST.", ierr) read(41, nml=config, iostat=ierr) if (ierr /= 0) call error_handler("READING SETUP NAMELIST.", ierr) @@ -304,9 +305,9 @@ subroutine read_setup_namelist(filename) !------------------------------------------------------------------------- if (trim(input_type) == "grib2") then - if (trim(grib2_file_input_grid) == "NULL" .or. trim(grib2_file_input_grid) == "") then - call error_handler("FOR GRIB2 DATA, PLEASE PROVIDE GRIB2_FILE_INPUT_GRID", 1) - endif + if (trim(grib2_file_input_grid) == "NULL" .or. trim(grib2_file_input_grid) == "") then + call error_handler("FOR GRIB2 DATA, PLEASE PROVIDE GRIB2_FILE_INPUT_GRID", 1) + endif endif !------------------------------------------------------------------------- @@ -314,14 +315,14 @@ subroutine read_setup_namelist(filename) !------------------------------------------------------------------------- if (trim(input_type) == "grib2") then - if (.not. any((/character(4)::"GFS","NAM","RAP","HRRR"/)==trim(external_model))) then - call error_handler( "KNOWN SUPPORTED external_model INPUTS ARE GFS, NAM, RAP, AND HRRR. " // & - "IF YOU WISH TO PROCESS GRIB2 DATA FROM ANOTHER MODEL, YOU MAY ATTEMPT TO DO SO AT YOUR OWN RISK. " // & - "ONE WAY TO DO THIS IS PROVIDE NAM FOR external_model AS IT IS A RELATIVELY STRAIGHT-" // & - "FORWARD REGIONAL GRIB2 FILE. YOU MAY ALSO COMMENT OUT THIS ERROR MESSAGE IN " // & - "program_setup.f90 LINE 389. NO GUARANTEE IS PROVIDED THAT THE CODE WILL WORK OR "// & - "THAT THE RESULTING DATA WILL BE CORRECT OR WORK WITH THE ATMOSPHERIC MODEL.", 1) - endif + if (.not. any((/character(4)::"GFS","NAM","RAP","HRRR"/)==trim(external_model))) then + call error_handler( "KNOWN SUPPORTED external_model INPUTS ARE GFS, NAM, RAP, AND HRRR. " // & + "IF YOU WISH TO PROCESS GRIB2 DATA FROM ANOTHER MODEL, YOU MAY ATTEMPT TO DO SO AT YOUR OWN RISK. " // & + "ONE WAY TO DO THIS IS PROVIDE NAM FOR external_model AS IT IS A RELATIVELY STRAIGHT-" // & + "FORWARD REGIONAL GRIB2 FILE. YOU MAY ALSO COMMENT OUT THIS ERROR MESSAGE IN " // & + "program_setup.f90 LINE 389. NO GUARANTEE IS PROVIDED THAT THE CODE WILL WORK OR "// & + "THAT THE RESULTING DATA WILL BE CORRECT OR WORK WITH THE ATMOSPHERIC MODEL.", 1) + endif endif !------------------------------------------------------------------------- @@ -330,11 +331,10 @@ subroutine read_setup_namelist(filename) !------------------------------------------------------------------------- if (trim(input_type) == "grib2" .and. trim(external_model)=="HRRR") then - if (trim(geogrid_file_input_grid) == "NULL" .or. trim(grib2_file_input_grid) == "") then - print*, "HRRR DATA DOES NOT CONTAIN SOIL TYPE INFORMATION. WITHOUT & - GEOGRID_FILE_INPUT_GRID SPECIFIED, SOIL MOISTURE INTERPOLATION MAY BE LESS & - ACCURATE. " - endif + if (trim(geogrid_file_input_grid) == "NULL" .or. trim(grib2_file_input_grid) == "") then + print*, "HRRR DATA DOES NOT CONTAIN SOIL TYPE INFORMATION. WITHOUT" + print*, "GEOGRID_FILE_INPUT_GRID SPECIFIED, SOIL MOISTURE INTERPOLATION MAY BE LESS ACCURATE." + endif endif if (trim(thomp_mp_climo_file) /= "NULL") then @@ -442,7 +442,6 @@ end subroutine read_varmap !! @author Jeff Beck subroutine get_var_cond(var_name,this_miss_var_method,this_miss_var_value, & this_field_var_name, loc) - use esmf implicit none character(len=20), intent(in) :: var_name diff --git a/sorc/chgres_cube.fd/sfc_input_data.F90 b/sorc/chgres_cube.fd/sfc_input_data.F90 new file mode 100644 index 000000000..4ea4d7629 --- /dev/null +++ b/sorc/chgres_cube.fd/sfc_input_data.F90 @@ -0,0 +1,3351 @@ +module sfc_input_data +!> @file +!! @brief Read atmospheric and surface data from GRIB2, NEMSIO and NetCDF files. +!! @author George Gayno NCEP/EMC + +!> Read atmospheric, surface and nst data on the input grid. +!! Supported formats include fv3 tiled 'restart' files, fv3 tiled +!! 'history' files, fv3 gaussian history files, spectral gfs +!! gaussian nemsio files, and spectral gfs sigio/sfcio files. +!! +!! Public variables are defined below: "input" indicates field +!! associated with the input grid. +!! +!! @author George Gayno NCEP/EMC + use esmf + use netcdf + use nemsio_module + + use program_setup, only : data_dir_input_grid, & + sfc_files_input_grid, & + grib2_file_input_grid, & + convert_nst, & + orog_dir_input_grid, & + orog_files_input_grid, & + input_type, & + get_var_cond, & + geogrid_file_input_grid, & + external_model, & + vgfrc_from_climo, & + minmax_vgfrc_from_climo, & + lai_from_climo,& + read_from_input + + use model_grid, only : input_grid, & + i_input, j_input, & + ip1_input, jp1_input, & + num_tiles_input_grid + use atm_input_data, only : terrain_input_grid + + use utilities, only : error_handler, & + netcdf_err, & + handle_grib_error, & + to_upper, & + check_soilt, & + check_cnwat + +! Fields associated with the land-surface model. + + integer, public :: veg_type_landice_input = 15 !< NOAH land ice option + !< defined at this veg type. + !< Default is igbp. + real :: ICET_DEFAULT = 265.0 !< Default value of soil and skin + !< temperature (K) over ice. + type(esmf_field), public :: canopy_mc_input_grid !< canopy moist content + type(esmf_field), public :: f10m_input_grid !< log((z0+10)*1/z0) + type(esmf_field), public :: ffmm_input_grid !< log((z0+z1)*1/z0) + !! See sfc_diff.f for details. + type(esmf_field), public :: landsea_mask_input_grid !< land sea mask; + !! 0-water, 1-land, 2-ice + type(esmf_field), public :: q2m_input_grid !< 2-m spec hum + type(esmf_field), public :: seaice_depth_input_grid !< sea ice depth + type(esmf_field), public :: seaice_fract_input_grid !< sea ice fraction + type(esmf_field), public :: seaice_skin_temp_input_grid !< sea ice skin temp + type(esmf_field), public :: skin_temp_input_grid !< skin temp/sst + type(esmf_field), public :: snow_depth_input_grid !< snow dpeth + type(esmf_field), public :: snow_liq_equiv_input_grid !< snow liq equiv depth + type(esmf_field), public :: soil_temp_input_grid !< 3-d soil temp + type(esmf_field), public :: soil_type_input_grid !< soil type + type(esmf_field), public :: soilm_liq_input_grid !< 3-d liquid soil moisture + type(esmf_field), public :: soilm_tot_input_grid !< 3-d total soil moisture + type(esmf_field), public :: srflag_input_grid !< snow/rain flag + type(esmf_field), public :: t2m_input_grid !< 2-m temperature + type(esmf_field), public :: tprcp_input_grid !< precip + type(esmf_field), public :: ustar_input_grid !< fric velocity + type(esmf_field), public :: veg_type_input_grid !< vegetation type + type(esmf_field), public :: z0_input_grid !< roughness length + type(esmf_field), public :: veg_greenness_input_grid !< vegetation fraction + type(esmf_field), public :: lai_input_grid !< leaf area index + type(esmf_field), public :: max_veg_greenness_input_grid !< shdmax + type(esmf_field), public :: min_veg_greenness_input_grid !< shdmin + + integer, public :: lsoil_input=4 !< number of soil layers, no longer hardwired to allow + !! for 7 layers of soil for the RUC LSM + + public :: read_input_sfc_data + public :: cleanup_input_sfc_data + public :: init_sfc_esmf_fields + + contains + + !> Driver to read input grid surface data. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_sfc_data(localpet) + + implicit none + + integer, intent(in) :: localpet + + call init_sfc_esmf_fields() + +!------------------------------------------------------------------------------- +! Read the tiled 'warm' restart files. +!------------------------------------------------------------------------------- + + if (trim(input_type) == "restart") then + + call read_input_sfc_restart_file(localpet) + +!------------------------------------------------------------------------------- +! Read the tiled or gaussian history files in netcdf format. +!------------------------------------------------------------------------------- + + elseif (trim(input_type) == "history" .or. trim(input_type) == & + "gaussian_netcdf") then + + call read_input_sfc_netcdf_file(localpet) + +!------------------------------------------------------------------------------- +! Read the gaussian history files in nemsio format. +!------------------------------------------------------------------------------- + + elseif (trim(input_type) == "gaussian_nemsio") then + + call read_input_sfc_gaussian_nemsio_file(localpet) + +!------------------------------------------------------------------------------- +! Read the spectral gfs gaussian history files in nemsio format. +!------------------------------------------------------------------------------- + + elseif (trim(input_type) == "gfs_gaussian_nemsio") then + + call read_input_sfc_gfs_gaussian_nemsio_file(localpet) + +!------------------------------------------------------------------------------- +! Read the spectral gfs gaussian history files in sfcio format. +!------------------------------------------------------------------------------- + + elseif (trim(input_type) == "gfs_sigio") then + + call read_input_sfc_gfs_sfcio_file(localpet) + +!------------------------------------------------------------------------------- +! Read fv3gfs surface data in grib2 format. +!------------------------------------------------------------------------------- + + elseif (trim(input_type) == "grib2") then + + call read_input_sfc_grib2_file(localpet) + + endif + + end subroutine read_input_sfc_data + + !> Read input grid surface data from a spectral gfs gaussian sfcio +!! file. +!! +!! @note Prior to July 19, 2017. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_sfc_gfs_sfcio_file(localpet) + + use sfcio_module + + implicit none + + integer, intent(in) :: localpet + + character(len=300) :: the_file + + integer(sfcio_intkind) :: iret + integer :: rc + + real(esmf_kind_r8), allocatable :: dummy2d(:,:) + real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) + + type(sfcio_head) :: sfchead + type(sfcio_dbta) :: sfcdata + + the_file = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) + + print*,"- READ SURFACE DATA IN SFCIO FORMAT." + print*,"- OPEN AND READ: ",trim(the_file) + call sfcio_sropen(23, trim(the_file), iret) + if (iret /= 0) then + rc=iret + call error_handler("OPENING FILE", rc) + endif + + call sfcio_srhead(23, sfchead, iret) + if (iret /= 0) then + rc=iret + call error_handler("READING HEADER", rc) + endif + + if (localpet == 0) then + call sfcio_aldbta(sfchead, sfcdata, iret) + if (iret /= 0) then + rc=iret + call error_handler("ALLOCATING DATA.", rc) + endif + call sfcio_srdbta(23, sfchead, sfcdata, iret) + if (iret /= 0) then + rc=iret + call error_handler("READING DATA.", rc) + endif + allocate(dummy2d(i_input,j_input)) + allocate(dummy3d(i_input,j_input,lsoil_input)) + else + allocate(dummy2d(0,0)) + allocate(dummy3d(0,0,0)) + endif + + if (localpet == 0) dummy2d = sfcdata%slmsk + + print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." + call ESMF_FieldScatter(landsea_mask_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%zorl + + print*,"- CALL FieldScatter FOR INPUT Z0." + call ESMF_FieldScatter(z0_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = nint(sfcdata%vtype) + + print*,"- CALL FieldScatter FOR INPUT VEG TYPE." + call ESMF_FieldScatter(veg_type_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Prior to July, 2017, gfs used zobler soil types. '13' indicates permanent land ice. + veg_type_landice_input = 13 + + if (localpet == 0) dummy2d = sfcdata%canopy + + print*,"- CALL FieldScatter FOR INPUT CANOPY MC." + call ESMF_FieldScatter(canopy_mc_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%fice + + print*,"- CALL FieldScatter FOR INPUT ICE FRACTION." + call ESMF_FieldScatter(seaice_fract_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%hice + + print*,"- CALL FieldScatter FOR INPUT ICE DEPTH." + call ESMF_FieldScatter(seaice_depth_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%tisfc + + print*,"- CALL FieldScatter FOR INPUT ICE SKIN TEMP." + call ESMF_FieldScatter(seaice_skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%snwdph ! mm (expected by program) + + print*,"- CALL FieldScatter FOR INPUT SNOW DEPTH." + call ESMF_FieldScatter(snow_depth_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%sheleg + + print*,"- CALL FieldScatter FOR INPUT SNOW LIQUID EQUIV." + call ESMF_FieldScatter(snow_liq_equiv_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%t2m + + print*,"- CALL FieldScatter FOR INPUT T2M." + call ESMF_FieldScatter(t2m_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%q2m + + print*,"- CALL FieldScatter FOR INPUT Q2M." + call ESMF_FieldScatter(q2m_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%tprcp + + print*,"- CALL FieldScatter FOR INPUT TPRCP." + call ESMF_FieldScatter(tprcp_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%f10m + + print*,"- CALL FieldScatter FOR INPUT F10M." + call ESMF_FieldScatter(f10m_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%uustar + + print*,"- CALL FieldScatter FOR INPUT USTAR." + call ESMF_FieldScatter(ustar_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%ffmm + + print*,"- CALL FieldScatter FOR INPUT FFMM." + call ESMF_FieldScatter(ffmm_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%srflag + + print*,"- CALL FieldScatter FOR INPUT SRFLAG." + call ESMF_FieldScatter(srflag_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%tsea + + print*,"- CALL FieldScatter FOR INPUT SKIN TEMP." + call ESMF_FieldScatter(skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = nint(sfcdata%stype) + + print*,"- CALL FieldScatter FOR INPUT SOIL TYPE." + call ESMF_FieldScatter(soil_type_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = sfcdata%orog + + print*,"- CALL FieldScatter FOR INPUT TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy3d = sfcdata%slc + + print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." + call ESMF_FieldScatter(soilm_liq_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy3d = sfcdata%smc + + print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." + call ESMF_FieldScatter(soilm_tot_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy3d = sfcdata%stc + + print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." + call ESMF_FieldScatter(soil_temp_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + deallocate(dummy2d, dummy3d) + call sfcio_axdbta(sfcdata, iret) + + call sfcio_sclose(23, iret) + + end subroutine read_input_sfc_gfs_sfcio_file + +!> Read input grid surface data from a spectral gfs gaussian nemsio +!! file. +!! +!! @note Format used by gfs starting July 19, 2017. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_sfc_gfs_gaussian_nemsio_file(localpet) + + implicit none + + integer, intent(in) :: localpet + + character(len=300) :: the_file + + integer :: rc + + real(nemsio_realkind), allocatable :: dummy(:) + real(esmf_kind_r8), allocatable :: dummy2d(:,:) + real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) + + type(nemsio_gfile) :: gfile + + the_file = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) + + if (localpet == 0) then + allocate(dummy3d(i_input,j_input,lsoil_input)) + allocate(dummy2d(i_input,j_input)) + allocate(dummy(i_input*j_input)) + print*,"- OPEN FILE ", trim(the_file) + call nemsio_open(gfile, the_file, "read", iret=rc) + if (rc /= 0) call error_handler("OPENING FILE.", rc) + else + allocate(dummy3d(0,0,0)) + allocate(dummy2d(0,0)) + allocate(dummy(0)) + endif + + if (localpet == 0) then + print*,"- READ TERRAIN." + call nemsio_readrecv(gfile, "orog", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING TERRAIN.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'orog ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ LANDSEA MASK." + call nemsio_readrecv(gfile, "land", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LANDSEA MASK.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'landmask ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." + call ESMF_FieldScatter(landsea_mask_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SEAICE FRACTION." + call nemsio_readrecv(gfile, "icec", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SEAICE FRACTION.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'icec ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE FRACTION." + call ESMF_FieldScatter(seaice_fract_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SEAICE DEPTH." + call nemsio_readrecv(gfile, "icetk", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SEAICE DEPTH.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'icetk ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE DEPTH." + call ESMF_FieldScatter(seaice_depth_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SEAICE SKIN TEMPERATURE." + call nemsio_readrecv(gfile, "tisfc", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SEAICE SKIN TEMP.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'ti ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE SKIN TEMPERATURE." + call ESMF_FieldScatter(seaice_skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SNOW LIQUID EQUIVALENT." + call nemsio_readrecv(gfile, "weasd", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SNOW LIQUID EQUIVALENT.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'weasd ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SNOW LIQUID EQUIVALENT." + call ESMF_FieldScatter(snow_liq_equiv_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SNOW DEPTH." + call nemsio_readrecv(gfile, "snod", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SNOW DEPTH.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'snod ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SNOW DEPTH." + call ESMF_FieldScatter(snow_depth_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ VEG TYPE." + call nemsio_readrecv(gfile, "vtype", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING VEG TYPE", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'vtype ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID VEG TYPE." + call ESMF_FieldScatter(veg_type_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SOIL TYPE." + call nemsio_readrecv(gfile, "sotyp", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SOIL TYPE.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'sotype ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SOIL TYPE." + call ESMF_FieldScatter(soil_type_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ T2M." + call nemsio_readrecv(gfile, "tmp", "2 m above gnd", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING T2M.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'t2m ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID T2M." + call ESMF_FieldScatter(t2m_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ Q2M." + call nemsio_readrecv(gfile, "spfh", "2 m above gnd", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING Q2M.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'q2m ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID Q2M." + call ESMF_FieldScatter(q2m_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ TPRCP." + call nemsio_readrecv(gfile, "tprcp", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING TPRCP.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'tprcp ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID TPRCP." + call ESMF_FieldScatter(tprcp_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ FFMM." + call nemsio_readrecv(gfile, "ffmm", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING FFMM.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'ffmm ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID FFMM" + call ESMF_FieldScatter(ffmm_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ USTAR." + call nemsio_readrecv(gfile, "fricv", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING USTAR.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'fricv ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID USTAR" + call ESMF_FieldScatter(ustar_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = 0.0 + print*,"- CALL FieldScatter FOR INPUT GRID SRFLAG" + call ESMF_FieldScatter(srflag_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SKIN TEMPERATURE." + call nemsio_readrecv(gfile, "tmp", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SKIN TEMPERATURE.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'tmp ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SKIN TEMPERATURE" + call ESMF_FieldScatter(skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ F10M." + call nemsio_readrecv(gfile, "f10m", "10 m above gnd", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING F10M.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'f10m ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID F10M." + call ESMF_FieldScatter(f10m_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ CANOPY MOISTURE CONTENT." + call nemsio_readrecv(gfile, "cnwat", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING CANOPY MOISTURE CONTENT.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'cnwat ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID CANOPY MOISTURE CONTENT." + call ESMF_FieldScatter(canopy_mc_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ Z0." + call nemsio_readrecv(gfile, "sfcr", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING Z0.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'sfcr ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID Z0." + call ESMF_FieldScatter(z0_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + deallocate(dummy2d) + + if (localpet == 0) then + print*,"- READ LIQUID SOIL MOISTURE." + call nemsio_readrecv(gfile, "slc", "soil layer", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 1 LIQUID SOIL MOIST.", rc) + dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "slc", "soil layer", 2, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 2 LIQUID SOIL MOIST.", rc) + dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "slc", "soil layer", 3, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 3 LIQUID SOIL MOIST.", rc) + dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "slc", "soil layer", 4, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 4 LIQUID SOIL MOIST.", rc) + dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) + print*,'slc ',maxval(dummy3d),minval(dummy3d) + endif + + print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." + call ESMF_FieldScatter(soilm_liq_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ TOTAL SOIL MOISTURE." + call nemsio_readrecv(gfile, "smc", "soil layer", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 1 TOTAL SOIL MOIST.", rc) + dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "smc", "soil layer", 2, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 2 TOTAL SOIL MOIST.", rc) + dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "smc", "soil layer", 3, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 3 TOTAL SOIL MOIST.", rc) + dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "smc", "soil layer", 4, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 4 TOTAL SOIL MOIST.", rc) + dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) + print*,'smc ',maxval(dummy3d),minval(dummy3d) + endif + + print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." + call ESMF_FieldScatter(soilm_tot_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SOIL TEMPERATURE." + call nemsio_readrecv(gfile, "stc", "soil layer", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 1 SOIL TEMP.", rc) + dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "stc", "soil layer", 2, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 2 SOIL TEMP.", rc) + dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "stc", "soil layer", 3, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 3 SOIL TEMP.", rc) + dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "stc", "soil layer", 4, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 4 SOIL TEMP.", rc) + dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) + print*,'stc ',maxval(dummy3d),minval(dummy3d) + endif + + print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." + call ESMF_FieldScatter(soil_temp_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + deallocate(dummy3d, dummy) + + if (localpet == 0) call nemsio_close(gfile) + + end subroutine read_input_sfc_gfs_gaussian_nemsio_file + +!> Read input grid surface data from an fv3 gaussian nemsio file. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_sfc_gaussian_nemsio_file(localpet) + + implicit none + + integer, intent(in) :: localpet + + character(len=250) :: the_file + + integer :: rc + + real(nemsio_realkind), allocatable :: dummy(:) + real(esmf_kind_r8), allocatable :: dummy2d(:,:) + real(esmf_kind_r8), allocatable :: dummy3d(:,:,:) + + type(nemsio_gfile) :: gfile + + the_file = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) + + if (localpet == 0) then + allocate(dummy3d(i_input,j_input,lsoil_input)) + allocate(dummy2d(i_input,j_input)) + allocate(dummy(i_input*j_input)) + print*,"- OPEN FILE ", trim(the_file) + call nemsio_open(gfile, the_file, "read", iret=rc) + if (rc /= 0) call error_handler("OPENING FILE.", rc) + else + allocate(dummy3d(0,0,0)) + allocate(dummy2d(0,0)) + allocate(dummy(0)) + endif + + if (localpet == 0) then + print*,"- READ TERRAIN." + call nemsio_readrecv(gfile, "orog", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING TERRAIN.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'orog ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ LANDSEA MASK." + call nemsio_readrecv(gfile, "land", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LANDSEA MASK.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'landmask ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." + call ESMF_FieldScatter(landsea_mask_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SEAICE FRACTION." + call nemsio_readrecv(gfile, "icec", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SEAICE FRACTION.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'icec ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE FRACTION." + call ESMF_FieldScatter(seaice_fract_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SEAICE DEPTH." + call nemsio_readrecv(gfile, "icetk", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SEAICE DEPTH.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'icetk ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE DEPTH." + call ESMF_FieldScatter(seaice_depth_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SEAICE SKIN TEMPERATURE." + call nemsio_readrecv(gfile, "ti", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SEAICE SKIN TEMP.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'ti ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE SKIN TEMPERATURE." + call ESMF_FieldScatter(seaice_skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SNOW LIQUID EQUIVALENT." + call nemsio_readrecv(gfile, "weasd", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SNOW LIQUID EQUIVALENT.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'weasd ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SNOW LIQUID EQUIVALENT." + call ESMF_FieldScatter(snow_liq_equiv_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SNOW DEPTH." + call nemsio_readrecv(gfile, "snod", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SNOW DEPTH.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) * 1000.0_8 + print*,'snod ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SNOW DEPTH." + call ESMF_FieldScatter(snow_depth_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ VEG TYPE." + call nemsio_readrecv(gfile, "vtype", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING VEG TYPE", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'vtype ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID VEG TYPE." + call ESMF_FieldScatter(veg_type_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SOIL TYPE." + call nemsio_readrecv(gfile, "sotyp", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SOIL TYPE.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'sotype ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SOIL TYPE." + call ESMF_FieldScatter(soil_type_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ T2M." + call nemsio_readrecv(gfile, "tmp", "2 m above gnd", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING T2M.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'t2m ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID T2M." + call ESMF_FieldScatter(t2m_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ Q2M." + call nemsio_readrecv(gfile, "spfh", "2 m above gnd", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING Q2M.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'q2m ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID Q2M." + call ESMF_FieldScatter(q2m_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ TPRCP." + call nemsio_readrecv(gfile, "tprcp", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING TPRCP.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'tprcp ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID TPRCP." + call ESMF_FieldScatter(tprcp_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ FFMM." + call nemsio_readrecv(gfile, "ffmm", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING FFMM.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'ffmm ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID FFMM" + call ESMF_FieldScatter(ffmm_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ USTAR." + call nemsio_readrecv(gfile, "fricv", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING USTAR.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'fricv ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID USTAR" + call ESMF_FieldScatter(ustar_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) dummy2d = 0.0 + print*,"- CALL FieldScatter FOR INPUT GRID SRFLAG" + call ESMF_FieldScatter(srflag_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SKIN TEMPERATURE." + call nemsio_readrecv(gfile, "tmp", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING SKIN TEMPERATURE.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'tmp ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SKIN TEMPERATURE" + call ESMF_FieldScatter(skin_temp_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ F10M." + call nemsio_readrecv(gfile, "f10m", "10 m above gnd", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING F10M.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'f10m ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID F10M." + call ESMF_FieldScatter(f10m_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ CANOPY MOISTURE CONTENT." + call nemsio_readrecv(gfile, "cnwat", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING CANOPY MOISTURE CONTENT.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) + print*,'cnwat ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID CANOPY MOISTURE CONTENT." + call ESMF_FieldScatter(canopy_mc_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ Z0." + call nemsio_readrecv(gfile, "sfcr", "sfc", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING Z0.", rc) + dummy2d = reshape(dummy, (/i_input,j_input/)) * 100.0_8 ! convert to cm + print*,'sfcr ',maxval(dummy2d),minval(dummy2d) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID Z0." + call ESMF_FieldScatter(z0_input_grid, dummy2d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + deallocate(dummy2d) + + if (localpet == 0) then + print*,"- READ LIQUID SOIL MOISTURE." + call nemsio_readrecv(gfile, "soill", "0-10 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 1 LIQUID SOIL MOIST.", rc) + dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "soill", "10-40 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 2 LIQUID SOIL MOIST.", rc) + dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "soill", "40-100 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 3 LIQUID SOIL MOIST.", rc) + dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "soill", "100-200 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 4 LIQUID SOIL MOIST.", rc) + dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) + print*,'soill ',maxval(dummy3d),minval(dummy3d) + endif + + print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." + call ESMF_FieldScatter(soilm_liq_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ TOTAL SOIL MOISTURE." + call nemsio_readrecv(gfile, "soilw", "0-10 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 1 TOTAL SOIL MOIST.", rc) + dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "soilw", "10-40 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 2 TOTAL SOIL MOIST.", rc) + dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "soilw", "40-100 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 3 TOTAL SOIL MOIST.", rc) + dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "soilw", "100-200 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 4 TOTAL SOIL MOIST.", rc) + dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) + print*,'soilm ',maxval(dummy3d),minval(dummy3d) + endif + + print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." + call ESMF_FieldScatter(soilm_tot_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ SOIL TEMPERATURE." + call nemsio_readrecv(gfile, "tmp", "0-10 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 1 SOIL TEMP.", rc) + dummy3d(:,:,1) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "tmp", "10-40 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 2 SOIL TEMP.", rc) + dummy3d(:,:,2) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "tmp", "40-100 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 3 SOIL TEMP.", rc) + dummy3d(:,:,3) = reshape(dummy, (/i_input,j_input/)) + call nemsio_readrecv(gfile, "tmp", "100-200 cm down", 1, dummy, 0, iret=rc) + if (rc /= 0) call error_handler("READING LAYER 4 SOIL TEMP.", rc) + dummy3d(:,:,4) = reshape(dummy, (/i_input,j_input/)) + print*,'soilt ',maxval(dummy3d),minval(dummy3d) + endif + + print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." + call ESMF_FieldScatter(soil_temp_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + deallocate(dummy3d, dummy) + + if (localpet == 0) call nemsio_close(gfile) + + end subroutine read_input_sfc_gaussian_nemsio_file + +!> Read input grid surface data from fv3 tiled warm 'restart' files. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_sfc_restart_file(localpet) + + implicit none + + integer, intent(in) :: localpet + + character(len=500) :: tilefile + + integer :: error, rc + integer :: id_dim, idim_input, jdim_input + integer :: ncid, tile, id_var + + real(esmf_kind_r8), allocatable :: data_one_tile(:,:) + real(esmf_kind_r8), allocatable :: data_one_tile_3d(:,:,:) + +!--------------------------------------------------------------------------- +! Get i/j dimensions and number of soil layers from first surface file. +! Do dimensions match those from the orography file? +!--------------------------------------------------------------------------- + + tilefile = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) + print*,"- READ GRID DIMENSIONS FROM: ", trim(tilefile) + error=nf90_open(trim(tilefile),nf90_nowrite,ncid) + call netcdf_err(error, 'opening: '//trim(tilefile) ) + + error=nf90_inq_dimid(ncid, 'xaxis_1', id_dim) + call netcdf_err(error, 'reading xaxis_1 id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=idim_input) + call netcdf_err(error, 'reading xaxis_1 value' ) + + error=nf90_inq_dimid(ncid, 'yaxis_1', id_dim) + call netcdf_err(error, 'reading yaxis_1 id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=jdim_input) + call netcdf_err(error, 'reading yaxis_1 value' ) + + if (idim_input /= i_input .or. jdim_input /= j_input) then + call error_handler("DIMENSION MISMATCH BETWEEN SFC AND OROG FILES.", 1) + endif + + error = nf90_close(ncid) + + if (localpet == 0) then + allocate(data_one_tile(idim_input,jdim_input)) + allocate(data_one_tile_3d(idim_input,jdim_input,lsoil_input)) + else + allocate(data_one_tile(0,0)) + allocate(data_one_tile_3d(0,0,0)) + endif + + TERRAIN_LOOP: do tile = 1, num_tiles_input_grid + + if (localpet == 0) then + tilefile = trim(orog_dir_input_grid) // trim(orog_files_input_grid(tile)) + print*,'- OPEN OROGRAPHY FILE: ', trim(tilefile) + error=nf90_open(tilefile,nf90_nowrite,ncid) + call netcdf_err(error, 'OPENING OROGRAPHY FILE' ) + error=nf90_inq_varid(ncid, 'orog_raw', id_var) + call netcdf_err(error, 'READING OROG RECORD ID' ) + error=nf90_get_var(ncid, id_var, data_one_tile) + call netcdf_err(error, 'READING OROG RECORD' ) + print*,'terrain check ',tile, maxval(data_one_tile) + error=nf90_close(ncid) + endif + + print*,"- CALL FieldScatter FOR INPUT TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + enddo TERRAIN_LOOP + + TILE_LOOP : do tile = 1, num_tiles_input_grid + +! liquid soil moisture + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('slc', tile, idim_input, jdim_input, & + lsoil_input, sfcdata_3d=data_one_tile_3d) + endif + + print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." + call ESMF_FieldScatter(soilm_liq_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('smc', tile, idim_input, jdim_input, & + lsoil_input, sfcdata_3d=data_one_tile_3d) + endif + + print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." + call ESMF_FieldScatter(soilm_tot_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('stc', tile, idim_input, jdim_input, & + lsoil_input, sfcdata_3d=data_one_tile_3d) + endif + + print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." + call ESMF_FieldScatter(soil_temp_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! land mask + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('slmsk', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." + call ESMF_FieldScatter(landsea_mask_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! sea ice fraction + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('fice', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE FRACTION." + call ESMF_FieldScatter(seaice_fract_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! sea ice depth + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('hice', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE DEPTH." + call ESMF_FieldScatter(seaice_depth_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! sea ice skin temperature + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('tisfc', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE SKIN TEMPERATURE." + call ESMF_FieldScatter(seaice_skin_temp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! liquid equivalent snow depth + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('sheleg', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SNOW LIQUID EQUIVALENT." + call ESMF_FieldScatter(snow_liq_equiv_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! physical snow depth + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('snwdph', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile = data_one_tile + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SNOW DEPTH." + call ESMF_FieldScatter(snow_depth_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Vegetation type + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('vtype', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID VEG TYPE." + call ESMF_FieldScatter(veg_type_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Soil type + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('stype', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SOIL TYPE." + call ESMF_FieldScatter(soil_type_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Two-meter temperature + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('t2m', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID T2M." + call ESMF_FieldScatter(t2m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Two-meter q + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('q2m', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID Q2M." + call ESMF_FieldScatter(q2m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('tprcp', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID TPRCP." + call ESMF_FieldScatter(tprcp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('f10m', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID F10M" + call ESMF_FieldScatter(f10m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('ffmm', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID FFMM" + call ESMF_FieldScatter(ffmm_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('uustar', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID USTAR" + call ESMF_FieldScatter(ustar_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('srflag', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SRFLAG" + call ESMF_FieldScatter(srflag_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('tsea', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SKIN TEMPERATURE" + call ESMF_FieldScatter(skin_temp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('canopy', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID CANOPY MOISTURE CONTENT." + call ESMF_FieldScatter(canopy_mc_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('zorl', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID Z0." + call ESMF_FieldScatter(z0_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + enddo TILE_LOOP + + deallocate(data_one_tile, data_one_tile_3d) + + end subroutine read_input_sfc_restart_file + +!> Read input grid surface data from tiled 'history' files (netcdf) or +!! gaussian netcdf files. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC + subroutine read_input_sfc_netcdf_file(localpet) + + implicit none + + integer, intent(in) :: localpet + + character(len=500) :: tilefile + + integer :: error, id_var + integer :: id_dim, idim_input, jdim_input + integer :: ncid, rc, tile + + real(esmf_kind_r8), allocatable :: data_one_tile(:,:) + real(esmf_kind_r8), allocatable :: data_one_tile_3d(:,:,:) + +!--------------------------------------------------------------------------- +! Get i/j dimensions and number of soil layers from first surface file. +! Do dimensions match those from the orography file? +!--------------------------------------------------------------------------- + + tilefile = trim(data_dir_input_grid) // "/" // trim(sfc_files_input_grid(1)) + print*,"- READ GRID DIMENSIONS FROM: ", trim(tilefile) + error=nf90_open(trim(tilefile),nf90_nowrite,ncid) + call netcdf_err(error, 'opening: '//trim(tilefile) ) + + error=nf90_inq_dimid(ncid, 'grid_xt', id_dim) + call netcdf_err(error, 'reading grid_xt id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=idim_input) + call netcdf_err(error, 'reading grid_xt value' ) + + error=nf90_inq_dimid(ncid, 'grid_yt', id_dim) + call netcdf_err(error, 'reading grid_yt id' ) + error=nf90_inquire_dimension(ncid,id_dim,len=jdim_input) + call netcdf_err(error, 'reading grid_yt value' ) + + if (idim_input /= i_input .or. jdim_input /= j_input) then + call error_handler("DIMENSION MISMATCH BETWEEN SFC AND OROG FILES.", 3) + endif + + error = nf90_close(ncid) + + if (localpet == 0) then + allocate(data_one_tile(idim_input,jdim_input)) + allocate(data_one_tile_3d(idim_input,jdim_input,lsoil_input)) + else + allocate(data_one_tile(0,0)) + allocate(data_one_tile_3d(0,0,0)) + endif + + TERRAIN_LOOP: do tile = 1, num_tiles_input_grid + + if (trim(input_type) == "gaussian_netcdf") then + if (localpet == 0) then + call read_fv3_grid_data_netcdf('orog', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + else + + if (localpet == 0) then + tilefile = trim(orog_dir_input_grid) // trim(orog_files_input_grid(tile)) + print*,'- OPEN OROGRAPHY FILE: ', trim(tilefile) + error=nf90_open(tilefile,nf90_nowrite,ncid) + call netcdf_err(error, 'OPENING OROGRAPHY FILE.' ) + error=nf90_inq_varid(ncid, 'orog_raw', id_var) + call netcdf_err(error, 'READING OROGRAPHY RECORD ID.' ) + error=nf90_get_var(ncid, id_var, data_one_tile) + call netcdf_err(error, 'READING OROGRAPHY RECORD.' ) + print*,'terrain check history ',tile, maxval(data_one_tile) + error=nf90_close(ncid) + endif + + endif + + print*,"- CALL FieldScatter FOR INPUT TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + enddo TERRAIN_LOOP + + TILE_LOOP : do tile = 1, num_tiles_input_grid + +! liquid soil moisture + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('soill1', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,1) = data_one_tile + call read_fv3_grid_data_netcdf('soill2', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,2) = data_one_tile + call read_fv3_grid_data_netcdf('soill3', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,3) = data_one_tile + call read_fv3_grid_data_netcdf('soill4', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,4) = data_one_tile + endif + + print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." + call ESMF_FieldScatter(soilm_liq_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! total soil moisture + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('soilw1', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,1) = data_one_tile + call read_fv3_grid_data_netcdf('soilw2', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,2) = data_one_tile + call read_fv3_grid_data_netcdf('soilw3', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,3) = data_one_tile + call read_fv3_grid_data_netcdf('soilw4', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,4) = data_one_tile + endif + + print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." + call ESMF_FieldScatter(soilm_tot_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! soil tempeature (ice temp at land ice points) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('soilt1', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,1) = data_one_tile + call read_fv3_grid_data_netcdf('soilt2', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,2) = data_one_tile + call read_fv3_grid_data_netcdf('soilt3', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,3) = data_one_tile + call read_fv3_grid_data_netcdf('soilt4', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile_3d(:,:,4) = data_one_tile + endif + + print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." + call ESMF_FieldScatter(soil_temp_input_grid, data_one_tile_3d, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! land mask + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('land', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." + call ESMF_FieldScatter(landsea_mask_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! sea ice fraction + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('icec', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE FRACTION." + call ESMF_FieldScatter(seaice_fract_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! sea ice depth + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('icetk', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE DEPTH." + call ESMF_FieldScatter(seaice_depth_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! sea ice skin temperature + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('tisfc', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE SKIN TEMPERATURE." + call ESMF_FieldScatter(seaice_skin_temp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! liquid equivalent snow depth + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('weasd', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SNOW LIQUID EQUIVALENT." + call ESMF_FieldScatter(snow_liq_equiv_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! physical snow depth + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('snod', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + data_one_tile = data_one_tile * 1000.0 ! convert from meters to mm. + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SNOW DEPTH." + call ESMF_FieldScatter(snow_depth_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Vegetation type + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('vtype', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID VEG TYPE." + call ESMF_FieldScatter(veg_type_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Soil type + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('sotyp', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SOIL TYPE." + call ESMF_FieldScatter(soil_type_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Two-meter temperature + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('tmp2m', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID T2M." + call ESMF_FieldScatter(t2m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + +! Two-meter q + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('spfh2m', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID Q2M." + call ESMF_FieldScatter(q2m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('tprcp', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID TPRCP." + call ESMF_FieldScatter(tprcp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('f10m', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID F10M" + call ESMF_FieldScatter(f10m_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('ffmm', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID FFMM" + call ESMF_FieldScatter(ffmm_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('fricv', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID USTAR" + call ESMF_FieldScatter(ustar_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then +! call read_fv3_grid_data_netcdf('srflag', tile, idim_input, jdim_input, & +! lsoil_input, sfcdata=data_one_tile) + data_one_tile = 0.0 + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SRFLAG" + call ESMF_FieldScatter(srflag_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('tmpsfc', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SKIN TEMPERATURE" + call ESMF_FieldScatter(skin_temp_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('cnwat', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID CANOPY MOISTURE CONTENT." + call ESMF_FieldScatter(canopy_mc_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + call read_fv3_grid_data_netcdf('sfcr', tile, idim_input, jdim_input, & + lsoil_input, sfcdata=data_one_tile) + endif + + print*,"- CALL FieldScatter FOR INPUT GRID Z0." + call ESMF_FieldScatter(z0_input_grid, data_one_tile, rootpet=0, tile=tile, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + enddo TILE_LOOP + + deallocate(data_one_tile, data_one_tile_3d) + + end subroutine read_input_sfc_netcdf_file + +!> Read input grid surface data from a grib2 file. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author Larissa Reames + subroutine read_input_sfc_grib2_file(localpet) + + use mpi + use grib_mod + use program_setup, only : vgtyp_from_climo, sotyp_from_climo + use model_grid, only : input_grid_type + use search_util + + implicit none + + integer, intent(in) :: localpet + + character(len=250) :: the_file + character(len=250) :: geo_file + character(len=200) :: err_msg + character(len=20) :: vname, vname_file, slev + character(len=50) :: method + + integer :: rc, varnum, iret, i, j,k + integer :: ncid2d, varid, varsize + integer :: lugb, lugi + integer :: jdisc, jgdtn, jpdtn, pdt_num + integer :: jids(200), jgdt(200), jpdt(200) + + logical :: rap_latlon, unpack + + real(esmf_kind_r4) :: value + real(esmf_kind_r4), allocatable :: dummy2d(:,:) + real(esmf_kind_r8), allocatable :: icec_save(:,:) + real(esmf_kind_r4), allocatable :: dummy1d(:) + real(esmf_kind_r8), allocatable :: dummy2d_8(:,:),dummy2d_82(:,:),tsk_save(:,:) + real(esmf_kind_r8), allocatable :: dummy3d(:,:,:), dummy3d_stype(:,:,:) + integer(esmf_kind_i4), allocatable :: slmsk_save(:,:) + integer(esmf_kind_i8), allocatable :: dummy2d_i(:,:) + + type(gribfield) :: gfld + + rap_latlon = trim(to_upper(external_model))=="RAP" .and. trim(input_grid_type) == "rotated_latlon" + + the_file = trim(data_dir_input_grid) // "/" // trim(grib2_file_input_grid) + geo_file = trim(geogrid_file_input_grid) + + print*,"- READ SFC DATA FROM GRIB2 FILE: ", trim(the_file) + +! Determine the number of soil layers in file. + + if (localpet == 0) then + + lugb=12 + call baopenr(lugb,the_file,rc) + if (rc /= 0) call error_handler("ERROR OPENING GRIB2 FILE.", rc) + + j = 0 ! search at beginning of file + lugi = 0 ! no grib index file + jdisc = -1 ! search for any discipline + jpdtn = -1 ! search for any product definition template number + jgdtn = -1 ! search for any grid definition template number + jids = -9999 ! array of values in identification section, set to wildcard + jgdt = -9999 ! array of values in grid definition template, set to wildcard + jpdt = -9999 ! array of values in product definition template, set to wildcard + unpack = .false. ! unpack data + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc == 0) then + if (gfld%idsect(1) == 7 .and. gfld%idsect(2) == 2) then + print*,'- THIS IS NCEP GEFS DATA.' + pdt_num = 1 + else + pdt_num = 0 + endif + else + if (rc /= 0) call error_handler("ERROR READING GRIB2 FILE.", rc) + endif + + j = 0 + lsoil_input = 0 + + do + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc /= 0) exit + + if (gfld%discipline == 2) then ! discipline - land products + if (gfld%ipdtnum == pdt_num) then ! prod template number - analysis or forecast at single level. + if (gfld%ipdtmpl(1) == 0 .and. gfld%ipdtmpl(2) == 2) then ! soil temp + ! Sect4/octs 10 and 11 + if (gfld%ipdtmpl(10) == 106 .and. gfld%ipdtmpl(13) == 106) then ! Sect4/octs 23/29. + ! Layer below ground. + lsoil_input = lsoil_input + 1 + endif + endif + endif + endif + + j = k + + enddo + + print*, "- FILE HAS ", lsoil_input, " SOIL LEVELS." + if (lsoil_input == 0) call error_handler("COUNTING SOIL LEVELS.", rc) + + endif ! localpet == 0 + + call MPI_BARRIER(MPI_COMM_WORLD, rc) + call MPI_BCAST(lsoil_input,1,MPI_INTEGER,0,MPI_COMM_WORLD,rc) + + ! We need to recreate the soil fields if we have something other than 4 levels + + if (lsoil_input /= 4) then + + call ESMF_FieldDestroy(soil_temp_input_grid, rc=rc) + call ESMF_FieldDestroy(soilm_tot_input_grid, rc=rc) + call ESMF_FieldDestroy(soilm_liq_input_grid, rc=rc) + + print*,"- CALL FieldCreate FOR INPUT SOIL TEMPERATURE." + soil_temp_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lsoil_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT TOTAL SOIL MOISTURE." + soilm_tot_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lsoil_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT LIQUID SOIL MOISTURE." + soilm_liq_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lsoil_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + endif + + if (localpet == 0) then + allocate(dummy2d(i_input,j_input)) + allocate(slmsk_save(i_input,j_input)) + allocate(tsk_save(i_input,j_input)) + allocate(icec_save(i_input,j_input)) + allocate(dummy2d_8(i_input,j_input)) + allocate(dummy2d_82(i_input,j_input)) + allocate(dummy3d(i_input,j_input,lsoil_input)) + else + allocate(dummy3d(0,0,0)) + allocate(dummy2d_8(0,0)) + allocate(dummy2d_82(0,0)) + allocate(dummy2d(0,0)) + allocate(slmsk_save(0,0)) + endif + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! These variables are always in grib files, or are required, so no need to check for them + ! in the varmap table. If they can't be found in the input file, then stop the program. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (localpet == 0) then + + print*,"- READ TERRAIN." + + j = 0 + jdisc = 0 ! Search for discipline 0 - meteorological products + jpdt = -9999 ! array of values in product definition template, set to wildcard. + jpdtn = pdt_num ! search for product definition template number 0 - anl or fcst. + jpdt(1) = 3 ! Sec4/oct 10 - param cat - mass field + jpdt(2) = 5 ! Sec4/oct 11 - param number - geopotential height + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + if (rc /= 0) call error_handler("READING TERRAIN.", rc) + + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) +! print*,'orog ', maxval(dummy2d_8),minval(dummy2d_8) + + endif + + print*,"- CALL FieldScatter FOR INPUT TERRAIN." + call ESMF_FieldScatter(terrain_input_grid, dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ SEAICE FRACTION." + + jdisc = 10 ! Search for discipline - ocean products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for product def template number 0 - anl or fcst. + jpdt = -9999 ! Array of values in Sec 4 product definition template; + ! Initialize to wildcard. + jpdt(1) = 2 ! Sec4/oct 10 - parameter category - ice + jpdt(2) = 0 ! Sec4/oct 11 - parameter number - ice cover + unpack=.true. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + if (rc /= 0) call error_handler("READING SEAICE FRACTION.", rc) + + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) +! print*,'icec ', maxval(dummy2d_8),minval(dummy2d_8) + + icec_save = dummy2d_8 + + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE FRACTION." + call ESMF_FieldScatter(seaice_fract_input_grid, dummy2d_8 ,rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + +!---------------------------------------------------------------------------------- +! GFS v14 and v15.2 grib data has two land masks. LANDN is created by +! nearest neighbor interpolation. LAND is created by bilinear interpolation. +! LANDN matches the bitmap. So use it first. For other GFS versions or other models, +! use LAND. Mask in grib file is '1' (land), '0' (not land). Add sea/lake ice category +! '2' based on ice concentration. +!---------------------------------------------------------------------------------- + + if (localpet == 0) then + + print*,"- READ LANDSEA MASK." + + jdisc = 2 ! Search for discipline - land products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for product definition template number 0 - anl or fcst. + jpdt = -9999 ! Initialize array of values in product definition template - Sec 4. + jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass + jpdt(2) = 218 ! Sec4/oct 11 - parameter number - land nearest neighbor + unpack=.true. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc == 0) then + + print*,'landnn ', maxval(gfld%fld),minval(gfld%fld) + + else + + jdisc = 2 ! Search for discipline - land products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for product def template number 0 - anl or fcst. + jpdt = -9999 ! Initialize array of values in product definition template - Sec 4. + jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass + jpdt(2) = 0 ! Sec4/oct 11 - parameter number - land cover (fraction) + unpack=.true. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + if (rc /= 0) call error_handler("READING LANDSEA MASK.", rc) + +! print*,'land ', maxval(gfld%fld),minval(gfld%fld) + + endif + + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + + do j = 1, j_input + do i = 1, i_input + if(dummy2d_8(i,j) < 0.5_esmf_kind_r8) dummy2d_8(i,j)=0.0 + if(icec_save(i,j) > 0.15_esmf_kind_r8) then + dummy2d_8(i,j) = 2.0_esmf_kind_r8 + endif + enddo + enddo + + slmsk_save = nint(dummy2d_8) + + deallocate(icec_save) + + endif ! read land mask + + print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." + call ESMF_FieldScatter(landsea_mask_input_grid, dummy2d_8 ,rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ SEAICE SKIN TEMPERATURE." + + jdisc = 0 ! Search for discipline - meteorological products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for product definition template number 0 - anl or fcst. + jpdt = -9999 ! Initialize array of values in product definition template - Sec4 + jpdt(1) = 0 ! Sec4/oct 10 - parameter category - temperature + jpdt(2) = 0 ! Sec4/oct 11 - parameter number - temperature + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + if (rc /= 0) call error_handler("READING SEAICE SKIN TEMP.", rc) + +! print*,'ti ',maxval(gfld%fld),minval(gfld%fld) + + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE SKIN TEMPERATURE." + call ESMF_FieldScatter(seaice_skin_temp_input_grid, dummy2d_8 ,rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + +!---------------------------------------------------------------------------------- +! Read snow fields. Zero out at non-land points and undefined points (points +! removed using the bitmap). Program expects depth and liquid equivalent +! in mm. +!---------------------------------------------------------------------------------- + + if (localpet == 0) then + + print*,"- READ SNOW LIQUID EQUIVALENT." + + jdisc = 0 ! Search for discipline - meteorological products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template - Sec4 + jpdt(1) = 1 ! Sec4/oct 10 - parameter category - moisture + jpdt(2) = 13 ! Sec4/oct 11 - parameter number - liquid equiv snow depth + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + if (rc /= 0) call error_handler("READING SNOW LIQUID EQUIVALENT.", rc) + +! print*,'weasd ', maxval(gfld%fld),minval(gfld%fld) + + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + + do j = 1, j_input + do i = 1, i_input + if(slmsk_save(i,j) == 0) dummy2d_8(i,j) = 0.0 + enddo + enddo + + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SNOW LIQUID EQUIVALENT." + call ESMF_FieldScatter(snow_liq_equiv_input_grid, dummy2d_8 ,rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ SNOW DEPTH." + + jdisc = 0 ! Search for discipline - meteorological products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template - Sec4 + jpdt(1) = 1 ! Sec4/oct 10 - parameter category - moisture + jpdt(2) = 11 ! Sec4/oct 11 - parameter number - snow depth + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc /= 0) then + call error_handler("READING SNOW DEPTH.", rc) + else + gfld%fld = gfld%fld * 1000.0 +! print*,'snod ', maxval(gfld%fld),minval(gfld%fld) + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + endif + + do j = 1, j_input + do i = 1, i_input + if(slmsk_save(i,j) == 0) dummy2d_8(i,j) = 0.0 + enddo + enddo + + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SNOW DEPTH." + call ESMF_FieldScatter(snow_depth_input_grid,dummy2d_8,rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ T2M." + + jdisc = 0 ! Search for discipline - meteorological products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template - Sec4 + jpdt(1) = 0 ! Sec4/oct 10 - parameter category - temperature + jpdt(2) = 0 ! Sec4/oct 11 - parameter number - temperature + jpdt(10) = 103 ! Sec4/oct 23 - type of level - height above ground surface + jpdt(12) = 2 ! Sec4/octs 25-28 - 2 meters above ground. + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc /= 0) call error_handler("READING T2M.", rc) +! print*,'t2m ', maxval(gfld%fld),minval(gfld%fld) + + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + + endif + + print*,"- CALL FieldScatter FOR INPUT GRID T2M." + call ESMF_FieldScatter(t2m_input_grid, dummy2d_8, rootpet=0,rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ Q2M." + + jdisc = 0 ! Search for discipline - meteorological products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template - Sec4 + jpdt(1) = 1 ! Sec4/oct 10 - parameter category - moisture + jpdt(2) = 0 ! Sec4/oct 11 - parameter number - specific humidity + jpdt(10) = 103 ! Sec4/oct 23 - type of level - height above ground surface + jpdt(12) = 2 ! Sec4/octs 25-28 - 2 meters above ground. + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + if (rc /=0) call error_handler("READING Q2M.", rc) + +! print*,'q2m ',maxval(gfld%fld),minval(gfld%fld) + + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + + endif + + print*,"- CALL FieldScatter FOR INPUT GRID Q2M." + call ESMF_FieldScatter(q2m_input_grid,dummy2d_8, rootpet=0,rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ SKIN TEMPERATURE." + + jdisc = 0 ! Search for discipline - meteorological products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template - Sec4 + jpdt(1) = 0 ! Sec4/oct 10 - parameter category - temperature + jpdt(2) = 0 ! Sec4/oct 11 - parameter number - temperature + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc /= 0 ) call error_handler("READING SKIN TEMPERATURE.", rc) +! print*,'skint ', maxval(gfld%fld),minval(gfld%fld) + + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + + tsk_save(:,:) = dummy2d_8 + + do j = 1, j_input + do i = 1, i_input + if(slmsk_save(i,j) == 0 .and. dummy2d_8(i,j) < 271.2) then +! print*,'too cool SST ',i,j,dummy2d_8(i,j) + dummy2d_8(i,j) = 271.2 + endif + if(slmsk_save(i,j) == 0 .and. dummy2d_8(i,j) > 310.) then +! print*,'too hot SST ',i,j,dummy2d_8(i,j) + dummy2d_8(i,j) = 310.0 + endif + enddo + enddo + + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SKIN TEMPERATURE" + call ESMF_FieldScatter(skin_temp_input_grid,dummy2d_8,rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + +! srflag not in files. Set to zero. + + if (localpet == 0) dummy2d_8 = 0.0 + + print*,"- CALL FieldScatter FOR INPUT GRID SRFLAG" + call ESMF_FieldScatter(srflag_input_grid,dummy2d_8, rootpet=0,rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ SOIL TYPE." + + jdisc = 2 ! Search for discipline - land products + j = 0 ! Search at beginning of file + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template - Sec4 + jpdt(1) = 3 ! Sec4/oct 10 - parameter category - soil products + jpdt(2) = 0 ! Sec4/oct 11 - parameter number - soil type + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc == 0 ) then +! print*,'soil type ', maxval(gfld%fld),minval(gfld%fld) + dummy2d = reshape(real(gfld%fld,kind=esmf_kind_r4) , (/i_input,j_input/)) + + endif + + if (rc /= 0 .and. (trim(to_upper(external_model))=="HRRR" .or. rap_latlon) .and. geo_file .ne. "NULL") then + ! Some HRRR and RAP files don't have dominant soil type in the output, but the geogrid files + ! do, so this gives users the option to provide the geogrid file and use input soil + ! type + print*, "OPEN GEOGRID FILE ", trim(geo_file) + rc = nf90_open(geo_file,NF90_NOWRITE,ncid2d) + call netcdf_err(rc,"READING GEOGRID FILE") + + print*, "INQURE ABOUT DIM IDS" + rc = nf90_inq_dimid(ncid2d,"west_east",varid) + call netcdf_err(rc,"READING west_east DIMENSION FROM GEOGRID FILE") + + rc = nf90_inquire_dimension(ncid2d,varid,len=varsize) + call netcdf_err(rc,"READING west_east DIMENSION SIZE") + if (varsize .ne. i_input) call error_handler ("GEOGRID FILE GRID SIZE DIFFERS FROM INPUT DATA.", -1) + + print*, "INQUIRE ABOUT SOIL TYPE FROM GEOGRID FILE" + rc = nf90_inq_varid(ncid2d,"SCT_DOM",varid) + call netcdf_err(rc,"FINDING SCT_DOM IN GEOGRID FILE") + + print*, "READ SOIL TYPE FROM GEOGRID FILE " + rc = nf90_get_var(ncid2d,varid,dummy2d) + call netcdf_err(rc,"READING SCT_DOM FROM FILE") + + print*, "INQUIRE ABOUT SOIL TYPE FRACTIONS FROM GEOGRID FILE" + rc = nf90_inq_varid(ncid2d,"SOILCTOP",varid) + call netcdf_err(rc,"FINDING SOILCTOP IN GEOGRID FILE") + + allocate(dummy3d_stype(i_input,j_input,16)) + print*, "READ SOIL TYPE FRACTIONS FROM GEOGRID FILE " + rc = nf90_get_var(ncid2d,varid,dummy3d_stype) + call netcdf_err(rc,"READING SCT_DOM FROM FILE") + + print*, "CLOSE GEOGRID FILE " + iret = nf90_close(ncid2d) + + ! There's an issue with the geogrid file containing soil type water at land points. + ! This correction replaces the soil type at these points with the soil type with + ! the next highest fractional coverage. + allocate(dummy1d(16)) + do j = 1, j_input + do i = 1, i_input + if(dummy2d(i,j) == 14.0_esmf_kind_r4 .and. slmsk_save(i,j) == 1) then + dummy1d(:) = real(dummy3d_stype(i,j,:),kind=esmf_kind_r4) + dummy1d(14) = 0.0_esmf_kind_r4 + dummy2d(i,j) = real(MAXLOC(dummy1d, 1),esmf_kind_r4) + endif + enddo + enddo + deallocate(dummy1d) + deallocate(dummy3d_stype) + endif ! failed + + if ((rc /= 0 .and. trim(to_upper(external_model)) /= "HRRR" .and. .not. rap_latlon) & + .or. (rc /= 0 .and. (trim(to_upper(external_model)) == "HRRR" .or. rap_latlon))) then + if (.not. sotyp_from_climo) then + call error_handler("COULD NOT FIND SOIL TYPE IN FILE. PLEASE SET SOTYP_FROM_CLIMO=.TRUE. . EXITING", rc) + else + vname = "sotyp" + slev = "surface" + call get_var_cond(vname,this_miss_var_method=method, this_miss_var_value=value, & + loc=varnum) + call handle_grib_error(vname, slev ,method,value,varnum,read_from_input,rc, var= dummy2d) + if (rc == 1) then ! missing_var_method == skip or no entry in varmap table + print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. WILL NOT "//& + "SCALE SOIL MOISTURE FOR DIFFERENCES IN SOIL TYPE. " + dummy2d(:,:) = -99999.0_esmf_kind_r4 + endif + endif + endif + + ! In the event that the soil type on the input grid still contains mismatches between + ! soil type and landmask, this correction is a last-ditch effort to replace these points + ! with soil type from a nearby land point. + + if (.not. sotyp_from_climo) then + do j = 1, j_input + do i = 1, i_input + if(dummy2d(i,j) == 14.0_esmf_kind_r4 .and. slmsk_save(i,j) == 1) dummy2d(i,j) = -99999.9_esmf_kind_r4 + enddo + enddo + + allocate(dummy2d_i(i_input,j_input)) + dummy2d_8 = real(dummy2d,esmf_kind_r8) + dummy2d_i(:,:) = 0 + where(slmsk_save == 1) dummy2d_i = 1 + + call search(dummy2d_8,dummy2d_i,i_input,j_input,1,230) + deallocate(dummy2d_i) + else + dummy2d_8=real(dummy2d,esmf_kind_r8) + endif + + print*,'sotype ',maxval(dummy2d_8),minval(dummy2d_8) + + endif ! read of soil type + + print*,"- CALL FieldScatter FOR INPUT GRID SOIL TYPE." + call ESMF_FieldScatter(soil_type_input_grid,dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + deallocate(dummy2d) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Begin variables whose presence in grib2 files varies, but no climatological + ! data is available, so we have to account for values in the varmap table + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (.not. vgfrc_from_climo) then + + if (localpet == 0) then + + print*,"- READ VEG FRACTION." + + jdisc = 2 ! Search for discipline - land products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template Sec4. + jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass + jpdt(2) = 4 ! Sec4/oct 11 - parameter number - vegetation + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc /= 0 )then + err_msg="COULD NOT FIND VEGETATION FRACTION IN FILE. PLEASE SET VGFRC_FROM_CLIMO=.TRUE." + call error_handler(err_msg, rc) + else + if (maxval(gfld%fld) > 2.0) gfld%fld = gfld%fld / 100.0 +! print*,'vfrac ', maxval(gfld%fld),minval(gfld%fld) + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + + endif + + endif ! localpet 0 + + print*,"- CALL FieldScatter FOR INPUT GRID VEG GREENNESS." + call ESMF_FieldScatter(veg_greenness_input_grid,dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldScatter", rc) + + endif + + if (.not. minmax_vgfrc_from_climo) then + + if (localpet == 0) then + + print*,"- READ MIN VEG FRACTION." + + jdisc = 2 ! Search for discipline - land products + j = 1105 ! grib2 file does not distinguish between the various veg + ! fractions. Need to search using record number. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template Sec4. + jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass + jpdt(2) = 4 ! Sec4/oct 11 - parameter number - vegetation + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc /= 0) then + j = 1101 ! Have to search by record number. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + if (rc /= 0) then + j = 1151 ! Have to search by record number. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + err_msg="COULD NOT FIND MIN VEGETATION FRACTION IN FILE. SET MINMAX_VGFRC_FROM_CLIMO=.TRUE." + if (rc/=0) call error_handler(err_msg, rc) + endif + endif + + if (maxval(gfld%fld) > 2.0) gfld%fld = gfld%fld / 100.0 + print*,'vfrac min ', maxval(gfld%fld),minval(gfld%fld) + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + + endif ! localpet == 0 + + print*,"- CALL FieldScatter FOR INPUT GRID MIN VEG GREENNESS." + call ESMF_FieldScatter(min_veg_greenness_input_grid,dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ MAX VEG FRACTION." + + jdisc = 2 ! Search for discipline - land products + j = 1106 ! Have to search by record number. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template Sec4. + jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass + jpdt(2) = 4 ! Sec4/oct 11 - parameter number - vegetation + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + if (rc /= 0) then + j = 1102 ! Have to search by record number. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + if (rc /= 0) then + j = 1152 ! Have to search by record number. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + err_msg="COULD NOT FIND MAX VEGETATION FRACTION IN FILE. SET MINMAX_VGFRC_FROM_CLIMO=.TRUE." + if (rc <= 0) call error_handler(err_msg, rc) + endif + endif + + if (maxval(gfld%fld) > 2.0) gfld%fld = gfld%fld / 100.0 +! print*,'vfrac max ', maxval(gfld%fld),minval(gfld%fld) + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + + endif !localpet==0 + + print*,"- CALL FieldScatter FOR INPUT GRID MAX VEG GREENNESS." + call ESMF_FieldScatter(max_veg_greenness_input_grid,dummy2d_8,rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + endif !minmax_vgfrc_from_climo + + if (.not. lai_from_climo) then + + if (localpet == 0) then + + print*,"- READ LAI." + + jdisc = 0 ! Search for discipline - meteorological products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template Sec4. + jpdt(1) = 7 ! Sec4/oct 10 - parameter category - thermo stability indices + jpdt(2) = 198 ! Sec4/oct 11 - parameter number - leaf area index + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + err_msg="COULD NOT FIND LAI IN FILE. SET LAI_FROM_CLIMO=.TRUE." + if (rc /= 0) call error_handler(err_msg, rc) + +! print*,'lai ', maxval(gfld%fld),minval(gfld%fld) + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + + endif !localpet==0 + + print*,"- CALL FieldScatter FOR INPUT GRID LAI." + call ESMF_FieldScatter(lai_input_grid,dummy2d_8,rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + endif ! lai + + if (localpet == 0) then + + print*,"- READ SEAICE DEPTH." + vname="hice" + slev=":surface:" + call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & + loc=varnum) + + jdisc = 10 ! Search for discipline - ocean products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template Sec4. + jpdt(1) = 2 ! Sec4/oct 10 - parameter category - ice + jpdt(2) = 1 ! Sec4/oct 11 - parameter number - thickness + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc /= 0 ) then + call handle_grib_error(vname, slev ,method,value,varnum,read_from_input,rc,var8=dummy2d_8) + if (rc==1) then ! missing_var_method == skip or no entry in varmap table + print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL BE"//& + " REPLACED WITH CLIMO. SET A FILL "// & + "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." + dummy2d_8(:,:) = 0.0 + endif + else +! print*,'hice ', maxval(gfld%fld),minval(gfld%fld) + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + endif + + endif + + print*,"- CALL FieldScatter FOR INPUT GRID SEAICE DEPTH." + call ESMF_FieldScatter(seaice_depth_input_grid,dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ TPRCP." + vname="tprcp" + slev=":surface:" + call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & + loc=varnum) + +! No test data contained this field. So could not test with g2 library. + rc = 1 + if (rc /= 0) then + call handle_grib_error(vname, slev ,method,value,varnum,read_from_input,rc, var8=dummy2d_8) + if (rc==1) then ! missing_var_method == skip or no entry in varmap table + print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL NOT"//& + " BE WRITTEN TO THE INPUT FILE. SET A FILL "// & + "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." + dummy2d_8 = 0.0 + endif + endif + print*,'tprcp ',maxval(dummy2d_8),minval(dummy2d_8) + + endif ! tprcp + + print*,"- CALL FieldScatter FOR INPUT GRID TPRCP." + call ESMF_FieldScatter(tprcp_input_grid,dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ FFMM." + vname="ffmm" + slev=":surface:" + call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & + loc=varnum) + +! No sample data contained this field, so could not test g2lib. + rc = 1 + if (rc /= 0) then + call handle_grib_error(vname, slev ,method,value,varnum,read_from_input,rc, var8=dummy2d_8) + if (rc==1) then ! missing_var_method == skip or no entry in varmap table + print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL NOT"//& + " BE WRITTEN TO THE INPUT FILE. SET A FILL "// & + "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." + dummy2d_8(:,:) = 0.0 + endif + endif + print*,'ffmm ',maxval(dummy2d_8),minval(dummy2d_8) + + endif ! ffmm + + print*,"- CALL FieldScatter FOR INPUT GRID FFMM" + call ESMF_FieldScatter(ffmm_input_grid,dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ USTAR." + vname="fricv" + slev=":surface:" + call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & + loc=varnum) + + jdisc = 0 ! Search for discipline - meteorological products + j = 0 ! Search at beginning of file. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template Sec4. + jpdt(1) = 2 ! Sec4/oct 10 - parameter category - momentum + jpdt(2) = 30 ! Sec4/oct 11 - parameter number - friction velocity + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + if (rc /= 0) then + jpdt(2) = 197 ! oct 11 - param number - friction vel. + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + endif + + if (rc == 0) then +! print*,'fricv ', maxval(gfld%fld),minval(gfld%fld) + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + else + call handle_grib_error(vname, slev ,method,value,varnum,read_from_input,rc, var8=dummy2d_8) + if (rc==1) then ! missing_var_method == skip or no entry in varmap table + print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL "//& + "REPLACED WITH CLIMO. SET A FILL "// & + "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." + dummy2d_8(:,:) = 0.0 + endif + endif + + endif ! ustar + + print*,"- CALL FieldScatter FOR INPUT GRID USTAR" + call ESMF_FieldScatter(ustar_input_grid,dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ F10M." + vname="f10m" + slev=":10 m above ground:" + call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & + loc=varnum) + + rc = -1 ! None of the test cases have this record. Can't test with g2lib. + if (rc /= 0) then + call handle_grib_error(vname, slev ,method,value,varnum,read_from_input,rc, var8=dummy2d_8) + if (rc==1) then ! missing_var_method == skip or no entry in varmap table + print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL NOT"//& + " BE WRITTEN TO THE INPUT FILE. SET A FILL "// & + "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." + dummy2d_8(:,:) = 0.0 + endif + endif + print*,'f10m ',maxval(dummy2d_8),minval(dummy2d_8) + + endif + + print*,"- CALL FieldScatter FOR INPUT GRID F10M." + call ESMF_FieldScatter(f10m_input_grid,dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ CANOPY MOISTURE CONTENT." + vname="cnwat" + slev=":surface:" + call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & + loc=varnum) + + jdisc = 2 ! Search for discipline - land products + j = 0 ! Search from beginning of file + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template Sec4. + jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass + jpdt(2) = 13 ! Sec4/oct 11 - parameter number - canopy water + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc /= 0 ) then + jpdt(2) = 196 ! Sec4/oct 11 - param number - canopy water + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + endif + + if (rc == 0 ) then + print*,'cnwat ', maxval(gfld%fld),minval(gfld%fld) + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + call check_cnwat(dummy2d_8,i_input,j_input) + else + call handle_grib_error(vname, slev ,method,value,varnum,read_from_input,rc, var8=dummy2d_8) + if (rc==1) then ! missing_var_method == skip or no entry in varmap table + print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL"//& + " REPLACED WITH CLIMO. SET A FILL "// & + "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." + dummy2d_8 = 0.0 + endif + endif + + endif + + print*,"- CALL FieldScatter FOR INPUT GRID CANOPY MOISTURE CONTENT." + call ESMF_FieldScatter(canopy_mc_input_grid,dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + + print*,"- READ Z0." + vname="sfcr" + slev=":surface:" + call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & + loc=varnum) + + jdisc = 2 ! Search for discipline - land products + j = 0 ! Search from beginning of file. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template Sec4. + jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass + jpdt(2) = 1 ! Sec4/oct 11 - parameter number - surface roughness + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc /= 0 ) then + call handle_grib_error(vname, slev ,method,value,varnum,read_from_input,rc, var8= dummy2d_8) + if (rc==1) then ! missing_var_method == skip or no entry in varmap table + print*, "WARNING: "//trim(vname)//" NOT AVAILABLE IN FILE. THIS FIELD WILL BE"//& + " REPLACED WITH CLIMO. SET A FILL "// & + "VALUE IN THE VARMAP TABLE IF THIS IS NOT DESIRABLE." + dummy2d_8(:,:) = 0.0 + endif + else + gfld%fld = gfld%fld * 10.0 ! Grib files have z0 (m), but fv3 expects z0(cm) +! print*,'sfcr ', maxval(gfld%fld),minval(gfld%fld) + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + endif + + endif + + print*,"- CALL FieldScatter FOR INPUT GRID Z0." + call ESMF_FieldScatter(z0_input_grid,dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ LIQUID SOIL MOISTURE." + vname = "soill" + vname_file = ":SOILL:" + call read_grib_soil(vname,vname_file,lugb, pdt_num,dummy3d) !!! NEED TO HANDLE + !!! SOIL LEVELS + endif + + print*,"- CALL FieldScatter FOR INPUT LIQUID SOIL MOISTURE." + call ESMF_FieldScatter(soilm_liq_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + if (localpet == 0) then + print*,"- READ TOTAL SOIL MOISTURE." + vname = "soilw" + vname_file = "var2_2_1_" ! the var number instead + call read_grib_soil(vname,vname_file,lugb, pdt_num,dummy3d) + endif + + print*,"- CALL FieldScatter FOR INPUT TOTAL SOIL MOISTURE." + call ESMF_FieldScatter(soilm_tot_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + +!---------------------------------------------------------------------------------------- +! Vegetation type is not available in some files. However, it is needed to identify +! permanent land ice points. At land ice, the total soil moisture is a flag value of +! '1'. Use this flag as a temporary solution. +!---------------------------------------------------------------------------------------- + + print*, "- CALL FieldGather for INPUT SOIL TYPE." + call ESMF_FieldGather(soil_type_input_grid, dummy2d_82, rootPet=0, tile=1, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldGather", rc) + + if (localpet == 0) then + + print*,"- READ VEG TYPE." + + jdisc = 2 ! Search for discipline - land products + j = 0 ! Search from beginning of file. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt = -9999 ! Initialize array of values in product definition template Sec4. + jpdt(1) = 0 ! Sec4/oct 10 - parameter category - veg/biomass + jpdt(2) = 198 ! Sec4/oct 11 - parameter number - vegetation type + jpdt(10) = 1 ! Sec4/oct 23 - type of level - ground surface + unpack=.true. + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc) + + if (rc /= 0 ) then + if (.not. vgtyp_from_climo) then + call error_handler("COULD NOT FIND VEGETATION TYPE IN FILE. PLEASE SET VGTYP_FROM_CLIMO=.TRUE. . EXITING", rc) + else ! Set input veg type at land ice from soil moisture flag (1.0). + do j = 1, j_input + do i = 1, i_input + dummy2d_8(i,j) = 0.0 + if(slmsk_save(i,j) == 1 .and. dummy3d(i,j,1) > 0.99) & ! land ice indicated by + ! soil moisture flag of '1'. + dummy2d_8(i,j) = real(veg_type_landice_input,esmf_kind_r8) + enddo + enddo + endif + else ! found vtype in file. + dummy2d_8 = reshape(gfld%fld , (/i_input,j_input/)) + endif + + if (trim(external_model) .ne. "GFS") then + do j = 1, j_input + do i = 1,i_input + if (dummy2d_8(i,j) == 15.0_esmf_kind_r8 .and. slmsk_save(i,j) == 1) then + if (dummy3d(i,j,1) < 0.6) then + dummy2d_8(i,j) = real(veg_type_landice_input,esmf_kind_r8) + elseif (dummy3d(i,j,1) > 0.99) then + slmsk_save(i,j) = 0 + dummy2d_8(i,j) = 0.0_esmf_kind_r8 + dummy2d_82(i,j) = 0.0_esmf_kind_r8 + endif + elseif (dummy2d_8(i,j) == 17.0_esmf_kind_r8 .and. slmsk_save(i,j)==0) then + dummy2d_8(i,j) = 0.0_esmf_kind_r8 + endif + enddo + enddo + endif + +! print*,'vgtyp ',maxval(dummy2d_8),minval(dummy2d_8) + + endif ! read veg type + + print*,"- CALL FieldScatter FOR INPUT VEG TYPE." + call ESMF_FieldScatter(veg_type_input_grid, dummy2d_8, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + print*,"- CALL FieldScatter FOR INPUT SOIL TYPE." + call ESMF_FieldScatter(soil_type_input_grid, dummy2d_82, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + deallocate(dummy2d_82) + + print*,"- CALL FieldScatter FOR INPUT LANDSEA MASK." + call ESMF_FieldScatter(landsea_mask_input_grid,real(slmsk_save,esmf_kind_r8),rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + +!--------------------------------------------------------------------------------- +! At open water (slmsk==0), the soil temperature array is not used and set +! to the filler value of SST. At lake/sea ice points (slmsk=2), the soil +! temperature array holds ice column temperature. This field is not available +! in the grib data, so set to a default value. +!--------------------------------------------------------------------------------- + + if (localpet == 0) then + print*,"- READ SOIL TEMPERATURE." + vname = "soilt" + vname_file = ":TSOIL:" + call read_grib_soil(vname,vname_file,lugb,pdt_num,dummy3d) + call check_soilt(dummy3d,slmsk_save,tsk_save,ICET_DEFAULT,i_input,j_input,lsoil_input) + deallocate(tsk_save) + endif + + deallocate(slmsk_save) + + print*,"- CALL FieldScatter FOR INPUT SOIL TEMPERATURE." + call ESMF_FieldScatter(soil_temp_input_grid, dummy3d, rootpet=0, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldScatter", rc) + + deallocate(dummy3d) + deallocate(dummy2d_8) + + if (localpet == 0) call baclose(lugb, rc) + + end subroutine read_input_sfc_grib2_file + + !> Create surface input grid esmf fields +!! +!! @author George Gayno NCEP/EMC + subroutine init_sfc_esmf_fields + + implicit none + + integer :: rc + + print*,"- CALL FieldCreate FOR INPUT GRID LANDSEA MASK." + landsea_mask_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID Z0." + z0_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID VEGETATION TYPE." + veg_type_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID CANOPY MOISTURE CONTENT." + canopy_mc_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID SEAICE FRACTION." + seaice_fract_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID SEAICE DEPTH." + seaice_depth_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID SEAICE SKIN TEMPERATURE." + seaice_skin_temp_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID SNOW DEPTH." + snow_depth_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID SNOW LIQUID EQUIVALENT." + snow_liq_equiv_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID T2M." + t2m_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID Q2M." + q2m_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID TPRCP." + tprcp_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID F10M." + f10m_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID USTAR." + ustar_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID FFMM." + ffmm_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT GRID SRFLAG." + srflag_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT SKIN TEMPERATURE." + skin_temp_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT SOIL TYPE." + soil_type_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT TERRAIN." + terrain_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT SOIL TEMPERATURE." + soil_temp_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lsoil_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT TOTAL SOIL MOISTURE." + soilm_tot_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lsoil_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT LIQUID SOIL MOISTURE." + soilm_liq_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + ungriddedLBound=(/1/), & + ungriddedUBound=(/lsoil_input/), rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + + + + if (.not. vgfrc_from_climo) then + print*,"- CALL FieldCreate FOR INPUT VEGETATION GREENNESS." + veg_greenness_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & + call error_handler("IN FieldCreate", rc) + endif + + if (.not. minmax_vgfrc_from_climo) then + print*,"- CALL FieldCreate FOR INPUT MIN VEGETATION GREENNESS." + min_veg_greenness_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldCreate", rc) + + print*,"- CALL FieldCreate FOR INPUT MAX VEGETATION GREENNESS." + max_veg_greenness_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldCreate", rc) + endif + + if (.not. lai_from_climo) then + print*,"- CALL FieldCreate FOR INPUT LEAF AREA INDEX." + lai_input_grid = ESMF_FieldCreate(input_grid, & + typekind=ESMF_TYPEKIND_R8, & + staggerloc=ESMF_STAGGERLOC_CENTER, rc=rc) + if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__))& + call error_handler("IN FieldCreate", rc) + endif + end subroutine init_sfc_esmf_fields + +!> Read a record from a netcdf file +!! +!! @param [in] field name of field to be read +!! @param [in] tile_num grid tile number +!! @param [in] imo i-dimension of field +!! @param [in] jmo j-dimension of field +!! @param [in] lmo number of vertical levels of field +!! @param [out] sfcdata 1-d array containing field data +!! @param [out] sfcdata_3d 3-d array containing field data +!! @author George Gayno NCEP/EMC + SUBROUTINE READ_FV3_GRID_DATA_NETCDF(FIELD,TILE_NUM,IMO,JMO,LMO, & + SFCDATA, SFCDATA_3D) + + IMPLICIT NONE + + CHARACTER(LEN=*),INTENT(IN) :: FIELD + + INTEGER, INTENT(IN) :: IMO, JMO, LMO, TILE_NUM + + REAL(ESMF_KIND_R8), INTENT(OUT), OPTIONAL :: SFCDATA(IMO,JMO) + REAL(ESMF_KIND_R8), INTENT(OUT), OPTIONAL :: SFCDATA_3D(IMO,JMO,LMO) + + CHARACTER(LEN=256) :: TILEFILE + + INTEGER :: ERROR, NCID, ID_VAR + + TILEFILE = TRIM(DATA_DIR_INPUT_GRID) // "/" // TRIM(SFC_FILES_INPUT_GRID(TILE_NUM)) + + PRINT*,'WILL READ ',TRIM(FIELD), ' FROM: ', TRIM(TILEFILE) + + ERROR=NF90_OPEN(TRIM(TILEFILE),NF90_NOWRITE,NCID) + CALL NETCDF_ERR(ERROR, 'OPENING: '//TRIM(TILEFILE) ) + + ERROR=NF90_INQ_VARID(NCID, FIELD, ID_VAR) + CALL NETCDF_ERR(ERROR, 'READING FIELD ID' ) + + IF (PRESENT(SFCDATA_3D)) THEN + ERROR=NF90_GET_VAR(NCID, ID_VAR, SFCDATA_3D) + CALL NETCDF_ERR(ERROR, 'READING FIELD' ) + ELSE + ERROR=NF90_GET_VAR(NCID, ID_VAR, SFCDATA) + CALL NETCDF_ERR(ERROR, 'READING FIELD' ) + ENDIF + + ERROR = NF90_CLOSE(NCID) + + END SUBROUTINE READ_FV3_GRID_DATA_NETCDF + + !> Read soil temperature and soil moisture fields from a GRIB2 file. +!! +!! @param [in] vname variable name in varmap table +!! @param [in] vname_file variable name in grib2 file +!! @param [in] lugb logical unit number for surface grib2 file +!! @param [in] pdt_num product definition template number. +!! @param [inout] dummy3d array of soil data +!! @author George Gayno NCEP/EMC + subroutine read_grib_soil(vname, vname_file, lugb, pdt_num, dummy3d) + + use grib_mod + + implicit none + + character(len=20), intent(in) :: vname,vname_file + + integer, intent(in) :: lugb, pdt_num + + real(esmf_kind_r8), intent(inout) :: dummy3d(:,:,:) + + character(len=50) :: slevs(lsoil_input) + character(len=50) :: method + + integer :: varnum, i, j, k, rc, rc2 + integer :: jdisc, jgdtn, jpdtn, lugi + integer :: jids(200), jgdt(200), jpdt(200) + integer :: iscale1, iscale2 + + logical :: unpack + + real(esmf_kind_r4), allocatable :: dummy2d(:,:) + real(esmf_kind_r4) :: value + + type(gribfield) :: gfld + + allocate(dummy2d(i_input,j_input)) + + if(lsoil_input == 4) then + slevs = (/character(24)::':0-0.1 m below ground:', ':0.1-0.4 m below ground:', & + ':0.4-1 m below ground:', ':1-2 m below ground:'/) + elseif(lsoil_input == 9) then + slevs = (/character(26)::':0-0 m below ground',':0.01-0.01 m below ground:',':0.04-0.04 m below ground:', & + ':0.1-0.1 m below ground:',':0.3-0.3 m below ground:',':0.6-0.6 m below ground:', & + ':1-1 m below ground:',':1.6-1.6 m below ground:',':3-3 m below ground:'/) + else + rc = -1 + call error_handler("reading soil levels. File must have 4 or 9 soil levels.", rc) + endif + + call get_var_cond(vname,this_miss_var_method=method,this_miss_var_value=value, & + loc=varnum) + + lugi = 0 ! unit number for index file + jdisc = 2 ! search for discipline - land products + j = 0 ! search at beginning of file. + jpdt = -9999 ! array of values in product definition template 4.n + jids = -9999 ! array of values in identification section, set to wildcard + jgdt = -9999 ! array of values in grid definition template 3.m + jgdtn = -1 ! search for any grid definition number. + jpdtn = pdt_num ! Search for the product definition template number. + jpdt(1) = 0 ! Section 4/Octet 10 - parameter category - veg/biomass + if (trim(vname) == 'soilt') jpdt(2) = 2 ! Section 4/Octet 11 - parameter number - soil temp + if (trim(vname) == 'soilw') jpdt(2) = 192 ! Section 4/Octet 11 - parameter number - total soilm + if (trim(vname) == 'soill') then + jpdt(1) = 3 ! Section 4/Octet 10 - soil products + jpdt(2) = 192 ! Section 4/Octet 11 - parameter number - liquid soilm + endif + jpdt(10) = 106 ! Section 4/Octet 23 - depth below ground + jpdt(13) = 106 ! Section 4/Octet 29 - depth below ground + unpack=.true. + + do i = 1,lsoil_input + + call getgb2(lugb, lugi, j, jdisc, jids, jpdtn, jpdt, jgdtn, jgdt, & + unpack, k, gfld, rc2) + + if (rc2 /= 0) then ! record not found. + call handle_grib_error(vname_file, slevs(i),method,value,varnum,read_from_input,rc,var=dummy2d) + if (rc==1 .and. trim(vname) /= "soill") then + ! missing_var_method == skip or no entry in varmap table + call error_handler("READING IN "//trim(vname)//". SET A FILL "// & + "VALUE IN THE VARMAP TABLE IF THIS ERROR IS NOT DESIRABLE.",rc) + elseif (rc==1) then + dummy3d(:,:,:) = 0.0_esmf_kind_r8 + return + endif + endif + + if (rc2 == 0) then ! record found. + iscale1 = 10 ** gfld%ipdtmpl(11) + iscale2 = 10 ** gfld%ipdtmpl(14) +! print*,'getgb2 top of soil layer in m ', float(gfld%ipdtmpl(12))/float(iscale1) +! print*,'getgb2 bot of soil layer in m ', float(gfld%ipdtmpl(15))/float(iscale2) + dummy2d = reshape(real(gfld%fld,kind=esmf_kind_r4), (/i_input,j_input/) ) + endif + + j = k + + dummy3d(:,:,i) = real(dummy2d,esmf_kind_r8) + + enddo + + deallocate(dummy2d) + + end subroutine read_grib_soil + + !> Free up memory associated with sfc data. +!! +!! @author George Gayno NCEP/EMC + subroutine cleanup_input_sfc_data + + implicit none + + integer :: rc + + print*,"- CALL FieldDestroy FOR INPUT GRID FIELDS." + + call ESMF_FieldDestroy(canopy_mc_input_grid, rc=rc) + call ESMF_FieldDestroy(f10m_input_grid, rc=rc) + call ESMF_FieldDestroy(ffmm_input_grid, rc=rc) + if (.not. convert_nst) then + call ESMF_FieldDestroy(landsea_mask_input_grid, rc=rc) + endif + call ESMF_FieldDestroy(q2m_input_grid, rc=rc) + call ESMF_FieldDestroy(seaice_depth_input_grid, rc=rc) + call ESMF_FieldDestroy(seaice_fract_input_grid, rc=rc) + call ESMF_FieldDestroy(seaice_skin_temp_input_grid, rc=rc) + call ESMF_FieldDestroy(skin_temp_input_grid, rc=rc) + call ESMF_FieldDestroy(snow_depth_input_grid, rc=rc) + call ESMF_FieldDestroy(snow_liq_equiv_input_grid, rc=rc) + call ESMF_FieldDestroy(soil_temp_input_grid, rc=rc) + call ESMF_FieldDestroy(soil_type_input_grid, rc=rc) + call ESMF_FieldDestroy(soilm_liq_input_grid, rc=rc) + call ESMF_FieldDestroy(soilm_tot_input_grid, rc=rc) + call ESMF_FieldDestroy(srflag_input_grid, rc=rc) + call ESMF_FieldDestroy(t2m_input_grid, rc=rc) + call ESMF_FieldDestroy(tprcp_input_grid, rc=rc) + call ESMF_FieldDestroy(ustar_input_grid, rc=rc) + call ESMF_FieldDestroy(veg_type_input_grid, rc=rc) + call ESMF_FieldDestroy(z0_input_grid, rc=rc) + call ESMF_FieldDestroy(terrain_input_grid, rc=rc) + if (.not. vgfrc_from_climo) then + call ESMF_FieldDestroy(veg_greenness_input_grid, rc=rc) + endif + if (.not. minmax_vgfrc_from_climo) then + call ESMF_FieldDestroy(min_veg_greenness_input_grid, rc=rc) + call ESMF_FieldDestroy(max_veg_greenness_input_grid, rc=rc) + endif + if (.not. lai_from_climo) then + call ESMF_FieldDestroy(lai_input_grid, rc=rc) + endif + + end subroutine cleanup_input_sfc_data + + end module sfc_input_data diff --git a/sorc/chgres_cube.fd/static_data.F90 b/sorc/chgres_cube.fd/static_data.F90 index 081d6beac..e95756c6c 100644 --- a/sorc/chgres_cube.fd/static_data.F90 +++ b/sorc/chgres_cube.fd/static_data.F90 @@ -14,6 +14,8 @@ module static_data use esmf + use utilities, only : error_handler, netcdf_err + implicit none private diff --git a/sorc/chgres_cube.fd/surface.F90 b/sorc/chgres_cube.fd/surface.F90 index 8213d17ba..26066e362 100644 --- a/sorc/chgres_cube.fd/surface.F90 +++ b/sorc/chgres_cube.fd/surface.F90 @@ -44,6 +44,8 @@ module surface use write_data, only : write_fv3_sfc_data_netcdf + use utilities, only : error_handler + implicit none private @@ -104,9 +106,10 @@ module surface !! @author George Gayno NCEP/EMC subroutine surface_driver(localpet) - use input_data, only : cleanup_input_sfc_data, & - cleanup_input_nst_data, & - read_input_sfc_data, & + use sfc_input_data, only : cleanup_input_sfc_data, & + read_input_sfc_data + + use nst_input_data, only : cleanup_input_nst_data, & read_input_nst_data use program_setup, only : calc_soil_params_driver, & @@ -117,6 +120,8 @@ subroutine surface_driver(localpet) use surface_target_data, only : cleanup_target_nst_data + use utilities, only : error_handler + implicit none integer, intent(in) :: localpet @@ -245,7 +250,7 @@ subroutine interp(localpet) use mpi use esmf - use input_data, only : canopy_mc_input_grid, & + use sfc_input_data, only : canopy_mc_input_grid, & f10m_input_grid, & ffmm_input_grid, & landsea_mask_input_grid, & @@ -265,7 +270,13 @@ subroutine interp(localpet) ustar_input_grid, & veg_type_input_grid, & z0_input_grid, & - c_d_input_grid, & + veg_type_landice_input, & + veg_greenness_input_grid, & + max_veg_greenness_input_grid, & + min_veg_greenness_input_grid, & + lai_input_grid + + use nst_input_data, only : c_d_input_grid, & c_0_input_grid, & d_conv_input_grid, & dt_cool_input_grid, & @@ -282,12 +293,9 @@ subroutine interp(localpet) xtts_input_grid, & xzts_input_grid, & z_c_input_grid, & - zm_input_grid, terrain_input_grid, & - veg_type_landice_input, & - veg_greenness_input_grid, & - max_veg_greenness_input_grid, & - min_veg_greenness_input_grid, & - lai_input_grid + zm_input_grid + + use atm_input_data, only : terrain_input_grid use model_grid, only : input_grid, target_grid, & i_target, j_target, & @@ -647,7 +655,7 @@ subroutine interp(localpet) mask_input_ptr = 1 where (nint(landmask_input_ptr) == 1) mask_input_ptr = 0 - mask_target_ptr = seamask_target_ptr + mask_target_ptr = int(seamask_target_ptr,kind=esmf_kind_i4) method=ESMF_REGRIDMETHOD_CONSERVE @@ -2006,11 +2014,12 @@ end subroutine adjust_soilt_for_terrain !! @author Jeff Beck subroutine adjust_soil_levels(localpet) use model_grid, only : lsoil_target, i_input, j_input, input_grid - use input_data, only : lsoil_input, soil_temp_input_grid, & + use sfc_input_data, only : lsoil_input, soil_temp_input_grid, & soilm_liq_input_grid, soilm_tot_input_grid implicit none integer, intent(in) :: localpet - character(len=1000) :: msg + character(len=500) :: msg + character(len=2) :: lsoil_input_ch, lsoil_target_ch integer :: rc real(esmf_kind_r8) :: tmp(i_input,j_input), & data_one_tile(i_input,j_input,lsoil_input), & @@ -2105,12 +2114,11 @@ subroutine adjust_soil_levels(localpet) elseif (lsoil_input /= lsoil_target) then rc = -1 - - write(msg,'("NUMBER OF SOIL LEVELS IN INPUT (",I2,") and OUPUT & - (",I2,") MUST EITHER BE EQUAL OR 9 AND 4, RESPECTIVELY")') & - lsoil_input, lsoil_target - - call error_handler(trim(msg), rc) + write(lsoil_input_ch, '(i2)') lsoil_input + write(lsoil_target_ch, '(i2)') lsoil_target + msg="NUMBER OF SOIL LEVELS IN INPUT " // lsoil_input_ch // " AND OUTPUT " & + // lsoil_target_ch // " MUST EITHER BE EQUAL OR 9 AND 4 RESPECTIVELY." + call error_handler(msg, rc) endif end subroutine adjust_soil_levels diff --git a/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 b/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 index 1dfd98d31..beb3c45a5 100644 --- a/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 +++ b/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 @@ -12,6 +12,7 @@ module thompson_mp_climo_data use netcdf use program_setup, only : cycle_mon, cycle_day, cycle_hour, & thomp_mp_climo_file + use utilities, only : error_handler, netcdf_err implicit none diff --git a/sorc/chgres_cube.fd/utils.F90 b/sorc/chgres_cube.fd/utils.F90 index 568d0de0e..c46540c5e 100644 --- a/sorc/chgres_cube.fd/utils.F90 +++ b/sorc/chgres_cube.fd/utils.F90 @@ -1,3 +1,6 @@ +module utilities + +contains !> @file !! @brief Contains utility routines. !! @@ -18,7 +21,7 @@ subroutine error_handler(string, rc) integer :: ierr - print*,"- FATAL ERROR: ", string + print*,"- FATAL ERROR: ", trim(string) print*,"- IOSTAT IS: ", rc call mpi_abort(mpi_comm_world, 999, ierr) @@ -99,3 +102,399 @@ subroutine to_lower(strIn) end do strIn(:) = strOut(:) end subroutine to_lower + +!> Handle GRIB2 read error based on the user selected +!! method in the varmap file. +!! +!! @param [in] vname grib2 variable name +!! @param [in] lev grib2 variable level +!! @param [in] method how missing data is handled +!! @param [in] value fill value for missing data +!! @param [in] varnum grib2 variable number +!! @param [inout] iret return status code +!! @param [inout] var 4-byte array of corrected data +!! @param [inout] var8 8-byte array of corrected data +!! @param [inout] var3d 3-d array of corrected data +!! @param [inout] read_from_input logical array indicating if variable was read in +!! @author Larissa Reames +subroutine handle_grib_error(vname,lev,method,value,varnum,read_from_input, iret,var,var8,var3d) + + use, intrinsic :: ieee_arithmetic + use esmf + + implicit none + + real(esmf_kind_r4), intent(in) :: value + logical, intent(inout) :: read_from_input(:) + real(esmf_kind_r4), intent(inout), optional :: var(:,:) + real(esmf_kind_r8), intent(inout), optional :: var8(:,:) + real(esmf_kind_r8), intent(inout), optional :: var3d(:,:,:) + + character(len=20), intent(in) :: vname, lev, method + character(len=200) :: err_msg + + integer, intent(in) :: varnum + integer, intent(inout) :: iret + + iret = 0 + if (varnum == 9999) then + print*, "WARNING: ", trim(vname), " NOT FOUND AT LEVEL ", lev, " IN EXTERNAL FILE ", & + "AND NO ENTRY EXISTS IN VARMAP TABLE. VARIABLE WILL NOT BE USED." + iret = 1 + + return + endif + + if (trim(method) == "skip" ) then + print*, "WARNING: SKIPPING ", trim(vname), " IN FILE" + read_from_input(varnum) = .false. + iret = 1 + elseif (trim(method) == "set_to_fill") then + print*, "WARNING: ,", trim(vname), " NOT AVAILABLE AT LEVEL ", trim(lev), & + ". SETTING EQUAL TO FILL VALUE OF ", value + if(present(var)) var(:,:) = value + if(present(var8)) var8(:,:) = value + if(present(var3d)) var3d(:,:,:) = value + elseif (trim(method) == "set_to_NaN") then + print*, "WARNING: ,", trim(vname), " NOT AVAILABLE AT LEVEL ", trim(lev), & + ". SETTING EQUAL TO NaNs" + if(present(var)) var(:,:) = ieee_value(var,IEEE_QUIET_NAN) + if(present(var8)) var8(:,:) = ieee_value(var8,IEEE_QUIET_NAN) + if(present(var3d)) var3d(:,:,:) = ieee_value(var3d,IEEE_QUIET_NAN) + elseif (trim(method) == "stop") then + err_msg="READING " // trim(vname) // " at level " //lev// ". TO MAKE THIS NON-" // & + "FATAL, CHANGE STOP TO SKIP FOR THIS VARIABLE IN YOUR VARMAP FILE." + call error_handler(err_msg, iret) + elseif (trim(method) == "intrp") then + print*, "WARNING: ,"//trim(vname)//" NOT AVAILABLE AT LEVEL "//trim(lev)// & + ". WILL INTERPOLATE INTERSPERSED MISSING LEVELS AND/OR FILL MISSING"//& + " LEVELS AT EDGES." + else + err_msg="ERROR USING MISSING_VAR_METHOD. PLEASE SET VALUES IN" // & + " VARMAP TABLE TO ONE OF: set_to_fill, set_to_NaN, intrp, skip, or stop." + call error_handler(err_msg, 1) + endif + +end subroutine handle_grib_error + +!> Sort an array of values. +!! +!! @param a the sorted array +!! @param first the first value of sorted array +!! @param last the last value of sorted array +!! @author Jili Dong NOAA/EMC +recursive subroutine quicksort(a, first, last) + implicit none + real*8 a(*), x, t + integer first, last + integer i, j + + x = a( (first+last) / 2 ) + i = first + j = last + do + do while (a(i) < x) + i=i+1 + end do + do while (x < a(j)) + j=j-1 + end do + if (i >= j) exit + t = a(i); a(i) = a(j); a(j) = t + i=i+1 + j=j-1 + end do + if (first < i-1) call quicksort(a, first, i-1) + if (j+1 < last) call quicksort(a, j+1, last) +end subroutine quicksort + +!> Check for and replace certain values in soil temperature. +!> At open water points (landmask=0) use skin temperature as +!> a filler value. At land points (landmask=1) with excessive +!> soil temperature, replace soil temperature with skin temperature. +!> In GEFSv12.0 data there are some erroneous missing values at +!> land points which this corrects. At sea ice points (landmask=2), +!> store a default ice column temperature because grib2 files do not +!> have ice column temperature which FV3 expects at these points. +!! +!! @param soilt [inout] 3-dimensional soil temperature arrray +!! @param landmask [in] landmask of the input grid +!! @param skint [in] 2-dimensional skin temperature array +!! @param ICET_DEFAULT [in] Default temperature to apply at ice points +!! @param i_input [in] i-dimension of input grid +!! @param j_input [in] j-dimension of input grid +!! @param lsoil_input [in] soil layers dimension of input grid +!! @author Larissa Reames CIMMS/NSSL + +subroutine check_soilt(soilt, landmask, skint,ICET_DEFAULT,i_input,j_input,lsoil_input) + use esmf + implicit none + integer, intent(in) :: i_input, j_input, lsoil_input + real(esmf_kind_r8), intent(inout) :: soilt(i_input,j_input,lsoil_input) + real(esmf_kind_r8), intent(in) :: skint(i_input,j_input) + real, intent(in) :: ICET_DEFAULT + integer(esmf_kind_i4), intent(in) :: landmask(i_input,j_input) + + integer :: i, j, k + + do k=1,lsoil_input + do j = 1, j_input + do i = 1, i_input + if (landmask(i,j) == 0_esmf_kind_i4 ) then + soilt(i,j,k) = skint(i,j) + else if (landmask(i,j) == 1_esmf_kind_i4 .and. soilt(i,j,k) > 350.0_esmf_kind_r8) then + soilt(i,j,k) = skint(i,j) + else if (landmask(i,j) == 2_esmf_kind_i4 ) then + soilt(i,j,k) = ICET_DEFAULT + endif + enddo + enddo + enddo +end subroutine check_soilt + +!> When using GEFS data, some points on the target grid have +!> unreasonable canpy moisture content, so zero out any +!> locations with unrealistic canopy moisture values (>0.5). +!! +!! @param cnwat [input] 2-dimensional canopy moisture content +!! @param i_input [in] i-dimension of input grid +!! @param j_input [in] j-dimension of input grid +!! @author Larissa Reames CIMMS/NSSL + +subroutine check_cnwat(cnwat,i_input,j_input) + use esmf + implicit none + integer, intent(in) :: i_input, j_input + real(esmf_kind_r8), intent(inout) :: cnwat(i_input,j_input) + + real(esmf_kind_r8) :: max_cnwat = 0.5 + + integer :: i, j + + do i = 1,i_input + do j = 1,j_input + if (cnwat(i,j) .gt. max_cnwat) cnwat(i,j) = 0.0_esmf_kind_r8 + enddo + enddo +end subroutine check_cnwat + +!> Pressure to presure vertical interpolation for tracers with linear or lnP +!> interpolation. Input tracers on pres levels are interpolated +!> to the target output pressure levels. The matching levels of input and +!> output will keep the same. Extrapolation is also allowed but needs +!> caution. The routine is mostly for GFSV16 combined grib2 input when spfh has +!> missing levels in low and mid troposphere from U/T/HGT/DZDT. +!! +!! @param [in] ppin 1d input pres levs +!! @param [in] xxin 1d input tracer +!! @param [in] npin number of input levs +!! @param [in] ppout 1d target pres levs +!! @param [out] xxout 1d interpolated tracer +!! @param [in] npout number of target levs +!! @param [in] linlog interp method.1:linear;not 1:log;neg:extrp allowed +!! @param [in] xmsg fill values of missing levels (-999.0) +!! @param [out] ier error status. non 0: failed interpolation +!! @author Jili Dong NCEP/EMC +!! @date 2021/07/30 +SUBROUTINE DINT2P(PPIN,XXIN,NPIN,PPOUT,XXOUT,NPOUT & + ,LINLOG,XMSG,IER) + IMPLICIT NONE + +! NCL code for pressure level interpolation +! +! This code was designed for one simple task. It has since +! been mangled and abused for assorted reasons. For example, +! early gfortran compilers had some issues with automatic arrays. +! Hence, the C-Wrapper was used to create 'work' arrays which +! were then passed to this code. The original focused (non-NCL) +! task was to handle PPIN & PPOUT that had the same 'monotonicity.' +! Extra code was added to handle the more general case. +! Blah-Blah: Punch line: it is embarrassingly convoluted!!! +! +! ! input types + INTEGER NPIN,NPOUT,LINLOG,IER + real*8 PPIN(NPIN),XXIN(NPIN),PPOUT(NPOUT),XMSG + ! output + real*8 XXOUT(NPOUT) + ! work + real*8 PIN(NPIN),XIN(NPIN),P(NPIN),X(NPIN) + real*8 POUT(NPOUT),XOUT(NPOUT) + +! local + INTEGER NP,NL,NLMAX,NLSAVE,NP1,NO1,N1,N2,LOGLIN, & + NLSTRT + real*8 SLOPE,PA,PB,PC + + LOGLIN = ABS(LINLOG) + +! error check: enough points: pressures consistency? + + IER = 0 + IF (NPOUT.GT.0) THEN + DO NP = 1,NPOUT + XXOUT(NP) = XMSG + END DO + END IF +! Jili Dong input levels have to be the same as output levels: +! we only interpolate for levels with missing variables +! IF (.not. all(PPIN .eq. PPOUT)) IER = IER+1 + + IF (NPIN.LT.2 .OR. NPOUT.LT.1) IER = IER + 1 + + IF (IER.NE.0) THEN +! PRINT *,'INT2P: error exit: ier=',IER + RETURN + END IF + +! should *input arrays* be reordered? want p(1) > p(2) > p(3) etc +! so that it will match order for which code was originally designed +! copy to 'work' arrays + + NP1 = 0 + NO1 = 0 + IF (PPIN(1).LT.PPIN(2)) THEN + NP1 = NPIN + 1 + END IF + IF (PPOUT(1).LT.PPOUT(2)) THEN + NO1 = NPOUT + 1 + END IF + + DO NP = 1,NPIN + PIN(NP) = PPIN(ABS(NP1-NP)) + XIN(NP) = XXIN(ABS(NP1-NP)) + END DO + + DO NP = 1,NPOUT + POUT(NP) = PPOUT(ABS(NO1-NP)) + END DO + +! eliminate XIN levels with missing data. +! . This can happen with observational data. + + NL = 0 + DO NP = 1,NPIN + IF (XIN(NP).NE.XMSG .AND. PIN(NP).NE.XMSG) THEN + NL = NL + 1 + P(NL) = PIN(NP) + X(NL) = XIN(NP) + END IF + END DO + NLMAX = NL + + ! all missing data + IF (NLMAX.LT.2) THEN + IER = IER + 1000 + PRINT *,'INT2P: ier=',IER + RETURN + END IF + +! ===============> pressure in decreasing order <================ +! perform the interpolation [pin(1)>pin(2)>...>pin(npin)] +! ( p ,x) +! ------------------------- p(nl+1), x(nl+1) example (200,5) +! . +! ------------------------- pout(np), xout(np) (250,?) +! . +! ------------------------- p(nl) , x(nl) (300,10) + + +! exact p-level matches + NLSTRT = 1 + NLSAVE = 1 + DO NP = 1,NPOUT + XOUT(NP) = XMSG + DO NL = NLSTRT,NLMAX + IF (POUT(NP).EQ.P(NL)) THEN + XOUT(NP) = X(NL) + NLSAVE = NL + 1 + GO TO 10 + END IF + END DO + 10 NLSTRT = NLSAVE + END DO + + IF (LOGLIN.EQ.1) THEN + DO NP = 1,NPOUT + DO NL = 1,NLMAX - 1 + IF (POUT(NP).LT.P(NL) .AND. POUT(NP).GT.P(NL+1)) THEN + SLOPE = (X(NL)-X(NL+1))/ (P(NL)-P(NL+1)) + XOUT(NP) = X(NL+1) + SLOPE* (POUT(NP)-P(NL+1)) + END IF + END DO + END DO + ELSE + DO NP = 1,NPOUT + DO NL = 1,NLMAX - 1 + IF (POUT(NP).LT.P(NL) .AND. POUT(NP).GT.P(NL+1)) THEN + PA = LOG(P(NL)) + PB = LOG(POUT(NP)) +! special case: In case someome inadvertently enter p=0. + if (p(nl+1).gt.0.d0) then + PC = LOG(P(NL+1)) + else + PC = LOG(1.E-4) + end if + + SLOPE = (X(NL)-X(NL+1))/ (PA-PC) + XOUT(NP) = X(NL+1) + SLOPE* (PB-PC) + END IF + END DO + END DO + END IF + +! extrapolate? +! . use the 'last' valid slope for extrapolating + + IF (LINLOG.LT.0) THEN + DO NP = 1,NPOUT + DO NL = 1,NLMAX + IF (POUT(NP).GT.P(1)) THEN + IF (LOGLIN.EQ.1) THEN + SLOPE = (X(2)-X(1))/ (P(2)-P(1)) + XOUT(NP) = X(1) + SLOPE* (POUT(NP)-P(1)) + ELSE + PA = LOG(P(2)) + PB = LOG(POUT(NP)) + PC = LOG(P(1)) + SLOPE = (X(2)-X(1))/ (PA-PC) + XOUT(NP) = X(1) + SLOPE* (PB-PC) + END IF + ELSE IF (POUT(NP).LT.P(NLMAX)) THEN + N1 = NLMAX + N2 = NLMAX - 1 + IF (LOGLIN.EQ.1) THEN + SLOPE = (X(N1)-X(N2))/ (P(N1)-P(N2)) + XOUT(NP) = X(N1) + SLOPE* (POUT(NP)-P(N1)) + ELSE + PA = LOG(P(N1)) + PB = LOG(POUT(NP)) + PC = LOG(P(N2)) + SLOPE = (X(N1)-X(N2))/ (PA-PC) + !XOUT(NP) = X(N1) + SLOPE* (PB-PC) !bug fixed below + XOUT(NP) = X(N1) + SLOPE* (PB-PA) + END IF + END IF + END DO + END DO + END IF + +! place results in the return array; +! . possibly .... reverse to original order + + if (NO1.GT.0) THEN + DO NP = 1,NPOUT + n1 = ABS(NO1-NP) + PPOUT(NP) = POUT(n1) + XXOUT(NP) = XOUT(n1) + END DO + ELSE + DO NP = 1,NPOUT + PPOUT(NP) = POUT(NP) + XXOUT(NP) = XOUT(NP) + END DO + END IF + + + RETURN + END SUBROUTINE DINT2P +end module utilities diff --git a/sorc/chgres_cube.fd/wam_climo_data.f90 b/sorc/chgres_cube.fd/wam_climo_data.f90 index 0ba5647bc..32ca66a9d 100644 --- a/sorc/chgres_cube.fd/wam_climo_data.f90 +++ b/sorc/chgres_cube.fd/wam_climo_data.f90 @@ -29,84 +29,84 @@ module wam_gtd7bk_mod ! msise-00 01-feb-02 ! - real :: pt1(50) !< block space data for temperature - real :: pt2(50) !< block space data for temperature - real :: pt3(50) !< block space data for temperature - real :: pa1(50) !< block space data for he denisity - real :: pa2(50) !< block space data for he denisity - real :: pa3(50) !< block space data for he denisity - real :: pb1(50) !< block space data for o density - real :: pb2(50) !< block space data for o density - real :: pb3(50) !< block space data for o density - real :: pc1(50) !< block space data for n2 density - real :: pc2(50) !< block space data for n2 density - real :: pc3(50) !< block space data for n2 density - real :: pd1(50) !< block space data for tlb - real :: pd2(50) !< block space data for tlb - real :: pd3(50) !< block space data for tlb - real :: pe1(50) !< block space data for o2 density - real :: pe2(50) !< block space data for o2 density - real :: pe3(50) !< block space data for o2 density - real :: pf1(50) !< block space data for ar density - real :: pf2(50) !< block space data for ar density - real :: pf3(50) !< block space data for ar density - real :: pg1(50) !< block space data for h density - real :: pg2(50) !< block space data for h density - real :: pg3(50) !< block space data for h density - real :: ph1(50) !< block space data for n density - real :: ph2(50) !< block space data for n density - real :: ph3(50) !< block space data for n density - real :: pi1(50) !< block space data for hot o density - real :: pi2(50) !< block space data for hot o density - real :: pi3(50) !< block space data for hot o density - real :: pj1(50) !< block space data for s param - real :: pj2(50) !< block space data for s param - real :: pj3(50) !< block space data for s param - real :: pk1(50) !< block space data for turbo - real :: pl1(50) !< block space data for tn1(2) - real :: pl2(50) !< block space data for tn1(2) - real :: pm1(50) !< block space data for tn1(3) - real :: pm2(50) !< block space data for tn1(3) - real :: pn1(50) !< block space data for tn1(4) - real :: pn2(50) !< block space data for tn1(4) - real :: po1(50) !< block space data for tn1(5) tn2(1) - real :: po2(50) !< block space data for tn1(5) tn2(1) - real :: pp1(50) !< block space data for tn2(2) - real :: pp2(50) !< block space data for tn2(2) - real :: pq1(50) !< block space data for tn2(3) - real :: pq2(50) !< block space data for tn2(3) - real :: pr1(50) !< block space data for tn2(4) tn3(1) - real :: pr2(50) !< block space data for tn2(4) tn3(1) - real :: ps1(50) !< block space data for tn3(2) - real :: ps2(50) !< block space data for tn3(2) - real :: pu1(50) !< block space data for tn3(3) - real :: pu2(50) !< block space data for tn3(3) - real :: pv1(50) !< block space data for tn3(4) - real :: pv2(50) !< block space data for tn3(4) - real :: pw1(50) !< block space data for tn3(5) surface temperature tsl - real :: pw2(50) !< block space data for tn3(5) surface temperature tsl - real :: px1(50) !< block space data for tgn3(2) surface grad tslg - real :: px2(50) !< block space data for tgn3(2) surface grad tslg - real :: py1(50) !< block space data for tgn2(1) tgn1(2) - real :: py2(50) !< block space data for tgn2(1) tgn1(2) - real :: pz1(50) !< block space data for tgn3(1) tgn2(2) - real :: pz2(50) !< block space data for tgn3(1) tgn2(2) - real :: paa1(50) !< block space data for semiannual mult sam - real :: paa2(50) !< block space data for semiannual mult sam + real :: pt1(50) !< block space data for temperature + real :: pt2(50) !< block space data for temperature + real :: pt3(50) !< block space data for temperature + real :: pa1(50) !< block space data for he denisity + real :: pa2(50) !< block space data for he denisity + real :: pa3(50) !< block space data for he denisity + real :: pb1(50) !< block space data for o density + real :: pb2(50) !< block space data for o density + real :: pb3(50) !< block space data for o density + real :: pc1(50) !< block space data for n2 density + real :: pc2(50) !< block space data for n2 density + real :: pc3(50) !< block space data for n2 density + real :: pd1(50) !< block space data for tlb + real :: pd2(50) !< block space data for tlb + real :: pd3(50) !< block space data for tlb + real :: pe1(50) !< block space data for o2 density + real :: pe2(50) !< block space data for o2 density + real :: pe3(50) !< block space data for o2 density + real :: pf1(50) !< block space data for ar density + real :: pf2(50) !< block space data for ar density + real :: pf3(50) !< block space data for ar density + real :: pg1(50) !< block space data for h density + real :: pg2(50) !< block space data for h density + real :: pg3(50) !< block space data for h density + real :: ph1(50) !< block space data for n density + real :: ph2(50) !< block space data for n density + real :: ph3(50) !< block space data for n density + real :: pi1(50) !< block space data for hot o density + real :: pi2(50) !< block space data for hot o density + real :: pi3(50) !< block space data for hot o density + real :: pj1(50) !< block space data for s param + real :: pj2(50) !< block space data for s param + real :: pj3(50) !< block space data for s param + real :: pk1(50) !< block space data for turbo + real :: pl1(50) !< block space data for tn1(2) + real :: pl2(50) !< block space data for tn1(2) + real :: pm1(50) !< block space data for tn1(3) + real :: pm2(50) !< block space data for tn1(3) + real :: pn1(50) !< block space data for tn1(4) + real :: pn2(50) !< block space data for tn1(4) + real :: po1(50) !< block space data for tn1(5) tn2(1) + real :: po2(50) !< block space data for tn1(5) tn2(1) + real :: pp1(50) !< block space data for tn2(2) + real :: pp2(50) !< block space data for tn2(2) + real :: pq1(50) !< block space data for tn2(3) + real :: pq2(50) !< block space data for tn2(3) + real :: pr1(50) !< block space data for tn2(4) tn3(1) + real :: pr2(50) !< block space data for tn2(4) tn3(1) + real :: ps1(50) !< block space data for tn3(2) + real :: ps2(50) !< block space data for tn3(2) + real :: pu1(50) !< block space data for tn3(3) + real :: pu2(50) !< block space data for tn3(3) + real :: pv1(50) !< block space data for tn3(4) + real :: pv2(50) !< block space data for tn3(4) + real :: pw1(50) !< block space data for tn3(5) surface temperature tsl + real :: pw2(50) !< block space data for tn3(5) surface temperature tsl + real :: px1(50) !< block space data for tgn3(2) surface grad tslg + real :: px2(50) !< block space data for tgn3(2) surface grad tslg + real :: py1(50) !< block space data for tgn2(1) tgn1(2) + real :: py2(50) !< block space data for tgn2(1) tgn1(2) + real :: pz1(50) !< block space data for tgn3(1) tgn2(2) + real :: pz2(50) !< block space data for tgn3(1) tgn2(2) + real :: paa1(50) !< block space data for semiannual mult sam + real :: paa2(50) !< block space data for semiannual mult sam ! - real :: ptm(10) !< block space data for lower boundary - real :: pdm(10,8) !< block space data for lower boundary + real :: ptm(10) !< block space data for lower boundary + real :: pdm(10,8) !< block space data for lower boundary ! real :: pavgm(10) !< block space data for middle atmosphere averages ! - character*4:: isdate(3) !< define date - character*4:: istime(2) !< define time - character*4:: name(2) !< define data name + character*4:: isdate(3) !< define date + character*4:: istime(2) !< define time + character*4:: name(2) !< define data name ! - integer :: imr !< define version + integer :: imr !< define version ! - real :: pr65(2,65) !< define pressures - real :: pr151(2,151) !< define pressures + real :: pr65(2,65) !< define pressures + real :: pr151(2,151) !< define pressures data imr/0/ data isdate/'01-f','eb-0','2 '/,istime/'15:4','9:27'/ @@ -878,73 +878,73 @@ end module wam_gtd7bk_mod !! @author Hann-Ming Henry Juang module gettemp_mod ! - real :: tlb !< labeled temperature - real :: s !< scale inverse to temperature difference - real :: db04 !< diffusive density at zlb for g4 - real :: db16 !< diffusive density at zlb for g18 - real :: db28 !< diffusive density at zlb for g28 - real :: db32 !< diffusive density at zlb for g32 - real :: db40 !< diffusive density at zlb for g40 - real :: db48 !< diffusive density at zlb for g48 - real :: db01 !< diffusive density at zlb for g01 - real :: za !< joining altitude of bates and spline - real :: t0 !< initial temperature - real :: z0 !< initial height - real :: g0 !< initial gradient variations - real :: rl !< correction to specified mixing ratio at ground - real :: dd !< diffusive density at alt - real :: db14 !< diffusive density at zlb for g14 - real :: tr12 !< try factor 1 or 2 + real :: tlb !< labeled temperature + real :: s !< scale inverse to temperature difference + real :: db04 !< diffusive density at zlb for g4 + real :: db16 !< diffusive density at zlb for g18 + real :: db28 !< diffusive density at zlb for g28 + real :: db32 !< diffusive density at zlb for g32 + real :: db40 !< diffusive density at zlb for g40 + real :: db48 !< diffusive density at zlb for g48 + real :: db01 !< diffusive density at zlb for g01 + real :: za !< joining altitude of bates and spline + real :: t0 !< initial temperature + real :: z0 !< initial height + real :: g0 !< initial gradient variations + real :: rl !< correction to specified mixing ratio at ground + real :: dd !< diffusive density at alt + real :: db14 !< diffusive density at zlb for g14 + real :: tr12 !< try factor 1 or 2 ! - real :: tn1(5) !< temperature at node 1 (~mesosphere) - real :: tn2(4) !< temperature at node 2 (~stratosphere) - real :: tn3(5) !< temperature at node 3 (~troposphere) - real :: tgn1(2) !< temperature gradient at node 1 (~mesosphere) - real :: tgn2(2) !< temperature gradient at node 2 (~stratosphere) - real :: tgn3(2) !< temperature gradient at node 3 (~troposphere) + real :: tn1(5) !< temperature at node 1 (~mesosphere) + real :: tn2(4) !< temperature at node 2 (~stratosphere) + real :: tn3(5) !< temperature at node 3 (~troposphere) + real :: tgn1(2) !< temperature gradient at node 1 (~mesosphere) + real :: tgn2(2) !< temperature gradient at node 2 (~stratosphere) + real :: tgn3(2) !< temperature gradient at node 3 (~troposphere) ! - real :: pt(150) !< temperature - real :: pd(150,9) !< he density - real :: ps(150) !< s parameter - real :: pdl(25,2) !< turbo - real :: ptl(100,4) !< upper temperature - real :: pma(100,10) !< middle and low temperature - real :: sam(100) !< semiannual mult sam + real :: pt(150) !< temperature + real :: pd(150,9) !< he density + real :: ps(150) !< s parameter + real :: pdl(25,2) !< turbo + real :: ptl(100,4) !< upper temperature + real :: pma(100,10) !< middle and low temperature + real :: sam(100) !< semiannual mult sam ! - real :: sw(25) !< weighting - real :: swc(25) !< weighting + real :: sw(25) !< weighting + real :: swc(25) !< weighting ! - real :: dm04 !< mixed density at alt04 - real :: dm16 !< mixed density at alt16 - real :: dm28 !< mixed density at alt28 - real :: dm32 !< mixed density at alt32 - real :: dm40 !< mixed density at alt40 - real :: dm01 !< mixed density at alt01 - real :: dm14 !< mixed density at alt14 + real :: dm04 !< mixed density at alt04 + real :: dm16 !< mixed density at alt16 + real :: dm28 !< mixed density at alt28 + real :: dm32 !< mixed density at alt32 + real :: dm40 !< mixed density at alt40 + real :: dm01 !< mixed density at alt01 + real :: dm14 !< mixed density at alt14 ! - real :: gsurf !< surface gravitation force at given latitude - real :: re !< referenced height related to gsurf + real :: gsurf !< surface gravitation force at given latitude + real :: re !< referenced height related to gsurf ! - real :: tinfg !< startinf referenced point for tt - real :: tt(15) !< referenced temperature + real :: tinfg !< startinf referenced point for tt + real :: tt(15) !< referenced temperature ! - real :: plg(9,4) !< Legendre polynomial points - real :: ctloc !< cosine of the location - real :: stloc !< sine of the location - real :: c2tloc !< cosine of 2 time location - real :: s2tloc !< sine of 2 time location - real :: c3tloc !< cosine of 3 time location - real :: s3tloc !< sine of 3 time location - real :: day !< day in a year - real :: df !< the difference of f10.7 effect - real :: dfa !< the difference to reference value - real :: apd !< parameter calcumate for magnetic activity - real :: apdf !< the same as apd - real :: apt(4) !< daily magnetic activity - real :: xlong !< a given longitude + real :: plg(9,4) !< Legendre polynomial points + real :: ctloc !< cosine of the location + real :: stloc !< sine of the location + real :: c2tloc !< cosine of 2 time location + real :: s2tloc !< sine of 2 time location + real :: c3tloc !< cosine of 3 time location + real :: s3tloc !< sine of 3 time location + real :: day !< day in a year + real :: df !< the difference of f10.7 effect + real :: dfa !< the difference to reference value + real :: apd !< parameter calcumate for magnetic activity + real :: apdf !< the same as apd + real :: apt(4) !< daily magnetic activity + real :: xlong !< a given longitude ! - integer :: isw !< indix for sw - integer :: iyr !< integer for a given year + integer :: isw !< indix for sw + integer :: iyr !< integer for a given year ! end module gettemp_mod @@ -1265,7 +1265,6 @@ subroutine gtd7(iyd,sec,alt,glat,glong,stl,f107a,f107,ap,mass,d,t) ! **** o density **** d(2)=0 d(9)=0 - 216 continue ! ***** o2 density **** d(4)=0 if(mass.ne.32.and.mass.ne.48) goto 232 @@ -2055,7 +2054,7 @@ function globe7(yrd,sec,lat,long,tloc,f107a,f107,ap,p) 10 end do if(sw(9).gt.0) sw9=1. if(sw(9).lt.0) sw9=-1. - iyr = yrd/1000. + iyr = nint(yrd/1000.) day = yrd - iyr*1000. xlong=long ! eq. a22 (remainder of code) diff --git a/sorc/chgres_cube.fd/write_data.F90 b/sorc/chgres_cube.fd/write_data.F90 index 57b9a2983..8334ae217 100644 --- a/sorc/chgres_cube.fd/write_data.F90 +++ b/sorc/chgres_cube.fd/write_data.F90 @@ -1,5 +1,7 @@ module write_data + use utilities, only : error_handler, netcdf_err + private public :: write_fv3_atm_header_netcdf @@ -659,16 +661,16 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) call error_handler("IN FieldGather", error) if (localpet == 0) then - dum2d_top(:,:) = data_one_tile(i_start_top:i_end_top, j_start_top:j_end_top) + dum2d_top(:,:) = real(data_one_tile(i_start_top:i_end_top, j_start_top:j_end_top),kind=4) error = nf90_put_var( ncid, id_ps_top, dum2d_top) call netcdf_err(error, 'WRITING PS TOP' ) - dum2d_bottom(:,:) = data_one_tile(i_start_bottom:i_end_bottom, j_start_bottom:j_end_bottom) + dum2d_bottom(:,:) = real(data_one_tile(i_start_bottom:i_end_bottom, j_start_bottom:j_end_bottom),kind=4) error = nf90_put_var( ncid, id_ps_bottom, dum2d_bottom) call netcdf_err(error, 'WRITING PS BOTTOM' ) - dum2d_left(:,:) = data_one_tile(i_start_left:i_end_left, j_start_left:j_end_left) + dum2d_left(:,:) = real(data_one_tile(i_start_left:i_end_left, j_start_left:j_end_left),kind=4) error = nf90_put_var( ncid, id_ps_left, dum2d_left) call netcdf_err(error, 'WRITING PS LEFT' ) - dum2d_right(:,:) = data_one_tile(i_start_right:i_end_right, j_start_right:j_end_right) + dum2d_right(:,:) = real(data_one_tile(i_start_right:i_end_right, j_start_right:j_end_right),kind=4) error = nf90_put_var( ncid, id_ps_right, dum2d_right) call netcdf_err(error, 'WRITING PS RIGHT' ) endif @@ -697,19 +699,19 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) call error_handler("IN FieldGather", error) if (localpet == 0) then - dum3d_top(:,:,:) = data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:) + dum3d_top(:,:,:) = real(data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:),kind=4) dum3d_top(:,:,1:levp1_target) = dum3d_top(:,:,levp1_target:1:-1) error = nf90_put_var( ncid, id_zh_top, dum3d_top) call netcdf_err(error, 'WRITING ZH TOP' ) - dum3d_bottom(:,:,:) = data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:) + dum3d_bottom(:,:,:) = real(data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:),kind=4) dum3d_bottom(:,:,1:levp1_target) = dum3d_bottom(:,:,levp1_target:1:-1) error = nf90_put_var( ncid, id_zh_bottom, dum3d_bottom) call netcdf_err(error, 'WRITING ZH BOTTOM' ) - dum3d_left(:,:,:) = data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:) + dum3d_left(:,:,:) = real(data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:),kind=4) dum3d_left(:,:,1:levp1_target) = dum3d_left(:,:,levp1_target:1:-1) error = nf90_put_var( ncid, id_zh_left, dum3d_left) call netcdf_err(error, 'WRITING ZH LEFT' ) - dum3d_right(:,:,:) = data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:) + dum3d_right(:,:,:) = real(data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:),kind=4) dum3d_right(:,:,1:levp1_target) = dum3d_right(:,:,levp1_target:1:-1) error = nf90_put_var( ncid, id_zh_right, dum3d_right) call netcdf_err(error, 'WRITING ZH RIGHT' ) @@ -741,19 +743,19 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) call error_handler("IN FieldGather", error) if (localpet == 0) then - dum3d_top(:,:,:) = data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:) + dum3d_top(:,:,:) = real(data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:),kind=4) dum3d_top(:,:,1:lev_target) = dum3d_top(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_tracer_top(n), dum3d_top) call netcdf_err(error, 'WRITING TRACER TOP' ) - dum3d_bottom(:,:,:) = data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:) + dum3d_bottom(:,:,:) = real(data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:),kind=4) dum3d_bottom(:,:,1:lev_target) = dum3d_bottom(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_tracer_bottom(n), dum3d_bottom) call netcdf_err(error, 'WRITING TRACER BOTTOM' ) - dum3d_left(:,:,:) = data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:) + dum3d_left(:,:,:) = real(data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:),kind=4) dum3d_left(:,:,1:lev_target) = dum3d_left(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_tracer_left(n), dum3d_left) call netcdf_err(error, 'WRITING TRACER LEFT' ) - dum3d_right(:,:,:) = data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:) + dum3d_right(:,:,:) = real(data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:),kind=4) dum3d_right(:,:,1:lev_target) = dum3d_right(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_tracer_right(n), dum3d_right) call netcdf_err(error, 'WRITING TRACER RIGHT' ) @@ -769,19 +771,19 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) call error_handler("IN FieldGather", error) if (localpet == 0) then - dum3d_top(:,:,:) = data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:) + dum3d_top(:,:,:) = real(data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:),kind=4) dum3d_top(:,:,1:lev_target) = dum3d_top(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_w_top, dum3d_top) call netcdf_err(error, 'WRITING W TOP' ) - dum3d_bottom(:,:,:) = data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:) + dum3d_bottom(:,:,:) = real(data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:),kind=4) dum3d_bottom(:,:,1:lev_target) = dum3d_bottom(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_w_bottom, dum3d_bottom) call netcdf_err(error, 'WRITING W BOTTOM' ) - dum3d_left(:,:,:) = data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:) + dum3d_left(:,:,:) = real(data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:),kind=4) dum3d_left(:,:,1:lev_target) = dum3d_left(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_w_left, dum3d_left) call netcdf_err(error, 'WRITING W LEFT' ) - dum3d_right(:,:,:) = data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:) + dum3d_right(:,:,:) = real(data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:),kind=4) dum3d_right(:,:,1:lev_target) = dum3d_right(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_w_right, dum3d_right) call netcdf_err(error, 'WRITING W RIGHT' ) @@ -795,19 +797,19 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) call error_handler("IN FieldGather", error) if (localpet == 0) then - dum3d_top(:,:,:) = data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:) + dum3d_top(:,:,:) = real(data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:),kind=4) dum3d_top(:,:,1:lev_target) = dum3d_top(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_t_top, dum3d_top) call netcdf_err(error, 'WRITING T TOP' ) - dum3d_bottom(:,:,:) = data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:) + dum3d_bottom(:,:,:) = real(data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:),kind=4) dum3d_bottom(:,:,1:lev_target) = dum3d_bottom(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_t_bottom, dum3d_bottom) call netcdf_err(error, 'WRITING T BOTTOM' ) - dum3d_left(:,:,:) = data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:) + dum3d_left(:,:,:) = real(data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:),kind=4) dum3d_left(:,:,1:lev_target) = dum3d_left(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_t_left, dum3d_left) call netcdf_err(error, 'WRITING T LEFT' ) - dum3d_right(:,:,:) = data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:) + dum3d_right(:,:,:) = real(data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:),kind=4) dum3d_right(:,:,1:lev_target) = dum3d_right(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_t_right, dum3d_right) call netcdf_err(error, 'WRITING T RIGHT' ) @@ -821,19 +823,19 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) call error_handler("IN FieldGather", error) if (localpet == 0) then - dum3d_top(:,:,:) = data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:) + dum3d_top(:,:,:) = real(data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:),kind=4) dum3d_top(:,:,1:lev_target) = dum3d_top(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_qnifa_top, dum3d_top) call netcdf_err(error, 'WRITING QNIFA CLIMO TOP' ) - dum3d_bottom(:,:,:) = data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:) + dum3d_bottom(:,:,:) = real(data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:),kind=4) dum3d_bottom(:,:,1:lev_target) = dum3d_bottom(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_qnifa_bottom, dum3d_bottom) call netcdf_err(error, 'WRITING QNIFA CLIMO BOTTOM' ) - dum3d_left(:,:,:) = data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:) + dum3d_left(:,:,:) = real(data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:),kind=4) dum3d_left(:,:,1:lev_target) = dum3d_left(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_qnifa_left, dum3d_left) call netcdf_err(error, 'WRITING QNIFA CLIMO LEFT' ) - dum3d_right(:,:,:) = data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:) + dum3d_right(:,:,:) = real(data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:),kind=4) dum3d_right(:,:,1:lev_target) = dum3d_right(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_qnifa_right, dum3d_right) call netcdf_err(error, 'WRITING QNIFA CLIMO RIGHT' ) @@ -845,19 +847,19 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) call error_handler("IN FieldGather", error) if (localpet == 0) then - dum3d_top(:,:,:) = data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:) + dum3d_top(:,:,:) = real(data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:),kind=4) dum3d_top(:,:,1:lev_target) = dum3d_top(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_qnwfa_top, dum3d_top) call netcdf_err(error, 'WRITING QNWFA CLIMO TOP' ) - dum3d_bottom(:,:,:) = data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:) + dum3d_bottom(:,:,:) = real(data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:),kind=4) dum3d_bottom(:,:,1:lev_target) = dum3d_bottom(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_qnwfa_bottom, dum3d_bottom) call netcdf_err(error, 'WRITING QNWFA CLIMO BOTTOM' ) - dum3d_left(:,:,:) = data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:) + dum3d_left(:,:,:) = real(data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:),kind=4) dum3d_left(:,:,1:lev_target) = dum3d_left(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_qnwfa_left, dum3d_left) call netcdf_err(error, 'WRITING QNWFA CLIMO LEFT' ) - dum3d_right(:,:,:) = data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:) + dum3d_right(:,:,:) = real(data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:),kind=4) dum3d_right(:,:,1:lev_target) = dum3d_right(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_qnwfa_right, dum3d_right) call netcdf_err(error, 'WRITING QNWFA CLIMO RIGHT' ) @@ -977,19 +979,19 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) call error_handler("IN FieldGather", error) if (localpet == 0) then - dum3d_top(:,:,:) = data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:) + dum3d_top(:,:,:) = real(data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:),kind=4) dum3d_top(:,:,1:lev_target) = dum3d_top(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_u_s_top, dum3d_top) call netcdf_err(error, 'WRITING U_S TOP' ) - dum3d_bottom(:,:,:) = data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:) + dum3d_bottom(:,:,:) = real(data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:),kind=4) dum3d_bottom(:,:,1:lev_target) = dum3d_bottom(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_u_s_bottom, dum3d_bottom) call netcdf_err(error, 'WRITING U_S BOTTOM' ) - dum3d_left(:,:,:) = data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:) + dum3d_left(:,:,:) = real(data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:),kind=4) dum3d_left(:,:,1:lev_target) = dum3d_left(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_u_s_left, dum3d_left) call netcdf_err(error, 'WRITING U_S LEFT' ) - dum3d_right(:,:,:) = data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:) + dum3d_right(:,:,:) = real(data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:),kind=4) dum3d_right(:,:,1:lev_target) = dum3d_right(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_u_s_right, dum3d_right) call netcdf_err(error, 'WRITING U_S RIGHT' ) @@ -1003,19 +1005,19 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) call error_handler("IN FieldGather", error) if (localpet == 0) then - dum3d_top(:,:,:) = data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:) + dum3d_top(:,:,:) = real(data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:),kind=4) dum3d_top(:,:,1:lev_target) = dum3d_top(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_v_s_top, dum3d_top) call netcdf_err(error, 'WRITING V_S TOP' ) - dum3d_bottom(:,:,:) = data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:) + dum3d_bottom(:,:,:) = real(data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:),kind=4) dum3d_bottom(:,:,1:lev_target) = dum3d_bottom(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_v_s_bottom, dum3d_bottom) call netcdf_err(error, 'WRITING V_S BOTTOM' ) - dum3d_left(:,:,:) = data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:) + dum3d_left(:,:,:) = real(data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:),kind=4) dum3d_left(:,:,1:lev_target) = dum3d_left(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_v_s_left, dum3d_left) call netcdf_err(error, 'WRITING V_S LEFT' ) - dum3d_right(:,:,:) = data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:) + dum3d_right(:,:,:) = real(data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:),kind=4) dum3d_right(:,:,1:lev_target) = dum3d_right(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_v_s_right, dum3d_right) call netcdf_err(error, 'WRITING V_S RIGHT' ) @@ -1133,19 +1135,19 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) call error_handler("IN FieldGather", error) if (localpet == 0) then - dum3d_top(:,:,:) = data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:) + dum3d_top(:,:,:) = real(data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:),kind=4) dum3d_top(:,:,1:lev_target) = dum3d_top(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_u_w_top, dum3d_top) call netcdf_err(error, 'WRITING U_W TOP' ) - dum3d_bottom(:,:,:) = data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:) + dum3d_bottom(:,:,:) = real(data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:),kind=4) dum3d_bottom(:,:,1:lev_target) = dum3d_bottom(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_u_w_bottom, dum3d_bottom) call netcdf_err(error, 'WRITING U_W BOTTOM' ) - dum3d_left(:,:,:) = data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:) + dum3d_left(:,:,:) = real(data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:),kind=4) dum3d_left(:,:,1:lev_target) = dum3d_left(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_u_w_left, dum3d_left) call netcdf_err(error, 'WRITING U_W LEFT' ) - dum3d_right(:,:,:) = data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:) + dum3d_right(:,:,:) = real(data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:),kind=4) dum3d_right(:,:,1:lev_target) = dum3d_right(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_u_w_right, dum3d_right) call netcdf_err(error, 'WRITING U_W RIGHT' ) @@ -1159,19 +1161,19 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) call error_handler("IN FieldGather", error) if (localpet == 0) then - dum3d_top(:,:,:) = data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:) + dum3d_top(:,:,:) = real(data_one_tile_3d(i_start_top:i_end_top,j_start_top:j_end_top,:),kind=4) dum3d_top(:,:,1:lev_target) = dum3d_top(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_v_w_top, dum3d_top) call netcdf_err(error, 'WRITING V_W TOP' ) - dum3d_bottom(:,:,:) = data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:) + dum3d_bottom(:,:,:) = real(data_one_tile_3d(i_start_bottom:i_end_bottom,j_start_bottom:j_end_bottom,:),kind=4) dum3d_bottom(:,:,1:lev_target) = dum3d_bottom(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_v_w_bottom, dum3d_bottom) call netcdf_err(error, 'WRITING V_W BOTTOM' ) - dum3d_left(:,:,:) = data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:) + dum3d_left(:,:,:) = real(data_one_tile_3d(i_start_left:i_end_left,j_start_left:j_end_left,:),kind=4) dum3d_left(:,:,1:lev_target) = dum3d_left(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_v_w_left, dum3d_left) call netcdf_err(error, 'WRITING V_W LEFT' ) - dum3d_right(:,:,:) = data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:) + dum3d_right(:,:,:) = real(data_one_tile_3d(i_start_right:i_end_right,j_start_right:j_end_right,:),kind=4) dum3d_right(:,:,1:lev_target) = dum3d_right(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_v_w_right, dum3d_right) call netcdf_err(error, 'WRITING V_W RIGHT' ) @@ -1445,7 +1447,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum2d(:,:) = data_one_tile(i_start:i_end, j_start:j_end) + dum2d(:,:) = real(data_one_tile(i_start:i_end, j_start:j_end),kind=4) error = nf90_put_var( ncid, id_lon, dum2d) call netcdf_err(error, 'WRITING LONGITUDE RECORD' ) endif @@ -1460,7 +1462,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum2d(:,:) = data_one_tile(i_start:i_end, j_start:j_end) + dum2d(:,:) = real(data_one_tile(i_start:i_end, j_start:j_end),kind=4) error = nf90_put_var( ncid, id_lat, dum2d) call netcdf_err(error, 'WRITING LATITUDE RECORD' ) endif @@ -1475,7 +1477,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum2d(:,:) = data_one_tile(i_start:i_end, j_start:j_end) + dum2d(:,:) = real(data_one_tile(i_start:i_end, j_start:j_end),kind=4) error = nf90_put_var( ncid, id_ps, dum2d) call netcdf_err(error, 'WRITING SURFACE PRESSURE RECORD' ) endif @@ -1500,7 +1502,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum3d(:,:,:) = data_one_tile_3d(i_start:i_end,j_start:j_end,:) + dum3d(:,:,:) = real(data_one_tile_3d(i_start:i_end,j_start:j_end,:),kind=4) dum3d(:,:,1:levp1_target) = dum3d(:,:,levp1_target:1:-1) error = nf90_put_var( ncid, id_zh, dum3d) call netcdf_err(error, 'WRITING HEIGHT RECORD' ) @@ -1526,7 +1528,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum3d(:,:,:) = data_one_tile_3d(i_start:i_end,j_start:j_end,:) + dum3d(:,:,:) = real(data_one_tile_3d(i_start:i_end,j_start:j_end,:),kind=4) dum3d(:,:,1:lev_target) = dum3d(:,:,lev_target:1:-1) print*,"MIN MAX W AT WRITE = ", minval(dum3d(:,:,:)), maxval(dum3d(:,:,:)) error = nf90_put_var( ncid, id_w, dum3d) @@ -1543,7 +1545,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum3d(:,:,:) = data_one_tile_3d(i_start:i_end,j_start:j_end,:) + dum3d(:,:,:) = real(data_one_tile_3d(i_start:i_end,j_start:j_end,:),kind=4) dum3d(:,:,1:lev_target) = dum3d(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_delp, dum3d) call netcdf_err(error, 'WRITING DELP RECORD' ) @@ -1559,7 +1561,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum3d(:,:,:) = data_one_tile_3d(i_start:i_end,j_start:j_end,:) + dum3d(:,:,:) = real(data_one_tile_3d(i_start:i_end,j_start:j_end,:),kind=4) dum3d(:,:,1:lev_target) = dum3d(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_t, dum3d) call netcdf_err(error, 'WRITING TEMPERTAURE RECORD' ) @@ -1577,7 +1579,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum3d(:,:,:) = data_one_tile_3d(i_start:i_end,j_start:j_end,:) + dum3d(:,:,:) = real(data_one_tile_3d(i_start:i_end,j_start:j_end,:),kind=4) dum3d(:,:,1:lev_target) = dum3d(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_tracers(n), dum3d) call netcdf_err(error, 'WRITING TRACER RECORD' ) @@ -1596,7 +1598,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum3d(:,:,:) = data_one_tile_3d(i_start:i_end,j_start:j_end,:) + dum3d(:,:,:) = real(data_one_tile_3d(i_start:i_end,j_start:j_end,:),kind=4) dum3d(:,:,1:lev_target) = dum3d(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_qnifa, dum3d) call netcdf_err(error, 'WRITING QNIFA RECORD' ) @@ -1612,7 +1614,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum3d(:,:,:) = data_one_tile_3d(i_start:i_end,j_start:j_end,:) + dum3d(:,:,:) = real(data_one_tile_3d(i_start:i_end,j_start:j_end,:),kind=4) dum3d(:,:,1:lev_target) = dum3d(:,:,lev_target:1:-1) error = nf90_put_var( ncid, id_qnwfa, dum3d) call netcdf_err(error, 'WRITING QNWFA RECORD' ) @@ -1639,7 +1641,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum2d(:,:) = data_one_tile(i_start:i_end,j_start:jp1_end) + dum2d(:,:) = real(data_one_tile(i_start:i_end,j_start:jp1_end),kind=4) error = nf90_put_var( ncid, id_lon_s, dum2d) call netcdf_err(error, 'WRITING LON_S RECORD' ) endif @@ -1652,7 +1654,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum2d(:,:) = data_one_tile(i_start:i_end,j_start:jp1_end) + dum2d(:,:) = real(data_one_tile(i_start:i_end,j_start:jp1_end),kind=4) error = nf90_put_var( ncid, id_lat_s, dum2d) call netcdf_err(error, 'WRITING LAT_S RECORD' ) endif @@ -1677,7 +1679,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum3d(:,:,:) = data_one_tile_3d(i_start:i_end,j_start:jp1_end,:) + dum3d(:,:,:) = real(data_one_tile_3d(i_start:i_end,j_start:jp1_end,:),kind=4) dum3d(:,:,1:lev_target) = dum3d(:,:,lev_target:1:-1) print*,"MIN MAX US AT WRITE = ", minval(dum3d(:,:,:)), maxval(dum3d(:,:,:)) error = nf90_put_var( ncid, id_u_s, dum3d) @@ -1694,7 +1696,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum3d(:,:,:) = data_one_tile_3d(i_start:i_end,j_start:jp1_end,:) + dum3d(:,:,:) = real(data_one_tile_3d(i_start:i_end,j_start:jp1_end,:),kind=4) dum3d(:,:,1:lev_target) = dum3d(:,:,lev_target:1:-1) print*,"MIN MAX VS AT WRITE = ", minval(dum3d(:,:,:)), maxval(dum3d(:,:,:)) error = nf90_put_var( ncid, id_v_s, dum3d) @@ -1721,7 +1723,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum2d(:,:) = data_one_tile(i_start:ip1_end,j_start:j_end) + dum2d(:,:) = real(data_one_tile(i_start:ip1_end,j_start:j_end),kind=4) error = nf90_put_var( ncid, id_lon_w, dum2d) call netcdf_err(error, 'WRITING LON_W RECORD' ) endif @@ -1734,7 +1736,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum2d(:,:) = data_one_tile(i_start:ip1_end,j_start:j_end) + dum2d(:,:) = real(data_one_tile(i_start:ip1_end,j_start:j_end),kind=4) error = nf90_put_var( ncid, id_lat_w, dum2d) call netcdf_err(error, 'WRITING LAT_W RECORD' ) endif @@ -1759,7 +1761,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum3d(:,:,:) = data_one_tile_3d(i_start:ip1_end,j_start:j_end,:) + dum3d(:,:,:) = real(data_one_tile_3d(i_start:ip1_end,j_start:j_end,:),kind=4) dum3d(:,:,1:lev_target) = dum3d(:,:,lev_target:1:-1) print*,"MIN MAX UW AT WRITE = ", minval(dum3d(:,:,:)), maxval(dum3d(:,:,:)) error = nf90_put_var( ncid, id_u_w, dum3d) @@ -1776,7 +1778,7 @@ subroutine write_fv3_atm_data_netcdf(localpet) enddo if (localpet < num_tiles_target_grid) then - dum3d(:,:,:) = data_one_tile_3d(i_start:ip1_end,j_start:j_end,:) + dum3d(:,:,:) = real(data_one_tile_3d(i_start:ip1_end,j_start:j_end,:),kind=4) dum3d(:,:,1:lev_target) = dum3d(:,:,lev_target:1:-1) print*,"MIN MAX VW AT WRITE = ", minval(dum3d(:,:,:)), maxval(dum3d(:,:,:)) error = nf90_put_var( ncid, id_v_w, dum3d) @@ -1916,17 +1918,17 @@ subroutine write_fv3_sfc_data_netcdf(localpet) allocate(lsoil_data(lsoil_target)) do i = 1, lsoil_target - lsoil_data(i) = float(i) + lsoil_data(i) = real(float(i),kind=4) enddo allocate(x_data(i_target_out)) do i = 1, i_target_out - x_data(i) = float(i) + x_data(i) = real(float(i),kind=4) enddo allocate(y_data(j_target_out)) do i = 1, j_target_out - y_data(i) = float(i) + y_data(i) = real(float(i),kind=4) enddo if (convert_nst) then diff --git a/sorc/fre-nctools.fd/shared_lib/mpp_io.c b/sorc/fre-nctools.fd/shared_lib/mpp_io.c index a226343d7..02ab0e88f 100644 --- a/sorc/fre-nctools.fd/shared_lib/mpp_io.c +++ b/sorc/fre-nctools.fd/shared_lib/mpp_io.c @@ -65,8 +65,41 @@ int mpp_open(const char *file, int action) { char curfile[STRING]; char errmsg[512]; int ncid, status, istat, n, fid; -/* size_t blksz=65536; */ - size_t blksz=1048576; + static int first_call = 1; + static size_t blksz=1048576; + + /* read the blksz from environment variable for the first_call */ + if(first_call) { + char *blkstr; + int len; + first_call = 0; + blkstr=getenv ("NC_BLKSZ"); + if(blkstr) { + len=strlen(blkstr); + /* check to make sure each character is either number of 'K' or 'M' */ + for(n=0; n '9' || blkstr[n] < '0') && blkstr[n] != 'K' && blkstr[n] != 'M' ) { + sprintf( errmsg, "mpp_io(mpp_open): the last charactor of environment variable NC_BLKSZ = %s " + "should be digit, 'K' or 'M'", blkstr); + mpp_error(errmsg); + } + } + else if( blkstr[n] > '9' || blkstr[n] < '0' ) { + sprintf( errmsg, "mpp_io(mpp_open): environment variable NC_BLKSZ = %s " + "should only contain digit except the last character", blkstr); + printf("error 2 = %s\n", errmsg); + mpp_error(errmsg); + } + } + blksz = atoi(blkstr); + if( blkstr[len-1] == 'K' ) + blksz *= 1024; + else if( blkstr[len-1] == 'M' ) + blksz *= (1024*1024); + } + + } /* write only from root pe. */ if(action != MPP_READ && mpp_pe() != mpp_root_pe() ) return -1; @@ -209,7 +242,35 @@ void mpp_get_varname(int fid, int varid, char *name) } } + +int mpp_get_record_name(int fid, char *name) +{ + int dimid, status; + char errmsg[512]; + int record_exist; + if(fid<0 || fid >=nfiles) mpp_error("mpp_io(mpp_get_record_name): invalid id number, id should be " + "a nonnegative integer that less than nfiles"); + status = nc_inq_unlimdim(files[fid].ncid, &dimid); + if(status != NC_NOERR) { + sprintf(errmsg, "mpp_io(mpp_get_record_name): error in get record id from file %s", files[fid].name); + netcdf_error(errmsg, status); + } + if(dimid >=0) { + record_exist = 1; + status = nc_inq_dimname(files[fid].ncid, dimid, name); + if(status != NC_NOERR) { + sprintf(errmsg, "mpp_io(mpp_get_record_name): error in get record name from file %s", files[fid].name); + netcdf_error(errmsg, status); + } + } + else { + record_exist = 0; + } + return record_exist; +} + + /*******************************************************************************/ /* */ /* The following are routines that retrieve information */ @@ -665,12 +726,13 @@ char mpp_get_var_cart(int fid, int vid) fldid = files[fid].var[vid].fldid; status = nc_get_att_text(ncid, fldid, "cartesian_axis", &cart); if(status != NC_NOERR)status = nc_get_att_text(ncid, fldid, "axis", &cart); + /* if(status != NC_NOERR){ sprintf(errmsg, "mpp_io(mpp_get_var_cart): Error in getting attribute cartesian_axis/axis of " "dimension variable %s from file %s", files[fid].var[vid].name, files[fid].name ); netcdf_error(errmsg, status); } - + */ return cart; } @@ -937,6 +999,63 @@ void mpp_def_var_att_double(int fid, int vid, const char *attname, double attval +/********************************************************************** + * void mpp_set_deflation(fid_in, fid_out, deflation, shuffle) * + * Sets netcdf4 deflation on the output file. If NetCDF3, exits. * + * If user requests deflation and shuffle settings, applies those * + * settings. If user doesn't specify (set to -1), the settings * + * of the input file are applied * + * ********************************************************************/ +void mpp_set_deflation(int fid_in, int fid_out, int deflation, int shuffle) { + // return if deflation set to zero + if (deflation == 0) { + printf("Not compressing due to option\n"); + return; + } + + // return if netcdf3 + int format; + char errmsg[512]; + int status; + status = nc_inq_format(files[fid_in].ncid, &format); + if (status != NC_NOERR) { + sprintf(errmsg, "mpp_io(mpp_set_deflation): Error in getting determining netcdf version"); + netcdf_error(errmsg, status); + } + printf("Input: filename=%s, nvar=%i, format=%i\n", files[fid_in].name, files[fid_in].nvar, format); + if (format == NC_FORMAT_CLASSIC || format == NC_FORMAT_64BIT) { + printf("Not compressing because input file is NetCDF3\n"); + return; + } + + int v, shuffle2, deflate2, deflation2; + + // loop thru vars + for (v = 0; v < files[fid_in].nvar; ++v) { + // get existing compression settings + status = nc_inq_var_deflate(files[fid_in].ncid, files[fid_in].var[v].fldid, &shuffle2, &deflate2, &deflation2); + if (status != NC_NOERR) { + sprintf(errmsg, "mpp_io(mpp_set_deflation): Error in getting deflation level"); + netcdf_error(errmsg, status); + } + printf("Input: var=%s, shuffle=%i, deflate=%i, deflation=%i\n", files[fid_in].var[v].name, shuffle2, deflate2, deflation2); + + // apply overrides + if (deflation == -1) + deflation = deflation2; + if (shuffle == -1) + shuffle = shuffle2; + + // set compression level + status = nc_def_var_deflate(files[fid_out].ncid, files[fid_out].var[v].fldid, shuffle, deflation, deflation); + if (status != NC_NOERR) { + sprintf(errmsg, "mpp_io(mpp_set_deflation): Error in setting deflation level"); + netcdf_error(errmsg, status); + } + printf("Output: var=%s, shuffle=%i, deflation=%i\n", files[fid_in].var[v].name, shuffle, deflation); + } +} + /********************************************************************** void mpp_copy_var_att(fid_in, fid_out) copy all the field attribute from infile to outfile @@ -981,9 +1100,55 @@ void mpp_copy_var_att(int fid_in, int vid_in, int fid_out, int vid_out) } } -}; /* mpp_copy_field_att */ +} /* mpp_copy_field_att */ +/********************************************************************** + void mpp_copy_var(fid_in, vid_in, fid_out) + copy one field from fid_in to fid_out +**********************************************************************/ +void mpp_copy_data(int fid_in, int vid_in, int fid_out, int vid_out) +{ + int status; + int ndim, dims[5], i; + size_t dsize, size; + char errmsg[512]; + double *data=NULL; + if( mpp_pe() != mpp_root_pe() ) return; + + if(fid_in<0 || fid_in >=nfiles) mpp_error("mpp_io(mpp_copy_var): invalid fid_in number, fid should be " + "a nonnegative integer that less than nfiles"); + if(fid_out<0 || fid_out >=nfiles) mpp_error("mpp_io(mpp_copy_var): invalid fid_out number, fid should be " + "a nonnegative integer that less than nfiles"); + /* + ncid_in = files[fid_in].ncid; + ncid_out = files[fid_out].ncid; + fldid_in = files[fid_in].var[vid_in].fldid; + fldid_out = files[fid_out].var[vid_out].fldid; + */ + ndim = mpp_get_var_ndim(fid_in, vid_in); + status = nc_inq_vardimid(files[fid_in].ncid, files[fid_in].var[vid_in].fldid,dims); + if(status != NC_NOERR) { + sprintf(errmsg, "mpp_io(mpp_copy_data): Error in getting dimid of var %s from file %s", + files[fid_in].var[vid_in].name, files[vid_in].name ); + netcdf_error(errmsg, status); + } + dsize = 1; + for(i=0; ixt[n2]; v2[1] = grid_out->yt[n2]; - v2[2] = grid_out->zt[n2]; + v2[2] = grid_out->zt[n2]; distance=normalize_great_circle_distance(v1, v2); if (distance < shortest[l]) { shortest[l]=distance; @@ -169,7 +170,7 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles } } /*------------------------------------------------ - determine lower left corner + determine lower left corner ------------------------------------------------*/ found[n0] = get_closest_index(&(grid_in[l]), grid_out, &(interp->index[3*(j*nx_out+i)]), index[3*l], index[3*l+1], index[3*l+2], i, j); @@ -188,10 +189,10 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles if (all_done) break; } } - + /*------------------------------------------------------------------ - double check if lower left corner was found - calculate weights for interpolation + double check if lower left corner was found + calculate weights for interpolation ------------------------------------------------------------------*/ for(j=0; jindex[m0]; jc=interp->index[m0+1]; l =interp->index[m0+2]; if (ic==nx_in && jc==ny_in) { /*------------------------------------------------------------ - calculate weights for bilinear interpolation near corner + calculate weights for bilinear interpolation near corner ------------------------------------------------------------*/ n1 = jc*nxd+ic; n2 = jc*nxd+ic+1; @@ -266,7 +267,7 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles v3[2] = grid_in[l].zt[n3]; v0[0] = grid_out->xt[n0]; v0[1] = grid_out->yt[n0]; - v0[2] = grid_out->zt[n0]; + v0[2] = grid_out->zt[n0]; dist1=dist2side(v2, v3, v0); dist2=dist2side(v2, v1, v0); dist3=dist2side(v1, v3, v0); @@ -274,7 +275,7 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles interp->weight[m1+1]=dist2; /* ic, jc+1 weight */ interp->weight[m1+2]=0.; /* ic+1, jc+1 weight */ interp->weight[m1+3]=dist3; /* ic+1, jc weight */ - + sum=interp->weight[m1]+interp->weight[m1+1]+interp->weight[m1+3]; interp->weight[m1] /=sum; interp->weight[m1+1]/=sum; @@ -282,9 +283,9 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles } else if (ic==0 && jc==ny_in) { /*------------------------------------------------------------ - calculate weights for bilinear interpolation near corner + calculate weights for bilinear interpolation near corner ------------------------------------------------------------*/ - + n1 = jc*nxd+ic; n2 = jc*nxd+ic+1; n3 = (jc+1)*nxd+ic+1; @@ -299,15 +300,15 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles v3[2] = grid_in[l].zt[n3]; v0[0] = grid_out->xt[n0]; v0[1] = grid_out->yt[n0]; - v0[2] = grid_out->zt[n0]; + v0[2] = grid_out->zt[n0]; dist1=dist2side(v3, v2, v0); dist2=dist2side(v2, v1, v0); - dist3=dist2side(v3, v1, v0); + dist3=dist2side(v3, v1, v0); interp->weight[m1] =dist1; /* ic, jc weight */ interp->weight[m1+1]=0.; /* ic, jc+1 weight */ interp->weight[m1+2]=dist2; /* ic+1, jc+1 weight */ interp->weight[m1+3]=dist3; /* ic+1, jc weight */ - + sum=interp->weight[m1]+interp->weight[m1+2]+interp->weight[m1+3]; interp->weight[m1] /=sum; interp->weight[m1+2]/=sum; @@ -315,7 +316,7 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles } else if (jc==0 && ic==nx_in) { /*------------------------------------------------------------ - calculate weights for bilinear interpolation near corner + calculate weights for bilinear interpolation near corner ------------------------------------------------------------*/ n1 = jc*nxd+ic; n2 = (jc+1)*nxd+ic; @@ -331,16 +332,16 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles v3[2] = grid_in[l].zt[n3]; v0[0] = grid_out->xt[n0]; v0[1] = grid_out->yt[n0]; - v0[2] = grid_out->zt[n0]; + v0[2] = grid_out->zt[n0]; dist1=dist2side(v2, v3, v0); dist2=dist2side(v1, v3, v0); - dist3=dist2side(v1, v2, v0); - + dist3=dist2side(v1, v2, v0); + interp->weight[m1] =dist1; /* ic, jc weight */ interp->weight[m1+1]=dist2; /* ic, jc+1 weight */ interp->weight[m1+2]=dist3; /* ic+1, jc+1 weight */ interp->weight[m1+3]=0.; /* ic+1, jc weight */ - + sum=interp->weight[m1]+interp->weight[m1+1]+interp->weight[m1+2]; interp->weight[m1] /=sum; interp->weight[m1+1]/=sum; @@ -348,7 +349,7 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles } else { /*------------------------------------------------------------ - calculate weights for bilinear interpolation if no corner + calculate weights for bilinear interpolation if no corner ------------------------------------------------------------*/ n1 = jc*nxd+ic; n2 = jc*nxd+ic+1; @@ -365,20 +366,20 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles v3[2] = grid_in[l].zt[n3]; v4[0] = grid_in[l].xt[n4]; v4[1] = grid_in[l].yt[n4]; - v4[2] = grid_in[l].zt[n4]; + v4[2] = grid_in[l].zt[n4]; v0[0] = grid_out->xt[n0]; v0[1] = grid_out->yt[n0]; - v0[2] = grid_out->zt[n0]; + v0[2] = grid_out->zt[n0]; dist1=dist2side(v1, v3, v0); dist2=dist2side(v3, v4, v0); dist3=dist2side(v4, v2, v0); dist4=dist2side(v2, v1, v0); - + interp->weight[m1] =dist2*dist3; /* ic, jc weight */ interp->weight[m1+1]=dist3*dist4; /* ic, jc+1 weight */ interp->weight[m1+2]=dist4*dist1; /* ic+1, jc+1 weight */ interp->weight[m1+3]=dist1*dist2; /* ic+1, jc weight */ - + sum=interp->weight[m1]+interp->weight[m1+1]+interp->weight[m1+2]+interp->weight[m1+3]; interp->weight[m1] /=sum; interp->weight[m1+1]/=sum; @@ -391,13 +392,13 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles if( opcode & WRITE ) { int fid, dim_three, dim_four, dim_nlon, dim_nlat, dims[3]; int fld_index, fld_weight; - + fid = mpp_open( interp->remap_file, MPP_WRITE); dim_nlon = mpp_def_dim(fid, "nlon", nx_out); dim_nlat = mpp_def_dim(fid, "nlat", ny_out); dim_three = mpp_def_dim(fid, "three", 3); dim_four = mpp_def_dim(fid, "four", 4); - + dims[0] = dim_three; dims[1] = dim_nlat; dims[2] = dim_nlon; fld_index = mpp_def_var(fid, "index", NC_INT, 3, dims, 0); dims[0] = dim_four; dims[1] = dim_nlat; dims[2] = dim_nlon; @@ -412,7 +413,7 @@ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles free(found); free(shortest); free(index); - + printf("\n done calculating interp_index and interp_weight\n"); }; /* setup_bilinear_interp */ @@ -428,35 +429,35 @@ void do_scalar_bilinear_interp(const Interp_config *interp, int vid, int ntiles_ int has_missing; double missing; double *data_fine; - + /*------------------------------------------------------------------ - determine target grid resolution + determine target grid resolution ------------------------------------------------------------------*/ nx_out = grid_out->nx_fine; ny_out = grid_out->ny_fine; nx_in = grid_in->nx; ny_in = grid_in->ny; /* currently we are regridding one vertical level for each call to reduce the memory usage */ - nz = 1; + nz = 1; missing = field_in[0].var[vid].missing; has_missing = field_in[0].var[vid].has_missing; data_fine = (double *)malloc(nx_out*ny_out*nz*sizeof(double)); - + do_c2l_interp(interp, nx_in, ny_in, nz, field_in, nx_out, ny_out, data_fine, has_missing, missing, fill_missing); do_latlon_coarsening(data_fine, grid_out->latt1D_fine, nx_out, ny_out, nz, field_out->data, finer_step, has_missing, missing); free(data_fine); - + }; /* do_c2l_scalar_interp */ - + /*---------------------------------------------------------------------------- void do_vector_bilinear_interp() interpolate vector data to latlon, ! --------------------------------------------------------------------------*/ -void do_vector_bilinear_interp(Interp_config *interp, int vid, int ntiles_in, const Grid_config *grid_in, int ntiles_out, +void do_vector_bilinear_interp(Interp_config *interp, int vid, int ntiles_in, const Grid_config *grid_in, int ntiles_out, const Grid_config *grid_out, const Field_config *u_in, const Field_config *v_in, Field_config *u_out, Field_config *v_out, int finer_step, int fill_missing) { @@ -465,7 +466,7 @@ void do_vector_bilinear_interp(Interp_config *interp, int vid, int ntiles_in, co int i, j, k, n, n1, n2, ts, tn, tw, te; double missing; double *x_latlon, *y_latlon, *z_latlon, *var_latlon; - + nx_out = grid_out->nx_fine; ny_out = grid_out->ny_fine; nx_in = grid_in->nx; @@ -473,11 +474,11 @@ void do_vector_bilinear_interp(Interp_config *interp, int vid, int ntiles_in, co nxd = nx_in + 2; nyd = ny_in + 2; /* currently we are regridding one vertical level for each call to reduce the memory usage */ - nz = 1; + nz = 1; missing = u_in[0].var[vid].missing; has_missing = u_in[0].var[vid].has_missing; - + x_latlon = (double *)malloc(nx_out*ny_out*nz*sizeof(double)); y_latlon = (double *)malloc(nx_out*ny_out*nz*sizeof(double)); z_latlon = (double *)malloc(nx_out*ny_out*nz*sizeof(double)); @@ -493,7 +494,7 @@ void do_vector_bilinear_interp(Interp_config *interp, int vid, int ntiles_in, co } } - do_c2l_interp(interp, nx_in, ny_in, nz, var_cubsph, nx_out, ny_out, x_latlon, has_missing, missing, fill_missing); + do_c2l_interp(interp, nx_in, ny_in, nz, var_cubsph, nx_out, ny_out, x_latlon, has_missing, missing, fill_missing); for(n=0; nweight[4*n1+2] + d_in[3]*interp->weight[4*n1+3]; } } - + }; /* do_c2l_interp */ - + /*------------------------------------------------------------------ void sort_index() - sort index by shortest + sort index by shortest ----------------------------------------------------------------*/ void sort_index(int ntiles, int *index, double *shortest) { @@ -606,7 +607,7 @@ void sort_index(int ntiles, int *index, double *shortest) shortest_sort = (double *)malloc(3*ntiles*sizeof(double)); index_sort = (int *)malloc( ntiles*sizeof(int )); - + for(l=0; l<3*ntiles; l++)index_sort[l] = 0; for(l=0; lnx_fine; ny_in = grid_in->nx_fine; @@ -667,9 +668,9 @@ int get_index(const Grid_config *grid_in, const Grid_config *grid_out, int *inde v3[1] = grid_in->yt[n3]; v3[2] = grid_in->zt[n3]; angle_1 = spherical_angle(v1, v2, v3); - angle_1a= spherical_angle(v1, v2, v0); + angle_1a= spherical_angle(v1, v2, v0); angle_1b= spherical_angle(v1, v3, v0); - + if (max(angle_1a,angle_1b)xt[n5]; v5[1] = grid_in->yt[n5]; - v5[2] = grid_in->zt[n5]; + v5[2] = grid_in->zt[n5]; angle_3 =spherical_angle(v1, v4, v5); angle_3a=angle_2b; angle_3b=spherical_angle(v1, v5, v0); @@ -717,7 +718,7 @@ int get_index(const Grid_config *grid_in, const Grid_config *grid_out, int *inde } } return ok; - + }; /* get_index */ @@ -736,7 +737,7 @@ int get_closest_index(const Grid_config *grid_in, const Grid_config *grid_out, i double angle_1, angle_1a, angle_1b; double angle_2, angle_2a, angle_2b; double angle_3, angle_3a, angle_3b; - double angle_4, angle_4a, angle_4b; + double angle_4, angle_4a, angle_4b; int n0, n1, n2, n3, n4, n5, n6, n7, n8; int nx_in, ny_in, nx_out, ny_out, nxd; double v0[3], v1[3], v2[3], v3[3], v4[3], v5[3], v6[3], v7[3], v8[3]; @@ -792,7 +793,7 @@ int get_closest_index(const Grid_config *grid_in, const Grid_config *grid_out, i n4 = j_in*nxd+i_in-1; v4[0] = grid_in->xt[n4]; v4[1] = grid_in->yt[n4]; - v4[2] = grid_in->zt[n4]; + v4[2] = grid_in->zt[n4]; angle_2 =spherical_angle(v1,v3,v4); angle_2a=angle_1b; angle_2b=spherical_angle(v1,v4,v0); @@ -830,7 +831,7 @@ int get_closest_index(const Grid_config *grid_in, const Grid_config *grid_out, i v5[2] = grid_in->zt[n5]; v6[0] = grid_in->xt[n6]; v6[1] = grid_in->yt[n6]; - v6[2] = grid_in->zt[n6]; + v6[2] = grid_in->zt[n6]; angle_3 =spherical_angle(v1, v5, v6); angle_3a=angle_2b; angle_3b=spherical_angle(v1, v6, v0); @@ -838,7 +839,7 @@ int get_closest_index(const Grid_config *grid_in, const Grid_config *grid_out, i n7 = (j_in-1)*nxd+i_in-1; v7[0] = grid_in->xt[n7]; v7[1] = grid_in->yt[n7]; - v7[2] = grid_in->zt[n7]; + v7[2] = grid_in->zt[n7]; angle_33 =spherical_angle(v7, v6, v5); angle_33a=spherical_angle(v7, v5, v0); angle_33b=spherical_angle(v7, v6, v0); @@ -863,7 +864,7 @@ int get_closest_index(const Grid_config *grid_in, const Grid_config *grid_out, i n8 = (j_in-1)*nxd+i_in+1; v8[0] = grid_in->xt[n8]; v8[1] = grid_in->yt[n8]; - v8[2] = grid_in->zt[n8]; + v8[2] = grid_in->zt[n8]; angle_44 =spherical_angle(v8, v2, v6); angle_44a=spherical_angle(v8, v6, v0); angle_44b=spherical_angle(v8, v2, v0); @@ -879,14 +880,14 @@ int get_closest_index(const Grid_config *grid_in, const Grid_config *grid_out, i } } return found; - + }; /* get_closest_index */ - + /*-------------------------------------------------------------------------- -calculate normalized great circle distance between v1 and v2 +calculate normalized great circle distance between v1 and v2 double normalize_great_circle_distance(v1, v2) ---------------------------------------------------------------------------*/ double normalize_great_circle_distance(const double *v1, const double *v2) @@ -894,34 +895,34 @@ double normalize_great_circle_distance(const double *v1, const double *v2) double dist; dist=(v1[0]*v2[0]+v1[1]*v2[1]+v1[2]*v2[2]) - /sqrt((v1[0]*v1[0]+v1[1]*v1[1]+v1[2]*v1[2]) + /sqrt((v1[0]*v1[0]+v1[1]*v1[1]+v1[2]*v1[2]) *(v2[0]*v2[0]+v2[1]*v2[1]+v2[2]*v2[2])); dist = sign(min(1.,fabs(dist)),dist); dist = acos(dist); return dist; - + }; /* normalize_great_circle_distance */ /*------------------------------------------------------------------ double spherical_angle(v1, v2, v3) - calculate spherical angle of a triangle formed by v1, v2 and v3 at v1 + calculate spherical angle of a triangle formed by v1, v2 and v3 at v1 ------------------------------------------------------------------*/ /* double spherical_angle(double *v1, double *v2, double *v3) */ /* { */ /* double angle; */ /* double px, py, pz, qx, qy, qz, abs_p, abs_q; */ -/* */ /* vector product between v1 and v2 */ +/* vector product between v1 and v2 */ /* px = v1[1]*v2[2] - v1[2]*v2[1]; */ /* py = v1[2]*v2[0] - v1[0]*v2[2]; */ /* pz = v1[0]*v2[1] - v1[1]*v2[0]; */ -/* */ /* vector product between v1 and v3 */ +/* vector product between v1 and v3 */ /* qx = v1[1]*v3[2] - v1[2]*v3[1]; */ /* qy = v1[2]*v3[0] - v1[0]*v3[2]; */ /* qz = v1[0]*v3[1] - v1[1]*v3[0]; */ - -/* */ /* angle between p and q */ + +/* angle between p and q */ /* abs_p=px*px+py*py+pz*pz; */ /* abs_q=qx*qx+qy*qy+qz*qz; */ /* if (abs_p*abs_q==0.) */ @@ -933,12 +934,12 @@ double normalize_great_circle_distance(const double *v1, const double *v2) /* } */ /* return angle; */ -/* };*/ /* spherical_angle */ +/* }; */ /* spherical_angle */ /*--------------------------------------------------------------------- double dist2side(v1, v2, point) - calculate shortest normalized distance on sphere - from point to straight line defined by v1 and v2 + calculate shortest normalized distance on sphere + from point to straight line defined by v1 and v2 ------------------------------------------------------------------*/ double dist2side(const double *v1, const double *v2, const double *point) { @@ -951,7 +952,7 @@ double dist2side(const double *v1, const double *v2, const double *point) };/* dist2side */ - + int max_weight_index( double *var, int nvar) { @@ -967,14 +968,14 @@ int max_weight_index( double *var, int nvar) } /*------------------------------------------------------------------------------ - void do_latlon_coarsening(var_latlon, ylat, nlon, nlat, nz, - var_latlon_crs, nlon_crs, nlat_crs, + void do_latlon_coarsening(var_latlon, ylat, nlon, nlat, nz, + var_latlon_crs, nlon_crs, nlat_crs, finer_steps, misval, varmisval) - calculate variable on coarser latlon grid - by doubling spatial resolution and preserving volume means + calculate variable on coarser latlon grid + by doubling spatial resolution and preserving volume means ---------------------------------------------------------------------------*/ -void do_latlon_coarsening(const double *var_latlon, const double *ylat, int nlon, int nlat, int nz, +void do_latlon_coarsening(const double *var_latlon, const double *ylat, int nlon, int nlat, int nz, double *var_latlon_crs, int finer_steps, int has_missing, double missvalue) { @@ -982,7 +983,7 @@ void do_latlon_coarsening(const double *var_latlon, const double *ylat, int nlon double dlat; int nlon_old, nlat_old, nlon_new, nlat_new, steps, i, j; int nlon_crs, nlat_crs; - + nlon_crs=nlon/pow(2,finer_steps); nlat_crs=(nlat-1)/pow(2,finer_steps)+1; switch (finer_steps) { @@ -1002,7 +1003,7 @@ void do_latlon_coarsening(const double *var_latlon, const double *ylat, int nlon var_latlon_old = (double *)malloc(nlon_old*nlat_old*nz*sizeof(double)); ylat_old = (double *)malloc(nlat_old*sizeof(double)); if (steps==1) { - for(i=0; i 0) { g_i_in = (int *)malloc(g_nxgrid*sizeof(int )); - g_j_in = (int *)malloc(g_nxgrid*sizeof(int )); + g_j_in = (int *)malloc(g_nxgrid*sizeof(int )); g_area = (double *)malloc(g_nxgrid*sizeof(double)); g_clon = (double *)malloc(g_nxgrid*sizeof(double)); g_clat = (double *)malloc(g_nxgrid*sizeof(double)); @@ -277,7 +277,7 @@ void setup_conserve_interp(int ntiles_in, const Grid_config *grid_in, int ntiles tmp_dj_in = interp[n].dj_in; interp[n].di_in = (double *)malloc(interp[n].nxgrid*sizeof(double)); interp[n].dj_in = (double *)malloc(interp[n].nxgrid*sizeof(double)); - for(i=0; i 0) { @@ -360,9 +360,9 @@ void setup_conserve_interp(int ntiles_in, const Grid_config *grid_in, int ntiles int fid, dim_string, dim_ncells, dim_two, dims[4]; int id_xgrid_area, id_tile1_dist; int id_tile1_cell, id_tile2_cell, id_tile1; - int *gdata_int, *ldata_int; + int *gdata_int, *ldata_int; double *gdata_dbl; - + fid = mpp_open( interp[n].remap_file, MPP_WRITE); dim_string = mpp_def_dim(fid, "string", STRING); dim_ncells = mpp_def_dim(fid, "ncells", nxgrid); @@ -393,7 +393,7 @@ void setup_conserve_interp(int ntiles_in, const Grid_config *grid_in, int ntiles for(i=0; i0)free(ldata_int); - + gdata_dbl = (double *)malloc(nxgrid*sizeof(double)); mpp_gather_field_double(interp[n].nxgrid, interp[n].area, gdata_dbl); mpp_put_var_value(fid, id_xgrid_area, gdata_dbl); - + if(opcode & CONSERVE_ORDER2) { start[1] = 0; mpp_gather_field_double(interp[n].nxgrid, interp[n].di_in, gdata_dbl); @@ -421,7 +421,7 @@ void setup_conserve_interp(int ntiles_in, const Grid_config *grid_in, int ntiles mpp_gather_field_double(interp[n].nxgrid, interp[n].dj_in, gdata_dbl); mpp_put_var_value_block(fid, id_tile1_dist, start, nwrite, gdata_dbl); } - + free(gdata_dbl); mpp_close(fid); } @@ -435,13 +435,13 @@ void setup_conserve_interp(int ntiles_in, const Grid_config *grid_in, int ntiles int nx1, ny1, max_i, max_j, i, j; double max_ratio, ratio_change; double *area2; - + /* sum over exchange grid to get the area of grid_in */ nx1 = grid_out[0].nxc; ny1 = grid_out[0].nyc; area2 = (double *)malloc(nx1*ny1*sizeof(double)); - + for(n=0; nvar[varid].interp_method; halo = 0; @@ -511,59 +513,63 @@ void do_scalar_conserve_interp(Interp_config *interp, int varid, int ntiles_in, halo = 1; monotonic = opcode & MONOTONIC; } - + area_missing = field_in->var[varid].area_missing; has_missing = field_in->var[varid].has_missing; weight_exist = grid_in[0].weight_exist; cell_measures = field_in->var[varid].cell_measures; cell_methods = field_in->var[varid].cell_methods; + target_grid = opcode & TARGET; + if( field_in->var[varid].use_volume ) target_grid = 0; missing = -MAXVAL; if(has_missing) missing = field_in->var[varid].missing; - + if( nz>1 && has_missing ) mpp_error("conserve_interp: has_missing should be false when nz > 1"); if( nz>1 && cell_measures ) mpp_error("conserve_interp: cell_measures should be false when nz > 1"); - if( nz>1 && cell_methods == CELL_METHODS_SUM ) mpp_error("conserve_interp: cell_methods should not be sum when nz > 1"); + if( nz>1 && cell_methods == CELL_METHODS_SUM ) mpp_error("conserve_interp: cell_methods should not be sum when nz > 1"); /* if( nz>1 && monotonic ) mpp_error("conserve_interp: monotonic should be false when nz > 1"); */ - + if(monotonic) monotone_data = (Monotone_config *)malloc(ntiles_in*sizeof(Monotone_config)); - + for(m=0; mvar[varid].name,tile,i1,j1,i2,j2); + mpp_error("conserve_interp: data is not missing but area is missing"); + } + area *= (field_in[tile].area[n1]/grid_in[tile].cell_area[n1]); + } field_out[m].data[n0] += (field_in[tile].data[n1]*area); out_area[n0] += area; - } - else if(cell_measures) { - if( field_in[tile].area[n1] != area_missing ){ - area *= (field_in[tile].area[n1]/grid_in[tile].cell_area[n1]); - out_area[n0] += area; - } + out_miss[n0] = 1; } } } @@ -572,7 +578,7 @@ void do_scalar_conserve_interp(Interp_config *interp, int varid, int ntiles_in, i2 = interp[m].i_out[n]; j2 = interp[m].j_out[n]; i1 = interp[m].i_in [n]; - j1 = interp[m].j_in [n]; + j1 = interp[m].j_in [n]; tile = interp[m].t_in [n]; area = interp[m].area [n]; nx1 = grid_in[tile].nx; @@ -581,15 +587,16 @@ void do_scalar_conserve_interp(Interp_config *interp, int varid, int ntiles_in, for(k=0; k monotone_data[tile].f_bar_max[n1] ) { /* z1l: Due to truncation error, we might get xdata[n] > f_bar_max[n1]. So we allow some tolerance. What is the suitable tolerance? */ @@ -686,10 +693,10 @@ void do_scalar_conserve_interp(Interp_config *interp, int varid, int ntiles_in, printf(" n = %d, n1 = %d, xdata = %f, f_bar_min=%f\n", n, n1, xdata[n], monotone_data[tile].f_bar_min[n1]); mpp_error(" xdata is less than f_bar_min "); } - } + } } } - for(n=0; nvar[varid].name,tile,i1,j1,i2,j2); + mpp_error("conserve_interp: data is not missing but area is missing"); + } area *= (field_in[tile].area[n1]/grid_in[tile].cell_area[n1]); - else if( cell_methods == CELL_METHODS_SUM ) - area /= grid_in[tile].cell_area[n1]; + } if(field_in[tile].grad_mask[n1]) { /* use zero gradient */ field_out[m].data[n0] += field_in[tile].data[n2]*area; } @@ -750,6 +761,7 @@ void do_scalar_conserve_interp(Interp_config *interp, int varid, int ntiles_in, +field_in[tile].grad_y[n1]*dj)*area; } out_area[n0] += area; + out_miss[n0] = 1; } } } @@ -771,13 +783,14 @@ void do_scalar_conserve_interp(Interp_config *interp, int varid, int ntiles_in, n0 = k*nx2*ny2 + j2*nx2+i2; n1 = k*nx1*ny1+j1*nx1+i1; n2 = k*(nx1+2)*(ny1+2)+(j1+1)*(nx1+2)+i1+1; - if( cell_measures ) + if( cell_methods == CELL_METHODS_SUM ) + area /= grid_in[tile].cell_area[n1]; + else if( cell_measures ) area *= (field_in[tile].area[n1]/grid_in[tile].cell_area[n1]); - else if( cell_methods == CELL_METHODS_SUM ) - area /= grid_in[tile].cell_area[n1]; field_out[m].data[n0] += (field_in[tile].data[n2]+field_in[tile].grad_x[n1]*di +field_in[tile].grad_y[n1]*dj)*area; - out_area[n0] += area; + out_area[n0] += area; + out_miss[n0] = 1; } } } @@ -789,32 +802,57 @@ void do_scalar_conserve_interp(Interp_config *interp, int varid, int ntiles_in, } } - if( cell_measures || ( !(opcode & TARGET) && !(cell_methods == CELL_METHODS_SUM)) ) { + if ( cell_methods == CELL_METHODS_SUM ) { for(i=0; i 0) - field_out[m].data[i] /= out_area[i]; - else - field_out[m].data[i] = missing; + if(out_area[i] == 0) { + if(out_miss[i] == 0) + for(k=0; k 0) - for(k=0; kvar[varid].name, gsum_in, gsum_out, gsum_out-gsum_in); - + } - - + + }; /* do_scalar_conserve_interp */ @@ -860,15 +898,15 @@ void do_scalar_conserve_interp(Interp_config *interp, int varid, int ntiles_in, void do_vector_conserve_interp( ) doing conservative interpolation *******************************************************************************/ -void do_vector_conserve_interp(Interp_config *interp, int varid, int ntiles_in, const Grid_config *grid_in, int ntiles_out, +void do_vector_conserve_interp(Interp_config *interp, int varid, int ntiles_in, const Grid_config *grid_in, int ntiles_out, const Grid_config *grid_out, const Field_config *u_in, const Field_config *v_in, - Field_config *u_out, Field_config *v_out, unsigned int opcode) + Field_config *u_out, Field_config *v_out, unsigned int opcode) { int nx1, ny1, nx2, ny2, i1, j1, i2, j2, tile, n, m, i; double area, missing, tmp_x, tmp_y; double *out_area; - missing = u_in->var[varid].missing; + missing = u_in->var[varid].missing; /* first rotate input data */ for(n = 0; n < ntiles_in; n++) { if(grid_in[n].rotate) { @@ -884,23 +922,23 @@ void do_vector_conserve_interp(Interp_config *interp, int varid, int ntiles_in, } } } - + for(m=0; m 0 || nscalar > 0 || nvector2 > 0) mpp_error("fregrid: when --input_file is not specified, --scalar_field, --u_field and --v_field should also not be specified"); @@ -585,6 +617,11 @@ int main(int argc, char* argv[]) else if(grid_type == BGRID) opcode |= BGRID; } + + if (shuffle < -1 || shuffle > 1) + mpp_error("fregrid: shuffle must be 0 (off) or 1 (on)"); + if (deflation < -1 || deflation > 9) + mpp_error("fregrid: deflation must be between 0 (off) and 9"); /* define history to be the history in the grid file */ strcpy(history,argv[0]); @@ -721,7 +758,7 @@ int main(int argc, char* argv[]) } if(remap_file) set_remap_file(ntiles_out, mosaic_out, remap_file, interp, &opcode, save_weight_only); - + if(!save_weight_only) { file_in = (File_config *)malloc(ntiles_in *sizeof(File_config)); file_out = (File_config *)malloc(ntiles_out*sizeof(File_config)); @@ -730,17 +767,7 @@ int main(int argc, char* argv[]) file2_in = (File_config *)malloc(ntiles_in *sizeof(File_config)); file2_out = (File_config *)malloc(ntiles_out*sizeof(File_config)); } - if(nscalar > 0) { - scalar_in = (Field_config *)malloc(ntiles_in *sizeof(Field_config)); - scalar_out = (Field_config *)malloc(ntiles_out *sizeof(Field_config)); - } - if(nvector > 0) { - u_in = (Field_config *)malloc(ntiles_in *sizeof(Field_config)); - u_out = (Field_config *)malloc(ntiles_out *sizeof(Field_config)); - v_in = (Field_config *)malloc(ntiles_in *sizeof(Field_config)); - v_out = (Field_config *)malloc(ntiles_out *sizeof(Field_config)); - } - + set_mosaic_data_file(ntiles_in, mosaic_in, dir_in, file_in, input_file[0]); set_mosaic_data_file(ntiles_out, mosaic_out, dir_out, file_out, output_file[0]); @@ -757,17 +784,22 @@ int main(int argc, char* argv[]) set_mosaic_data_file(ntiles_out, mosaic_out, dir_out, file2_out, output_file[1]); } - for(n=0; n 0) { + scalar_in = (Field_config *)malloc(ntiles_in *sizeof(Field_config)); + scalar_out = (Field_config *)malloc(ntiles_out *sizeof(Field_config)); + } + if(nvector > 0) { + mpp_error("fregrid: currently does not support vertical interpolation, contact developer"); + u_in = (Field_config *)malloc(ntiles_in *sizeof(Field_config)); + u_out = (Field_config *)malloc(ntiles_out *sizeof(Field_config)); + v_in = (Field_config *)malloc(ntiles_in *sizeof(Field_config)); + v_out = (Field_config *)malloc(ntiles_out *sizeof(Field_config)); + } + set_field_struct ( ntiles_in, scalar_in, nscalar, scalar_name_remap[0], file_in); set_field_struct ( ntiles_out, scalar_out, nscalar, scalar_name_remap[0], file_out); set_field_struct ( ntiles_in, u_in, nvector, u_name[0], file_in); @@ -796,9 +848,20 @@ int main(int argc, char* argv[]) kbegin, kend, lbegin, lend, opcode, associated_file_dir); set_weight_inf( ntiles_in, grid_in, weight_file, weight_field, file_in->has_cell_measure_att); + + //If the netcdf format was specified as an input argument, use that format. Otherwise + // use the format from the first ( tile 0) input file. + if(format != NULL) { + set_in_format(format); + }else if (in_format_0 >= 0){ + reset_in_format( in_format_0); + }else{ + printf("WARNING: fregrid could not set in_format"); + } set_output_metadata(ntiles_in, nfiles, file_in, file2_in, scalar_in, u_in, v_in, - ntiles_out, file_out, file2_out, scalar_out, u_out, v_out, grid_out, &vgrid_out, history, tagname, opcode); + ntiles_out, file_out, file2_out, scalar_out, u_out, v_out, grid_out, &vgrid_out, history, tagname, opcode, + deflation, shuffle); if(debug) print_mem_usage("After set_output_metadata"); /* when the interp_method specified through command line is CONSERVE_ORDER1, but the interp_method in the source file @@ -834,8 +897,29 @@ int main(int argc, char* argv[]) */ if(debug) time_start = clock(); - if( opcode & BILINEAR ) /* bilinear interpolation from cubic to lalon */ - setup_bilinear_interp(ntiles_in, grid_in, ntiles_out, grid_out, interp, opcode ); + if( opcode & BILINEAR ) { /* bilinear interpolation from cubic to lalon */ + double dlon_in, dlat_in; + double lonbegin_in, latbegin_in; + /* when dlon_in is 0, bilinear_interp will use the default 2*M_PI */ + if(fabs(lonend-lonbegin-360) < EPSLN10) + dlon_in = M_PI+M_PI; + else + dlon_in = (lonend-lonbegin)*D2R; + if(fabs(latend-latbegin-180) < EPSLN10) + dlat_in = M_PI; + else + dlat_in = (latend-latbegin)*D2R; + if(fabs(lonbegin) < EPSLN10) + lonbegin_in = 0.0; + else + lonbegin_in = lonbegin*D2R; + if(fabs(latbegin+90) < EPSLN10) + latbegin_in = -0.5*M_PI; + else + latbegin_in = latbegin*D2R; + + setup_bilinear_interp(ntiles_in, grid_in, ntiles_out, grid_out, interp, opcode, dlon_in, dlat_in, lonbegin_in, latbegin_in ); + } else setup_conserve_interp(ntiles_in, grid_in, ntiles_out, grid_out, interp, opcode); if(debug) { @@ -891,6 +975,7 @@ int main(int argc, char* argv[]) /* first interp scalar variable */ for(l=0; lvar[l].has_taxis && m>0) continue; + if( !scalar_in->var[l].do_regrid ) continue; level_t = m + scalar_in->var[l].lstart; /*--- to reduce memory usage, we are only do remapping for on horizontal level one time */ for(level_n =0; level_n < scalar_in->var[l].nn; level_n++) { diff --git a/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.c b/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.c index 13434216a..8167123c5 100644 --- a/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.c +++ b/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.c @@ -14,12 +14,14 @@ #include "gradient_c2l.h" #include "globals.h" #include "interp.h" +#include "create_xgrid.h" #define D2R (M_PI/180) #define R2D (180/M_PI) #define EPSLN10 (1.e-10) #define REL_COEF ( 0.9 ) #define MAX_ITER 4000 +#define MAX_NUM_VARS 5 void init_halo(double *var, int nx, int ny, int nz, int halo); void update_halo(int nx, int ny, int nz, double *data, Bound_config *bound, Data_holder *dHold); @@ -43,8 +45,8 @@ void set_mosaic_data_file(int ntiles, const char *mosaic_file, const char *dir, int i, n, len, fid, vid; size_t start[4], nread[4]; - len = strlen(filename); - if( strcmp(filename+len-3, ".nc") ==0 ) + len = strlen(filename); + if( strcmp(filename+len-3, ".nc") ==0 ) strncpy(str1, filename, len-3); else strcpy(str1, filename); @@ -55,7 +57,7 @@ void set_mosaic_data_file(int ntiles, const char *mosaic_file, const char *dir, } else strcpy(str2, str1); - + for(i=0; i<4; i++) { start[i] = 0; nread[i] = 1; } @@ -73,7 +75,7 @@ void set_mosaic_data_file(int ntiles, const char *mosaic_file, const char *dir, "length of tilename should be no greater than STRING-5"); sprintf(file[i].name, "%s.%s.nc", str2, tilename); } - else + else sprintf(file[i].name, "%s.nc", str2); } @@ -85,16 +87,16 @@ void set_mosaic_data_file(int ntiles, const char *mosaic_file, const char *dir, void set_field_struct(int ntiles, Field_config *field, int nvar, char * varname, File_config *file) { int n, i; - + if(nvar == 0) return; - + for(n=0; n0) { init_halo(grid[n].lonc, nx[n]+1, ny[n]+1, 1, halo); init_halo(grid[n].latc, nx[n]+1, ny[n]+1, 1, halo); @@ -221,18 +223,18 @@ void get_input_grid(int ntiles, Grid_config *grid, Bound_config *bound_T, const grid[n].lont[ind1] = x[ind2]*D2R; grid[n].latt[ind1] = y[ind2]*D2R; } - + init_halo(grid[n].lont, nx[n], ny[n], 1, 1); init_halo(grid[n].latt, nx[n], ny[n], 1, 1); } - + /* if vector, need to get rotation angle */ /* we assume the grid is orthogonal */ if( opcode & VECTOR ) { if( opcode & AGRID) { double *angle; angle = (double *) malloc((2*nx[n]+1)*(2*ny[n]+1)*sizeof(double)); - grid[n].cosrot = (double *) malloc(nx[n]*ny[n]*sizeof(double)); + grid[n].cosrot = (double *) malloc(nx[n]*ny[n]*sizeof(double)); grid[n].sinrot = (double *) malloc(nx[n]*ny[n]*sizeof(double)); vid = mpp_get_varid(g_fid, "angle_dx"); mpp_get_var_value(g_fid, vid, angle); @@ -271,13 +273,13 @@ void get_input_grid(int ntiles, Grid_config *grid, Bound_config *bound_T, const update_halo(nlon+2, nlat+2, 1, grid[n].lont, &(bound_T[n]), dHold ); for(l=0; lnx = nlon; grid->ny = nlat; grid->nx_fine = pow(2,finer_steps)*nlon; @@ -589,16 +591,16 @@ void get_output_grid_by_size(int ntiles, Grid_config *grid, double lonbegin, dou for(j=0; jlatt1D[j] = (latbegin+j*dlat)*D2R; for(j=0; j<=nlat; j++) grid->latc1D[j] = (latbegin+(j-0.5)*dlat)*D2R; } - + if(opcode & BILINEAR) { grid->latt1D_fine = (double *)malloc(ny_fine*sizeof(double)); grid->lont = (double *)malloc(nx_fine*ny_fine*sizeof(double)); grid->latt = (double *)malloc(nx_fine*ny_fine*sizeof(double)); grid->xt = (double *)malloc(nx_fine*ny_fine*sizeof(double)); - grid->yt = (double *)malloc(nx_fine*ny_fine*sizeof(double)); - grid->zt = (double *)malloc(nx_fine*ny_fine*sizeof(double)); + grid->yt = (double *)malloc(nx_fine*ny_fine*sizeof(double)); + grid->zt = (double *)malloc(nx_fine*ny_fine*sizeof(double)); grid->vlon_t = (double *)malloc(3*nx_fine*ny_fine*sizeof(double)); - grid->vlat_t = (double *)malloc(3*nx_fine*ny_fine*sizeof(double)); + grid->vlat_t = (double *)malloc(3*nx_fine*ny_fine*sizeof(double)); dlon = lon_range/nx_fine; for(i=0; ilatt1D_fine[j] = (latbegin+j*dlat)*D2R; - + } for(j=0; jlatt[j*nx_fine+i] = grid->latt1D_fine[j]; } - /* get the cartesian coordinates */ + /* get the cartesian coordinates */ latlon2xyz(nx_fine*ny_fine, grid->lont, grid->latt, grid->xt, grid->yt, grid->zt); unit_vect_latlon(nx_fine*ny_fine, grid->lont, grid->latt, grid->vlon_t, grid->vlat_t); - + } grid->lonc = (double *) malloc((nxc+1)*(nyc+1)*sizeof(double)); @@ -637,7 +639,7 @@ void get_output_grid_by_size(int ntiles, Grid_config *grid, double lonbegin, dou if(opcode & VECTOR) { /* no rotation is needed for regular lat-lon grid. */ grid->rotate = 0; } - + }; /* get_output_grid_by_size */ @@ -650,14 +652,14 @@ void init_var_config(Var_config *var, int interp_method) var->nn = 1; var->has_naxis = 0; var->has_zaxis = 0; - var->has_taxis = 0; + var->has_taxis = 0; var->kstart = 0; var->kend = 0; var->lstart = 0; var->lend = 0; var->ndim = 0; var->interp_method = interp_method; - + } /******************************************************************************* @@ -666,7 +668,7 @@ void copy_var_config(Var_config *var) void copy_var_config(const Var_config *var_in, Var_config *var_out) { int i; - + var_out->nz = var_in->nz; var_out->nn = var_in->nn; var_out->has_naxis = var_in->has_naxis; @@ -686,7 +688,7 @@ void get_output_vgrid( VGrid_config *vgrid, const char *vgrid_file ) { int fid, nz, vid, k; double *z=NULL; - + /* first get number of levels */ fid = mpp_open(vgrid_file, MPP_READ); nz = mpp_get_dimlen(fid, "nzv"); @@ -695,7 +697,7 @@ void get_output_vgrid( VGrid_config *vgrid, const char *vgrid_file ) vid = mpp_get_varid(fid, "zeta"); mpp_get_var_value(fid, vid, z); mpp_close(fid); - + nz = (nz-1)/2; vgrid->nz = nz; vgrid->z = (double *)malloc(nz*sizeof(double)); @@ -710,10 +712,10 @@ void get_input_vgrid( VGrid_config *vgrid, const char *vgrid_file, const char *f int fid, vid, vid2, ndim, i, nz; char dimname[32]; char cart; - + /* first get number of levels */ fid = mpp_open(vgrid_file, MPP_READ); - + vid = mpp_get_varid(fid, field); ndim = mpp_get_var_ndim(fid, vid); nz = 0; @@ -730,15 +732,15 @@ void get_input_vgrid( VGrid_config *vgrid, const char *vgrid_file, const char *f } mpp_close(fid); - + if(nz == 0) mpp_error("fregrid_util: no vertical levels found in the input file"); - + } void setup_vertical_interp(VGrid_config *vgrid_in, VGrid_config *vgrid_out) { int nk1, nk2, kstart, kend, k; - + nk1 = vgrid_in->nz; nk2 = vgrid_out->nz; @@ -756,7 +758,7 @@ void setup_vertical_interp(VGrid_config *vgrid_in, VGrid_config *vgrid_out) } if(kend kstart = kstart; vgrid_out->kend = kend; vgrid_out->need_interp = 1; @@ -772,7 +774,7 @@ void do_vertical_interp(VGrid_config *vgrid_in, VGrid_config *vgrid_out, Grid_co { int nk1, nk2, nx, ny, kstart, kend, i, k; double *tmp; - + if(vgrid_out->need_interp && field->var[varid].has_zaxis ) { nk1 = vgrid_in->nz; nk2 = vgrid_out->nz; @@ -784,7 +786,7 @@ void do_vertical_interp(VGrid_config *vgrid_in, VGrid_config *vgrid_out, Grid_co free(field->data); field->data = (double *)malloc(nx*ny*nk2*sizeof(double)); } - + kstart = vgrid_out->kstart; kend = vgrid_out->kend; for(k=0; kdata[k*nx*ny+i] = tmp[(nk1-1)*nx*ny+i]; } nk2 = kend - kstart + 1; - linear_vertical_interp(nx, ny, nk1, nk2, vgrid_in->z, vgrid_out->z+kstart, tmp, field->data+kstart*nx*ny); + linear_vertical_interp(nx, ny, nk1, nk2, vgrid_in->z, vgrid_out->z+kstart, tmp, field->data+kstart*nx*ny); free(tmp); } - + } /******************************************************************************* @@ -817,9 +819,9 @@ void get_input_metadata(int ntiles, int nfiles, File_config *file1, File_config Field_config *field = NULL; size_t start[4], nread[4]; int interp_method, use_bilinear, use_conserve; - int len, found; - - + int len, found, standard_dimension; + + standard_dimension = opcode & STANDARD_DIMENSION; use_bilinear = 0; use_conserve = 0; if(opcode & CONSERVE_ORDER1) { @@ -834,7 +836,7 @@ void get_input_metadata(int ntiles, int nfiles, File_config *file1, File_config use_bilinear = 1; interp_method = BILINEAR; } - + /* First find out how many fields in file and file2. */ nscalar = 0; nvector = 0; @@ -844,9 +846,9 @@ void get_input_metadata(int ntiles, int nfiles, File_config *file1, File_config for(n=0; n<4; n++) { start[n] = 0; nread[n] = 1; } - + for(m=0; m5) mpp_error("get_input_metadata(fregrid_util.c): ndim should be no larger than 5"); + field[n].var[ll].do_regrid = 0; + if(ndim>1) { + for(i=0; i2) { if(field[n].var[ll].area_has_taxis) mpp_get_var_dimname(field[n].var[ll].area_fid, field[n].var[ll].area_vid, 1, dimname); @@ -1070,16 +1108,22 @@ void get_input_metadata(int ntiles, int nfiles, File_config *file1, File_config mpp_get_var_dimname(field[n].var[ll].area_fid, field[n].var[ll].area_vid, 0, dimname); vid2 = mpp_get_varid(field[n].var[ll].area_fid, dimname); cart = mpp_get_var_cart(field[n].var[ll].area_fid, vid2); - if(cart == 'N') { + if(cart == 'N' ) field[n].var[ll].area_has_naxis = 1; + else if( cart == 'Z' ) + field[n].var[ll].area_has_zaxis = 1; + + if(field[n].var[ll].area_has_naxis || field[n].var[ll].area_has_zaxis) { if(ndim==3 && field[n].var[ll].area_has_taxis) { - sprintf(errmsg, "fregrid_util(get_input_metadata): ndim=3, has_taxis=T and hax_naxis=T for field %s in file %s", + sprintf(errmsg, "fregrid_util(get_input_metadata): ndim=3, has_taxis=T and hax_naxis/has_zaxis=T for field %s in file %s", field[n].var[ll].area_name, associated_file ); + mpp_error(errmsg); } else if(ndim==4 && !field[n].var[ll].area_has_taxis) { sprintf(errmsg, "fregrid_util(get_input_metadata): ndim=4, has_taxis=F for field %s in file %s", field[n].var[ll].area_name, associated_file ); - } + mpp_error(errmsg); + } } } @@ -1095,7 +1139,7 @@ void get_input_metadata(int ntiles, int nfiles, File_config *file1, File_config mpp_get_var_att_double(field[n].var[ll].area_fid, field[n].var[ll].area_vid, "_FillValue", &(field[n].var[ll].area_missing)); } else - field[n].var[ll].area_missing = 0; + field[n].var[ll].area_missing = 0; } } else { @@ -1103,8 +1147,8 @@ void get_input_metadata(int ntiles, int nfiles, File_config *file1, File_config field[n].var[ll].area_missing = 0; field[n].var[ll].area_has_taxis = 0; } - - /* get the interp_method from the field attribute if existing + + /* get the interp_method from the field attribute if existing when interp_method is not conserve_order2_monotonic */ if( !(opcode & MONOTONIC) ) { @@ -1125,14 +1169,13 @@ void get_input_metadata(int ntiles, int nfiles, File_config *file1, File_config } else { sprintf(errmsg, "get_input_metadata(fregrid_util.c): in file %s, attribute interp_method of field %s has value = %s" - "is not suitable, it should be conserve_order1, conserve_order2 or bilinear", file[n].name, + " is not suitable, it should be conserve_order1, conserve_order2 or bilinear", file[n].name, field[n].var[ll].name, remap_method); mpp_error(errmsg); } } } - ndim = mpp_get_var_ndim(file[n].fid, field[n].var[ll].vid); - if(ndim <2 || ndim>5) mpp_error("get_input_metadata(fregrid_util.c): ndim should be no less than 2 and no larger than 5"); + ndim = field[n].var[ll].ndim; for(i=0; i 2) { - if(cart[ndim-3] == 'Z') { - field[n].var[ll].has_zaxis = 1; - field[n].var[ll].nz = dimsize[ndim-3]; - if(kend > field[n].var[ll].nz) { - sprintf(errmsg, "get_input_metadata(fregrid_util.c): KlevelEnd should be no larger than " - "number of vertical levels of field %s in file %s.", field[n].var[ll].name, file[n].name); - mpp_error(errmsg); + if(field[n].var[ll].do_regrid) { + if(cart[ndim-1] != 'X') mpp_error("get_input_metadata(fregrid_util.c): the last dimension cartesian should be 'X'"); + if(cart[ndim-2] != 'Y') mpp_error("get_input_metadata(fregrid_util.c): the second last dimension cartesian should be 'Y'"); + if(dimsize[ndim-1] != grid[n].nx) mpp_error("get_input_metadata(fregrid_util.c): x-size in grid file in not the same as in data file"); + if(dimsize[ndim-2] != grid[n].ny) mpp_error("get_input_metadata(fregrid_util.c): y-size in grid file in not the same as in data file"); + if(ndim > 2) { + if(cart[ndim-3] == 'Z') { + field[n].var[ll].has_zaxis = 1; + field[n].var[ll].nz = dimsize[ndim-3]; + if(kend > field[n].var[ll].nz) { + sprintf(errmsg, "get_input_metadata(fregrid_util.c): KlevelEnd should be no larger than " + "number of vertical levels of field %s in file %s.", field[n].var[ll].name, file[n].name); + mpp_error(errmsg); + } + if(kbegin>0) { + field[n].var[ll].kstart = kbegin - 1; + field[n].var[ll].kend = kend - 1; + field[n].var[ll].nz = kend - kbegin + 1; + } + else { + field[n].var[ll].kstart = 0; + field[n].var[ll].kend = field[n].var[ll].nz - 1; + } } - if(kbegin>0) { - field[n].var[ll].kstart = kbegin - 1; - field[n].var[ll].kend = kend - 1; - field[n].var[ll].nz = kend - kbegin + 1; + else if(cart[ndim-3] == 'N') { + field[n].var[ll].has_naxis = 1; + field[n].var[ll].nn = dimsize[ndim-3]; } - else { - field[n].var[ll].kstart = 0; - field[n].var[ll].kend = field[n].var[ll].nz - 1; - } - } - else if(cart[ndim-3] == 'N') { - field[n].var[ll].has_naxis = 1; - field[n].var[ll].nn = dimsize[ndim-3]; } - } - if(ndim > 3) { - if(cart[ndim-4] == 'Z') { - mpp_error("get_input_metadata(fregrid_util.c): the Z-axis must be the third dimension"); - } - if(cart[ndim-4] == 'N') { - field[n].var[ll].has_naxis = 1; - field[n].var[ll].nn = dimsize[ndim-4]; - } - } - - if(cart[0] == 'T') { - field[n].var[ll].has_taxis = 1; - if(lend > dimsize[0]) { - sprintf(errmsg, "get_input_metadata(fregrid_util.c): LstepEnd should be no larger than " - "number of time levels of field %s in file %s.", field[n].var[ll].name, file[n].name); - mpp_error(errmsg); - } - if(lbegin>0) { - field[n].var[ll].lstart = lbegin - 1; - field[n].var[ll].lend = lend - 1; - file[n].nt = lend - lbegin + 1; + if(ndim > 3) { + if(cart[ndim-4] == 'Z') { + mpp_error("get_input_metadata(fregrid_util.c): the Z-axis must be the third dimension"); + } + if(cart[ndim-4] == 'N') { + field[n].var[ll].has_naxis = 1; + field[n].var[ll].nn = dimsize[ndim-4]; + } } - else { - field[n].var[ll].lstart = 0; - field[n].var[ll].lend = dimsize[0] - 1; - file[n].nt = dimsize[0]; + + if(cart[0] == 'T') { + field[n].var[ll].has_taxis = 1; + if(lend > dimsize[0]) { + sprintf(errmsg, "get_input_metadata(fregrid_util.c): LstepEnd should be no larger than " + "number of time levels of field %s in file %s.", field[n].var[ll].name, file[n].name); + mpp_error(errmsg); + } + if(lbegin>0) { + field[n].var[ll].lstart = lbegin - 1; + field[n].var[ll].lend = lend - 1; + file[n].nt = lend - lbegin + 1; + } + else { + field[n].var[ll].lstart = 0; + field[n].var[ll].lend = dimsize[0] - 1; + file[n].nt = dimsize[0]; + } } - } for(i=0; i 0) + file[n].tavg_type = mpp_get_var_type(file[n].fid, file[n].id_t1); + if(lbegin > 0) start[0] = lbegin-1; else start[0] = 0; - nread[0] = file[n].nt; nread[1] = 1; + nread[0] = file[n].nt; nread[1] = 1; mpp_get_var_value_block(file[n].fid, file[n].id_t1, start, nread, file[n].t1); - mpp_get_var_value_block(file[n].fid, file[n].id_t2, start, nread, file[n].t2); + mpp_get_var_value_block(file[n].fid, file[n].id_t2, start, nread, file[n].t2); mpp_get_var_value_block(file[n].fid, file[n].id_dt, start, nread, file[n].dt); } } @@ -1332,9 +1406,9 @@ void get_input_metadata(int ntiles, int nfiles, File_config *file1, File_config if(use_bilinear && use_conserve) mpp_error("get_input_metadata(fregrid_util.c): bilinear interpolation and conservative " "interpolation can not co-exist, check you option interp_method in command " "line and field attribute interp_method in source file"); - + }; /* get_input_metadata */ - + /* get the string after str2 in str1 and save it into strOut return 1 if the string is found, return 0 if not, return -1 if error found */ @@ -1349,7 +1423,7 @@ int parse_string(const char *str1, const char *str2, char *strOut, char *errmsg) if( str ) { /* str2 is found */ str = str+len2; len = strlen(str); - + /* find the start position */ istart = len; for(i=0; invar; if( u_in) nvector = u_in->nvar; for(n=0; nnz > 0) scalar_out[n].var[l].nz = vgrid_out->nz; + if( vgrid_out->nz > 0) scalar_out[n].var[l].nz = vgrid_out->nz; } - + for(l=0; lnz >0 ) @@ -1462,7 +1536,7 @@ void set_output_metadata (int ntiles_in, int nfiles, const File_config *file1_in else file_out[n].axis[i].size = file_in[0].axis[i].size; if(file_out[n].axis[i].cart == 'X') file_out[n].axis[i].size = grid_out[n].nx; - if(file_out[n].axis[i].cart == 'Y') file_out[n].axis[i].size = grid_out[n].ny; + if(file_out[n].axis[i].cart == 'Y') file_out[n].axis[i].size = grid_out[n].ny; file_out[n].axis[i].type = file_in[0].axis[i].type; file_out[n].axis[i].bndtype = file_in[0].axis[i].bndtype; if(standard_dimension && (file_out[n].axis[i].cart == 'X' || file_out[n].axis[i].cart == 'Y') ) @@ -1475,19 +1549,19 @@ void set_output_metadata (int ntiles_in, int nfiles, const File_config *file1_in for(i=0; inz > 0 ) { /* z-axis */ - for(l=0; lz[l]; } else { - for(l=0; lnvar; jj++) { + if(!strcmp(coord_var[j], scalar_in->var[jj].name)) { + found_var = 1; + break; + } + } + if(!found_var) { + save_coord = 0; + break; + } + } + + if(save_coord) mpp_copy_att_by_name(file_in[0].fid, scalar_in[0].var[l].vid, file_out[n].fid, + scalar_out[n].var[l].vid,name); + } } - - if(scalar_out[n].var[l].interp_method == CONSERVE_ORDER1) - mpp_def_var_att(file_out[n].fid, scalar_out[n].var[l].vid, "interp_method", "conserve_order1"); - else if(scalar_out[n].var[l].interp_method == CONSERVE_ORDER2) - mpp_def_var_att(file_out[n].fid, scalar_out[n].var[l].vid, "interp_method", "conserve_order2"); - else if(scalar_out[n].var[l].interp_method == BILINEAR) - mpp_def_var_att(file_out[n].fid, scalar_out[n].var[l].vid, "interp_method", "bilinear"); + if( scalar_in[0].var[l].do_regrid ) { + if(scalar_out[n].var[l].interp_method == CONSERVE_ORDER1) + mpp_def_var_att(file_out[n].fid, scalar_out[n].var[l].vid, "interp_method", "conserve_order1"); + else if(scalar_out[n].var[l].interp_method == CONSERVE_ORDER2) + mpp_def_var_att(file_out[n].fid, scalar_out[n].var[l].vid, "interp_method", "conserve_order2"); + else if(scalar_out[n].var[l].interp_method == BILINEAR) + mpp_def_var_att(file_out[n].fid, scalar_out[n].var[l].vid, "interp_method", "bilinear"); + } + } for(l=0; l 0 ) mpp_put_var_value(file_out[n].fid, file_out[n].axis[i].bndid, file_out[n].axis[i].bnddata); } + + /* copy the data of non-regriddable varialbe */ + /* + for(l=0; lnvar; for(l=0; lnvar; l++) { field_out[n].var[l].missing = field_in->var[l].missing; field_out[n].var[l].scale = field_in->var[l].scale; field_out[n].var[l].offset = field_in->var[l].offset; } - + } - + /******************************************************************************* void set_remap_file( ) @@ -1819,16 +1955,16 @@ void set_remap_file( int ntiles, const char *mosaic_file, const char *remap_file size_t start[4], nread[4]; char str1[STRING], tilename[STRING]; int file_exist; - + if(!remap_file) return; - + for(i=0; i<4; i++) { start[i] = 0; nread[i] = 1; } nread[1] = STRING; - + len = strlen(remap_file); - if(len >= STRING) mpp_error("setoutput_remap_file(fregrid_util): length of remap_file should be less than STRING"); + if(len >= STRING) mpp_error("setoutput_remap_file(fregrid_util): length of remap_file should be less than STRING"); if( strcmp(remap_file+len-3, ".nc")==0 ) { strncpy(str1, remap_file, len-3); str1[len-3] = 0; @@ -1842,7 +1978,7 @@ void set_remap_file( int ntiles, const char *mosaic_file, const char *remap_file fid = mpp_open(mosaic_file, MPP_READ); vid = mpp_get_varid(fid, "gridtiles"); } - + for(m=0; m 1) { @@ -1859,11 +1995,11 @@ void set_remap_file( int ntiles, const char *mosaic_file, const char *remap_file (*opcode) |= READ; interp[m].file_exist = 1; } - + } if(ntiles>1) mpp_close(fid); - + };/* set_remap_file */ @@ -1879,14 +2015,14 @@ void write_output_time(int ntiles, File_config *file, int level) for(i=0; i<4; i++) { start[i] = 0; nwrite[i] = 1; } - start[0] = level; + start[0] = level; if( mpp_pe() == mpp_root_pe()) { for(n=0; nvar[varid].missing; interp_method = field->var[varid].interp_method; if(interp_method == CONSERVE_ORDER1) @@ -1948,10 +2084,10 @@ void get_input_data(int ntiles, Field_config *field, Grid_config *grid, Bound_co start[pos++] = field->var[varid].kstart; } else - start[pos++] = level_z; + start[pos++] = level_z; } if(ndim != pos + 2) mpp_error("fregrid_util(get_input_data): mimstch between ndim and has_taxis/has_zaxis/has_naxis"); - + /* first read input data for each tile */ for(n=0; n 0 */ if(halo > 0) { @@ -2070,7 +2208,7 @@ void get_input_data(int ntiles, Field_config *field, Grid_config *grid, Bound_co p = k*(nx+2)*(ny+2); grad_c2l(&(grid[n].nx), &(grid[n].ny), field[n].data+p, grid[n].dx, grid[n].dy, grid[n].area, grid[n].edge_w, grid[n].edge_e, grid[n].edge_s, grid[n].edge_n, - grid[n].en_n, grid[n].en_e, grid[n].vlon_t, grid[n].vlat_t, + grid[n].en_n, grid[n].en_e, grid[n].vlon_t, grid[n].vlat_t, field[n].grad_x, field[n].grad_y, &is_true, &is_true, &is_true, &is_true); } /* where there is missing and using second order conservative interpolation, need to calculate mask for gradient */ @@ -2093,7 +2231,7 @@ void get_input_data(int ntiles, Field_config *field, Grid_config *grid, Bound_co } - + }; /* get_input_data */ /*--------------------------------------------------------------------------- @@ -2107,13 +2245,13 @@ void get_test_input_data(char *test_case, double test_param, int ntiles, Field_c double *data; Data_holder *dHold; char input_file[128]; - int fid, vid, dim[2]; - + int fid, vid, dim[2]; + if(opcode & CONSERVE_ORDER1) halo = 0; else halo = 1; - + for(n=0; n 0 */ if(halo > 0) { for(n=0; nvar[varid].ndim; - if(ndim < 2) mpp_error("fregrid_util(write_field_data): ndim must be no less than 2"); nwrite = (size_t *)malloc(ndim*sizeof(size_t)); start = (size_t *)malloc(ndim*sizeof(size_t)); @@ -2241,13 +2378,13 @@ void write_field_data(int ntiles, Field_config *field, Grid_config *grid, int va start[pos++] = level_z; } if(ndim != pos + 2) mpp_error("fregrid_util(write_field_data): mimstch between ndim and has_taxis/has_zaxis/has_naxis"); - + for(n=0; n 0) { free(bound[n].is1); @@ -2461,7 +2598,7 @@ void delete_bound_memory(int ntiles, Bound_config *bound) } } } - + /*----------------------------------------------------------------------------- void init_halo(double *var, int nx, int ny, int nz, int halo) @@ -2475,7 +2612,7 @@ void init_halo(double *var, int nx, int ny, int nz, int halo) nxd = nx+2*halo; nyd = ny+2*halo; nall = nxd*nyd; - + for(k=0; knbound; size1 = nx*ny; @@ -2528,7 +2665,7 @@ void update_halo(int nx, int ny, int nz, double *data, Bound_config *bound, Data l = 0; for(k=0; k #include #include +#include #include #include "mpp.h" #include "mosaic_util.h" @@ -43,19 +44,19 @@ void create_conformal_cubic_grid( int *npts, int *nratio, char *method, char *or ny = nx; nxp = nx+1; nyp = nxp; - + /*calculate geographic coordinates. */ if(strcmp(orientation, "center_pole") == 0) calc_geocoords_centerpole(nx, ny, x, y); else - mpp_error("create_cubic_grid: only center pole orientation is implemented"); + mpp_error("create_cubic_grid: only center pole orientation is implemented"); /* calculate cell length and area */ - calc_fvgrid(nx, ny, *nratio, dx, dy, area); + calc_fvgrid(nx, ny, *nratio, dx, dy, area); /*calculate rotation angle, just some workaround, will modify this in the future. */ calc_rotation_angle(nxp, nyp, x, y, angle_dx, angle_dy ); - + }; /* create_conformal_cubic_grid */ /*********************************************************************** @@ -71,8 +72,8 @@ void calc_geocoords_centerpole(int nx, int ny, double *x, double *y) nxp = nx+1; nyp = ny+1; nxh = (nxp+1)/2; - nyh = (nyp+1)/2; - + nyh = (nyp+1)/2; + lx = (double *)malloc(nxh*nyh*sizeof(double)); ly = (double *)malloc(nxh*nyh*sizeof(double)); @@ -82,7 +83,7 @@ void calc_geocoords_centerpole(int nx, int ny, double *x, double *y) lx[n] = -1. + 2.0*i/(nxp-1); ly[n++] = -1. + 2.0*j/(nyp-1); } - } + } X = (double *)malloc(nxh*nyh*sizeof(double)); Y = (double *)malloc(nxh*nyh*sizeof(double)); @@ -95,7 +96,7 @@ void calc_geocoords_centerpole(int nx, int ny, double *x, double *y) latP = (double *) malloc(nxp*nyp*sizeof(double)); lonE = (double *) malloc(nxp*nyp*sizeof(double)); latE = (double *) malloc(nxp*nyp*sizeof(double)); - + /* map 3D coordinates to geographical coordinates. */ map_xyz2lonlat( nxh, nyh, X, Y, Z, lx, ly ); @@ -113,7 +114,7 @@ void calc_geocoords_centerpole(int nx, int ny, double *x, double *y) if( i= M_PI ) lonP[j*nxp+i] -= 2*M_PI; } } @@ -123,7 +124,7 @@ void calc_geocoords_centerpole(int nx, int ny, double *x, double *y) for(j=0; j=0; m--) w = ( w + A[m] ) * zc; if( w != 0. ) w = cpow(I,THRD) * cpow( w*I, THRD); w = (w-RA)/(CB+CC*w); - X[n] = creal(w); + X[n] = creal(w); Y[n] = cimag(w); h = 2./(1+cpow(X[n],2)+cpow(Y[n],2)); X[n] = X[n]*h; @@ -337,7 +338,7 @@ void conformal_map_coords2xyz ( int ni, int nj, double *lx, double *ly, ************************************************************/ -void map_xyz2lonlat(int ni, int nj, double *X, double *Y, double *Z, +void map_xyz2lonlat(int ni, int nj, double *X, double *Y, double *Z, double *lon, double *lat ) { int i, j, n; @@ -363,19 +364,19 @@ void map_xyz2lonlat(int ni, int nj, double *X, double *Y, double *Z, if(X[n]<0 && Y[n] >=0) lon[n] += M_PI; if(X[n]<=0 && Y[n] < 0) lon[n] -= M_PI; } - + }; /* map_xyz2lonlat */ /************************************************************** - void rotate_about_xaxis(int ni, int nj, double *X, double *Y, + void rotate_about_xaxis(int ni, int nj, double *X, double *Y, double *Z, double angle) Rotate about X axis by "angle" ***************************************************************/ -void rotate_about_xaxis(int ni, int nj, double *X, double *Y, +void rotate_about_xaxis(int ni, int nj, double *X, double *Y, double *Z, double angle) { int i, j, n; double s,c,old; @@ -414,7 +415,7 @@ void permutiles(int ni, int nj, double *b, int num) { int i, j, k, n; int ntiles = 6; double *c=NULL; - + c = (double *)malloc(ni*nj*ntiles*sizeof(double)); for(k=0; ki) areal[j*(nif-1)+i] = areal[i*(nif-1)+j]; @@ -581,7 +582,7 @@ void calc_fvgrid(int nx, int ny, int nratio, double *dx, double *dy, double *are } /* copy data from fine grid to super grid. */ - + for(j=0;j* angle_between_vectors(array vec1, array vec2) *******************************************************************************/ @@ -639,7 +640,7 @@ double* angle_between_vectors(int ni, int nj, double *vec1, double *vec2) { int n; double vector_prod, nrm1, nrm2; double *angle; - + angle = (double *)malloc(ni*nj*sizeof(double)); for(n=0; n= ntiles) tp1 -= ntiles; jp1 = 0; } - } + } if(jm1 < 0) { /* find the neighbor tile. */ if(n % 2 == 0) { /* tile 1, 3, 5 */ tm1 = n-1; @@ -806,7 +807,7 @@ void calc_rotation_angle(int nxp, int nyp, double *x, double *y, double *angle_d im1 = nx; jm1 = nx-i; } - } + } angle_dy[n*nxp*nyp+j*nxp+i] = atan2(y[tp1*nxp*nyp+jp1*nxp+ip1]-y[tm1*nxp*nyp+jm1*nxp+im1], (x[tp1*nxp*nyp+jp1*nxp+ip1]-x[tm1*nxp*nyp+jm1*nxp+im1])*lon_scale )*R2D; @@ -815,4 +816,3 @@ void calc_rotation_angle(int nxp, int nyp, double *x, double *y, double *angle_d } }; /* calc_rotation_angle */ - diff --git a/sorc/fre-nctools.fd/tools/make_hgrid/create_gnomonic_cubic_grid.c b/sorc/fre-nctools.fd/tools/make_hgrid/create_gnomonic_cubic_grid.c index 078e7f257..f21177eb9 100644 --- a/sorc/fre-nctools.fd/tools/make_hgrid/create_gnomonic_cubic_grid.c +++ b/sorc/fre-nctools.fd/tools/make_hgrid/create_gnomonic_cubic_grid.c @@ -1,6 +1,30 @@ /** @file @brief Create gnomonic cubic grids. + This file creates the 6 tiles for a gnomonic projection of a cubed sphere. + It also creates nest grids if they are defined. + Modifications: + 05/10/2020 -- Added multiple nest capability. Bill Ramstrom, AOML/HRD + Nests can be specified on any parent tile, and can each be + different sizes. Nests with different refinement ratios + have NOT been tested and should be considered unsupported. + 12/07/2020 -- Global refinement bug fix. Kyle Ahern, AOML/HRD + 12/10/2020 -- Make multiple nest functionality consistent with latest + NOAA-GFDL source. Kyle Ahern, AOML/HRD + 03/05/2020 -- Enable many level Telescoping nests + (Nests within nests). Joseph Mouallem FV3/GFDL + 04/12/2021 -- Fixed several IMAs (Invalid Memory Access), memory leaks, and some + non-critical compiler warnings. Some notes related to MAs are scattered below. + Inorder to help reproduce the pre multinest GR (Global Refinement) awnsers, + the pre mulit-nest version of function create_gnomonic_cubic_grid was added back + as a second version of the function by that name. + Miguel Zuniga. +*******************************************************************************/ + +/** + * \author Zhi Liang */ + + #include #include #include @@ -27,9 +51,9 @@ void spherical_to_cartesian(double lon, double lat, double r, double *x, double void symm_ed(int ni, double *lamda, double *theta); void mirror_grid(int ni, int ntiles, double *x, double *y ); void mirror_latlon(double lon1, double lat1, double lon2, double lat2, double lon0, - double lat0, double *lon, double *lat); + double lat0, double *lon, double *lat); void rot_3d(int axis, double x1in, double y1in, double z1in, double angle, double *x2out, - double *y2out, double *z2out, int degrees, int convert); + double *y2out, double *z2out, int degrees, int convert); double excess_of_quad2(const double *vec1, const double *vec2, const double *vec3, const double *vec4 ); double angle_between_vectors2(const double *vec1, const double *vec2); void plane_normal2(const double *P1, const double *P2, double *plane); @@ -39,10 +63,12 @@ void cell_east(int ni, int nj, const double *lonc, const double *latc, double *l void cell_north(int ni, int nj, const double *lonc, const double *latc, double *lonn, double *latn); void calc_cell_area(int nx, int ny, const double *x, const double *y, double *area); void direct_transform(double stretch_factor, int i1, int i2, int j1, int j2, double lon_p, double lat_p, - int n, double *lon, double *lat); + int n, double *lon, double *lat); +void cube_transform(double stretch_factor, int i1, int i2, int j1, int j2, double lon_p, double lat_p, + int n, double *lon, double *lat); void setup_aligned_nest(int parent_ni, int parent_nj, const double *parent_xc, const double *parent_yc, int halo, int refine_ratio, int istart, int iend, int jstart, int jend, - double *xc, double *yc); + double *xc, double *yc, int is_gr); void spherical_linear_interpolation(double beta, const double *p1, const double *p2, double *pb); @@ -53,27 +79,673 @@ void spherical_linear_interpolation(double beta, const double *p1, const double create nomomic cubic grid. All six tiles grid will be generated. *******************************************************************************/ void create_gnomonic_cubic_grid( char* grid_type, int *nlon, int *nlat, double *x, double *y, + double *dx, double *dy, double *area, double *angle_dx, + double *angle_dy, double shift_fac, int do_schmidt, int do_cube_transform, double stretch_factor, + double target_lon, double target_lat, int num_nest_grids, + int parent_tile[MAX_NESTS], int refine_ratio[MAX_NESTS], int istart_nest[MAX_NESTS], + int iend_nest[MAX_NESTS], int jstart_nest[MAX_NESTS], int jend_nest[MAX_NESTS], + int halo, int output_length_angle) +{ + const int ntiles = 6; + int verbose = 1; + long ntiles2, global_nest=0; + + long nx, ny, nxp, nyp, ni, nj, nip, njp; + + int nx_nest[MAX_NESTS], ny_nest[MAX_NESTS]; + int ni_nest[MAX_NESTS], nj_nest[MAX_NESTS]; + int ni_parent[MAX_NESTS], nj_parent[MAX_NESTS]; + int istart[MAX_NESTS], iend[MAX_NESTS], jstart[MAX_NESTS], jend[MAX_NESTS]; + + int *nx_nest_arr=NULL; + int *ny_nest_arr=NULL; + int *ni_nest_arr=NULL; + int *nj_nest_arr=NULL; + + long ni2, nj2, ni2p, nj2p, n1, n2; + int *nxl=NULL, *nyl=NULL, *nil=NULL, *njl=NULL; + int *tile_offset=NULL; + int *tile_offset_supergrid=NULL; + int *tile_offset_supergrid_m=NULL; + int *tile_offset_area=NULL; + + long i, j, n, npts, nn; + long npts_supergrid, npts_supergrid_m, npts_area; + + double p1[2], p2[2]; + double *lon=NULL, *lat=NULL; + double *xc=NULL, *yc=NULL, *xtmp=NULL, *ytmp=NULL; + double *xc2=NULL, *yc2=NULL; + int stretched_grid=0; + + /* + * make sure the first 6 tiles have the same grid size and + * the size in x and y-direction are the same + */ + + /* ntiles is a constant always equal to 6. ntiles2 is variable, and includes the 6 global tiles plus any nests */ + + if (verbose) fprintf(stderr, "[INFO] Starting create_gnomonic_grid with num_nest_grids=%d\n", num_nest_grids); + + for(n=0; n EPSLN5 ) stretched_grid = 1; + + lon = (double *)malloc(nip*nip*sizeof(double)); + lat = (double *)malloc(nip*nip*sizeof(double)); + + if(strcmp(grid_type, "gnomonic_ed")==0 ) + gnomonic_ed( ni, lon, lat); + else if(strcmp(grid_type,"gnomonic_dist")==0) + gnomonic_dist(ni, lon, lat); + else if(strcmp(grid_type,"gnomonic_angl")==0) + gnomonic_angl(ni, lon, lat); + else mpp_error("create_gnomonic_cubic_grid: grid type should be 'gnomonic_ed', " + "'gnomonic_dist' or 'gnomonic_angl'"); + + symm_ed(ni, lon, lat); + + // Cycle through all of the tiles; global and nests, adding enough points based on the dimensions + // The 6 cubed-sphere tiles are square thus, nil=njl, but the nests can be rectangular + npts = 0; + npts_supergrid = 0; + npts_supergrid_m = 0; + npts_area = 0; + + for (n=0; n EPSLN4) xc[n] -= M_PI/18.; + if(xc[n] < 0.) xc[n] += 2.*M_PI; + if(fabs(xc[n]) < EPSLN10) xc[n] = 0; + if(fabs(yc[n]) < EPSLN10) yc[n] = 0; + } + + /* ensure consistency on the boundary between tiles */ + for(j=0; j 2W */ + yc[ nip*nip+j*nip] = yc[j*nip+ni]; /* 1E -> 2W */ + xc[2*nip*nip+j*nip] = xc[ni*nip+ni-j]; /* 1N -> 3W */ + yc[2*nip*nip+j*nip] = yc[ni*nip+ni-j]; /* 1N -> 3W */ + } + for(i=0; i 5N */ + yc[4*nip*nip+ni*nip+i] = yc[(ni-i)*nip]; /* 1W -> 2N */ + xc[5*nip*nip+ni*nip+i] = xc[i]; /* 1S -> 6N */ + yc[5*nip*nip+ni*nip+i] = yc[i]; /* 1S -> 6N */ + xc[2*nip*nip+i] = xc[nip*nip+ni*nip+i]; /* 2N -> 3S */ + yc[2*nip*nip+i] = yc[nip*nip+ni*nip+i]; /* 2N -> 3S */ + xc[3*nip*nip+i] = xc[nip*nip+(ni-i)*nip+ni]; /* 2E -> 4S */ + yc[3*nip*nip+i] = yc[nip*nip+(ni-i)*nip+ni]; /* 2E -> 4S */ + } + for(j=0; j 6E */ + yc[5*nip*nip+j*nip+ni] = yc[nip*nip+ni-j]; /* 2S -> 6E */ + xc[3*nip*nip+j*nip] = xc[2*nip*nip+j*nip+ni]; /* 3E -> 4W */ + yc[3*nip*nip+j*nip] = yc[2*nip*nip+j*nip+ni]; /* 3E -> 4W */ + xc[4*nip*nip+j*nip] = xc[2*nip*nip+ni*nip+ni-j]; /* 3N -> 5W */ + yc[4*nip*nip+j*nip] = yc[2*nip*nip+ni*nip+ni-j]; /* 3N -> 5W */ + } + for(i=0; i 5S */ + yc[4*nip*nip+i] = yc[3*nip*nip+ni*nip+i]; /* 4N -> 5S */ + xc[5*nip*nip+i] = xc[3*nip*nip+(ni-i)*nip+ni]; /* 4E -> 6S */ + yc[5*nip*nip+i] = yc[3*nip*nip+(ni-i)*nip+ni]; /* 4E -> 6S */ + } + for(j=0; j 6W */ + yc[5*nip*nip+j*nip] = yc[4*nip*nip+j*nip+ni]; /* 5E -> 6W */ + } + + /* Schmidt transformation */ + if ( do_schmidt ) { + for(n=0; n 0 ) { + for (nn=0; nn < num_nest_grids; nn++) { + if (verbose) { + fprintf(stderr, + "[INFO] Processing setup_aligned_nest for nest %ld . ntiles=%d parent_tile[nn]: %d\n", + nn, ntiles, parent_tile[nn]); + } + /* Setup aligned nest -- final two arguments are memory locations for data to be returned */ + /* The pointer arithmetic is complicated */ + /* ni = number of points on supergrid */ + /* nip = ni + 1 */ + setup_aligned_nest(ni_parent[nn], nj_parent[nn], xc+tile_offset[parent_tile[nn]-1], + yc+tile_offset[parent_tile[nn]-1], halo, refine_ratio[nn], + istart[nn], iend[nn], jstart[nn], jend[nn], + xc+tile_offset[ntiles+nn], yc+tile_offset[ntiles+nn], 0); + } + + if (verbose) fprintf(stderr, "[INFO] Completed processing setup_aligned_nest for nest(s)\n"); + } + + /* calculate grid box center location */ + + ni2 = 0; + nj2 = 0; + for(n=0; nni2) ni2 = nil[n]; + if(njl[n]>nj2) nj2 = njl[n]; + } + ni2p = ni2+1; + nj2p = nj2+1; + xtmp = (double *)malloc(ni2p*nj2p*sizeof(double)); + ytmp = (double *)malloc(ni2p*nj2p*sizeof(double)); + + /* Setting the x, y values for each tile */ + /* Not clear that data is handled correctly for nested tiles, though. */ + + /* Iterate over all of the tiles */ + /* Copy the lat/lons into the x, y array */ + /* C-cell */ + /* Center */ + /* East */ + /* North */ + + for(n=0; n max_n1) max_n1 = n1; + } + } + } + + /* cell center and copy to super grid */ + cell_center(nil[n], njl[n], xc + tile_offset[n], yc + tile_offset[n], xtmp, ytmp); + if (verbose) fprintf(stderr, "[INFO] CENTER n: %ld n*nip*nip: %ld tile_offset[n]: %d\n", n, n*nip*nip, tile_offset[n]); + for(j=0; j max_n1) max_n1 = n1; + } + + } + } + + /* cell east and copy to super grid */ + cell_east(nil[n], njl[n], xc + tile_offset[n], yc + tile_offset[n], xtmp, ytmp); + for(j=0; j max_n1) max_n1 = n1; + } + } + } + + /* cell north and copy to super grid */ + cell_north(nil[n], njl[n], xc + tile_offset[n], yc + tile_offset[n], xtmp, ytmp); + for(j=0; j<=njl[n]; j++){ + for(i=0; i max_n1) max_n1 = n1; + } + } + } + + if (verbose) fprintf(stderr, + "[INFO] INDEX tile: %ld min_n1: %ld max_n1: %ld max_n1 - min_n1: %ld sqrt(max_n1 - min_n1 + 1): %f\n", + n, min_n1, max_n1, max_n1 - min_n1, sqrt(max_n1 - min_n1 + 1)); + + } + + free(xtmp); + free(ytmp); + + /* calculate grid cell length */ + if (output_length_angle) { + /* Calculate dx */ + for(n=0; n= 6) ) { + for(j=0; j= 6)) */ { + for(j=0; j= 6)) */ + } /* n < ntiles2 */ + + /* ensure consistency on the boundaries between tiles */ + for(j=0; j 1W */ + dy[n21] = dy[n22]; /* 2W -> 1E */ + dy[n31] = dx[n32]; /* 4S -> 2E */ + dy[n41] = dx[n42]; /* 1N -> 3W */ + dy[n51] = dy[n52]; /* 4W -> 3E */ + dy[n61] = dx[n62]; /* 4S -> 2E */ + dy[n71] = dx[n72]; /* 3N -> 5W */ + dy[n81] = dy[n82]; /* 6W -> 5E */ + dy[n91] = dx[n92]; /* 2S -> 6E */ + } /* j < nx */ + } /* output_length_angle */ + + if(do_schmidt) { /* calculate area for each tile */ + for(n=0; n EPSLN5 ) stretched_grid = 1; + if ( (do_schmidt || do_cube_transform) && fabs(stretch_factor-1.) > EPSLN5 ) stretched_grid = 1; + lon = (double *)malloc(nip*nip*sizeof(double)); lat = (double *)malloc(nip*nip*sizeof(double)); - + if(strcmp(grid_type, "gnomonic_ed")==0 ) gnomonic_ed( ni, lon, lat); else if(strcmp(grid_type,"gnomonic_dist")==0) @@ -156,56 +816,55 @@ void create_gnomonic_cubic_grid( char* grid_type, int *nlon, int *nlat, double * else if(strcmp(grid_type,"gnomonic_angl")==0) gnomonic_angl(ni, lon, lat); else mpp_error("create_gnomonic_cubic_grid: grid type should be 'gnomonic_ed', " - "'gnomonic_dist' or 'gnomonic_angl'"); + "'gnomonic_dist' or 'gnomonic_angl'"); symm_ed(ni, lon, lat); - npts = ntiles*nip*nip; if(ntiles2>ntiles) npts += (ni_nest+1)*(nj_nest+1); - + xc = (double *)malloc(npts*sizeof(double)); yc = (double *)malloc(npts*sizeof(double)); - + for(j=0; j EPSLN4) xc[n] -= M_PI/18.; + if( do_schmidt == 0 && do_cube_transform==0 && shift_fac > EPSLN4) xc[n] -= M_PI/18.; if(xc[n] < 0.) xc[n] += 2.*M_PI; if(fabs(xc[n]) < EPSLN10) xc[n] = 0; if(fabs(yc[n]) < EPSLN10) yc[n] = 0; } - + /* ensure consistency on the boundary between tiles */ for(j=0; j 2W */ yc[ nip*nip+j*nip] = yc[j*nip+ni]; /* 1E -> 2W */ xc[2*nip*nip+j*nip] = xc[ni*nip+ni-j]; /* 1N -> 3W */ - yc[2*nip*nip+j*nip] = yc[ni*nip+ni-j]; /* 1N -> 3W */ + yc[2*nip*nip+j*nip] = yc[ni*nip+ni-j]; /* 1N -> 3W */ } for(i=0; i 5N */ yc[4*nip*nip+ni*nip+i] = yc[(ni-i)*nip]; /* 1W -> 2N */ xc[5*nip*nip+ni*nip+i] = xc[i]; /* 1S -> 6N */ - yc[5*nip*nip+ni*nip+i] = yc[i]; /* 1S -> 6N */ + yc[5*nip*nip+ni*nip+i] = yc[i]; /* 1S -> 6N */ xc[2*nip*nip+i] = xc[nip*nip+ni*nip+i]; /* 2N -> 3S */ yc[2*nip*nip+i] = yc[nip*nip+ni*nip+i]; /* 2N -> 3S */ xc[3*nip*nip+i] = xc[nip*nip+(ni-i)*nip+ni]; /* 2E -> 4S */ - yc[3*nip*nip+i] = yc[nip*nip+(ni-i)*nip+ni]; /* 2E -> 4S */ + yc[3*nip*nip+i] = yc[nip*nip+(ni-i)*nip+ni]; /* 2E -> 4S */ } for(j=0; j 6E */ - yc[5*nip*nip+j*nip+ni] = yc[nip*nip+ni-j]; /* 2S -> 6E */ + yc[5*nip*nip+j*nip+ni] = yc[nip*nip+ni-j]; /* 2S -> 6E */ xc[3*nip*nip+j*nip] = xc[2*nip*nip+j*nip+ni]; /* 3E -> 4W */ yc[3*nip*nip+j*nip] = yc[2*nip*nip+j*nip+ni]; /* 3E -> 4W */ xc[4*nip*nip+j*nip] = xc[2*nip*nip+ni*nip+ni-j]; /* 3N -> 5W */ @@ -219,22 +878,30 @@ void create_gnomonic_cubic_grid( char* grid_type, int *nlon, int *nlat, double * } for(j=0; j 6W */ - yc[5*nip*nip+j*nip] = yc[4*nip*nip+j*nip+ni]; /* 5E -> 6W */ + yc[5*nip*nip+j*nip] = yc[4*nip*nip+j*nip+ni]; /* 5E -> 6W */ } /* Schmidt transformation */ if ( do_schmidt ) { for(n=0; n 1W */ - dy[j*nxp+nx] = dy[nxp*nx+j*nxp]; /* 2W -> 1E */ - dy[nxp*nx+j*nxp+nx] = dx[3*nx*nxp+(nx-j-1)]; /* 4S -> 2E */ - dy[2*nxp*nx+j*nxp] = dx[nx*nx+nx-j-1]; /* 1N -> 3W */ - dy[2*nxp*nx+j*nxp+nx] = dy[3*nxp*nx+j*nxp]; /* 4W -> 3E */ - dy[3*nxp*nx+j*nxp+nx] = dx[5*nx*nxp+(nx-j-1)]; /* 4S -> 2E */ - dy[4*nxp*nx+j*nxp] = dx[2*nx*nxp+nx*nx+nx-j-1]; /* 3N -> 5W */ - dy[4*nxp*nx+j*nxp+nx] = dy[5*nxp*nx+j*nxp]; /* 6W -> 5E */ - dy[5*nxp*nx+j*nxp+nx] = dx[nx*nxp+(nx-j-1)]; /* 2S -> 6E */ + + /* ensure consistency on the boundaries between tiles */ + for(j=0; j 1W */ + dy[n21] = dy[n22]; /* 2W -> 1E */ + dy[n31] = dx[n32]; /* 4S -> 2E */ + dy[n41] = dx[n42]; /* 1N -> 3W */ + dy[n51] = dy[n52]; /* 4W -> 3E */ + dy[n61] = dx[n62]; /* 4S -> 2E */ + dy[n71] = dx[n72]; /* 3N -> 5W */ + dy[n81] = dy[n82]; /* 6W -> 5E */ + dy[n91] = dx[n92]; /* 2S -> 6E */ + } } - if(do_schmidt) { /* calculate area for each tile */ - for(n=0; nntiles) { + pos1 = ntiles*nxp*nyp; + pos2 = ntiles*nx*ny; + calc_cell_area(nx_nest, ny_nest, x+pos1, y+ntiles*nxp*nyp, area+pos2); } } - -} - /* calculate nested grid area */ - if(ntiles2>ntiles) calc_cell_area(nx_nest, ny_nest, x+ntiles*nxp*nyp, y+ntiles*nxp*nyp, area+ntiles*nx*ny); - - /*calculate rotation angle, just some workaround, will modify this in the future. */ - calc_rotation_angle2(nxp, x, y, angle_dx, angle_dy ); - - /* since angle is used in the model, set angle to 0 for nested region */ - if(ntiles2>ntiles) { - for(i=0; i<=(nx_nest+1)*(ny_nest+1); i++) { - angle_dx[ntiles*nxp*nxp+i]=0; - angle_dy[ntiles*nxp*nxp+i]=0; + + if(output_length_angle) { + /*calculate rotation angle, just some workaround, will modify this in the future. */ + calc_rotation_angle2(nxp, x, y, angle_dx, angle_dy ); + + /* since angle is used in the model, set angle to 0 for nested region */ + if(ntiles2>ntiles) { + for(i=0; i<=(nx_nest+1)*(ny_nest+1); i++) { + angle_dx[ntiles*nxp*nxp+i]=0; + angle_dy[ntiles*nxp*nxp+i]=0; + } } } - - /* convert grid location from radians to degree */ - npts = ntiles*nxp*nyp; - if(nx_nest>0) npts += (nx_nest+1)*(ny_nest+1); - - for(i=0; i0) npts += (nx_nest+1)*(ny_nest+1); + + + for(i=0; i EPSLN7 ) { - sin_lat = sin(lat[l]); - lat_t = asin( (c2m1+c2p1*sin_lat)/(c2p1+c2m1*sin_lat) ); + sin_lat = sin(lat[l]); + lat_t = asin( (c2m1+c2p1*sin_lat)/(c2p1+c2m1*sin_lat) ); } else { - lat_t = lat[l]; + lat_t = lat[l]; } sin_lat = sin(lat_t); - cos_lat = cos(lat_t); + cos_lat = cos(lat_t); sin_o = -(sin_p*sin_lat + cos_p*cos_lat*cos(lon[l])); if ( (1.-fabs(sin_o)) < EPSLN7 ) { /* poles */ - lon[l] = 0.; - lat[l] = (sin_o < 0) ? -p2:p2; + lon[l] = 0.; + lat[l] = (sin_o < 0) ? -p2:p2; } else { - lat[l] = asin( sin_o ); - lon[l] = lon_p + atan2(-cos_lat*sin(lon[l]), -sin_lat*cos_p+cos_lat*sin_p*cos(lon[l])); - if ( lon[l] < 0. ) - lon[l] +=two_pi; - else if( lon[l] >= two_pi ) - lon[l] -=two_pi; + lat[l] = asin( sin_o ); + lon[l] = lon_p + atan2(-cos_lat*sin(lon[l]), -sin_lat*cos_p+cos_lat*sin_p*cos(lon[l])); + if ( lon[l] < 0. ) + lon[l] +=two_pi; + else if( lon[l] >= two_pi ) + lon[l] -=two_pi; } - } - -}; /* direct_transform */ + } +} /* direct_transform */ + +/*------------------------------------------------------------------------- + void cube_transform(double c, int i1, int i2, int j1, int j2, double lon_p, double lat_p, int n, + double *lon, double *lat) + + This is a direct transformation of the standard (symmetrical) cubic grid + to a locally enhanced high-res grid on the sphere; it is an application + of the Schmidt transformation at the **north** pole followed by a + pole_shift_to_target (rotation) operation + + arguments: + c : Stretching factor + lon_p, lat_p : center location of the target face, radian + n : grid face number + i1,i2,j1,j2 : starting and ending index in i- and j-direction + lon : longitude. 0 <= lon <= 2*pi + lat : latitude. -pi/2 <= lat <= pi/2 + ------------------------------------------------------------------------*/ + +void cube_transform(double stretch_factor, int i1, int i2, int j1, int j2, double lon_p, double lat_p, + int n, double *lon, double *lat) +{ +#ifndef HAVE_LONG_DOUBLE_WIDER + double lat_t, sin_p, cos_p, sin_lat, cos_lat, sin_o, p2, two_pi; + double c2p1, c2m1; +#else + long double lat_t, sin_p, cos_p, sin_lat, cos_lat, sin_o, p2, two_pi; + long double c2p1, c2m1; +#endif + int i, j, l, nxp; + + nxp = i2-i1+1; + p2 = 0.5*M_PI; + two_pi = 2.*M_PI; + if(n==0) printf("create_gnomonic_cubic_grid: Cube transformation (revised Schmidt): stretching factor=%g, center=(%g,%g)\n", + stretch_factor, lon_p, lat_p); + + c2p1 = 1. + stretch_factor*stretch_factor; + c2m1 = 1. - stretch_factor*stretch_factor; + sin_p = sin(lat_p); + cos_p = cos(lat_p); + /* Try rotating pole around before doing the regular rotation */ + for(j=j1; j<=j2; j++) for(i=i1; i<=i2; i++) { + l = j*nxp+i; + if ( fabs(c2m1) > EPSLN7 ) { + sin_lat = sin(lat[l]); + lat_t = asin( (c2m1+c2p1*sin_lat)/(c2p1+c2m1*sin_lat) ); + } + else { + lat_t = lat[l]; + } + sin_lat = sin(lat_t); + cos_lat = cos(lat_t); + lon[l] = lon[l] + M_PI; /* rotate around first to get final orientation correct */ + sin_o = -(sin_p*sin_lat + cos_p*cos_lat*cos(lon[l])); + if ( (1.-fabs(sin_o)) < EPSLN7 ) { /* poles */ + lon[l] = 0.; + lat[l] = (sin_o < 0) ? -p2:p2; + } + else { + lat[l] = asin( sin_o ); + lon[l] = lon_p + atan2(-cos_lat*sin(lon[l]), -sin_lat*cos_p+cos_lat*sin_p*cos(lon[l])); + if ( lon[l] < 0. ) + lon[l] +=two_pi; + else if( lon[l] >= two_pi ) + lon[l] -=two_pi; + } + } +} /* cube_transform */ /*----------------------------------------------------- - void gnomonic_ed + void gnomonic_ed Equal distance along the 4 edges of the cubed sphere ----------------------------------------------------- - Properties: + Properties: * defined by intersections of great circles * max(dx,dy; global) / min(dx,dy; global) = sqrt(2) = 1.4142 * Max(aspect ratio) = 1.06089 - * the N-S coordinate curves are const longitude on the 4 faces with equator + * the N-S coordinate curves are const longitude on the 4 faces with equator For C2000: (dx_min, dx_max) = (3.921, 5.545) in km unit ! Ranges: ! lamda = [0.75*pi, 1.25*pi] @@ -521,7 +1323,7 @@ void gnomonic_ed(int ni, double* lamda, double* theta) int i, j, n, nip; double dely; - double *pp, *x, *y, *z; + double *x, *y, *z; double rsq3, alpha; @@ -542,10 +1344,10 @@ void gnomonic_ed(int ni, double* lamda, double* theta) /* Get North-South edges by symmetry: */ for(i=1; i=0 ? 1:-1); x[j*nip+ip] = x1 * (x[j*nip+ip] >=0 ? 1:-1); x[jp*nip+i] = x1 * (x[jp*nip+i] >=0 ? 1:-1); - x[jp*nip+ip] = x1 * (x[jp*nip+ip] >=0 ? 1:-1); + x[jp*nip+ip] = x1 * (x[jp*nip+ip] >=0 ? 1:-1); y1 = 0.25 * (fabs(y[j*nip+i]) + fabs(y[j*nip+ip]) + fabs(y[jp*nip+i]) + fabs(y[jp*nip+ip]) ); y[j*nip+i] = y1 * (y[j*nip+i] >=0 ? 1:-1); y[j*nip+ip] = y1 * (y[j*nip+ip] >=0 ? 1:-1); y[jp*nip+i] = y1 * (y[jp*nip+i] >=0 ? 1:-1); - y[jp*nip+ip] = y1 * (y[jp*nip+ip] >=0 ? 1:-1); - + y[jp*nip+ip] = y1 * (y[jp*nip+ip] >=0 ? 1:-1); + /* force dateline/greenwich-meridion consitency */ if( nip%2 ) { - if( i == (nip-1)/2 ) { - x[j*nip+i] = 0.0; - x[jp*nip+i] = 0.0; - } + if( i == (nip-1)/2 ) { + x[j*nip+i] = 0.0; + x[jp*nip+i] = 0.0; + } } } } @@ -720,84 +1527,84 @@ void mirror_grid(int ni, int ntiles, double *x, double *y ) for(nt=1; nt(nip-1)/2) ) x2 = M_PI; - } - break; - case 3: /* tile 4 */ - ang = -180.; - rot_3d( 3, x1, y1, z1, ang, &x2, &y2, &z2, 1, 1); /* rotate about the z-axis */ - ang = 90.; - rot_3d( 1, x2, y2, z2, ang, &x1, &y1, &z1, 1, 1); /* rotate about the z-axis */ - x2=x1; - y2=y1; - z2=z1; - - /* force dateline/greenwich-meridion consitency */ - if( nip%2 ) { - if( j == (nip-1)/2 ) x2 = M_PI; - } - break; - case 4: /* tile 5 */ - ang = 90.; - rot_3d( 3, x1, y1, z1, ang, &x2, &y2, &z2, 1, 1); /* rotate about the z-axis */ - ang = 90.; - rot_3d( 2, x2, y2, z2, ang, &x1, &y1, &z1, 1, 1); /* rotate about the z-axis */ - x2=x1; - y2=y1; - z2=z1; - break; - case 5: /* tile 6 */ - ang = 90.; - rot_3d( 2, x1, y1, z1, ang, &x2, &y2, &z2, 1, 1); /* rotate about the z-axis */ - ang = 0.; - rot_3d( 3, x2, y2, z2, ang, &x1, &y1, &z1, 1, 1); /* rotate about the z-axis */ - x2=x1; - y2=y1; - z2=z1; - - /* force South Pole and dateline/greenwich-meridion consitency */ - if(nip%2) { - if( (i==(nip-1)/2) && (i==j) ) { - x2 = 0; - y2 = -M_PI*0.5; - } - - if( (i==(nip-1)/2) && (j>(nip-1)/2) ) x2 = 0; - if( (i==(nip-1)/2) && (j<(nip-1)/2) ) x2 = M_PI; - } - break; - } - x[nt*nip*nip+j*nip+i] = x2; - y[nt*nip*nip+j*nip+i] = y2; + x1 = x[j*nip+i]; + y1 = y[j*nip+i]; + z1 = RADIUS; + switch (nt) { + case 1: /* tile 2 */ + ang = -90.; + rot_3d( 3, x1, y1, z1, ang, &x2, &y2, &z2, 1, 1); /* rotate about the z-axis */ + break; + case 2: /* tile 3 */ + ang = -90.; + rot_3d( 3, x1, y1, z1, ang, &x2, &y2, &z2, 1, 1); /* rotate about the z-axis */ + ang = 90.; + rot_3d( 1, x2, y2, z2, ang, &x1, &y1, &z1, 1, 1); /* rotate about the z-axis */ + x2=x1; + y2=y1; + z2=z1; + + /* force North Pole and dateline/greenwich-meridion consitency */ + if(nip%2) { + if( (i==(nip-1)/2) && (i==j) ) { + x2 = 0; + y2 = M_PI*0.5; + } + + if( (j==(nip-1)/2) && (i<(nip-1)/2) ) x2 = 0; + if( (j==(nip-1)/2) && (i>(nip-1)/2) ) x2 = M_PI; + } + break; + case 3: /* tile 4 */ + ang = -180.; + rot_3d( 3, x1, y1, z1, ang, &x2, &y2, &z2, 1, 1); /* rotate about the z-axis */ + ang = 90.; + rot_3d( 1, x2, y2, z2, ang, &x1, &y1, &z1, 1, 1); /* rotate about the z-axis */ + x2=x1; + y2=y1; + z2=z1; + + /* force dateline/greenwich-meridion consitency */ + if( nip%2 ) { + if( j == (nip-1)/2 ) x2 = M_PI; + } + break; + case 4: /* tile 5 */ + ang = 90.; + rot_3d( 3, x1, y1, z1, ang, &x2, &y2, &z2, 1, 1); /* rotate about the z-axis */ + ang = 90.; + rot_3d( 2, x2, y2, z2, ang, &x1, &y1, &z1, 1, 1); /* rotate about the z-axis */ + x2=x1; + y2=y1; + z2=z1; + break; + case 5: /* tile 6 */ + ang = 90.; + rot_3d( 2, x1, y1, z1, ang, &x2, &y2, &z2, 1, 1); /* rotate about the z-axis */ + ang = 0.; + rot_3d( 3, x2, y2, z2, ang, &x1, &y1, &z1, 1, 1); /* rotate about the z-axis */ + x2=x1; + y2=y1; + z2=z1; + + /* force South Pole and dateline/greenwich-meridion consitency */ + if(nip%2) { + if( (i==(nip-1)/2) && (i==j) ) { + x2 = 0; + y2 = -M_PI*0.5; + } + + if( (i==(nip-1)/2) && (j>(nip-1)/2) ) x2 = 0; + if( (i==(nip-1)/2) && (j<(nip-1)/2) ) x2 = M_PI; + } + break; + } + x[nt*nip*nip+j*nip+i] = x2; + y[nt*nip*nip+j*nip+i] = y2; } } } -}; /* mirror_grid */ +} /* mirror_grid */ /*------------------------------------------------------------------------------- @@ -806,11 +1613,11 @@ void mirror_grid(int ni, int ntiles, double *x, double *y ) degrees to radians if necessary) -----------------------------------------------------------------------------*/ void rot_3d(int axis, double x1in, double y1in, double z1in, double angle, double *x2out, - double *y2out, double *z2out, int degrees, int convert) + double *y2out, double *z2out, int degrees, int convert) { double x1, y1, z1, x2, y2, z2, c, s; - + if(convert) spherical_to_cartesian(x1in, y1in, z1in, &x1, &y1, &z1); else { @@ -843,14 +1650,14 @@ void rot_3d(int axis, double x1in, double y1in, double z1in, double angle, doubl default: mpp_error("Invalid axis: must be 1 for X, 2 for Y, 3 for Z."); } - + if(convert) cartesian_to_spherical(x2, y2, z2, x2out, y2out, z2out); else { *x2out=x2;; *y2out=y2; *z2out=z2; - } + } } /* rot_3d */ /*------------------------------------------------------------- @@ -868,7 +1675,7 @@ void cartesian_to_spherical(double x, double y, double z, double *lon, double *l *lat = acos(z/(*r)) - M_PI/2.; -};/* cartesian_to_spherical */ +}/* cartesian_to_spherical */ /*------------------------------------------------------------------------------- void spherical_to_cartesian @@ -885,7 +1692,7 @@ void spherical_to_cartesian(double lon, double lat, double r, double *x, double /***************************************************************** - double* excess_of_quad(int ni, int nj, double *vec1, double *vec2, + double* excess_of_quad(int ni, int nj, double *vec1, double *vec2, double *vec3, double *vec4 ) *******************************************************************/ double excess_of_quad2(const double *vec1, const double *vec2, const double *vec3, const double *vec4 ) @@ -893,7 +1700,7 @@ double excess_of_quad2(const double *vec1, const double *vec2, const double *vec double plane1[3], plane2[3], plane3[3], plane4[3]; double angle12, angle23, angle34, angle41, excess; double ang12, ang23, ang34, ang41; - + plane_normal2(vec1, vec2, plane1); plane_normal2(vec2, vec3, plane2); plane_normal2(vec3, vec4, plane3); @@ -911,9 +1718,9 @@ double excess_of_quad2(const double *vec1, const double *vec2, const double *vec return excess; -}; /* excess_of_quad */ +} /* excess_of_quad */ -/******************************************************************************* +/******************************************************************************* double angle_between_vectors(const double *vec1, const double *vec2) *******************************************************************************/ @@ -921,7 +1728,7 @@ double angle_between_vectors2(const double *vec1, const double *vec2) { int n; double vector_prod, nrm1, nrm2; double angle; - + vector_prod=vec1[0]*vec2[0] + vec1[1]*vec2[1] + vec1[2]*vec2[2]; nrm1=pow(vec1[0],2)+pow(vec1[1],2)+pow(vec1[2],2); nrm2=pow(vec2[0],2)+pow(vec2[1],2)+pow(vec2[2],2); @@ -929,9 +1736,9 @@ double angle_between_vectors2(const double *vec1, const double *vec2) { angle = acos( vector_prod/sqrt(nrm1*nrm2) ); else angle = 0; - + return angle; -}; /* angle_between_vectors */ +} /* angle_between_vectors */ /*********************************************************************** @@ -941,7 +1748,7 @@ double angle_between_vectors2(const double *vec1, const double *vec2) { void plane_normal2(const double *P1, const double *P2, double *plane) { double mag; - + plane[0] = P1[1] * P2[2] - P1[2] * P2[1]; plane[1] = P1[2] * P2[0] - P1[0] * P2[2]; plane[2] = P1[0] * P2[1] - P1[1] * P2[0]; @@ -951,8 +1758,8 @@ void plane_normal2(const double *P1, const double *P2, double *plane) plane[1]=plane[1]/mag; plane[2]=plane[2]/mag; } - -}; /* plane_normal */ + +} /* plane_normal */ /****************************************************************** @@ -964,87 +1771,93 @@ void calc_rotation_angle2(int nxp, double *x, double *y, double *angle_dx, doubl { int ip1, im1, jp1, jm1, tp1, tm1, i, j, n, ntiles, nx; double lon_scale; + unsigned int n1, n2, n3; nx = nxp-1; ntiles = 6; for(n=0; n= nxp) { /* find the neighbor tile. */ - if(n % 2 == 0) { /* tile 1, 3, 5 */ - tp1 = n+1; - ip1 = 0; - } - else { /* tile 2, 4, 6 */ - tp1 = n+2; - if(tp1 >= ntiles) tp1 -= ntiles; - ip1 = nx-j-1; - jp1 = 0; - } - } + if(n % 2 == 0) { /* tile 1, 3, 5 */ + tp1 = n+1; + ip1 = 0; + } + else { /* tile 2, 4, 6 */ + tp1 = n+2; + if(tp1 >= ntiles) tp1 -= ntiles; + ip1 = nx-j-1; + jp1 = 0; + } + } if(im1 < 0) { /* find the neighbor tile. */ - if(n % 2 == 0) { /* tile 1, 3, 5 */ - tm1 = n-2; - if(tm1 < 0) tm1 += ntiles; - jm1 = nx; - im1 = nx-j; - } - else { /* tile 2, 4, 6 */ - tm1 = n-1; - im1 = nx; - } - } - - angle_dx[n*nxp*nxp+j*nxp+i] = atan2(y[tp1*nxp*nxp+jp1*nxp+ip1]-y[tm1*nxp*nxp+jm1*nxp+im1], - (x[tp1*nxp*nxp+jp1*nxp+ip1]-x[tm1*nxp*nxp+jm1*nxp+im1])*lon_scale )*R2D; - tp1 = n; - tm1 = n; - ip1 = i; - im1 = i; - jp1 = j+1; - jm1 = j-1; + if(n % 2 == 0) { /* tile 1, 3, 5 */ + tm1 = n-2; + if(tm1 < 0) tm1 += ntiles; + jm1 = nx; + im1 = nx-j; + } + else { /* tile 2, 4, 6 */ + tm1 = n-1; + im1 = nx; + } + } + n1 = n*nxp*nxp+j*nxp+i; + n2 = tp1*nxp*nxp+jp1*nxp+ip1; + n3 = tm1*nxp*nxp+jm1*nxp+im1; + angle_dx[n1] = atan2( y[n2]-y[n3], (x[n2]-x[n3])*lon_scale )*R2D; + tp1 = n; + tm1 = n; + ip1 = i; + im1 = i; + jp1 = j+1; + jm1 = j-1; + if(jp1 >=nxp) { /* find the neighbor tile. */ - if(n % 2 == 0) { /* tile 1, 3, 5 */ - tp1 = n+2; - if(tp1 >= ntiles) tp1 -= ntiles; - jp1 = nx-i; - ip1 = 0; - } - else { /* tile 2, 4, 6 */ - tp1 = n+1; - if(tp1 >= ntiles) tp1 -= ntiles; - jp1 = 0; - } - } + if(n % 2 == 0) { /* tile 1, 3, 5 */ + tp1 = n+2; + if(tp1 >= ntiles) tp1 -= ntiles; + jp1 = nx-i; + ip1 = 0; + } + else { /* tile 2, 4, 6 */ + tp1 = n+1; + if(tp1 >= ntiles) tp1 -= ntiles; + jp1 = 0; + } + } if(jm1 < 0) { /* find the neighbor tile. */ - if(n % 2 == 0) { /* tile 1, 3, 5 */ - tm1 = n-1; - if(tm1 < 0) tm1 += ntiles; - jm1 = nx; - } - else { /* tile 2, 4, 6 */ - tm1 = n-2; - if(tm1 < 0) tm1 += ntiles; - im1 = nx; - jm1 = nx-i; - } - } - - angle_dy[n*nxp*nxp+j*nxp+i] = atan2(y[tp1*nxp*nxp+jp1*nxp+ip1]-y[tm1*nxp*nxp+jm1*nxp+im1], - (x[tp1*nxp*nxp+jp1*nxp+ip1]-x[tm1*nxp*nxp+jm1*nxp+im1])*lon_scale )*R2D; + if(n % 2 == 0) { /* tile 1, 3, 5 */ + tm1 = n-1; + if(tm1 < 0) tm1 += ntiles; + jm1 = nx; + } + else { /* tile 2, 4, 6 */ + tm1 = n-2; + if(tm1 < 0) tm1 += ntiles; + im1 = nx; + jm1 = nx-i; + } + } + + n1 = n*nxp*nxp+j*nxp+i; + n2 = tp1*nxp*nxp+jp1*nxp+ip1; + n3 = tm1*nxp*nxp+jm1*nxp+im1; + angle_dy[n1] = atan2( y[n2]-y[n3], (x[n2]-x[n3])*lon_scale )*R2D; } } } -}; /* calc_rotation_angle2 */ +} /* calc_rotation_angle2 */ /* This routine calculate center location based on the vertices location */ @@ -1054,7 +1867,7 @@ void cell_center(int ni, int nj, const double *lonc, const double *latc, double int nip, njp, i, j, p, p1, p2, p3, p4; double *xc, *yc, *zc, *xt, *yt, *zt; double dd; - + nip = ni+1; njp = nj+1; xc = (double *)malloc(nip*njp*sizeof(double)); @@ -1062,24 +1875,24 @@ void cell_center(int ni, int nj, const double *lonc, const double *latc, double zc = (double *)malloc(nip*njp*sizeof(double)); xt = (double *)malloc(ni *nj *sizeof(double)); yt = (double *)malloc(ni *nj *sizeof(double)); - zt = (double *)malloc(ni *nj *sizeof(double)); - latlon2xyz(nip*njp, lonc, latc, xc, yc, zc); + zt = (double *)malloc(ni *nj *sizeof(double)); + latlon2xyz(nip*njp, lonc, latc, xc, yc, zc); for(j=0; j max_nj){ + jcf = max_nj;//then use the uppr (last) row data + //fprintf(stderr, "[INFO] index_an_gr : jcf=%d max_nj=%d\n",jcf, max_nj); + if(is_gr == 0){ + mpp_error("make_hgrid in index_ar_gr, jcf > max_nj"); + } + } + if(icf > max_ni){ + icf = max_ni;//then use the rightmost column data + //fprintf(stderr, "[INFO] index_an_gr : icf=%d max_ni=%d\n",icf, max_ni); + if(is_gr == 0){ + mpp_error("make_hgrid in index_ar_gr, icf > max_ni"); + } + } + return ( jcf * p_npi + icf ); +} -/* void setup_aligned_nest */ - -/* - -ni_parent : parent grid size in x-direction. -nj_parent : parent grid size in y-direction. +/* void setup_aligned_nest + parent_ni : (input) parent grid size in x-direction. + parent_nj : (input) parent grid size in y-direction. + parent_xc : (input) parent array in x-direction + parent_yc : (input) parent array in y-direction + halo : (input) halo size + refine_ratio : (input) refinement ratio + istart : (input) start of nest in x direction + iend : (input) end of nest in x direction + jstart : (input) start of nest in y direction + jend : (input) end of nest in y direction + xc : (output) nest array in x-direction + yc : (output) nest array in y-direction */ - - void setup_aligned_nest(int parent_ni, int parent_nj, const double *parent_xc, const double *parent_yc, - int halo, int refine_ratio, int istart, int iend, int jstart, int jend, - double *xc, double *yc) + int halo, int refine_ratio, int istart, int iend, int jstart, int jend, + double *xc, double *yc, int is_gr) { - double q1[2], q2[2], t1[2], t2[2], p1[0], p2[0]; + double q1[2], q2[2], t1[2], t2[2]; double two_pi; int ni, nj, npi, npj; int parent_npi, i, j, ic, jc, imod, jmod; - + int verbose = 1; + two_pi = 2.*M_PI; - + /* Check that the grid does not lie outside its parent */ if( (jstart - halo) < 1 || (istart - halo) < 1 || (jend + halo) > parent_nj || (iend + halo) > parent_ni ) mpp_error("create_gnomonic_cubic_grid(setup_aligned_nest): nested grid lies outside its parent"); + if (verbose) { + fprintf(stderr, "[INFO] setup_aligned nest: parent_ni: %d parent_nj: %d refine_ratio: %d parent_xc: %p parent_yc: %p\n", + parent_ni, parent_nj, refine_ratio, (void *)parent_xc, (void *)parent_yc); + + } + ni = (iend-istart+1)*refine_ratio; nj = (jend-jstart+1)*refine_ratio; npi = ni+1; npj = nj+1; parent_npi = parent_ni+1; - + for(j=0; j two_pi ) xc[j*npi+i] -= two_pi; if( xc[j*npi+i] < 0. ) xc[j*npi+i] += two_pi; - } - } -} + if (verbose && (j==0)) { + if (i==0) { + printf("setup_aligned_nest xc[0]: %f yc[0]: %f\n", xc[0], yc[0]); + } else if (i==1) { + printf("setup_aligned_nest xc[1]: %f yc[1]: %f\n", xc[1], yc[1]); + } + } + } + }//end j loop +} diff --git a/sorc/fre-nctools.fd/tools/make_hgrid/create_grid_from_file.c b/sorc/fre-nctools.fd/tools/make_hgrid/create_grid_from_file.c index 7ff06e218..f6ecd7128 100644 --- a/sorc/fre-nctools.fd/tools/make_hgrid/create_grid_from_file.c +++ b/sorc/fre-nctools.fd/tools/make_hgrid/create_grid_from_file.c @@ -21,6 +21,7 @@ void get_grid_v1(int fid, double *xt, double *yt, double *xc, double *yc); void get_grid_v2(int fid, int nlon, int nlat, double *xt, double *yt, double *xc, double *yc); void get_grid_v3(int fid, int nlon, int nlat, double *xt, double *yt, double *xc, double *yc); void get_grid_v4(int fid, int nlon, int nlat, double *xt, double *yt, double *xc, double *yc); +void get_grid_v5(int fid, double *xt, double *yt, double *xc, double *yc, int ni, int nj); /*********************************************************************** void create_grid_from_file( char *file, int *nlon, int *nlat, double *x, double *y, double *dx, @@ -57,8 +58,10 @@ void create_grid_from_file( char *file, int *nlon, int *nlat, double *x, double yt = (double *)malloc( ni * nj *sizeof(double)); fid = mpp_open(file, MPP_READ); - if(mpp_dim_exist(fid, "grid_xt") ) + if(mpp_dim_exist(fid, "grid_xt") && mpp_var_exist(fid, "grid_lon") ) get_grid_v1(fid, xt, yt, xc, yc); + else if(mpp_dim_exist(fid, "grid_xt") && mpp_var_exist(fid, "grid_xt") ) + get_grid_v5(fid, xt, yt, xc, yc, ni, nj); else if(mpp_dim_exist(fid, "rlon") || mpp_dim_exist(fid, "i") ) get_grid_v2(fid, ni, nj, xt, yt, xc, yc); else if(mpp_dim_exist(fid, "lon") ) @@ -229,6 +232,62 @@ void get_grid_v1(int fid, double *xt, double *yt, double *xc, double *yc) } +void get_grid_v5(int fid, double *xt, double *yt, double *xc, double *yc, int ni, int nj) +/* calculated based on grid_xt and grid_yt. We assume cyclic boundary condition + in x-direction. The latitude is between -90 and 90. Also assume the grid is regular lat-lon grid. +*/ +{ + int vid; + double *grid_xt=NULL, *grid_yt=NULL; + double x1, x2, is_reverse; + int i,j; + + + grid_xt = (double *)malloc(ni*sizeof(double)); + grid_yt = (double *)malloc(nj*sizeof(double)); + vid = mpp_get_varid(fid, "grid_xt"); + mpp_get_var_value(fid, vid, grid_xt); + vid = mpp_get_varid(fid, "grid_yt"); + mpp_get_var_value(fid, vid, grid_yt); + + if(grid_yt[0] >0.) + is_reverse = 1; + else + is_reverse = 0; + + + for(j=0; j x2 + 180) x1-=360; + xc[0] = 0.5*(x1+x2); + xc[ni] = xc[0] + 360.; + for(i=1; i 1.e-6 ) { printf("%d\n",nyp); printf("%s\n" ,"Note: End point resolutions differ for y-axis. Not suitable for periodic axes"); printf("%s\n" ," See documentation for generating periodic axes when center = 'c_cell'"); - } - + } + set_regular_lonlat_grid( nxp, nyp, *isc, *iec, *jsc, *jec, xb, yb, x, y, dx, dy, area, angle_dx, use_great_circle_algorithm); free(xb); free(yb); - + }; /* create_regular_lonlat_grid */ @@ -114,7 +115,7 @@ void create_simple_cartesian_grid( double *xbnds, double *ybnds, int *nlon, int nx = *nlon; ny = *nlat; nxp = nx + 1; - nyp = ny + 1; + nyp = ny + 1; /* use cubic-spline interpolation algorithm to calculate nominal zonal grid location. */ xb = (double *)malloc(nxp*sizeof(double)); grid1 = (double *)malloc(nxb*sizeof(double)); @@ -147,15 +148,15 @@ void create_simple_cartesian_grid( double *xbnds, double *ybnds, int *nlon, int nxc = *iec - *isc + 1; nyc = *jec - *jsc + 1; - + for(n = 0; n< nxc*(nyc+1); n++) dx[n] = *simple_dx; for(n = 0; n< (nxc+1)*nyc; n++) dy[n] = *simple_dy; for(n = 0; n< nxc*nyc; n++) area[n] = (*simple_dx)*(*simple_dy); for(n = 0; n< (nxc+1)*(nyc+1); n++) angle_dx[n] = 0; - + free(xb); free(yb); - + }; /* create_simple_cartesian_grid */ @@ -172,10 +173,10 @@ void create_spectral_grid( int *nlon, int *nlat, int *isc, int *iec, const int itermax = 10; const double epsln = 1e-15; int ni, nj, nx, ny, nxp, nyp, i, j, converge, iter; - double dlon, z, p1, p2, p3, z1, pp, a, b, c, d, sum_wts; + double dlon, z, p1, p2, p3, z1, pp, a, b, c, d, sum_wts; double *xb, *yb, *lon, *lonb, *lat, *latb; double *sin_hem, *wts_hem, *sin_lat, *wts_lat; - + nx = *nlon; ny = *nlat; nxp = nx + 1; @@ -257,8 +258,8 @@ void create_spectral_grid( int *nlon, int *nlat, int *isc, int *iec, free(sin_hem); free(wts_hem); free(sin_lat); - free(wts_lat); - + free(wts_lat); + }; /* create_spectral_grid */ /******************************************************************************* @@ -266,15 +267,15 @@ void create_spectral_grid( int *nlon, int *nlat, int *isc, int *iec, double *xb, double *yb, double *x, double *y, double *dx, double *dy, double *area, double *angle ) set geographic grid location, calculate grid length, area and rotation angle - x and y are on global domain, the other fields are on compute domain + x and y are on global domain, the other fields are on compute domain *******************************************************************************/ void set_regular_lonlat_grid( int nxp, int nyp, int isc, int iec, int jsc, int jec, double *xb, double *yb, double *x, double *y, double *dx, double *dy, double *area, double *angle, int use_great_circle_algorithm) { - int n, i, j; + long n, i, j; double lon[4], lat[4]; - + n = 0; for(j=0; j 1.e-6 ) { @@ -376,7 +377,7 @@ void create_tripolar_grid( int *nxbnds, int *nybnds, double *xbnds, double *ybnd printf("%s\n" ,"Note: End point resolutions differ for x-axis. Not suitable for periodic axes"); printf("%s\n" ," See documentation for generating periodic axes when center = 'c_cell'"); } - + n = 0; for(j=0; j 1.e-6 ) { printf("%d\n",nyp); printf("%s\n" ,"Note: End point resolutions differ for y-axis. Not suitable for periodic axes"); printf("%s\n" ," See documentation for generating periodic axes when center = 'c_cell'"); - } - + } + set_f_plane_grid( nxp, nyp, *isc, *iec, *jsc, *jec, xb, yb, f_plane_latitude, x, y, dx, dy, area, angle_dx); free(xb); free(yb); - + }; /* create_f_plane_grid */ @@ -597,7 +598,7 @@ double cartesian_dist(double x1, double y1, double x2, double y2, double f_plane if(x1 == x2) dist = fabs(y2-y1)*D2R*RADIUS; - else if(y1 == y2) + else if(y1 == y2) dist = fabs(x2-x1)*D2R*RADIUS*cos(f_plane_latitude*D2R); else mpp_error("create_lonlat_grid: This is not rectangular grid"); @@ -605,7 +606,7 @@ double cartesian_dist(double x1, double y1, double x2, double y2, double f_plane return dist; } - + /* rectangular grid box area for cartesian grid */ double cartesian_box_area(double x1, double y1, double x2, double y2, double f_plane_latitude) { @@ -620,4 +621,3 @@ double cartesian_box_area(double x1, double y1, double x2, double y2, double f_p return area; } - diff --git a/sorc/fre-nctools.fd/tools/make_hgrid/make_hgrid.c b/sorc/fre-nctools.fd/tools/make_hgrid/make_hgrid.c index 7543ba14b..06fcff476 100644 --- a/sorc/fre-nctools.fd/tools/make_hgrid/make_hgrid.c +++ b/sorc/fre-nctools.fd/tools/make_hgrid/make_hgrid.c @@ -4,6 +4,17 @@ @author Zhi Liang (Zhi.Liang@noaa.gov) NOAA Geophysical Fluid Dynamics Lab, Princeton, NJ + Modifications: + 05/10/2020 -- Added multiple nest capability. Bill Ramstrom, AOML/HRD + 11/23/2020 -- Updated usage statement, sanity check w/runs against + new FV3 dycore codebase. Modify refine_ratio option for + global grid refinement (old code no longer valid, + see comment with tag [Ahern]). Formatting changes. + Kyle Ahern, AOML/HRD + 4/12/2021 -- Fixed several IMAs (Invalid Memory Access), memory leaks, and some + non-critical compiler warnings. Some notes in create_gnomonic_cubic_grid + concerning changes related to global refinement runs. + M Zuniga */ #include #include @@ -19,6 +30,7 @@ const int MAXBOUNDS = 100; const int STRINGLEN = 255; + #define REGULAR_LONLAT_GRID 1 #define TRIPOLAR_GRID 2 #define FROM_FILE 3 @@ -48,8 +60,15 @@ char *usage[] = { " --simple_dx simple_dx --simple_dy simple_dy ", " --grid_name gridname --center center --verbose --shift_fac # ", " --do_schmidt --stretch_fac # --target_lon # --target_lat # ", - " --nest_grid --parent_tile # --refine_ratio # --halo # ", - " --istart_nest # --iend_nest # --jstart_nest # --jend_nest # ", + " --do_cube_transform ", + " --nest_grids nests ", + " --parent_tile parent_tile(1),...parent_tile(nests-1) ", + " --refine_ratio refine_ratio(1),...refine_ratio(nests-1) ", + " --halo # ", + " --istart_nest istart_nest(1),...istart_nest(nests-1) ", + " --iend_nest iend_nest(1),...iend_nest(nests-1) ", + " --jstart_nest jstart_nest(1),...jstart_nest(nests-1) ", + " --jend_nest jend_nest(1),...jend_nest(nests-1) ", " --great_circle_algorithm --out_halo # ", " ", " This program can generate different types of horizontal grid. The ", @@ -140,7 +159,7 @@ char *usage[] = { " ", " --nlon nlon(1),..,nlon(nxbnds-1) Number of model grid points(supergrid) for ", " each zonal regions of varying resolution. ", - " ", + " ", " --nlat nlat(1),..,nlat(nybnds-1) Number of model grid points(supergid) for ", " each meridinal regions of varying resolution.", " ", @@ -158,7 +177,7 @@ char *usage[] = { " simple cartesian grid. ", " ", " --simple_dy dimple_dy Specify the uniform cell length in y-direction for ", - " simple cartesian grid. ", + " simple cartesian grid. ", " ", " --grid_name grid_name Specify the grid name. The output grid file name ", " will be grid_name.nc if there is one tile and ", @@ -179,37 +198,74 @@ char *usage[] = { " following must be set: --stretch_factor, ", " --target_lon and --target_lat. ", " ", + " --do_cube_transform re-orient the rotated cubed sphere so that tile 6 ", + " has 'north' facing upward, which would make ", + " analysis and explaining nest placement much easier.", + " When do_cube_transform is set, the following must ", + " be set: --stretch_factor, --latget_lon, and ", + " --target_lat. ", + " ", " --stretch_factor # Stretching factor for the grid ", " ", " --target_lon # center longitude of the highest resolution tile ", " ", " --target_lat # center latitude of the highest resolution tile ", " ", - " --nest_grid set to create nest grid as well as the global grid.", + " --nest_grids nests set to create this # nested grids as well as the ", + " global grid. This replaces the option --nest_grid. ", " This option could only be set when grid_type is ", " 'gnomonic_ed'. When it is set, besides 6 tile grid ", - " files created, there is one more nest grid with ", + " files created, there are # more nest grids with ", " file name = $grid_name.tile${parent_tile}.nest.nc ", " ", - " --parent_tile # Specify the parent tile number of nest grid. ", - " ", - " --refine_ratio # Specify the refinement ratio for nest grid. ", - " ", - " --istart_nest # Specify the starting i-direction index of nest ", - " grid in parent tile supergrid(Fortran index). ", - " ", - " --iend_nest # Specify the ending i-direction index of nest ", - " grid in parent tile supergrid(Fortran index). ", - " ", - " --jstart_nest # Specify the starting j-direction index of nest ", - " grid in parent tile supergrid(Fortran index). ", - " ", - " --jend_nest # Specify the ending j-direction index of nest ", - " grid in parent tile supergrid(Fortran index). ", - " ", - " --halo # halo size to used in the atmosphere cubic sphere ", - " model. It only needs to be specified when ", - " --nest_grid is set. ", + " --nest_grids=1 --parent_tile=0 This option activates global refinement (GR); ", + " 'gnomonic_ed' is a required co-option. GR is a ", + " method of creating two grids, such that the higher ", + " resolution one overlays the course one with ", + " identical intersecting points. GR is no longer ", + " supported as we revisit its requirements. Please ", + " create a github issue if you are using this feature", + " (see https://github.com/NOAA-GFDL/FRE-NCtools). ", + " Grid generating behavior for GR has changed with ", + " release 18.1. We believe the behavior is more ", + " correct now (memory access bugs fixed) but use at ", + " your own risk. ", + " ", + " --parent_tile parent_tile(1),...parent_tile(nests-1) ", + " Specify the comma-separated list of the parent tile", + " number(s) of nest grid(s). ", + " ", + " --refine_ratio refine_ratio(1),...refine_ratio(nests-1) ", + " Specify the comma-separated list of refinement ", + " ratio(s) for nest grid(s). ", + " ", + " --halo # halo size is used in the atmosphere cubic sphere ", + " model. Its purpose is to make sure the nest, ", + " including the halo region, is fully contained ", + " within a single parent (coarse) tile. The option ", + " may be obsolete and removed in future development. ", + " It only needs to be specified when --nest_grid(s) ", + " is set. ", + " ", + " --istart_nest istart_nest(1),...istart_nest(nests-1) ", + " Specify the comma-separated list of starting ", + " i-direction index(es) of nest ", + " grid(s) in parent tile supergrid(Fortran index). ", + " ", + " --iend_nest iend_nest(1),...iend_nest(nests-1) ", + " Specify the comma-separated list of ending ", + " i-direction index(es) of nest ", + " grids in parent tile supergrid(Fortran index). ", + " ", + " --jstart_nest jstart_nest(1),...jstart_nest(nests-1) ", + " Specify the comma-separated list of starting ", + " j-direction index(es) of nest ", + " grids in parent tile supergrid(Fortran index). ", + " ", + " --jend_nest jend_nest(1),...jend_nest(nests-1) ", + " Specify the comma-separated list of ending ", + " j-direction index(es) of nest ", + " grids in parent tile supergrid(Fortran index). ", " ", " --great_circle_algorithm When specified, great_circle_algorithm will be ", " used to compute grid cell area. ", @@ -217,11 +273,14 @@ char *usage[] = { " --out_halo # extra halo size data to be written out. This is ", " only works for gnomonic_ed. ", " ", + " --non_length_angle When specified, will not output length(dx,dy) and ", + " angle (angle_dx, angle_dy) ", + " ", " --verbose Will print out running time message when this ", " option is set. Otherwise the run will be silent ", " when there is no error. ", " ", - " Example ", + " Example ", " ", " ", " 1. generating regular lon-lat grid (supergrid size 60x20) ", @@ -241,7 +300,7 @@ char *usage[] = { " --ybnd -82,-30,-10,0,10,30,90 --dlon 1.0,1.0 ", " --dlat 1.0,1.0,0.6666667,0.3333333,0.6666667,1.0,1.0 ", " --grid_name om3_grid --center c_cell ", - " ", + " ", " 4. generating simple cartesian grid(supergrid size 20x20) ", " > make_hgrid --grid_type simple_cartesian_grid --xbnd 0,30 --ybnd 50,60 ", " --nlon 20 --nlat 20 --simple_dx 1000 --simple_dy 1000 ", @@ -252,23 +311,30 @@ char *usage[] = { " 6. generating gnomonic cubic grid with equal_dist_face_edge(C48 grid) ", " > make_hgrid --grid_type gnomonic_ed --nlon 96 ", " ", - " 7. generating gnomonic cubic streched grid. ", + " 7. generating gnomonic cubic stretched grid. ", " > make_hgrid --grid_type gnomonic_ed --nlon 180 --do_schmidt ", " --stretch_factor 3 --target_lat 40. --target_lon 20. ", " ", - " 8. generating spectral grid. (supergrid size 128x64) ", + " 8. generating gnomonic cubic stretched grid with two nests on tile 6. ", + " > make_hgrid --grid_type gnomonic_ed --nlon 192 --do_schmidt ", + " --stretch_factor 3 --target_lat 10. --target_lon 20. ", + " --nest_grids 2 --parent_tile 6,6 --refine_ratio 2,2 ", + " --istart_nest 11,51 --jstart_nest 11,51 ", + " --iend_nest 42,82 --jend_nest 42,82 --halo 3 ", + " ", + " 9. generating spectral grid. (supergrid size 128x64) ", " > make_hgrid --grid_type spectral_grid --nlon 128 --nlat 64 ", " ", - " 9. Through user-defined grids ", + " 10. Through user-defined grids ", " > make_hgrid --grid_type from_file --my_grid_file my_grid_file ", " --nlon 4 --nlat 4 ", " ", " contents of sample my_grid_file ", - " The first line of my_grid_file will be text ( will be ignored) ", + " The first line of my_grid_file will be text ( will be ignored) ", " followed by nlon+1 lines of real value of x-direction supergrid bound ", " location. Then another line of text ( will be ignored), followed by ", " nlat+1 lines of real value of y-direction supergrid bound location. ", - " ", + " ", " For example: ", " ", " x-grid ", @@ -282,9 +348,9 @@ char *usage[] = { " 10 ", " 20 ", " 30 ", - " 40 ", + " 40 ", " ", - " 10. generating f_plane_grids ", + " 11. generating f_plane_grids ", " > make_hgrid --grid_type f_plane_grid --f_plane_latitude 55 --nxbnd 2 ", " --nybnd 2 --xbnd 0,30 --ybnd 50,60 --nlon 60 --nlat 20 ", " ", @@ -326,26 +392,51 @@ char grid_version[] = "0.2"; char tagname[] = "$Name: fre-nctools-bronx-10 $"; +int parse_comma_list(char *arg_list, int var_array[MAX_NESTS]) +{ + int i = 0; + int j; + char *ptr = strtok(arg_list, ","); + + while(ptr != NULL && i < MAX_NESTS) + { + var_array[i] = atoi(ptr); + ptr = strtok(NULL, ","); + i++; + } + + + for (j=i+1; j < MAX_NESTS; j++) + { + var_array[j] = 0; + } + + return i; +} + + + void fill_cubic_grid_halo(int nx, int ny, int halo, double *data, double *data1_all, - double *data2_all, int tile, int ioff, int joff) + double *data2_all, int tile, int ioff, int joff) { int lw, le, ls, ln; int ntiles,nxp,nyp,nxph,nyph,i,j; - + nxp = nx+ioff; nyp = ny+joff; nxph = nx+ioff+2*halo; nyph = ny+joff+2*halo; - + for(i=0; i 1) mpp_error( "make_hgrid: make_hgrid must be run one processor, contact developer"); - + /* * process command line */ errflg = argc <3; - + while ((c = getopt_long(argc, argv, "", long_options, &option_index)) != -1) { switch (c) { case 'a': @@ -500,7 +605,7 @@ int main(int argc, char* argv[]) break; case 'd': nybnds0 = atoi(optarg); - break; + break; case 'e': strcpy(entry, optarg); nxbnds1 = get_double_entry(entry, xbnds); @@ -519,10 +624,10 @@ int main(int argc, char* argv[]) break; case 'j': lat_join = atof(optarg); - break; + break; case 'k': nratio = atoi(optarg); - break; + break; case 'l': simple_dx = atof(optarg); break; @@ -562,25 +667,29 @@ int main(int argc, char* argv[]) target_lat = atof(optarg); break; case 'A': - nest_grid = 1; + nest_grids = atoi(optarg); + break; + case 'Z': + // Backwards compatibility -- allow single nest + nest_grids = 1; break; case 'B': - refine_ratio = atoi(optarg); + num_nest_args = parse_comma_list(optarg, refine_ratio); break; case 'C': - parent_tile = atoi(optarg); + num_nest_args = parse_comma_list(optarg, parent_tile); break; case 'D': - istart_nest = atoi(optarg); + num_nest_args = parse_comma_list(optarg, istart_nest); break; case 'E': - iend_nest = atoi(optarg); + num_nest_args = parse_comma_list(optarg, iend_nest); break; case 'F': - jstart_nest = atoi(optarg); + num_nest_args = parse_comma_list(optarg, jstart_nest); break; case 'G': - jend_nest = atoi(optarg); + num_nest_args = parse_comma_list(optarg, jend_nest); break; case 'H': halo = atoi(optarg); @@ -593,32 +702,39 @@ int main(int argc, char* argv[]) break; case 'K': out_halo = atoi(optarg); - break; + break; + case 'L': + do_cube_transform = 1; + break; + case 'M': + output_length_angle = 0; + break; case 'v': verbose = 1; break; case 'h': errflg++; break; + + case '?': - errflg++; - } + errflg++; + } } - - if (errflg ) { + + if (errflg) { char **u = usage; while (*u) { fprintf(stderr, "%s\n", *u); u++; } exit(2); - } + } /* define history to be the history in the grid file */ strcpy(history,argv[0]); - for(i=1;iNOTE: the grid type is %s\n",grid_type); if(strcmp(grid_type,"regular_lonlat_grid") ==0 ) @@ -641,17 +757,23 @@ int main(int argc, char* argv[]) my_grid_type = BETA_PLANE_GRID; else mpp_error("make_hgrid: only grid_type = 'regular_lonlat_grid', 'tripolar_grid', 'from_file', " - "'gnomonic_ed', 'conformal_cubic_grid', 'simple_cartesian_grid', " - "'spectral_grid', 'f_plane_grid' and 'beta_plane_grid' is implemented"); + "'gnomonic_ed', 'conformal_cubic_grid', 'simple_cartesian_grid', " + "'spectral_grid', 'f_plane_grid' and 'beta_plane_grid' is implemented"); if(my_grid_type != GNOMONIC_ED && out_halo != 0) mpp_error("make_hgrid: out_halo should not be set when grid_type = gnomonic_ed"); if(out_halo !=0 && out_halo != 1) mpp_error("make_hgrid: out_halo should be 0 or 1"); - - if( my_grid_type != GNOMONIC_ED && do_schmidt ) + + if( my_grid_type != GNOMONIC_ED && do_schmidt ) mpp_error("make_hgrid: --do_schmidt should not be set when grid_type is not 'gnomonic_ed'"); - + + if ( my_grid_type != GNOMONIC_ED && do_cube_transform ) + mpp_error("make_hgrid: --do_cube_transform should not be set when grid_type is not 'gnomonic_ed'"); + + if ( do_cube_transform && do_schmidt ) + mpp_error("make_hgrid: both --do_cube_transform and --do_schmidt are set"); + use_legacy = 0; /* check the command-line arguments to make sure the value are suitable */ if( my_grid_type == REGULAR_LONLAT_GRID || my_grid_type == TRIPOLAR_GRID || @@ -659,11 +781,11 @@ int main(int argc, char* argv[]) int num_specify; nxbnds = nxbnds0; nybnds = nybnds0; if( nxbnds <2 || nybnds < 2) mpp_error("make_hgrid: grid type is 'regular_lonlat_grid', 'tripolar_grid', 'f_plane_grid' or 'beta_plane_grid', " - "both nxbnds and nybnds should be no less than 2"); + "both nxbnds and nybnds should be no less than 2"); if( nxbnds != nxbnds1 ) mpp_error("make_hgrid: grid type is 'regular_lonlat_grid, 'tripolar_grid', 'f_plane_grid' or 'beta_plane_grid', " - "nxbnds does not match number of entry in xbnds"); + "nxbnds does not match number of entry in xbnds"); if( nybnds != nybnds1 ) mpp_error("make_hgrid: grid type is 'regular_lonlat_grid, 'tripolar_grid', 'f_plane_grid' or 'beta_plane_grid', " - "nybnds does not match number of entry in ybnds"); + "nybnds does not match number of entry in ybnds"); num_specify = 0; if( nxbnds2 > 0 && nybnds2 > 0 ) num_specify ++; if( nxbnds3 > 0 && nybnds3 > 0 ) { @@ -672,32 +794,32 @@ int main(int argc, char* argv[]) } if( num_specify == 0 ) mpp_error("make_hgrid: grid type is 'regular_lonlat_grid', 'tripolar_grid', 'f_plane_grid' or 'beta_plane_grid', " - "need to specify one of the pair --nlon --nlat or --dlon --dlat"); + "need to specify one of the pair --nlon --nlat or --dlon --dlat"); if( num_specify == 2 ) mpp_error("make_hgrid: grid type is 'regular_lonlat_grid', 'tripolar_grid', 'f_plane_grid' or 'beta_plane_grid', " - "can not specify both --nlon --nlat and --dlon --dlat"); + "can not specify both --nlon --nlat and --dlon --dlat"); if( use_legacy ) { if( nxbnds != nxbnds3 ) mpp_error("make_hgrid: grid type is 'tripolar_grid', 'tripolar_grid', 'f_plane_grid' or 'beta_plane_grid', " - "nxbnds does not match number of entry in dlon"); + "nxbnds does not match number of entry in dlon"); if( nybnds != nybnds3 ) mpp_error("make_hgrid: grid type is 'tripolar_grid', 'tripolar_grid', 'f_plane_grid' or 'beta_plane_grid', " - "nybnds does not match number of entry in dlat"); + "nybnds does not match number of entry in dlat"); } else { if( nxbnds != nxbnds2+1 ) mpp_error("make_hgrid: grid type is 'tripolar_grid', 'tripolar_grid', 'f_plane_grid' or 'beta_plane_grid', " - "nxbnds does not match number of entry in nlon"); + "nxbnds does not match number of entry in nlon"); if( nybnds != nybnds2+1 ) mpp_error("make_hgrid: grid type is 'tripolar_grid', 'tripolar_grid', 'f_plane_grid' or 'beta_plane_grid', " - "nybnds does not match number of entry in nlat"); + "nybnds does not match number of entry in nlat"); } - } + } if( my_grid_type == CONFORMAL_CUBIC_GRID || my_grid_type == GNOMONIC_ED ) { ntiles = 6; ntiles_global = 6; } - - if( my_grid_type != GNOMONIC_ED && nest_grid ) - mpp_error("make_hgrid: --nest_grid can be set only when grid_type = 'gnomonic_ed'"); - + + if( my_grid_type != GNOMONIC_ED && nest_grids ) + mpp_error("make_hgrid: --nest_grids can be set only when grid_type = 'gnomonic_ed'"); + if( my_grid_type == TRIPOLAR_GRID ) { strcpy(projection, "tripolar"); if( nxbnds != 2) mpp_error("make_hgrid: grid type is 'tripolar_grid', nxbnds should be 2"); @@ -706,123 +828,138 @@ int main(int argc, char* argv[]) /* For ascii file, nlon and nlat should be specified through --nlon, --nlat For netcdf file, grid resolution will be read from grid file */ - + if(ntiles_file == 0) mpp_error("make_hgrid: grid_type is 'from_file', but my_grid_file is not specified"); ntiles = ntiles_file; for(n=0; n= 1) { + for (n=0; n < nest_grids; n++) { + + if(refine_ratio[n] == 0) mpp_error("make_hgrid: --refine_ratio must be set when --nest_grids is set"); + if(parent_tile[n] == 0 && mpp_pe()==mpp_root_pe()) { + fprintf(stderr,"NOTE from make_hgrid: parent_tile is 0, the output grid will have resolution refine_ration*nlon\n"); } else { - if(istart_nest == 0) mpp_error("make_hgrid: --istart_nest must be set when --nest_grid is set"); - if(iend_nest == 0) mpp_error("make_hgrid: --iend_nest must be set when --nest_grid is set"); - if(jstart_nest == 0) mpp_error("make_hgrid: --jstart_nest must be set when --nest_grid is set"); - if(jend_nest == 0) mpp_error("make_hgrid: --jend_nest must be set when --nest_grid is set"); - if(halo == 0 ) mpp_error("make_hgrid: --halo must be set when --nest_grid is set"); - ntiles++; /* one more tile for the nest region */ + if(istart_nest[n] == 0) mpp_error("make_hgrid: --istart_nest must be set when --nest_grids is set"); + if(iend_nest[n] == 0) mpp_error("make_hgrid: --iend_nest must be set when --nest_grids is set"); + if(jstart_nest[n] == 0) mpp_error("make_hgrid: --jstart_nest must be set when --nest_grids is set"); + if(jend_nest[n] == 0) mpp_error("make_hgrid: --jend_nest must be set when --nest_grids is set"); + if(halo == 0 ) mpp_error("make_hgrid: --halo must be set when --nest_grids is set"); + ntiles++; /* one more tile for the nest region */ + if (verbose) fprintf(stderr, "Configuration for nest %d validated.\n", ntiles); } } + + if (verbose) { + fprintf(stderr,"Updated number of tiles, including nests (ntiles): %d\n", ntiles); + } + if(nxbnds2 != 1 ) mpp_error("make_hgrid: grid type is 'gnomonic_cubic_grid', number entry entered " - "through --nlon should be 1"); + "through --nlon should be 1"); } else if( my_grid_type == F_PLANE_GRID || my_grid_type == BETA_PLANE_GRID) { if(f_plane_latitude > 90 || f_plane_latitude < -90.) mpp_error("make_hgrid: f_plane_latitude should be between -90 and 90."); if(f_plane_latitude > ybnds[nybnds-1] || f_plane_latitude < ybnds[0] ) { if(mpp_pe() == mpp_root_pe()) - printf("Warning from make_hgrid: f_plane_latitude is not inside the latitude range of the grid\n"); + fprintf(stderr,"Warning from make_hgrid: f_plane_latitude is not inside the latitude range of the grid\n"); } if(mpp_pe() == mpp_root_pe()) - printf("make_hgrid: setting geometric factor according to f-plane with f_plane_latitude = %g\n", f_plane_latitude ); + fprintf(stderr,"make_hgrid: setting geometric factor according to f-plane with f_plane_latitude = %g\n", f_plane_latitude ); + } + + + + if (verbose) { + fprintf(stderr,"[INFO] make_hgrid.c Number of tiles (ntiles): %d\n", ntiles); + fprintf(stderr,"[INFO] make_hgrid.c Number of global tiles (ntiles_global): %d\n", ntiles_global); } nxl = (int *)malloc(ntiles*sizeof(int)); nyl = (int *)malloc(ntiles*sizeof(int)); - + /* get super grid size */ if(use_legacy) { nxl[0] = get_legacy_grid_size(nxbnds, xbnds, dx_bnds); @@ -830,24 +967,38 @@ int main(int argc, char* argv[]) } else { if( my_grid_type == GNOMONIC_ED || my_grid_type == CONFORMAL_CUBIC_GRID ) { - for(n=0; n ntiles_global) { - nxl[ntiles_global] = (iend_nest-istart_nest+1)*refine_ratio; - nyl[ntiles_global] = (jend_nest-jstart_nest+1)*refine_ratio; + + for (n=ntiles_global; n < ntiles; n++){ + nn = n - ntiles_global; + + nxl[n] = (iend_nest[nn]-istart_nest[nn]+1)*refine_ratio[nn]; + nyl[n] = (jend_nest[nn]-jstart_nest[nn]+1)*refine_ratio[nn]; } } else { nxl[0] = 0; nyl[0] = 0; for(n=0; n1) - sprintf(outfile, "%s.tile%d.nc", gridname, n+1); + sprintf(outfile, "%s.tile%d.nc", gridname, n+1); else - sprintf(outfile, "%s.nc", gridname); + sprintf(outfile, "%s.nc", gridname); + + if (verbose) fprintf(stderr, "Writing out %s.\n", outfile); + fid = mpp_open(outfile, MPP_WRITE); /* define dimenison */ nx = nxl[n]; ny = nyl[n]; + if (verbose) fprintf(stderr, "[INFO] Outputting arrays of size nx: %d and ny: %d for tile: %d\n", nx, ny, n); nxp = nx+1; nyp = ny+1; dimlist[0] = mpp_def_dim(fid, "string", STRINGLEN); @@ -956,117 +1137,154 @@ int main(int argc, char* argv[]) dimlist[4] = mpp_def_dim(fid, "nyp", nyp+2*out_halo); /* define variable */ if( strcmp(north_pole_tile, "none") == 0) /* no north pole, then no projection */ - id_tile = mpp_def_var(fid, "tile", MPP_CHAR, 1, dimlist, 4, "standard_name", "grid_tile_spec", - "geometry", geometry, "discretization", discretization, "conformal", conformal ); - else if( strcmp(projection, "none") == 0) - id_tile = mpp_def_var(fid, "tile", MPP_CHAR, 1, dimlist, 5, "standard_name", "grid_tile_spec", - "geometry", geometry, "north_pole", north_pole_tile, "discretization", - discretization, "conformal", conformal ); + id_tile = mpp_def_var(fid, "tile", MPP_CHAR, 1, dimlist, 4, "standard_name", "grid_tile_spec", + "geometry", geometry, "discretization", discretization, "conformal", conformal ); + else if( strcmp(projection, "none") == 0) + id_tile = mpp_def_var(fid, "tile", MPP_CHAR, 1, dimlist, 5, "standard_name", "grid_tile_spec", + "geometry", geometry, "north_pole", north_pole_tile, "discretization", + discretization, "conformal", conformal ); else - id_tile = mpp_def_var(fid, "tile", MPP_CHAR, 1, dimlist, 6, "standard_name", "grid_tile_spec", - "geometry", geometry, "north_pole", north_pole_tile, "projection", projection, - "discretization", discretization, "conformal", conformal ); - + id_tile = mpp_def_var(fid, "tile", MPP_CHAR, 1, dimlist, 6, "standard_name", "grid_tile_spec", + "geometry", geometry, "north_pole", north_pole_tile, "projection", projection, + "discretization", discretization, "conformal", conformal ); + dims[0] = dimlist[4]; dims[1] = dimlist[3]; id_x = mpp_def_var(fid, "x", MPP_DOUBLE, 2, dims, 2, "standard_name", "geographic_longitude", - "units", "degree_east"); + "units", "degree_east"); if(out_halo>0) mpp_def_var_att_double(fid, id_x, "_FillValue", MISSING_VALUE); id_y = mpp_def_var(fid, "y", MPP_DOUBLE, 2, dims, 2, "standard_name", "geographic_latitude", - "units", "degree_north"); + "units", "degree_north"); if(out_halo>0) mpp_def_var_att_double(fid, id_y, "_FillValue", MISSING_VALUE); - dims[0] = dimlist[4]; dims[1] = dimlist[1]; - id_dx = mpp_def_var(fid, "dx", MPP_DOUBLE, 2, dims, 2, "standard_name", "grid_edge_x_distance", - "units", "meters"); - if(out_halo>0) mpp_def_var_att_double(fid, id_dx, "_FillValue", MISSING_VALUE); - dims[0] = dimlist[2]; dims[1] = dimlist[3]; - id_dy = mpp_def_var(fid, "dy", MPP_DOUBLE, 2, dims, 2, "standard_name", "grid_edge_y_distance", - "units", "meters"); - if(out_halo>0) mpp_def_var_att_double(fid, id_dy, "_FillValue", MISSING_VALUE); + if (output_length_angle) { + dims[0] = dimlist[4]; dims[1] = dimlist[1]; + id_dx = mpp_def_var(fid, "dx", MPP_DOUBLE, 2, dims, 2, "standard_name", "grid_edge_x_distance", + "units", "meters"); + if(out_halo>0) mpp_def_var_att_double(fid, id_dx, "_FillValue", MISSING_VALUE); + dims[0] = dimlist[2]; dims[1] = dimlist[3]; + id_dy = mpp_def_var(fid, "dy", MPP_DOUBLE, 2, dims, 2, "standard_name", "grid_edge_y_distance", + "units", "meters"); + if(out_halo>0) mpp_def_var_att_double(fid, id_dy, "_FillValue", MISSING_VALUE); + } dims[0] = dimlist[2]; dims[1] = dimlist[1]; id_area = mpp_def_var(fid, "area", MPP_DOUBLE, 2, dims, 2, "standard_name", "grid_cell_area", - "units", "m2" ); + "units", "m2" ); if(out_halo>0) mpp_def_var_att_double(fid, id_area, "_FillValue", MISSING_VALUE); - dims[0] = dimlist[4]; dims[1] = dimlist[3]; - id_angle_dx = mpp_def_var(fid, "angle_dx", MPP_DOUBLE, 2, dims, 2, "standard_name", - "grid_vertex_x_angle_WRT_geographic_east", "units", "degrees_east"); - if(out_halo>0) mpp_def_var_att_double(fid, id_angle_dx, "_FillValue", MISSING_VALUE); - if(strcmp(conformal, "true") != 0) { - id_angle_dy = mpp_def_var(fid, "angle_dy", MPP_DOUBLE, 2, dims, 2, "standard_name", - "grid_vertex_y_angle_WRT_geographic_north", "units", "degrees_north"); - if(out_halo>0) mpp_def_var_att_double(fid, id_angle_dy, "_FillValue", MISSING_VALUE); + if (output_length_angle) { + dims[0] = dimlist[4]; dims[1] = dimlist[3]; + id_angle_dx = mpp_def_var(fid, "angle_dx", MPP_DOUBLE, 2, dims, 2, "standard_name", + "grid_vertex_x_angle_WRT_geographic_east", "units", "degrees_east"); + if(out_halo>0) mpp_def_var_att_double(fid, id_angle_dx, "_FillValue", MISSING_VALUE); + if(strcmp(conformal, "true") != 0) { + id_angle_dy = mpp_def_var(fid, "angle_dy", MPP_DOUBLE, 2, dims, 2, "standard_name", + "grid_vertex_y_angle_WRT_geographic_north", "units", "degrees_north"); + if(out_halo>0) mpp_def_var_att_double(fid, id_angle_dy, "_FillValue", MISSING_VALUE); + } } if( strcmp(north_pole_arcx, "none") == 0) - id_arcx = mpp_def_var(fid, "arcx", MPP_CHAR, 1, dimlist, 1, "standard_name", "grid_edge_x_arc_type" ); + id_arcx = mpp_def_var(fid, "arcx", MPP_CHAR, 1, dimlist, 1, "standard_name", "grid_edge_x_arc_type" ); else - id_arcx = mpp_def_var(fid, "arcx", MPP_CHAR, 1, dimlist, 2, "standard_name", "grid_edge_x_arc_type", - "north_pole", north_pole_arcx ); + id_arcx = mpp_def_var(fid, "arcx", MPP_CHAR, 1, dimlist, 2, "standard_name", "grid_edge_x_arc_type", + "north_pole", north_pole_arcx ); mpp_def_global_att(fid, "grid_version", grid_version); mpp_def_global_att(fid, "code_version", tagname); if(use_great_circle_algorithm) mpp_def_global_att(fid, "great_circle_algorithm", "TRUE"); - if(n>=ntiles_global) mpp_def_global_att(fid, "nest_grid", "TRUE"); + if(n>=ntiles_global) mpp_def_global_att(fid, "nest_grids", "TRUE"); mpp_def_global_att(fid, "history", history); - + mpp_end_def(fid); for(m=0; m<4; m++) { start[m] = 0; nwrite[m] = 0; } nwrite[0] = strlen(tilename); mpp_put_var_value_block(fid, id_tile, start, nwrite, tilename ); if(out_halo ==0) { + if (verbose) { + fprintf(stderr, "[INFO] START NC XARRAY write out_halo=0 tile number = n: %d offset = pos_c: %d\n", n, pos_c); + fprintf(stderr, "[INFO] XARRAY: n: %d x[0]: %f x[1]: %f x[2]: %f x[3]: %f x[4]: %f x[5]: %f x[10]: %f\n", + n, x[pos_c], x[pos_c+1], x[pos_c+2], x[pos_c+3], x[pos_c+4], x[pos_c+5], x[pos_c+10]); + if (n > 0) fprintf(stderr, "[INFO] XARRAY: n: %d x[0]: %f x[-1]: %f x[-2]: %f x[-3]: %f x[-4]: %f x[-5]: %f x[-10]: %f\n", + n, x[pos_c], x[pos_c-1], x[pos_c-2], x[pos_c-3], x[pos_c-4], x[pos_c-5], x[pos_c-10]); + } + mpp_put_var_value(fid, id_x, x+pos_c); - mpp_put_var_value(fid, id_y, y+pos_c); - mpp_put_var_value(fid, id_dx, dx+pos_n); - mpp_put_var_value(fid, id_dy, dy+pos_e); - mpp_put_var_value(fid, id_area, area+pos_t); - mpp_put_var_value(fid, id_angle_dx, angle_dx+pos_c); - if(strcmp(conformal, "true") != 0) mpp_put_var_value(fid, id_angle_dy, angle_dy+pos_c); + mpp_put_var_value(fid, id_y, y+pos_c); + if (output_length_angle) { + mpp_put_var_value(fid, id_dx, dx+pos_n); + mpp_put_var_value(fid, id_dy, dy+pos_e); + } + mpp_put_var_value(fid, id_area, area+pos_t); + if (output_length_angle) { + mpp_put_var_value(fid, id_angle_dx, angle_dx+pos_c); + if(strcmp(conformal, "true") != 0) mpp_put_var_value(fid, id_angle_dy, angle_dy+pos_c); + } } else { - double *tmp; - - tmp = (double *)malloc((nxp+2*out_halo)*(nyp+2*out_halo)*sizeof(double)); - fill_cubic_grid_halo(nx,ny,out_halo,tmp,x,x,n,1,1); - mpp_put_var_value(fid, id_x, tmp); - fill_cubic_grid_halo(nx,ny,out_halo,tmp,y,y,n,1,1); - mpp_put_var_value(fid, id_y, tmp); - fill_cubic_grid_halo(nx,ny,out_halo,tmp,angle_dx,angle_dx,n,1,1); - mpp_put_var_value(fid, id_angle_dx, tmp); - if(strcmp(conformal, "true") != 0) { - fill_cubic_grid_halo(nx,ny,out_halo,tmp,angle_dy,angle_dy,n,1,1); - mpp_put_var_value(fid, id_angle_dy, tmp); - } - - fill_cubic_grid_halo(nx,ny,out_halo,tmp,dx,dy,n,0,1); - mpp_put_var_value(fid, id_dx, tmp); - fill_cubic_grid_halo(nx,ny,out_halo,tmp,dy,dx,n,1,0); - mpp_put_var_value(fid, id_dy, tmp); - fill_cubic_grid_halo(nx,ny,out_halo,tmp,area,area,n,0,1); - mpp_put_var_value(fid, id_area, tmp); - free(tmp); + double *tmp; + + tmp = (double *)malloc((nxp+2*out_halo)*(nyp+2*out_halo)*sizeof(double)); + if (verbose) fprintf(stderr, "[INFO] INDEX NC write with halo tile number = n: %d \n", n); + + fill_cubic_grid_halo(nx,ny,out_halo,tmp,x,x,n,1,1); + mpp_put_var_value(fid, id_x, tmp); + fill_cubic_grid_halo(nx,ny,out_halo,tmp,y,y,n,1,1); + mpp_put_var_value(fid, id_y, tmp); + if (output_length_angle) { + fill_cubic_grid_halo(nx,ny,out_halo,tmp,angle_dx,angle_dx,n,1,1); + mpp_put_var_value(fid, id_angle_dx, tmp); + if(strcmp(conformal, "true") != 0) { + fill_cubic_grid_halo(nx,ny,out_halo,tmp,angle_dy,angle_dy,n,1,1); + mpp_put_var_value(fid, id_angle_dy, tmp); + } + + fill_cubic_grid_halo(nx,ny,out_halo,tmp,dx,dy,n,0,1); + mpp_put_var_value(fid, id_dx, tmp); + fill_cubic_grid_halo(nx,ny,out_halo,tmp,dy,dx,n,1,0); + mpp_put_var_value(fid, id_dy, tmp); + } + fill_cubic_grid_halo(nx,ny,out_halo,tmp,area,area,n,0,0); + mpp_put_var_value(fid, id_area, tmp); + free(tmp); } - + nwrite[0] = strlen(arcx); mpp_put_var_value_block(fid, id_arcx, start, nwrite, arcx ); + + if (verbose) fprintf(stderr, "About to close %s\n", outfile); mpp_close(fid); + + /* Advance the pointers to the next tile */ + /* Use the size of a full panel, not the nest, because code in create_gnomonic_cubic_grid uses ntile*size */ + + nx = nxl[n]; + ny = nyl[n]; + nxp = nx + 1; + nyp = ny + 1; + + if (verbose) fprintf(stderr, "[INFO] INDEX Before increment n: %d pos_c %d nxp %d nyp %d nxp*nyp %d\n", n, pos_c, nxp, nyp, nxp*nyp); pos_c += nxp*nyp; + if (verbose) fprintf(stderr, "[INFO] INDEX After increment n: %d pos_c %d.\n", n, pos_c); pos_e += nxp*ny; pos_n += nx*nyp; pos_t += nx*ny; + + } } free(x); free(y); - free(dx); - free(dy); + free(nxl); + free(nyl); free(area); - free(angle_dx); - if(strcmp(conformal, "true") != 0) free(angle_dy); - if(mpp_pe() == mpp_root_pe() && verbose) printf("generate_grid is run successfully. \n"); + if (output_length_angle) { + free(dx); + free(dy); + free(angle_dx); + if(strcmp(conformal, "true") != 0) free(angle_dy); + } + if(mpp_pe() == mpp_root_pe() && verbose) fprintf(stderr, "generate_grid is run successfully. \n"); mpp_end(); return 0; - -}; /* end of main */ - +} /* end of main */ diff --git a/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.c b/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.c index 1850e2e7d..a94ba4d03 100644 --- a/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.c +++ b/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.c @@ -3,6 +3,7 @@ */ #include #include +#include #include "mosaic_util.h" #include "get_contact.h" @@ -11,8 +12,8 @@ int get_align_contact( This routine will return number of algined contacts bewteen two tiles (line contact). This routine assume the starting and ending points of the contact line are coincidence with - the grid points of both tiles. lrg_rectangle tiles are assumed. - It will return the contact information, which includes + the grid points of both tiles. lrg_rectangle tiles are assumed. + It will return the contact information, which includes *************************************************************************************************/ @@ -21,21 +22,21 @@ double* west_bound(const double *data, int nx, int ny); double* south_bound(const double *data, int nx, int ny); double* north_bound(const double *data, int nx, int ny); #define EPSLN (1.0e-10) - +#define EPSLN2 (1.0e-7) int get_contact_index( int size1, int size2, double *x1, double *y1, double *x2, double *y2, double periodx, double periody, int *start1, int *end1, int *start2, int *end2); int get_overlap_index( double x1, double y1, int nx2, int ny2, const double *x2, const double *y2, int *i2, int *j2 ); -int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, - const double *x1, const double *y1, const double *x2, +int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, + const double *x1, const double *y1, const double *x2, const double *y2, double periodx, double periody, - int *istart1, int *iend1, int *jstart1, int *jend1, + int *istart1, int *iend1, int *jstart1, int *jend1, int *istart2, int *iend2, int *jstart2, int *jend2) { double *xb1, *yb1, *xb2, *yb2; int ncontact, start1, end1, start2, end2; - + ncontact = 0; /* East bound of tile1 and west bound of tile2 */ xb1 = east_bound(x1, nx1, ny1); @@ -46,12 +47,12 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, istart1[ncontact] = nx1-1; iend1[ncontact] = nx1-1; istart2[ncontact] = 1; - iend2[ncontact] = 1; + iend2[ncontact] = 1; jstart1[ncontact] = start1; jend1[ncontact] = end1; jstart2[ncontact] = start2; jend2[ncontact] = end2; - ncontact++; + ncontact++; } /* East bound of tile1 and SOUTH bound of tile2, tile1 and tile must be different tile */ @@ -64,7 +65,7 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, istart1[ncontact] = nx1-1; iend1[ncontact] = nx1-1; istart2[ncontact] = start2; - iend2[ncontact] = end2; + iend2[ncontact] = end2; jstart1[ncontact] = start1; jend1[ncontact] = end1; jstart2[ncontact] = 1; @@ -73,10 +74,10 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, } } free(xb1); - free(yb1); + free(yb1); free(xb2); - free(yb2); - + free(yb2); + /* South bound of tile1 and NORTH bound of tile2 */ xb1 = south_bound(x1, nx1, ny1); yb1 = south_bound(y1, nx1, ny1); @@ -86,7 +87,7 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, istart1[ncontact] = start1; iend1[ncontact] = end1; istart2[ncontact] = start2; - iend2[ncontact] = end2; + iend2[ncontact] = end2; jstart1[ncontact] = 1; jend1[ncontact] = 1; jstart2[ncontact] = ny2-1; @@ -94,7 +95,7 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, ncontact++; } - /* South bound of tile1 and East bound of tile2, tile1 and tile must be different tile*/ + /* South bound of tile1 and East bound of tile2, tile1 and tile must be different tile*/ if(tile1 != tile2 ) { free(xb2); free(yb2); @@ -104,7 +105,7 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, istart1[ncontact] = start1; iend1[ncontact] = end1; istart2[ncontact] = nx2-1; - iend2[ncontact] = nx2-1; + iend2[ncontact] = nx2-1; jstart1[ncontact] = 1; jend1[ncontact] = 1; jstart2[ncontact] = start2; @@ -113,9 +114,9 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, } } free(xb1); - free(yb1); + free(yb1); free(xb2); - free(yb2); + free(yb2); /* to avoid duplicate, the following will be done only when tile1 not equal to tile2 */ if(tile1 != tile2) { @@ -128,7 +129,7 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, istart1[ncontact] = 1; iend1[ncontact] = 1; istart2[ncontact] = nx2-1; - iend2[ncontact] = nx2-1; + iend2[ncontact] = nx2-1; jstart1[ncontact] = start1; jend1[ncontact] = end1; jstart2[ncontact] = start2; @@ -138,14 +139,14 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, free(xb2); free(yb2); - /* West bound of tile1 and North bound of tile2 */ + /* West bound of tile1 and North bound of tile2 */ xb2 = north_bound(x2, nx2, ny2); yb2 = north_bound(y2, nx2, ny2); if( get_contact_index( ny1, nx2, xb1, yb1, xb2, yb2, 0.0, 0.0, &start1, &end1, &start2, &end2) ) { istart1[ncontact] = 1; iend1[ncontact] = 1; istart2[ncontact] = start2; - iend2[ncontact] = end2; + iend2[ncontact] = end2; jstart1[ncontact] = start1; jend1[ncontact] = end1; jstart2[ncontact] = ny2-1; @@ -153,11 +154,11 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, ncontact++; } free(xb1); - free(yb1); + free(yb1); free(xb2); - free(yb2); + free(yb2); + - /* North bound of tile1 and South bound of tile2 */ xb1 = north_bound(x1, nx1, ny1); yb1 = north_bound(y1, nx1, ny1); @@ -167,7 +168,7 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, istart1[ncontact] = start1; iend1[ncontact] = end1; istart2[ncontact] = start2; - iend2[ncontact] = end2; + iend2[ncontact] = end2; jstart1[ncontact] = ny1-1; jend1[ncontact] = ny1-1; jstart2[ncontact] = 1; @@ -177,14 +178,14 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, free(xb2); free(yb2); - /* North bound of tile1 and West bound of tile2 */ + /* North bound of tile1 and West bound of tile2 */ xb2 = west_bound(x2, nx2, ny2); yb2 = west_bound(y2, nx2, ny2); if( get_contact_index( nx1, ny2, xb1, yb1, xb2, yb2, 0.0, 0.0, &start1, &end1, &start2, &end2) ) { istart1[ncontact] = start1; iend1[ncontact] = end1; istart2[ncontact] = 1; - iend2[ncontact] = 1; + iend2[ncontact] = 1; jstart1[ncontact] = ny1-1; jend1[ncontact] = ny1-1; jstart2[ncontact] = start2; @@ -192,31 +193,36 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, ncontact++; } free(xb1); - free(yb1); + free(yb1); free(xb2); - free(yb2); + free(yb2); } /* when tile1 = tile2, we need to consider about folded. Only foled north is considered here */ if(tile1 == tile2) { int i, folded = 1; - double dx; + double dx, dy; int num; - + num = 0; xb1 = north_bound(x1, nx1, ny1); yb1 = north_bound(y1, nx1, ny1); for(i=0; i EPSLN2 ) { + printf("i=%d, yb1=%13.10f, yb2=%13.10f, dy=%13.10f\n", i, yb1[i], yb1[nx1-i-1], dy); folded = 0; break; } dx = fabs(xb1[i] - xb1[nx1-i-1]); - if( dx !=0 && dx != 360 ) { - if(dx == 180) + if( dx > EPSLN2 && fabs(dx-360)>EPSLN2 ) { + if( fabs(dx-180) < EPSLN2 ) { num++; + /* printf("i=%d, num=%d, dx=%13.10f\n", i, num, dx); */ + } else { folded = 0; + printf("i=%d, xb1=%13.10f, xb2=%13.10f, dx=%13.10f\n", i, xb1[i], xb1[nx1-i-1], dx-180); break; } } @@ -228,7 +234,7 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, istart1[ncontact] = 1; iend1[ncontact] = nx1/2; istart2[ncontact] = nx1-1; - iend2[ncontact] = nx1/2+1; + iend2[ncontact] = nx1/2+1; jstart1[ncontact] = ny1-1; jend1[ncontact] = ny1-1; jstart2[ncontact] = ny1-1; @@ -238,17 +244,17 @@ int get_align_contact(int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, free(xb1); free(yb1); } - + return ncontact; - + }; /* For simplying reason, we are only deal with nested overlap. */ -int get_overlap_contact( int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, - const double *x1, const double *y1, const double *x2, - const double *y2, int *istart1, int *iend1, int *jstart1, int *jend1, +int get_overlap_contact( int tile1, int tile2, int nx1, int ny1, int nx2, int ny2, + const double *x1, const double *y1, const double *x2, + const double *y2, int *istart1, int *iend1, int *jstart1, int *jend1, int *istart2, int *iend2, int *jstart2, int *jend2) { int l1, l2, count; @@ -257,7 +263,7 @@ int get_overlap_contact( int tile1, int tile2, int nx1, int ny1, int nx2, int ny /* check the four corner of tile 2 */ - + /* southwest corner */ l2 = 0; p2x[0] = 0; p2y[0]=0; @@ -273,16 +279,16 @@ int get_overlap_contact( int tile1, int tile2, int nx1, int ny1, int nx2, int ny if( count > 0 ) { l2 = (ny2-1)*nx2; count = get_overlap_index(x2[l2], y2[l2], nx1, ny1, x1, y1, p1x+2, p1y+2); - } + } /* northeast corner */ p2x[3] = nx2-1; p2y[3] = ny2-1; if( count > 0 ) { l2 = (ny2-1)*nx2+ nx2-1; count = get_overlap_index(x2[l2], y2[l2], nx1, ny1, x1, y1, p1x+3, p1y+3); - } + } /* check the four corner of tile 1 if count==0 */ if(count == 0) { - + /* southwest corner */ l1 = 0; p1x[0] = 0; p1y[0]=0; @@ -300,16 +306,16 @@ int get_overlap_contact( int tile1, int tile2, int nx1, int ny1, int nx2, int ny l1 = (ny1-1)*nx1; count = get_overlap_index(x1[l1], y1[l1], nx2, ny2, x2, y2, p2x+2, p2y+2); if(count == 0) return 0; - + /* northeast corner */ p1x[3] = nx1-1; p1y[3] = ny1-1; l1 = (ny1-1)*nx1+ nx1-1; count = get_overlap_index(x1[l1], y1[l1], nx2, ny2, x2, y2, p2x+3, p2y+3); if(count == 0) return 0; - - } - - + + } + + /* for(j1=0; j1=0; j1--) for(i1=0;i1=0; j2--) for(i2=0; i2=0; j1--) for(i1=nx1-1;i1>=0; i1--) { */ /* l1 = j1*nx1+i1; */ /* for(j2=ny2-1;j2>=0; j2--) for(i2=nx2-1; i2>=0; i2--) { */ @@ -379,7 +385,7 @@ int get_overlap_contact( int tile1, int tile2, int nx1, int ny1, int nx2, int ny /* } */ /* } */ /* return 0; */ - + /* found_ne: */ /* currently we assume there is no rotation for the overlapped grid */ /* The following must be true @@ -408,17 +414,17 @@ int get_overlap_contact( int tile1, int tile2, int nx1, int ny1, int nx2, int ny istart2[0] = p2x[0]+1; iend2[0] = p2x[1]; jstart2[0] = p2y[0]+1; - jend2[0] = p2y[3]; - + jend2[0] = p2y[3]; + return 1; } - + int get_overlap_index( double x1, double y1, int nx2, int ny2, const double *x2, const double *y2, int *i2, int *j2 ) { int i, j, l2; double dx, dy; - + for(j=0; j *end1 ) @@ -490,10 +496,10 @@ int get_contact_index( int size1, int size2, double *x1, double *y1, double *x2, if(*start2 > *end2 ) (*start2)--; else - (*end2)--; + (*end2)--; return 1; - + }; diff --git a/sorc/fre-nctools.fd/tools/make_solo_mosaic/make_solo_mosaic.c b/sorc/fre-nctools.fd/tools/make_solo_mosaic/make_solo_mosaic.c index 2321e0546..ce18a1841 100644 --- a/sorc/fre-nctools.fd/tools/make_solo_mosaic/make_solo_mosaic.c +++ b/sorc/fre-nctools.fd/tools/make_solo_mosaic/make_solo_mosaic.c @@ -58,16 +58,16 @@ char *usage[] = { " C48_grid.tile5.nc,C48_grid.tile6.nc ", " ", NULL}; - + const int MAXTILE = 100; const int MAXCONTACT = 100; const int SHORTSTRING = 32; char grid_version[] = "0.2"; char tagname[] = "$Name: fre-nctools-bronx-10 $"; -main (int argc, char *argv[]) +int main (int argc, char *argv[]) { - + extern char *optarg; char *pch=NULL, *dir=NULL, history[512], entry[1280]; char tilefile[MAXTILE][STRING], tiletype[MAXTILE][SHORTSTRING]; @@ -81,16 +81,16 @@ main (int argc, char *argv[]) int contact_tile1_jstart[MAXCONTACT], contact_tile1_jend[MAXCONTACT]; int contact_tile2_istart[MAXCONTACT], contact_tile2_iend[MAXCONTACT]; int contact_tile2_jstart[MAXCONTACT], contact_tile2_jend[MAXCONTACT]; - char mosaic_name[STRING] = "solo_mosaic"; + char mosaic_name[128] = "solo_mosaic"; char grid_descriptor[128] = ""; int c, i, n, m, l, errflg; - + int option_index = 0; static struct option long_options[] = { {"mosaic_name", required_argument, NULL, 'm'}, {"num_tiles", required_argument, NULL, 'n'}, {"grid_descriptor", required_argument, NULL, 'g'}, - {"tile_file", required_argument, NULL, 'f'}, + {"tile_file", required_argument, NULL, 'f'}, {"periodx", required_argument, NULL, 'x'}, {"periody", required_argument, NULL, 'y'}, {"directory", required_argument, NULL, 'd'}, @@ -100,7 +100,7 @@ main (int argc, char *argv[]) mpp_init(&argc, &argv); /* this tool must be run one processor */ if(mpp_npes()>1) mpp_error("make_solo_mosaic: this tool must be run on one processor"); - + errflg = (argc == 1); /* First read command line arguments. */ @@ -116,7 +116,7 @@ main (int argc, char *argv[]) strcpy(grid_descriptor, optarg); break; case 'f': - strcpy(entry, optarg); + strcpy(entry, optarg); pch = strtok(entry, ", "); nfiles = 0; while( pch != NULL) { @@ -129,7 +129,7 @@ main (int argc, char *argv[]) break; case 'y': periody = atof(optarg); - break; + break; case 'd': // path of the simple grid file. dir = optarg; break; @@ -141,7 +141,7 @@ main (int argc, char *argv[]) if (errflg || ntiles < 1 || !dir ) { char **u = usage; while (*u) { fprintf(stderr, "%s\n", *u); u++; } - exit(2); + exit(2); } strcpy(history,argv[0]); @@ -154,7 +154,7 @@ main (int argc, char *argv[]) if(ntiles > MAXTILE) { mpp_error("make_solo_mosaic: number of tiles is greater than MAXTILE."); } - + /*--- if file name is not specified through -f, file name will be horizontal_grid.tile#.nc */ if(nfiles == 0) { if(ntiles == 1) { @@ -252,7 +252,7 @@ main (int argc, char *argv[]) } } } - + /* write out data */ { @@ -266,7 +266,7 @@ main (int argc, char *argv[]) /* define dimenison */ dim_ntiles = mpp_def_dim(fid, "ntiles", ntiles); if(ncontact>0) dim_ncontact = mpp_def_dim(fid, "ncontact", ncontact); - dim_string = mpp_def_dim(fid, "string", STRING); + dim_string = mpp_def_dim(fid, "string", STRING); /* define variable */ id_mosaic = mpp_def_var(fid, "mosaic", MPP_CHAR, 1, &dim_string, 4, "standard_name", "grid_mosaic_spec", "children", "gridtiles", "contact_regions", "contacts", @@ -306,7 +306,7 @@ main (int argc, char *argv[]) nwrite[1] = strlen(tilefile[n]); mpp_put_var_value_block(fid, id_gridfiles, start, nwrite, tilefile[n]); } - + for(n=0; n /dev/null 2>&1 ) ; then echo load the module command 1>&2 diff --git a/sorc/sfc_climo_gen.fd/driver.F90 b/sorc/sfc_climo_gen.fd/driver.F90 index 4f05d974a..60014fda9 100644 --- a/sorc/sfc_climo_gen.fd/driver.F90 +++ b/sorc/sfc_climo_gen.fd/driver.F90 @@ -141,6 +141,16 @@ program driver call source_grid_cleanup endif +! Soil color + + if (trim(input_soil_color_file) /= "NULL") then + call define_source_grid(localpet, npets, input_soil_color_file) + method=ESMF_REGRIDMETHOD_NEAREST_STOD + call interp(localpet, method, input_soil_color_file) + call source_grid_cleanup + endif + + ! Vegetation greenness if (trim(input_vegetation_greenness_file) /= "NULL") then diff --git a/sorc/sfc_climo_gen.fd/interp.F90 b/sorc/sfc_climo_gen.fd/interp.F90 index 628e67c66..af374478f 100644 --- a/sorc/sfc_climo_gen.fd/interp.F90 +++ b/sorc/sfc_climo_gen.fd/interp.F90 @@ -188,7 +188,7 @@ subroutine interp(localpet, method, input_file) ! These fields are adjusted at landice. select case (trim(field_names(n))) - case ('substrate_temperature','vegetation_greenness','leaf_area_index','slope_type','soil_type') + case ('substrate_temperature','vegetation_greenness','leaf_area_index','slope_type','soil_type','soil_color') if (localpet == 0) then allocate(vegt_mdl_one_tile(i_mdl,j_mdl)) else @@ -219,7 +219,7 @@ subroutine interp(localpet, method, input_file) call error_handler("IN FieldGather.", rc) select case (trim(field_names(n))) - case ('substrate_temperature','vegetation_greenness','leaf_area_index','slope_type','soil_type') + case ('substrate_temperature','vegetation_greenness','leaf_area_index','slope_type','soil_type','soil_color') print*,"- CALL FieldGather FOR MODEL GRID VEG TYPE." call ESMF_FieldGather(vegt_field_mdl, vegt_mdl_one_tile, rootPet=0, tile=tile, rc=rc) if(ESMF_logFoundError(rcToCheck=rc,msg=ESMF_LOGERR_PASSTHRU,line=__LINE__,file=__FILE__)) & @@ -230,7 +230,7 @@ subroutine interp(localpet, method, input_file) print*,'- CALL SEARCH FOR TILE ',tile call search (data_mdl_one_tile, mask_mdl_one_tile, i_mdl, j_mdl, tile, field_names(n)) select case (field_names(n)) - case ('substrate_temperature','vegetation_greenness','leaf_area_index','slope_type','soil_type') + case ('substrate_temperature','vegetation_greenness','leaf_area_index','slope_type','soil_type','soil_color') call adjust_for_landice (data_mdl_one_tile, vegt_mdl_one_tile, i_mdl, j_mdl, field_names(n)) end select where(mask_mdl_one_tile == 0) data_mdl_one_tile = missing @@ -344,6 +344,15 @@ subroutine adjust_for_landice(field, vegt, idim, jdim, field_ch) endif enddo enddo + case ('soil_color') ! soil color + landice_value = 10.0 + do j = 1, jdim + do i = 1, idim + if (nint(vegt(i,j)) == landice) then + field(i,j) = landice_value + endif + enddo + enddo case default print*,'- FATAL ERROR IN ROUTINE ADJUST_FOR_LANDICE. UNIDENTIFIED FIELD : ', field_ch call mpi_abort(mpi_comm_world, 57, ierr) diff --git a/sorc/sfc_climo_gen.fd/output.f90 b/sorc/sfc_climo_gen.fd/output.f90 index 7a61c9123..7df8c18b7 100644 --- a/sorc/sfc_climo_gen.fd/output.f90 +++ b/sorc/sfc_climo_gen.fd/output.f90 @@ -72,6 +72,9 @@ subroutine output(data_one_tile, lat_one_tile, lon_one_tile, i_mdl, j_mdl, & case ('soil_type') out_file = "./soil_type." // grid_tiles(tile) // ".nc" out_file_with_halo = "./soil_type." // grid_tiles(tile) // ".halo.nc" + case ('soil_color') + out_file = "./soil_color." // grid_tiles(tile) // ".nc" + out_file_with_halo = "./soil_color." // grid_tiles(tile) // ".halo.nc" case ('vegetation_type') out_file = "./vegetation_type." // grid_tiles(tile) // ".nc" out_file_with_halo = "./vegetation_type." // grid_tiles(tile) // ".halo.nc" diff --git a/sorc/sfc_climo_gen.fd/program_setup.f90 b/sorc/sfc_climo_gen.fd/program_setup.f90 index a5c59b901..608befd03 100644 --- a/sorc/sfc_climo_gen.fd/program_setup.f90 +++ b/sorc/sfc_climo_gen.fd/program_setup.f90 @@ -29,6 +29,7 @@ module program_setup character(len=500), public :: input_snowfree_albedo_file = "NULL" !< File containing input snow-free albedo data. character(len=500), public :: input_slope_type_file = "NULL" !< File containing input slope type data. character(len=500), public :: input_soil_type_file = "NULL" !< File containing input soil type data. + character(len=500), public :: input_soil_color_file = "NULL" !< File containing input soil color data. character(len=500), public :: input_vegetation_type_file = "NULL" !< File containing input vegetation type data. character(len=500), public :: input_vegetation_greenness_file = "NULL" !< File containing input vegetation greenness data. character(len=500), public :: mosaic_file_mdl = "NULL" !< Model grid mosaic file. @@ -63,7 +64,7 @@ subroutine read_setup_namelist(localpet) namelist /config/ input_facsf_file, input_substrate_temperature_file, & input_maximum_snow_albedo_file, input_snowfree_albedo_file, & - input_slope_type_file, input_soil_type_file, & + input_slope_type_file, input_soil_type_file, input_soil_color_file,& input_leaf_area_index_file, input_vegetation_type_file, & input_vegetation_greenness_file, mosaic_file_mdl, & orog_dir_mdl, orog_files_mdl, halo, & diff --git a/sorc/sfc_climo_gen.fd/search.f90 b/sorc/sfc_climo_gen.fd/search.f90 index ea3faef2a..d5b44ebe6 100644 --- a/sorc/sfc_climo_gen.fd/search.f90 +++ b/sorc/sfc_climo_gen.fd/search.f90 @@ -71,6 +71,8 @@ subroutine search (field, mask, idim, jdim, tile, field_name) default_value = float(1) case ('soil_type') ! soil type default_value = float(2) + case ('soil_color') ! soil color + default_value = float(4) case ('vegetation_type') ! vegetation type default_value = float(3) case default diff --git a/tests/chgres_cube/ftst_convert_winds.F90 b/tests/chgres_cube/ftst_convert_winds.F90 index 0dcc75fea..dd675c58c 100644 --- a/tests/chgres_cube/ftst_convert_winds.F90 +++ b/tests/chgres_cube/ftst_convert_winds.F90 @@ -14,7 +14,7 @@ program winds latitude_input_grid, & longitude_input_grid - use input_data, only : lev_input, convert_winds, & + use atm_input_data, only : lev_input, convert_winds, & wind_input_grid, & u_input_grid, & v_input_grid diff --git a/tests/chgres_cube/ftst_dint2p.F90 b/tests/chgres_cube/ftst_dint2p.F90 index a501e3a7e..c854f554b 100644 --- a/tests/chgres_cube/ftst_dint2p.F90 +++ b/tests/chgres_cube/ftst_dint2p.F90 @@ -1,6 +1,6 @@ program ftst_dint2p - use input_data + use utilities implicit none diff --git a/tests/chgres_cube/ftst_program_setup_varmaps.F90 b/tests/chgres_cube/ftst_program_setup_varmaps.F90 index db192f58e..0b466002f 100644 --- a/tests/chgres_cube/ftst_program_setup_varmaps.F90 +++ b/tests/chgres_cube/ftst_program_setup_varmaps.F90 @@ -4,6 +4,7 @@ program ftst_program_setup_varmaps use mpi + use esmf use program_setup implicit none integer :: my_rank, nprocs @@ -19,7 +20,7 @@ program ftst_program_setup_varmaps character(len=MAX_NAME_LEN) :: expected_missing_var_methods(EXPECTED_NUM_VARS) = [character(len=20):: 'set_to_fill', 'set_to_fill', & 'set_to_fill', 'set_to_fill', 'set_to_fill', 'set_to_fill', 'set_to_fill', 'set_to_fill', 'skip', 'skip', 'skip', 'set_to_fill', 'set_to_fill', & 'set_to_fill', 'set_to_fill', 'set_to_fill', 'stop', 'set_to_fill', 'stop', 'set_to_fill', 'set_to_fill', 'set_to_fill', 'set_to_fill'] - real :: expected_missing_var_values(EXPECTED_NUM_VARS) = (/ 0.0, 1E-7, 0.0, 1E-7, 0.0, 0.0, 0.0, 0.0, 0.0, & + real(kind=esmf_kind_r4) :: expected_missing_var_values(EXPECTED_NUM_VARS) = (/ 0.0, 1E-7, 0.0, 1E-7, 0.0, 0.0, 0.0, 0.0, 0.0, & 0.0, 0.0, 0.0, 0.01, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.5, 0.0, 0.0 /) character(len=MAX_NAME_LEN) :: expected_tracers_input(EXPECTED_NUM_TRACERS) = [character(len=20):: 'sphum', 'liq_wat', & 'o3mr', 'ice_wat', 'rainwat', 'snowwat', 'graupel'] diff --git a/tests/chgres_cube/ftst_quicksort.F90 b/tests/chgres_cube/ftst_quicksort.F90 index 4f3127fe2..711ca7b0d 100644 --- a/tests/chgres_cube/ftst_quicksort.F90 +++ b/tests/chgres_cube/ftst_quicksort.F90 @@ -6,7 +6,7 @@ program quick_sort ! ! @author George Gayno NOAA/EMC - use input_data + use utilities implicit none diff --git a/tests/chgres_cube/ftst_read_atm_gaussian_netcdf.F90 b/tests/chgres_cube/ftst_read_atm_gaussian_netcdf.F90 index 25a3ab847..95300c988 100644 --- a/tests/chgres_cube/ftst_read_atm_gaussian_netcdf.F90 +++ b/tests/chgres_cube/ftst_read_atm_gaussian_netcdf.F90 @@ -19,7 +19,7 @@ program read_atm_gaussian_netcdf latitude_input_grid, & longitude_input_grid - use input_data, only : read_input_atm_data, & + use atm_input_data, only : read_input_atm_data, & lev_input, & levp1_input, & temp_input_grid, & diff --git a/tests/chgres_cube/ftst_read_atm_grib2.F90 b/tests/chgres_cube/ftst_read_atm_grib2.F90 index b9a030974..907180cb9 100644 --- a/tests/chgres_cube/ftst_read_atm_grib2.F90 +++ b/tests/chgres_cube/ftst_read_atm_grib2.F90 @@ -11,7 +11,7 @@ program read_atm_grib2 use esmf - use input_data, only : read_input_atm_data, & + use atm_input_data, only : read_input_atm_data, & lev_input, & levp1_input, & temp_input_grid, tracers_input_grid, & diff --git a/tests/chgres_cube/ftst_read_nst_nemsio.F90 b/tests/chgres_cube/ftst_read_nst_nemsio.F90 index a96496304..f57103285 100644 --- a/tests/chgres_cube/ftst_read_nst_nemsio.F90 +++ b/tests/chgres_cube/ftst_read_nst_nemsio.F90 @@ -16,7 +16,7 @@ program read_nst_nemsio input_grid, & num_tiles_input_grid - use input_data, only : read_input_nst_data, & + use nst_input_data, only : read_input_nst_data, & c_d_input_grid, & c_0_input_grid, & d_conv_input_grid, & diff --git a/tests/chgres_cube/ftst_read_nst_netcdf.F90 b/tests/chgres_cube/ftst_read_nst_netcdf.F90 index db0f546b2..d5a65da95 100644 --- a/tests/chgres_cube/ftst_read_nst_netcdf.F90 +++ b/tests/chgres_cube/ftst_read_nst_netcdf.F90 @@ -16,7 +16,7 @@ program readnst input_grid, & num_tiles_input_grid - use input_data, only : read_input_nst_data, & + use nst_input_data, only : read_input_nst_data, & c_d_input_grid, & c_0_input_grid, & d_conv_input_grid, & diff --git a/tests/chgres_cube/ftst_read_sfc_gfs_nemsio.F90 b/tests/chgres_cube/ftst_read_sfc_gfs_nemsio.F90 index 9bd79cc57..e14278e49 100644 --- a/tests/chgres_cube/ftst_read_sfc_gfs_nemsio.F90 +++ b/tests/chgres_cube/ftst_read_sfc_gfs_nemsio.F90 @@ -16,10 +16,9 @@ program readsfc_gfs_nemsio input_grid, & num_tiles_input_grid - use input_data, only : read_input_sfc_data, & + use sfc_input_data, only : read_input_sfc_data, & lsoil_input, & landsea_mask_input_grid, & - terrain_input_grid, & soilm_liq_input_grid, & soilm_tot_input_grid, & soil_temp_input_grid, & @@ -41,6 +40,8 @@ program readsfc_gfs_nemsio canopy_mc_input_grid, & z0_input_grid + use atm_input_data, only : terrain_input_grid + use program_setup, only : input_type, & data_dir_input_grid, & sfc_files_input_grid diff --git a/tests/chgres_cube/ftst_read_sfc_grib2.F90 b/tests/chgres_cube/ftst_read_sfc_grib2.F90 index 5f587912a..f87d8aac0 100644 --- a/tests/chgres_cube/ftst_read_sfc_grib2.F90 +++ b/tests/chgres_cube/ftst_read_sfc_grib2.F90 @@ -8,10 +8,9 @@ program read_sfc_grib2 ! Author George Gayno use esmf - - use input_data, only : read_input_sfc_data, & + use atm_input_data, only : terrain_input_grid + use sfc_input_data, only : read_input_sfc_data, & lsoil_input, & - terrain_input_grid, & soilm_liq_input_grid, & soilm_tot_input_grid, & soil_temp_input_grid, & diff --git a/tests/chgres_cube/ftst_read_sfc_nemsio.F90 b/tests/chgres_cube/ftst_read_sfc_nemsio.F90 index d051f6652..c4294926d 100644 --- a/tests/chgres_cube/ftst_read_sfc_nemsio.F90 +++ b/tests/chgres_cube/ftst_read_sfc_nemsio.F90 @@ -15,11 +15,10 @@ program readsfc_nemsio use model_grid, only : i_input, j_input, & input_grid, & num_tiles_input_grid - - use input_data, only : read_input_sfc_data, & + use atm_input_data, only : terrain_input_grid + use sfc_input_data, only : read_input_sfc_data, & lsoil_input, & landsea_mask_input_grid, & - terrain_input_grid, & soilm_liq_input_grid, & soilm_tot_input_grid, & soil_temp_input_grid, & diff --git a/tests/chgres_cube/ftst_read_sfc_netcdf.F90 b/tests/chgres_cube/ftst_read_sfc_netcdf.F90 index 0daa3f253..aafec63f6 100644 --- a/tests/chgres_cube/ftst_read_sfc_netcdf.F90 +++ b/tests/chgres_cube/ftst_read_sfc_netcdf.F90 @@ -16,10 +16,11 @@ program readsfcnetcdf input_grid, & num_tiles_input_grid - use input_data, only : read_input_sfc_data, & + use atm_input_data, only : terrain_input_grid + + use sfc_input_data, only : read_input_sfc_data, & lsoil_input, & landsea_mask_input_grid, & - terrain_input_grid, & soilm_liq_input_grid, & soilm_tot_input_grid, & soil_temp_input_grid, & diff --git a/tests/chgres_cube/ftst_sfc_input_data.F90 b/tests/chgres_cube/ftst_sfc_input_data.F90 index 75bf1bf19..fe1cc9c40 100644 --- a/tests/chgres_cube/ftst_sfc_input_data.F90 +++ b/tests/chgres_cube/ftst_sfc_input_data.F90 @@ -10,9 +10,9 @@ program test_sfc_input_data use mpi use esmf - use input_data + use utilities use model_grid - + use sfc_input_data, only : lsoil_input implicit none integer :: ierr @@ -25,7 +25,7 @@ program test_sfc_input_data real(esmf_kind_r8), allocatable :: cnwat_bad(:,:), & cnwat_updated(:,:), & cnwat_correct(:,:) - + real :: ICET_DEFAULT = 265.0 call mpi_init(ierr) !--------------------------------------------------------! @@ -87,7 +87,7 @@ program test_sfc_input_data print*,"Starting test of check_soilt subroutine." soilt_updated = soilt_bad - call check_soilt(soilt_updated,mask,skint) + call check_soilt(soilt_updated,mask,skint,ICET_DEFAULT,i_input,j_input,lsoil_input) if (any(soilt_updated /= soilt_correct)) then print*,'SOILT TEST FAILED ' @@ -123,7 +123,7 @@ program test_sfc_input_data print*,"Starting test of check_cnwat subroutine." cnwat_updated = cnwat_bad - call check_cnwat(cnwat_updated) + call check_cnwat(cnwat_updated,i_input,j_input) if (any(cnwat_updated /= cnwat_correct)) then print*,'CNWAT TEST FAILED ' diff --git a/tests/chgres_cube/ftst_surface_interp.F90 b/tests/chgres_cube/ftst_surface_interp.F90 index fdc9a91a0..7b3d7c29b 100644 --- a/tests/chgres_cube/ftst_surface_interp.F90 +++ b/tests/chgres_cube/ftst_surface_interp.F90 @@ -32,11 +32,12 @@ program surface_interp interp, & cleanup_target_sfc_data - use input_data, only : init_sfc_esmf_fields, & + use atm_input_data, only : terrain_input_grid + + use sfc_input_data, only : init_sfc_esmf_fields, & soil_type_input_grid, & veg_type_input_grid, & landsea_mask_input_grid, & - terrain_input_grid, & t2m_input_grid, & cleanup_input_sfc_data diff --git a/tests/chgres_cube/ftst_surface_nst_landfill.F90 b/tests/chgres_cube/ftst_surface_nst_landfill.F90 index 00d801478..e2fcd7bde 100644 --- a/tests/chgres_cube/ftst_surface_nst_landfill.F90 +++ b/tests/chgres_cube/ftst_surface_nst_landfill.F90 @@ -35,6 +35,8 @@ program surface_nst_landfill zm_target_grid, & cleanup_target_nst_data + use utilities, only : error_handler + implicit none integer, parameter :: IPTS_TARGET=4 diff --git a/tests/chgres_cube/ftst_surface_regrid_many.F90 b/tests/chgres_cube/ftst_surface_regrid_many.F90 index 34619d7b6..fb182d6c9 100644 --- a/tests/chgres_cube/ftst_surface_regrid_many.F90 +++ b/tests/chgres_cube/ftst_surface_regrid_many.F90 @@ -17,11 +17,13 @@ program surface_interp latitude_target_grid, & longitude_target_grid - use input_data, only: t2m_input_grid, & + use sfc_input_data, only: t2m_input_grid, & q2m_input_grid use surface, only : regrid_many + use utilities, only : error_handler + use surface_target_data, only : t2m_target_grid, & q2m_target_grid diff --git a/tests/chgres_cube/ftst_surface_search_many.F90 b/tests/chgres_cube/ftst_surface_search_many.F90 index ec627d6e8..f8700ba9f 100644 --- a/tests/chgres_cube/ftst_surface_search_many.F90 +++ b/tests/chgres_cube/ftst_surface_search_many.F90 @@ -17,6 +17,8 @@ program surface_interp use surface, only : search_many + use utilities, only : error_handler + implicit none integer, parameter :: IPTS_TARGET=3 diff --git a/tests/chgres_cube/ftst_utils.F90 b/tests/chgres_cube/ftst_utils.F90 index bbef568b9..21ef49fed 100644 --- a/tests/chgres_cube/ftst_utils.F90 +++ b/tests/chgres_cube/ftst_utils.F90 @@ -5,12 +5,12 @@ program ftst_utils + use utilities, only : to_lower, to_upper implicit none logical :: match_result - character(len=12) :: to_upper character(len=12) :: test_input_char_1, test_input_char_2, u_st_base, l_st_base u_st_base="STAGGERLOCCE" diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh index 7aed682b4..9347749f0 100755 --- a/ush/fv3gfs_driver_grid.sh +++ b/ush/fv3gfs_driver_grid.sh @@ -102,7 +102,7 @@ export out_dir=${out_dir:?} export home_dir=${home_dir:-"$PWD/../"} export script_dir=$home_dir/ush export exec_dir=${exec_dir:-"$home_dir/exec"} -export topo=$home_dir/fix/orog +export topo=$home_dir/fix/orog_raw export NCDUMP=${NCDUMP:-ncdump} diff --git a/ush/sfc_climo_gen.sh b/ush/sfc_climo_gen.sh index f3113122f..43d601c32 100755 --- a/ush/sfc_climo_gen.sh +++ b/ush/sfc_climo_gen.sh @@ -70,6 +70,7 @@ input_maximum_snow_albedo_file="${input_sfc_climo_dir}/maximum_snow_albedo.0.05. input_snowfree_albedo_file="${input_sfc_climo_dir}/snowfree_albedo.4comp.0.05.nc" input_slope_type_file="${input_sfc_climo_dir}/slope_type.1.0.nc" input_soil_type_file="${SOIL_TYPE_FILE}" +input_soil_color_file="${input_sfc_climo_dir}/soil_color.clm.0.05.nc" input_vegetation_type_file="${VEG_TYPE_FILE}" input_vegetation_greenness_file="${input_sfc_climo_dir}/vegetation_greenness.0.144.nc" mosaic_file_mdl="$mosaic_file" diff --git a/util/gdas_init/config b/util/gdas_init/config index 5ca148541..a67f75c35 100644 --- a/util/gdas_init/config +++ b/util/gdas_init/config @@ -1,10 +1,10 @@ #----------------------------------------------------------- # # 1) Compile the chgres_cube program. Invoke -# ./sorc/build_chgres_cube.sh +# ../../build_all.sh # # 2) Ensure links to the 'fixed' directories are -# set. See the ./sorc/link_fixdirs.sh script prolog +# set. See the ../../fix/link_fixdirs.sh script prolog # for details. # # 3) Set all config variables. See definitions diff --git a/util/gdas_init/readme.md b/util/gdas_init/readme.md new file mode 100644 index 000000000..4a0139a00 --- /dev/null +++ b/util/gdas_init/readme.md @@ -0,0 +1,7 @@ +This utility creates 'cold start' initialization files to start a +global cycled experiment. + +Edit the 'config' file for your experiment. Then invoke the +driver script for your machine. + +Only machines with access to the HPSS database are supported. diff --git a/util/sfc_climo_gen/readme.md b/util/sfc_climo_gen/readme.md new file mode 100644 index 000000000..95745a1ec --- /dev/null +++ b/util/sfc_climo_gen/readme.md @@ -0,0 +1,4 @@ +Run the sfc_climo_gen program stand-alone on WCOSS2 using +pre-exiting 'grid' and 'orography' files. + +Outputs surface fields such as soil and vegetation type.