diff --git a/.github/workflows/gcc.yml b/.github/workflows/gcc.yml
index 6ba8ef3295..1f6fa3afcd 100644
--- a/.github/workflows/gcc.yml
+++ b/.github/workflows/gcc.yml
@@ -15,9 +15,9 @@ env:
# The jobs are split into:
# 1. a dependency build step (setup), and
-# 2. a GSI build step (build)
+# 2. a GSI build step (gsi)
# The setup is run once and the environment is cached,
-# so each build of GSI can reuse the cached dependencies to save time (and compute).
+# so each subsequent build of GSI can reuse the cached dependencies to save time (and compute).
jobs:
setup:
@@ -25,11 +25,11 @@ jobs:
steps:
# Checkout the GSI to get the ci/spack.yaml file
- - name: checkout-gsi
+ - name: checkout
if: steps.cache-env.outputs.cache-hit != 'true'
- uses: actions/checkout@v3
+ uses: actions/checkout@v4
with:
- path: GSI
+ path: gsi
# Cache spack, compiler and dependencies
- name: cache-env
@@ -39,33 +39,34 @@ jobs:
path: |
spack
~/.spack
- key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }}
+ key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }}
# Install dependencies using Spack
- name: install-dependencies-with-spack
if: steps.cache-env.outputs.cache-hit != 'true'
run: |
sudo apt-get install cmake
- git clone -c feature.manyFiles=true https://github.com/NOAA-EMC/spack.git
+ git clone -c feature.manyFiles=true https://github.com/JCSDA/spack.git
source spack/share/spack/setup-env.sh
- spack env create gsi-env GSI/ci/spack.yaml
+ spack env create gsi-env gsi/ci/spack.yaml
spack env activate gsi-env
spack compiler find
+ sudo apt install cmake
spack external find
spack add mpich@3.4.2
spack concretize
spack install -v --fail-fast --dirty
spack clean -a
- build:
+ gsi:
needs: setup
runs-on: ubuntu-latest
steps:
- - name: checkout-gsi
- uses: actions/checkout@v3
+ - name: checkout
+ uses: actions/checkout@v4
with:
- path: GSI
+ path: gsi
- name: cache-env
id: cache-env
@@ -74,13 +75,13 @@ jobs:
path: |
spack
~/.spack
- key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }}
+ key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }}
- - name: build-gsi
+ - name: build
run: |
source spack/share/spack/setup-env.sh
spack env activate gsi-env
- cd GSI
+ cd gsi
mkdir -p build && cd build
cmake -DCMAKE_INSTALL_PREFIX=../install -DGSI_MODE=Regional -DENKF_MODE=GFS -DBUILD_REG_TESTING=OFF ..
make -j2 VERBOSE=1
diff --git a/.github/workflows/intel.yml b/.github/workflows/intel.yml
index d48c00a21e..d21420687a 100644
--- a/.github/workflows/intel.yml
+++ b/.github/workflows/intel.yml
@@ -18,21 +18,30 @@ env:
# The jobs are split into:
# 1. a dependency build step (setup), and
-# 2. a GSI build step (build)
+# 2. a GSI build step (gsi)
# The setup is run once and the environment is cached,
-# so each build of GSI can reuse the cached dependencies to save time (and compute).
+# so each subsequent build of GSI can reuse the cached dependencies to save time (and compute).
jobs:
setup:
runs-on: ubuntu-latest
steps:
+ # Free up disk space
+ - name: free-disk-spack
+ run: |
+ df -h
+ sudo swapoff -a
+ sudo rm -f /swapfile
+ sudo apt clean
+ docker rmi $(docker image ls -aq)
+
# Checkout the GSI to get the ci/spack.yaml file
- - name: checkout-gsi
+ - name: checkout
if: steps.cache-env.outputs.cache-hit != 'true'
- uses: actions/checkout@v3
+ uses: actions/checkout@v4
with:
- path: GSI
+ path: gsi
# Cache spack, compiler and dependencies
- name: cache-env
@@ -43,16 +52,15 @@ jobs:
spack
~/.spack
/opt/intel
- key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }}
+ key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }}
- name: install-intel-compilers
- if: steps.cache-env.outputs.cache-hit != 'true'
run: |
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
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
+ sudo apt-get install intel-oneapi-dev-utilities intel-oneapi-mpi-devel intel-oneapi-openmp intel-oneapi-compiler-fortran-2023.2.1 intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic-2023.2.1
sudo apt-get clean
echo "source /opt/intel/oneapi/setvars.sh" >> ~/.bash_profile
@@ -62,31 +70,32 @@ jobs:
run: |
sudo mv /usr/local/ /usr_local_mv
sudo apt-get install cmake
- git clone -c feature.manyFiles=true https://github.com/NOAA-EMC/spack.git
+ git clone -c feature.manyFiles=true https://github.com/JCSDA/spack.git
source spack/share/spack/setup-env.sh
- spack env create gsi-env GSI/ci/spack.yaml
+ spack env create gsi-env gsi/ci/spack.yaml
spack env activate gsi-env
spack compiler find
+ sudo apt install cmake
spack external find
spack add intel-oneapi-mpi
spack concretize
spack install -v --fail-fast --dirty
spack clean -a
- build:
+ gsi:
needs: setup
runs-on: ubuntu-latest
steps:
- - name: checkout-gsi
- uses: actions/checkout@v3
- with:
- path: GSI
-
- name: install-intel
run: |
echo "source /opt/intel/oneapi/setvars.sh" >> ~/.bash_profile
+ - name: checkout
+ uses: actions/checkout@v4
+ with:
+ path: gsi
+
- name: cache-env
id: cache-env
uses: actions/cache@v3
@@ -95,13 +104,13 @@ jobs:
spack
~/.spack
/opt/intel
- key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('GSI/ci/spack.yaml') }}
+ key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('gsi/ci/spack.yaml') }}
- - name: build-gsi
+ - name: build
run: |
source spack/share/spack/setup-env.sh
spack env activate gsi-env
- cd GSI
+ cd gsi
mkdir -p build && cd build
cmake -DCMAKE_INSTALL_PREFIX=../install -DGSI_MODE=Regional -DENKF_MODE=GFS -DBUILD_REG_TESTING=OFF ..
make -j2 VERBOSE=1
diff --git a/CMakeLists.txt b/CMakeLists.txt
index ac2a6a71c7..176a765262 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -29,6 +29,7 @@ endif()
option(OPENMP "Enable OpenMP Threading" OFF)
option(ENABLE_MKL "Use MKL for LAPACK implementation (if available)" ON)
option(BUILD_GSDCLOUD "Build GSD Cloud Analysis Library" OFF)
+option(BUILD_MGBF "Build MGBF Library" ON)
option(BUILD_GSI "Build GSI" ON)
option(BUILD_ENKF "Build EnKF" ON)
option(BUILD_REG_TESTING "Build the Regression Testing Suite" OFF)
@@ -37,6 +38,7 @@ option(BUILD_REG_TESTING "Build the Regression Testing Suite" OFF)
message(STATUS "OPENMP ................. ${OPENMP}")
message(STATUS "ENABLE_MKL ............. ${ENABLE_MKL}")
message(STATUS "BUILD_GSDCLOUD ......... ${BUILD_GSDCLOUD}")
+message(STATUS "BUILD_MGBF ............. ${BUILD_MGBF}")
message(STATUS "BUILD_GSI .............. ${BUILD_GSI}")
message(STATUS "BUILD_ENKF ............. ${BUILD_ENKF}")
message(STATUS "BUILD_REG_TESTING ...... ${BUILD_REG_TESTING}")
diff --git a/INSTALL.md b/INSTALL.md
index 8e3187f603..eca09919c3 100644
--- a/INSTALL.md
+++ b/INSTALL.md
@@ -79,6 +79,7 @@ CMake allows for various options that can be specified on the command line via `
| `OPENMP` | Enable OpenMP Threading (`OFF`) |
| `ENABLE_MKL` | Use MKL (`ON`), If not found use LAPACK |
| `BUILD_GSDCLOUD` | Build GSD Cloud Library (`OFF`) |
+| `BUILD_MGBF` | Build MGBF Library (`ON`) |
| `BUILD_GSI` | Build GSI library and executable (`ON`) |
| `BUILD_ENKF` | Build EnKF library and executable (`ON`) |
| `BUILD_REG_TESTING` | Enable Regression Testing (`ON`) |
diff --git a/LICENSE.md b/LICENSE.md
new file mode 100644
index 0000000000..0927556b54
--- /dev/null
+++ b/LICENSE.md
@@ -0,0 +1,157 @@
+### GNU LESSER GENERAL PUBLIC LICENSE
+
+Version 3, 29 June 2007
+
+Copyright (C) 2007 Free Software Foundation, Inc.
+
+
+Everyone is permitted to copy and distribute verbatim copies of this
+license document, but changing it is not allowed.
+
+This version of the GNU Lesser General Public License incorporates the
+terms and conditions of version 3 of the GNU General Public License,
+supplemented by the additional permissions listed below.
+
+#### 0. Additional Definitions.
+
+As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the
+GNU General Public License.
+
+"The Library" refers to a covered work governed by this License, other
+than an Application or a Combined Work as defined below.
+
+An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+A "Combined Work" is a work produced by combining or linking an
+Application with the Library. The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+#### 1. Exception to Section 3 of the GNU GPL.
+
+You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+#### 2. Conveying Modified Versions.
+
+If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+- a) under this License, provided that you make a good faith effort
+ to ensure that, in the event an Application does not supply the
+ function or data, the facility still operates, and performs
+ whatever part of its purpose remains meaningful, or
+- b) under the GNU GPL, with none of the additional permissions of
+ this License applicable to that copy.
+
+#### 3. Object Code Incorporating Material from Library Header Files.
+
+The object code form of an Application may incorporate material from a
+header file that is part of the Library. You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+- a) Give prominent notice with each copy of the object code that
+ the Library is used in it and that the Library and its use are
+ covered by this License.
+- b) Accompany the object code with a copy of the GNU GPL and this
+ license document.
+
+#### 4. Combined Works.
+
+You may convey a Combined Work under terms of your choice that, taken
+together, effectively do not restrict modification of the portions of
+the Library contained in the Combined Work and reverse engineering for
+debugging such modifications, if you also do each of the following:
+
+- a) Give prominent notice with each copy of the Combined Work that
+ the Library is used in it and that the Library and its use are
+ covered by this License.
+- b) Accompany the Combined Work with a copy of the GNU GPL and this
+ license document.
+- c) For a Combined Work that displays copyright notices during
+ execution, include the copyright notice for the Library among
+ these notices, as well as a reference directing the user to the
+ copies of the GNU GPL and this license document.
+- d) Do one of the following:
+ - 0) Convey the Minimal Corresponding Source under the terms of
+ this License, and the Corresponding Application Code in a form
+ suitable for, and under terms that permit, the user to
+ recombine or relink the Application with a modified version of
+ the Linked Version to produce a modified Combined Work, in the
+ manner specified by section 6 of the GNU GPL for conveying
+ Corresponding Source.
+ - 1) Use a suitable shared library mechanism for linking with
+ the Library. A suitable mechanism is one that (a) uses at run
+ time a copy of the Library already present on the user's
+ computer system, and (b) will operate properly with a modified
+ version of the Library that is interface-compatible with the
+ Linked Version.
+- e) Provide Installation Information, but only if you would
+ otherwise be required to provide such information under section 6
+ of the GNU GPL, and only to the extent that such information is
+ necessary to install and execute a modified version of the
+ Combined Work produced by recombining or relinking the Application
+ with a modified version of the Linked Version. (If you use option
+ 4d0, the Installation Information must accompany the Minimal
+ Corresponding Source and Corresponding Application Code. If you
+ use option 4d1, you must provide the Installation Information in
+ the manner specified by section 6 of the GNU GPL for conveying
+ Corresponding Source.)
+
+#### 5. Combined Libraries.
+
+You may place library facilities that are a work based on the Library
+side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+- a) Accompany the combined library with a copy of the same work
+ based on the Library, uncombined with any other library
+ facilities, conveyed under the terms of this License.
+- b) Give prominent notice with the combined library that part of it
+ is a work based on the Library, and explaining where to find the
+ accompanying uncombined form of the same work.
+
+#### 6. Revised Versions of the GNU Lesser General Public License.
+
+The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library
+as you received it specifies that a certain numbered version of the
+GNU Lesser General Public License "or any later version" applies to
+it, you have the option of following the terms and conditions either
+of that published version or of any later version published by the
+Free Software Foundation. If the Library as you received it does not
+specify a version number of the GNU Lesser General Public License, you
+may choose any version of the GNU Lesser General Public License ever
+published by the Free Software Foundation.
+
+If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.
diff --git a/ci/spack.yaml b/ci/spack.yaml
index eeb9f95512..647904108e 100644
--- a/ci/spack.yaml
+++ b/ci/spack.yaml
@@ -6,20 +6,20 @@ spack:
- intel
- gcc@10:10
specs:
- - netcdf-c@4.7.4
- - netcdf-fortran@4.5.3
+ - netcdf-c@4.9.2
+ - netcdf-fortran@4.6.1
- bufr@11.7.0
- bacio@2.4.1
- - w3emc@2.9.2
- - sp@2.3.3
- - ip@3.3.3
+ - w3emc@2.10.0
+ - sp@2.5.0
+ - ip@4.3.0
- sigio@2.3.2
- sfcio@1.4.1
- - nemsio@2.5.2
+ - nemsio@2.5.4
- wrf-io@1.2.0
- ncio@1.1.2
- - crtm@2.3.0
- - gsi-ncdiag@1.0.0
+ - crtm@2.4.0.1
+ - gsi-ncdiag@1.1.2
view: true
concretizer:
unify: true
diff --git a/fix b/fix
index 0be26971f8..15ffa60307 160000
--- a/fix
+++ b/fix
@@ -1 +1 @@
-Subproject commit 0be26971f834fe9b1d5b118e1e0ffed53facf671
+Subproject commit 15ffa60307bbc19746d8caeb41782de0b7604be6
diff --git a/modulefiles/gsi_cheyenne.gnu.lua b/modulefiles/gsi_cheyenne.gnu.lua
deleted file mode 100644
index 494ec6fb18..0000000000
--- a/modulefiles/gsi_cheyenne.gnu.lua
+++ /dev/null
@@ -1,32 +0,0 @@
-help([[
-]])
-
-load("cmake/3.22.0")
-load("python/3.7.9")
-load("ncarenv/1.3")
-load("gnu/10.1.0")
-load("mpt/2.22")
-load("ncarcompilers/0.5.0")
-unload("netcdf")
-
-prepend_path("MODULEPATH", "/glade/work/epicufsrt/GMTB/tools/gnu/10.1.0/hpc-stack-v1.2.0/modulefiles/stack")
-
-load("hpc/1.2.0")
-load("hpc-gnu/10.1.0")
-load("hpc-mpt/2.22")
-
--- Preload w3nco to work around nemsio "find_dependency(w3nco)" hpc-stack bug
-load("w3nco/2.4.1")
-
-load("gsi_common")
-
-local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2"
-load(pathJoin("prod_util", prod_util_ver))
-
-pushenv("MKLROOT", "/glade/u/apps/opt/intel/2022.1/mkl/latest")
-
-pushenv("CC", "mpicc")
-pushenv("FC", "mpif90")
-pushenv("CXX", "mpicxx")
-
-whatis("Description: GSI environment on Cheyenne with GNU Compilers")
diff --git a/modulefiles/gsi_cheyenne.intel.lua b/modulefiles/gsi_cheyenne.intel.lua
deleted file mode 100644
index 72bf458516..0000000000
--- a/modulefiles/gsi_cheyenne.intel.lua
+++ /dev/null
@@ -1,26 +0,0 @@
-help([[
-]])
-
-load("cmake/3.22.0")
-load("python/3.7.9")
-load("ncarenv/1.3")
-load("intel/2022.1")
-load("mpt/2.25")
-load("ncarcompilers/0.5.0")
-
-prepend_path("MODULEPATH", "/glade/work/epicufsrt/GMTB/tools/intel/2022.1/hpc-stack-v1.2.0_6eb6/modulefiles/stack")
-
-load("hpc/1.2.0")
-load("hpc-intel/2022.1")
-load("hpc-mpt/2.25")
-load("mkl/2022.1")
-
-load("gsi_common")
-
-local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2"
-load(pathJoin("prod_util", prod_util_ver))
-
-pushenv("CFLAGS", "-xHOST")
-pushenv("FFLAGS", "-xHOST")
-
-whatis("Description: GSI environment on Cheyenne with Intel Compilers")
diff --git a/modulefiles/gsi_common.lua b/modulefiles/gsi_common.lua
index 6844372324..cb49a43878 100644
--- a/modulefiles/gsi_common.lua
+++ b/modulefiles/gsi_common.lua
@@ -2,22 +2,24 @@ help([[
Load common modules to build GSI on all machines
]])
-local netcdf_ver=os.getenv("netcdf_ver") or "4.7.4"
+local netcdf_c_ver=os.getenv("netcdf_c_ver") or "4.9.2"
+local netcdf_fortran_ver=os.getenv("netcdf_fortran_ver") or "4.6.1"
local bufr_ver=os.getenv("bufr_ver") or "11.7.0"
local bacio_ver=os.getenv("bacio_ver") or "2.4.1"
-local w3emc_ver=os.getenv("w3emc_ver") or "2.9.1"
-local sp_ver=os.getenv("sp_ver") or "2.3.3"
-local ip_ver=os.getenv("ip_ver") or "3.3.3"
+local w3emc_ver=os.getenv("w3emc_ver") or "2.10.0"
+local sp_ver=os.getenv("sp_ver") or "2.5.0"
+local ip_ver=os.getenv("ip_ver") or "4.3.0"
local sigio_ver=os.getenv("sigio_ver") or "2.3.2"
local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1"
-local nemsio_ver=os.getenv("nemsio_ver") or "2.5.2"
+local nemsio_ver=os.getenv("nemsio_ver") or "2.5.4"
local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0"
local ncio_ver=os.getenv("ncio_ver") or "1.1.2"
-local crtm_ver=os.getenv("crtm_ver") or "2.3.0"
-local ncdiag_ver=os.getenv("ncdiag_ver") or "1.0.0"
+local crtm_ver=os.getenv("crtm_ver") or "2.4.0.1"
+local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.2"
-load(pathJoin("netcdf", netcdf_ver))
+load(pathJoin("netcdf-c", netcdf_c_ver))
+load(pathJoin("netcdf-fortran", netcdf_fortran_ver))
load(pathJoin("bufr", bufr_ver))
load(pathJoin("bacio", bacio_ver))
@@ -27,8 +29,7 @@ load(pathJoin("ip", ip_ver))
load(pathJoin("sigio", sigio_ver))
load(pathJoin("sfcio", sfcio_ver))
load(pathJoin("nemsio", nemsio_ver))
-load(pathJoin("wrf_io", wrf_io_ver))
+load(pathJoin("wrf-io", wrf_io_ver))
load(pathJoin("ncio", ncio_ver))
load(pathJoin("crtm", crtm_ver))
-load(pathJoin("ncdiag",ncdiag_ver))
-
+load(pathJoin("gsi-ncdiag",ncdiag_ver))
diff --git a/modulefiles/gsi_discover b/modulefiles/gsi_discover.intel
similarity index 100%
rename from modulefiles/gsi_discover
rename to modulefiles/gsi_discover.intel
diff --git a/modulefiles/gsi_gaea b/modulefiles/gsi_gaea
deleted file mode 100644
index 91089895a1..0000000000
--- a/modulefiles/gsi_gaea
+++ /dev/null
@@ -1,65 +0,0 @@
-#%Module1.0
-######################################################################
-## NOAA-EMC/GSI
-##_____________________________________________________
-proc ModulesHelp { } {
-puts stderr "Set environment variables for NOAA-EMC/GSI"
-puts stderr "This module initializes the environment "
-puts stderr "for the Intel Compiler Suite $version\n"
-}
-module-whatis " NOAA-EMC/GSI whatis description"
-
-set COMPILER intel
-
-setenv FFLAGS_COM "-fp-model strict"
-setenv LDFLAGS_COM " "
-
-#set WRF_SHARED_VER v1.1.0
-#set WRF_SHARED_ROOT /gpfs/hps/nco/ops/nwprod/wrf_shared
-#set WRF_SHARED_ROOT /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/EXTERNAL/wrf_shared
-#setenv WRF_SHARED_PATH ${WRF_SHARED_ROOT}.${WRF_SHARED_VER}
-
-setenv NCEPLIBS /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib
-
-# Loading ncep environment
-##module load ncep/1.0
-module use /opt/cray/pe/craype/2.5.5/modulefiles
-
-# Loading Intel Compiler Suite
-module load PrgEnv-intel
-
-# Loading pe environment
-module load cray-mpich
-module load cray-libsci
-module unload craype-broadwell
-module load craype-haswell
-
-module use /sw/gaea/modulefiles
-module load cmake
-
-# Loading nceplibs modules
-module use /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/modulefiles
-#module load HDF5-serial-intel-haswell/1.8.9
-#module load NetCDF-intel-haswell/4.2
-module load cray-hdf5
-module load cray-netcdf
-
-#module use /gpfs/hps/nco/ops/nwprod/lib/modulefiles
-module load bufr-intel-sandybridge/11.0.1
-module load nemsio-intel-sandybridge/2.2.2
-module load sfcio-intel-sandybridge/1.0.0
-module load sigio-intel-sandybridge/2.0.1
-module load sp-intel-sandybridge/2.0.2
-module load w3nco-intel-sandybridge/2.0.6
-module load w3emc-intel-sandybridge/2.2.0
-module load crtm-intel/2.2.4
-#setenv CRTM_INC /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/crtm/v2.2.4/intel/include/crtm_v2.2.4
-#setenv CRTM_LIB /lustre/f1/pdata/ncep_shared/NCEPLIBS/lib/crtm/v2.2.4/intel/libcrtm_v2.2.4.a
-module load bacio-intel-sandybridge/2.0.2
-setenv CRAYOS_VERSION $::env(CRAYPE_VERSION)
-#setenv CRAYOS_VERSION ${CRAYPE_VERSION}
-
-# Compiler flags specific to this platform
-setenv CFLAGS "-xCORE-AVX2"
-setenv FFLAGS "-xCORE-AVX2"
-
diff --git a/modulefiles/gsi_gaea.intel.lua b/modulefiles/gsi_gaea.intel.lua
new file mode 100644
index 0000000000..799822caa8
--- /dev/null
+++ b/modulefiles/gsi_gaea.intel.lua
@@ -0,0 +1,32 @@
+help([[
+]])
+
+prepend_path("MODULEPATH", "/ncrc/proj/epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core")
+
+local stack_python_ver=os.getenv("stack_python_ver") or "3.11.6"
+local stack_intel_ver=os.getenv("stack_intel_ver") or "2023.1.0"
+local stack_cray_mpich_ver=os.getenv("stack_cray_mpich_ver") or "8.1.25"
+local cmake_ver=os.getenv("cmake_ver") or "3.23.1"
+local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1"
+
+load(pathJoin("stack-intel", stack_intel_ver))
+load(pathJoin("stack-cray-mpich", stack_cray_mpich_ver))
+load(pathJoin("stack-python", stack_python_ver))
+load(pathJoin("cmake", cmake_ver))
+
+load("gsi_common")
+load(pathJoin("prod_util", prod_util_ver))
+
+local MKLROOT="/opt/intel/oneapi/mkl/2022.0.2/"
+prepend_path("LD_LIBRARY_PATH",pathJoin(MKLROOT,"lib/intel64"))
+pushenv("MKLROOT", MKLROOT)
+
+pushenv("GSI_BINARY_SOURCE_DIR", "/gpfs/f5/ufs-ard/world-shared/GSI_data/fix/gsi/20240208")
+
+setenv("CC","cc")
+setenv("FC","ftn")
+setenv("CXX","CC")
+pushenv("CRAYPE_LINK_TYPE","dynamic")
+
+unload("cray-libsci")
+whatis("Description: GSI environment on Gaea with Intel Compilers")
diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua
index 3ed9fbddb0..eab352553f 100644
--- a/modulefiles/gsi_hera.gnu.lua
+++ b/modulefiles/gsi_hera.gnu.lua
@@ -1,25 +1,27 @@
help([[
]])
-prepend_path("MODULEPATH", "/scratch2/NCEPDEV/nwprod/hpc-stack/libs/hpc-stack/modulefiles/stack")
-
-local hpc_ver=os.getenv("hpc_ver") or "1.1.0"
-local hpc_gnu_ver=os.getenv("hpc_gnu_ver") or "9.2.0"
-local hpc_mpich_ver=os.getenv("hpc_mpich_ver") or "3.3.2"
-local cmake_ver=os.getenv("cmake_ver") or "3.20.1"
-local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2"
-
-load(pathJoin("hpc", hpc_ver))
-load(pathJoin("hpc-gnu", hpc_gnu_ver))
-load(pathJoin("hpc-mpich", hpc_mpich_ver))
+prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core")
+--Needed for openmpi build
+prepend_path("MODULEPATH", "/scratch1/NCEPDEV/jcsda/jedipara/spack-stack/modulefiles")
+
+local python_ver=os.getenv("python_ver") or "3.11.6"
+local stack_gnu_ver=os.getenv("stack_gnu_ver") or "9.2.0"
+local stack_openmpi_ver=os.getenv("stack_openmpi_ver") or "4.1.5"
+local cmake_ver=os.getenv("cmake_ver") or "3.23.1"
+local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1"
+local openblas_ver=os.getenv("openblas_ver") or "0.3.24"
+
+load(pathJoin("stack-gcc", stack_gnu_ver))
+load(pathJoin("stack-openmpi", stack_openmpi_ver))
+load(pathJoin("python", python_ver))
load(pathJoin("cmake", cmake_ver))
load("gsi_common")
load(pathJoin("prod_util", prod_util_ver))
+load(pathJoin("openblas", openblas_ver))
-pushenv("MKLROOT", "/apps/oneapi/mkl/2022.0.2")
-
-pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20221128")
+pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20240208")
whatis("Description: GSI environment on Hera with GNU Compilers")
diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua
index 1efb6f4405..d21b9195c3 100644
--- a/modulefiles/gsi_hera.intel.lua
+++ b/modulefiles/gsi_hera.intel.lua
@@ -1,31 +1,25 @@
help([[
]])
-prepend_path("MODULEPATH", "/scratch2/NCEPDEV/nwprod/hpc-stack/libs/hpc-stack/modulefiles/stack")
+prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev-rocky8/install/modulefiles/Core")
-local hpc_ver=os.getenv("hpc_ver") or "1.1.0"
-local hpc_intel_ver=os.getenv("hpc_intel_ver") or "18.0.5.274"
-local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2018.0.4"
-local cmake_ver=os.getenv("cmake_ver") or "3.20.1"
-local anaconda_ver=os.getenv("anaconda_ver") or "2.3.0"
-local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2"
+local python_ver=os.getenv("python_ver") or "3.11.6"
+local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0"
+local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1"
+local cmake_ver=os.getenv("cmake_ver") or "3.23.1"
+local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1"
-load(pathJoin("hpc", hpc_ver))
-load(pathJoin("hpc-intel", hpc_intel_ver))
-load(pathJoin("hpc-impi", hpc_impi_ver))
+load(pathJoin("stack-intel", stack_intel_ver))
+load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver))
+load(pathJoin("python", python_ver))
load(pathJoin("cmake", cmake_ver))
-prepend_path("MODULEPATH", "/contrib/anaconda/modulefiles")
-
-load(pathJoin("anaconda", anaconda_ver))
-
load("gsi_common")
-
load(pathJoin("prod_util", prod_util_ver))
pushenv("CFLAGS", "-xHOST")
pushenv("FFLAGS", "-xHOST")
-pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20221128")
+pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20240208")
whatis("Description: GSI environment on Hera with Intel Compilers")
diff --git a/modulefiles/gsi_hercules.intel.lua b/modulefiles/gsi_hercules.intel.lua
new file mode 100644
index 0000000000..597cc87291
--- /dev/null
+++ b/modulefiles/gsi_hercules.intel.lua
@@ -0,0 +1,36 @@
+help([[
+]])
+
+prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/hercules/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core")
+
+local stack_python_ver=os.getenv("stack_python_ver") or "3.11.6"
+local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.9.0"
+local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.9.0"
+local cmake_ver=os.getenv("cmake_ver") or "3.23.1"
+local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1"
+
+load(pathJoin("stack-intel", stack_intel_ver))
+load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver))
+load(pathJoin("python", stack_python_ver))
+load(pathJoin("cmake", cmake_ver))
+
+load("gsi_common")
+setenv("crtm_ROOT","/work/noaa/da/eliu/HERCULES/CRTM/crtm_v2.4.1-jedi.1/build")
+setenv("crtm_VERSION","2.4.1-jedi.1")
+setenv("CRTM_INC","/work/noaa/da/eliu/HERCULES/CRTM/crtm_v2.4.1-jedi.1/build/module")
+setenv("CRTM_LIB","/work/noaa/da/eliu/HERCULES/CRTM/crtm_v2.4.1-jedi.1/build/lib/libcrtm_static.a")
+setenv("CRTM_FIX","/work/noaa/da/eliu/HERCULES/CRTM-fix/crtm_v2.4.1-jedi.1-fix_gdasapp")
+whatis("Name: crtm")
+whatis("Version: 2.4.1-jedi.1")
+whatis("Category: library")
+whatis("Description: crtm library")
+
+load(pathJoin("prod_util", prod_util_ver))
+load("intel-oneapi-mkl/2022.2.1")
+
+pushenv("CFLAGS", "-xHOST")
+pushenv("FFLAGS", "-xHOST")
+
+pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20240208")
+
+whatis("Description: GSI environment on Hercules with Intel Compilers")
diff --git a/modulefiles/gsi_jet.intel.lua b/modulefiles/gsi_jet.intel.lua
new file mode 100644
index 0000000000..48189ba241
--- /dev/null
+++ b/modulefiles/gsi_jet.intel.lua
@@ -0,0 +1,25 @@
+help([[
+]])
+
+prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev-rocky8/install/modulefiles/Core")
+
+local python_ver=os.getenv("python_ver") or "3.11.6"
+local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0"
+local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1"
+local cmake_ver=os.getenv("cmake_ver") or "3.23.1"
+local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1"
+
+load(pathJoin("stack-intel", stack_intel_ver))
+load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver))
+load(pathJoin("python", python_ver))
+load(pathJoin("cmake", cmake_ver))
+
+load("gsi_common")
+load(pathJoin("prod_util", prod_util_ver))
+
+pushenv("CFLAGS", "-axSSE4.2,AVX,CORE-AVX2")
+pushenv("FFLAGS", "-axSSE4.2,AVX,CORE-AVX2")
+
+pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20240208")
+
+whatis("Description: GSI environment on Jet with Intel Compilers")
diff --git a/modulefiles/gsi_jet.lua b/modulefiles/gsi_jet.lua
deleted file mode 100644
index ddb255bc1f..0000000000
--- a/modulefiles/gsi_jet.lua
+++ /dev/null
@@ -1,26 +0,0 @@
-help([[
-]])
-
-load("cmake/3.20.1")
-
-prepend_path("MODULEPATH", "/contrib/anaconda/modulefiles")
-
-load("anaconda/5.3.1")
-
-prepend_path("MODULEPATH", "/lfs4/HFIP/hfv3gfs/nwprod/hpc-stack/libs/modulefiles/stack")
-
-load("hpc/1.1.0")
-load("hpc-intel/18.0.5.274")
-load("hpc-impi/2018.4.274")
-
-load("gsi_common")
-
-local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2"
-load(pathJoin("prod_util", prod_util_ver))
-
-pushenv("CFLAGS", "-axSSE4.2,AVX,CORE-AVX2")
-pushenv("FFLAGS", "-axSSE4.2,AVX,CORE-AVX2")
-
-pushenv("GSI_BINARY_SOURCE_DIR", "/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20221128")
-
-whatis("Description: GSI environment on Jet with Intel Compilers")
diff --git a/modulefiles/gsi_noaacloud.intel.lua b/modulefiles/gsi_noaacloud.intel.lua
new file mode 100644
index 0000000000..e2e019628e
--- /dev/null
+++ b/modulefiles/gsi_noaacloud.intel.lua
@@ -0,0 +1,25 @@
+help([[
+]])
+
+prepend_path("MODULEPATH", "/contrib/spack-stack/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core")
+
+local python_ver=os.getenv("python_ver") or "3.10.13"
+local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.3.0"
+local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.3.0"
+local cmake_ver=os.getenv("cmake_ver") or "3.23.1"
+local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1"
+
+load(pathJoin("stack-intel", stack_intel_ver))
+load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver))
+load(pathJoin("python", python_ver))
+load(pathJoin("cmake", cmake_ver))
+
+load("gsi_common")
+load(pathJoin("prod_util", prod_util_ver))
+
+pushenv("CFLAGS", "-xHOST")
+pushenv("FFLAGS", "-xHOST")
+
+pushenv("GSI_BINARY_SOURCE_DIR", "/contrib/Wei.Huang/data/hack-orion/fix/gsi/20240208")
+
+whatis("Description: GSI environment on NOAA Cloud with Intel Compilers")
diff --git a/modulefiles/gsi_orion.intel.lua b/modulefiles/gsi_orion.intel.lua
new file mode 100644
index 0000000000..ede89f5b77
--- /dev/null
+++ b/modulefiles/gsi_orion.intel.lua
@@ -0,0 +1,36 @@
+help([[
+]])
+
+prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.6.0/envs/gsi-addon-env-rocky9/install/modulefiles/Core")
+
+local stack_python_ver=os.getenv("stack_python_ver") or "3.11.6"
+local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.9.0"
+local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.9.0"
+local cmake_ver=os.getenv("cmake_ver") or "3.23.1"
+local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1"
+
+load(pathJoin("stack-intel", stack_intel_ver))
+load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver))
+load(pathJoin("python", stack_python_ver))
+load(pathJoin("cmake", cmake_ver))
+
+load("gsi_common")
+setenv("crtm_ROOT","/work/noaa/da/eliu/ORION/CRTM/crtm_v2.4.1-jedi.1/build")
+setenv("crtm_VERSION","2.4.1-jedi.1")
+setenv("CRTM_INC","/work/noaa/da/eliu/ORION/CRTM/crtm_v2.4.1-jedi.1/build/module")
+setenv("CRTM_LIB","/work/noaa/da/eliu/ORION/CRTM/crtm_v2.4.1-jedi.1/build/lib/libcrtm_static.a")
+setenv("CRTM_FIX","/work/noaa/da/eliu/ORION/CRTM-fix/crtm_v2.4.1-jedi.1-fix_gdasapp")
+whatis("Name: crtm")
+whatis("Version: 2.4.1-jedi.1")
+whatis("Category: library")
+whatis("Description: crtm library")
+
+load(pathJoin("prod_util", prod_util_ver))
+load("intel-oneapi-mkl/2022.2.1")
+
+pushenv("CFLAGS", "-xHOST")
+pushenv("FFLAGS", "-xHOST")
+
+pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20240208")
+
+whatis("Description: GSI environment on Orion with Intel Compilers")
diff --git a/modulefiles/gsi_orion.lua b/modulefiles/gsi_orion.lua
deleted file mode 100644
index b69467f7ce..0000000000
--- a/modulefiles/gsi_orion.lua
+++ /dev/null
@@ -1,28 +0,0 @@
-help([[
-]])
-
-prepend_path("MODULEPATH", "/apps/contrib/NCEP/libs/hpc-stack/modulefiles/stack")
-
-local hpc_ver=os.getenv("hpc_ver") or "1.1.0"
-local hpc_intel_ver=os.getenv("hpc_intel_ver") or "2018.4"
-local hpc_impi_ver=os.getenv("hpc_impi_ver") or "2018.4"
-local cmake_ver=os.getenv("cmake_ver") or "3.22.1"
-local python_ver=os.getenv("python_ver") or "3.7.5"
-local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2"
-
-load(pathJoin("hpc", hpc_ver))
-load(pathJoin("hpc-intel", hpc_intel_ver))
-load(pathJoin("hpc-impi", hpc_impi_ver))
-load(pathJoin("cmake", cmake_ver))
-load(pathJoin("python", python_ver))
-
-load("gsi_common")
-
-load(pathJoin("prod_util", prod_util_ver))
-
-pushenv("CFLAGS", "-xHOST")
-pushenv("FFLAGS", "-xHOST")
-
-pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20221128")
-
-whatis("Description: GSI environment on Orion with Intel Compilers")
diff --git a/modulefiles/gsi_s4.intel.lua b/modulefiles/gsi_s4.intel.lua
new file mode 100644
index 0000000000..04945eef3e
--- /dev/null
+++ b/modulefiles/gsi_s4.intel.lua
@@ -0,0 +1,25 @@
+help([[
+]])
+
+prepend_path("MODULEPATH", "/data/prod/jedi/spack-stack/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core")
+
+local python_ver=os.getenv("python_ver") or "3.11.6"
+local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0"
+local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.0"
+local cmake_ver=os.getenv("cmake_ver") or "3.23.1"
+local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1"
+
+load(pathJoin("stack-intel", stack_intel_ver))
+load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver))
+load(pathJoin("python", python_ver))
+load(pathJoin("cmake", cmake_ver))
+
+load("gsi_common")
+load(pathJoin("prod_util", prod_util_ver))
+
+pushenv("CFLAGS", "-march=ivybridge")
+pushenv("FFLAGS", "-march=ivybridge")
+
+pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20240208")
+
+whatis("Description: GSI environment on S4 with Intel Compilers")
diff --git a/modulefiles/gsi_s4.lua b/modulefiles/gsi_s4.lua
deleted file mode 100644
index f393ce516a..0000000000
--- a/modulefiles/gsi_s4.lua
+++ /dev/null
@@ -1,28 +0,0 @@
-help([[
-]])
-
-local hpc_ver=os.getenv("hpc_ver") or "1.1.0"
-local hpc_intel_ver=os.getenv("hpc_intel_ver") or "18.0.4"
-local hpc_impi_ver=os.getenv("hpc_impi_ver") or "18.0.4"
-local miniconda_ver=os.getenv("miniconda_ver") or "3.8-s4"
-local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2"
-
-prepend_path("MODULEPATH", "/data/prod/hpc-stack/modulefiles/stack")
-
-load("license_intel/S4")
-load(pathJoin("hpc", hpc_ver))
-load(pathJoin("hpc-intel", hpc_intel_ver))
-load(pathJoin("hpc-impi", hpc_impi_ver))
-
-load(pathJoin("miniconda", miniconda_ver))
-
-load("gsi_common")
-
-load(pathJoin("prod_util", prod_util_ver))
-
-pushenv("CFLAGS", "-march=ivybridge")
-pushenv("FFLAGS", "-march=ivybridge")
-
-pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20221128")
-
-whatis("Description: GSI environment on S4 with Intel Compilers")
diff --git a/modulefiles/gsi_wcoss2.intel.lua b/modulefiles/gsi_wcoss2.intel.lua
new file mode 100644
index 0000000000..c3bfd1156c
--- /dev/null
+++ b/modulefiles/gsi_wcoss2.intel.lua
@@ -0,0 +1,51 @@
+help([[
+]])
+
+local PrgEnv_intel_ver=os.getenv("PrgEnv_intel_ver") or "8.1.0"
+local intel_ver=os.getenv("intel_ver") or "19.1.3.304"
+local craype_ver=os.getenv("craype_ver") or "2.7.8"
+local cray_mpich_ver=os.getenv("cray_mpich_ver") or "8.1.7"
+local cmake_ver= os.getenv("cmake_ver") or "3.20.2"
+local python_ver=os.getenv("python_ver") or "3.8.6"
+local prod_util_ver=os.getenv("prod_util_ver") or "2.0.10"
+
+local netcdf_ver=os.getenv("netcdf_ver") or "4.7.4"
+local bufr_ver=os.getenv("bufr_ver") or "11.7.0"
+local bacio_ver=os.getenv("bacio_ver") or "2.4.1"
+local w3emc_ver=os.getenv("w3emc_ver") or "2.9.2"
+local sp_ver=os.getenv("sp_ver") or "2.3.3"
+local ip_ver=os.getenv("ip_ver") or "3.3.3"
+local sigio_ver=os.getenv("sigio_ver") or "2.3.2"
+local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1"
+local nemsio_ver=os.getenv("nemsio_ver") or "2.5.4"
+local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0"
+local ncio_ver=os.getenv("ncio_ver") or "1.1.2"
+local crtm_ver=os.getenv("crtm_ver") or "2.4.0.1"
+local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.1"
+
+load(pathJoin("PrgEnv-intel", PrgEnv_intel_ver))
+load(pathJoin("intel", intel_ver))
+load(pathJoin("craype", craype_ver))
+load(pathJoin("cray-mpich", cray_mpich_ver))
+load(pathJoin("cmake", cmake_ver))
+load(pathJoin("python", python_ver))
+
+load(pathJoin("prod_util", prod_util_ver))
+
+load(pathJoin("netcdf", netcdf_ver))
+load(pathJoin("bufr", bufr_ver))
+load(pathJoin("bacio", bacio_ver))
+load(pathJoin("w3emc", w3emc_ver))
+load(pathJoin("sp", sp_ver))
+load(pathJoin("ip", ip_ver))
+load(pathJoin("sigio", sigio_ver))
+load(pathJoin("sfcio", sfcio_ver))
+load(pathJoin("nemsio", nemsio_ver))
+load(pathJoin("wrf_io", wrf_io_ver))
+load(pathJoin("ncio", ncio_ver))
+load(pathJoin("crtm", crtm_ver))
+load(pathJoin("ncdiag",ncdiag_ver))
+
+pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20240208")
+
+whatis("Description: GSI environment on WCOSS2")
diff --git a/modulefiles/gsi_wcoss2.lua b/modulefiles/gsi_wcoss2.lua
deleted file mode 100644
index 84ffce874a..0000000000
--- a/modulefiles/gsi_wcoss2.lua
+++ /dev/null
@@ -1,34 +0,0 @@
-help([[
-]])
-
-local PrgEnv_intel_ver=os.getenv("PrgEnv_intel_ver") or "8.1.0"
-local intel_ver=os.getenv("intel_ver") or "19.1.3.304"
-local craype_ver=os.getenv("craype_ver") or "2.7.8"
-local cray_mpich_ver=os.getenv("cray_mpich_ver") or "8.1.7"
-local cmake_ver= os.getenv("cmake_ver") or "3.20.2"
-local python_ver=os.getenv("python_ver") or "3.8.6"
-local prod_util_ver=os.getenv("prod_util_ver") or "2.0.10"
-
-load(pathJoin("PrgEnv-intel", PrgEnv_intel_ver))
-load(pathJoin("intel", intel_ver))
-load(pathJoin("craype", craype_ver))
-load(pathJoin("cray-mpich", cray_mpich_ver))
-load(pathJoin("cmake", cmake_ver))
-load(pathJoin("python", python_ver))
-
-load(pathJoin("prod_util", prod_util_ver))
-
-load("gsi_common")
-unload("ncio")
-unload("ncdiag")
-
-pushenv("HPC_OPT", "/apps/ops/para/libs")
-prepend_path("MODULEPATH", "/apps/ops/para/libs/modulefiles/compiler/intel/19.1.3.304")
-prepend_path("MODULEPATH", "/apps/ops/para/libs/modulefiles/mpi/intel/19.1.3.304/cray-mpich/8.1.7")
-
-load("ncio/1.1.2")
-load("ncdiag/1.0.0")
-
-pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20221128")
-
-whatis("Description: GSI environment on WCOSS2")
diff --git a/regression/CMakeLists.txt b/regression/CMakeLists.txt
index cfbce04b40..e36cca605b 100644
--- a/regression/CMakeLists.txt
+++ b/regression/CMakeLists.txt
@@ -38,15 +38,22 @@ endif()
# GSI regression test names
list(APPEND GSI_REG_TEST_NAMES
- global_3dvar global_4dvar global_4denvar
- hwrf_nmm_d2 hwrf_nmm_d3 rtma
- rrfs_3denvar_glbens netcdf_fv3_regional
+ global_4denvar
+ rtma
+ rrfs_3denvar_rdasens
+ hafs_4denvar_glbens hafs_3denvar_hybens
)
# EnKF regression test names
-list(APPEND ENKF_REG_TEST_NAMES
- global_enkf
-)
+if(ENKF_MODE MATCHES "^(FV3REG)$")
+ list(APPEND ENKF_REG_TEST_NAMES
+ rrfs_enkf_conv
+ )
+else()
+ list(APPEND ENKF_REG_TEST_NAMES
+ global_enkf
+ )
+endif()
# Add GSI regression tests to list of tests
if(GSICONTROLEXEC)
diff --git a/regression/global_3dvar.sh b/regression/global_3dvar.sh
deleted file mode 100755
index 145cb6212c..0000000000
--- a/regression/global_3dvar.sh
+++ /dev/null
@@ -1,305 +0,0 @@
-set -x
-
-# Set experiment name and analysis date
-
-exp=$jobname
-
-# Set the JCAP resolution which you want.
-export JCAP=48
-export LEVS=127
-export JCAP_B=$JCAP
-
-# Set runtime directories
-tmpdir=$tmpdir/$tmpregdir/${exp}
-
-# Specify GSI fixed field and data directories.
-fixcrtm=${fixcrtm:-$CRTM_FIX}
-
-
-# Set variables used in script
-UNCOMPRESS=gunzip
-CLEAN=NO
-ncp=/bin/cp
-nln="/bin/ln -fs"
-
-
-# Given the requested resolution, set dependent resolution parameters
-if [[ "$JCAP" = "96" ]]; then
- export LONA=384
- export LATA=192
- export DELTIM=1200
-elif [[ "$JCAP" = "48" ]]; then
- export LONA=192
- export LATA=96
- export DELTIM=1200
-else
- echo "INVALID JCAP = $JCAP"
- exit
-fi
-export NLON=$LONA
-export NLAT=$((${LATA}+2))
-
-
-# Given the analysis date, compute the date from which the
-# first guess comes. Extract cycle and set prefix and suffix
-# for guess and observation data files
-gdate=`date +%Y%m%d%H -d "${global_adate:0:8} ${global_adate:8:2} - 6 hours"`
-PDYa=`echo $global_adate | cut -c1-8`
-cyca=`echo $global_adate | cut -c9-10`
-PDYg=`echo $gdate | cut -c1-8`
-cycg=`echo $gdate | cut -c9-10`
-
-dumpobs=gdas
-prefix_obs=${dumpobs}.t${cyca}z
-prefix_ges=gdas.t${cycg}z
-prefix_ens=gdas.t${cycg}z
-suffix=tm00.bufr_d
-
-dumpges=gdas
-COMROOTgfs=$casesdir/gfs/prod
-datobs=$COMROOTgfs/$dumpobs.$PDYa/${cyca}/atmos
-datges=$COMROOTgfs/$dumpges.$PDYg/${cycg}/atmos
-datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg}/atmos
-
-
-# Set up $tmpdir
-rm -rf $tmpdir
-mkdir -p $tmpdir
-cd $tmpdir
-
-# Make gsi namelist
-
-. $scripts/regression_nl_update.sh
-
-SETUP="$SETUP_update"
-GRIDOPTS="$GRIDOPTS_update"
-BKGVERR="$BKGVERR_update"
-ANBKGERR="$ANBKERR_update"
-JCOPTS="$JCOPTS_update"
-STRONGOPTS="$STRONGOPTS_update"
-OBSQC="$OBSQC_update"
-OBSINPUT="$OBSINPUT_update"
-SUPERRAD="$SUPERRAD_update"
-SINGLEOB="$SINGLEOB_update"
-
-if [ "$debug" = ".false." ]; then
- . $scripts/regression_namelists.sh global_3dvar
-else
- . $scripts/regression_namelists_db.sh global_3dvar
-fi
-
-cat << EOF > gsiparm.anl
-
-$gsi_namelist
-
-EOF
-
-# Set fixed files
-# berror = forecast model background error statistics
-# specoef = CRTM spectral coefficients
-# trncoef = CRTM transmittance coefficients
-# emiscoef = CRTM coefficients for IR sea surface emissivity model
-# aerocoef = CRTM coefficients for aerosol effects
-# cldcoef = CRTM coefficients for cloud effects
-# satinfo = text file with information about assimilation of brightness temperatures
-# satangl = angle dependent bias correction file (fixed in time)
-# pcpinfo = text file with information about assimilation of prepcipitation rates
-# ozinfo = text file with information about assimilation of ozone data
-# errtable = text file with obs error for conventional data (optional)
-# convinfo = text file with information about assimilation of conventional data
-# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.)
-# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.)
-# aeroinfo = text file with information about assimilation of aerosol data
-
-anavinfo=$fixgsi/global_anavinfo.l${LEVS}.txt
-berror=$fixgsi/Big_Endian/global_berror.l${LEVS}y${NLAT}.f77
-locinfo=$fixgsi/global_hybens_info.l${LEVS}.txt
-satinfo=$fixgsi/global_satinfo.txt
-scaninfo=$fixgsi/global_scaninfo.txt
-satangl=$fixgsi/global_satangbias.txt
-pcpinfo=$fixgsi/global_pcpinfo.txt
-ozinfo=$fixgsi/global_ozinfo.txt
-convinfo=$fixgsi/global_convinfo.txt
-vqcdat=$fixgsi/vqctp001.dat
-insituinfo=$fixgsi/global_insituinfo.txt
-errtable=$fixgsi/prepobs_errtable.global
-aeroinfo=$fixgsi/global_aeroinfo.txt
-atmsbeaminfo=$fixgsi/atms_beamwidth.txt
-cloudyinfo=$fixgsi/cloudy_radiance_info.txt
-
-emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin
-emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin
-emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin
-emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin
-emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin
-emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin
-emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin
-emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin
-emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin
-aercoef=$fixcrtm/AerosolCoeff.bin
-cldcoef=$fixcrtm/CloudCoeff.bin
-#cldcoef=$fixcrtm/CloudCoeff.GFDLFV3.-109z-1.bin # use with crtm/2.4.0
-
-# Only need this file for single obs test
-bufrtable=$fixgsi/prepobs_prep.bufrtable
-
-# Only need this file for sst retrieval
-bftab_sst=$fixgsi/bufrtab.012
-
-# Copy executable and fixed files to $tmpdir
-if [[ $exp == *"updat"* ]]; then
- $ncp $gsiexec_updat ./gsi.x
-elif [[ $exp == *"contrl"* ]]; then
- $ncp $gsiexec_contrl ./gsi.x
-fi
-
-$ncp $anavinfo ./anavinfo
-$ncp $berror ./berror_stats
-$ncp $locinfo ./hybens_info
-$ncp $satinfo ./satinfo
-$ncp $scaninfo ./scaninfo
-$ncp $pcpinfo ./pcpinfo
-$ncp $ozinfo ./ozinfo
-$ncp $convinfo ./convinfo
-$ncp $vqcdat ./vqctp001.dat
-$ncp $insituinfo ./insituinfo
-$ncp $errtable ./errtable
-$ncp $aeroinfo ./aeroinfo
-$ncp $atmsbeaminfo ./atms_beamwidth.txt
-$ncp $cloudyinfo ./cloudy_radiance_info.txt
-
-$ncp $bufrtable ./prepobs_prep.bufrtable
-$ncp $bftab_sst ./bftab_sstphr
-
-#If using correlated error, get the covariance files
-if grep -q "Rcov" $anavinfo ;
-then
- if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1;
- then
- $ncp ${fixgsi}/Rcov* $tmpdir
-
-# Correlated error utlizes mkl lapack. Found it necesary to fix the
-# number of mkl threads to ensure reproducible results independent
-# of the job configuration.
- export MKL_NUM_THREADS=1
-
- else
- echo "Warning: Satellite error covariance files are missing."
- echo "Check for the required Rcov files in " $ANAVINFO
- exit 1
- fi
-fi
-
-# Copy CRTM coefficient files based on entries in satinfo file
-export CRTM_PATH="./crtm_coeffs/"
-mkdir -p ${CRTM_PATH}
-for file in `awk '{if($1!~"!"){print $1}}' satinfo | sort | uniq` ;do
- $nln $fixcrtm/${file}.SpcCoeff.bin ${CRTM_PATH}/${file}.SpcCoeff.bin
- $nln $fixcrtm/${file}.TauCoeff.bin ${CRTM_PATH}/${file}.TauCoeff.bin
-done
-$nln $fixcrtm/amsua_metop-a_v2.SpcCoeff.bin ${CRTM_PATH}/amsua_metop-a_v2.SpcCoeff.bin
-
-$nln $emiscoef_IRwater ${CRTM_PATH}Nalli.IRwater.EmisCoeff.bin
-$nln $emiscoef_IRice ${CRTM_PATH}NPOESS.IRice.EmisCoeff.bin
-$nln $emiscoef_IRsnow ${CRTM_PATH}NPOESS.IRsnow.EmisCoeff.bin
-$nln $emiscoef_IRland ${CRTM_PATH}NPOESS.IRland.EmisCoeff.bin
-$nln $emiscoef_VISice ${CRTM_PATH}NPOESS.VISice.EmisCoeff.bin
-$nln $emiscoef_VISland ${CRTM_PATH}NPOESS.VISland.EmisCoeff.bin
-$nln $emiscoef_VISsnow ${CRTM_PATH}NPOESS.VISsnow.EmisCoeff.bin
-$nln $emiscoef_VISwater ${CRTM_PATH}NPOESS.VISwater.EmisCoeff.bin
-$nln $emiscoef_MWwater ${CRTM_PATH}FASTEM6.MWwater.EmisCoeff.bin
-$nln $aercoef ${CRTM_PATH}AerosolCoeff.bin
-$nln $cldcoef ${CRTM_PATH}CloudCoeff.bin
-
-# Copy observational data
-$nln $datobs/${prefix_obs}.prepbufr ./prepbufr
-$nln $datobs/${prefix_obs}.prepbufr.acft_profiles ./prepbufr_profl
-$nln $datobs/${prefix_obs}.nsstbufr ./nsstbufr
-$nln $datobs/${prefix_obs}.syndata.tcvitals.tm00 ./tcvitl
-$nln $datobs/${prefix_obs}.gpsro.${suffix} ./gpsrobufr
-$nln $datobs/${prefix_obs}.satwnd.${suffix} ./satwndbufr
-$nln $datobs/${prefix_obs}.hdob.${suffix} ./hdobbufr
-
-$nln $datobs/${prefix_obs}.osbuv8.${suffix} ./sbuvbufr
-$nln $datobs/${prefix_obs}.gome.${suffix} ./gomebufr
-$nln $datobs/${prefix_obs}.omi.${suffix} ./omibufr
-$nln $datobs/${prefix_obs}.mls.${suffix} ./mlsbufr
-$nln $datobs/${prefix_obs}.ompsn8.${suffix} ./ompsnpbufr
-$nln $datobs/${prefix_obs}.ompst8.${suffix} ./ompstcbufr
-$nln $datobs/${prefix_obs}.ompslp.${suffix} ./ompslpbufr
-
-$nln $datobs/${prefix_obs}.goesfv.${suffix} ./gsnd1bufr
-$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db
-$nln $datobs/${prefix_obs}.airsev.${suffix} ./airsbufr
-$nln $datobs/${prefix_obs}.sevcsr.${suffix} ./seviribufr
-$nln $datobs/${prefix_obs}.saphir.${suffix} ./saphirbufr
-$nln $datobs/${prefix_obs}.avcsam.${suffix} ./avhambufr
-$nln $datobs/${prefix_obs}.avcspm.${suffix} ./avhpmbufr
-$nln $datobs/${prefix_obs}.1bhrs4.${suffix} ./hirs4bufr
-$nln $datobs/${prefix_obs}.1bhrs2.${suffix} ./hirs2bufr
-$nln $datobs/${prefix_obs}.1bhrs3.${suffix} ./hirs3bufr
-$nln $datobs/${prefix_obs}.eshrs3.${suffix} ./hirs3bufrears
-$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db
-$nln $datobs/${prefix_obs}.mtiasi.${suffix} ./iasibufr
-$nln $datobs/${prefix_obs}.esiasi.${suffix} ./iasibufrears
-$nln $datobs/${prefix_obs}.iasidb.${suffix} ./iasibufr_db
-$nln $datobs/${prefix_obs}.crisf4.${suffix} ./crisfsbufr
-$nln $datobs/${prefix_obs}.escrsf.${suffix} ./crisfsbufrears
-$nln $datobs/${prefix_obs}.crsfdb.${suffix} ./crisfsbufr_db
-$nln $datobs/${prefix_obs}.ahicsr.${suffix} ./ahibufr
-$nln $datobs/${prefix_obs}.gsrcsr.${suffix} ./abibufr
-$nln $datobs/${prefix_obs}.sstvcw.${suffix} ./sstviirs
-
-$nln $datobs/${prefix_obs}.1bmhs.${suffix} ./mhsbufr
-$nln $datobs/${prefix_obs}.1bmsu.${suffix} ./msubufr
-$nln $datobs/${prefix_obs}.gmi1cr.${suffix} ./gmibufr
-$nln $datobs/${prefix_obs}.ssmit.${suffix} ./ssmitbufr
-$nln $datobs/${prefix_obs}.ssmisu.${suffix} ./ssmisbufr
-$nln $datobs/${prefix_obs}.1bamua.${suffix} ./amsuabufr
-$nln $datobs/${prefix_obs}.esamua.${suffix} ./amsuabufrears
-$nln $datobs/${prefix_obs}.amuadb.${suffix} ./amsuabufr_db
-$nln $datobs/${prefix_obs}.1bamub.${suffix} ./amsubbufr
-$nln $datobs/${prefix_obs}.esamub.${suffix} ./amsubbufrears
-$nln $datobs/${prefix_obs}.amubdb.${suffix} ./amsubbufr_db
-$nln $datobs/${prefix_obs}.atms.${suffix} ./atmsbufr
-$nln $datobs/${prefix_obs}.atmsdb.${suffix} ./atmsbufr_db
-$nln $datobs/${prefix_obs}.esatms.${suffix} ./atmsbufrears
-
-# Do not process
-## $nln $datobs/${prefix_obs}.amsre.${suffix} ./amsrebufr
-## $nln $datobs/${prefix_obs}.amsr2.tm00.bufr_d ./amsr2bufr
-
-# Copy bias correction, atmospheric and surface files
-$nln $datges/${prefix_ges}.abias ./satbias_in
-$nln $datges/${prefix_ges}.abias_pc ./satbias_pc
-$nln $datges/${prefix_ges}.abias_air ./aircftbias_in
-$nln $datges/${prefix_ges}.radstat ./radstat.gdas
-
-member=mem001
-$nln $datens/$member/${prefix_ges}.sfcf003.nc ./sfcf03
-$nln $datens/$member/${prefix_ges}.sfcf006.nc ./sfcf06
-$nln $datens/$member/${prefix_ges}.sfcf009.nc ./sfcf09
-
-$nln $datens/$member/${prefix_ges}.atmf003.nc ./sigf03
-$nln $datens/$member/${prefix_ges}.atmf006.nc ./sigf06
-$nln $datens/$member/${prefix_ges}.atmf009.nc ./sigf09
-
-$nln $datens/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid
-
-
-listdiag=`tar xvf radstat.gdas | cut -d' ' -f2 | grep _ges`
-for type in $listdiag; do
- diag_file=`echo $type | cut -d',' -f1`
- fname=`echo $diag_file | cut -d'.' -f1`
- date=`echo $diag_file | cut -d'.' -f2`
- $UNCOMPRESS $diag_file
- fnameanl=$(echo $fname|sed 's/_ges//g')
- mv $fname.$date $fnameanl
-done
-
-# Run GSI
-echo "run gsi now"
-eval "$APRUN $tmpdir/gsi.x > stdout 2>&1"
-rc=$?
-
-exit $rc
diff --git a/regression/global_4denvar.sh b/regression/global_4denvar.sh
index 7212b819e9..945200eb66 100755
--- a/regression/global_4denvar.sh
+++ b/regression/global_4denvar.sh
@@ -55,14 +55,15 @@ cycg=`echo $gdate | cut -c9-10`
dumpobs=gdas
prefix_obs=${dumpobs}.t${cyca}z
prefix_ges=gdas.t${cycg}z
-prefix_ens=gdas.t${cycg}z
+prefix_ens=enkfgdas.t${cycg}z
suffix=tm00.bufr_d
dumpges=gdas
COMROOTgfs=$casesdir/gfs/prod
-datobs=$COMROOTgfs/$dumpobs.$PDYa/${cyca}/atmos
-datges=$COMROOTgfs/$dumpges.$PDYg/${cycg}/atmos
-datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg}/atmos
+datobs=$COMROOTgfs/$dumpobs.$PDYa/${cyca}/obs
+dathis=$COMROOTgfs/$dumpges.$PDYg/${cycg}/model/atmos/history
+datanl=$COMROOTgfs/gdas.$PDYg/${cycg}/analysis/atmos
+datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg}
# Set up $tmpdir
@@ -127,6 +128,8 @@ errtable=$fixgsi/prepobs_errtable.global
aeroinfo=$fixgsi/global_aeroinfo.txt
atmsbeaminfo=$fixgsi/atms_beamwidth.txt
cloudyinfo=$fixgsi/cloudy_radiance_info.txt
+cris_clddet=$fixgsi/CRIS_CLDDET.NL
+iasi_clddet=$fixgsi/IASI_CLDDET.NL
emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin
emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin
@@ -168,6 +171,8 @@ $ncp $errtable ./errtable
$ncp $aeroinfo ./aeroinfo
$ncp $atmsbeaminfo ./atms_beamwidth.txt
$ncp $cloudyinfo ./cloudy_radiance_info.txt
+$ncp $cris_clddet ./CRIS_CLDDET.NL
+$ncp $iasi_clddet ./IASI_CLDDET.NL
$ncp $bufrtable ./prepobs_prep.bufrtable
$ncp $bftab_sst ./bftab_sstphr
@@ -230,17 +235,11 @@ $nln $datobs/${prefix_obs}.ompst8.${suffix} ./ompstcbufr
$nln $datobs/${prefix_obs}.ompslp.${suffix} ./ompslpbufr
$nln $datobs/${prefix_obs}.goesfv.${suffix} ./gsnd1bufr
-$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db
$nln $datobs/${prefix_obs}.airsev.${suffix} ./airsbufr
$nln $datobs/${prefix_obs}.sevcsr.${suffix} ./seviribufr
$nln $datobs/${prefix_obs}.saphir.${suffix} ./saphirbufr
$nln $datobs/${prefix_obs}.avcsam.${suffix} ./avhambufr
$nln $datobs/${prefix_obs}.avcspm.${suffix} ./avhpmbufr
-$nln $datobs/${prefix_obs}.1bhrs4.${suffix} ./hirs4bufr
-$nln $datobs/${prefix_obs}.1bhrs2.${suffix} ./hirs2bufr
-$nln $datobs/${prefix_obs}.1bhrs3.${suffix} ./hirs3bufr
-$nln $datobs/${prefix_obs}.eshrs3.${suffix} ./hirs3bufrears
-$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db
$nln $datobs/${prefix_obs}.mtiasi.${suffix} ./iasibufr
$nln $datobs/${prefix_obs}.esiasi.${suffix} ./iasibufrears
$nln $datobs/${prefix_obs}.iasidb.${suffix} ./iasibufr_db
@@ -271,28 +270,28 @@ $nln $datobs/${prefix_obs}.esatms.${suffix} ./atmsbufrears
## $nln $datobs/${prefix_obs}.amsr2.tm00.bufr_d ./amsr2bufr
# Copy bias correction, atmospheric and surface files
-$nln $datges/${prefix_ges}.abias ./satbias_in
-$nln $datges/${prefix_ges}.abias_pc ./satbias_pc
-$nln $datges/${prefix_ges}.abias_air ./aircftbias_in
-$nln $datges/${prefix_ges}.radstat ./radstat.gdas
-
-$nln $datges/${prefix_ges}.sfcf003.nc ./sfcf03
-$nln $datges/${prefix_ges}.sfcf004.nc ./sfcf04
-$nln $datges/${prefix_ges}.sfcf005.nc ./sfcf05
-$nln $datges/${prefix_ges}.sfcf006.nc ./sfcf06
-$nln $datges/${prefix_ges}.sfcf007.nc ./sfcf07
-$nln $datges/${prefix_ges}.sfcf008.nc ./sfcf08
-$nln $datges/${prefix_ges}.sfcf009.nc ./sfcf09
-
-$nln $datges/${prefix_ges}.atmf003.nc ./sigf03
-$nln $datges/${prefix_ges}.atmf004.nc ./sigf04
-$nln $datges/${prefix_ges}.atmf005.nc ./sigf05
-$nln $datges/${prefix_ges}.atmf006.nc ./sigf06
-$nln $datges/${prefix_ges}.atmf007.nc ./sigf07
-$nln $datges/${prefix_ges}.atmf008.nc ./sigf08
-$nln $datges/${prefix_ges}.atmf009.nc ./sigf09
-
-$nln $datens/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid
+$nln $datanl/${prefix_ges}.abias ./satbias_in
+$nln $datanl/${prefix_ges}.abias_pc ./satbias_pc
+$nln $datanl/${prefix_ges}.abias_air ./aircftbias_in
+$nln $datanl/${prefix_ges}.radstat ./radstat.gdas
+
+$nln $dathis/${prefix_ges}.sfcf003.nc ./sfcf03
+$nln $dathis/${prefix_ges}.sfcf004.nc ./sfcf04
+$nln $dathis/${prefix_ges}.sfcf005.nc ./sfcf05
+$nln $dathis/${prefix_ges}.sfcf006.nc ./sfcf06
+$nln $dathis/${prefix_ges}.sfcf007.nc ./sfcf07
+$nln $dathis/${prefix_ges}.sfcf008.nc ./sfcf08
+$nln $dathis/${prefix_ges}.sfcf009.nc ./sfcf09
+
+$nln $dathis/${prefix_ges}.atmf003.nc ./sigf03
+$nln $dathis/${prefix_ges}.atmf004.nc ./sigf04
+$nln $dathis/${prefix_ges}.atmf005.nc ./sigf05
+$nln $dathis/${prefix_ges}.atmf006.nc ./sigf06
+$nln $dathis/${prefix_ges}.atmf007.nc ./sigf07
+$nln $dathis/${prefix_ges}.atmf008.nc ./sigf08
+$nln $dathis/${prefix_ges}.atmf009.nc ./sigf09
+
+$nln $datens/ensstat/model/atmos/history/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid
export ENS_PATH='./ensemble_data/'
mkdir -p ${ENS_PATH}
@@ -302,7 +301,7 @@ for fh in $flist; do
imem=1
while [[ $imem -le $NMEM_ENKF ]]; do
member="mem"`printf %03i $imem`
- $nln $datens/$member/$sigens ${ENS_PATH}sigf${fh}_ens_${member}
+ $nln $datens/$member/model/atmos/history/$sigens ${ENS_PATH}sigf${fh}_ens_${member}
(( imem = $imem + 1 ))
done
done
diff --git a/regression/global_4dvar.sh b/regression/global_4dvar.sh
deleted file mode 100755
index ec2a8396e0..0000000000
--- a/regression/global_4dvar.sh
+++ /dev/null
@@ -1,338 +0,0 @@
-set -x
-
-# Set experiment name and analysis date
-
-exp=$jobname
-
-# Set the JCAP resolution which you want.
-export JCAP=48
-export LEVS=127
-export JCAP_B=48
-
-# Set runtime directories
-tmpdir=$tmpdir/$tmpregdir/${exp}
-
-# Specify GSI fixed field and data directories.
-fixcrtm=${fixcrtm:-$CRTM_FIX}
-
-
-# Set variables used in script
-UNCOMPRESS=gunzip
-CLEAN=NO
-ncp=/bin/cp
-nln="/bin/ln -fs"
-
-
-# Given the requested resolution, set dependent resolution parameters
-if [[ "$JCAP" = "96" ]]; then
- export LONA=384
- export LATA=192
- export DELTIM=1200
-elif [[ "$JCAP" = "48" ]]; then
- export LONA=192
- export LATA=96
- export DELTIM=1200
-else
- echo "INVALID JCAP = $JCAP"
- exit
-fi
-export NLON=$LONA
-export NLAT=$((${LATA}+2))
-
-
-# Given the analysis date, compute the date from which the
-# first guess comes. Extract cycle and set prefix and suffix
-# for guess and observation data files
-gdate=`date +%Y%m%d%H -d "${global_adate:0:8} ${global_adate:8:2} - 6 hours"`
-PDYa=`echo $global_adate | cut -c1-8`
-cyca=`echo $global_adate | cut -c9-10`
-PDYg=`echo $gdate | cut -c1-8`
-cycg=`echo $gdate | cut -c9-10`
-
-dumpobs=gdas
-prefix_obs=${dumpobs}.t${cyca}z
-prefix_ges=gdas.t${cycg}z
-prefix_ens=gdas.t${cycg}z
-suffix=tm00.bufr_d
-
-dumpges=gdas
-COMROOTgfs=$casesdir/gfs/prod
-datobs=$COMROOTgfs/$dumpobs.$PDYa/${cyca}/atmos
-datges=$COMROOTgfs/$dumpges.$PDYg/${cycg}/atmos
-datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg}/atmos
-
-
-# Set up $tmpdir
-rm -rf $tmpdir
-mkdir -p $tmpdir
-cd $tmpdir
-
-# Make gsi namelist
-
-SETUP=""
-GRIDOPTS=""
-BKGVERR=""
-ANBKGERR=""
-JCOPTS=""
-STRONGOPTS=""
-OBSQC=""
-OBSINPUT=""
-SUPERRAD=""
-SINGLEOB=""
-
-
-# Set fixed files
-# berror = forecast model background error statistics
-# specoef = CRTM spectral coefficients
-# trncoef = CRTM transmittance coefficients
-# emiscoef = CRTM coefficients for IR sea surface emissivity model
-# aerocoef = CRTM coefficients for aerosol effects
-# cldcoef = CRTM coefficients for cloud effects
-# satinfo = text file with information about assimilation of brightness temperatures
-# satangl = angle dependent bias correction file (fixed in time)
-# pcpinfo = text file with information about assimilation of prepcipitation rates
-# ozinfo = text file with information about assimilation of ozone data
-# errtable = text file with obs error for conventional data (optional)
-# convinfo = text file with information about assimilation of conventional data
-# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.)
-# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.)
-# aeroinfo = text file with information about assimilation of aerosol data
-
-anavinfo=$fixgsi/global_anavinfo.l${LEVS}.txt
-berror=$fixgsi/Big_Endian/global_berror.l${LEVS}y${NLAT}.f77
-locinfo=$fixgsi/global_hybens_info.l${LEVS}.txt
-satinfo=$fixgsi/global_satinfo.txt
-scaninfo=$fixgsi/global_scaninfo.txt
-satangl=$fixgsi/global_satangbias.txt
-pcpinfo=$fixgsi/global_pcpinfo.txt
-ozinfo=$fixgsi/global_ozinfo.txt
-convinfo=$fixgsi/global_convinfo.txt
-vqcdat=$fixgsi/vqctp001.dat
-insituinfo=$fixgsi/global_insituinfo.txt
-errtable=$fixgsi/prepobs_errtable.global
-aeroinfo=$fixgsi/global_aeroinfo.txt
-atmsbeaminfo=$fixgsi/atms_beamwidth.txt
-cloudyinfo=$fixgsi/cloudy_radiance_info.txt
-
-emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin
-emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin
-emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin
-emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin
-emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin
-emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin
-emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin
-emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin
-emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin
-aercoef=$fixcrtm/AerosolCoeff.bin
-cldcoef=$fixcrtm/CloudCoeff.bin
-#cldcoef=$fixcrtm/CloudCoeff.GFDLFV3.-109z-1.bin # use with crtm/2.4.0
-
-# Only need this file for single obs test
-bufrtable=$fixgsi/prepobs_prep.bufrtable
-
-# Only need this file for sst retrieval
-bftab_sst=$fixgsi/bufrtab.012
-
-# Copy executable and fixed files to $tmpdir
-if [[ $exp == *"updat"* ]]; then
- $ncp $gsiexec_updat ./gsi.x
-elif [[ $exp == *"contrl"* ]]; then
- $ncp $gsiexec_contrl ./gsi.x
-fi
-
-$ncp $anavinfo ./anavinfo
-$ncp $berror ./berror_stats
-$ncp $locinfo ./hybens_info
-$ncp $satinfo ./satinfo
-$ncp $scaninfo ./scaninfo
-##$ncp $satangl ./satbias_angle
-$ncp $pcpinfo ./pcpinfo
-$ncp $ozinfo ./ozinfo
-$ncp $convinfo ./convinfo
-$ncp $vqcdat ./vqctp001.dat
-$ncp $insituinfo ./insituinfo
-$ncp $errtable ./errtable
-$ncp $aeroinfo ./aeroinfo
-$ncp $atmsbeaminfo ./atms_beamwidth.txt
-$ncp $cloudyinfo ./cloudy_radiance_info.txt
-
-$ncp $bufrtable ./prepobs_prep.bufrtable
-$ncp $bftab_sst ./bftab_sstphr
-
-#If using correlated error, get the covariance files
-if grep -q "Rcov" $anavinfo ;
-then
- if ls ${fixgsi}/Rcov* 1> /dev/null 2>&1;
- then
- $ncp ${fixgsi}/Rcov* $tmpdir
-
-# Correlated error utlizes mkl lapack. Found it necesary to fix the
-# number of mkl threads to ensure reproducible results independent
-# of the job configuration.
- export MKL_NUM_THREADS=1
-
- else
- echo "Warning: Satellite error covariance files are missing."
- echo "Check for the required Rcov files in " $ANAVINFO
- exit 1
- fi
-fi
-
-# Copy CRTM coefficient files based on entries in satinfo file
-export CRTM_PATH="./crtm_coeffs/"
-mkdir -p ${CRTM_PATH}
-for file in `awk '{if($1!~"!"){print $1}}' satinfo | sort | uniq` ;do
- $nln $fixcrtm/${file}.SpcCoeff.bin ${CRTM_PATH}/${file}.SpcCoeff.bin
- $nln $fixcrtm/${file}.TauCoeff.bin ${CRTM_PATH}/${file}.TauCoeff.bin
-done
-$nln $fixcrtm/amsua_metop-a_v2.SpcCoeff.bin ${CRTM_PATH}/amsua_metop-a_v2.SpcCoeff.bin
-
-$nln $emiscoef_IRwater ${CRTM_PATH}Nalli.IRwater.EmisCoeff.bin
-$nln $emiscoef_IRice ${CRTM_PATH}NPOESS.IRice.EmisCoeff.bin
-$nln $emiscoef_IRsnow ${CRTM_PATH}NPOESS.IRsnow.EmisCoeff.bin
-$nln $emiscoef_IRland ${CRTM_PATH}NPOESS.IRland.EmisCoeff.bin
-$nln $emiscoef_VISice ${CRTM_PATH}NPOESS.VISice.EmisCoeff.bin
-$nln $emiscoef_VISland ${CRTM_PATH}NPOESS.VISland.EmisCoeff.bin
-$nln $emiscoef_VISsnow ${CRTM_PATH}NPOESS.VISsnow.EmisCoeff.bin
-$nln $emiscoef_VISwater ${CRTM_PATH}NPOESS.VISwater.EmisCoeff.bin
-$nln $emiscoef_MWwater ${CRTM_PATH}FASTEM6.MWwater.EmisCoeff.bin
-$nln $aercoef ${CRTM_PATH}AerosolCoeff.bin
-$nln $cldcoef ${CRTM_PATH}CloudCoeff.bin
-
-# Copy observational data
-$nln $datobs/${prefix_obs}.prepbufr ./prepbufr
-$nln $datobs/${prefix_obs}.prepbufr.acft_profiles ./prepbufr_profl
-$nln $datobs/${prefix_obs}.nsstbufr ./nsstbufr
-$nln $datobs/${prefix_obs}.syndata.tcvitals.tm00 ./tcvitl
-$nln $datobs/${prefix_obs}.gpsro.${suffix} ./gpsrobufr
-$nln $datobs/${prefix_obs}.satwnd.${suffix} ./satwndbufr
-$nln $datobs/${prefix_obs}.hdob.${suffix} ./hdobbufr
-
-$nln $datobs/${prefix_obs}.osbuv8.${suffix} ./sbuvbufr
-$nln $datobs/${prefix_obs}.gome.${suffix} ./gomebufr
-$nln $datobs/${prefix_obs}.omi.${suffix} ./omibufr
-$nln $datobs/${prefix_obs}.mls.${suffix} ./mlsbufr
-$nln $datobs/${prefix_obs}.ompsn8.${suffix} ./ompsnpbufr
-$nln $datobs/${prefix_obs}.ompst8.${suffix} ./ompstcbufr
-$nln $datobs/${prefix_obs}.ompslp.${suffix} ./ompslpbufr
-
-$nln $datobs/${prefix_obs}.goesfv.${suffix} ./gsnd1bufr
-$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db
-$nln $datobs/${prefix_obs}.airsev.${suffix} ./airsbufr
-$nln $datobs/${prefix_obs}.sevcsr.${suffix} ./seviribufr
-$nln $datobs/${prefix_obs}.saphir.${suffix} ./saphirbufr
-$nln $datobs/${prefix_obs}.avcsam.${suffix} ./avhambufr
-$nln $datobs/${prefix_obs}.avcspm.${suffix} ./avhpmbufr
-$nln $datobs/${prefix_obs}.1bhrs4.${suffix} ./hirs4bufr
-$nln $datobs/${prefix_obs}.1bhrs2.${suffix} ./hirs2bufr
-$nln $datobs/${prefix_obs}.1bhrs3.${suffix} ./hirs3bufr
-$nln $datobs/${prefix_obs}.eshrs3.${suffix} ./hirs3bufrears
-$nln $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db
-$nln $datobs/${prefix_obs}.mtiasi.${suffix} ./iasibufr
-$nln $datobs/${prefix_obs}.esiasi.${suffix} ./iasibufrears
-$nln $datobs/${prefix_obs}.iasidb.${suffix} ./iasibufr_db
-$nln $datobs/${prefix_obs}.crisf4.${suffix} ./crisfsbufr
-$nln $datobs/${prefix_obs}.escrsf.${suffix} ./crisfsbufrears
-$nln $datobs/${prefix_obs}.crsfdb.${suffix} ./crisfsbufr_db
-$nln $datobs/${prefix_obs}.ahicsr.${suffix} ./ahibufr
-$nln $datobs/${prefix_obs}.gsrcsr.${suffix} ./abibufr
-$nln $datobs/${prefix_obs}.sstvcw.${suffix} ./sstviirs
-
-$nln $datobs/${prefix_obs}.1bmhs.${suffix} ./mhsbufr
-$nln $datobs/${prefix_obs}.1bmsu.${suffix} ./msubufr
-$nln $datobs/${prefix_obs}.gmi1cr.${suffix} ./gmibufr
-$nln $datobs/${prefix_obs}.ssmit.${suffix} ./ssmitbufr
-$nln $datobs/${prefix_obs}.ssmisu.${suffix} ./ssmisbufr
-$nln $datobs/${prefix_obs}.1bamua.${suffix} ./amsuabufr
-$nln $datobs/${prefix_obs}.esamua.${suffix} ./amsuabufrears
-$nln $datobs/${prefix_obs}.amuadb.${suffix} ./amsuabufr_db
-$nln $datobs/${prefix_obs}.1bamub.${suffix} ./amsubbufr
-$nln $datobs/${prefix_obs}.esamub.${suffix} ./amsubbufrears
-$nln $datobs/${prefix_obs}.amubdb.${suffix} ./amsubbufr_db
-$nln $datobs/${prefix_obs}.atms.${suffix} ./atmsbufr
-$nln $datobs/${prefix_obs}.atmsdb.${suffix} ./atmsbufr_db
-$nln $datobs/${prefix_obs}.esatms.${suffix} ./atmsbufrears
-
-# Do not process
-## $nln $datobs/${prefix_obs}.amsre.${suffix} ./amsrebufr
-## $nln $datobs/${prefix_obs}.amsr2.tm00.bufr_d ./amsr2bufr
-
-# Copy bias correction, atmospheric and surface files
-##$nln $datges/${prefix_ges}.abias ./satbias_in
-##$nln $datges/${prefix_ges}.abias_pc ./satbias_pc
-##$nln $datges/${prefix_ges}.abias_air ./aircftbias_in
-
-
-#$nln $datges/${prefix_ges}.abias.4dvar ./satbias_in
-$nln $datges/${prefix_ges}.satang.4dvar ./satbias_angle
-
-$nln $datges/${prefix_ges}.radstat ./radstat.gdas
-
-member=mem001
-$nln $datens/$member/${prefix_ges}.sfcf003.nc ./sfcf03
-##$nln $datens/$member/${prefix_ges}.sfcf004.nc ./sfcf04
-##$nln $datens/$member/${prefix_ges}.sfcf005.nc ./sfcf05
-$nln $datens/$member/${prefix_ges}.sfcf006.nc ./sfcf06
-##$nln $datens/$member/${prefix_ges}.sfcf007.nc ./sfcf07
-##$nln $datens/$member/${prefix_ges}.sfcf008.nc ./sfcf08
-$nln $datens/$member/${prefix_ges}.sfcf009.nc ./sfcf09
-
-$nln $datens/$member/${prefix_ges}.atmf003.nc ./sigf03
-##$nln $datens/$member/${prefix_ges}.atmf004.nc ./sigf04
-##$nln $datens/$member/${prefix_ges}.atmf005.nc ./sigf05
-$nln $datens/$member/${prefix_ges}.atmf006.nc ./sigf06
-##$nln $datens/$member/${prefix_ges}.atmf007.nc ./sigf07
-##$nln $datens/$member/${prefix_ges}.atmf008.nc ./sigf08
-$nln $datens/$member/${prefix_ges}.atmf009.nc ./sigf09
-
-$nln $datens/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid
-
-listdiag=`tar xvf radstat.gdas | cut -d' ' -f2 | grep _ges`
-for type in $listdiag; do
- diag_file=`echo $type | cut -d',' -f1`
- fname=`echo $diag_file | cut -d'.' -f1`
- date=`echo $diag_file | cut -d'.' -f2`
- $UNCOMPRESS $diag_file
- fnameanl=$(echo $fname|sed 's/_ges//g')
- mv $fname.$date $fnameanl
-done
-
-
-# Run GSI in observer mode
-SETUP="l4dvar=.true.,jiterstart=1,lobserver=.true.,iwrtinc=1,nhr_assimilation=6,nhr_obsbin=1,"
-if [ "$debug" = ".false." ]; then
- . $scripts/regression_namelists.sh global_lanczos
-else
- . $scripts/regression_namelists_db.sh global_lanczos
-fi
-rm gsiparm.anl
-cat << EOF > gsiparm.anl
-$gsi_namelist
-EOF
-cp gsiparm.anl gsiparm.anl.obsvr
-
-echo "run gsi now"
-eval "$APRUN $tmpdir/gsi.x < gsiparm.anl > stdout.obsvr 2>&1"
-rc=$?
-
-# Run gsi identity model 4dvar under Parallel Operating Environment (poe) on NCEP IBM
-rm -f siganl sfcanl.gsi satbias_out fort.2*
-rm -rf dir.0*
-
-# Create namelist for identity model 4dvar run
-SETUP="l4dvar=.true.,jiterstart=1,nhr_assimilation=6,nhr_obsbin=1,idmodel=.true.,iwrtinc=1,lanczosave=.true.,"
-if [ "$debug" = ".false." ]; then
- . $scripts/regression_namelists.sh global_lanczos
-else
- . $scripts/regression_namelists_db.sh global_lanczos
-fi
-rm gsiparm.anl
-cat < gsiparm.anl
-$gsi_namelist
-EOF
-
-echo "run gsi now"
-eval "$APRUN $tmpdir/gsi.x < gsiparm.anl > stdout 2>&1"
-rc=$?
-
-exit $rc
diff --git a/regression/global_enkf.sh b/regression/global_enkf.sh
index e458c5830d..a35f8d109f 100755
--- a/regression/global_enkf.sh
+++ b/regression/global_enkf.sh
@@ -51,17 +51,14 @@ cyca=`echo $global_adate | cut -c9-10`
PDYg=`echo $gdate | cut -c1-8`
cycg=`echo $gdate | cut -c9-10`
-dumpobs=gdas
-prefix_obs=${dumpobs}.t${cyca}z
-prefix_ges=gdas.t${cycg}z
-prefix_ens=gdas.t${cycg}z
+prefix_obs=enkfgdas.t${cyca}z
+prefix_ens=enkfgdas.t${cycg}z
suffix=tm00.bufr_d
dumpges=gdas
COMROOTgfs=$casesdir/gfs/prod
-datobs=$COMROOTgfs/enkfgdas.$PDYa/${cyca}/atmos
-datges=$COMROOTgfs/$dumpges.$PDYg/${cycg}/atmos
-datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg}/atmos
+datobs=$COMROOTgfs/enkfgdas.$PDYa/${cyca}/ensstat/analysis/atmos
+datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg}
# Set up $tmpdir
@@ -166,19 +163,19 @@ nfhrs=`echo $IAUFHRS_ENKF | sed 's/,/ /g'`
for fhr in $nfhrs; do
for imem in $(seq 1 $NMEM_ENKF); do
memchar="mem"$(printf %03i $imem)
- $nln $datens/$memchar/${prefix_ens}.atmf00${fhr}.nc sfg_${global_adate}_fhr0${fhr}_${memchar}
+ $nln $datens/$memchar/model/atmos/history/${prefix_ens}.atmf00${fhr}.nc sfg_${global_adate}_fhr0${fhr}_${memchar}
if [ $cnvw_option = ".true." ]; then
- $nln $datens/$memchar/${prefix_ens}sfcf00${fhr}.nc sfgsfc_${global_adate}_fhr0${fhr}_${memchar}
+ $nln $datens/$memchar/model/atmos/history/${prefix_ens}sfcf00${fhr}.nc sfgsfc_${global_adate}_fhr0${fhr}_${memchar}
fi
(( imem = $imem + 1 ))
done
- $nln $datens/${prefix_ens}.atmf00${fhr}.ensmean.nc sfg_${global_adate}_fhr0${fhr}_ensmean
+ $nln $datens/ensstat/model/atmos/history/${prefix_ens}.atmf00${fhr}.ensmean.nc sfg_${global_adate}_fhr0${fhr}_ensmean
if [ $cnvw_option = ".true." ]; then
$nln $datens/${prefix_ens}.sfcf00${fhr}.ensmean.nc sfgsfc_${global_adate}_fhr0${fhr}_ensmean
fi
done
-$nln $datobs/${prefix_obs}.abias_int ./satbias_in
+$nln $datobs/${prefix_obs}.abias_int.ensmean ./satbias_in
cd $tmpdir
diff --git a/regression/hafs_3denvar_hybens.sh b/regression/hafs_3denvar_hybens.sh
new file mode 100755
index 0000000000..fa128b8efa
--- /dev/null
+++ b/regression/hafs_3denvar_hybens.sh
@@ -0,0 +1,451 @@
+set -x
+# Set variables used in script
+# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone)
+# ncp is cp replacement, currently keep as /bin/cp
+
+UNCOMPRESS=gunzip
+CLEAN=NO
+ncp=/bin/cp
+nln="/bin/ln -sf"
+
+# HAFS test cases set up
+RUN_FGAT=YES # use FGAT or not
+RUN_ENSDA=YES
+l4densvar=.false.
+nhr_obsbin=-1
+l_both_fv3sar_gfs_ens=.true.
+n_ens_gfs=5
+n_ens_fv3sar=5
+
+#
+# Set experiment name
+#
+exp=$jobname
+
+#-----------------------------------------------------------------------
+#
+# Extract from ADATE the starting year, month, day, and hour of the
+# forecast. These are needed below for various operations.
+#
+#-----------------------------------------------------------------------
+#
+adate=${hafs_envar_adate}
+YYYYMMDDHH=$(date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2}")
+JJJ=$(date +%j -d "${adate:0:8} ${adate:8:2}")
+
+YYYY=${YYYYMMDDHH:0:4}
+MM=${YYYYMMDDHH:4:2}
+DD=${YYYYMMDDHH:6:2}
+HH=${YYYYMMDDHH:8:2}
+YYYYMMDD=${YYYYMMDDHH:0:8}
+PDY=${YYYYMMDD}
+cyc=${HH}
+# prior date and hour
+adateprior=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 6 hours"`
+
+ymdprior=$(echo ${adateprior} | cut -c1-8)
+hhprior=$(echo ${adateprior} | cut -c9-10)
+
+CDATEtm03=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 3 hours"`
+ymdtm03=$(echo ${CDATEtm03} | cut -c1-8)
+hhtm03=$(echo ${CDATEtm03} | cut -c9-10)
+
+CDATEtp03=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} + 3 hours"`
+ymdtp03=$(echo ${CDATEtp03} | cut -c1-8)
+hhtp03=$(echo ${CDATEtp03} | cut -c9-10)
+
+#
+#-----------------------------------------------------------------------
+#
+# go to working directory and save directory.
+# define fix and background path
+#
+#-----------------------------------------------------------------------
+# Set runtime and save directories
+tmpdir=$tmpdir/tmpreg_hafs_3denvar_hybens/${exp}
+savdir=$savdir/outreg_hafs_3denvar_hybens/${exp}
+
+# Set up $tmpdir
+rm -rf $tmpdir
+mkdir -p $tmpdir
+chgrp rstprod $tmpdir
+chmod 750 $tmpdir
+cd $tmpdir
+
+bkpath=${hafs_envar_ges}
+fixcrtm=${fixcrtm:-$CRTM_FIX}
+
+################################################################
+##### input data and fix directory #######################
+inputdata=${hafs_envar_ges}
+COMINgdas=${hafs_envar_ens}
+COMINobs=${hafs_envar_obs}
+COMINgfs=${hafs_envar_obs}
+WORKhafs=${hafs_envar_obs}
+##########################################################
+
+# use FGAT or not
+if [ ${RUN_FGAT} = "YES" ]; then
+ ln -sf ${inputdata}/coupler.res_03 .
+ ln -sf ${inputdata}/fv3_akbk_03 .
+ ln -sf ${inputdata}/fv3_sfcdata_03 .
+ ln -sf ${inputdata}/fv3_srfwnd_03 .
+ ln -sf ${inputdata}/fv3_dynvars_03 .
+ ln -sf ${inputdata}/fv3_tracer_03 .
+
+ ln -sf ${inputdata}/coupler.res_09 .
+ ln -sf ${inputdata}/fv3_akbk_09 .
+ ln -sf ${inputdata}/fv3_sfcdata_09 .
+ ln -sf ${inputdata}/fv3_srfwnd_09 .
+ ln -sf ${inputdata}/fv3_dynvars_09 .
+ ln -sf ${inputdata}/fv3_tracer_09 .
+fi
+
+# copy background and grib configuration files
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.coupler.res ./coupler.res
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_core.res.nc ./fv3_akbk
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.sfc_data.nc ./fv3_sfcdata
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_srf_wnd.res.tile1.nc ./fv3_srfwnd
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_core.res.tile1.nc ./fv3_dynvars
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_tracer.res.tile1.nc ./fv3_tracer
+
+cp ${bkpath}/oro_data.nc ./fv3_oro_data
+cp ${bkpath}/atmos_static.nc ./fv3_atmos_static
+cp ${bkpath}/grid_spec.nc ./fv3_grid_spec
+
+# create ensemble member file list
+if [ ${RUN_ENSDA} != "YES" ] || [ $l_both_fv3sar_gfs_ens = .true. ]; then
+# Link gdas ensemble members
+ mkdir -p ensemble_data
+ GSUFFIX=${GSUFFIX:-.nc}
+ if [ ${l4densvar:-.false.} = ".true." ]; then
+ fhrs="03 06 09"
+ else
+ fhrs="06"
+ fi
+ for fhh in $fhrs; do
+ rm -f filelist${fhh}
+ for mem in $(seq -f '%03g' 1 ${n_ens_gfs}); do
+ if [ -s ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}s${GSUFFIX:-.nc} ]; then
+ ${nln} ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}s${GSUFFIX:-.nc} ./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem}
+ elif [ -s ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}${GSUFFIX:-.nc} ]; then
+ ${nln} ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}${GSUFFIX:-.nc} ./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem}
+ fi
+ echo "./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem}" >> filelist${fhh}
+ done
+ done
+fi
+
+if [ ${RUN_ENSDA} = "YES" ]; then
+ for mem in $(seq -f '%03g' 1 ${n_ens_fv3sar})
+ do
+ RESTARTens=${inputdata}
+ fhh="06"
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-coupler.res .
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk .
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata .
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd .
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars .
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer .
+ if [ ! -s ./fv3_ens_grid_spec ]; then
+ ln -sf ${RESTARTens}/grid_spec.nc ./fv3_ens_grid_spec
+ fi
+ if [ ${l4densvar:-.false.} = ".true." ]; then
+ export ENS_NSTARTHR=3
+ fhh="03"
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-coupler.res .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer .
+ fhh="09"
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-coupler.res .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer .
+ fi
+ done
+fi
+if [ ${RUN_ENSDA} != "YES" ]; then
+ export N_ENS=${n_ens_gfs}
+ export BETA_S0=${BETA_S0:-0.2}
+ export GRID_RATIO_ENS=1
+ export REGIONAL_ENSEMBLE_OPTION=1
+elif [ ${RUN_ENSDA} = "YES" ]; then
+ if [ $l_both_fv3sar_gfs_ens = .false. ]; then
+ export N_ENS=${n_ens_fv3sar}
+ export BETA_S0=${BETA_S0:-0.0}
+ export GRID_RATIO_ENS=2
+ export grid_ratio_fv3_regional=2
+ export REGIONAL_ENSEMBLE_OPTION=5
+ elif [ $l_both_fv3sar_gfs_ens = .true. ]; then
+ export N_ENS=$((${n_ens_gfs} + ${n_ens_fv3sar}))
+ export BETA_S0=${BETA_S0:-0.0}
+ export GRID_RATIO_ENS=2
+ export grid_ratio_fv3_regional=2
+ export REGIONAL_ENSEMBLE_OPTION=5
+ fi
+fi
+
+#-----------------------------------------------------------------------
+#
+# link observation files
+# copy observation files to working directory
+#
+#-----------------------------------------------------------------------
+
+# Link GFS/GDAS input and observation files
+COMIN_OBS=${COMIN_OBS:-${COMINobs}}
+COMIN_GFS=${COMIN_GFS:-${COMINgfs}}
+
+OPREFIX=${OPREFIX:-"gfs.t${cyc}z."}
+OSUFFIX=${OSUFFIX:-""}
+PREPQC=${PREPQC:-${COMIN_OBS}/${OPREFIX}prepbufr${OSUFFIX}}
+PREPQCPF=${PREPQCPF:-${COMIN_OBS}/${OPREFIX}prepbufr.acft_profiles${OSUFFIX}}
+NSSTBF=${NSSTBF:-${COMIN_OBS}/${OPREFIX}nsstbufr${OSUFFIX}}
+SATWND=${SATWND:-${COMIN_OBS}/${OPREFIX}satwnd.tm00.bufr_d${OSUFFIX}}
+SATWHR=${SATWHR:-${COMIN_OBS}/${OPREFIX}satwhr.tm00.bufr_d${OSUFFIX}}
+OSCATBF=${OSCATBF:-${COMIN_OBS}/${OPREFIX}oscatw.tm00.bufr_d${OSUFFIX}}
+RAPIDSCATBF=${RAPIDSCATBF:-${COMIN_OBS}/${OPREFIX}rapidscatw.tm00.bufr_d${OSUFFIX}}
+GSNDBF=${GSNDBF:-${COMIN_OBS}/${OPREFIX}goesnd.tm00.bufr_d${OSUFFIX}}
+GSNDBF1=${GSNDBF1:-${COMIN_OBS}/${OPREFIX}goesfv.tm00.bufr_d${OSUFFIX}}
+B1HRS2=${B1HRS2:-${COMIN_OBS}/${OPREFIX}1bhrs2.tm00.bufr_d${OSUFFIX}}
+B1MSU=${B1MSU:-${COMIN_OBS}/${OPREFIX}1bmsu.tm00.bufr_d${OSUFFIX}}
+B1HRS3=${B1HRS3:-${COMIN_OBS}/${OPREFIX}1bhrs3.tm00.bufr_d${OSUFFIX}}
+B1HRS4=${B1HRS4:-${COMIN_OBS}/${OPREFIX}1bhrs4.tm00.bufr_d${OSUFFIX}}
+B1AMUA=${B1AMUA:-${COMIN_OBS}/${OPREFIX}1bamua.tm00.bufr_d${OSUFFIX}}
+B1AMUB=${B1AMUB:-${COMIN_OBS}/${OPREFIX}1bamub.tm00.bufr_d${OSUFFIX}}
+B1MHS=${B1MHS:-${COMIN_OBS}/${OPREFIX}1bmhs.tm00.bufr_d${OSUFFIX}}
+ESHRS3=${ESHRS3:-${COMIN_OBS}/${OPREFIX}eshrs3.tm00.bufr_d${OSUFFIX}}
+ESAMUA=${ESAMUA:-${COMIN_OBS}/${OPREFIX}esamua.tm00.bufr_d${OSUFFIX}}
+ESAMUB=${ESAMUB:-${COMIN_OBS}/${OPREFIX}esamub.tm00.bufr_d${OSUFFIX}}
+ESMHS=${ESMHS:-${COMIN_OBS}/${OPREFIX}esmhs.tm00.bufr_d${OSUFFIX}}
+HRS3DB=${HRS3DB:-${COMIN_OBS}/${OPREFIX}hrs3db.tm00.bufr_d${OSUFFIX}}
+AMUADB=${AMUADB:-${COMIN_OBS}/${OPREFIX}amuadb.tm00.bufr_d${OSUFFIX}}
+AMUBDB=${AMUBDB:-${COMIN_OBS}/${OPREFIX}amubdb.tm00.bufr_d${OSUFFIX}}
+MHSDB=${MHSDB:-${COMIN_OBS}/${OPREFIX}mhsdb.tm00.bufr_d${OSUFFIX}}
+AIRSBF=${AIRSBF:-${COMIN_OBS}/${OPREFIX}airsev.tm00.bufr_d${OSUFFIX}}
+IASIBF=${IASIBF:-${COMIN_OBS}/${OPREFIX}mtiasi.tm00.bufr_d${OSUFFIX}}
+ESIASI=${ESIASI:-${COMIN_OBS}/${OPREFIX}esiasi.tm00.bufr_d${OSUFFIX}}
+IASIDB=${IASIDB:-${COMIN_OBS}/${OPREFIX}iasidb.tm00.bufr_d${OSUFFIX}}
+AMSREBF=${AMSREBF:-${COMIN_OBS}/${OPREFIX}amsre.tm00.bufr_d${OSUFFIX}}
+AMSR2BF=${AMSR2BF:-${COMIN_OBS}/${OPREFIX}amsr2.tm00.bufr_d${OSUFFIX}}
+GMI1CRBF=${GMI1CRBF:-${COMIN_OBS}/${OPREFIX}gmi1cr.tm00.bufr_d${OSUFFIX}}
+SAPHIRBF=${SAPHIRBF:-${COMIN_OBS}/${OPREFIX}saphir.tm00.bufr_d${OSUFFIX}}
+SEVIRIBF=${SEVIRIBF:-${COMIN_OBS}/${OPREFIX}sevcsr.tm00.bufr_d${OSUFFIX}}
+AHIBF=${AHIBF:-${COMIN_OBS}/${OPREFIX}ahicsr.tm00.bufr_d${OSUFFIX}}
+ABIBF=${ABIBF:-${COMIN_OBS}/${OPREFIX}gsrcsr.tm00.bufr_d${OSUFFIX}}
+CRISBF=${CRISBF:-${COMIN_OBS}/${OPREFIX}cris.tm00.bufr_d${OSUFFIX}}
+ESCRIS=${ESCRIS:-${COMIN_OBS}/${OPREFIX}escris.tm00.bufr_d${OSUFFIX}}
+CRISDB=${CRISDB:-${COMIN_OBS}/${OPREFIX}crisdb.tm00.bufr_d${OSUFFIX}}
+CRISFSBF=${CRISFSBF:-${COMIN_OBS}/${OPREFIX}crisf4.tm00.bufr_d${OSUFFIX}}
+ESCRISFS=${ESCRISFS:-${COMIN_OBS}/${OPREFIX}escrsf.tm00.bufr_d${OSUFFIX}}
+CRISFSDB=${CRISFSDB:-${COMIN_OBS}/${OPREFIX}crsfdb.tm00.bufr_d${OSUFFIX}}
+ATMSBF=${ATMSBF:-${COMIN_OBS}/${OPREFIX}atms.tm00.bufr_d${OSUFFIX}}
+ESATMS=${ESATMS:-${COMIN_OBS}/${OPREFIX}esatms.tm00.bufr_d${OSUFFIX}}
+ATMSDB=${ATMSDB:-${COMIN_OBS}/${OPREFIX}atmsdb.tm00.bufr_d${OSUFFIX}}
+ESATMS=${ESATMS:-${COMIN_OBS}/${OPREFIX}esatms.tm00.bufr_d${OSUFFIX}}
+ATMSDB=${ATMSDB:-${COMIN_OBS}/${OPREFIX}atmsdb.tm00.bufr_d${OSUFFIX}}
+SSMITBF=${SSMITBF:-${COMIN_OBS}/${OPREFIX}ssmit.tm00.bufr_d${OSUFFIX}}
+SSMISBF=${SSMISBF:-${COMIN_OBS}/${OPREFIX}ssmisu.tm00.bufr_d${OSUFFIX}}
+SBUVBF=${SBUVBF:-${COMIN_OBS}/${OPREFIX}osbuv8.tm00.bufr_d${OSUFFIX}}
+OMPSNPBF=${OMPSNPBF:-${COMIN_OBS}/${OPREFIX}ompsn8.tm00.bufr_d${OSUFFIX}}
+OMPSTCBF=${OMPSTCBF:-${COMIN_OBS}/${OPREFIX}ompst8.tm00.bufr_d${OSUFFIX}}
+GOMEBF=${GOMEBF:-${COMIN_OBS}/${OPREFIX}gome.tm00.bufr_d${OSUFFIX}}
+OMIBF=${OMIBF:-${COMIN_OBS}/${OPREFIX}omi.tm00.bufr_d${OSUFFIX}}
+MLSBF=${MLSBF:-${COMIN_OBS}/${OPREFIX}mls.tm00.bufr_d${OSUFFIX}}
+OMPSLPBF=${OMPSLPBF:-${COMIN_OBS}/${OPREFIX}ompslp.tm00.bufr_d${OSUFFIX}}
+SMIPCP=${SMIPCP:-${COMIN_OBS}/${OPREFIX}spssmi.tm00.bufr_d${OSUFFIX}}
+TMIPCP=${TMIPCP:-${COMIN_OBS}/${OPREFIX}sptrmm.tm00.bufr_d${OSUFFIX}}
+if [[ ${use_bufr_nr:-no} = "no" ]]; then
+ GPSROBF=${GPSROBF:-${COMIN_OBS}/${OPREFIX}gpsro.tm00.bufr_d${OSUFFIX}}
+else
+ GPSROBF=${GPSROBF:-${COMIN_OBS}/${OPREFIX}gpsro.tm00.bufr_d.nr}
+fi
+TCVITL=${TCVITL:-${COMIN_GFS}/${OPREFIX}syndata.tcvitals.tm00}
+B1AVHAM=${B1AVHAM:-${COMIN_OBS}/${OPREFIX}avcsam.tm00.bufr_d${OSUFFIX}}
+B1AVHPM=${B1AVHPM:-${COMIN_OBS}/${OPREFIX}avcspm.tm00.bufr_d${OSUFFIX}}
+
+# Observational data
+if [[ ${use_bufr_nr:-no} = "no" ]] && [ -s $PREPQC ]; then
+ $ncp -Lp $PREPQC prepbufr
+else
+ touch prepbufr
+fi
+ln -sf $SATWND satwndbufr
+ln -sf $SATWHR satwhrbufr
+ln -sf $GSNDBF1 gsnd1bufr
+ln -sf $B1AMUA amsuabufr
+ln -sf $B1MHS mhsbufr
+ln -sf $ESAMUA amsuabufrears
+ln -sf $SBUVBF sbuvbufr
+ln -sf $OMPSNPBF ompsnpbufr
+ln -sf $OMPSTCBF ompstcbufr
+ln -sf $GOMEBF gomebufr
+ln -sf $OMIBF omibufr
+ln -sf $MLSBF mlsbufr
+ln -sf $AIRSBF airsbufr
+ln -sf $IASIBF iasibufr
+ln -sf $ESIASI iasibufrears
+ln -sf $IASIDB iasibufr_db
+ln -sf $AMSR2BF amsr2bufr
+ln -sf $GMI1CRBF gmibufr
+ln -sf $SAPHIRBF saphirbufr
+ln -sf $SEVIRIBF seviribufr
+ln -sf $CRISBF crisbufr
+ln -sf $ESCRIS crisbufrears
+ln -sf $CRISDB crisbufr_db
+ln -sf $CRISFSBF crisfsbufr
+ln -sf $ESCRISFS crisfsbufrears
+ln -sf $CRISFSDB crisfsbufr_db
+ln -sf $ATMSBF atmsbufr
+ln -sf $ESATMS atmsbufrears
+ln -sf $ATMSDB atmsbufr_db
+ln -sf $SSMISBF ssmisbufr
+ln -sf $GPSROBF gpsrobufr
+ln -sf $TCVITL tcvitl
+ln -sf $B1AVHAM avhambufr
+ln -sf $B1AVHPM avhpmbufr
+
+if [[ ${use_bufr_nr:-no} = "yes" ]]; then
+
+ if [ -s ${PREPQC}.nr ]; then
+ $ncp -L ${PREPQC}.nr prepbufr
+ fi
+ ln -sf ${SAPHIRBF}.nr saphirbufr
+
+fi
+# HAFS specific observations
+INTCOMobs=${WORKhafs}/obs_prep
+# Use updated prepbufr if exists
+if [ -s ${INTCOMobs}/hafs.t${cyc}z.prepbufr ]; then
+ ln -s ${INTCOMobs}/hafs.t${cyc}z.prepbufr prepbufr
+fi
+# cat tempdrop.prepbufr with drifting correction into prepbufr
+if [ -s ${INTCOMobs}/hafs.t${cyc}z.tempdrop.prepbufr ]; then
+ cat ${INTCOMobs}/hafs.t${cyc}z.tempdrop.prepbufr >> prepbufr
+fi
+if [ -s ${INTCOMobs}/hafs.t${cyc}z.tldplr.tm00.bufr_d ]; then
+ ln -s ${INTCOMobs}/hafs.t${cyc}z.tldplr.tm00.bufr_d tldplrbufr
+fi
+if [ -s ${INTCOMobs}/hafs.t${cyc}z.hdob.tm00.bufr_d ]; then
+ ln -s ${INTCOMobs}/hafs.t${cyc}z.hdob.tm00.bufr_d hdobbufr
+fi
+if [ -s ${INTCOMobs}/hafs.t${cyc}z.nexrad.tm00.bufr_d ]; then
+ ln -s ${INTCOMobs}/hafs.t${cyc}z.nexrad.tm00.bufr_d l2rwbufr
+fi
+
+
+#
+#-----------------------------------------------------------------------
+#
+# Create links to fix files in the FIXgsi directory.
+#
+#-----------------------------------------------------------------------
+
+ln -sf ${inputdata}/berror_stats .
+ln -sf ${inputdata}/satinfo .
+ln -sf ${inputdata}/atms_beamwidth.txt .
+ln -sf ${inputdata}/anavinfo .
+ln -sf ${inputdata}/convinfo .
+ln -sf ${inputdata}/ozinfo .
+ln -sf ${inputdata}/pcpinfo .
+ln -sf ${inputdata}/scaninfo .
+ln -sf ${inputdata}/errtable .
+ln -sf ${inputdata}/prepobs_prep.bufrtable .
+ln -sf ${inputdata}/bftab_sstphr .
+
+#-----------------------------------------------------------------------
+#
+# CRTM Spectral and Transmittance coefficients
+#
+#-----------------------------------------------------------------------
+emiscoef_IRwater=${fixcrtm}/Nalli.IRwater.EmisCoeff.bin
+emiscoef_IRice=${fixcrtm}/NPOESS.IRice.EmisCoeff.bin
+emiscoef_IRland=${fixcrtm}/NPOESS.IRland.EmisCoeff.bin
+emiscoef_IRsnow=${fixcrtm}/NPOESS.IRsnow.EmisCoeff.bin
+emiscoef_VISice=${fixcrtm}/NPOESS.VISice.EmisCoeff.bin
+emiscoef_VISland=${fixcrtm}/NPOESS.VISland.EmisCoeff.bin
+emiscoef_VISsnow=${fixcrtm}/NPOESS.VISsnow.EmisCoeff.bin
+emiscoef_VISwater=${fixcrtm}/NPOESS.VISwater.EmisCoeff.bin
+emiscoef_MWwater=${fixcrtm}/FASTEM6.MWwater.EmisCoeff.bin
+aercoef=${fixcrtm}/AerosolCoeff.bin
+cldcoef=${fixcrtm}/CloudCoeff.bin
+
+ln -sf ${emiscoef_IRwater} Nalli.IRwater.EmisCoeff.bin
+ln -sf $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin
+ln -sf $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin
+ln -sf $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin
+ln -sf $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin
+ln -sf $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin
+ln -sf $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin
+ln -sf $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin
+ln -sf $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin
+ln -sf $aercoef ./AerosolCoeff.bin
+ln -sf $cldcoef ./CloudCoeff.bin
+
+
+# Copy CRTM coefficient files based on entries in satinfo file
+for file in $(awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq) ;do
+ ln -sf ${fixcrtm}/${file}.SpcCoeff.bin ./
+ ln -sf ${fixcrtm}/${file}.TauCoeff.bin ./
+done
+
+# Read from previous cycles for satbias predictors (no online satbias)
+PASSIVE_BC=.false.
+UPD_PRED=0
+ln -sf ${COMINgdas}/gdas.t${hhprior}z.abias satbias_in
+ln -sf ${COMINgdas}/gdas.t${hhprior}z.abias_pc satbias_pc
+
+#-----------------------------------------------------------------------
+#
+# Build the GSI namelist on-the-fly
+#
+#-----------------------------------------------------------------------
+#
+
+. $scripts/regression_nl_update.sh
+
+SETUP="$SETUP_update"
+GRIDOPTS="$GRIDOPTS_update"
+BKGVERR="$BKGVERR_update"
+ANBKGERR="$ANBKERR_update"
+JCOPTS="$JCOPTS_update"
+STRONGOPTS="$STRONGOPTS_update"
+OBSQC="$OBSQC_update"
+OBSINPUT="$OBSINPUT_update"
+SUPERRAD="$SUPERRAD_update"
+HYBRID_ENSEMBLE='ensemble_path="",'
+SINGLEOB="$SINGLEOB_update"
+
+if [ "$debug" = ".false." ]; then
+ . $scripts/regression_namelists.sh hafs_envar
+else
+ . $scripts/regression_namelists_db.sh hafs_envar
+fi
+
+cat << EOF > gsiparm.anl
+
+$gsi_namelist
+
+EOF
+
+# Copy executable and fixed files to $tmpdir
+if [[ $exp == *"updat"* ]]; then
+ $ncp $gsiexec_updat ./gsi.x
+elif [[ $exp == *"contrl"* ]]; then
+ $ncp $gsiexec_contrl ./gsi.x
+fi
+
+# Run GSI
+cd $tmpdir
+echo "run gsi now"
+eval "$APRUN $tmpdir/gsi.x > stdout 2>&1"
+rc=$?
+exit $rc
+
+
+
diff --git a/regression/hafs_4denvar_glbens.sh b/regression/hafs_4denvar_glbens.sh
new file mode 100755
index 0000000000..ddbd53dcf9
--- /dev/null
+++ b/regression/hafs_4denvar_glbens.sh
@@ -0,0 +1,451 @@
+set -x
+# Set variables used in script
+# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone)
+# ncp is cp replacement, currently keep as /bin/cp
+
+UNCOMPRESS=gunzip
+CLEAN=NO
+ncp=/bin/cp
+nln="/bin/ln -sf"
+
+# HAFS test cases set up
+RUN_FGAT=YES # use FGAT or not
+RUN_ENSDA=NO
+l4densvar=.true.
+nhr_obsbin=3
+l_both_fv3sar_gfs_ens=.false.
+n_ens_gfs=5
+n_ens_fv3sar=5
+
+#
+# Set experiment name
+#
+exp=$jobname
+
+#-----------------------------------------------------------------------
+#
+# Extract from ADATE the starting year, month, day, and hour of the
+# forecast. These are needed below for various operations.
+#
+#-----------------------------------------------------------------------
+#
+adate=${hafs_envar_adate}
+YYYYMMDDHH=$(date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2}")
+JJJ=$(date +%j -d "${adate:0:8} ${adate:8:2}")
+
+YYYY=${YYYYMMDDHH:0:4}
+MM=${YYYYMMDDHH:4:2}
+DD=${YYYYMMDDHH:6:2}
+HH=${YYYYMMDDHH:8:2}
+YYYYMMDD=${YYYYMMDDHH:0:8}
+PDY=${YYYYMMDD}
+cyc=${HH}
+# prior date and hour
+adateprior=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 6 hours"`
+
+ymdprior=$(echo ${adateprior} | cut -c1-8)
+hhprior=$(echo ${adateprior} | cut -c9-10)
+
+CDATEtm03=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 3 hours"`
+ymdtm03=$(echo ${CDATEtm03} | cut -c1-8)
+hhtm03=$(echo ${CDATEtm03} | cut -c9-10)
+
+CDATEtp03=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} + 3 hours"`
+ymdtp03=$(echo ${CDATEtp03} | cut -c1-8)
+hhtp03=$(echo ${CDATEtp03} | cut -c9-10)
+
+#
+#-----------------------------------------------------------------------
+#
+# go to working directory and save directory.
+# define fix and background path
+#
+#-----------------------------------------------------------------------
+# Set runtime and save directories
+tmpdir=$tmpdir/tmpreg_hafs_4denvar_glbens/${exp}
+savdir=$savdir/outreg_hafs_4denvar_glbens/${exp}
+
+# Set up $tmpdir
+rm -rf $tmpdir
+mkdir -p $tmpdir
+chgrp rstprod $tmpdir
+chmod 750 $tmpdir
+cd $tmpdir
+
+bkpath=${hafs_envar_ges}
+fixcrtm=${fixcrtm:-$CRTM_FIX}
+
+################################################################
+##### input data and fix directory #######################
+inputdata=${hafs_envar_ges}
+COMINgdas=${hafs_envar_ens}
+COMINobs=${hafs_envar_obs}
+COMINgfs=${hafs_envar_obs}
+WORKhafs=${hafs_envar_obs}
+##########################################################
+
+# use FGAT or not
+if [ ${RUN_FGAT} = "YES" ]; then
+ ln -sf ${inputdata}/coupler.res_03 .
+ ln -sf ${inputdata}/fv3_akbk_03 .
+ ln -sf ${inputdata}/fv3_sfcdata_03 .
+ ln -sf ${inputdata}/fv3_srfwnd_03 .
+ ln -sf ${inputdata}/fv3_dynvars_03 .
+ ln -sf ${inputdata}/fv3_tracer_03 .
+
+ ln -sf ${inputdata}/coupler.res_09 .
+ ln -sf ${inputdata}/fv3_akbk_09 .
+ ln -sf ${inputdata}/fv3_sfcdata_09 .
+ ln -sf ${inputdata}/fv3_srfwnd_09 .
+ ln -sf ${inputdata}/fv3_dynvars_09 .
+ ln -sf ${inputdata}/fv3_tracer_09 .
+fi
+
+# copy background and grib configuration files
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.coupler.res ./coupler.res
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_core.res.nc ./fv3_akbk
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.sfc_data.nc ./fv3_sfcdata
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_srf_wnd.res.tile1.nc ./fv3_srfwnd
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_core.res.tile1.nc ./fv3_dynvars
+cp ${bkpath}/${YYYYMMDD}.${HH}0000.fv_tracer.res.tile1.nc ./fv3_tracer
+
+cp ${bkpath}/oro_data.nc ./fv3_oro_data
+cp ${bkpath}/atmos_static.nc ./fv3_atmos_static
+cp ${bkpath}/grid_spec.nc ./fv3_grid_spec
+
+# create ensemble member file list
+if [ ${RUN_ENSDA} != "YES" ] || [ $l_both_fv3sar_gfs_ens = .true. ]; then
+# Link gdas ensemble members
+ mkdir -p ensemble_data
+ GSUFFIX=${GSUFFIX:-.nc}
+ if [ ${l4densvar:-.false.} = ".true." ]; then
+ fhrs="03 06 09"
+ else
+ fhrs="06"
+ fi
+ for fhh in $fhrs; do
+ rm -f filelist${fhh}
+ for mem in $(seq -f '%03g' 1 ${n_ens_gfs}); do
+ if [ -s ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}s${GSUFFIX:-.nc} ]; then
+ ${nln} ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}s${GSUFFIX:-.nc} ./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem}
+ elif [ -s ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}${GSUFFIX:-.nc} ]; then
+ ${nln} ${COMINgdas}/enkfgdas.${ymdprior}/${hhprior}/atmos/mem${mem}/gdas.t${hhprior}z.atmf0${fhh}${GSUFFIX:-.nc} ./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem}
+ fi
+ echo "./ensemble_data/enkfgdas.${ymdprior}${hhprior}.atmf0${fhh}_ens_${mem}" >> filelist${fhh}
+ done
+ done
+fi
+
+if [ ${RUN_ENSDA} = "YES" ]; then
+ for mem in $(seq -f '%03g' 1 ${n_ens_fv3sar})
+ do
+ RESTARTens=${inputdata}
+ fhh="06"
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-coupler.res .
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk .
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata .
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd .
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars .
+ ln -sf ${inputdata}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer .
+ if [ ! -s ./fv3_ens_grid_spec ]; then
+ ln -sf ${RESTARTens}/grid_spec.nc ./fv3_ens_grid_spec
+ fi
+ if [ ${l4densvar:-.false.} = ".true." ]; then
+ export ENS_NSTARTHR=3
+ fhh="03"
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-coupler.res .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer .
+ fhh="09"
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-coupler.res .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_akbk .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_sfcdata .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_srfwnd .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_dynvars .
+ ${nln} ${RESTARTens}/fv3SAR${fhh}_ens_mem${mem}-fv3_tracer .
+ fi
+ done
+fi
+if [ ${RUN_ENSDA} != "YES" ]; then
+ export N_ENS=${n_ens_gfs}
+ export BETA_S0=${BETA_S0:-0.2}
+ export GRID_RATIO_ENS=1
+ export REGIONAL_ENSEMBLE_OPTION=1
+elif [ ${RUN_ENSDA} = "YES" ]; then
+ if [ $l_both_fv3sar_gfs_ens = .false. ]; then
+ export N_ENS=${n_ens_fv3sar}
+ export BETA_S0=${BETA_S0:-0.0}
+ export GRID_RATIO_ENS=2
+ export grid_ratio_fv3_regional=2
+ export REGIONAL_ENSEMBLE_OPTION=5
+ elif [ $l_both_fv3sar_gfs_ens = .true. ]; then
+ export N_ENS=$((${n_ens_gfs} + ${n_ens_fv3sar}))
+ export BETA_S0=${BETA_S0:-0.0}
+ export GRID_RATIO_ENS=2
+ export grid_ratio_fv3_regional=2
+ export REGIONAL_ENSEMBLE_OPTION=5
+ fi
+fi
+
+#-----------------------------------------------------------------------
+#
+# link observation files
+# copy observation files to working directory
+#
+#-----------------------------------------------------------------------
+
+# Link GFS/GDAS input and observation files
+COMIN_OBS=${COMIN_OBS:-${COMINobs}}
+COMIN_GFS=${COMIN_GFS:-${COMINgfs}}
+
+OPREFIX=${OPREFIX:-"gfs.t${cyc}z."}
+OSUFFIX=${OSUFFIX:-""}
+PREPQC=${PREPQC:-${COMIN_OBS}/${OPREFIX}prepbufr${OSUFFIX}}
+PREPQCPF=${PREPQCPF:-${COMIN_OBS}/${OPREFIX}prepbufr.acft_profiles${OSUFFIX}}
+NSSTBF=${NSSTBF:-${COMIN_OBS}/${OPREFIX}nsstbufr${OSUFFIX}}
+SATWND=${SATWND:-${COMIN_OBS}/${OPREFIX}satwnd.tm00.bufr_d${OSUFFIX}}
+SATWHR=${SATWHR:-${COMIN_OBS}/${OPREFIX}satwhr.tm00.bufr_d${OSUFFIX}}
+OSCATBF=${OSCATBF:-${COMIN_OBS}/${OPREFIX}oscatw.tm00.bufr_d${OSUFFIX}}
+RAPIDSCATBF=${RAPIDSCATBF:-${COMIN_OBS}/${OPREFIX}rapidscatw.tm00.bufr_d${OSUFFIX}}
+GSNDBF=${GSNDBF:-${COMIN_OBS}/${OPREFIX}goesnd.tm00.bufr_d${OSUFFIX}}
+GSNDBF1=${GSNDBF1:-${COMIN_OBS}/${OPREFIX}goesfv.tm00.bufr_d${OSUFFIX}}
+B1HRS2=${B1HRS2:-${COMIN_OBS}/${OPREFIX}1bhrs2.tm00.bufr_d${OSUFFIX}}
+B1MSU=${B1MSU:-${COMIN_OBS}/${OPREFIX}1bmsu.tm00.bufr_d${OSUFFIX}}
+B1HRS3=${B1HRS3:-${COMIN_OBS}/${OPREFIX}1bhrs3.tm00.bufr_d${OSUFFIX}}
+B1HRS4=${B1HRS4:-${COMIN_OBS}/${OPREFIX}1bhrs4.tm00.bufr_d${OSUFFIX}}
+B1AMUA=${B1AMUA:-${COMIN_OBS}/${OPREFIX}1bamua.tm00.bufr_d${OSUFFIX}}
+B1AMUB=${B1AMUB:-${COMIN_OBS}/${OPREFIX}1bamub.tm00.bufr_d${OSUFFIX}}
+B1MHS=${B1MHS:-${COMIN_OBS}/${OPREFIX}1bmhs.tm00.bufr_d${OSUFFIX}}
+ESHRS3=${ESHRS3:-${COMIN_OBS}/${OPREFIX}eshrs3.tm00.bufr_d${OSUFFIX}}
+ESAMUA=${ESAMUA:-${COMIN_OBS}/${OPREFIX}esamua.tm00.bufr_d${OSUFFIX}}
+ESAMUB=${ESAMUB:-${COMIN_OBS}/${OPREFIX}esamub.tm00.bufr_d${OSUFFIX}}
+ESMHS=${ESMHS:-${COMIN_OBS}/${OPREFIX}esmhs.tm00.bufr_d${OSUFFIX}}
+HRS3DB=${HRS3DB:-${COMIN_OBS}/${OPREFIX}hrs3db.tm00.bufr_d${OSUFFIX}}
+AMUADB=${AMUADB:-${COMIN_OBS}/${OPREFIX}amuadb.tm00.bufr_d${OSUFFIX}}
+AMUBDB=${AMUBDB:-${COMIN_OBS}/${OPREFIX}amubdb.tm00.bufr_d${OSUFFIX}}
+MHSDB=${MHSDB:-${COMIN_OBS}/${OPREFIX}mhsdb.tm00.bufr_d${OSUFFIX}}
+AIRSBF=${AIRSBF:-${COMIN_OBS}/${OPREFIX}airsev.tm00.bufr_d${OSUFFIX}}
+IASIBF=${IASIBF:-${COMIN_OBS}/${OPREFIX}mtiasi.tm00.bufr_d${OSUFFIX}}
+ESIASI=${ESIASI:-${COMIN_OBS}/${OPREFIX}esiasi.tm00.bufr_d${OSUFFIX}}
+IASIDB=${IASIDB:-${COMIN_OBS}/${OPREFIX}iasidb.tm00.bufr_d${OSUFFIX}}
+AMSREBF=${AMSREBF:-${COMIN_OBS}/${OPREFIX}amsre.tm00.bufr_d${OSUFFIX}}
+AMSR2BF=${AMSR2BF:-${COMIN_OBS}/${OPREFIX}amsr2.tm00.bufr_d${OSUFFIX}}
+GMI1CRBF=${GMI1CRBF:-${COMIN_OBS}/${OPREFIX}gmi1cr.tm00.bufr_d${OSUFFIX}}
+SAPHIRBF=${SAPHIRBF:-${COMIN_OBS}/${OPREFIX}saphir.tm00.bufr_d${OSUFFIX}}
+SEVIRIBF=${SEVIRIBF:-${COMIN_OBS}/${OPREFIX}sevcsr.tm00.bufr_d${OSUFFIX}}
+AHIBF=${AHIBF:-${COMIN_OBS}/${OPREFIX}ahicsr.tm00.bufr_d${OSUFFIX}}
+ABIBF=${ABIBF:-${COMIN_OBS}/${OPREFIX}gsrcsr.tm00.bufr_d${OSUFFIX}}
+CRISBF=${CRISBF:-${COMIN_OBS}/${OPREFIX}cris.tm00.bufr_d${OSUFFIX}}
+ESCRIS=${ESCRIS:-${COMIN_OBS}/${OPREFIX}escris.tm00.bufr_d${OSUFFIX}}
+CRISDB=${CRISDB:-${COMIN_OBS}/${OPREFIX}crisdb.tm00.bufr_d${OSUFFIX}}
+CRISFSBF=${CRISFSBF:-${COMIN_OBS}/${OPREFIX}crisf4.tm00.bufr_d${OSUFFIX}}
+ESCRISFS=${ESCRISFS:-${COMIN_OBS}/${OPREFIX}escrsf.tm00.bufr_d${OSUFFIX}}
+CRISFSDB=${CRISFSDB:-${COMIN_OBS}/${OPREFIX}crsfdb.tm00.bufr_d${OSUFFIX}}
+ATMSBF=${ATMSBF:-${COMIN_OBS}/${OPREFIX}atms.tm00.bufr_d${OSUFFIX}}
+ESATMS=${ESATMS:-${COMIN_OBS}/${OPREFIX}esatms.tm00.bufr_d${OSUFFIX}}
+ATMSDB=${ATMSDB:-${COMIN_OBS}/${OPREFIX}atmsdb.tm00.bufr_d${OSUFFIX}}
+ESATMS=${ESATMS:-${COMIN_OBS}/${OPREFIX}esatms.tm00.bufr_d${OSUFFIX}}
+ATMSDB=${ATMSDB:-${COMIN_OBS}/${OPREFIX}atmsdb.tm00.bufr_d${OSUFFIX}}
+SSMITBF=${SSMITBF:-${COMIN_OBS}/${OPREFIX}ssmit.tm00.bufr_d${OSUFFIX}}
+SSMISBF=${SSMISBF:-${COMIN_OBS}/${OPREFIX}ssmisu.tm00.bufr_d${OSUFFIX}}
+SBUVBF=${SBUVBF:-${COMIN_OBS}/${OPREFIX}osbuv8.tm00.bufr_d${OSUFFIX}}
+OMPSNPBF=${OMPSNPBF:-${COMIN_OBS}/${OPREFIX}ompsn8.tm00.bufr_d${OSUFFIX}}
+OMPSTCBF=${OMPSTCBF:-${COMIN_OBS}/${OPREFIX}ompst8.tm00.bufr_d${OSUFFIX}}
+GOMEBF=${GOMEBF:-${COMIN_OBS}/${OPREFIX}gome.tm00.bufr_d${OSUFFIX}}
+OMIBF=${OMIBF:-${COMIN_OBS}/${OPREFIX}omi.tm00.bufr_d${OSUFFIX}}
+MLSBF=${MLSBF:-${COMIN_OBS}/${OPREFIX}mls.tm00.bufr_d${OSUFFIX}}
+OMPSLPBF=${OMPSLPBF:-${COMIN_OBS}/${OPREFIX}ompslp.tm00.bufr_d${OSUFFIX}}
+SMIPCP=${SMIPCP:-${COMIN_OBS}/${OPREFIX}spssmi.tm00.bufr_d${OSUFFIX}}
+TMIPCP=${TMIPCP:-${COMIN_OBS}/${OPREFIX}sptrmm.tm00.bufr_d${OSUFFIX}}
+if [[ ${use_bufr_nr:-no} = "no" ]]; then
+ GPSROBF=${GPSROBF:-${COMIN_OBS}/${OPREFIX}gpsro.tm00.bufr_d${OSUFFIX}}
+else
+ GPSROBF=${GPSROBF:-${COMIN_OBS}/${OPREFIX}gpsro.tm00.bufr_d.nr}
+fi
+TCVITL=${TCVITL:-${COMIN_GFS}/${OPREFIX}syndata.tcvitals.tm00}
+B1AVHAM=${B1AVHAM:-${COMIN_OBS}/${OPREFIX}avcsam.tm00.bufr_d${OSUFFIX}}
+B1AVHPM=${B1AVHPM:-${COMIN_OBS}/${OPREFIX}avcspm.tm00.bufr_d${OSUFFIX}}
+
+# Observational data
+if [[ ${use_bufr_nr:-no} = "no" ]] && [ -s $PREPQC ]; then
+ $ncp -Lp $PREPQC prepbufr
+else
+ touch prepbufr
+fi
+ln -sf $SATWND satwndbufr
+ln -sf $SATWHR satwhrbufr
+ln -sf $GSNDBF1 gsnd1bufr
+ln -sf $B1AMUA amsuabufr
+ln -sf $B1MHS mhsbufr
+ln -sf $ESAMUA amsuabufrears
+ln -sf $SBUVBF sbuvbufr
+ln -sf $OMPSNPBF ompsnpbufr
+ln -sf $OMPSTCBF ompstcbufr
+ln -sf $GOMEBF gomebufr
+ln -sf $OMIBF omibufr
+ln -sf $MLSBF mlsbufr
+ln -sf $AIRSBF airsbufr
+ln -sf $IASIBF iasibufr
+ln -sf $ESIASI iasibufrears
+ln -sf $IASIDB iasibufr_db
+ln -sf $AMSR2BF amsr2bufr
+ln -sf $GMI1CRBF gmibufr
+ln -sf $SAPHIRBF saphirbufr
+ln -sf $SEVIRIBF seviribufr
+ln -sf $CRISBF crisbufr
+ln -sf $ESCRIS crisbufrears
+ln -sf $CRISDB crisbufr_db
+ln -sf $CRISFSBF crisfsbufr
+ln -sf $ESCRISFS crisfsbufrears
+ln -sf $CRISFSDB crisfsbufr_db
+ln -sf $ATMSBF atmsbufr
+ln -sf $ESATMS atmsbufrears
+ln -sf $ATMSDB atmsbufr_db
+ln -sf $SSMISBF ssmisbufr
+ln -sf $GPSROBF gpsrobufr
+ln -sf $TCVITL tcvitl
+ln -sf $B1AVHAM avhambufr
+ln -sf $B1AVHPM avhpmbufr
+
+if [[ ${use_bufr_nr:-no} = "yes" ]]; then
+
+ if [ -s ${PREPQC}.nr ]; then
+ $ncp -L ${PREPQC}.nr prepbufr
+ fi
+ ln -sf ${SAPHIRBF}.nr saphirbufr
+
+fi
+# HAFS specific observations
+INTCOMobs=${WORKhafs}/obs_prep
+# Use updated prepbufr if exists
+if [ -s ${INTCOMobs}/hafs.t${cyc}z.prepbufr ]; then
+ ln -s ${INTCOMobs}/hafs.t${cyc}z.prepbufr prepbufr
+fi
+# cat tempdrop.prepbufr with drifting correction into prepbufr
+if [ -s ${INTCOMobs}/hafs.t${cyc}z.tempdrop.prepbufr ]; then
+ cat ${INTCOMobs}/hafs.t${cyc}z.tempdrop.prepbufr >> prepbufr
+fi
+if [ -s ${INTCOMobs}/hafs.t${cyc}z.tldplr.tm00.bufr_d ]; then
+ ln -s ${INTCOMobs}/hafs.t${cyc}z.tldplr.tm00.bufr_d tldplrbufr
+fi
+if [ -s ${INTCOMobs}/hafs.t${cyc}z.hdob.tm00.bufr_d ]; then
+ ln -s ${INTCOMobs}/hafs.t${cyc}z.hdob.tm00.bufr_d hdobbufr
+fi
+if [ -s ${INTCOMobs}/hafs.t${cyc}z.nexrad.tm00.bufr_d ]; then
+ ln -s ${INTCOMobs}/hafs.t${cyc}z.nexrad.tm00.bufr_d l2rwbufr
+fi
+
+
+#
+#-----------------------------------------------------------------------
+#
+# Create links to fix files in the FIXgsi directory.
+#
+#-----------------------------------------------------------------------
+
+ln -sf ${inputdata}/berror_stats .
+ln -sf ${inputdata}/satinfo .
+ln -sf ${inputdata}/atms_beamwidth.txt .
+ln -sf ${inputdata}/anavinfo .
+ln -sf ${inputdata}/convinfo .
+ln -sf ${inputdata}/ozinfo .
+ln -sf ${inputdata}/pcpinfo .
+ln -sf ${inputdata}/scaninfo .
+ln -sf ${inputdata}/errtable .
+ln -sf ${inputdata}/prepobs_prep.bufrtable .
+ln -sf ${inputdata}/bftab_sstphr .
+
+#-----------------------------------------------------------------------
+#
+# CRTM Spectral and Transmittance coefficients
+#
+#-----------------------------------------------------------------------
+emiscoef_IRwater=${fixcrtm}/Nalli.IRwater.EmisCoeff.bin
+emiscoef_IRice=${fixcrtm}/NPOESS.IRice.EmisCoeff.bin
+emiscoef_IRland=${fixcrtm}/NPOESS.IRland.EmisCoeff.bin
+emiscoef_IRsnow=${fixcrtm}/NPOESS.IRsnow.EmisCoeff.bin
+emiscoef_VISice=${fixcrtm}/NPOESS.VISice.EmisCoeff.bin
+emiscoef_VISland=${fixcrtm}/NPOESS.VISland.EmisCoeff.bin
+emiscoef_VISsnow=${fixcrtm}/NPOESS.VISsnow.EmisCoeff.bin
+emiscoef_VISwater=${fixcrtm}/NPOESS.VISwater.EmisCoeff.bin
+emiscoef_MWwater=${fixcrtm}/FASTEM6.MWwater.EmisCoeff.bin
+aercoef=${fixcrtm}/AerosolCoeff.bin
+cldcoef=${fixcrtm}/CloudCoeff.bin
+
+ln -sf ${emiscoef_IRwater} Nalli.IRwater.EmisCoeff.bin
+ln -sf $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin
+ln -sf $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin
+ln -sf $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin
+ln -sf $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin
+ln -sf $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin
+ln -sf $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin
+ln -sf $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin
+ln -sf $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin
+ln -sf $aercoef ./AerosolCoeff.bin
+ln -sf $cldcoef ./CloudCoeff.bin
+
+
+# Copy CRTM coefficient files based on entries in satinfo file
+for file in $(awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq) ;do
+ ln -sf ${fixcrtm}/${file}.SpcCoeff.bin ./
+ ln -sf ${fixcrtm}/${file}.TauCoeff.bin ./
+done
+
+# Read from previous cycles for satbias predictors (no online satbias)
+PASSIVE_BC=.false.
+UPD_PRED=0
+ln -sf ${COMINgdas}/gdas.t${hhprior}z.abias satbias_in
+ln -sf ${COMINgdas}/gdas.t${hhprior}z.abias_pc satbias_pc
+
+#-----------------------------------------------------------------------
+#
+# Build the GSI namelist on-the-fly
+#
+#-----------------------------------------------------------------------
+#
+
+. $scripts/regression_nl_update.sh
+
+SETUP="$SETUP_update"
+GRIDOPTS="$GRIDOPTS_update"
+BKGVERR="$BKGVERR_update"
+ANBKGERR="$ANBKERR_update"
+JCOPTS="$JCOPTS_update"
+STRONGOPTS="$STRONGOPTS_update"
+OBSQC="$OBSQC_update"
+OBSINPUT="$OBSINPUT_update"
+SUPERRAD="$SUPERRAD_update"
+HYBRID_ENSEMBLE='ensemble_path="",'
+SINGLEOB="$SINGLEOB_update"
+
+if [ "$debug" = ".false." ]; then
+ . $scripts/regression_namelists.sh hafs_envar
+else
+ . $scripts/regression_namelists_db.sh hafs_envar
+fi
+
+cat << EOF > gsiparm.anl
+
+$gsi_namelist
+
+EOF
+
+# Copy executable and fixed files to $tmpdir
+if [[ $exp == *"updat"* ]]; then
+ $ncp $gsiexec_updat ./gsi.x
+elif [[ $exp == *"contrl"* ]]; then
+ $ncp $gsiexec_contrl ./gsi.x
+fi
+
+# Run GSI
+cd $tmpdir
+echo "run gsi now"
+eval "$APRUN $tmpdir/gsi.x > stdout 2>&1"
+rc=$?
+exit $rc
+
+
+
diff --git a/regression/hwrf_nmm_d2.sh b/regression/hwrf_nmm_d2.sh
deleted file mode 100755
index 2b4d2e1bfe..0000000000
--- a/regression/hwrf_nmm_d2.sh
+++ /dev/null
@@ -1,339 +0,0 @@
-
-set -x
-
-# Set analysis date
-adate=$hwrf_nmm_adate
-
-io_format=netcdf
-
-if [[ "$io_format" = "binary" ]]; then
- NETCDF=.false.
- FORMAT=binary
-elif [[ "$io_format" = "netcdf" ]]; then
- NETCDF=.true.
- FORMAT=netcdf
-else
- echo "***ERRROR*** INVALID io_format = $io_format"
- exit
-fi
-
-# Set experiment name and analysis date
-
-exp=$jobname
-
-# Set path/file for gsi executable
-#gsiexec=$gsiexec
-
-# Set the JCAP resolution which you want.
-# All resolutions use LEVS=64
-#export JCAP=62
-export LEVS=60
-export JCAP_B=$JCAP
-export DELTIM=1200
-
-# Set runtime and save directories
-tmpdir=$tmpdir/tmpreg_hwrf_nmm_d2/${exp}
-savdir=$savdir/outreg_hwrf_nmm_d2/${exp}
-
-# Specify GSI fixed field and data directories.
-fixcrtm=${fixcrtm:-$CRTM_FIX}
-
-#datobs=$datobs
-
-# Set variables used in script
-# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone)
-# ncp is cp replacement, currently keep as /bin/cp
-
-CLEAN=NO
-ncp=/bin/cp
-lnsf='ln -sf'
-
-NX2=166
-NY2=336
-export NLAT=$(( NY2 - 1 ))
-export NLON=$(( NX2 - 1 ))
-
-# Given the analysis date, compute the date from which the
-# first guess comes. Extract cycle and set prefix and suffix
-# for guess and observation data files
-gdate=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 6 hours"`
-hha=`echo $adate | cut -c9-10`
-hhg=`echo $gdate | cut -c9-10`
-prefixa=gfs.t${hha}z
-prefixo=gdas1.t${hha}z
-suffix=tm00.bufr_d
-
-
-# Set up $tmpdir
-rm -rf $tmpdir
-mkdir -p $tmpdir
-cd $tmpdir
-rm -rf core*
-
-# Make gsi namelist
-
-. $scripts/regression_nl_update.sh
-
-GRIDOPTS="$GRIDOPTS_update"
-BKGVERR="$BKGVERR_update"
-ANBKGERR="$ANBKERR_update"
-JCOPTS="$JCOPTS_update"
-STRONGOPTS="$STRONGOPTS_update"
-OBSQC="$OBSQC_update"
-OBSINPUT="$OBSINPUT_update"
-SUPERRAD="$SUPERRAD_update"
-SINGLEOB="$SINGLEOB_update"
-
-# parameters for radiance data assimilation
-export SETUP="newpc4pred=.true., adp_anglebc=.true., angord=4, \
- passive_bc=.false., use_edges=.false., emiss_bc=.true., \
- diag_precon=.true., step_start=1.e-3, upd_pred(1)=0, \
- upd_pred(2)=0,upd_pred(3)=0,upd_pred(4)=0, \
- upd_pred(5)=0,upd_pred(6)=0,upd_pred(7)=0, \
- upd_pred(8)=0,upd_pred(9)=0,upd_pred(10)=0, \
- upd_pred(11)=0,upd_pred(12)=0,"
-
-export USE_GFS_STRATOSPHERE=".true."
-export USE_GFS_OZONE=".true."
-export REGIONAL_OZONE=".false."
-
-if [ "$debug" = ".false." ]; then
- . $scripts/regression_namelists.sh hwrf_nmm_d2
-else
- . $scripts/regression_namelists_db.sh hwrf_nmm_d2
-fi
-
-cat << EOF > gsiparm.anl
-
-$gsi_namelist
-
-EOF
-
-# Set fixed files
-# berror = forecast model background error statistics
-# specoef = CRTM spectral coefficients
-# trncoef = CRTM transmittance coefficients
-# emiscoef = CRTM coefficients for IR sea surface emissivity model
-# aerocoef = CRTM coefficients for aerosol effects
-# cldcoef = CRTM coefficients for cloud effects
-# satinfo = text file with information about assimilation of brightness temperatures
-# cloudyinfo = text file with information about assimilation of cloudy radiance
-# pcpinfo = text file with information about assimilation of prepcipitation rates
-# ozinfo = text file with information about assimilation of ozone data
-# errtable = text file with obs error for conventional data (optional)
-# convinfo = text file with information about assimilation of conventional data
-# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.)
-# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.)
-
-anavinfo=$fixgsi/anavinfo_hwrf_L75
-berror=$fixgsi/$endianness/nam_glb_berror.f77.gcv
-emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin
-emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin
-emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin
-emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin
-emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin
-emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin
-emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin
-emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin
-emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin
-aercoef=$fixcrtm/AerosolCoeff.bin
-cldcoef=$fixcrtm/CloudCoeff.bin
-satinfo=$fixgsi/hwrf_satinfo.txt
-cloudyinfo=$fixgsi/cloudy_radiance_info.txt
-atmsbeaminfo=$fixgsi/atms_beamwidth.txt
-scaninfo=$fixgsi/global_scaninfo.txt
-pcpinfo=$fixgsi/nam_global_pcpinfo.txt
-ozinfo=$fixgsi/global_ozinfo.txt
-errtable=$fixgsi/hwrf_nam_errtable.r3dv
-convinfo=$fixgsi/hwrf_convinfo.txt
-### add 9 tables
-errtable_pw=$fixgsi/prepobs_errtable_pw.global
-errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf
-errtable_t=$fixgsi/prepobs_errtable_t.global_nqcf
-errtable_q=$fixgsi/prepobs_errtable_q.global_nqcf
-errtable_uv=$fixgsi/prepobs_errtable_uv.global_nqcf
-btable_ps=$fixgsi/nqc_b_ps.global_nqcf
-btable_t=$fixgsi/nqc_b_t.global_nqcf
-btable_q=$fixgsi/nqc_b_q.global_nqcf
-btable_uv=$fixgsi/nqc_b_uv.global_nqcf
-
-# add vertical profile of localization and beta_s,beta_e weights for hybrid ensemble runs
-hybens_info=$fixgsi/hwrf_hybens_d2_info
-
-
-# Only need this file for single obs test
-bufrtable=$fixgsi/prepobs_prep.bufrtable
-
-# Only need this file for sst retrieval
-bftab_sst=$fixgsi/bufrtab.012
-
-# Copy executable and fixed files to $tmpdir
-if [[ $exp == *"updat"* ]]; then
- $ncp $gsiexec_updat ./gsi.x
-elif [[ $exp == *"contrl"* ]]; then
- $ncp $gsiexec_contrl ./gsi.x
-fi
-
-$ncp $anavinfo ./anavinfo
-$ncp $berror ./berror_stats
-$ncp $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin
-$ncp $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin
-$ncp $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin
-$ncp $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin
-$ncp $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin
-$ncp $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin
-$ncp $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin
-$ncp $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin
-$ncp $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin
-$ncp $aercoef ./AerosolCoeff.bin
-$ncp $cldcoef ./CloudCoeff.bin
-$ncp $satinfo ./satinfo
-$ncp $cloudyinfo ./cloudy_radiance_info.txt
-$ncp $scaninfo ./scaninfo
-$ncp $pcpinfo ./pcpinfo
-$ncp $ozinfo ./ozinfo
-$ncp $convinfo ./convinfo
-$ncp $errtable ./errtable
-$ncp $atmsbeaminfo ./atms_beamwidth.txt
-
-#add 9 tables for new varqc
-$ncp $errtable_pw ./errtable_pw
-$ncp $errtable_ps ./errtable_ps
-$ncp $errtable_t ./errtable_t
-$ncp $errtable_q ./errtable_q
-$ncp $errtable_uv ./errtable_uv
-$ncp $btable_ps ./btable_ps
-$ncp $btable_t ./btable_t
-$ncp $btable_q ./btable_q
-$ncp $btable_uv ./btable_uv
-
-$ncp $hybens_info ./hybens_info
-
-$ncp $bufrtable ./prepobs_prep.bufrtable
-$ncp $bftab_sst ./bftab_sstphr
-
-# Copy CRTM coefficient files based on entries in satinfo file
-for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do
- $ncp $fixcrtm/${file}.SpcCoeff.bin ./
- $ncp $fixcrtm/${file}.TauCoeff.bin ./
-done
-
-
-# Copy observational data to $tmpdir
-$lnsf $hwrf_nmm_obs/${prefixa}.prepbufr ./prepbufr
-$lnsf $hwrf_nmm_obs/${prefixa}.satwnd.${suffix} ./satwndbufr
-$lnsf $hwrf_nmm_obs/${prefixa}.gpsro.${suffix} ./gpsrobufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.spssmi.${suffix} ./ssmirrbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.sptrmm.${suffix} ./tmirrbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.gome.${suffix} ./gomebufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.omi.${suffix} ./omibufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.mls.${suffix} ./mlsbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.osbuv8.${suffix} ./sbuvbufr
-$lnsf $hwrf_nmm_obs/${prefixa}.goesfv.${suffix} ./gsnd1bufr
-$lnsf $hwrf_nmm_obs/${prefixa}.1bamua.${suffix} ./amsuabufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.1bamub.${suffix} ./amsubbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs2.${suffix} ./hirs2bufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs3.${suffix} ./hirs3bufr
-$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs4.${suffix} ./hirs4bufr
-$lnsf $hwrf_nmm_obs/${prefixa}.1bmhs.${suffix} ./mhsbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.1bmsu.${suffix} ./msubufr
-$lnsf $hwrf_nmm_obs/${prefixa}.airsev.${suffix} ./airsbufr
-$lnsf $hwrf_nmm_obs/${prefixa}.sevcsr.${suffix} ./seviribufr
-$lnsf $hwrf_nmm_obs/${prefixa}.mtiasi.${suffix} ./iasibufr
-$lnsf $hwrf_nmm_obs/${prefixa}.esamua.${suffix} ./amsuabufrears
-$lnsf $hwrf_nmm_obs/${prefixa}.esamub.${suffix} ./amsubbufrears
-$lnsf $hwrf_nmm_obs/${prefixa}.eshrs3.${suffix} ./hirs3bufrears
-#$lnsf $hwrf_nmm_obs/${prefixa}.ssmit.${suffix} ./ssmitbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.amsre.${suffix} ./amsrebufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.ssmis.${suffix} ./ssmisbufr
-$lnsf $hwrf_nmm_obs/${prefixa}.atms.${suffix} ./atmsbufr
-$lnsf $hwrf_nmm_obs/${prefixa}.cris.${suffix} ./crisbufr
-$lnsf $hwrf_nmm_obs/${prefixa}.crisf4.${suffix} ./crisfsbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.syndata.tcvitals.tm00 ./tcvitl
-$lnsf $hwrf_nmm_obs/${prefixo}.tldplr.${suffix} ./tldplrbufr
-
-
-# Copy bias correction, atmospheric and surface files
-$lnsf $hwrf_nmm_obs/gdas1.t${hhg}z.abias ./satbias_in
-$lnsf $hwrf_nmm_obs/gdas1.t${hhg}z.abias_pc ./satbias_pc
-
-$ncp $hwrf_nmm_ges/wrfghost_d02_03 ./wrf_inou3
-$ncp $hwrf_nmm_ges/wrfghost_d02_06 ./wrf_inout
-$ncp $hwrf_nmm_ges/wrfghost_d02_09 ./wrf_inou9
-
-$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf03 ./gfs_sigf03
-$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf06 ./gfs_sigf06
-$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf09 ./gfs_sigf09
-
-# Copy ensemble forecast files for hybrid analysis
-export ENSEMBLE_SIZE_REGIONAL=10
->filelist06
-n=1
-while [[ $n -le ${ENSEMBLE_SIZE_REGIONAL} ]]; do
- $lnsf $hwrf_nmm_ges/$( printf sfg_${gdate}_fhr06s_mem%03d $n ) \
- ./$( printf sfg_${gdate}_fhr06s_mem%03d $n )
- ls ./$( printf sfg_${gdate}_fhr06s_mem%03d $n ) >> filelist06
- n=$((n + 1))
-done
-
-# Run GSI
-cd $tmpdir
-echo "run gsi now"
-eval "$APRUN $tmpdir/gsi.x > stdout 2>&1"
-rc=$?
-exit $rc
-
-
-
-
-# Loop over first and last outer loops to generate innovation
-# diagnostic files for indicated observation types (groups)
-#
-# NOTE: Since we set miter=2 in GSI namelist SETUP, outer
-# loop 03 will contain innovations with respect to
-# the analysis. Creation of o-a innovation files
-# is triggered by write_diag(3)=.true. The setting
-# write_diag(1)=.true. turns on creation of o-g
-# innovation files.
-#
-
-
-echo "Time before diagnostic loop is `date` "
-cd $tmpdir
-loops="01 03"
-for loop in $loops; do
-
-case $loop in
- 01) string=ges;;
- 03) string=anl;;
- *) string=$loop;;
-esac
-
-# Collect diagnostic files for obs types (groups) below
- listall="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 pcp_ssmi_dmsp pcp_tmi_trmm conv sbuv2_n16 sbuv2_n17 sbuv2_n18 gome_metop-a omi_aura ssmi_f13 ssmi_f15 hirs4_n18 hirs4_metop-a amsua_n18 amsua_metop-a mhs_n18 mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_las_f16 ssmis_uas_f16 ssmis_img_f16 ssmis_env_f16 iasi_metop-a"
- for type in $listall; do
- count=`ls dir.*/${type}_${loop}* | wc -l`
- if [[ $count -gt 0 ]]; then
- cat dir.*/${type}_${loop}* > diag_${type}_${string}.${hwrf_nmm_adate}
- compress diag_${type}_${string}.${hwrf_nmm_adate}
- $ncp diag_${type}_${string}.${hwrf_nmm_adate}.Z $savdir/
- fi
- done
-done
-echo "Time after diagnostic loop is `date` "
-
-
-
-# If requested, clean up $tmpdir
-if [[ "$CLEAN" = "YES" ]];then
- if [[ $rc -eq 0 ]];then
- rm -rf $tmpdir
- cd $tmpdir
- cd ../
- rmdir $tmpdir
- fi
-fi
-
-
-# End of script
-exit
diff --git a/regression/hwrf_nmm_d3.sh b/regression/hwrf_nmm_d3.sh
deleted file mode 100755
index 7b6746b741..0000000000
--- a/regression/hwrf_nmm_d3.sh
+++ /dev/null
@@ -1,337 +0,0 @@
-
-set -x
-
-# Set analysis date
-adate=$hwrf_nmm_adate
-
-io_format=netcdf
-
-if [[ "$io_format" = "binary" ]]; then
- NETCDF=.false.
- FORMAT=binary
-elif [[ "$io_format" = "netcdf" ]]; then
- NETCDF=.true.
- FORMAT=netcdf
-else
- echo "***ERRROR*** INVALID io_format = $io_format"
- exit
-fi
-
-# Set experiment name and analysis date
-
-exp=$jobname
-
-# Set path/file for gsi executable
-#gsiexec=$gsiexec
-
-# Set the JCAP resolution which you want.
-# All resolutions use LEVS=64
-#export JCAP=62
-export LEVS=60
-export JCAP_B=$JCAP
-export DELTIM=1200
-
-# Set runtime and save directories
-tmpdir=$tmpdir/tmpreg_hwrf_nmm_d3/${exp}
-savdir=$savdir/outreg_hwrf_nmm_d3/${exp}
-
-# Specify GSI fixed field and data directories.
-fixcrtm=${fixcrtm:-$CRTM_FIX}
-
-#datobs=$datobs
-
-# Set variables used in script
-# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone)
-# ncp is cp replacement, currently keep as /bin/cp
-
-CLEAN=NO
-ncp=/bin/cp
-lnsf='ln -sf'
-
-NX3=250
-NY3=500
-export NLAT=$(( NY3 - 1 ))
-export NLON=$(( NX3 - 1 ))
-
-# Given the analysis date, compute the date from which the
-# first guess comes. Extract cycle and set prefix and suffix
-# for guess and observation data files
-gdate=`date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2} - 6 hours"`
-hha=`echo $adate | cut -c9-10`
-hhg=`echo $gdate | cut -c9-10`
-prefixa=gfs.t${hha}z
-prefixo=gdas1.t${hha}z
-suffix=tm00.bufr_d
-
-
-# Set up $tmpdir
-rm -rf $tmpdir
-mkdir -p $tmpdir
-cd $tmpdir
-rm -rf core*
-
-# Make gsi namelist
-
-. $scripts/regression_nl_update.sh
-
-GRIDOPTS="$GRIDOPTS_update"
-BKGVERR="$BKGVERR_update"
-ANBKGERR="$ANBKERR_update"
-JCOPTS="$JCOPTS_update"
-STRONGOPTS="$STRONGOPTS_update"
-OBSQC="$OBSQC_update"
-OBSINPUT="$OBSINPUT_update"
-SUPERRAD="$SUPERRAD_update"
-SINGLEOB="$SINGLEOB_update"
-
-# parameters for radiance data assimilation
-export SETUP="newpc4pred=.true., adp_anglebc=.true., angord=4, \
- passive_bc=.false., use_edges=.false., emiss_bc=.true., \
- diag_precon=.true., step_start=1.e-3, upd_pred(1)=0, \
- upd_pred(2)=0,upd_pred(3)=0,upd_pred(4)=0, \
- upd_pred(5)=0,upd_pred(6)=0,upd_pred(7)=0, \
- upd_pred(8)=0,upd_pred(9)=0,upd_pred(10)=0, \
- upd_pred(11)=0,upd_pred(12)=0,"
-
-export USE_GFS_STRATOSPHERE=".false."
-export USE_GFS_OZONE=".false."
-export REGIONAL_OZONE=".false."
-
-if [ "$debug" = ".false." ]; then
- . $scripts/regression_namelists.sh hwrf_nmm_d3
-else
- . $scripts/regression_namelists_db.sh hwrf_nmm_d3
-fi
-
-cat << EOF > gsiparm.anl
-
-$gsi_namelist
-
-EOF
-
-# Set fixed files
-# berror = forecast model background error statistics
-# specoef = CRTM spectral coefficients
-# trncoef = CRTM transmittance coefficients
-# emiscoef = CRTM coefficients for IR sea surface emissivity model
-# aerocoef = CRTM coefficients for aerosol effects
-# cldcoef = CRTM coefficients for cloud effects
-# satinfo = text file with information about assimilation of brightness temperatures
-# cloudyinfo = text file with information about assimilation of cloudy radiance
-# pcpinfo = text file with information about assimilation of prepcipitation rates
-# ozinfo = text file with information about assimilation of ozone data
-# errtable = text file with obs error for conventional data (optional)
-# convinfo = text file with information about assimilation of conventional data
-# bufrtable= text file ONLY needed for single obs test (oneobstest=.true.)
-# bftab_sst= bufr table for sst ONLY needed for sst retrieval (retrieval=.true.)
-
-anavinfo=$fixgsi/anavinfo_hwrf_L60_nooz
-berror=$fixgsi/$endianness/nam_glb_berror.f77.gcv
-emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin
-emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin
-emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin
-emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin
-emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin
-emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin
-emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin
-emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin
-emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin
-aercoef=$fixcrtm/AerosolCoeff.bin
-cldcoef=$fixcrtm/CloudCoeff.bin
-satinfo=$fixgsi/hwrf_satinfo.txt
-cloudyinfo=$fixgsi/cloudy_radiance_info.txt
-atmsbeaminfo=$fixgsi/atms_beamwidth.txt
-scaninfo=$fixgsi/global_scaninfo.txt
-pcpinfo=$fixgsi/nam_global_pcpinfo.txt
-ozinfo=$fixgsi/global_ozinfo.txt
-errtable=$fixgsi/hwrf_nam_errtable.r3dv
-convinfo=$fixgsi/hwrf_convinfo.txt
-### add 9 tables
-errtable_pw=$fixgsi/prepobs_errtable_pw.global
-errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf
-errtable_t=$fixgsi/prepobs_errtable_t.global_nqcf
-errtable_q=$fixgsi/prepobs_errtable_q.global_nqcf
-errtable_uv=$fixgsi/prepobs_errtable_uv.global_nqcf
-btable_ps=$fixgsi/nqc_b_ps.global_nqcf
-btable_t=$fixgsi/nqc_b_t.global_nqcf
-btable_q=$fixgsi/nqc_b_q.global_nqcf
-btable_uv=$fixgsi/nqc_b_uv.global_nqcf
-
-# add vertical profile of localization and beta_s,beta_e weights for hybrid ensemble runs
-hybens_info=$fixgsi/hwrf_hybens_d3_info
-
-
-# Only need this file for single obs test
-bufrtable=$fixgsi/prepobs_prep.bufrtable
-
-# Only need this file for sst retrieval
-bftab_sst=$fixgsi/bufrtab.012
-
-# Copy executable and fixed files to $tmpdir
-if [[ $exp == *"updat"* ]]; then
- $ncp $gsiexec_updat ./gsi.x
-elif [[ $exp == *"contrl"* ]]; then
- $ncp $gsiexec_contrl ./gsi.x
-fi
-
-$ncp $anavinfo ./anavinfo
-$ncp $berror ./berror_stats
-$ncp $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin
-$ncp $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin
-$ncp $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin
-$ncp $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin
-$ncp $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin
-$ncp $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin
-$ncp $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin
-$ncp $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin
-$ncp $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin
-$ncp $aercoef ./AerosolCoeff.bin
-$ncp $cldcoef ./CloudCoeff.bin
-$ncp $satinfo ./satinfo
-$ncp $cloudyinfo ./cloudy_radiance_info.txt
-$ncp $scaninfo ./scaninfo
-$ncp $pcpinfo ./pcpinfo
-$ncp $ozinfo ./ozinfo
-$ncp $convinfo ./convinfo
-$ncp $errtable ./errtable
-$ncp $atmsbeaminfo ./atms_beamwidth.txt
-#add 9 tables for new varqc
-$ncp $errtable_pw ./errtable_pw
-$ncp $errtable_ps ./errtable_ps
-$ncp $errtable_t ./errtable_t
-$ncp $errtable_q ./errtable_q
-$ncp $errtable_uv ./errtable_uv
-$ncp $btable_ps ./btable_ps
-$ncp $btable_t ./btable_t
-$ncp $btable_q ./btable_q
-$ncp $btable_uv ./btable_uv
-
-$ncp $hybens_info ./hybens_info
-
-$ncp $bufrtable ./prepobs_prep.bufrtable
-$ncp $bftab_sst ./bftab_sstphr
-
-# Copy CRTM coefficient files based on entries in satinfo file
-for file in `awk '{if($1!~"!"){print $1}}' ./satinfo | sort | uniq` ;do
- $ncp $fixcrtm/${file}.SpcCoeff.bin ./
- $ncp $fixcrtm/${file}.TauCoeff.bin ./
-done
-
-
-# Copy observational data to $tmpdir
-$lnsf $hwrf_nmm_obs/${prefixa}.prepbufr ./prepbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.satwnd.${suffix} ./satwndbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.gpsro.${suffix} ./gpsrobufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.spssmi.${suffix} ./ssmirrbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.sptrmm.${suffix} ./tmirrbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.gome.${suffix} ./gomebufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.omi.${suffix} ./omibufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.mls.${suffix} ./mlsbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.osbuv8.${suffix} ./sbuvbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.goesfv.${suffix} ./gsnd1bufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.1bamua.${suffix} ./amsuabufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.1bamub.${suffix} ./amsubbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs2.${suffix} ./hirs2bufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs3.${suffix} ./hirs3bufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.1bhrs4.${suffix} ./hirs4bufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.1bmhs.${suffix} ./mhsbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.1bmsu.${suffix} ./msubufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.airsev.${suffix} ./airsbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.sevcsr.${suffix} ./seviribufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.mtiasi.${suffix} ./iasibufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.esamua.${suffix} ./amsuabufrears
-#$lnsf $hwrf_nmm_obs/${prefixa}.esamub.${suffix} ./amsubbufrears
-#$lnsf $hwrf_nmm_obs/${prefixa}.eshrs3.${suffix} ./hirs3bufrears
-#$lnsf $hwrf_nmm_obs/${prefixa}.ssmit.${suffix} ./ssmitbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.amsre.${suffix} ./amsrebufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.ssmis.${suffix} ./ssmisbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.atms.${suffix} ./atmsbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.cris.${suffix} ./crisbufr
-#$lnsf $hwrf_nmm_obs/${prefixa}.syndata.tcvitals.tm00 ./tcvitl
-$lnsf $hwrf_nmm_obs/${prefixo}.tldplr.${suffix} ./tldplrbufr
-
-
-# Copy bias correction, atmospheric and surface files
-$lnsf $hwrf_nmm_obs/gdas1.t${hhg}z.abias ./satbias_in
-$lnsf $hwrf_nmm_obs/gdas1.t${hhg}z.abias_pc ./satbias_pc
-
-$ncp $hwrf_nmm_ges/wrfghost_d03_03 ./wrf_inou3
-$ncp $hwrf_nmm_ges/wrfghost_d03_06 ./wrf_inout
-$ncp $hwrf_nmm_ges/wrfghost_d03_09 ./wrf_inou9
-
-$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf03 ./gfs_sigf03
-$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf06 ./gfs_sigf06
-$ncp $hwrf_nmm_ges/gdas1.t${hhg}z.sf09 ./gfs_sigf09
-
-# Copy ensemble forecast files for hybrid analysis
-export ENSEMBLE_SIZE_REGIONAL=10
->filelist06
-n=1
-while [[ $n -le ${ENSEMBLE_SIZE_REGIONAL} ]]; do
- $lnsf $hwrf_nmm_ges/$( printf sfg_${gdate}_fhr06s_mem%03d $n ) \
- ./$( printf sfg_${gdate}_fhr06s_mem%03d $n )
- ls ./$( printf sfg_${gdate}_fhr06s_mem%03d $n ) >> filelist06
- n=$((n + 1))
-done
-
-# Run GSI
-cd $tmpdir
-echo "run gsi now"
-eval "$APRUN $tmpdir/gsi.x > stdout 2>&1"
-rc=$?
-exit $rc
-
-
-
-
-# Loop over first and last outer loops to generate innovation
-# diagnostic files for indicated observation types (groups)
-#
-# NOTE: Since we set miter=2 in GSI namelist SETUP, outer
-# loop 03 will contain innovations with respect to
-# the analysis. Creation of o-a innovation files
-# is triggered by write_diag(3)=.true. The setting
-# write_diag(1)=.true. turns on creation of o-g
-# innovation files.
-#
-
-
-echo "Time before diagnostic loop is `date` "
-cd $tmpdir
-loops="01 03"
-for loop in $loops; do
-
-case $loop in
- 01) string=ges;;
- 03) string=anl;;
- *) string=$loop;;
-esac
-
-# Collect diagnostic files for obs types (groups) below
- listall="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 pcp_ssmi_dmsp pcp_tmi_trmm conv sbuv2_n16 sbuv2_n17 sbuv2_n18 gome_metop-a omi_aura ssmi_f13 ssmi_f15 hirs4_n18 hirs4_metop-a amsua_n18 amsua_metop-a mhs_n18 mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_las_f16 ssmis_uas_f16 ssmis_img_f16 ssmis_env_f16 iasi_metop-a"
- for type in $listall; do
- count=`ls dir.*/${type}_${loop}* | wc -l`
- if [[ $count -gt 0 ]]; then
- cat dir.*/${type}_${loop}* > diag_${type}_${string}.${hwrf_nmm_adate}
- compress diag_${type}_${string}.${hwrf_nmm_adate}
- $ncp diag_${type}_${string}.${hwrf_nmm_adate}.Z $savdir/
- fi
- done
-done
-echo "Time after diagnostic loop is `date` "
-
-
-
-# If requested, clean up $tmpdir
-if [[ "$CLEAN" = "YES" ]];then
- if [[ $rc -eq 0 ]];then
- rm -rf $tmpdir
- cd $tmpdir
- cd ../
- rmdir $tmpdir
- fi
-fi
-
-
-# End of script
-exit
diff --git a/regression/multi_regression.sh b/regression/multi_regression.sh
index b850863d69..d01492aa44 100755
--- a/regression/multi_regression.sh
+++ b/regression/multi_regression.sh
@@ -1,22 +1,18 @@
#!/bin/sh --login
-regtests_all="global_3dvar
- global_4dvar
- global_4denvar
- netcdf_fv3_regional
- rrfs_3denvar_glbens
- hwrf_nmm_d2
- hwrf_nmm_d3
+regtests_all="global_4denvar
+ rrfs_3denvar_rdasens
+ hafs_4denvar_glbens
+ hafs_3denvar_hybens
rtma
global_enkf"
-regtests_debug="global_3dvar
- global_4dvar
- global_4denvar
- netcdf_fv3_regional
- rrfs_3denvar_glbens
- hwrf_nmm_d2
- hwrf_nmm_d3
+# rrfs_enkf_conv : comment out RRFS enkf case for now
+# need to update EnKF code
+regtests_debug="global_4denvar
+ rrfs_3denvar_rdasens
+ hafs_4denvar_glbens
+ hafs_3denvar_hybens
rtma
global_enkf"
diff --git a/regression/netcdf_fv3_regional.sh b/regression/netcdf_fv3_regional.sh
deleted file mode 100755
index db5ecb920a..0000000000
--- a/regression/netcdf_fv3_regional.sh
+++ /dev/null
@@ -1,217 +0,0 @@
-
-set -x
-
-# Set analysis date
-#adate=2015061000
-
-# Set experiment name
-exp=$jobname
-
-#TM=00
-#TM2=03
-#tmmark=tm${TM}
-
-
-# Set path/file for gsi executable
-#gsiexec=/meso/save/Wanshu.Wu/Code/trunk/trunk_40320/src/global_gsi_org
-#gsiexec=/da/save/Michael.Lueken/trunk/src/global_gsi.x
-
-# Set runtime and save directories
-tmpdir=$tmpdir/tmpreg_netcdf_fv3_regional/${exp}
-savdir=$savdir/outreg_netcdf_fv3_regional/${exp}
-
-# Set variables used in script
-# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone)
-# ncp is cp replacement, currently keep as /bin/cp
-
-UNCOMPRESS=gunzip
-CLEAN=NO
-ncp=/bin/cp
-
-
-# Set up $tmpdir
-rm -rf $tmpdir
-mkdir -p $tmpdir
-chgrp rstprod $tmpdir
-chmod 750 $tmpdir
-cd $tmpdir
-
-#FIXnam=/da/save/Michael.Lueken/trunk/fix
-fixcrtm=${fixcrtm:-$CRTM_FIX}
-
-berror=$fixgsi/nam_nmm_berror.f77.gcv
-anavinfo=$fixgsi/anavinfo_fv3
-
-
-# Make gsi namelist
-
-. $scripts/regression_nl_update.sh
-
-SETUP="$SETUP_update"
-GRIDOPTS="$GRIDOPTS_update"
-BKGVERR="$BKGVERR_update"
-ANBKGERR="$ANBKERR_update"
-JCOPTS="$JCOPTS_update"
-STRONGOPTS="$STRONGOPTS_update"
-OBSQC="$OBSQC_update"
-OBSINPUT="$OBSINPUT_update"
-SUPERRAD="$SUPERRAD_update"
-HYBRID_ENSEMBLE='ensemble_path="",'
-SINGLEOB="$SINGLEOB_update"
-
-if [ "$debug" = ".false." ]; then
- . $scripts/regression_namelists.sh netcdf_fv3_regional
-else
- . $scripts/regression_namelists_db.sh netcdf_fv3_regional
-fi
-
-# dmesh(1)=120.0,time_window_max=1.5,ext_sonde=.true.,
-
-cat << EOF > gsiparm.anl
-
-$gsi_namelist
-
-EOF
-
-emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin
-emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin
-emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin
-emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin
-emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin
-emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin
-emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin
-emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin
-emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin
-aercoef=$fixcrtm/AerosolCoeff.bin
-cldcoef=$fixcrtm/CloudCoeff.bin
-satinfo=$fixgsi/nam_regional_satinfo.txt
-cloudyinfo=$fixgsi/cloudy_radiance_info.txt
-scaninfo=$fixgsi/global_scaninfo.txt
-pcpinfo=$fixgsi/nam_global_pcpinfo.txt
-ozinfo=$fixgsi/nam_global_ozinfo.txt
-errtable=$fixgsi/nam_errtable.r3dv
-convinfo=$fixgsi/nam_regional_convinfo.txt
-mesonetuselist=$fixgsi/nam_mesonet_uselist.txt
-stnuselist=$fixgsi/nam_mesonet_stnuselist.txt
-qdaylist=$fixgsi/rtma_q_day_rejectlist
-qnightlist=$fixgsi/rtma_q_night_rejectlist
-tdaylist=$fixgsi/rtma_t_day_rejectlist
-tnightlist=$fixgsi/rtma_t_night_rejectlist
-wbinuselist=$fixgsi/rtma_wbinuselist
-locinfo=$fixgsi/nam_hybens_d01_locinfo
-### add 9 tables
-errtable_pw=$fixgsi/prepobs_errtable_pw.global
-errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf
-errtable_t=$fixgsi/prepobs_errtable_t.global_nqcf
-errtable_q=$fixgsi/prepobs_errtable_q.global_nqcf
-errtable_uv=$fixgsi/prepobs_errtable_uv.global_nqcf
-btable_ps=$fixgsi/nqc_b_ps.global_nqcf
-btable_t=$fixgsi/nqc_b_t.global_nqcf
-btable_q=$fixgsi/nqc_b_q.global_nqcf
-btable_uv=$fixgsi/nqc_b_uv.global_nqcf
-
-# add vertical profile of localization and beta_s,beta_e weights for hybrid ensemble runs
-hybens_info=$fixgsi/nam_hybens_d01_info
-
-
-# Copy executable and fixed files to $tmpdir
-if [[ $exp == *"updat"* ]]; then
- $ncp $gsiexec_updat ./gsi.x
-elif [[ $exp == *"contrl"* ]]; then
- $ncp $gsiexec_contrl ./gsi.x
-fi
-
-cp $anavinfo ./anavinfo
-cp $berror ./berror_stats
-cp $errtable ./errtable
-cp $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin
-cp $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin
-cp $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin
-cp $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin
-cp $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin
-cp $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin
-cp $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin
-cp $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin
-cp $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin
-cp $aercoef ./AerosolCoeff.bin
-cp $cldcoef ./CloudCoeff.bin
-cp $satinfo ./satinfo
-cp $cloudyinfo ./cloudy_radiance_info.txt
-cp $scaninfo ./scaninfo
-cp $pcpinfo ./pcpinfo
-cp $ozinfo ./ozinfo
-cp $convinfo ./convinfo
-cp $mesonetuselist ./mesonetuselist
-cp $stnuselist ./mesonet_stnuselist
-cp $qdaylist ./q_day_rejectlist
-cp $qnightlist ./q_night_rejectlist
-cp $tdaylist ./t_day_rejectlist
-cp $tnightlist ./t_night_rejectlist
-cp $wbinuselist ./wbinuselist
-#cp $locinfo ./hybens_info
-#add 9 tables for new varqc
-$ncp $errtable_pw ./errtable_pw
-$ncp $errtable_ps ./errtable_ps
-$ncp $errtable_t ./errtable_t
-$ncp $errtable_q ./errtable_q
-$ncp $errtable_uv ./errtable_uv
-$ncp $btable_ps ./btable_ps
-$ncp $btable_t ./btable_t
-$ncp $btable_q ./btable_q
-$ncp $btable_uv ./btable_uv
-
-$ncp $hybens_info ./hybens_info
-
-
-###### crtm coeff's #######################
-set +x
-for file in `awk '{if($1!~"!"){print $1}}' satinfo | sort | uniq` ;do
- cp $fixcrtm/${file}.SpcCoeff.bin ./
- cp $fixcrtm/${file}.TauCoeff.bin ./
-done
-set -x
-
-PDY=`echo $adate | cut -c1-8`
-CYC=`echo $adate | cut -c9-10`
-
-#datdir=/meso/noscrub/Wanshu.Wu/CASE/$adate
-
-cp $fv3_netcdf_obs/ndas.t06z.radwnd.tm06.bufr_d ./radarbufr
-cp $fv3_netcdf_obs/ndas.t06z.prepbufr.tm06 ./prepbufr
-cp $fv3_netcdf_obs/ndas.t06z.1bamua.tm06.bufr_d ./amsuabufr
-cp $fv3_netcdf_obs/ndas.t06z.1bmhs.tm06.bufr_d ./mhsbufr
-cp $fv3_netcdf_obs/ndas.t06z.1bhrs4.tm06.bufr_d ./hirs4bufr
-cp $fv3_netcdf_obs/ndas.t06z.goesfv.tm06.bufr_d ./gsnd1bufr
-cp $fv3_netcdf_obs/ndas.t06z.airsev.tm06.bufr_d ./airsbufr
-cp $fv3_netcdf_obs/ndas.t06z.satwnd.tm06.bufr_d ./satwndbufr
-
-cp $fv3_netcdf_ges/coupler.res coupler.res
-cp $fv3_netcdf_ges/fv_core.res.nest02.nc fv3_akbk
-cp $fv3_netcdf_ges/grid_spec.nest02.nc fv3_grid_spec
-#the current GSI parallel IO for fv3-lam require the netcdf 4 format for nc files containing 3d fields
-nccopy -4 $fv3_netcdf_ges/fv_core.res.nest02.tile7.nc fv3_dynvars
-nccopy -4 $fv3_netcdf_ges/fv_tracer.res.nest02.tile7.nc fv3_tracer
-cp $fv3_netcdf_ges/sfc_data.nest02.tile7.nc fv3_sfcdata
-
-
-cp $fv3_netcdf_ges/nam.t06z.satbias_pc.tm04 ./satbias_pc
-cp $fv3_netcdf_ges/nam.t06z.satbias.tm04 ./satbias_in
-cp $fv3_netcdf_ges/nam.t06z.radstat.tm04 ./radstat.gdas
-
-listdiag=`tar xvf radstat.gdas | cut -d' ' -f2 | grep _ges`
-for type in $listdiag; do
- diag_file=`echo $type | cut -d',' -f1`
- fname=`echo $diag_file | cut -d'.' -f1`
- date=`echo $diag_file | cut -d'.' -f2`
- $UNCOMPRESS $diag_file
- fnameanl=$(echo $fname|sed 's/_ges//g')
- mv $fname.$date $fnameanl
-done
-
-
-# Run GSI
-cd $tmpdir
-echo "run gsi now"
-eval "$APRUN $tmpdir/gsi.x > stdout 2>&1"
-rc=$?
-exit $rc
diff --git a/regression/regression_driver.sh b/regression/regression_driver.sh
index 621ccbf485..805a9dd1fb 100755
--- a/regression/regression_driver.sh
+++ b/regression/regression_driver.sh
@@ -35,9 +35,13 @@ for jn in `seq ${RSTART} ${REND}`; do
if [ $jn -le 2 ]; then
export scripts=${scripts_updat:-$scripts}
export fixgsi=${fixgsi_updat:-$fixgsi}
+ export modulefiles=${modulefiles_updat:-$modulefiles}
+ export ush=${ush_update:-$ush}
else
export scripts=${scripts_contrl:-$scripts}
export fixgsi=${fixgsi_contrl:-$fixgsi}
+ export modulefiles=${modulefiles_contrl:-$modulefiles}
+ export ush=${ush_cntrl:-$ush}
fi
rm -f ${job[$jn]}.out
@@ -47,7 +51,6 @@ for jn in `seq ${RSTART} ${REND}`; do
$scripts/regression_wait.sh ${job[$jn]} ${rcname} $check_resource
rc=$?
if [ $rc -ne 0 ]; then
- rm -f ${rcname}
exit 1
fi
done
@@ -56,7 +59,7 @@ if [ "$debug" == ".false." ]; then
export scripts=${scripts_updat:-$scripts}
- if [ $regtest = 'global_enkf' ]; then
+ if [ $regtest = 'global_enkf' ] || [ $regtest = 'rrfs_enkf_conv' ]; then
/bin/sh $scripts/regression_test_enkf.sh ${job[1]} ${job[2]} ${job[3]} ${job[4]} ${tmpregdir} ${result} ${scaling[1]} ${scaling[2]} ${scaling[3]}
else
/bin/sh $scripts/regression_test.sh ${job[1]} ${job[2]} ${job[3]} ${job[4]} ${tmpregdir} ${result} ${scaling[1]} ${scaling[2]} ${scaling[3]}
diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh
index 824c6f0719..a4f283f92b 100755
--- a/regression/regression_namelists.sh
+++ b/regression/regression_namelists.sh
@@ -2,14 +2,14 @@ regtest=$1
case $regtest in
- global_3dvar)
+ global_4denvar)
-# Define namelist for global run (pcgsoi minimization)
+# Define namelist for global hybrid run
export gsi_namelist="
&SETUP
- miter=2,niter(1)=5,niter(2)=10,
+ miter=2,niter(1)=5,niter(2)=5,
niter_no_qc(1)=2,niter_no_qc(2)=0,
write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
qoption=2,
@@ -26,9 +26,12 @@ export gsi_namelist="
verbose=.false.,imp_physics=11,lupp=.true.,
binary_diag=.false.,netcdf_diag=.true.,
lobsdiag_forenkf=.false.,
- nhr_anal=3,6,9,nhr_obsbin=3,
+ nhr_anal=3,6,9,nhr_obsbin=1,
+ l4densvar=.true.,ens_nstarthr=3,nhr_assimilation=6,lwrite4danl=.true.,
optconv=0.05,cao_check=.true.,ta2tb=.false.,
- tzr_qc=1,sfcnst_comb=.true., write_fv3_incr=.true.,incvars_to_zero= 'liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc',incvars_zero_strat='sphum_inc','liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc',incvars_efold=5, use_gfs_ncio=.true.,
+ tzr_qc=1,sfcnst_comb=.true.,
+ write_fv3_incr=.true.,incvars_to_zero= 'liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc',
+ incvars_zero_strat='sphum_inc','liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc',incvars_efold=5, use_gfs_ncio=.true.,
$SETUP
/
&GRIDOPTS
@@ -56,7 +59,8 @@ export gsi_namelist="
$JCOPTS
/
&STRONGOPTS
- tlnmc_option=2,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5,
+ tlnmc_option=3,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5,
+
baldiag_full=.false.,baldiag_inc=.false.,
$STRONGOPTS
/
@@ -64,7 +68,7 @@ export gsi_namelist="
dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.04,
use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.false.,nvqc=.true.,hub_norm=.true.,
aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true.,
- tcp_width=70.0,tcp_ermax=7.35,
+ tcp_width=70.0,tcp_ermax=7.35,cris_cads=.true.,iasi_cads=.true.,
$OBSQC
/
&OBS_INPUT
@@ -94,8 +98,6 @@ OBS_INPUT::
sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
- hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0
- hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1
gimgrbufr goes_img g11 imgr_g11 0.0 1 0
gimgrbufr goes_img g12 imgr_g12 0.0 1 0
airsbufr airs aqua airs_aqua 0.0 1 1
@@ -129,7 +131,6 @@ OBS_INPUT::
gomebufr gome metop-a gome_metop-a 0.0 2 0
omibufr omi aura omi_aura 0.0 2 0
sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
- hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1
amsuabufr amsua n19 amsua_n19 0.0 1 1
mhsbufr mhs n19 mhs_n19 0.0 1 1
tcvitl tcp null tcp 0.0 0 0
@@ -137,7 +138,6 @@ OBS_INPUT::
seviribufr seviri m09 seviri_m09 0.0 1 0
seviribufr seviri m10 seviri_m10 0.0 1 0
seviribufr seviri m11 seviri_m11 0.0 1 0
- hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1
amsuabufr amsua metop-b amsua_metop-b 0.0 1 1
mhsbufr mhs metop-b mhs_metop-b 0.0 1 1
iasibufr iasi metop-b iasi_metop-b 0.0 1 1
@@ -195,7 +195,13 @@ OBS_INPUT::
/
&HYBRID_ENSEMBLE
- $HYBRIDENSEMBLE
+ l_hyb_ens=.true.,n_ens=$NMEM_ENKF,beta_s0=0.125,readin_beta=.false.,
+ generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=48,nlat_ens=98,nlon_ens=192,
+ ANISO_A_EN=.false.,jcap_ens_test=48,oz_univ_static=.false.,
+ ensemble_path='./ensemble_data/',ens_fast_read=.true.,write_ens_sprd=.false.,
+ s_ens_h=1000.0,450.0,685.0,s_ens_v=-0.5,-0.5,0.0,readin_localization=.false.,
+ global_spectral_filter_sd=.false.,r_ensloccov4scl=1,nsclgrp=2,naensloc=3,
+ $HYBRID_ENSEMBLE
/
&RAPIDREFRESH_CLDSURF
dfi_radar_latent_heat_time_period=30.0,
@@ -214,797 +220,17 @@ OBS_INPUT::
/
"
;;
+ RTMA)
- global_lanczos)
-
-# Define namelist for global run (lanczos minimization)
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=50,niter(2)=50,
- niter_no_qc(1)=500,niter_no_qc(2)=500,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- gencode=82,qoption=2,
- factqmin=0.005,factqmax=0.005,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,l_foto=.false.,
- use_pbl=.false.,use_compress=.false.,nsig_ext=10,gpstop=30.,
- crtm_coeffs_path='./crtm_coeffs/',
- lsqrtb=.true.,lcongrad=.true.,ltlint=.true.,ladtest=.true.,lgrtest=.false.,
- use_gfs_nemsio=.false.,lrun_subdirs=.true.,use_gfs_ncio=.true.,
- $SETUP
- /
- &GRIDOPTS
- JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS,
- regional=.false.,nlayers(63)=3,nlayers(64)=6,
- $GRIDOPTS
- /
- &BKGERR
- vs=0.7,
- hzscl=1.7,0.8,0.5,
- hswgt=0.45,0.3,0.25,
- bw=0.0,norsp=4,
- bkgv_flowdep=.true.,bkgv_rewgtfct=1.5,
- $BKGVERR
- /
- &ANBKGERR
- anisotropic=.false.,
- $ANBKGERR
- /
- &JCOPTS
- ljcpdry=.false.,bamp_jcpdry=2.5e7,
- $JCOPTS
- /
- &STRONGOPTS
- tlnmc_option=1,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5,
- baldiag_full=.true.,baldiag_inc=.true.,
- $STRONGOPTS
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.false.,oberrflg=.false.,c_varqc=0.02,
- use_poq7=.true.,njqc=.false.,vqc=.true.,
- $OBSQC
- /
- &OBS_INPUT
- dmesh(1)=180.0,dmesh(2)=145.0,dmesh(3)=240.0,dmesh(4)=160.0,dmesh(5)=180.0,dmesh(6)=150.0,dmesh(7)=145.0,time_window_max=3.0,
- $OBSINPUT
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 1.0 0 0
- prepbufr t null t 1.0 0 0
- prepbufr q null q 1.0 0 0
- prepbufr pw null pw 1.0 0 0
- satwndbufr uv null uv 1.0 0 0
- prepbufr uv null uv 1.0 0 0
- prepbufr spd null spd 1.0 0 0
- prepbufr dw null dw 1.0 0 0
- radarbufr rw null l3rw 1.0 0 0
- l2rwbufr rw null l2rw 1.0 0 0
- prepbufr sst null sst 1.0 0 0
- gpsrobufr $gps_dtype null gps 1.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 1.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 1.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 1.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 1.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 1.0 0 0
- hirs2bufr hirs2 n14 hirs2_n14 6.0 1 1
- hirs3bufr hirs3 n16 hirs3_n16 0.0 1 1
- hirs3bufr hirs3 n17 hirs3_n17 6.0 1 1
- hirs4bufr hirs4 n18 hirs4_n18 0.0 1 1
- hirs4bufr hirs4 metop-a hirs4_metop-a 6.0 1 1
- gsndrbufr sndr g11 sndr_g11 0.0 1 0
- gsndrbufr sndr g12 sndr_g12 0.0 1 0
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs_aqua 20.0 1 1
- msubufr msu n14 msu_n14 2.0 2 1
- amsuabufr amsua n15 amsua_n15 10.0 2 1
- amsuabufr amsua n16 amsua_n16 0.0 2 1
- amsuabufr amsua n17 amsua_n17 0.0 2 1
- amsuabufr amsua n18 amsua_n18 10.0 2 1
- amsuabufr amsua metop-a amsua_metop-a 10.0 2 1
- airsbufr amsua aqua amsua_aqua 5.0 2 1
- amsubbufr amsub n15 amsub_n15 3.0 3 1
- amsubbufr amsub n16 amsub_n16 3.0 3 1
- amsubbufr amsub n17 amsub_n17 3.0 3 1
- mhsbufr mhs n18 mhs_n18 3.0 3 1
- mhsbufr mhs metop-a mhs_metop-a 3.0 3 1
- ssmitbufr ssmi f13 ssmi_f13 0.0 4 0
- ssmitbufr ssmi f15 ssmi_f15 0.0 4 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 4 1
- amsrebufr amsre_mid aqua amsre_aqua 0.0 4 1
- amsrebufr amsre_hig aqua amsre_aqua 0.0 4 1
- ssmisbufr ssmis f16 ssmis_f16 0.0 4 1
- gsnd1bufr sndrd1 g12 sndrD1_g12 1.5 5 0
- gsnd1bufr sndrd2 g12 sndrD2_g12 1.5 5 0
- gsnd1bufr sndrd3 g12 sndrD3_g12 1.5 5 0
- gsnd1bufr sndrd4 g12 sndrD4_g12 1.5 5 0
- gsnd1bufr sndrd1 g11 sndrD1_g11 1.5 5 0
- gsnd1bufr sndrd2 g11 sndrD2_g11 1.5 5 0
- gsnd1bufr sndrd3 g11 sndrD3_g11 1.5 5 0
- gsnd1bufr sndrd4 g11 sndrD4_g11 1.5 5 0
- gsnd1bufr sndrd1 g13 sndrD1_g13 1.5 5 0
- gsnd1bufr sndrd2 g13 sndrD2_g13 1.5 5 0
- gsnd1bufr sndrd3 g13 sndrD3_g13 1.5 5 0
- gsnd1bufr sndrd4 g13 sndrD4_g13 1.5 5 0
- iasibufr iasi metop-a iasi_metop-a 20.0 1 1
- gomebufr gome metop-a gome_metop-a 1.0 6 0
- omibufr omi aura omi_aura 1.0 6 0
- sbuvbufr sbuv2 n19 sbuv8_n19 1.0 0 0
- hirs4bufr hirs4 n19 hirs4_n19 6.0 1 1
- amsuabufr amsua n19 amsua_n19 10.0 2 1
- mhsbufr mhs n19 mhs_n19 3.0 3 1
- tcvitl tcp null tcp 1.0 0 0
- mlsbufr mls30 aura mls30_aura 1.0 0 0
- seviribufr seviri m08 seviri_m08 0.0 7 0
- seviribufr seviri m09 seviri_m09 0.0 7 0
- seviribufr seviri m10 seviri_m10 0.0 7 0
- seviribufr seviri m11 seviri_m11 0.0 7 0
- oscatbufr uv null uv 1.0 0 0
- ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0
- ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0
- abibufr abi g16 abi_g16 0.0 7 0
- ahibufr ahi himawari8 ahi_himawari8 0.0 7 0
- abibufr abi g17 abi_g17 0.0 7 0
- abibufr abi g18 abi_g18 0.0 7 0
- ahibufr ahi himawari9 ahi_himawari9 0.0 7 0
- atmsbufr atms n21 atms_n21 0.0 7 1
- crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 7 0
- sstviirs viirs-m j2 viirs-m_j2 0.0 4 0
- ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0
- ompstcbufr ompstc8 n21 ompstc8_n21 0.0 6 0
- gomebufr gome metop-c gome_metop-c 0.0 6 0
-::
- &SUPEROB_RADAR
- $SUPERRAD
- /
- &LAG_DATA
- /
- &HYBRID_ENSEMBLE
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- /
- &CHEM
- /
- &SINGLEOB_TEST
- maginnov=0.1,magoberr=0.1,oneob_type='t',
- oblat=45.,oblon=180.,obpres=1000.,obdattim=${adate},
- obhourset=0.,
- $SINGLEOB
- /
- &NST
- /
-"
-
-;;
-
- global_hybrid_T126)
-
-# Define namelist for global hybrid run
+# Define namelist for RTMA runs
export gsi_namelist="
&SETUP
- miter=1,niter(1)=5,niter(2)=150,
- niter_no_qc(1)=50,niter_no_qc(2)=0,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- qoption=2,cwoption=3,
- gencode=82,factqmin=0.1,factqmax=0.1,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,l_foto=.false.,
- use_pbl=.false.,use_prepb_satwnd=.false.,
- nhr_assimilation=6,lrun_subdirs=.true.,
- $SETUP
- /
- &GRIDOPTS
- JCAP_B=$JCAP_B,JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS,
- regional=.false.,nlayers(63)=3,nlayers(64)=6,
- $GRIDOPTS
- /
- &BKGERR
- hzscl=1.7,0.8,0.5,
- hswgt=0.45,0.3,0.25,
-
- bw=0.0,norsp=4,
- bkgv_flowdep=.true.,bkgv_rewgtfct=1.5,
- bkgv_write=.false.,
- $BKGVERR
- /
- &ANBKGERR
- anisotropic=.false.,
- $ANBKGERR
- /
- &JCOPTS
- ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=2.5e7,
- $JCOPTS
- /
- &STRONGOPTS
- tlnmc_option=1,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5,
- baldiag_full=.true.,baldiag_inc=.true.,
- $STRONGOPTS
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.02,
- use_poq7=.true.,njqc=.false.,vqc=.true.,aircraft_t_bc=.true.,biaspredt=1000.0,upd_aircraft=.true.,
- $OBSQC
- /
- &OBS_INPUT
- dmesh(1)=145.0,dmesh(2)=150.0,time_window_max=3.0,
- $OBSINPUT
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 0.0 0 0
- prepbufr t null t 0.0 0 0
- prepbufr_profl t null t 0.0 0 0
- prepbufr q null q 0.0 0 0
- prepbufr_profl q null q 0.0 0 0
- prepbufr pw null pw 0.0 0 0
- prepbufr uv null uv 0.0 0 0
- prepbufr_profl uv null uv 0.0 0 0
- satwndbufr uv null uv 0.0 0 0
- prepbufr spd null spd 0.0 0 0
- prepbufr dw null dw 0.0 0 0
- radarbufr rw null l3rw 0.0 0 0
- l2rwbufr rw null l2rw 0.0 0 0
- prepbufr sst null sst 0.0 0 0
- gpsrobufr gps_bnd null gps 0.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
- hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0
- hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs_aqua 0.0 1 1
- amsuabufr amsua n15 amsua_n15 0.0 1 1
- amsuabufr amsua n18 amsua_n18 0.0 1 1
- amsuabufr amsua metop-a amsua_metop-a 0.0 1 1
- airsbufr amsua aqua amsua_aqua 0.0 1 1
- amsubbufr amsub n17 amsub_n17 0.0 1 1
- mhsbufr mhs n18 mhs_n18 0.0 1 1
- mhsbufr mhs metop-a mhs_metop-a 0.0 1 1
- ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0
- ssmisbufr ssmis_las f16 ssmis_f16 0.0 1 0
- ssmisbufr ssmis_uas f16 ssmis_f16 0.0 1 0
- ssmisbufr ssmis_img f16 ssmis_f16 0.0 1 0
- ssmisbufr ssmis_env f16 ssmis_f16 0.0 1 0
- gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0
- gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0
- gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0
- gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0
- gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0
- gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0
- gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0
- gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0
- gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0
- gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0
- gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0
- gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0
- iasibufr iasi metop-a iasi_metop-a 0.0 1 1
- gomebufr gome metop-a gome_metop-a 0.0 2 0
- omibufr omi aura omi_aura 0.0 2 0
- sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
- hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1
- amsuabufr amsua n19 amsua_n19 0.0 1 1
- mhsbufr mhs n19 mhs_n19 0.0 1 1
- tcvitl tcp null tcp 0.0 0 0
- seviribufr seviri m08 seviri_m08 0.0 1 0
- seviribufr seviri m09 seviri_m09 0.0 1 0
- seviribufr seviri m10 seviri_m10 0.0 1 0
- seviribufr seviri m11 seviri_m11 0.0 1 0
- hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0
- amsuabufr amsua metop-b amsua_metop-b 0.0 1 0
- mhsbufr mhs metop-b mhs_metop-b 0.0 1 0
- iasibufr iasi metop-b iasi_metop-b 0.0 1 0
- gomebufr gome metop-b gome_metop-b 0.0 2 0
- atmsbufr atms npp atms_npp 0.0 1 0
- atmsbufr atms n20 atms_n20 0.0 1 0
- crisbufr cris npp cris_npp 0.0 1 0
- crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0
- crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0
- gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0
- gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0
- gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0
- gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 1 0
- gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0
- gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0
- gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0
- gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0
- ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0
- ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0
- abibufr abi g16 abi_g16 0.0 1 0
- ahibufr ahi himawari8 ahi_himawari8 0.0 1 0
- abibufr abi g17 abi_g17 0.0 1 0
- abibufr abi g18 abi_g18 0.0 1 0
- ahibufr ahi himawari9 ahi_himawari9 0.0 1 0
- atmsbufr atms n21 atms_n21 0.0 1 1
- crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0
- sstviirs viirs-m j2 viirs-m_j2 0.0 4 0
- ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0
- ompstcbufr ompstc8 n21 ompstc8_n21 0.0 2 0
- gomebufr gome metop-c gome_metop-c 0.0 2 0
-::
- &SUPEROB_RADAR
- $SUPERRAD
- /
- &LAG_DATA
- $LAGDATA
- /
- &HYBRID_ENSEMBLE
- l_hyb_ens=.true.,n_ens=$ENS_NUM_ANAL,beta_s0=0.25,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.7,generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=62,
- nlat_ens=96,nlon_ens=192,ANISO_A_EN=.false.,jcap_ens_test=62,oz_univ_static=.true.,readin_localization=.true.,
- write_ens_sprd=.false.,
- $HYBRID_ENSEMBLE
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- /
- &CHEM
-
- /
- &SINGLEOB_TEST
- maginnov=0.1,magoberr=0.1,oneob_type='t',
- oblat=45.,oblon=180.,obpres=1000.,obdattim=${global_hybrid_T126_adate},
- obhourset=0.,
- $SINGLEOB
- /
- &NST
- /
-"
-;;
-
- global_4denvar )
-
-# Define namelist for global hybrid run
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=5,niter(2)=10,
- niter_no_qc(1)=2,niter_no_qc(2)=0,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- qoption=2,
- gencode=0,factqmin=0.5,factqmax=0.0002,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,l_foto=.false.,
- use_pbl=.false.,use_compress=.true.,nsig_ext=45,gpstop=50.,
- commgpstop=45.,commgpserrinf=1.0,
- use_gfs_nemsio=.false.,lrun_subdirs=.true.,
- use_readin_anl_sfcmask=.true.,
- crtm_coeffs_path='./crtm_coeffs/',
- newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true.,use_edges=.false.,
- diag_precon=.true.,step_start=1.e-3,emiss_bc=.true.,thin4d=.true.,cwoption=3,
- verbose=.false.,imp_physics=11,lupp=.true.,
- binary_diag=.false.,netcdf_diag=.true.,
- lobsdiag_forenkf=.false.,
- nhr_anal=3,6,9,nhr_obsbin=1,
- l4densvar=.true.,ens_nstarthr=3,nhr_assimilation=6,lwrite4danl=.true.,
- optconv=0.05,cao_check=.true.,ta2tb=.false.,
- tzr_qc=1,sfcnst_comb=.true.,
- write_fv3_incr=.true.,incvars_to_zero= 'liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc',
- incvars_zero_strat='sphum_inc','liq_wat_inc','icmr_inc','rwmr_inc','snmr_inc','grle_inc',incvars_efold=5, use_gfs_ncio=.true.,
- $SETUP
- /
- &GRIDOPTS
- JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS,
- regional=.false.,
- $GRIDOPTS
- /
- &BKGERR
- vs=0.7,
- hzscl=1.7,0.8,0.5,
- hswgt=0.45,0.3,0.25,
- bw=0.0,norsp=4,
- bkgv_flowdep=.true.,bkgv_rewgtfct=1.5,
- bkgv_write=.false.,
- cwcoveqqcov=.false.,
- $BKGVERR
- /
- &ANBKGERR
- anisotropic=.false.,
- $ANBKGERR
- /
- &JCOPTS
- ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=5.0e7,
- ljc4tlevs=.true.,
- $JCOPTS
- /
- &STRONGOPTS
- tlnmc_option=3,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5,
-
- baldiag_full=.false.,baldiag_inc=.false.,
- $STRONGOPTS
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.04,
- use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.false.,nvqc=.true.,hub_norm=.true.,
- aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true.,
- tcp_width=70.0,tcp_ermax=7.35,
- $OBSQC
- /
- &OBS_INPUT
- dmesh(1)=1450.0,dmesh(2)=1500.0,dmesh(3)=1000.0,dmesh(4)=500.0,time_window_max=3.0,
- $OBSINPUT
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 0.0 0 0
- prepbufr t null t 0.0 0 0
- prepbufr_profl t null t 0.0 0 0
- hdobbufr t null t 0.0 0 0
- prepbufr q null q 0.0 0 0
- prepbufr_profl q null q 0.0 0 0
- hdobbufr q null q 0.0 0 0
- prepbufr pw null pw 0.0 0 0
- prepbufr uv null uv 0.0 0 0
- prepbufr_profl uv null uv 0.0 0 0
- satwndbufr uv null uv 0.0 0 0
- hdobbufr uv null uv 0.0 0 0
- prepbufr spd null spd 0.0 0 0
- hdobbufr spd null spd 0.0 0 0
- prepbufr dw null dw 0.0 0 0
- radarbufr rw null rw 0.0 0 0
- nsstbufr sst nsst sst 0.0 0 0
- gpsrobufr gps_bnd null gps 0.0 0 0
- sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
- hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0
- hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs_aqua 0.0 1 1
- amsuabufr amsua n15 amsua_n15 0.0 1 1
- amsuabufr amsua n18 amsua_n18 0.0 1 1
- amsuabufr amsua metop-a amsua_metop-a 0.0 1 1
- airsbufr amsua aqua amsua_aqua 0.0 1 1
- amsubbufr amsub n17 amsub_n17 0.0 1 1
- mhsbufr mhs n18 mhs_n18 0.0 1 1
- mhsbufr mhs metop-a mhs_metop-a 0.0 1 1
- ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0
- ssmisbufr ssmis f16 ssmis_f16 0.0 1 0
- ssmisbufr ssmis f17 ssmis_f17 0.0 1 0
- ssmisbufr ssmis f18 ssmis_f18 0.0 1 0
- gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0
- gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0
- gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0
- gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0
- gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0
- gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0
- gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0
- gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0
- gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0
- gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0
- gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0
- gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0
- iasibufr iasi metop-a iasi_metop-a 0.0 1 1
- gomebufr gome metop-a gome_metop-a 0.0 2 0
- omibufr omi aura omi_aura 0.0 2 0
- sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
- hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1
- amsuabufr amsua n19 amsua_n19 0.0 1 1
- mhsbufr mhs n19 mhs_n19 0.0 1 1
- tcvitl tcp null tcp 0.0 0 0
- seviribufr seviri m08 seviri_m08 0.0 1 0
- seviribufr seviri m09 seviri_m09 0.0 1 0
- seviribufr seviri m10 seviri_m10 0.0 1 0
- seviribufr seviri m11 seviri_m11 0.0 1 0
- hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1
- amsuabufr amsua metop-b amsua_metop-b 0.0 1 1
- mhsbufr mhs metop-b mhs_metop-b 0.0 1 1
- iasibufr iasi metop-b iasi_metop-b 0.0 1 1
- gomebufr gome metop-b gome_metop-b 0.0 2 0
- atmsbufr atms npp atms_npp 0.0 1 1
- atmsbufr atms n20 atms_n20 0.0 1 1
- crisbufr cris npp cris_npp 0.0 1 0
- crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0
- crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0
- gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0
- gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0
- gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0
- gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 1 0
- gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0
- gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0
- gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0
- gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0
- oscatbufr uv null uv 0.0 0 0
- mlsbufr mls30 aura mls30_aura 0.0 0 0
- avhambufr avhrr metop-a avhrr3_metop-a 0.0 4 0
- avhpmbufr avhrr n18 avhrr3_n18 0.0 4 0
- avhambufr avhrr metop-b avhrr3_metop-b 0.0 4 0
- avhambufr avhrr metop-c avhrr3_metop-c 0.0 4 0
- avhpmbufr avhrr n19 avhrr3_n19 0.0 4 0
- amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0
- gmibufr gmi gpm gmi_gpm 0.0 1 0
- saphirbufr saphir meghat saphir_meghat 0.0 3 0
- ahibufr ahi himawari8 ahi_himawari8 0.0 1 0
- abibufr abi g16 abi_g16 0.0 1 0
- abibufr abi g17 abi_g17 0.0 1 0
- rapidscatbufr uv null uv 0.0 0 0
- ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0
- ompslpbufr ompslp npp ompslp_npp 0.0 0 0
- ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0
- ompsnpbufr ompsnp n20 ompsnp_n20 0.0 0 0
- ompstcbufr ompstc8 n20 ompstc8_n20 0.0 2 0
- amsuabufr amsua metop-c amsua_metop-c 0.0 1 1
- mhsbufr mhs metop-c mhs_metop-c 0.0 1 1
- iasibufr iasi metop-c iasi_metop-c 0.0 1 1
- sstviirs viirs-m npp viirs-m_npp 0.0 4 0
- sstviirs viirs-m j1 viirs-m_j1 0.0 4 0
- abibufr abi g18 abi_g18 0.0 1 0
- ahibufr ahi himawari9 ahi_himawari9 0.0 1 0
- atmsbufr atms n21 atms_n21 0.0 1 1
- crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0
- sstviirs viirs-m j2 viirs-m_j2 0.0 4 0
- ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0
- ompstcbufr ompstc8 n21 ompstc8_n21 0.0 2 0
- gomebufr gome metop-c gome_metop-c 0.0 2 0
-::
- &SUPEROB_RADAR
- $SUPERRAD
- /
- &LAG_DATA
-
- /
- &HYBRID_ENSEMBLE
- l_hyb_ens=.true.,n_ens=$NMEM_ENKF,beta_s0=0.125,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.8,
- generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=48,nlat_ens=98,nlon_ens=192,
- ANISO_A_EN=.false.,jcap_ens_test=48,oz_univ_static=.false.,readin_localization=.true.,
- ensemble_path='./ensemble_data/',ens_fast_read=.true.,write_ens_sprd=.false.,
- $HYBRID_ENSEMBLE
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
-
- /
- &CHEM
-
- /
- &NST
- nst_gsi=3,nstinfo=4,zsea1=0,zsea2=0,fac_dtl=1,fac_tsl=1,
- /
- &SINGLEOB_TEST
- maginnov=0.1,magoberr=0.1,oneob_type='t',
- oblat=5.,oblon=180.,obpres=850.,obdattim=2022110900,
- obhourset=0.,
- /
-"
-;;
-
- global_fv3_4denvar_C192 )
-
-# Define namelist for global hybrid run
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=5,niter(2)=5,
- niter_no_qc(1)=2,niter_no_qc(2)=0,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- qoption=2,
- gencode=82,factqmin=0.5,factqmax=0.0002,deltim=400
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,l_foto=.false.,
- use_pbl=.false.,use_compress=.true.,nsig_ext=56,gpstop=55.,
- use_gfs_nemsio=.false.,lrun_subdirs=.true.,use_readin_anl_sfcmask=.true.,
- crtm_coeffs_path='./crtm_coeffs/',
- newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true.,use_edges=.false.,
- diag_precon=.true.,step_start=1.e-3,emiss_bc=.true.,thin4d=.true.,cwoption=3,
- verbose=.false.,imp_physics=11,lupp=.true.,
- binary_diag=.false.,netcdf_diag=.true.,
- lobsdiag_forenkf=.false.,
- nhr_anal=3,6,9,
- l4densvar=.true.,ens_nstarthr=3,nhr_obsbin=1,nhr_assimilation=6,lwrite4danl=.true.,
- tzr_qc=1,sfcnst_comb=.true.,
- write_fv3_incr=.true.,incvars_to_zero= 'liq_wat_inc','icmr_inc',incvars_zero_strat='sphum_inc','liq_wat_inc','icmr_inc',
- incvars_efold=5,
- use_gfs_ncio=.true.,
- $SETUP
- /
- &GRIDOPTS
- JCAP_B=$JCAP_B,JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS,
- regional=.false.,
- $GRIDOPTS
- /
- &BKGERR
- vs=0.7,
- hzscl=1.7,0.8,0.5,
- hswgt=0.45,0.3,0.25,
- bw=0.0,norsp=4,
- bkgv_flowdep=.true.,bkgv_rewgtfct=1.5,
- bkgv_write=.false.,
- cwcoveqqcov=.false.,
- $BKGVERR
- /
- &ANBKGERR
- anisotropic=.false.,
- $ANBKGERR
- /
- &JCOPTS
- ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=5.0e7,
- ljc4tlevs=.true.,
- $JCOPTS
- /
- &STRONGOPTS
- tlnmc_option=3,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5,
- baldiag_full=.false.,baldiag_inc=.false.,
- $STRONGOPTS
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.04,
- use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.false.,
- aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true.
- nvqc=.true.,
- $OBSQC
- /
- &OBS_INPUT
- dmesh(1)=1450.0,dmesh(2)=1500.0,dmesh(3)=1000.0,time_window_max=3.0,
- $OBSINPUT
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 0.0 0 0
- prepbufr t null t 0.0 0 0
- prepbufr_profl t null t 0.0 0 0
- prepbufr q null q 0.0 0 0
- prepbufr_profl q null q 0.0 0 0
- prepbufr pw null pw 0.0 0 0
- prepbufr uv null uv 0.0 0 0
- prepbufr_profl uv null uv 0.0 0 0
- satwndbufr uv null uv 0.0 0 0
- prepbufr spd null spd 0.0 0 0
- prepbufr dw null dw 0.0 0 0
- radarbufr rw null rw 0.0 0 0
- nsstbufr sst nsst sst 0.0 0 0
- gpsrobufr gps_bnd null gps 0.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
- hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0
- hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs_aqua 0.0 1 1
- amsuabufr amsua n15 amsua_n15 0.0 1 1
- amsuabufr amsua n18 amsua_n18 0.0 1 1
- amsuabufr amsua metop-a amsua_metop-a 0.0 1 1
- airsbufr amsua aqua amsua_aqua 0.0 1 1
- amsubbufr amsub n17 amsub_n17 0.0 1 1
- mhsbufr mhs n18 mhs_n18 0.0 1 1
- mhsbufr mhs metop-a mhs_metop-a 0.0 1 1
- ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0
- ssmisbufr ssmis f16 ssmis_f16 0.0 1 0
- ssmisbufr ssmis f17 ssmis_f17 0.0 1 0
- ssmisbufr ssmis f18 ssmis_f18 0.0 1 0
- gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0
- gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0
- gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0
- gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0
- gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0
- gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0
- gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0
- gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0
- gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0
- gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0
- gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0
- gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0
- iasibufr iasi metop-a iasi_metop-a 0.0 1 1
- gomebufr gome metop-a gome_metop-a 0.0 2 0
- omibufr omi aura omi_aura 0.0 2 0
- sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
- hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1
- amsuabufr amsua n19 amsua_n19 0.0 1 1
- mhsbufr mhs n19 mhs_n19 0.0 1 1
- tcvitl tcp null tcp 0.0 0 0
- seviribufr seviri m08 seviri_m08 0.0 1 0
- seviribufr seviri m09 seviri_m09 0.0 1 0
- seviribufr seviri m10 seviri_m10 0.0 1 0
- seviribufr seviri m11 seviri_m11 0.0 1 0
- hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1
- amsuabufr amsua metop-b amsua_metop-b 0.0 1 1
- mhsbufr mhs metop-b mhs_metop-b 0.0 1 1
- iasibufr iasi metop-b iasi_metop-b 0.0 1 1
- gomebufr gome metop-b gome_metop-b 0.0 2 0
- atmsbufr atms npp atms_npp 0.0 1 1
- atmsbufr atms n20 atms_n20 0.0 1 1
- crisbufr cris npp cris_npp 0.0 1 0
- crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0
- crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0
- gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0
- gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0
- gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0
- gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 1 0
- gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0
- gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0
- gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0
- gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0
- oscatbufr uv null uv 0.0 0 0
- mlsbufr mls30 aura mls30_aura 0.0 0 0
- avhambufr avhrr metop-a avhrr3_metop-a 0.0 1 0
- avhpmbufr avhrr n18 avhrr3_n18 0.0 1 0
- avhambufr avhrr metop-b avhrr3_metop-b 0.0 1 0
- avhpmbufr avhrr n19 avhrr3_n19 0.0 1 0
- amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0
- gmibufr gmi gpm gmi_gpm 0.0 3 0
- saphirbufr saphir meghat saphir_meghat 0.0 3 0
- ahibufr ahi himawari8 ahi_himawari8 0.0 1 0
- abibufr abi g16 abi_g16 0.0 1 0
- abibufr abi g17 abi_g17 0.0 1 0
- rapidscatbufr uv null uv 0.0 0 0
- ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0
- ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0
- amsuabufr amsua metop-c amsua_metop-c 0.0 1 1
- mhsbufr mhs metop-c mhs_metop-c 0.0 1 1
- iasibufr iasi metop-c iasi_metop-c 0.0 1 1
- ompslpbufr ompslp npp ompslp_npp 0.0 1 1
- abibufr abi g18 abi_g18 0.0 1 0
- ahibufr ahi himawari9 ahi_himawari9 0.0 1 0
- atmsbufr atms n21 atms_n21 0.0 1 1
- crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0
- sstviirs viirs-m j2 viirs-m_j2 0.0 4 0
- ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0
- ompstcbufr ompstc8 n21 ompstc8_n21 0.0 2 0
- gomebufr gome metop-c gome_metop-c 0.0 2 0
-::
- &SUPEROB_RADAR
- $SUPERRAD
- /
- &LAG_DATA
- $LAGDATA
- /
- &HYBRID_ENSEMBLE
- l_hyb_ens=.true.,n_ens=20,beta_s0=0.125,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.8,generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=190,
- nlat_ens=194,nlon_ens=384,aniso_a_en=.false.,jcap_ens_test=62,oz_univ_static=.false.,readin_localization=.true.,ensemble_path='./ensemble_data/',
- ens_fast_read=.true.,write_ens_sprd=.false.,
- $HYBRID_ENSEMBLE
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- /
- &CHEM
-
- /
- &SINGLEOB_TEST
- maginnov=0.1,magoberr=0.1,oneob_type='t',
- oblat=45.,oblon=180.,obpres=1000.,obdattim=${global_4denvar_T670_adate},
- obhourset=0.,
- $SINGLEOB
- /
- &NST
- nst_gsi=3,nstinfo=4,fac_dtl=1,fac_tsl=1,zsea1=0,zsea2=0,
- $NST
- /
-"
-;;
-
- RTMA)
-
-# Define namelist for RTMA runs
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=10,niter(2)=10,
- write_diag(1)=.true.,write_diag(2)=.true.,write_diag(3)=.true.,
- gencode=78,qoption=1,tsensible=.true.
- factqmin=1.0,factqmax=1.0,factv=0.0,factcldch=0.0,factw10m=1.0,deltim=$DELTIM,
+ miter=2,niter(1)=5,niter(2)=5,
+ write_diag(1)=.true.,write_diag(2)=.true.,write_diag(3)=.true.,
+ gencode=78,qoption=1,tsensible=.true.
+ factqmin=1.0,factqmax=1.0,factv=0.0,factcldch=0.0,factw10m=1.0,deltim=$DELTIM,
iguess=-1,
oneobtest=.false.,retrieval=.false.,
diag_rad=.false.,diag_pcp=.false.,diag_ozone=.false.,diag_aero=.false.,
@@ -1016,394 +242,100 @@ export gsi_namelist="
/
&GRIDOPTS
JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS,
- wrf_nmm_regional=.false.,wrf_mass_regional=.false.,twodvar_regional=.true.,
- diagnostic_reg=.false.,
- filled_grid=.false.,half_grid=.true.,netcdf=.false.,
- /
- &BKGERR
- hzscl=1.414,1.000,0.707,
- vs=0.5,bw=0.0,
- /
- &ANBKGERR
- anisotropic=.true.,an_vs=0.5,ngauss=1,
- an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200.,
- ifilt_ord=2,npass=3,normal=-200,grid_ratio=1.,nord_f2a=4,
- rtma_subdomain_option=.true.,triad4=.true.,nsmooth=0,nsmooth_shapiro=0,lreadnorm=.true.,
- /
- &JCOPTS
- /
- &STRONGOPTS
- nstrong=1,nvmodes_keep=20,period_max=3.,
- baldiag_full=.true.,baldiag_inc=.true.,
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',hilbert_curve=.true.,
- buddycheck_t=.false.,buddydiag_save=.false.,oberrflg=.true.,njqc=.true.,vqc=.false.,
- $OBSQC
- /
- &OBS_INPUT
- dmesh(1)=60.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,time_window_max=3.0,
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 1.0 0 0
- prepbufr t null t 1.0 0 0
- prepbufr q null q 1.0 0 0
- prepbufr uv null uv 1.0 0 0
- satwndbufr uv null uv 1.0 0 0
- prepbufr spd null spd 1.0 0 0
- prepbufr wspd10m null wspd10m 1.0 0 0
- satwnd wspd10m null wspd10m 1.0 0 0
- prepbufr uwnd10m null uwnd10m 1.0 0 0
- satwnd uwnd10m null uwnd10m 1.0 0 0
- prepbufr vwnd10m null vwnd10m 1.0 0 0
- satwnd vwnd10m null vwnd10m 1.0 0 0
- prepbufr gust null gust 1.0 0 0
- prepbufr vis null vis 1.0 0 0
- prepbufr td2m null td2m 1.0 0 0
- mxtmdat mxtm null mxtm 1.0 0 0
- mitmdat mitm null mitm 1.0 0 0
- prepbufr mxtm null mxtm 1.0 0 0
- prepbufr mitm null mitm 1.0 0 0
- prepbufr pmsl null pmsl 1.0 0 0
- prepbufr howv null howv 1.0 0 0
- satmar howv null howv 1.0 0 0
- prepbufr tcamt null tcamt 1.0 0 0
- goessky tcamt null tcamt 1.0 0 0
- prepbufr cldch null cldch 1.0 0 0
-::
- &SUPEROB_RADAR
- /
- &LAG_DATA
- /
- &HYBRID_ENSEMBLE
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- l_closeobs=.true.
- /
- &CHEM
- /
- &SINGLEOB_TEST
- maginnov=0.1,magoberr=0.1,oneob_type='t',
- oblat=36.,oblon=260.,obpres=1000.,obdattim=${adate},
- obhourset=0.,
- /
- &NST
- /
-"
-;;
-
- arw_binary)
-
-# Define namelist for arw binary run
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=50,niter(2)=50,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- gencode=78,qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,
- nhr_assimilation=3,l_foto=.false.,
- use_pbl=.false.,use_compress=.false.,nsig_ext=13,gpstop=30.,
- lrun_subdirs=.true.,
- $SETUP
- /
- &GRIDOPTS
- JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS,
- wrf_nmm_regional=.false.,wrf_mass_regional=.true.,diagnostic_reg=.false.,
- filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF,
- /
- &BKGERR
- hzscl=0.373,0.746,1.50,
- vs=1.0,bw=0.,fstat=.true.,
- /
- &ANBKGERR
- anisotropic=.false.,an_vs=1.0,ngauss=1,
- an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200.,
- ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4,
- /
- &JCOPTS
- /
- &STRONGOPTS
- nstrong=0,nvmodes_keep=20,period_max=3.,
- baldiag_full=.true.,baldiag_inc=.true.,
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true.,
- /
- &OBS_INPUT
- dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5,
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 1.0 0 0
- prepbufr t null t 1.0 0 0
- prepbufr q null q 1.0 0 0
- prepbufr uv null uv 1.0 0 0
- satwndbufr uv null uv 1.0 0 0
- prepbufr spd null spd 1.0 0 0
- radarbufr rw null l3rw 1.0 0 0
- l2rwbufr rw null l2rw 1.0 0 0
- prepbufr dw null dw 1.0 0 0
- prepbufr sst null sst 1.0 0 0
- prepbufr pw null pw 1.0 0 0
- gpsrobufr $gps_dtype null gps 1.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 1.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 1.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 1.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 1.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 1.0 0 0
- omi omi aura omi_aura 1.0 6 0
- hirs2bufr hirs2 n14 hirs2_n14 6.0 1 1
- hirs3bufr hirs3 n16 hirs3_n16 0.0 1 1
- hirs3bufr hirs3 n17 hirs3_n17 6.0 1 1
- hirs4bufr hirs4 n18 hirs4_n18 0.0 1 1
- hirs4bufr hirs4 metop-a hirs4_metop-a 6.0 1 1
- gsndrbufr sndr g11 sndr_g11 0.0 1 0
- gsndrbufr sndr g12 sndr_g12 0.0 1 0
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs_aqua 20.0 1 1
- msubufr msu n14 msu_n14 2.0 2 1
- amsuabufr amsua n15 amsua_n15 10.0 2 1
- amsuabufr amsua n16 amsua_n16 0.0 2 1
- amsuabufr amsua n17 amsua_n17 0.0 2 1
- amsuabufr amsua n18 amsua_n18 10.0 2 1
- amsuabufr amsua metop-a amsua_metop-a 10.0 2 1
- airsbufr amsua aqua amsua_aqua 5.0 2 1
- amsubbufr amsub n15 amsub_n15 3.0 3 1
- amsubbufr amsub n16 amsub_n16 3.0 3 1
- amsubbufr amsub n17 amsub_n17 3.0 3 1
- mhsbufr mhs n18 mhs_n18 3.0 3 1
- mhsbufr mhs metop-a mhs_metop-a 3.0 3 1
- ssmitbufr ssmi f13 ssmi_f13 0.0 4 0
- ssmitbufr ssmi f15 ssmi_f15 0.0 4 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 4 1
- amsrebufr amsre_mid aqua amsre_aqua 0.0 4 1
- amsrebufr amsre_hig aqua amsre_aqua 0.0 4 1
- ssmisbufr ssmis f16 ssmis_f16 0.0 4 1
- gsnd1bufr sndrd1 g12 sndrD1_g12 1.5 5 0
- gsnd1bufr sndrd2 g12 sndrD2_g12 1.5 5 0
- gsnd1bufr sndrd3 g12 sndrD3_g12 1.5 5 0
- gsnd1bufr sndrd4 g12 sndrD4_g12 1.5 5 0
- gsnd1bufr sndrd1 g11 sndrD1_g11 1.5 5 0
- gsnd1bufr sndrd2 g11 sndrD2_g11 1.5 5 0
- gsnd1bufr sndrd3 g11 sndrD3_g11 1.5 5 0
- gsnd1bufr sndrd4 g11 sndrD4_g11 1.5 5 0
- gsnd1bufr sndrd1 g13 sndrD1_g13 1.5 5 0
- gsnd1bufr sndrd2 g13 sndrD2_g13 1.5 5 0
- gsnd1bufr sndrd3 g13 sndrD3_g13 1.5 5 0
- gsnd1bufr sndrd4 g13 sndrD4_g13 1.5 5 0
- iasibufr iasi metop-a iasi_metop-a 20.0 1 1
- gomebufr gome metop-a gome_metop-a 1.0 6 0
- mlsbufr mls30 aura mls30_aura 1.0 0 0
- oscatbufr uv null uv 1.0 0 0
- ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0
- ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0
-::
- &SUPEROB_RADAR
- del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000.,
- l2superob_only=.false.,
- /
- &LAG_DATA
- /
- &HYBRID_ENSEMBLE
- l_hyb_ens=${HYBENS_REGIONAL},
- n_ens=${ENSEMBLE_SIZE_REGIONAL},
- uv_hyb_ens=${HYBENS_UV_REGIONAL},
- beta_s0=${BETA_S0_REGIONAL},
- readin_beta=.false.,
- s_ens_h=${HYBENS_HOR_SCALE_REGIONAL},
- s_ens_v=${HYBENS_VER_SCALE_REGIONAL},
- generate_ens=${GENERATE_ENS_REGIONAL},
- aniso_a_en=${HYBENS_ANISO_REGIONAL},
- nlon_ens=${NLON_ENS_REGIONAL},
- nlat_ens=${NLAT_ENS_REGIONAL},
- jcap_ens=${JCAP_ENS_REGIONAL},
- jcap_ens_test=${JCAP_ENS_TEST_REGIONAL},
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- /
- &CHEM
- /
- &SINGLEOB_TEST
- maginnov=0.1,magoberr=0.1,oneob_type='t',
- oblat=45.,oblon=270.,obpres=850.,obdattim=${adate},
- obhourset=0.,
- /
- &NST
- /
-"
-;;
-
- arw_netcdf)
-
-# Define namelist for arw netcdf run
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=50,niter(2)=50,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- gencode=78,qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,
- nhr_assimilation=3,l_foto=.false.,
- use_pbl=.false.,use_compress=.false.,nsig_ext=13,gpstop=30.,
- lrun_subdirs=.true.,
- $SETUP
- /
- &GRIDOPTS
- JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS,
- wrf_nmm_regional=.false.,wrf_mass_regional=.true.,diagnostic_reg=.false.,
- filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF,
+ wrf_nmm_regional=.false.,wrf_mass_regional=.false.,twodvar_regional=.true.,
+ diagnostic_reg=.false.,
+ filled_grid=.false.,half_grid=.true.,netcdf=.false.,
/
&BKGERR
- hzscl=0.373,0.746,1.50,
- vs=1.0,bw=0.,fstat=.true.,
+ hzscl=1.414,1.000,0.707,
+ vs=0.5,bw=0.0,
/
&ANBKGERR
- anisotropic=.false.,an_vs=1.0,ngauss=1,
+ anisotropic=.true.,an_vs=0.5,ngauss=1,
an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200.,
- ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4,
+ ifilt_ord=2,npass=3,normal=-200,grid_ratio=1.,nord_f2a=4,
+ rtma_subdomain_option=.true.,triad4=.true.,nsmooth=0,nsmooth_shapiro=0,lreadnorm=.true.,
/
&JCOPTS
/
&STRONGOPTS
- nstrong=0,nvmodes_keep=20,period_max=3.,
+ nstrong=1,nvmodes_keep=20,period_max=3.,
baldiag_full=.true.,baldiag_inc=.true.,
/
&OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true.,
+ dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',hilbert_curve=.true.,
+ buddycheck_t=.false.,buddydiag_save=.false.,oberrflg=.true.,njqc=.true.,vqc=.false.,
+ $OBSQC
/
&OBS_INPUT
- dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5,
+ dmesh(1)=60.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,time_window_max=3.0,
/
OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 1.0 0 0
- prepbufr t null t 1.0 0 0
- prepbufr q null q 1.0 0 0
- prepbufr uv null uv 1.0 0 0
- satwndbufr uv null uv 1.0 0 0
- prepbufr spd null spd 1.0 0 0
- radarbufr rw null l3rw 1.0 0 0
- l2rwbufr rw null l2rw 1.0 0 0
- prepbufr dw null dw 1.0 0 0
- prepbufr sst null sst 1.0 0 0
- prepbufr pw null pw 1.0 0 0
- gpsrobufr $gps_dtype null gps 1.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 1.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 1.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 1.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 1.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 1.0 0 0
- omi omi aura omi_aura 1.0 6 0
- hirs2bufr hirs2 n14 hirs2_n14 6.0 1 1
- hirs3bufr hirs3 n16 hirs3_n16 0.0 1 1
- hirs3bufr hirs3 n17 hirs3_n17 6.0 1 1
- hirs4bufr hirs4 n18 hirs4_n18 0.0 1 1
- hirs4bufr hirs4 metop-a hirs4_metop-a 6.0 1 1
- gsndrbufr sndr g11 sndr_g11 0.0 1 0
- gsndrbufr sndr g12 sndr_g12 0.0 1 0
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs_aqua 20.0 1 1
- msubufr msu n14 msu_n14 2.0 2 1
- amsuabufr amsua n15 amsua_n15 10.0 2 1
- amsuabufr amsua n16 amsua_n16 0.0 2 1
- amsuabufr amsua n17 amsua_n17 0.0 2 1
- amsuabufr amsua n18 amsua_n18 10.0 2 1
- amsuabufr amsua metop-a amsua_metop-a 10.0 2 1
- airsbufr amsua aqua amsua_aqua 5.0 2 1
- amsubbufr amsub n15 amsub_n15 3.0 3 1
- amsubbufr amsub n16 amsub_n16 3.0 3 1
- amsubbufr amsub n17 amsub_n17 3.0 3 1
- mhsbufr mhs n18 mhs_n18 3.0 3 1
- mhsbufr mhs metop-a mhs_metop-a 3.0 3 1
- ssmitbufr ssmi f13 ssmi_f13 0.0 4 0
- ssmitbufr ssmi f15 ssmi_f15 0.0 4 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 4 1
- amsrebufr amsre_mid aqua amsre_aqua 0.0 4 1
- amsrebufr amsre_hig aqua amsre_aqua 0.0 4 1
- ssmisbufr ssmis f16 ssmis_f16 0.0 4 1
- gsnd1bufr sndrd1 g12 sndrD1_g12 1.5 5 0
- gsnd1bufr sndrd2 g12 sndrD2_g12 1.5 5 0
- gsnd1bufr sndrd3 g12 sndrD3_g12 1.5 5 0
- gsnd1bufr sndrd4 g12 sndrD4_g12 1.5 5 0
- gsnd1bufr sndrd1 g11 sndrD1_g11 1.5 5 0
- gsnd1bufr sndrd2 g11 sndrD2_g11 1.5 5 0
- gsnd1bufr sndrd3 g11 sndrD3_g11 1.5 5 0
- gsnd1bufr sndrd4 g11 sndrD4_g11 1.5 5 0
- gsnd1bufr sndrd1 g13 sndrD1_g13 1.5 5 0
- gsnd1bufr sndrd2 g13 sndrD2_g13 1.5 5 0
- gsnd1bufr sndrd3 g13 sndrD3_g13 1.5 5 0
- gsnd1bufr sndrd4 g13 sndrD4_g13 1.5 5 0
- iasibufr iasi metop-a iasi_metop-a 20.0 1 1
- gomebufr gome metop-a gome_metop-a 1.0 6 0
- mlsbufr mls30 aura mls30_aura 1.0 0 0
- oscatbufr uv null uv 1.0 0 0
- ompsnpbufr ompsnp npp ompsnp_npp 1.0 0 0
- ompstcbufr ompstc8 npp ompstc8_npp 1.0 6 0
+! dfile dtype dplat dsis dval dthin dsfcalc
+ prepbufr ps null ps 1.0 0 0
+ prepbufr t null t 1.0 0 0
+ prepbufr q null q 1.0 0 0
+ prepbufr uv null uv 1.0 0 0
+ satwndbufr uv null uv 1.0 0 0
+ prepbufr spd null spd 1.0 0 0
+ prepbufr wspd10m null wspd10m 1.0 0 0
+ satwnd wspd10m null wspd10m 1.0 0 0
+ prepbufr uwnd10m null uwnd10m 1.0 0 0
+ satwnd uwnd10m null uwnd10m 1.0 0 0
+ prepbufr vwnd10m null vwnd10m 1.0 0 0
+ satwnd vwnd10m null vwnd10m 1.0 0 0
+ prepbufr gust null gust 1.0 0 0
+ prepbufr vis null vis 1.0 0 0
+ prepbufr td2m null td2m 1.0 0 0
+ mxtmdat mxtm null mxtm 1.0 0 0
+ mitmdat mitm null mitm 1.0 0 0
+ prepbufr mxtm null mxtm 1.0 0 0
+ prepbufr mitm null mitm 1.0 0 0
+ prepbufr pmsl null pmsl 1.0 0 0
+ prepbufr howv null howv 1.0 0 0
+ satmar howv null howv 1.0 0 0
+ prepbufr tcamt null tcamt 1.0 0 0
+ goessky tcamt null tcamt 1.0 0 0
+ prepbufr cldch null cldch 1.0 0 0
::
&SUPEROB_RADAR
- del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000.,
- l2superob_only=.false.,
/
&LAG_DATA
/
&HYBRID_ENSEMBLE
- l_hyb_ens=${HYBENS_REGIONAL},
- n_ens=${ENSEMBLE_SIZE_REGIONAL},
- uv_hyb_ens=${HYBENS_UV_REGIONAL},
- beta_s0=${BETA_S0_REGIONAL},
- readin_beta=.false.,
- s_ens_h=${HYBENS_HOR_SCALE_REGIONAL},
- s_ens_v=${HYBENS_VER_SCALE_REGIONAL},
- generate_ens=${GENERATE_ENS_REGIONAL},
- aniso_a_en=${HYBENS_ANISO_REGIONAL},
- nlon_ens=${NLON_ENS_REGIONAL},
- nlat_ens=${NLAT_ENS_REGIONAL},
- jcap_ens=${JCAP_ENS_REGIONAL},
- jcap_ens_test=${JCAP_ENS_TEST_REGIONAL},
/
&RAPIDREFRESH_CLDSURF
dfi_radar_latent_heat_time_period=30.0,
+ l_closeobs=.true.
/
&CHEM
/
&SINGLEOB_TEST
maginnov=0.1,magoberr=0.1,oneob_type='t',
- oblat=45.,oblon=270.,obpres=850.,obdattim=${adate},
+ oblat=36.,oblon=260.,obpres=1000.,obdattim=${adate},
obhourset=0.,
/
&NST
/
"
;;
-
- rrfs_3denvar_glbens)
+ rrfs_3denvar_rdasens)
# Define namelist for rrfs 3d hybrid envar run with global ensembles
export gsi_namelist="
&SETUP
- miter=2,niter(1)=25,niter(2)=25,
+ miter=2,niter(1)=5,niter(2)=5,
write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- qoption=2,print_obs_para=.true.,diag_radardbz=.false.,
- if_model_dbz=.false., static_gsi_nopcp_dbz=0.0,
+ qoption=2,print_obs_para=.true.,diag_fed=.true.,diag_radardbz=.false.,
+ if_model_dbz=.true.,if_model_fed=.true.,static_gsi_nopcp_dbz=0.0,if_use_w_vr=.false.,
rmesh_dbz=4.0,rmesh_vr=4.0,zmesh_dbz=1000.0,zmesh_vr=1000.0,
- missing_to_nopcp=.false.,radar_no_thinning=.true.,
+ inflate_dbz_obserr=.true.,missing_to_nopcp=.false.,radar_no_thinning=.true.,
gencode=78,factqmin=0.0,factqmax=0.0,
- iguess=-1,
+ iguess=-1,crtm_coeffs_path='./',
lread_obs_save=.false.,lread_obs_skip=.false.,
+ ens_nstarthr=01,
oneobtest=.false.,retrieval=.false.,
nhr_assimilation=3,l_foto=.false.,
use_pbl=.false.,use_prepb_satwnd=.false.,
@@ -1412,8 +344,10 @@ export gsi_namelist="
diag_precon=.true.,step_start=1.e-3,
l4densvar=.false.,nhr_obsbin=3,
use_gfs_nemsio=.false.,use_gfs_ncio=.true.,reset_bad_radbc=.true.,
- netcdf_diag=.false.,binary_diag=.true.,
+ netcdf_diag=.true.,binary_diag=.false.,
l_obsprvdiag=.false.,
+ lwrite_peakwt=.true.,
+ innov_use_model_fed=.true.,
/
&GRIDOPTS
fv3_regional=.true.,grid_ratio_fv3_regional=2.0,nvege_type=20,
@@ -1441,7 +375,9 @@ export gsi_namelist="
/
OBS_INPUT::
! dfile dtype dplat dsis dval dthin dsfcalc
+ pm25bufr pm2_5 null TEOM 1.0 0 0
dbzobs.nc dbz null dbz 1.0 0 0
+ fedobs.nc fed null fed 1.0 0 0
prepbufr ps null ps 1.0 0 0
prepbufr t null t 1.0 0 0
prepbufr q null q 1.0 0 0
@@ -1472,12 +408,14 @@ OBS_INPUT::
amsuabufr amsua n19 amsua_n19 0.0 2 0
amsuabufr amsua metop-a amsua_metop-a 0.0 2 0
amsuabufr amsua metop-b amsua_metop-b 0.0 2 0
+ amsuabufr amsua metop-c amsua_metop-c 0.0 2 0
airsbufr amsua aqua amsua_aqua 0.0 2 0
amsubbufr amsub n17 amsub_n17 0.0 1 0
mhsbufr mhs n18 mhs_n18 0.0 2 0
mhsbufr mhs n19 mhs_n19 0.0 2 0
mhsbufr mhs metop-a mhs_metop-a 0.0 2 0
mhsbufr mhs metop-b mhs_metop-b 0.0 2 0
+ mhsbufr mhs metop-c mhs_metop-c 0.0 2 0
ssmitbufr ssmi f13 ssmi_f13 0.0 2 0
ssmitbufr ssmi f14 ssmi_f14 0.0 2 0
ssmitbufr ssmi f15 ssmi_f15 0.0 2 0
@@ -1506,11 +444,23 @@ OBS_INPUT::
gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 2 0
iasibufr iasi metop-a iasi_metop-a 0.0 2 0
gomebufr gome metop-a gome_metop-a 0.0 2 0
+ omibufr omi aura omi_aura 0.0 2 0
+ sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
+ tcvitl tcp null tcp 0.0 0 0
+ seviribufr seviri m08 seviri_m08 0.0 2 0
+ seviribufr seviri m09 seviri_m09 0.0 2 0
+ seviribufr seviri m10 seviri_m10 0.0 2 0
+ seviribufr seviri m11 seviri_m11 0.0 2 0
+ iasibufr iasi metop-b iasi_metop-b 0.0 2 0
+ iasibufr iasi metop-c iasi_metop-c 0.0 2 0
+ gomebufr gome metop-b gome_metop-b 0.0 2 0
atmsbufr atms npp atms_npp 0.0 2 0
atmsbufr atms n20 atms_n20 0.0 2 0
+ atmsbufr atms n21 atms_n21 0.0 2 0
crisbufr cris npp cris_npp 0.0 2 0
crisfsbufr cris-fsr npp cris-fsr_npp 0.0 2 0
crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 2 0
+ crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 2 0
abibufr abi g16 abi_g16 0.0 2 0
mlsbufr mls30 aura mls30_aura 0.0 0 0
oscatbufr uv null uv 0.0 0 0
@@ -1519,6 +469,7 @@ OBS_INPUT::
refInGSI rad_ref null rad_ref 1.0 0 0
lghtInGSI lghtn null lghtn 1.0 0 0
larcInGSI larccld null larccld 1.0 0 0
+ abibufr abi g18 abi_g18 0.0 2 0
::
&SUPEROB_RADAR
del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., l2superob_only=.false.,
@@ -1531,17 +482,30 @@ OBS_INPUT::
q_hyb_ens=.false.,
aniso_a_en=.false.,generate_ens=.false.,
n_ens=${nummem},
- beta_s0=0.15,s_ens_h=110,s_ens_v=3,
- regional_ensemble_option=1,
+ l_both_fv3sar_gfs_ens=.false.,n_ens_gfs=0,n_ens_fv3sar=30,
+ weight_ens_gfs=1.0,weight_ens_fv3sar=1.0,
+ beta_s0=0.15,s_ens_h=328.632,82.1580,4.10790,4.10790,82.1580,s_ens_v=3,3,-0.30125,-0.30125,0.0,
+ regional_ensemble_option=5,
pseudo_hybens = .false.,
- grid_ratio_ens = 3,
+ grid_ratio_ens = 1,
l_ens_in_diff_time=.true.,
ensemble_path='',
i_en_perts_io=1,
jcap_ens=574,
fv3sar_bg_opt=0,
- readin_localization=.true.,
- ens_fast_read=.false.,
+ readin_localization=.false.,
+ parallelization_over_ensmembers=.false.,
+ nsclgrp=2,l_timloc_opt=.false.,ngvarloc=2,naensloc=5,
+ r_ensloccov4tim=1.0,r_ensloccov4var=0.05,r_ensloccov4scl=1.0,
+ global_spectral_filter_sd=.false.,assign_vdl_nml=.false.,vdl_scale=0,
+ vloc_varlist(1,1)='sf ',vloc_varlist(2,1)='w ',vloc_varlist(3,1)='sf ',vloc_varlist(4,1)='w ',
+ vloc_varlist(1,2)='vp ',vloc_varlist(2,2)='qr ',vloc_varlist(3,2)='vp ',vloc_varlist(4,2)='qr ',
+ vloc_varlist(1,3)='ps ',vloc_varlist(2,3)='qs ',vloc_varlist(3,3)='ps ',vloc_varlist(4,3)='qs ',
+ vloc_varlist(1,4)='t ',vloc_varlist(2,4)='qi ',vloc_varlist(3,4)='t ',vloc_varlist(4,4)='qi ',
+ vloc_varlist(1,5)='q ',vloc_varlist(2,5)='qg ',vloc_varlist(3,5)='q ',vloc_varlist(4,5)='qg ',
+ vloc_varlist(1,6)='sst',vloc_varlist(2,6)='ql ',vloc_varlist(3,6)='sst',vloc_varlist(4,6)='ql ',
+ vloc_varlist(1,7)='stl',vloc_varlist(2,7)='dbz',vloc_varlist(3,7)='stl',vloc_varlist(4,7)='dbz',
+ vloc_varlist(1,8)='sti',vloc_varlist(2,8)='aaa',vloc_varlist(3,8)='sti',vloc_varlist(4,8)='aaa',
/
&RAPIDREFRESH_CLDSURF
dfi_radar_latent_heat_time_period=20.0,
@@ -1581,6 +545,8 @@ OBS_INPUT::
i_gsdqc=2,
/
&CHEM
+ laeroana_fv3smoke=.false.,
+ berror_fv3_cmaq_regional=.false.,
/
&NST
/
@@ -1591,255 +557,49 @@ OBS_INPUT::
/
"
;;
- netcdf_fv3_regional)
-
-# Define namelist for netcdf fv3 run
+ hafs_envar)
+# Define namelist for hafs 3denvar run with global ensembles
export gsi_namelist="
&SETUP
- miter=2,niter(1)=50,niter(2)=50,niter_no_qc(1)=20,
+ miter=2,niter(1)=5,niter(2)=5,
+ niter_no_qc(1)=2,niter_no_qc(2)=0,
write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
+ gencode=78,deltim=1200,
+ factqmin=0.0,factqmax=0.0,
iguess=-1,
- newpc4pred=.true., adp_anglebc=.true., angord=4,
- diag_precon=.true., step_start=1.e-3,
- nhr_assimilation=3,l_foto=.false.,
- use_pbl=.false.,use_compress=.false.,gpstop=30.,
+ aircraft_recon=.true.,
+ oneobtest=.false.,retrieval=.false.,l_foto=.false.,
+ nhr_assimilation=6,
+ use_pbl=.true.,use_compress=.false.,nsig_ext=14,gpstop=50.,
+ use_gfs_nemsio=.false.,use_gfs_ncio=.true.,
+ print_diag_pcg=.true.,l2rwthin=.false.,hurricane_radar=.true.,
+ use_gfs_ozone=.false.,l4densvar=${l4densvar},nhr_obsbin=${nhr_obsbin},
lrun_subdirs=.true.,
- $SETUP
- /
- &GRIDOPTS
- fv3_regional=.true.,grid_ratio_fv3_regional=3.0,
- /
- &BKGERR
- hzscl=0.373,0.746,1.50,
- vs=0.6,bw=0.,fstat=.false.,
- /
- &ANBKGERR
- anisotropic=.false.,
- /
- &JCOPTS
- /
- &STRONGOPTS
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,
- vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true.,
- /
- &OBS_INPUT
- dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5,ext_sonde=.true.,
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 0.0 0 0
- prepbufr t null t 0.0 0 0
- prepbufr q null q 0.0 0 0
- prepbufr pw null pw 0.0 0 0
- prepbufr uv null uv 0.0 0 0
- prepbufr spd null spd 0.0 0 0
- prepbufr dw null dw 0.0 0 0
- radarbufr rw null rw 0.0 0 0
- prepbufr sst null sst 0.0 0 0
- gpsrobufr gps_bnd null gps_bnd 0.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
- hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0
- hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0
- hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0
- hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0
- hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0
- hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0
- gsndrbufr sndr g11 sndr_g11 0.0 1 0
- gsndrbufr sndr g12 sndr_g12 0.0 1 0
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs281_aqua 0.0 1 0
- msubufr msu n14 msu_n14 0.0 1 0
- amsuabufr amsua n15 amsua_n15 0.0 1 0
- amsuabufr amsua n16 amsua_n16 0.0 1 0
- amsuabufr amsua n17 amsua_n17 0.0 1 0
- amsuabufr amsua n18 amsua_n18 0.0 1 0
- amsuabufr amsua metop-a amsua_metop-a 0.0 1 0
- amsuabufr amsua metop-b amsua_metop-b 0.0 1 0
- airsbufr amsua aqua amsua_aqua 0.0 1 0
- amsubbufr amsub n15 amsub_n15 0.0 1 0
- amsubbufr amsub n16 amsub_n16 0.0 1 0
- amsubbufr amsub n17 amsub_n17 0.0 1 0
- mhsbufr mhs n18 mhs_n18 0.0 1 0
- mhsbufr mhs metop-a mhs_metop-a 0.0 1 0
- mhsbufr mhs metop-b mhs_metop-b 0.0 1 0
- ssmitbufr ssmi f13 ssmi_f13 0.0 1 0
- ssmitbufr ssmi f14 ssmi_f14 0.0 1 0
- ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0
- ssmisbufr ssmis f16 ssmis_f16 0.0 1 0
- iasibufr iasi metop-a iasi_metop-a 0.0 1 0
- gomebufr gome metop-a gome_metop-a 0.0 1 0
- iasibufr iasi metop-b iasi_metop-b 0.0 1 0
- omibufr omi aura omi_aura 0.0 1 0
- sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0
- hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0
- amsuabufr amsua n19 amsua_n19 0.0 1 0
- mhsbufr mhs n19 mhs_n19 0.0 1 0
- tcvitl tcp null tcp 0.0 0 0
- satwndbufr uv null uv 0.0 0 0
- atmsbufr atms npp atms_npp 0.0 1 0
- crisbufr cris npp cris_npp 0.0 1 0
- crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0
- seviribufr seviri m08 seviri_m08 0.0 1 0
- seviribufr seviri m09 seviri_m09 0.0 1 0
- seviribufr seviri m10 seviri_m10 0.0 1 0
- seviribufr seviri m11 seviri_m11 0.0 1 0
- gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0
- gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0
- gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0
- gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0
- prepbufr mta_cld null mta_cld 1.0 0 0
- prepbufr gos_ctp null gos_ctp 1.0 0 0
- lgycldbufr larccld null larccld 1.0 0 0
-::
- &SUPEROB_RADAR
- del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000.,
- l2superob_only=.false.,
- /
- &LAG_DATA
- /
- &HYBRID_ENSEMBLE
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- /
- &CHEM
- /
- &SINGLEOB_TEST
- /
- &NST
- /
-"
-;;
-
- cmaq_binary)
-
-# Define namelist for cmaq binary run
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=50,niter(2)=50,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- gencode=78,qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,
- nhr_assimilation=3,l_foto=.false.,
- use_pbl=.false.,use_compress=.false.,
- diag_conv=.true.,lrun_subdirs=.true.,
- $SETUP
- /
- &GRIDOPTS
- JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS,
- wrf_nmm_regional=.false.,wrf_mass_regional=.false.,
- cmaq_regional=.true.,diagnostic_reg=.false.,
- filled_grid=.false.,half_grid=.true.,netcdf=.false.,
- /
- &BKGERR
- hzscl=0.373,0.746,1.50,
- vs=1.0,bw=0.,fstat=.true.,
- /
- &ANBKGERR
- anisotropic=.false.,an_vs=1.0,ngauss=1,
- an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200.,
- ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4,
- /
- &JCOPTS
- /
- &STRONGOPTS
- nstrong=0,nvmodes_keep=20,
- period_max=3.,baldiag_full=.true.,baldiag_inc=.true.,
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true.,
- /
- &OBS_INPUT
- dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,
- dmesh(5)=120,time_window_max=1.5,
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- anowbufr pm2_5 null TEOM 1.0 0 0
- /
-!max name length for dfile=13
-!max name length for dtype=10
- &SUPEROB_RADAR
- del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000.,
- l2superob_only=.false.,
-::
- &LAG_DATA
- /
- &HYBRID_ENSEMBLE
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- /
- &CHEM
- berror_chem=.true.,
- oneobtest_chem=.false.,
- maginnov_chem=60,magoberr_chem=2.,oneob_type_chem='pm2_5',
- oblat_chem=45.,oblon_chem=270.,obpres_chem=1000.,
- diag_incr=.true.,elev_tolerance=500.,tunable_error=0.5,
- in_fname="\""${cmaq_input}"\"",out_fname="\""${cmaq_output}"\"",
- incr_fname="\""${chem_increment}"\"",
-!diag_incr for diagnostic increment output
- /
- &SINGLEOB_TEST
- maginnov=5,magoberr=0.1,oneob_type='t',
- oblat=45.,oblon=270.,obpres=1000.,obdattim=${adate},
- obhourset=0.,
- /
- &NST
- /
-"
-;;
-
- hwrf_nmm_d2)
-
-# Define namelist for hwrf nmm d2 run
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=50,niter(2)=50,niter_no_qc(1)=20,niter_no_qc(2)=0,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- gencode=78,qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,
- nhr_assimilation=6,l_foto=.false.,
- use_pbl=.true.,use_compress=.false.,
- print_diag_pcg=.true.,
- use_gfs_stratosphere=$USE_GFS_STRATOSPHERE,
- use_gfs_ozone=$USE_GFS_OZONE,
- regional_ozone=$REGIONAL_OZONE,
- nsig_ext=12,gpstop=50.,
- $SETUP
+ netcdf_diag=.true.,binary_diag=.false.,
+ newpc4pred=.true., adp_anglebc=.true., angord=4,
+ passive_bc=.false., use_edges=.false., emiss_bc=.true.,
+ diag_precon=.true., step_start=1.e-3, upd_pred(1)=0,
+ upd_pred(2)=0,upd_pred(3)=0,upd_pred(4)=0,
+ upd_pred(5)=0,upd_pred(6)=0,upd_pred(7)=0,
+ upd_pred(8)=0,upd_pred(9)=0,upd_pred(10)=0,
+ upd_pred(11)=0,upd_pred(12)=0,
+ lread_obs_save=.false.,
+ lread_obs_skip=.false.,
+ ens_nstarthr=6,
+ lwrite_predterms=.false.,lwrite_peakwt=.false.,reduce_diag=.false.,
/
&GRIDOPTS
- JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$NLON,nsig=$LEVS,
- wrf_nmm_regional=.true.,wrf_mass_regional=.false.,
- diagnostic_reg=.false.,
- filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF,
+ fv3_regional=.true.,grid_ratio_fv3_regional=1,nvege_type=20,
/
&BKGERR
- hzscl=0.25,0.5,1.0,
- vs=0.6,bw=0.,fstat=.false.,
- /
+ vs=1.0,
+ hzscl=0.2,0.4,0.8,
+ bw=0.,
+ fstat=.false.,
+/
&ANBKGERR
anisotropic=.false.,an_vs=1.0,ngauss=1,
an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200.,
@@ -1853,299 +613,336 @@ export gsi_namelist="
/
&OBSQC
dfact=0.75,dfact1=3.0,erradar_inflate=1.0,tdrerr_inflate=.true.,
- noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true.,
+ noiqc=.true.,c_varqc=0.03333,vadfile='prepbufr',njqc=.false.,vqc=.true.,vadwnd_l2rw_qc=.false.,
+ q_doe_a_136=0.65,
+ q_doe_b_136=0.0003,
+ q_doe_a_137=0.75,
+ q_doe_b_137=0.0003,
+ t_doe_a_136=0.75,
+ t_doe_b_136=0.2,
+ t_doe_a_137=0.7,
+ t_doe_b_137=0.2,
+ uv_doe_a_236=0.5,
+ uv_doe_b_236=0.85,
+ uv_doe_a_237=0.5,
+ uv_doe_b_237=0.85,
+ uv_doe_a_213=0.4,
+ uv_doe_b_213=1.0,
/
&OBS_INPUT
dmesh(1)=90.0,dmesh(2)=45.0,dmesh(3)=45.0,dmesh(4)=45.0,dmesh(5)=90,time_window_max=3.0,l_foreaft_thin=.false.,
/
OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 0.0 0 0
- prepbufr t null t 0.0 0 0
- prepbufr q null q 0.0 0 0
- prepbufr pw null pw 0.0 0 0
- prepbufr uv null uv 0.0 0 0
- satwndbufr uv null uv 0.0 0 0
- prepbufr spd null spd 0.0 0 0
- prepbufr dw null dw 0.0 0 0
- radarbufr rw null l3rw 0.0 0 0
- l2rwbufr rw null l2rw 0.0 0 0
- prepbufr sst null sst 0.0 0 0
- tcvitl tcp null tcp 0.0 0 0
- tldplrbufr rw null rw 0.0 0 0
- hdobbufr uv null uv 0.0 0 0
- hdobbufr t null t 0.0 0 0
- hdobbufr q null q 0.0 0 0
- hdobbufr spd null spd 0.0 0 0
- gpsrobufr gps_bnd null gps 0.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
- hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0
- hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs_aqua 0.0 1 1
- amsuabufr amsua n15 amsua_n15 0.0 2 1
- amsuabufr amsua n18 amsua_n18 0.0 2 1
- amsuabufr amsua metop-a amsua_metop-a 0.0 2 1
- airsbufr amsua aqua amsua_aqua 0.0 2 1
- amsubbufr amsub n17 amsub_n17 0.0 3 1
- mhsbufr mhs n18 mhs_n18 0.0 3 1
- mhsbufr mhs metop-a mhs_metop-a 0.0 3 1
- ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 4 0
- amsrebufr amsre_mid aqua amsre_aqua 0.0 4 0
- amsrebufr amsre_hig aqua amsre_aqua 0.0 4 0
- ssmisbufr ssmis f16 ssmis_f16 0.0 4 0
- ssmisbufr ssmis f17 ssmis_f17 0.0 4 0
- ssmisbufr ssmis f18 ssmis_f18 0.0 4 0
- ssmisbufr ssmis f19 ssmis_f19 0.0 4 0
- gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 5 0
- gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 5 0
- gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 5 0
- gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 5 0
- gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 5 0
- gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 5 0
- gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 5 0
- gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 5 0
- gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 5 0
- gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 5 0
- gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 5 0
- gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 5 0
- iasibufr iasi metop-a iasi_metop-a 0.0 1 1
- gomebufr gome metop-a gome_metop-a 0.0 2 0
- omibufr omi aura omi_aura 0.0 2 0
- sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
- hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1
- amsuabufr amsua n19 amsua_n19 0.0 2 1
- mhsbufr mhs n19 mhs_n19 0.0 3 1
- seviribufr seviri m08 seviri_m08 0.0 1 0
- seviribufr seviri m09 seviri_m09 0.0 1 0
- seviribufr seviri m10 seviri_m10 0.0 1 0
- seviribufr seviri m11 seviri_m11 0.0 1 0
- hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0
- amsuabufr amsua metop-b amsua_metop-b 0.0 2 0
- mhsbufr mhs metop-b mhs_metop-b 0.0 3 0
- iasibufr iasi metop-b iasi_metop-b 0.0 1 0
- gomebufr gome metop-b gome_metop-b 0.0 2 0
- atmsbufr atms npp atms_npp 0.0 2 0
- atmsbufr atms n20 atms_n20 0.0 2 0
- crisbufr cris npp cris_npp 0.0 1 0
- crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0
- crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0
- gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 5 0
- gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 5 0
- gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 5 0
- gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 5 0
- gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 5 0
- gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0
- gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0
- gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0
- ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0
- ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0
+! dfile dtype dplat dsis dval dthin dsfcalc
+ prepbufr ps null ps 0.0 0 0
+ prepbufr t null t 0.0 0 0
+ prepbufr_profl t null t 0.0 0 0
+ prepbufr q null q 0.0 0 0
+ prepbufr_profl q null q 0.0 0 0
+ prepbufr pw null pw 0.0 0 0
+ prepbufr uv null uv 0.0 0 0
+ prepbufr_profl uv null uv 0.0 0 0
+ satwndbufr uv null uv 0.0 0 0
+ satwhrbufr uv null uv 0.0 0 0
+ prepbufr spd null spd 0.0 0 0
+ prepbufr dw null dw 0.0 0 0
+ radarbufr rw null rw 0.0 0 0
+ prepbufr sst null sst 0.0 0 0
+ tcvitl tcp null tcp 0.0 0 0
+ tldplrbufr rw null rw 0.0 0 0
+ l2rwbufr rw null l2rw 0.0 0 0
+ hdobbufr uv null uv 0.0 0 0
+ hdobbufr t null t 0.0 0 0
+ hdobbufr q null q 0.0 0 0
+ hdobbufr spd null spd 0.0 0 0
+ gpsrobufr gps_bnd null gps 0.0 0 0
+ ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
+ tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
+ sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
+ sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
+ sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
+ gimgrbufr goes_img g11 imgr_g11 0.0 1 0
+ gimgrbufr goes_img g12 imgr_g12 0.0 1 0
+ airsbufr airs aqua airs_aqua 0.0 1 1
+ amsuabufr amsua n15 amsua_n15 0.0 2 1
+ amsuabufr amsua n18 amsua_n18 0.0 2 1
+ amsuabufr amsua metop-a amsua_metop-a 0.0 2 1
+ airsbufr amsua aqua amsua_aqua 0.0 2 1
+ amsubbufr amsub n17 amsub_n17 0.0 3 1
+ mhsbufr mhs n18 mhs_n18 0.0 3 1
+ mhsbufr mhs metop-a mhs_metop-a 0.0 3 1
+ ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
+ amsrebufr amsre_low aqua amsre_aqua 0.0 4 0
+ amsrebufr amsre_mid aqua amsre_aqua 0.0 4 0
+ amsrebufr amsre_hig aqua amsre_aqua 0.0 4 0
+ ssmisbufr ssmis f16 ssmis_f16 0.0 4 0
+ ssmisbufr ssmis f17 ssmis_f17 0.0 4 0
+ ssmisbufr ssmis f18 ssmis_f18 0.0 4 0
+ ssmisbufr ssmis f19 ssmis_f19 0.0 4 0
+ gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 5 0
+ gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 5 0
+ gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 5 0
+ gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 5 0
+ gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 5 0
+ gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 5 0
+ gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 5 0
+ gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 5 0
+ gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 5 0
+ gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 5 0
+ gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 5 0
+ gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 5 0
+ iasibufr iasi metop-a iasi_metop-a 0.0 1 1
+ gomebufr gome metop-a gome_metop-a 0.0 2 0
+ omibufr omi aura omi_aura 0.0 2 0
+ sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
+ amsuabufr amsua n19 amsua_n19 0.0 2 1
+ mhsbufr mhs n19 mhs_n19 0.0 3 1
+ seviribufr seviri m08 seviri_m08 0.0 1 0
+ seviribufr seviri m09 seviri_m09 0.0 1 0
+ seviribufr seviri m10 seviri_m10 0.0 1 0
+ amsuabufr amsua metop-b amsua_metop-b 0.0 2 0
+ mhsbufr mhs metop-b mhs_metop-b 0.0 3 0
+ iasibufr iasi metop-b iasi_metop-b 0.0 1 0
+ gomebufr gome metop-b gome_metop-b 0.0 2 0
+ atmsbufr atms npp atms_npp 0.0 2 0
+ atmsbufr atms n20 atms_n20 0.0 2 0
+ crisbufr cris npp cris_npp 0.0 1 0
+ crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0
+ crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0
+ gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 5 0
+ gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 5 0
+ gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 5 0
+ gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 5 0
+ gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 5 0
+ gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0
+ gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0
+ gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0
+ oscatbufr uv null uv 0.0 0 0
+ mlsbufr mls30 aura mls30_aura 0.0 0 0
+ amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0
+ gmibufr gmi gpm gmi_gpm 0.0 3 0
+ saphirbufr saphir meghat saphir_meghat 0.0 3 0
+ ahibufr ahi himawari8 ahi_himawari8 0.0 3 0
::
&SUPEROB_RADAR
- del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000.,
- l2superob_only=.false.,
- /
+ del_azimuth=5.,del_elev=.25,del_range=10000.,del_time=1.0,elev_angle_max=5.,minnum=1,range_max=200000.,
+ l2superob_only=.false.,radar_sites=.false.,
+ radar_box=.true.,radar_rmesh=10,radar_zmesh=500,
+ /
+SUPEROB_RADAR::
+ KBRO 1
+ KCRP 1
+ KEWX 1
+ KGRX 1
+ KDFX 1
+ KHGX 1
+ KLCH 1
+ KLIX 1
+ KPOE 1
+ KSHV 1
+ KDGX 1
+ KMOB 1
+ KEVX 1
+ KEOX 1
+ KMXX 1
+ KBMX 1
+ KTLH 1
+ KTBW 1
+ KBYX 1
+ KAMX 1
+ KMLB 1
+ KJAX 1
+ KVAX 1
+ KJGX 1
+ KFFC 1
+ KCLX 1
+ KCAE 1
+ KGSP 1
+ KLTX 1
+ KMHX 1
+ KRAX 1
+ KAKQ 1
+ KFCX 1
+ KLWX 1
+ KDOX 1
+ KCCX 1
+ KDIX 1
+ KOKX 1
+ KENX 1
+ KBGM 1
+ KCXX 1
+ KBOX 1
+ KGYX 1
+ KCBW 1
+ TJUA 1
+ PHWA 1
+ PHKI 1
+ PHMO 1
+ PHKM 1
+::
+/
&LAG_DATA
/
&HYBRID_ENSEMBLE
- l_hyb_ens=.true.,n_ens=10,uv_hyb_ens=.true.,beta_s0=0.2,
- readin_beta=.true.,
- s_ens_h=300,s_ens_v=-0.5,readin_localization=.false.,
- generate_ens=.false.,regional_ensemble_option=1,grid_ratio_ens=1,
- pseudo_hybens=.false.,merge_two_grid_ensperts=.false.,
- pwgtflg=.false.,aniso_a_en=.false.,
- nlon_ens=165,nlat_ens=335,jcap_ens=0,jcap_ens_test=0,
+ l_hyb_ens=.true.,
+ n_ens=${N_ENS},
+ uv_hyb_ens=.true.,
+ beta_s0=${BETA_S0},
+ s_ens_h=150,
+ s_ens_v=-0.5,
+ readin_localization=.false.,
+ generate_ens=.false.,
+ regional_ensemble_option=${REGIONAL_ENSEMBLE_OPTION},
+ grid_ratio_ens=${GRID_RATIO_ENS},
+ pseudo_hybens=.false.,
+ merge_two_grid_ensperts=F,
+ pwgtflg=F,
+ aniso_a_en=.false.,
+ nlon_ens=387,
+ nlat_ens=777,
+ write_ens_sprd=F,
+ l_both_fv3sar_gfs_ens=${l_both_fv3sar_gfs_ens},
+ n_ens_gfs=${n_ens_gfs},
+ n_ens_fv3sar=${n_ens_fv3sar},
/
&RAPIDREFRESH_CLDSURF
dfi_radar_latent_heat_time_period=30.0,
/
&CHEM
/
+ &NST
+ /
&SINGLEOB_TEST
maginnov=1.0,magoberr=0.8,oneob_type='t',
- oblat=38.,oblon=279.,obpres=500.,obdattim=${adate},
+ oblat=38.,oblon=279.,obpres=500.,obdattim=2020040500,
obhourset=0.,
/
- &NST
- /
"
;;
+ rrfs_enkf_conv)
- hwrf_nmm_d3)
-
-# Define namelist for hwrf nmm d3 run
+# Define namelist for rrfs EnKF run
export gsi_namelist="
- &SETUP
- miter=2,niter(1)=50,niter(2)=50,niter_no_qc(1)=20,niter_no_qc(2)=0,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- gencode=78,qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,
- nhr_assimilation=6,l_foto=.false.,
- use_pbl=.true.,use_compress=.false.,
- print_diag_pcg=.true.,
- use_gfs_stratosphere=$USE_GFS_STRATOSPHERE,
- use_gfs_ozone=$USE_GFS_OZONE,
- regional_ozone=$REGIONAL_OZONE,
- nsig_ext=12,gpstop=50.,
- $SETUP
- /
- &GRIDOPTS
- JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$NLON,nsig=$LEVS,
- wrf_nmm_regional=.true.,wrf_mass_regional=.false.,
- diagnostic_reg=.false.,
- filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF,
- /
- &BKGERR
- hzscl=0.2,0.4,0.8,
- vs=0.6,bw=0.,fstat=.false.,
- /
- &ANBKGERR
- anisotropic=.false.,an_vs=1.0,ngauss=1,
- an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200.,
- ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4,
- /
- &JCOPTS
- /
- &STRONGOPTS
- tlnmc_option=0,reg_tlnmc_type=1,nstrong=1,nvmodes_keep=8,period_max=6.,
- period_width=1.5,baldiag_full=.false.,baldiag_inc=.false.,
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,erradar_inflate=1.0,tdrerr_inflate=.true.,
- noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true.,
- /
- &OBS_INPUT
- dmesh(1)=90.0,dmesh(2)=45.0,dmesh(3)=45.0,dmesh(4)=45.0,dmesh(5)=90,time_window_max=3.0,l_foreaft_thin=.false.,
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 0.0 0 0
- prepbufr t null t 0.0 0 0
- prepbufr q null q 0.0 0 0
- prepbufr pw null pw 0.0 0 0
- prepbufr uv null uv 0.0 0 0
- satwndbufr uv null uv 0.0 0 0
- prepbufr spd null spd 0.0 0 0
- prepbufr dw null dw 0.0 0 0
- radarbufr rw null l3rw 0.0 0 0
- l2rwbufr rw null l2rw 0.0 0 0
- prepbufr sst null sst 0.0 0 0
- tcvitl tcp null tcp 0.0 0 0
- tldplrbufr rw null rw 0.0 0 0
- hdobbufr uv null uv 0.0 0 0
- hdobbufr t null t 0.0 0 0
- hdobbufr q null q 0.0 0 0
- hdobbufr spd null spd 0.0 0 0
- gpsrobufr gps_bnd null gps 0.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
- hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0
- hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs_aqua 0.0 1 1
- amsuabufr amsua n15 amsua_n15 0.0 2 1
- amsuabufr amsua n18 amsua_n18 0.0 2 1
- amsuabufr amsua metop-a amsua_metop-a 0.0 2 1
- airsbufr amsua aqua amsua_aqua 0.0 2 1
- amsubbufr amsub n17 amsub_n17 0.0 3 1
- mhsbufr mhs n18 mhs_n18 0.0 3 1
- mhsbufr mhs metop-a mhs_metop-a 0.0 3 1
- ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 4 0
- amsrebufr amsre_mid aqua amsre_aqua 0.0 4 0
- amsrebufr amsre_hig aqua amsre_aqua 0.0 4 0
- ssmisbufr ssmis f16 ssmis_f16 0.0 4 0
- ssmisbufr ssmis f17 ssmis_f17 0.0 4 0
- ssmisbufr ssmis f18 ssmis_f18 0.0 4 0
- ssmisbufr ssmis f19 ssmis_f19 0.0 4 0
- gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 5 0
- gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 5 0
- gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 5 0
- gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 5 0
- gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 5 0
- gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 5 0
- gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 5 0
- gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 5 0
- gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 5 0
- gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 5 0
- gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 5 0
- gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 5 0
- iasibufr iasi metop-a iasi_metop-a 0.0 1 1
- gomebufr gome metop-a gome_metop-a 0.0 2 0
- omibufr omi aura omi_aura 0.0 2 0
- sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
- hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1
- amsuabufr amsua n19 amsua_n19 0.0 2 1
- mhsbufr mhs n19 mhs_n19 0.0 3 1
- seviribufr seviri m08 seviri_m08 0.0 1 0
- seviribufr seviri m09 seviri_m09 0.0 1 0
- seviribufr seviri m10 seviri_m10 0.0 1 0
- seviribufr seviri m11 seviri_m11 0.0 1 0
- hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0
- amsuabufr amsua metop-b amsua_metop-b 0.0 2 0
- mhsbufr mhs metop-b mhs_metop-b 0.0 3 0
- iasibufr iasi metop-b iasi_metop-b 0.0 1 0
- gomebufr gome metop-b gome_metop-b 0.0 2 0
- atmsbufr atms npp atms_npp 0.0 2 0
- atmsbufr atms n20 atms_n20 0.0 2 0
- crisbufr cris npp cris_npp 0.0 1 0
- crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0
- crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0
- gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 5 0
- gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 5 0
- gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 5 0
- gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 5 0
- gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 5 0
- gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0
- gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0
- gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0
- ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0
- ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0
-::
- &SUPEROB_RADAR
- del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000.,
- l2superob_only=.false.,
- /
- &LAG_DATA
- /
- &HYBRID_ENSEMBLE
- l_hyb_ens=.true.,n_ens=10,uv_hyb_ens=.true.,beta_s0=0.2,
- readin_beta=.true.,
- s_ens_h=150,s_ens_v=-0.5,readin_localization=.false.,
- generate_ens=.false.,regional_ensemble_option=1,grid_ratio_ens=1,
- pseudo_hybens=.false.,merge_two_grid_ensperts=.false.,
- pwgtflg=.false.,aniso_a_en=.false.,
- nlon_ens=249,nlat_ens=499,jcap_ens=0,jcap_ens_test=0,
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- /
- &CHEM
- /
- &SINGLEOB_TEST
- maginnov=1.0,magoberr=0.8,oneob_type='t',
- oblat=38.,oblon=279.,obpres=500.,obdattim=${adate},
- obhourset=0.,
- /
- &NST
- /
+ &nam_enkf
+ datestring=${rrfs_enkf_adate},datapath='${tmpdir}/',
+ analpertwtnh=1.10,analpertwtsh=1.10,analpertwttr=1.10,
+ covinflatemax=1.e2,covinflatemin=1,pseudo_rh=.true.,iassim_order=0,
+ corrlengthnh=300,corrlengthsh=300,corrlengthtr=300,
+ lnsigcutoffnh=0.5,lnsigcutoffsh=0.5,lnsigcutofftr=0.5,
+ lnsigcutoffpsnh=0.5,lnsigcutoffpssh=0.5,lnsigcutoffpstr=0.5,
+ lnsigcutoffsatnh=0.5,lnsigcutoffsatsh=0.5,lnsigcutoffsattr=0.5,
+ obtimelnh=1.e30,obtimelsh=1.e30,obtimeltr=1.e30,
+ saterrfact=1.0,numiter=1,
+ sprd_tol=1.e30,paoverpb_thresh=0.98,
+ nlons=420,nlats= 252, nlevs= 65,nanals=5,
+ deterministic=.true.,sortinc=.true.,lupd_satbiasc=.false.,
+ reducedgrid=.true.,readin_localization=.false.,
+ use_gfs_nemsio=.true.,imp_physics=99,lupp=.false.,
+ univaroz=.false.,adp_anglebc=.true.,angord=4,use_edges=.false.,emiss_bc=.true.,
+ lobsdiag_forenkf=.false.,
+ write_spread_diag=.false.,
+ netcdf_diag=.true.,
+ fv3_native=.true.,
+ /
+ &satobs_enkf
+ sattypes_rad(1) = 'amsua_n15', dsis(1) = 'amsua_n15',
+ sattypes_rad(2) = 'amsua_n18', dsis(2) = 'amsua_n18',
+ sattypes_rad(3) = 'amsua_n19', dsis(3) = 'amsua_n19',
+ sattypes_rad(4) = 'amsub_n16', dsis(4) = 'amsub_n16',
+ sattypes_rad(5) = 'amsub_n17', dsis(5) = 'amsub_n17',
+ sattypes_rad(6) = 'amsua_aqua', dsis(6) = 'amsua_aqua',
+ sattypes_rad(7) = 'amsua_metop-a', dsis(7) = 'amsua_metop-a',
+ sattypes_rad(8) = 'airs_aqua', dsis(8) = 'airs_aqua',
+ sattypes_rad(9) = 'hirs3_n17', dsis(9) = 'hirs3_n17',
+ sattypes_rad(10)= 'hirs4_n19', dsis(10)= 'hirs4_n19',
+ sattypes_rad(11)= 'hirs4_metop-a', dsis(11)= 'hirs4_metop-a',
+ sattypes_rad(12)= 'mhs_n18', dsis(12)= 'mhs_n18',
+ sattypes_rad(13)= 'mhs_n19', dsis(13)= 'mhs_n19',
+ sattypes_rad(14)= 'mhs_metop-a', dsis(14)= 'mhs_metop-a',
+ sattypes_rad(15)= 'goes_img_g11', dsis(15)= 'imgr_g11',
+ sattypes_rad(16)= 'goes_img_g12', dsis(16)= 'imgr_g12',
+ sattypes_rad(17)= 'goes_img_g13', dsis(17)= 'imgr_g13',
+ sattypes_rad(18)= 'goes_img_g14', dsis(18)= 'imgr_g14',
+ sattypes_rad(19)= 'goes_img_g15', dsis(19)= 'imgr_g15',
+ sattypes_rad(20)= 'avhrr_n18', dsis(20)= 'avhrr3_n18',
+ sattypes_rad(21)= 'avhrr_metop-a', dsis(21)= 'avhrr3_metop-a',
+ sattypes_rad(22)= 'avhrr_n19', dsis(22)= 'avhrr3_n19',
+ sattypes_rad(23)= 'amsre_aqua', dsis(23)= 'amsre_aqua',
+ sattypes_rad(24)= 'ssmis_f16', dsis(24)= 'ssmis_f16',
+ sattypes_rad(25)= 'ssmis_f17', dsis(25)= 'ssmis_f17',
+ sattypes_rad(26)= 'ssmis_f18', dsis(26)= 'ssmis_f18',
+ sattypes_rad(27)= 'ssmis_f19', dsis(27)= 'ssmis_f19',
+ sattypes_rad(28)= 'ssmis_f20', dsis(28)= 'ssmis_f20',
+ sattypes_rad(29)= 'sndrd1_g11', dsis(29)= 'sndrD1_g11',
+ sattypes_rad(30)= 'sndrd2_g11', dsis(30)= 'sndrD2_g11',
+ sattypes_rad(31)= 'sndrd3_g11', dsis(31)= 'sndrD3_g11',
+ sattypes_rad(32)= 'sndrd4_g11', dsis(32)= 'sndrD4_g11',
+ sattypes_rad(33)= 'sndrd1_g12', dsis(33)= 'sndrD1_g12',
+ sattypes_rad(34)= 'sndrd2_g12', dsis(34)= 'sndrD2_g12',
+ sattypes_rad(35)= 'sndrd3_g12', dsis(35)= 'sndrD3_g12',
+ sattypes_rad(36)= 'sndrd4_g12', dsis(36)= 'sndrD4_g12',
+ sattypes_rad(37)= 'sndrd1_g13', dsis(37)= 'sndrD1_g13',
+ sattypes_rad(38)= 'sndrd2_g13', dsis(38)= 'sndrD2_g13',
+ sattypes_rad(39)= 'sndrd3_g13', dsis(39)= 'sndrD3_g13',
+ sattypes_rad(40)= 'sndrd4_g13', dsis(40)= 'sndrD4_g13',
+ sattypes_rad(41)= 'sndrd1_g14', dsis(41)= 'sndrD1_g14',
+ sattypes_rad(42)= 'sndrd2_g14', dsis(42)= 'sndrD2_g14',
+ sattypes_rad(43)= 'sndrd3_g14', dsis(43)= 'sndrD3_g14',
+ sattypes_rad(44)= 'sndrd4_g14', dsis(44)= 'sndrD4_g14',
+ sattypes_rad(45)= 'sndrd1_g15', dsis(45)= 'sndrD1_g15',
+ sattypes_rad(46)= 'sndrd2_g15', dsis(46)= 'sndrD2_g15',
+ sattypes_rad(47)= 'sndrd3_g15', dsis(47)= 'sndrD3_g15',
+ sattypes_rad(48)= 'sndrd4_g15', dsis(48)= 'sndrD4_g15',
+ sattypes_rad(49)= 'iasi_metop-a', dsis(49)= 'iasi_metop-a',
+ sattypes_rad(50)= 'seviri_m08', dsis(50)= 'seviri_m08',
+ sattypes_rad(51)= 'seviri_m09', dsis(51)= 'seviri_m09',
+ sattypes_rad(52)= 'seviri_m10', dsis(52)= 'seviri_m10',
+ sattypes_rad(53)= 'seviri_m11', dsis(53)= 'seviri_m11',
+ sattypes_rad(54)= 'amsua_metop-b', dsis(54)= 'amsua_metop-b',
+ sattypes_rad(55)= 'hirs4_metop-b', dsis(55)= 'hirs4_metop-b',
+ sattypes_rad(56)= 'mhs_metop-b', dsis(56)= 'mhs_metop-b',
+ sattypes_rad(57)= 'iasi_metop-b', dsis(57)= 'iasi_metop-b',
+ sattypes_rad(58)= 'avhrr_metop-b', dsis(58)= 'avhrr3_metop-b',
+ sattypes_rad(59)= 'atms_npp', dsis(59)= 'atms_npp',
+ sattypes_rad(60)= 'atms_n20', dsis(60)= 'atms_n20',
+ sattypes_rad(61)= 'cris_npp', dsis(61)= 'cris_npp',
+ sattypes_rad(62)= 'cris-fsr_npp', dsis(62)= 'cris-fsr_npp',
+ sattypes_rad(63)= 'cris-fsr_n20', dsis(63)= 'cris-fsr_n20',
+ sattypes_rad(64)= 'gmi_gpm', dsis(64)= 'gmi_gpm',
+ sattypes_rad(65)= 'saphir_meghat', dsis(65)= 'saphir_meghat',
+ sattypes_rad(66)= 'amsua_metop-c', dsis(66)= 'amsua_metop-c',
+ sattypes_rad(67)= 'mhs_metop-c', dsis(67)= 'mhs_metop-c',
+ sattypes_rad(68)= 'ahi_himawari8', dsis(68)= 'ahi_himawari8',
+ sattypes_rad(69)= 'abi_g16', dsis(69)= 'abi_g16',
+ sattypes_rad(70)= 'abi_g17', dsis(70)= 'abi_g17',
+ sattypes_rad(71)= 'iasi_metop-c', dsis(71)= 'iasi_metop-c',
+ sattypes_rad(72)= 'viirs-m_npp', dsis(72)= 'viirs-m_npp',
+ sattypes_rad(73)= 'viirs-m_j1', dsis(73)= 'viirs-m_j1',
+ sattypes_rad(74)= 'avhrr_metop-c', dsis(74)= 'avhrr3_metop-c',
+ sattypes_rad(75)= 'abi_g18', dsis(75)= 'abi_g18',
+ sattypes_rad(76)= 'ahi_himawari9', dsis(76)= 'ahi_himawari9',
+ sattypes_rad(77)= 'viirs-m_j2', dsis(77)= 'viirs-m_j2',
+ sattypes_rad(78)= 'atms_n21', dsis(78)= 'atms_n21',
+ sattypes_rad(79)= 'cris-fsr_n21', dsis(79)= 'cris-fsr_n21',
+ /
+ &ozobs_enkf
+ sattypes_oz(1) = 'sbuv2_n16',
+ sattypes_oz(2) = 'sbuv2_n17',
+ sattypes_oz(3) = 'sbuv2_n18',
+ sattypes_oz(4) = 'sbuv2_n19',
+ sattypes_oz(5) = 'omi_aura',
+ sattypes_oz(6) = 'gome_metop-a',
+ sattypes_oz(7) = 'gome_metop-b',
+ sattypes_oz(8) = 'mls30_aura',
+ /
+ &nam_fv3
+ fv3fixpath="XXX",nx_res=${NX_RES:-420},ny_res=${NY_RES-252},ntiles=1,
+ l_fv3reg_filecombined=.false.,
+ /
"
;;
-
global_enkf)
# Define namelist for global enkf run
@@ -2155,7 +952,7 @@ export gsi_namelist="
&nam_enkf
datestring=${global_adate},datapath='${DATA}/',
analpertwtnh=${analpertwt},analpertwtsh=${analpertwt},analpertwttr=${analpertwt},
- covinflatemax=1.e2,covinflatemin=1,pseudo_rh=.true.,iassim_order=0,
+ covinflatemax=1.e2,covinflatemin=1,pseudo_rh=.false.,iassim_order=0,
corrlengthnh=${corrlength},corrlengthsh=${corrlength},corrlengthtr=${corrlength},
lnsigcutoffnh=${lnsigcutoff},lnsigcutoffsh=${lnsigcutoff},lnsigcutofftr=${lnsigcutoff},
lnsigcutoffpsnh=${lnsigcutoff},lnsigcutoffpssh=${lnsigcutoff},lnsigcutoffpstr=${lnsigcutoff},
@@ -2169,7 +966,7 @@ export gsi_namelist="
use_gfs_nemsio=${use_gfs_nemsio},use_gfs_ncio=${use_gfs_ncio},imp_physics=$imp_physics,lupp=$lupp,
univaroz=.false.,adp_anglebc=.true.,angord=4,use_edges=.false.,emiss_bc=.true.,
letkf_flag=${letkf_flag},nobsl_max=${nobsl_max},denkf=${denkf},getkf=${getkf}.,
- nhr_anal=${IAUFHRS_ENKF},nhr_state=${IAUFHRS_ENKF},use_qsatensmean=.true.,
+ nhr_anal=${IAUFHRS_ENKF},nhr_state=${IAUFHRS_ENKF},
lobsdiag_forenkf=$lobsdiag_forenkf,
write_spread_diag=$write_spread_diag,
modelspace_vloc=$modelspace_vloc,
diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh
index 59962a587b..b96c208070 100755
--- a/regression/regression_namelists_db.sh
+++ b/regression/regression_namelists_db.sh
@@ -2,173 +2,7 @@ job_name=$1
case $job_name in
-global_3dvar)
-
-# Define namelist for global run (pcgsoi minimization)
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=2,niter(2)=1,
- niter_no_qc(1)=1,niter_no_qc(2)=0,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- gencode=82,qoption=2,cwoption=3,
- factqmin=5.0,factqmax=5.0,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,l_foto=.false.,
- use_pbl=.false.,use_compress=.true.,nsig_ext=12,gpstop=50.,
- use_gfs_nemsio=.false.,lrun_subdirs=.true.,
- $SETUP
- /
- &GRIDOPTS
- JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS,
- regional=.false.,nlayers(63)=3,nlayers(64)=6,
- $GRIDOPTS
- /
- &BKGERR
- vs=0.7,
- hzscl=1.7,0.8,0.5,
- hswgt=0.45,0.3,0.25,
- bw=0.0,norsp=4,
- bkgv_flowdep=.true.,bkgv_rewgtfct=1.5,
- $BKGVERR
- /
- &ANBKGERR
- anisotropic=.false.,
- $ANBKGERR
- /
- &JCOPTS
- ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=5.0e7,
- $JCOPTS
- /
- &STRONGOPTS
- tlnmc_option=1,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5,
- baldiag_full=.true.,baldiag_inc=.true.,
- $STRONGOPTS
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.02,
- use_poq7=.true.,njqc=.false.,vqc=.true.,
- $OBSQC
- /
- &OBS_INPUT
- dmesh(1)=1450.0,dmesh(2)=1500.0,time_window_max=0.5,
- $OBSINPUT
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 0.0 0 0
- prepbufr t null t 0.0 0 0
- prepbufr q null q 0.0 0 0
- prepbufr pw null pw 0.0 0 0
- prepbufr uv null uv 0.0 0 0
- satwndbufr uv null uv 0.0 0 0
- prepbufr spd null spd 0.0 0 0
- prepbufr dw null dw 0.0 0 0
- radarbufr rw null rw 0.0 0 0
- prepbufr sst null sst 0.0 0 0
- gpsrobufr $gps_dtype null gps 0.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
- hirs3bufr hirs3 n17 hirs3_n17 0.0 1 1
- hirs4bufr_skip hirs4 metop-a hirs4_metop-a 0.0 1 1
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs_aqua 0.0 1 1
- amsuabufr_skip amsua n15 amsua_n15 0.0 1 1
- amsuabufr_skip amsua n18 amsua_n18 0.0 1 1
- amsuabufr_skip amsua metop-a amsua_metop-a 0.0 1 1
- airsbufr_skip amsua aqua amsua_aqua 0.0 1 1
- amsubbufr amsub n17 amsub_n17 0.0 1 1
- mhsbufr_skip mhs n18 mhs_n18 0.0 1 1
- mhsbufr_skip mhs metop-a mhs_metop-a 0.0 1 1
- ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0
- ssmisbufr ssmis_las f16 ssmis_f16 0.0 1 0
- ssmisbufr ssmis_uas f16 ssmis_f16 0.0 1 0
- ssmisbufr ssmis_img f16 ssmis_f16 0.0 1 0
- ssmisbufr ssmis_env f16 ssmis_f16 0.0 1 0
- gsnd1bufr_skip sndrd1 g12 sndrD1_g12 0.0 1 0
- gsnd1bufr_skip sndrd2 g12 sndrD2_g12 0.0 1 0
- gsnd1bufr_skip sndrd3 g12 sndrD3_g12 0.0 1 0
- gsnd1bufr_skip sndrd4 g12 sndrD4_g12 0.0 1 0
- gsnd1bufr_skip sndrd1 g11 sndrD1_g11 0.0 1 0
- gsnd1bufr_skip sndrd2 g11 sndrD2_g11 0.0 1 0
- gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0
- gsnd1bufr_skip sndrd4 g11 sndrD4_g11 0.0 1 0
- gsnd1bufr_skip sndrd1 g13 sndrD1_g13 0.0 1 0
- gsnd1bufr_skip sndrd2 g13 sndrD2_g13 0.0 1 0
- gsnd1bufr_skip sndrd3 g13 sndrD3_g13 0.0 1 0
- gsnd1bufr_skip sndrd4 g13 sndrD4_g13 0.0 1 0
- iasibufr iasi metop-a iasi_metop-a 0.0 1 1
- gomebufr gome metop-a gome_metop-a 0.0 2 0
- omibufr omi aura omi_aura 0.0 2 0
- sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
- hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1
- amsuabufr amsua n19 amsua_n19 0.0 1 1
- mhsbufr mhs n19 mhs_n19 0.0 1 1
- tcvitl tcp null tcp 0.0 0 0
- mlsbufr mls30 aura mls30_aura 1.0 0 0
- seviribufr seviri m08 seviri_m08 0.0 1 0
- seviribufr seviri m09 seviri_m09 0.0 1 0
- seviribufr seviri m10 seviri_m10 0.0 1 0
- seviribufr seviri m11 seviri_m11 0.0 1 0
- hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0
- amsuabufr amsua metop-b amsua_metop-b 0.0 1 0
- mhsbufr mhs metop-b mhs_metop-b 0.0 1 0
- iasibufr iasi metop-b iasi_metop-b 0.0 1 0
- gomebufr gome metop-b gome_metop-b 0.0 2 0
- atmsbufr atms npp atms_npp 0.0 1 0
- atmsbufr atms n20 atms_n20 0.0 1 0
- crisbufr cris npp cris_npp 0.0 1 0
- crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0
- crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0
- ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0
- ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0
-::
- /
- &SUPEROB_RADAR
- $SUPERRAD
- /
- &LAG_DATA
- /
- &HYBRID_ENSEMBLE
- l_hyb_ens=${HYBENS_GLOBAL},
- n_ens=${ENSEMBLE_SIZE_GLOBAL},
- uv_hyb_ens=${HYBENS_UV_GLOBAL},
- beta_s0=${BETA_S0_GLOBAL},
- readin_beta=.false.,
- s_ens_h=${HYBENS_HOR_SCALE_GLOBAL},
- s_ens_v=${HYBENS_VER_SCALE_GLOBAL},
- generate_ens=${GENERATE_ENS_GLOBAL},
- aniso_a_en=${HYBENS_ANISO_GLOBAL},
- nlon_ens=${LONA},
- nlat_ens=${NLAT},
- jcap_ens=${JCAP},
- jcap_ens_test=${JCAP},
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- /
- &CHEM
- /
- &SINGLEOB_TEST
- maginnov=0.1,magoberr=0.1,oneob_type='t',
- oblat=45.,oblon=180.,obpres=1000.,obdattim=${adate},
- obhourset=0.,
- $SINGLEOB
- /
- &NST
- /
-"
-;;
-
- global_4denvar )
+ global_4denvar)
# Define namelist for global hybrid run
@@ -256,8 +90,6 @@ OBS_INPUT::
sbuvbufr_ sbuv2 n16 sbuv8_n16 0.0 0 0
sbuvbufr_ sbuv2 n17 sbuv8_n17 0.0 0 0
sbuvbufr_ sbuv2 n18 sbuv8_n18 0.0 0 0
- hirs3bufr_ hirs3 n17 hirs3_n17 0.0 1 0
- hirs4bufr_skip hirs4 metop-a hirs4_metop-a 0.0 1 1
gimgrbufr_ goes_img g11 imgr_g11 0.0 1 0
gimgrbufr_ goes_img g12 imgr_g12 0.0 1 0
airsbufr_ airs aqua airs_aqua 0.0 1 1
@@ -291,7 +123,6 @@ OBS_INPUT::
gomebufr gome metop-a gome_metop-a 0.0 2 0
omibufr omi aura omi_aura 0.0 2 0
sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
- hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1
amsuabufr amsua n19 amsua_n19 0.0 1 1
mhsbufr mhs n19 mhs_n19 0.0 1 1
tcvitl tcp null tcp 0.0 0 0
@@ -299,7 +130,6 @@ OBS_INPUT::
seviribufr seviri m09 seviri_m09 0.0 1 0
seviribufr seviri m10 seviri_m10 0.0 1 0
seviribufr seviri m11 seviri_m11 0.0 1 0
- hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 1
amsuabufr amsua metop-b amsua_metop-b 0.0 1 1
mhsbufr mhs metop-b mhs_metop-b 0.0 1 1
iasibufr iasi metop-b iasi_metop-b 0.0 1 1
@@ -344,9 +174,12 @@ OBS_INPUT::
$LAGDATA
/
&HYBRID_ENSEMBLE
- l_hyb_ens=.true.,n_ens=10,beta_s0=0.125,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.8,generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=190,
- nlat_ens=194,nlon_ens=384,aniso_a_en=.false.,jcap_ens_test=62,oz_univ_static=.false.,readin_localization=.true.,ensemble_path='./ensemble_data/',
- ens_fast_read=.true.,write_ens_sprd=.false.,
+ l_hyb_ens=.true.,n_ens=$NMEM_ENKF,beta_s0=0.125,readin_beta=.false.,
+ generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=48,nlat_ens=98,nlon_ens=192,
+ ANISO_A_EN=.false.,jcap_ens_test=48,oz_univ_static=.false.,
+ ensemble_path='./ensemble_data/',ens_fast_read=.true.,write_ens_sprd=.false.,
+ s_ens_h=1000.0,450.0,685.0,s_ens_v=-0.5,-0.5,0.0,readin_localization=.false.,
+ global_spectral_filter_sd=.false.,r_ensloccov4scl=1,nsclgrp=2,naensloc=3,
$HYBRID_ENSEMBLE
/
&RAPIDREFRESH_CLDSURF
@@ -468,7 +301,7 @@ OBS_INPUT::
"
;;
- rrfs_3denvar_glbens)
+ rrfs_3denvar_rdasens)
# Define namelist for rrfs 3d hybrid envar run with global ensembles
@@ -477,13 +310,14 @@ export gsi_namelist="
&SETUP
miter=1,niter(1)=2,niter(2)=2,
write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- qoption=2,print_obs_para=.true.,diag_radardbz=.false.,
- if_model_dbz=.false., static_gsi_nopcp_dbz=0.0,
+ qoption=2,print_obs_para=.true.,diag_fed=.true.,diag_radardbz=.false.,
+ if_model_dbz=.true.,if_model_fed=.true.,static_gsi_nopcp_dbz=0.0,if_use_w_vr=.false.,
rmesh_dbz=4.0,rmesh_vr=4.0,zmesh_dbz=1000.0,zmesh_vr=1000.0,
- missing_to_nopcp=.false.,radar_no_thinning=.true.,
+ inflate_dbz_obserr=.true.,missing_to_nopcp=.false.,radar_no_thinning=.true.,
gencode=78,factqmin=0.0,factqmax=0.0,
- iguess=-1,
+ iguess=-1,crtm_coeffs_path='./',
lread_obs_save=.false.,lread_obs_skip=.false.,
+ ens_nstarthr=01,
oneobtest=.false.,retrieval=.false.,
nhr_assimilation=3,l_foto=.false.,
use_pbl=.false.,use_prepb_satwnd=.false.,
@@ -492,8 +326,10 @@ export gsi_namelist="
diag_precon=.true.,step_start=1.e-3,
l4densvar=.false.,nhr_obsbin=3,
use_gfs_nemsio=.false.,use_gfs_ncio=.true.,reset_bad_radbc=.true.,
- netcdf_diag=.false.,binary_diag=.true.,
+ netcdf_diag=.true.,binary_diag=.false.,
l_obsprvdiag=.false.,
+ lwrite_peakwt=.true.,
+ innov_use_model_fed=.true.,
/
&GRIDOPTS
fv3_regional=.true.,grid_ratio_fv3_regional=2.0,nvege_type=20,
@@ -521,7 +357,9 @@ export gsi_namelist="
/
OBS_INPUT::
! dfile dtype dplat dsis dval dthin dsfcalc
+ pm25bufr pm2_5 null TEOM 1.0 0 0
dbzobs.nc dbz null dbz 1.0 0 0
+ fedobs.nc fed null fed 1.0 0 0
prepbufr ps null ps 1.0 0 0
prepbufr t null t 1.0 0 0
prepbufr q null q 1.0 0 0
@@ -552,12 +390,14 @@ OBS_INPUT::
amsuabufr amsua n19 amsua_n19 0.0 2 0
amsuabufr amsua metop-a amsua_metop-a 0.0 2 0
amsuabufr amsua metop-b amsua_metop-b 0.0 2 0
+ amsuabufr amsua metop-c amsua_metop-c 0.0 2 0
airsbufr amsua aqua amsua_aqua 0.0 2 0
amsubbufr amsub n17 amsub_n17 0.0 1 0
mhsbufr mhs n18 mhs_n18 0.0 2 0
mhsbufr mhs n19 mhs_n19 0.0 2 0
mhsbufr mhs metop-a mhs_metop-a 0.0 2 0
mhsbufr mhs metop-b mhs_metop-b 0.0 2 0
+ mhsbufr mhs metop-c mhs_metop-c 0.0 2 0
ssmitbufr ssmi f13 ssmi_f13 0.0 2 0
ssmitbufr ssmi f14 ssmi_f14 0.0 2 0
ssmitbufr ssmi f15 ssmi_f15 0.0 2 0
@@ -586,11 +426,23 @@ OBS_INPUT::
gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 2 0
iasibufr iasi metop-a iasi_metop-a 0.0 2 0
gomebufr gome metop-a gome_metop-a 0.0 2 0
+ omibufr omi aura omi_aura 0.0 2 0
+ sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
+ tcvitl tcp null tcp 0.0 0 0
+ seviribufr seviri m08 seviri_m08 0.0 2 0
+ seviribufr seviri m09 seviri_m09 0.0 2 0
+ seviribufr seviri m10 seviri_m10 0.0 2 0
+ seviribufr seviri m11 seviri_m11 0.0 2 0
+ iasibufr iasi metop-b iasi_metop-b 0.0 2 0
+ iasibufr iasi metop-c iasi_metop-c 0.0 2 0
+ gomebufr gome metop-b gome_metop-b 0.0 2 0
atmsbufr atms npp atms_npp 0.0 2 0
atmsbufr atms n20 atms_n20 0.0 2 0
+ atmsbufr atms n21 atms_n21 0.0 2 0
crisbufr cris npp cris_npp 0.0 2 0
crisfsbufr cris-fsr npp cris-fsr_npp 0.0 2 0
crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 2 0
+ crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 2 0
abibufr abi g16 abi_g16 0.0 2 0
mlsbufr mls30 aura mls30_aura 0.0 0 0
oscatbufr uv null uv 0.0 0 0
@@ -599,6 +451,7 @@ OBS_INPUT::
refInGSI rad_ref null rad_ref 1.0 0 0
lghtInGSI lghtn null lghtn 1.0 0 0
larcInGSI larccld null larccld 1.0 0 0
+ abibufr abi g18 abi_g18 0.0 2 0
::
&SUPEROB_RADAR
del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., l2superob_only=.false.,
@@ -611,17 +464,30 @@ OBS_INPUT::
q_hyb_ens=.false.,
aniso_a_en=.false.,generate_ens=.false.,
n_ens=${nummem},
- beta_s0=0.15,s_ens_h=110,s_ens_v=3,
- regional_ensemble_option=1,
+ l_both_fv3sar_gfs_ens=.false.,n_ens_gfs=0,n_ens_fv3sar=30,
+ weight_ens_gfs=1.0,weight_ens_fv3sar=1.0,
+ beta_s0=0.15,s_ens_h=328.632,82.1580,4.10790,4.10790,82.1580,s_ens_v=3,3,-0.30125,-0.30125,0.0,
+ regional_ensemble_option=5,
pseudo_hybens = .false.,
- grid_ratio_ens = 3,
+ grid_ratio_ens = 1,
l_ens_in_diff_time=.true.,
ensemble_path='',
i_en_perts_io=1,
jcap_ens=574,
fv3sar_bg_opt=0,
- readin_localization=.true.,
- ens_fast_read=.false.,
+ readin_localization=.false.,
+ parallelization_over_ensmembers=.false.,
+ nsclgrp=2,l_timloc_opt=.false.,ngvarloc=2,naensloc=5,
+ r_ensloccov4tim=1.0,r_ensloccov4var=0.05,r_ensloccov4scl=1.0,
+ global_spectral_filter_sd=.false.,assign_vdl_nml=.false.,vdl_scale=0,
+ vloc_varlist(1,1)='sf ',vloc_varlist(2,1)='w ',vloc_varlist(3,1)='sf ',vloc_varlist(4,1)='w ',
+ vloc_varlist(1,2)='vp ',vloc_varlist(2,2)='qr ',vloc_varlist(3,2)='vp ',vloc_varlist(4,2)='qr ',
+ vloc_varlist(1,3)='ps ',vloc_varlist(2,3)='qs ',vloc_varlist(3,3)='ps ',vloc_varlist(4,3)='qs ',
+ vloc_varlist(1,4)='t ',vloc_varlist(2,4)='qi ',vloc_varlist(3,4)='t ',vloc_varlist(4,4)='qi ',
+ vloc_varlist(1,5)='q ',vloc_varlist(2,5)='qg ',vloc_varlist(3,5)='q ',vloc_varlist(4,5)='qg ',
+ vloc_varlist(1,6)='sst',vloc_varlist(2,6)='ql ',vloc_varlist(3,6)='sst',vloc_varlist(4,6)='ql ',
+ vloc_varlist(1,7)='stl',vloc_varlist(2,7)='dbz',vloc_varlist(3,7)='stl',vloc_varlist(4,7)='dbz',
+ vloc_varlist(1,8)='sti',vloc_varlist(2,8)='aaa',vloc_varlist(3,8)='sti',vloc_varlist(4,8)='aaa',
/
&RAPIDREFRESH_CLDSURF
dfi_radar_latent_heat_time_period=20.0,
@@ -661,6 +527,8 @@ OBS_INPUT::
i_gsdqc=2,
/
&CHEM
+ laeroana_fv3smoke=.false.,
+ berror_fv3_cmaq_regional=.false.,
/
&NST
/
@@ -672,253 +540,50 @@ OBS_INPUT::
"
;;
- netcdf_fv3_regional)
+ hafs_envar)
-# Define namelist for netcdf fv3 run
+# Define namelist for hafs 3d hybrid envar run with global ensembles
export gsi_namelist="
&SETUP
- miter=2,niter(1)=50,niter(2)=50,niter_no_qc(1)=20,
+ miter=1,niter(1)=2,niter(2)=2,
+ niter_no_qc(1)=1,niter_no_qc(2)=0,
write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
+ gencode=78,deltim=1200,
+ factqmin=0.0,factqmax=0.0,
iguess=-1,
- newpc4pred=.true., adp_anglebc=.true., angord=4,
- diag_precon=.true., step_start=1.e-3,
- nhr_assimilation=3,l_foto=.false.,
- use_pbl=.false.,use_compress=.false.,gpstop=30.,
+ aircraft_recon=.true.,
+ oneobtest=.false.,retrieval=.false.,l_foto=.false.,
+ nhr_assimilation=6,
+ use_pbl=.true.,use_compress=.false.,nsig_ext=14,gpstop=50.,
+ use_gfs_nemsio=.false.,use_gfs_ncio=.true.,
+ print_diag_pcg=.true.,l2rwthin=.false.,hurricane_radar=.true.,
+ use_gfs_ozone=.false.,l4densvar=${l4densvar},nhr_obsbin=${nhr_obsbin},
lrun_subdirs=.true.,
- $SETUP
- /
- &GRIDOPTS
- fv3_regional=.true.,grid_ratio_fv3_regional=3.0,
- /
- &BKGERR
- hzscl=0.373,0.746,1.50,
- vs=0.6,bw=0.,fstat=.false.,
- /
- &ANBKGERR
- anisotropic=.false.,
- /
- &JCOPTS
- /
- &STRONGOPTS
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,
- vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true.,
- /
- &OBS_INPUT
- dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5,ext_sonde=.true.,
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 0.0 0 0
- prepbufr t null t 0.0 0 0
- prepbufr q null q 0.0 0 0
- prepbufr pw null pw 0.0 0 0
- prepbufr uv null uv 0.0 0 0
- prepbufr spd null spd 0.0 0 0
- prepbufr dw null dw 0.0 0 0
- radarbufr rw null rw 0.0 0 0
- prepbufr sst null sst 0.0 0 0
- gpsrobufr gps_bnd null gps_bnd 0.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
- hirs2bufr hirs2 n14 hirs2_n14 0.0 1 0
- hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0
- hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0
- hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0
- hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0
- hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0
- gsndrbufr sndr g11 sndr_g11 0.0 1 0
- gsndrbufr sndr g12 sndr_g12 0.0 1 0
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs281_aqua 0.0 1 0
- msubufr msu n14 msu_n14 0.0 1 0
- amsuabufr amsua n15 amsua_n15 0.0 1 0
- amsuabufr amsua n16 amsua_n16 0.0 1 0
- amsuabufr amsua n17 amsua_n17 0.0 1 0
- amsuabufr amsua n18 amsua_n18 0.0 1 0
- amsuabufr amsua metop-a amsua_metop-a 0.0 1 0
- amsuabufr amsua metop-b amsua_metop-b 0.0 1 0
- airsbufr amsua aqua amsua_aqua 0.0 1 0
- amsubbufr amsub n15 amsub_n15 0.0 1 0
- amsubbufr amsub n16 amsub_n16 0.0 1 0
- amsubbufr amsub n17 amsub_n17 0.0 1 0
- mhsbufr mhs n18 mhs_n18 0.0 1 0
- mhsbufr mhs metop-a mhs_metop-a 0.0 1 0
- mhsbufr mhs metop-b mhs_metop-b 0.0 1 0
- ssmitbufr ssmi f13 ssmi_f13 0.0 1 0
- ssmitbufr ssmi f14 ssmi_f14 0.0 1 0
- ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0
- amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0
- ssmisbufr ssmis f16 ssmis_f16 0.0 1 0
- iasibufr iasi metop-a iasi_metop-a 0.0 1 0
- gomebufr gome metop-a gome_metop-a 0.0 1 0
- iasibufr iasi metop-b iasi_metop-b 0.0 1 0
- omibufr omi aura omi_aura 0.0 1 0
- sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0
- hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0
- amsuabufr amsua n19 amsua_n19 0.0 1 0
- mhsbufr mhs n19 mhs_n19 0.0 1 0
- tcvitl tcp null tcp 0.0 0 0
- satwndbufr uv null uv 0.0 0 0
- atmsbufr atms npp atms_npp 0.0 1 0
- crisbufr cris npp cris_npp 0.0 1 0
- crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0
- seviribufr seviri m08 seviri_m08 0.0 1 0
- seviribufr seviri m09 seviri_m09 0.0 1 0
- seviribufr seviri m10 seviri_m10 0.0 1 0
- seviribufr seviri m11 seviri_m11 0.0 1 0
- gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0
- gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0
- gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0
- gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0
- prepbufr mta_cld null mta_cld 1.0 0 0
- prepbufr gos_ctp null gos_ctp 1.0 0 0
- lgycldbufr larccld null larccld 1.0 0 0
-::
- &SUPEROB_RADAR
- del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000.,
- l2superob_only=.false.,
- /
- &LAG_DATA
- /
- &HYBRID_ENSEMBLE
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- /
- &CHEM
- /
- &SINGLEOB_TEST
- /
- &NST
- /
-"
-;;
-
-cmaq_binary)
-
-# Define namelist for cmaq binary run
-
- export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=1,niter(2)=2,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- gencode=78,qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,
- nhr_assimilation=3,l_foto=.false.,
- use_pbl=.false.,use_compress=.false.,
- diag_conv=.true.,lrun_subdirs=.true.,
- $SETUP
- /
- &GRIDOPTS
- JCAP=$JCAP,NLAT=$NLAT,NLON=$LONA,nsig=$LEVS,
- wrf_nmm_regional=.false.,wrf_mass_regional=.false.,
- cmaq_regional=.true.,diagnostic_reg=.true.,
- filled_grid=.false.,half_grid=.true.,netcdf=.false.,
- /
- &BKGERR
- hzscl=0.373,0.746,1.50,
- vs=1.0,bw=0.,fstat=.true.,
- /
- &ANBKGERR
- anisotropic=.false.,an_vs=1.0,ngauss=1,
- an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200.,
- ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4,
- /
- &JCOPTS
- /
- &STRONGOPTS
- tlnmc_option=0,nstrong=0,nvmodes_keep=20,
- period_max=3.,baldiag_full=.true.,baldiag_inc=.true.,
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',njqc=.false.,vqc=.true.,
- /
- &OBS_INPUT
- dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,
- dmesh(5)=120,time_window_max=1.5,
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- anowbufr pm2_5 null TEOM 1.0 0 0
-::
-!max name length for dfile=13
-!max name length for dtype=10
- &SUPEROB_RADAR
- del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000.,
- l2superob_only=.false.,
- /
- &LAG_DATA
- /
- &HYBRID_ENSEMBLE
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- /
- &CHEM
- berror_chem=.true.,
- oneobtest_chem=.false.,
- maginnov_chem=60,magoberr_chem=2.,oneob_type_chem='pm2_5',
- oblat_chem=45.,oblon_chem=270.,obpres_chem=1000.,
- diag_incr=.true.,elev_tolerance=500.,tunable_error=0.5,
- in_fname="\""${cmaq_input}"\"",out_fname="\""${cmaq_output}"\"",
- incr_fname="\""${chem_increment}"\"",
-!diag_incr for diagnostic increment output
- /
- &SINGLEOB_TEST
- maginnov=5,magoberr=0.1,oneob_type='t',
- oblat=45.,oblon=270.,obpres=1000.,obdattim=${adate},
- obhourset=0.,
- /
- &NST
- /
-"
-;;
-
-hwrf_nmm_d2)
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=1,niter(2)=2,niter_no_qc(1)=20,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- gencode=78,qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,
- nhr_assimilation=6,l_foto=.false.,
- use_pbl=.true.,use_compress=.false.,
- print_diag_pcg=.true.,
- use_gfs_stratosphere=$USE_GFS_STRATOSPHERE,
- use_gfs_ozone=$USE_GFS_OZONE,
- regional_ozone=$REGIONAL_OZONE,
- nsig_ext=12,gpstop=50.,
- $SETUP
+ netcdf_diag=.true.,binary_diag=.false.,
+ newpc4pred=.true., adp_anglebc=.true., angord=4,
+ passive_bc=.false., use_edges=.false., emiss_bc=.true.,
+ diag_precon=.true., step_start=1.e-3, upd_pred(1)=0,
+ upd_pred(2)=0,upd_pred(3)=0,upd_pred(4)=0,
+ upd_pred(5)=0,upd_pred(6)=0,upd_pred(7)=0,
+ upd_pred(8)=0,upd_pred(9)=0,upd_pred(10)=0,
+ upd_pred(11)=0,upd_pred(12)=0,
+ lread_obs_save=.false.,
+ lread_obs_skip=.false.,
+ ens_nstarthr=6,
+ lwrite_predterms=.false.,lwrite_peakwt=.false.,reduce_diag=.false.,
/
&GRIDOPTS
- JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$NLON,nsig=$LEVS,
- wrf_nmm_regional=.true.,wrf_mass_regional=.false.,
- diagnostic_reg=.true.,
- filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF,
+ fv3_regional=.true.,grid_ratio_fv3_regional=1,nvege_type=20,
/
&BKGERR
- hzscl=0.25,0.5,1.0,
- vs=0.6,bw=0.,fstat=.false.,
- /
+ vs=1.0,
+ hzscl=0.2,0.4,0.8,
+ bw=0.,
+ fstat=.false.,
+/
&ANBKGERR
anisotropic=.false.,an_vs=1.0,ngauss=1,
an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200.,
@@ -932,229 +597,210 @@ export gsi_namelist="
/
&OBSQC
dfact=0.75,dfact1=3.0,erradar_inflate=1.0,tdrerr_inflate=.true.,
- noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',njqc=.false.,vqc=.true.,
+ noiqc=.true.,c_varqc=0.03333,vadfile='prepbufr',njqc=.false.,vqc=.true.,vadwnd_l2rw_qc=.false.,
+ q_doe_a_136=0.65,
+ q_doe_b_136=0.0003,
+ q_doe_a_137=0.75,
+ q_doe_b_137=0.0003,
+ t_doe_a_136=0.75,
+ t_doe_b_136=0.2,
+ t_doe_a_137=0.7,
+ t_doe_b_137=0.2,
+ uv_doe_a_236=0.5,
+ uv_doe_b_236=0.85,
+ uv_doe_a_237=0.5,
+ uv_doe_b_237=0.85,
+ uv_doe_a_213=0.4,
+ uv_doe_b_213=1.0,
/
&OBS_INPUT
- dmesh(1)=90.0,dmesh(2)=45.0,dmesh(3)=45.0,dmesh(4)=45.0,dmesh(5)=90,dmesh(7)=9.0,time_window_max=3.0,l_foreaft_thin=.false.,
+ dmesh(1)=90.0,dmesh(2)=45.0,dmesh(3)=45.0,dmesh(4)=45.0,dmesh(5)=90,time_window_max=3.0,l_foreaft_thin=.false.,
/
OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 0.0 0 0
- prepbufr t null t 0.0 0 0
- prepbufr q null q 0.0 0 0
- prepbufr pw null pw 0.0 0 0
- prepbufr uv null uv 0.0 0 0
- satwndbufr uv null uv 0.0 0 0
- prepbufr spd null spd 0.0 0 0
- prepbufr dw null dw 0.0 0 0
- radarbufr rw null rw 0.0 0 0
- prepbufr sst null sst 0.0 0 0
- tcvitl tcp null tcp 0.0 0 0
- tldplrbufr rw null rw 0.0 7 0
- hdobbufr uv null uv 0.0 0 0
- hdobbufr t null t 0.0 0 0
- hdobbufr q null q 0.0 0 0
- hdobbufr spd null spd 0.0 0 0
- gpsrobufr gps_bnd null gps 0.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
- hirs3bufr_skip hirs3 n17 hirs3_n17 0.0 1 0
- hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 1
- gimgrbufr goes_img g11 imgr_g11 0.0 1 0
- gimgrbufr goes_img g12 imgr_g12 0.0 1 0
- airsbufr airs aqua airs_aqua 0.0 1 1
- amsuabufr_skip amsua n15 amsua_n15 0.0 2 1
- amsuabufr_skip amsua n18 amsua_n18 0.0 2 1
- amsuabufr amsua metop-a amsua_metop-a 0.0 2 1
- airsbufr_skip amsua aqua amsua_aqua 0.0 2 1
- amsubbufr amsub n17 amsub_n17 0.0 3 1
- mhsbufr_skip mhs n18 mhs_n18 0.0 3 1
- mhsbufr mhs metop-a mhs_metop-a 0.0 3 1
- ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
- amsrebufr amsre_low aqua amsre_aqua 0.0 4 0
- amsrebufr amsre_mid aqua amsre_aqua 0.0 4 0
- amsrebufr amsre_hig aqua amsre_aqua 0.0 4 0
- ssmisbufr ssmis f16 ssmis_f16 0.0 4 0
- ssmisbufr ssmis f17 ssmis_f17 0.0 4 0
- ssmisbufr ssmis f18 ssmis_f18 0.0 4 0
- ssmisbufr ssmis f19 ssmis_f19 0.0 4 0
- gsnd1bufr_skip sndrd1 g12 sndrD1_g12 0.0 5 0
- gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 5 0
- gsnd1bufr_skip sndrd3 g12 sndrD3_g12 0.0 5 0
- gsnd1bufr_skip sndrd4 g12 sndrD4_g12 0.0 5 0
- gsnd1bufr_skip sndrd1 g11 sndrD1_g11 0.0 5 0
- gsnd1bufr_skip sndrd2 g11 sndrD2_g11 0.0 5 0
- gsnd1bufr_skip sndrd3 g11 sndrD3_g11 0.0 5 0
- gsnd1bufr_skip sndrd4 g11 sndrD4_g11 0.0 5 0
- gsnd1bufr_skip sndrd1 g13 sndrD1_g13 0.0 5 0
- gsnd1bufr_skip sndrd2 g13 sndrD2_g13 0.0 5 0
- gsnd1bufr_skip sndrd3 g13 sndrD3_g13 0.0 5 0
- gsnd1bufr_skip sndrd4 g13 sndrD4_g13 0.0 5 0
- iasibufr iasi metop-a iasi_metop-a 0.0 1 1
- gomebufr gome metop-a gome_metop-a 0.0 2 0
- omibufr omi aura omi_aura 0.0 2 0
- sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
- hirs4bufr hirs4 n19 hirs4_n19 0.0 1 1
- amsuabufr amsua n19 amsua_n19 0.0 2 1
- mhsbufr mhs n19 mhs_n19 0.0 3 1
- seviribufr seviri m08 seviri_m08 0.0 1 0
- seviribufr seviri m09 seviri_m09 0.0 1 0
- seviribufr seviri m10 seviri_m10 0.0 1 0
- seviribufr seviri m11 seviri_m11 0.0 1 0
- hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0
- amsuabufr amsua metop-b amsua_metop-b 0.0 2 0
- mhsbufr mhs metop-b mhs_metop-b 0.0 3 0
- iasibufr iasi metop-b iasi_metop-b 0.0 1 0
- gomebufr gome metop-b gome_metop-b 0.0 2 0
- atmsbufr atms npp atms_npp 0.0 2 0
- atmsbufr atms n20 atms_n20 0.0 2 0
- crisbufr cris npp cris_npp 0.0 1 0
- crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0
- crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0
- gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 5 0
- gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 5 0
- gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 5 0
- gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 5 0
- gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 5 0
- gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0
- gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0
- gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0
- ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0
- ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0
+! dfile dtype dplat dsis dval dthin dsfcalc
+ prepbufr ps null ps 0.0 0 0
+ prepbufr t null t 0.0 0 0
+ prepbufr_profl t null t 0.0 0 0
+ prepbufr q null q 0.0 0 0
+ prepbufr_profl q null q 0.0 0 0
+ prepbufr pw null pw 0.0 0 0
+ prepbufr uv null uv 0.0 0 0
+ prepbufr_profl uv null uv 0.0 0 0
+ satwndbufr uv null uv 0.0 0 0
+ satwhrbufr uv null uv 0.0 0 0
+ prepbufr spd null spd 0.0 0 0
+ prepbufr dw null dw 0.0 0 0
+ radarbufr rw null rw 0.0 0 0
+ prepbufr sst null sst 0.0 0 0
+ tcvitl tcp null tcp 0.0 0 0
+ tldplrbufr rw null rw 0.0 0 0
+ l2rwbufr rw null l2rw 0.0 0 0
+ hdobbufr uv null uv 0.0 0 0
+ hdobbufr t null t 0.0 0 0
+ hdobbufr q null q 0.0 0 0
+ hdobbufr spd null spd 0.0 0 0
+ gpsrobufr gps_bnd null gps 0.0 0 0
+ ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
+ tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
+ sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
+ sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
+ sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
+ gimgrbufr goes_img g11 imgr_g11 0.0 1 0
+ gimgrbufr goes_img g12 imgr_g12 0.0 1 0
+ airsbufr airs aqua airs_aqua 0.0 1 1
+ amsuabufr amsua n15 amsua_n15 0.0 2 1
+ amsuabufr amsua n18 amsua_n18 0.0 2 1
+ amsuabufr amsua metop-a amsua_metop-a 0.0 2 1
+ airsbufr amsua aqua amsua_aqua 0.0 2 1
+ amsubbufr amsub n17 amsub_n17 0.0 3 1
+ mhsbufr mhs n18 mhs_n18 0.0 3 1
+ mhsbufr mhs metop-a mhs_metop-a 0.0 3 1
+ ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
+ amsrebufr amsre_low aqua amsre_aqua 0.0 4 0
+ amsrebufr amsre_mid aqua amsre_aqua 0.0 4 0
+ amsrebufr amsre_hig aqua amsre_aqua 0.0 4 0
+ ssmisbufr ssmis f16 ssmis_f16 0.0 4 0
+ ssmisbufr ssmis f17 ssmis_f17 0.0 4 0
+ ssmisbufr ssmis f18 ssmis_f18 0.0 4 0
+ ssmisbufr ssmis f19 ssmis_f19 0.0 4 0
+ gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 5 0
+ gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 5 0
+ gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 5 0
+ gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 5 0
+ gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 5 0
+ gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 5 0
+ gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 5 0
+ gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 5 0
+ gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 5 0
+ gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 5 0
+ gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 5 0
+ gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 5 0
+ iasibufr iasi metop-a iasi_metop-a 0.0 1 1
+ gomebufr gome metop-a gome_metop-a 0.0 2 0
+ omibufr omi aura omi_aura 0.0 2 0
+ sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
+ amsuabufr amsua n19 amsua_n19 0.0 2 1
+ mhsbufr mhs n19 mhs_n19 0.0 3 1
+ seviribufr seviri m08 seviri_m08 0.0 1 0
+ seviribufr seviri m09 seviri_m09 0.0 1 0
+ seviribufr seviri m10 seviri_m10 0.0 1 0
+ amsuabufr amsua metop-b amsua_metop-b 0.0 2 0
+ mhsbufr mhs metop-b mhs_metop-b 0.0 3 0
+ iasibufr iasi metop-b iasi_metop-b 0.0 1 0
+ gomebufr gome metop-b gome_metop-b 0.0 2 0
+ atmsbufr atms npp atms_npp 0.0 2 0
+ atmsbufr atms n20 atms_n20 0.0 2 0
+ crisbufr cris npp cris_npp 0.0 1 0
+ crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0
+ crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 1 0
+ gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 5 0
+ gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 5 0
+ gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 5 0
+ gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 5 0
+ gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 5 0
+ gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 5 0
+ gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 5 0
+ gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 5 0
+ oscatbufr uv null uv 0.0 0 0
+ mlsbufr mls30 aura mls30_aura 0.0 0 0
+ amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0
+ gmibufr gmi gpm gmi_gpm 0.0 3 0
+ saphirbufr saphir meghat saphir_meghat 0.0 3 0
+ ahibufr ahi himawari8 ahi_himawari8 0.0 3 0
::
&SUPEROB_RADAR
- del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000.,
- l2superob_only=.false.,
- /
+ del_azimuth=5.,del_elev=.25,del_range=10000.,del_time=1.0,elev_angle_max=5.,minnum=1,range_max=200000.,
+ l2superob_only=.false.,radar_sites=.false.,
+ radar_box=.true.,radar_rmesh=10,radar_zmesh=500,
+ /
+SUPEROB_RADAR::
+ KBRO 1
+ KCRP 1
+ KEWX 1
+ KGRX 1
+ KDFX 1
+ KHGX 1
+ KLCH 1
+ KLIX 1
+ KPOE 1
+ KSHV 1
+ KDGX 1
+ KMOB 1
+ KEVX 1
+ KEOX 1
+ KMXX 1
+ KBMX 1
+ KTLH 1
+ KTBW 1
+ KBYX 1
+ KAMX 1
+ KMLB 1
+ KJAX 1
+ KVAX 1
+ KJGX 1
+ KFFC 1
+ KCLX 1
+ KCAE 1
+ KGSP 1
+ KLTX 1
+ KMHX 1
+ KRAX 1
+ KAKQ 1
+ KFCX 1
+ KLWX 1
+ KDOX 1
+ KCCX 1
+ KDIX 1
+ KOKX 1
+ KENX 1
+ KBGM 1
+ KCXX 1
+ KBOX 1
+ KGYX 1
+ KCBW 1
+ TJUA 1
+ PHWA 1
+ PHKI 1
+ PHMO 1
+ PHKM 1
+::
+/
&LAG_DATA
/
&HYBRID_ENSEMBLE
- l_hyb_ens=.true.,n_ens=10,uv_hyb_ens=.true.,beta_s0=0.2,
- readin_beta=.true.,
- s_ens_h=300,s_ens_v=-0.5,readin_localization=.false.,
- generate_ens=.false.,regional_ensemble_option=1,grid_ratio_ens=1,
- pseudo_hybens=.false.,merge_two_grid_ensperts=.false.,
- pwgtflg=.false.,aniso_a_en=.false.,
- nlon_ens=165,nlat_ens=335,jcap_ens=0,jcap_ens_test=0,
+ l_hyb_ens=.true.,
+ n_ens=${N_ENS},
+ uv_hyb_ens=.true.,
+ beta_s0=${BETA_S0},
+ s_ens_h=150,
+ s_ens_v=-0.5,
+ readin_localization=.false.,
+ generate_ens=.false.,
+ regional_ensemble_option=${REGIONAL_ENSEMBLE_OPTION},
+ grid_ratio_ens=${GRID_RATIO_ENS},
+ pseudo_hybens=.false.,
+ merge_two_grid_ensperts=F,
+ pwgtflg=F,
+ aniso_a_en=.false.,
+ nlon_ens=387,
+ nlat_ens=777,
+ write_ens_sprd=F,
+ l_both_fv3sar_gfs_ens=${l_both_fv3sar_gfs_ens},
+ n_ens_gfs=${n_ens_gfs},
+ n_ens_fv3sar=${n_ens_fv3sar},
/
&RAPIDREFRESH_CLDSURF
dfi_radar_latent_heat_time_period=30.0,
/
&CHEM
/
- &SINGLEOB_TEST
- maginnov=1.0,magoberr=0.8,oneob_type='t',
- oblat=38.,oblon=279.,obpres=500.,obdattim=${adate},
- obhourset=0.,
- /
&NST
/
-"
-;;
-
-hwrf_nmm_d3)
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=1,niter(2)=2,niter_no_qc(1)=20,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- gencode=78,qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
- iguess=-1,
- oneobtest=.false.,retrieval=.false.,
- nhr_assimilation=6,l_foto=.false.,
- use_pbl=.true.,use_compress=.false.,
- print_diag_pcg=.true.,
- use_gfs_stratosphere=$USE_GFS_STRATOSPHERE,
- use_gfs_ozone=$USE_GFS_OZONE,
- regional_ozone=$REGIONAL_OZONE,
- nsig_ext=12,gpstop=50.,
- $SETUP
- /
- &GRIDOPTS
- JCAP=$JCAP,JCAP_B=$JCAP_B,NLAT=$NLAT,NLON=$NLON,nsig=$LEVS,
- wrf_nmm_regional=.true.,wrf_mass_regional=.false.,
- diagnostic_reg=.true.,
- filled_grid=.false.,half_grid=.true.,netcdf=$NETCDF,
- /
- &BKGERR
- hzscl=0.2,0.4,0.8,
- vs=0.6,bw=0.,fstat=.false.,
- /
- &ANBKGERR
- anisotropic=.false.,an_vs=1.0,ngauss=1,
- an_flen_u=-5.,an_flen_t=3.,an_flen_z=-200.,
- ifilt_ord=2,npass=3,normal=-200,grid_ratio=4.,nord_f2a=4,
- /
- &JCOPTS
- /
- &STRONGOPTS
- tlnmc_option=0,reg_tlnmc_type=1,nstrong=1,nvmodes_keep=8,period_max=6.,
- period_width=1.5,baldiag_full=.false.,baldiag_inc=.false.,
- /
- &OBSQC
- dfact=0.75,dfact1=3.0,erradar_inflate=1.0,tdrerr_inflate=.true.,
- noiqc=.true.,c_varqc=0.02,vadfile='prepbufr',njqc=.false.,vqc=.true.,
- /
- &OBS_INPUT
- dmesh(1)=90.0,dmesh(2)=45.0,dmesh(3)=45.0,dmesh(4)=45.0,dmesh(5)=90,dmesh(7)=9.0,time_window_max=3.0,l_foreaft_thin=.false.,
- /
-OBS_INPUT::
-! dfile dtype dplat dsis dval dthin dsfcalc
- prepbufr ps null ps 0.0 0 0
- prepbufr t null t 0.0 0 0
- prepbufr q null q 0.0 0 0
- prepbufr pw null pw 0.0 0 0
- prepbufr uv null uv 0.0 0 0
- satwndbufr uv null uv 0.0 0 0
- prepbufr spd null spd 0.0 0 0
- prepbufr dw null dw 0.0 0 0
- radarbufr rw null rw 0.0 0 0
- prepbufr sst null sst 0.0 0 0
- tcvitl tcp null tcp 0.0 0 0
- tldplrbufr rw null rw 0.0 7 0
- hdobbufr uv null uv 0.0 0 0
- hdobbufr t null t 0.0 0 0
- hdobbufr q null q 0.0 0 0
- hdobbufr spd null spd 0.0 0 0
- gpsrobufr gps_bnd null gps 0.0 0 0
- ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
- tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
- sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
- sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
- sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
-::
- &SUPEROB_RADAR
- del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000.,
- l2superob_only=.false.,
- /
- &LAG_DATA
- /
- &HYBRID_ENSEMBLE
- l_hyb_ens=.true.,n_ens=10,uv_hyb_ens=.true.,beta_s0=0.2,
- readin_beta=.true.,
- s_ens_h=150,s_ens_v=-0.5,readin_localization=.false.,
- generate_ens=.false.,regional_ensemble_option=1,grid_ratio_ens=1,
- pseudo_hybens=.false.,merge_two_grid_ensperts=.false.,
- pwgtflg=.false.,aniso_a_en=.false.,
- nlon_ens=249,nlat_ens=499,jcap_ens=0,jcap_ens_test=0,
- /
- &RAPIDREFRESH_CLDSURF
- dfi_radar_latent_heat_time_period=30.0,
- /
- &CHEM
- /
&SINGLEOB_TEST
maginnov=1.0,magoberr=0.8,oneob_type='t',
- oblat=38.,oblon=279.,obpres=500.,obdattim=${adate},
+ oblat=38.,oblon=279.,obpres=500.,obdattim=2020040500,
obhourset=0.,
/
- &NST
- /
"
;;
diff --git a/regression/regression_param.sh b/regression/regression_param.sh
index 85f2949bfe..bfc6f042fc 100755
--- a/regression/regression_param.sh
+++ b/regression/regression_param.sh
@@ -9,15 +9,25 @@ case $machine in
memnode=96
numcore=40
;;
- Orion)
+ Orion)
sub_cmd="sub_orion"
memnode=192
numcore=40
+ ;;
+ Hercules)
+ sub_cmd="sub_hercules"
+ memnode=512
+ numcore=40
;;
Jet)
sub_cmd="sub_jet"
memnode=96
numcore=40
+ ;;
+ Gaea)
+ sub_cmd="sub_gaea"
+ memnode=251
+ numcore=128
;;
wcoss2)
sub_cmd="sub_wcoss2"
@@ -26,9 +36,6 @@ case $machine in
;;
Discover)
sub_cmd="sub_discover"
- ;;
- Cheyenne)
- sub_cmd="sub_ncar -a p48503002 -q economy -d $PWD"
;;
*) # EXIT out for unresolved machine
echo "unknown $machine"
@@ -44,144 +51,148 @@ export maxmem=$((($memnode*1024*1024)/$numcore)) # Kb / core
case $regtest in
- global_3dvar)
+ global_4denvar)
if [[ "$machine" = "Hera" ]]; then
- topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2"
+ topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1"
+ topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2"
elif [[ "$machine" = "Orion" ]]; then
- topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2"
+ topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1"
+ topts[2]="0:10:00" ; popts[2]="12/12/" ; ropts[2]="/2"
+ elif [[ "$machine" = "Hercules" ]]; then
+ topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1"
+ topts[2]="0:10:00" ; popts[2]="12/12/" ; ropts[2]="/2"
elif [[ "$machine" = "Jet" ]]; then
- topts[1]="0:50:00" ; popts[1]="12/3/" ; ropts[1]="/1"
- topts[2]="0:50:00" ; popts[2]="12/9/" ; ropts[2]="/2"
- elif [[ "$machine" = "Cheyenne" ]]; then
- topts[1]="0:30:00" ; popts[1]="16/2/" ; ropts[1]="/1"
- topts[2]="0:30:00" ; popts[2]="16/4/" ; ropts[2]="/2"
- elif [[ "$machine" = "wcoss2" ]]; then
- topts[1]="0:15:00" ; popts[1]="12/5/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="12/9/" ; ropts[2]="/2"
+ topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1"
+ topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2"
elif [[ "$machine" = "Discover" ]]; then
- topts[1]="0:30:00" ; popts[1]="36/2" ; ropts[1]="/1"
- topts[2]="0:30:00" ; popts[2]="72/3" ; ropts[2]="/2"
+ topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1"
+ topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2"
+ elif [[ "$machine" = "Gaea" ]]; then
+ topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1"
+ topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2"
+ elif [[ "$machine" = "wcoss2" ]]; then
+ topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1"
+ topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2"
fi
if [ "$debug" = ".true." ] ; then
- topts[1]="0:45:00"
+ topts[1]="1:30:00"
fi
scaling[1]=10; scaling[2]=8; scaling[3]=4
;;
- global_4dvar)
+ rrfs_3denvar_rdasens)
if [[ "$machine" = "Hera" ]]; then
- topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2"
+ topts[1]="0:05:00" ; popts[1]="40/3/" ; ropts[1]="/1"
+ topts[2]="0:05:00" ; popts[2]="40/5/" ; ropts[2]="/1"
elif [[ "$machine" = "Orion" ]]; then
- topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2"
+ topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2"
+ elif [[ "$machine" = "Hercules" ]]; then
+ topts[1]="0:05:00" ; popts[1]="40/3/" ; ropts[1]="/1"
+ topts[2]="0:05:00" ; popts[2]="40/5/" ; ropts[2]="/2"
elif [[ "$machine" = "Jet" ]]; then
- topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2"
- elif [[ "$machine" = "Cheyenne" ]]; then
- topts[1]="0:35:00" ; popts[1]="16/2/" ; ropts[1]="/1"
- topts[2]="0:25:00" ; popts[2]="16/4/" ; ropts[2]="/2"
+ topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1"
+ elif [[ "$machine" = "Gaea" ]]; then
+ topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1"
elif [[ "$machine" = "wcoss2" ]]; then
- topts[1]="0:15:00" ; popts[1]="28/2/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="28/4/" ; ropts[2]="/2"
- elif [[ "$machine" = "Discover" ]]; then
- topts[1]="2:00:00" ; popts[1]="48/2" ; ropts[1]="/1"
- topts[2]="2:00:00" ; popts[2]="60/3" ; ropts[2]="/2"
+ topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1"
fi
if [ "$debug" = ".true." ] ; then
- topts[1]="0:45:00"
- if [[ "$machine" = "Hera" ]]; then
- popts[1]="12/5/"
- elif [[ "$machine" = "Orion" ]]; then
- popts[1]="12/5/"
- elif [[ "$machine" = "Jet" ]]; then
- popts[1]="12/5/"
- elif [[ "$machine" = "wcoss2" ]]; then
- popts[1]="28/4/"
- topts[1]="3:00:00"
- fi
+ topts[1]="0:30:00"
fi
- scaling[1]=5; scaling[2]=8; scaling[3]=2
+ scaling[1]=2; scaling[2]=10; scaling[3]=4
;;
- global_4denvar)
+ hafs_3denvar_hybens)
if [[ "$machine" = "Hera" ]]; then
- topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1"
- topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2"
+ topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1"
elif [[ "$machine" = "Orion" ]]; then
- topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1"
- topts[2]="0:10:00" ; popts[2]="12/12/" ; ropts[2]="/2"
+ topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2"
+ elif [[ "$machine" = "Hercules" ]]; then
+ topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="5/8/" ; ropts[2]="/2"
elif [[ "$machine" = "Jet" ]]; then
- topts[1]="0:35:00" ; popts[1]="6/8/" ; ropts[1]="/1"
- topts[2]="0:35:00" ; popts[2]="6/10/" ; ropts[2]="/2"
- elif [[ "$machine" = "Discover" ]]; then
- topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1"
- topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2"
- elif [[ "$machine" = "Cheyenne" ]]; then
- topts[1]="1:59:00" ; popts[1]="6/8/" ; ropts[1]="/1"
- topts[2]="0:35:00" ; popts[2]="6/10/" ; ropts[2]="/2"
+ topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1"
+ elif [[ "$machine" = "Gaea" ]]; then
+ topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1"
elif [[ "$machine" = "wcoss2" ]]; then
- topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1"
- topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2"
+ topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1"
fi
if [ "$debug" = ".true." ] ; then
- topts[1]="1:30:00"
+ topts[1]="0:30:00"
fi
- scaling[1]=10; scaling[2]=8; scaling[3]=4
+ scaling[1]=2; scaling[2]=10; scaling[3]=4
;;
- rrfs_3denvar_glbens)
-
+ hafs_4denvar_glbens)
if [[ "$machine" = "Hera" ]]; then
- topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1"
+ topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1"
elif [[ "$machine" = "Orion" ]]; then
- topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1"
+ topts[1]="0:20:00" ; popts[1]="5/4/" ; ropts[1]="/1"
+ topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1"
+ elif [[ "$machine" = "Hercules" ]]; then
+ topts[1]="0:20:00" ; popts[1]="5/4/" ; ropts[1]="/1"
+ topts[2]="0:20:00" ; popts[2]="10/4/" ; ropts[2]="/1"
elif [[ "$machine" = "Jet" ]]; then
- topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1"
+ topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1"
+ elif [[ "$machine" = "Gaea" ]]; then
+ topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1"
elif [[ "$machine" = "wcoss2" ]]; then
topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1"
topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1"
fi
if [ "$debug" = ".true." ] ; then
- topts[1]="0:30:00"
+ topts[1]="0:45:00"
fi
- scaling[1]=2; scaling[2]=10; scaling[3]=4
+ scaling[1]=10; scaling[2]=8; scaling[3]=4
;;
- netcdf_fv3_regional)
+ rrfs_enkf_conv)
if [[ "$machine" = "Hera" ]]; then
- topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1"
+ topts[1]="0:05:00" ; popts[1]="40/2/" ; ropts[1]="/1"
+ topts[2]="0:05:00" ; popts[2]="40/4/" ; ropts[2]="/1"
elif [[ "$machine" = "Orion" ]]; then
- topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1"
+ topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1"
+ elif [[ "$machine" = "Hercules" ]]; then
+ topts[1]="0:05:00" ; popts[1]="40/2/" ; ropts[1]="/1"
+ topts[2]="0:05:00" ; popts[2]="40/4/" ; ropts[2]="/1"
elif [[ "$machine" = "Jet" ]]; then
- topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1"
+ topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1"
+ elif [[ "$machine" = "Gaea" ]]; then
+ topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1"
elif [[ "$machine" = "wcoss2" ]]; then
- topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1"
+ topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="64/2/" ; ropts[2]="/1"
fi
if [ "$debug" = ".true." ] ; then
@@ -195,17 +206,20 @@ case $regtest in
rtma)
if [[ "$machine" = "Hera" ]]; then
- topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1"
- topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1"
+ topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1"
+ topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1"
elif [[ "$machine" = "Orion" ]]; then
- topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1"
- topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1"
+ topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1"
+ topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1"
+ elif [[ "$machine" = "Hercules" ]]; then
+ topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1"
+ topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1"
elif [[ "$machine" = "Jet" ]]; then
- topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1"
- topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1"
- elif [[ "$machine" = "Cheyenne" ]]; then
- topts[1]="0:15:00" ; popts[1]="8/6/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="8/8/" ; ropts[2]="/1"
+ topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1"
+ topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1"
+ elif [[ "$machine" = "Gaea" ]]; then
+ topts[1]="0:30:00" ; popts[1]="14/8/" ; ropts[1]="/1"
+ topts[2]="0:30:00" ; popts[2]="14/14/" ; ropts[2]="/1"
elif [[ "$machine" = "wcoss2" ]]; then
topts[1]="0:30:00" ; popts[1]="14/8/" ; ropts[1]="/1"
topts[2]="0:30:00" ; popts[2]="14/14/" ; ropts[2]="/2"
@@ -219,47 +233,23 @@ case $regtest in
;;
- hwrf_nmm_d2 | hwrf_nmm_d3)
-
- if [[ "$machine" = "Hera" ]]; then
- topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1"
- topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1"
- elif [[ "$machine" = "Orion" ]]; then
- topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1"
- topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1"
- elif [[ "$machine" = "Jet" ]]; then
- topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1"
- topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1"
- elif [[ "$machine" = "Cheyenne" ]]; then
- topts[1]="0:20:00" ; popts[1]="6/6/" ; ropts[1]="/1"
- topts[2]="0:20:00" ; popts[2]="8/8/" ; ropts[2]="/1"
- elif [[ "$machine" = "wcoss2" ]]; then
- topts[1]="0:15:00" ; popts[1]="10/10/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="14/14/" ; ropts[2]="/2"
- fi
-
- if [ "$debug" = ".true." ] ; then
- topts[1]="1:00:00"
- fi
-
- scaling[1]=5; scaling[2]=10; scaling[3]=2
-
- ;;
-
global_enkf)
if [[ "$machine" = "Hera" ]]; then
- topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1"
- topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2"
+ topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1"
+ topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2"
elif [[ "$machine" = "Orion" ]]; then
- topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1"
- topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2"
+ topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1"
+ topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2"
+ elif [[ "$machine" = "Hercules" ]]; then
+ topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1"
+ topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2"
elif [[ "$machine" = "Jet" ]]; then
- topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2"
- elif [[ "$machine" = "Cheyenne" ]]; then
- topts[1]="0:15:00" ; popts[1]="16/2/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="16/4/" ; ropts[2]="/2"
+ topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1"
+ topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2"
+ elif [[ "$machine" = "Gaea" ]]; then
+ topts[1]="0:10:00" ; popts[1]="16/2/" ; ropts[1]="/1"
+ topts[2]="0:10:00" ; popts[2]="16/4/" ; ropts[2]="/2"
elif [[ "$machine" = "wcoss2" ]]; then
topts[1]="0:10:00" ; popts[1]="16/2/" ; ropts[1]="/1"
topts[2]="0:10:00" ; popts[2]="16/4/" ; ropts[2]="/2"
@@ -310,19 +300,22 @@ if [[ "$machine" = "Hera" ]]; then
export APRUN="srun"
elif [[ "$machine" = "Orion" ]]; then
export OMP_STACKSIZE=2048M
- export APRUN="srun -n \$ntasks"
+ export APRUN="srun -n \$ntasks --mem=0 --cpus-per-task=\$threads"
+elif [[ "$machine" = "Hercules" ]]; then
+ export OMP_STACKSIZE=2048M
+ export APRUN="srun -n \$ntasks --mem=0 --cpus-per-task=\$threads"
elif [[ "$machine" = "Jet" ]]; then
export OMP_STACKSIZE=1024M
export MPI_BUFS_PER_PROC=256
export MPI_BUFS_PER_HOST=256
export MPI_GROUP_MAX=256
- export APRUN="srun"
-elif [[ "$machine" = "Cheyenne" ]]; then
+ export APRUN="srun -n \$ntasks --cpus-per-task=\$threads"
+elif [[ "$machine" = "Gaea" ]]; then
export OMP_STACKSIZE=1024M
export MPI_BUFS_PER_PROC=256
export MPI_BUFS_PER_HOST=256
export MPI_GROUP_MAX=256
- export APRUN="mpirun -v -np \$NCPUS"
+ export APRUN="srun --export=ALL -n \$ntasks"
elif [[ "$machine" = "wcoss2" ]]; then
export OMP_PLACES=cores
export OMP_STACKSIZE=2G
diff --git a/regression/regression_test.sh b/regression/regression_test.sh
index deb34ff244..263761052a 100755
--- a/regression/regression_test.sh
+++ b/regression/regression_test.sh
@@ -33,7 +33,6 @@ cd $tmpdir
# Other required constants for regression testing
maxtime=1200
-maxmem=${maxmem:-3400000} # set in regression_param
# Copy stdout and fort.220 files
# from $savdir to $tmpdir
@@ -182,24 +181,6 @@ fi
} >> $output
- # Next, maximum residence set size (both harware limitation and percent difference)
- # First, hardware limitation
-
- {
-
- if [[ $(awk '{ print $8 }' memory.$exp1.txt) -gt $maxmem ]]; then
- echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs. This has exceeded maximum allowable hardware memory limit of '$maxmem' KBs,'
- echo 'resulting in Failure maxmem of the regression test.'
- echo
- failed_test=1
- else
- echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs and is within the maximum allowable hardware memory limit of '$maxmem' KBs,'
- echo 'continuing with regression test.'
- echo
- fi
-
- } >> $output
-
# Next, maximum residence set size
{
@@ -348,7 +329,7 @@ fi
} >> $output
fi
- elif [[ `expr substr $exp1 1 4` = "rrfs" ]]; then
+ elif [[ `expr substr $exp1 1 4` = "rrfs" ]] || [[ `expr substr $exp1 1 4` = "hafs" ]]; then
{
fv3_failed_test=0
if cmp -s fv3_dynvars.${exp1} fv3_dynvars.${exp2}
@@ -520,7 +501,7 @@ elif [[ `expr substr $exp1 1 6` = "global" ]]; then
fi
-elif [[ `expr substr $exp1 1 4` = "rrfs" ]]; then
+elif [[ `expr substr $exp1 1 4` = "rrfs" ]] || [[ `expr substr $exp1 1 4` = "hafs" ]]; then
{
fv3_failed_test=0
if cmp -s fv3_dynvars.${exp1} fv3_dynvars.${exp3}
@@ -556,31 +537,25 @@ elif [[ `expr substr $exp1 1 4` = "rrfs" ]]; then
fi
- # Finally, scalability
-
- {
-
- timelogic=$( echo "$scale1thresh >= $scale2" | bc )
- if [[ "$timelogic" = 1 ]]; then
- echo 'The case has passed the scalability regression test.'
- echo 'The slope for the update ('$scale1thresh' seconds per node) is greater than or equal to that for the control ('$scale2' seconds per node).'
- else
- echo 'The case has Failed the scalability test.'
- echo 'The slope for the update ('$scale1thresh' seconds per node) is less than that for the control ('$scale2' seconds per node).'
- fi
-
- } >> $output
-
# Copy select results to $savdir
mkdir -p $vfydir
$ncp $output $vfydir/
+# Final check for any failed tests
+count=$(grep -i "fail" $output |wc -l)
+if [ $count -gt 0 ]; then
+ (( failed_test = $failed_test + $count ))
+fi
+
+# Remove job log files is no failures detected
cd $scripts
-rm -f ${exp1}.out
-rm -f ${exp2}.out
-rm -f ${exp3}.out
-rm -f ${exp2_scale}.out
+if [ $count -eq 0 ]; then
+ rm -f ${exp1}.out
+ rm -f ${exp2}.out
+ rm -f ${exp3}.out
+ rm -f ${exp2_scale}.out
+fi
if [[ "$clean" = ".true." ]]; then
rm -rf $savdir
diff --git a/regression/regression_test_enkf.sh b/regression/regression_test_enkf.sh
index 213ee726da..ac839631c2 100755
--- a/regression/regression_test_enkf.sh
+++ b/regression/regression_test_enkf.sh
@@ -31,22 +31,34 @@ cd $tmpdir
# Other required constants for regression testing
maxtime=1200
-maxmem=${maxmem:-3400000} # set in regression_param
-maxmem=$((${memnode:-64}*1024*1024))
-# Copy stdout and sanl files
+# Copy stdout and incr files
# from $savdir to $tmpdir
list="$exp1 $exp2 $exp3"
-for exp in $list; do
- $ncp $savdir/$exp/stdout ./stdout.$exp
- nmem=10
- imem=1
- while [[ $imem -le $nmem ]]; do
- member="_mem"`printf %03i $imem`
- $ncp $savdir/$exp/sanl_${global_adate}_fhr06$member $tmpdir/sanl$member.$exp
- (( imem = $imem + 1 ))
+if [[ $(expr substr $exp1 1 4) = "rrfs" ]]; then
+ for exp in $list; do
+ $ncp $savdir/$exp/stdout ./stdout.$exp
+ nmem=5
+ imem=1
+ while [[ $imem -le $nmem ]]; do
+ member="_mem"`printf %03i $imem`
+ $ncp $savdir/$exp/fv3sar_tile1_mem${member}_dynvars $tmpdir/dynvars$member.$exp
+ $ncp $savdir/$exp/fv3sar_tile1_mem${member}_tracer $tmpdir/tracer$member.$exp
+ (( imem = $imem + 1 ))
+ done
done
-done
+else
+ for exp in $list; do
+ $ncp $savdir/$exp/stdout ./stdout.$exp
+ nmem=10
+ imem=1
+ while [[ $imem -le $nmem ]]; do
+ member="_mem"`printf %03i $imem`
+ $ncp $savdir/$exp/incr_${global_adate}_fhr06$member $tmpdir/incr$member.$exp
+ (( imem = $imem + 1 ))
+ done
+ done
+fi
# Grep out ensemble mean increment information, run time, and maximum resident memory from stdout file
list="$exp1 $exp2 $exp3"
@@ -177,20 +189,6 @@ fi
# Next, maximum residence set size (both harware limitation and percent difference)
# First, hardware limitation
- {
-
- if [[ $(awk '{ print $8 }' memory.$exp1.txt) -gt $maxmem ]]; then
- echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs. This has exceeded maximum allowable hardware memory limit of '$maxmem' KBs,'
- echo 'resulting in Failure maxmem of the regression test.'
- echo
- failed_test=1
- else
- echo 'The memory for '$exp1' is '$(awk '{ print $8 }' memory.$exp1.txt)' KBs and is within the maximum allowable hardware memory limit of '$maxmem' KBs,'
- echo 'continuing with regression test.'
- echo
- fi
-
- } >> $output
# Next, maximum residence set size
@@ -239,16 +237,36 @@ fi
# Next, check reproducibility of results between exp1 and exp2
-if [[ `expr substr $exp1 1 4` = "rtma" ]]; then
+if [[ $(expr substr $exp1 1 4) = "rrfs" ]]; then
{
-if cmp -s siganl.${exp1} siganl.${exp2}
-then
- echo 'The results between the two runs ('${exp1}' and '${exp2}') are reproducible'
- echo 'since the corresponding results are identical.'
- echo
-fi
+nmem=5
+imem=1
+while [[ $imem -le $nmem ]]; do
+ member="_mem"`printf %03i $imem`
+ ncdump dynvars$member.${exp1} > dynvars$member.${exp1}.out
+ ncdump dynvars$member.${exp2} > dynvars$member.${exp2}.out
+ if [ ! diff dynvars$member.${exp1}.out dynvars$member.${exp2}.out ]; then
+ echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp2}' are NOT identical'
+ failed_test=1
+ else
+ rm -f dynvars$member.${exp1}.out dynvars$member.${exp2}.out
+ echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp2}' are identical'
+ fi
+ ncdump tracer$member.${exp1} > tracers$member.${exp1}.out
+ ncdump tracer$member.${exp2} > tracers$member.${exp2}.out
+ if [ ! diff tracers$member.${exp1}.out tracers$member.${exp2}.out ]; then
+ echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp2}' are NOT identical'
+ failed_test=1
+ else
+ rm -f tracers$member.${exp1}.out tracers$member.${exp2}.out
+ echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp2}' are identical'
+ q
+ fi
+ (( imem = $imem + 1 ))
+done
+echo
} >> $output
@@ -282,10 +300,13 @@ nmem=10
imem=1
while [[ $imem -le $nmem ]]; do
member="_mem"`printf %03i $imem`
- if ! cmp -s sanl$member.${exp1} sanl$member.${exp2}
-then
- echo 'sanl'$member'.'${exp1}' sanl'$member'.'${exp2}' are NOT identical'
-fi
+ ncdump incr$member.${exp1} > incr$member.${exp1}.out
+ ncdump incr$member.${exp2} > incr$member.${exp2}.out
+ if [ ! diff incr$member.${exp1}.out incr$member.${exp2}.out ]; then
+ echo 'incr'$member'.'${exp1}' incr'$member'.'${exp2}' are NOT identical'
+ else
+ rm -f incr$member.${exp1}.out incr$member.${exp2}.out
+ fi
(( imem = $imem + 1 ))
done
echo
@@ -334,16 +355,35 @@ else
# Next, check reproducibility of results between exp1 and exp3
- if [[ `expr substr $exp1 1 4` = "rtma" ]]; then
+ if [[ $(expr substr $exp1 1 4) = "rrfs" ]]; then
{
- if cmp -s wrf_inout.${exp1} wrf_inout.${exp3}
- then
- echo 'The results between the two runs ('${exp1}' and '${exp3}') are reproducible'
- echo 'since the corresponding results are identical.'
- echo
- fi
+ nmem=5
+ imem=1
+ while [[ $imem -le $nmem ]]; do
+ member="_mem"`printf %03i $imem`
+ ncdump dynvars$member.${exp1} > dynvars$member.${exp1}.out
+ ncdump dynvars$member.${exp3} > dynvars$member.${exp3}.out
+ if [ ! diff dynvars$member.${exp1}.out dynvars$member.${exp3}.out ]; then
+ echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp3}' are NOT identical'
+ failed_test=1
+ else
+ rm -f dynvars$member.${exp1}.out dynvars$member.${exp3}.out
+ echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp3}' are identical'
+ fi
+ ncdump tracer$member.${exp1} > tracers$member.${exp1}.out
+ ncdump tracer$member.${exp3} > tracers$member.${exp3}.out
+ if [ ! diff tracers$member.${exp1}.out tracers$member.${exp3}.out ]; then
+ echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp3}' are NOT identical'
+ failed_test=1
+ else
+ rm -f tracers$member.${exp1}.out tracers$member.${exp3}.out
+ echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp3}' are identical'
+ fi
+ (( imem = $imem + 1 ))
+ done
+ echo
} >> $output
@@ -379,11 +419,14 @@ else
imem=1
while [[ $imem -le $nmem ]]; do
member="_mem"`printf %03i $imem`
- if ! cmp -s sanl$member.${exp1} sanl$member.${exp3}
- then
- echo 'sanl'$member'.'${exp1}' sanl'$member'.'${exp3}' are NOT identical'
+ ncdump incr$member.${exp1} > incr$member.${exp1}.out
+ ncdump incr$member.${exp3} > incr$member.${exp3}.out
+ if [ ! diff incr$member.${exp1}.out incr$member.${exp3}.out ]; then
+ echo 'incr'$member'.'${exp1}' incr'$member'.'${exp3}' are NOT identical'
+ else
+ rm -f incr$member.${exp1}.out incr$member.${exp3}.out
fi
- (( imem = $imem + 1 ))
+ (( imem = $imem + 1 ))
done
echo
} >> $output
@@ -391,31 +434,25 @@ else
fi
fi
- # Finally, scalability
-
- {
-
- timelogic=$( echo "$scale1thresh >= $scale2" | bc )
- if [[ "$timelogic" = 1 ]]; then
- echo 'The case has passed the scalability regression test.'
- echo 'The slope for the update ('$scale1thresh' seconds per node) is greater than or equal to that for the control ('$scale2' seconds per node).'
- else
- echo 'The case has Failed the scalability test.'
- echo 'The slope for the update ('$scale1thresh' seconds per node) is less than that for the control ('$scale2' seconds per node).'
- fi
-
- } >> $output
-
# Copy select results to $savdir
mkdir -p $vfydir
$ncp $output $vfydir/
+# Final check for any failed tests
+count=$(grep -i "fail" $output |wc -l)
+if [ $count -gt 0 ]; then
+ (( failed_test = $failed_test + $count ))
+fi
+
+# Remove job log files is no failures detected
cd $scripts
-rm -f ${exp1}.out
-rm -f ${exp2}.out
-rm -f ${exp3}.out
-rm -f ${exp2_scale}.out
+if [ $count -eq 0 ]; then
+ rm -f ${exp1}.out
+ rm -f ${exp2}.out
+ rm -f ${exp3}.out
+ rm -f ${exp2_scale}.out
+fi
if [[ "$clean" = ".true." ]]; then
rm -rf $savdir
diff --git a/regression/regression_var.sh b/regression/regression_var.sh
index 250317f405..4a2bc85874 100755
--- a/regression/regression_var.sh
+++ b/regression/regression_var.sh
@@ -14,6 +14,7 @@ if [ "$#" = 7 ] ; then
export enkfexec_contrl=$7
export fixgsi="$gsisrc/fix"
export scripts="$gsisrc/regression"
+ export modulefiles="$gsisrc/modulefiles"
export ush="$gsisrc/ush"
export cmaketest="true"
export clean="false"
@@ -29,40 +30,38 @@ else
fi
# Determine the machine
-if [[ -d /glade ]]; then # Cheyenne
- export machine="Cheyenne"
-elif [[ -d /scratch1 ]]; then # Hera
+if [[ -d /scratch1 ]]; then # Hera
export machine="Hera"
-elif [[ -d /jetmon ]]; then # Jet
+elif [[ -d /mnt/lfs4 || -d /jetmon || -d /mnt/lfs5 ]]; then # Jet
export machine="Jet"
elif [[ -d /discover ]]; then # NCCS Discover
export machine="Discover"
-elif [[ -d /sw/gaea ]]; then # Gaea
+elif [[ -d /ncrc ]]; then # Gaea
export machine="Gaea"
elif [[ -d /data/prod ]]; then # S4
export machine="S4"
-elif [[ -d /work ]]; then # Orion
- export machine="Orion"
+elif [[ -d /work ]]; then # Orion or Hercules
+ mount=$(findmnt -n -o SOURCE /home)
+ if [[ ${mount} =~ "hercules" ]]; then
+ export machine="Hercules"
+ else
+ export machine="Orion"
+ fi
elif [[ -d /lfs/h2 ]]; then # wcoss2
export machine="wcoss2"
fi
echo "Running Regression Tests on '$machine'";
case $machine in
- Cheyenne)
- export queue="economy"
- export noscrub="/glade/scratch/$LOGNAME"
- export group="global"
- if [[ "$cmaketest" = "false" ]]; then
- export basedir="/glade/scratch/$LOGNAME/gsi"
- fi
- export ptmp="/glade/scratch/$LOGNAME/$ptmpName"
-
- export fixcrtm="/glade/p/ral/jntp/tools/crtm/2.2.3/fix_update"
- export casesdir="/glade/p/ral/jntp/tools/CASES"
+ Gaea)
+ export queue="normal"
+ export group="ufs-ard"
+ export noscrub="/gpfs/f5/${group}/scratch/${USER}/$LOGNAME/gsi_tmp/noscrub"
+ export ptmp="/gpfs/f5/${group}/scratch/${USER}/$LOGNAME/gsi_tmp/ptmp"
+ export casesdir="/gpfs/f5/ufs-ard/world-shared/GSI_data/CASES/regtest"
export check_resource="no"
- export accnt="p48503002"
+ export accnt="ufs-ard"
;;
wcoss2)
export local_or_default="${local_or_default:-/lfs/h2/emc/da/noscrub/$LOGNAME}"
@@ -84,22 +83,28 @@ case $machine in
export check_resource="no"
export accnt="${accnt:-GFS-DEV}"
;;
- Orion)
+ Orion | Hercules)
export local_or_default="${local_or_default:-/work/noaa/da/$LOGNAME}"
if [ -d $local_or_default ]; then
- export noscrub="$local_or_default/noscrub"
+ export noscrub="$local_or_default/noscrub"
elif [ -d /work/noaa/global/$LOGNAME ]; then
- export noscrub="/work/noaa/global/$LOGNAME/noscrub"
+ export noscrub="/work/noaa/global/$LOGNAME/noscrub"
fi
export queue="${queue:-batch}"
+
+ if [[ "${machine}" == "Orion" ]]; then
+ export partition="${partition:-orion}"
+ else
+ export partition="${partition:-hercules}"
+ fi
+
export group="${group:-global}"
if [[ "$cmaketest" = "false" ]]; then
- export basedir="/work/noaa/da/$LOGNAME/gsi"
+ export basedir="/work/noaa/da/$LOGNAME/gsi"
fi
export ptmp="${ptmp:-/work/noaa/stmp/$LOGNAME/$ptmpName}"
- export fixcrtm=${CRTM_FIX:-/apps/contrib/NCEPLIBS/orion/fix/crtm_v2.3.0}
export casesdir="/work/noaa/da/rtreadon/CASES/regtest"
export check_resource="no"
@@ -124,7 +129,6 @@ case $machine in
export ptmp="${ptmp:-/scratch1/NCEPDEV/stmp2/$LOGNAME/$ptmpName}"
-## export fixcrtm="${CRTM_FIX:-/scratch1/NCEPDEV/da/Michael.Lueken/CRTM_REL-2.2.3/crtm_v2.2.3/fix_update}"
export casesdir="/scratch1/NCEPDEV/da/Russ.Treadon/CASES/regtest"
export check_resource="no"
@@ -136,21 +140,18 @@ case $machine in
;;
Jet)
- export noscrub=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/noscrub
- export ptmp=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/ptmp
- export fixcrtm="/lfs1/NESDIS/nesdis-rdo2/David.Huber/save/CRTM_REL-2.2.3/crtm_v2.2.3/fix_update"
- export casesdir="/lfs1/NESDIS/nesdis-rdo2/David.Huber/save/CASES"
+ export noscrub=/lfs5/NESDIS/nesdis-rdo2/$LOGNAME/noscrub
+ export ptmp=/lfs5/NESDIS/nesdis-rdo2/$LOGNAME/ptmp
+ export casesdir="/lfs5/NESDIS/nesdis-rdo2/David.Huber/save/CASES/regtest"
export check_resource="no"
export accnt="nesdis-rdo2"
export group="global"
export queue="batch"
if [[ "$cmaketest" = "false" ]]; then
- export basedir="/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/gsi"
+ export basedir="/lfs5/NESDIS/nesdis-rdo2/$LOGNAME/save/git/gsi"
fi
- export ptmp="/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/ptmp/$ptmpName"
-
# On Jet, there are no scrubbers to remove old contents from stmp* directories.
# After completion of regression tests, will remove the regression test subdirecories
export clean=".true."
@@ -163,7 +164,6 @@ case $machine in
export ptmp=$basedir
export ptmp=$basedir
export noscrub=$basedir
- export fixcrtm="/discover/nobackup/projects/gmao/share/gmao_ops/fvInput_4dvar/gsi/etc/fix_ncep20170329/REL-2.2.3-r60152_local-rev_1/CRTM_Coeffs/$endianness"
export casesdir="/discover/nobackup/projects/gmao/obsdev/wrmccart/NCEP_regression/CASES"
export check_resource="no"
export accnt="g0613"
@@ -176,18 +176,6 @@ case $machine in
;;
esac
-if [[ "$cmaketest" = "false" ]]; then
- export builddir=$noscrub/build
- export gsisrc="$basedir/$updat/src"
- export gsiexec_updat="$gsisrc/global_gsi.x"
- export gsiexec_contrl="$basedir/$contrl/src/global_gsi.x"
- export enkfexec_updat="$gsisrc/enkf/global_enkf.x"
- export enkfexec_contrl="$basedir/$contrl/src/enkf/global_enkf.x"
- export fixgsi="$basedir/$updat/fix"
- export scripts="$basedir/$updat/regression"
- export ush="$basedir/$updat/ush"
-fi
-
# We are dealing with *which* endian files
export endianness="Big_Endian"
@@ -201,23 +189,25 @@ export savdir="$ptmp"
export JCAP="62"
# Case Study analysis dates
-export global_adate="2022110900"
+export global_adate="2024022300"
export rtma_adate="2020022420"
-export hwrf_nmm_adate="2012102812"
-export fv3_netcdf_adate="2017030100"
-export rrfs_3denvar_glbens_adate="2021072518"
+export rrfs_enkf_adate="2023061012"
+export rrfs_3denvar_rdasens_adate="2023061012"
+export hafs_envar_adate="2020082512"
# Paths for canned case data.
export global_data="$casesdir/gfs/prod"
export rtma_obs="$casesdir/regional/rtma_binary/$rtma_adate"
export rtma_ges="$casesdir/regional/rtma_binary/$rtma_adate"
-export hwrf_nmm_obs="$casesdir/regional/hwrf_nmm/$hwrf_nmm_adate"
-export hwrf_nmm_ges="$casesdir/regional/hwrf_nmm/$hwrf_nmm_adate"
-export fv3_netcdf_obs="$casesdir/regional/fv3_netcdf/$fv3_netcdf_adate"
-export fv3_netcdf_ges="$casesdir/regional/fv3_netcdf/$fv3_netcdf_adate"
-export rrfs_3denvar_glbens_obs="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/obs"
-export rrfs_3denvar_glbens_ges="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/ges"
-export rrfs_3denvar_glbens_ens="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/ens"
+export rrfs_enkf_diag="$casesdir/regional/rrfs/$rrfs_enkf_adate/diag"
+export rrfs_enkf_ges="$casesdir/regional/rrfs/$rrfs_enkf_adate/ens"
+export rrfs_3denvar_rdasens_obs="$casesdir/regional/rrfs/$rrfs_3denvar_rdasens_adate/obs"
+export rrfs_3denvar_rdasens_ges="$casesdir/regional/rrfs/$rrfs_3denvar_rdasens_adate/ges"
+export rrfs_3denvar_rdasens_ens="$casesdir/regional/rrfs/$rrfs_3denvar_rdasens_adate/ens"
+export hafs_envar_obs="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/obs"
+export hafs_envar_ges="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/ges"
+export hafs_envar_ens="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/ens"
+
# Define type of GPSRO data to be assimilated (refractivity or bending angle)
export gps_dtype="gps_bnd"
@@ -228,7 +218,7 @@ export regression_vfydir="$noscrub/regression"
# Define debug variable - If you want to run the debug tests, set this variable to .true. Default is .false.
export debug=".false."
-# Define parameters for global_3dvar, global_4dvar, global_4denvar
+# Define parameters for global_4denvar
export minimization="lanczos" # If "lanczos", use sqrtb lanczos minimization algorithm. Otherwise use "pcgsoi".
export nhr_obsbin="6" # Time window for observation binning. Use "6" for 3d4dvar test. Otherwise use "1"
diff --git a/regression/rrfs_3denvar_glbens.sh b/regression/rrfs_3denvar_rdasens.sh
similarity index 55%
rename from regression/rrfs_3denvar_glbens.sh
rename to regression/rrfs_3denvar_rdasens.sh
index af5da51172..b00047ec65 100755
--- a/regression/rrfs_3denvar_glbens.sh
+++ b/regression/rrfs_3denvar_rdasens.sh
@@ -21,7 +21,7 @@ exp=$jobname
#
#-----------------------------------------------------------------------
#
-adate=${rrfs_3denvar_glbens_adate}
+adate=${rrfs_3denvar_rdasens_adate}
YYYYMMDDHH=$(date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2}")
JJJ=$(date +%j -d "${adate:0:8} ${adate:8:2}")
@@ -31,9 +31,6 @@ DD=${YYYYMMDDHH:6:2}
HH=${YYYYMMDDHH:8:2}
YYYYMMDD=${YYYYMMDDHH:0:8}
#
-#MESO_USELIST_FN=$(date +%Y-%m-%d -d "${START_DATE} -1 day")_meso_uselist.txt
-#AIR_REJECT_FN=$(date +%Y%m%d -d "${START_DATE} -1 day")_rejects.txt
-
#
#-----------------------------------------------------------------------
#
@@ -42,17 +39,16 @@ YYYYMMDD=${YYYYMMDDHH:0:8}
#
#-----------------------------------------------------------------------
# Set runtime and save directories
-tmpdir=$tmpdir/tmpreg_rrfs_3denvar_glbens/${exp}
-savdir=$savdir/outreg_rrfs_3denvar_glbens/${exp}
+tmpdir=$tmpdir/tmpreg_rrfs_3denvar_rdasens/${exp}
+savdir=$savdir/outreg_rrfs_3denvar_rdasens/${exp}
# Set up $tmpdir
rm -rf $tmpdir
mkdir -p $tmpdir
-chgrp rstprod $tmpdir
chmod 750 $tmpdir
cd $tmpdir
-bkpath=${rrfs_3denvar_glbens_ges}
+bkpath=${rrfs_3denvar_rdasens_ges}
# decide background type
if [ -r "${bkpath}/fv3_coupler.res" ]; then
BKTYPE=0 # warm start
@@ -68,19 +64,59 @@ fixcrtm=${fixcrtm:-$CRTM_FIX}
#
#---------------------------------------------------------------------
#
-echo "regional_ensemble_option is ",${regional_ensemble_option:-1}
-
+regional_ensemble_option=${regional_ensemble_option:-5}
+NUM_ENS_MEMBERS=5
+echo "regional_ensemble_option is ",${regional_ensemble_option}
+echo "regional_ensemble number is ",${NUM_ENS_MEMBERS}
echo "$VERBOSE" "fixgsi is $fixgsi"
-echo "$VERBOSE" "fixgriddir is $fixgriddir"
echo "$VERBOSE" "default bkpath is $bkpath"
echo "$VERBOSE" "background type is is $BKTYPE"
ifhyb=.false.
-if [[ ${regional_ensemble_option:-1} -eq 1 ]]; then #using GDAS
+#
+# Check if we have enough FV3-LAM ensembles when regional_ensemble_option=5
+#
+if [[ ${regional_ensemble_option} -eq 5 ]]; then
+
+ imem=1
+ ifound=0
+ while [[ $imem -le ${NUM_ENS_MEMBERS} ]];do
+ memcharv0=$( printf "%03d" $imem )
+ memchar=mem$( printf "%04d" $imem )
+
+ restart_prefix="${YYYYMMDD}.${HH}0000."
+ slash_ensmem_subdir=$memchar
+ bkpathmem=${rrfs_3denvar_rdasens_ens}/${slash_ensmem_subdir}/fcst_fv3lam/RESTART
+
+ dynvarfile=${bkpathmem}/${restart_prefix}fv_core.res.tile1.nc
+ tracerfile=${bkpathmem}/${restart_prefix}fv_tracer.res.tile1.nc
+ phyvarfile=${bkpathmem}/${restart_prefix}phy_data.nc
+ if [ -r "${dynvarfile}" ] && [ -r "${tracerfile}" ] && [ -r "${phyvarfile}" ] ; then
+ ln -snf ${bkpathmem}/${restart_prefix}fv_core.res.tile1.nc fv3SAR01_ens_mem${memcharv0}-fv3_dynvars
+ ln -snf ${bkpathmem}/${restart_prefix}fv_tracer.res.tile1.nc fv3SAR01_ens_mem${memcharv0}-fv3_tracer
+ ln -snf ${bkpathmem}/${restart_prefix}phy_data.nc fv3SAR01_ens_mem${memcharv0}-fv3_phyvars
+ (( ifound += 1 ))
+ else
+ print_info_msg "WARNING: Cannot find ensemble files: ${dynvarfile} ${tracerfile} ${phyvarfile} "
+ fi
+ (( imem += 1 ))
+ done
+
+ ifhyb=.true.
+ nummem=${NUM_ENS_MEMBERS}
+ if [[ $ifound -ne ${NUM_ENS_MEMBERS} ]] || [[ ${BKTYPE} -eq 1 ]]; then
+ print_info_msg "Not enough FV3_LAM ensembles, will fall to GDAS"
+ regional_ensemble_option=1
+ l_both_fv3sar_gfs_ens=.false.
+ ifhyb=.false.
+ fi
+fi
+#
+if [[ ${regional_ensemble_option} -eq 1 ]]; then #using GDAS
#-----------------------------------------------------------------------
# Make a list of the latest GFS EnKF ensemble
#-----------------------------------------------------------------------
- ls ${rrfs_3denvar_glbens_ens}/*gdas.t??z.atmf009.mem0??.nc >> filelist03
+ ls ${rrfs_3denvar_rdasens_ens}/*gdas.t??z.atmf009.mem0??.nc >> filelist03
nummem=$(more filelist03 | wc -l)
nummem=$((nummem - 3 ))
@@ -109,12 +145,13 @@ ln -snf ${bkpath}/fv3_akbk fv3_akbk
ln -snf ${bkpath}/fv3_grid_spec fv3_grid_spec
if [ ${BKTYPE} -eq 1 ]; then # cold start uses background from INPUT
- ln -snf ${bkpath}/phis.nc phis.nc
- ncks -A -v phis phis.nc ${bkpath}/gfs_data.tile7.halo0.nc
- ln_vrfy -snf ${bkpath}/sfc_data.tile7.halo0.nc fv3_sfcdata
- ln_vrfy -snf ${bkpath}/gfs_data.tile7.halo0.nc fv3_dynvars
- ln_vrfy -s fv3_dynvars fv3_tracer
+ cp ${bkpath}/sfc_data.tile7.halo0.nc fv3_sfcdata
+ cp ${bkpath}/gfs_data.tile7.halo0.nc fv3_dynvars
+ ln_vrfy -s fv3_dynvars fv3_tracer
+
+ ln -snf ${bkpath}/phis.nc phis.nc
+ ncks -A -v phis phis.nc fv3_dynvars
fv3lam_bg_type=1
else # cycle uses background from restart
@@ -133,7 +170,6 @@ sed -i "s/mm/${MM}/" coupler.res
sed -i "s/dd/${DD}/" coupler.res
sed -i "s/hh/${HH}/" coupler.res
-
#
#-----------------------------------------------------------------------
#
@@ -143,7 +179,7 @@ sed -i "s/hh/${HH}/" coupler.res
#-----------------------------------------------------------------------
obs_source=rap
obsfileprefix=${YYYYMMDDHH}.${obs_source}
- obspath_tmp=${rrfs_3denvar_glbens_obs}
+ obspath_tmp=${rrfs_3denvar_rdasens_obs}
obs_files_source[0]=${obspath_tmp}/${obsfileprefix}.t${HH}${SUBH}z.prepbufr.tm00
obs_files_target[0]=prepbufr
@@ -156,6 +192,73 @@ sed -i "s/hh/${HH}/" coupler.res
obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}${SUBH}z.nexrad.tm00.bufr_d
obs_files_target[${obs_number}]=l2rwbufr
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${YYYYMMDDHH}.Gridded_ref.nc
+ obs_files_target[${obs_number}]=dbzobs.nc
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${YYYYMMDDHH}.fedobs.nc
+ obs_files_target[${obs_number}]=fedobs.nc
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.1bamua.tm00.bufr_d
+ obs_files_target[${obs_number}]=amsuabufr
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esamua.tm00.bufr_d
+ obs_files_target[${obs_number}]=amsuabufrears
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.1bmhs.tm00.bufr_d
+ obs_files_target[${obs_number}]=mhsbufr
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esmhs.tm00.bufr_d
+ obs_files_target[${obs_number}]=mhsbufrears
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.atms.tm00.bufr_d
+ obs_files_target[${obs_number}]=atmsbufr
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esatms.tm00.bufr_d
+ obs_files_target[${obs_number}]=atmsbufrears
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.atmsdb.tm00.bufr_d
+ obs_files_target[${obs_number}]=atmsbufr_db
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.crisf4.tm00.bufr_d
+ obs_files_target[${obs_number}]=crisfsbufr
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.crsfdb.tm00.bufr_d
+ obs_files_target[${obs_number}]=crisfsbufr_db
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.mtiasi.tm00.bufr_d
+ obs_files_target[${obs_number}]=iasibufr
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esiasi.tm00.bufr_d
+ obs_files_target[${obs_number}]=iasibufrears
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.iasidb.tm00.bufr_d
+ obs_files_target[${obs_number}]=iasibufr_db
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.gsrcsr.tm00.bufr_d
+ obs_files_target[${obs_number}]=abibufr
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.ssmisu.tm00.bufr_d
+ obs_files_target[${obs_number}]=ssmisbufr
+
+ obs_number=${#obs_files_source[@]}
+ obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.sevcsr.tm00.bufr_d
+ obs_files_target[${obs_number}]=sevcsr
obs_number=${#obs_files_source[@]}
for (( i=0; i<${obs_number}; i++ ));
@@ -176,7 +279,7 @@ done
#
#-----------------------------------------------------------------------
-ANAVINFO=${fixgsi}/anavinfo.rrfs
+ANAVINFO=${fixgsi}/anavinfo.rrfs_conv_dbz
CONVINFO=${fixgsi}/convinfo.rrfs
HYBENSINFO=${fixgsi}/hybens_info.rrfs
OBERROR=${fixgsi}/errtable.rrfs
@@ -198,9 +301,31 @@ cp $OBERROR errtable
cp $ATMS_BEAMWIDTH atms_beamwidth.txt
cp ${HYBENSINFO} hybens_info
-cp ${bkpath}/gsd_sfcobs_provider.txt gsd_sfcobs_provider.txt
-cp ${bkpath}/current_bad_aircraft current_bad_aircraft
-cp ${bpath}/gsd_sfcobs_uselist.txt gsd_sfcobs_uselist.txt
+cp ${obspath_tmp}/gsd_sfcobs_provider.txt gsd_sfcobs_provider.txt
+cp ${obspath_tmp}/current_bad_aircraft current_bad_aircraft
+cp ${obspath_tmp}/gsd_sfcobs_uselist.txt gsd_sfcobs_uselist.txt
+
+#-----------------------------------------------------------------------
+#
+# cycling radiance bias corretion files
+#
+#-----------------------------------------------------------------------
+
+cp $obspath_tmp/rrfs.prod.${YYYYMMDDHH}_satbias_pc ./satbias_pc
+cp $obspath_tmp/rrfs.prod.${YYYYMMDDHH}_satbias ./satbias_in
+cp $obspath_tmp/rrfs.prod.${YYYYMMDDHH}_radstat ./radstat.rrfs
+
+if [ -r radstat.rrfs ]; then
+ listdiag=$(tar xvf radstat.rrfs | cut -d' ' -f2 | grep _ges)
+ for type in $listdiag; do
+ diag_file=$(echo $type | cut -d',' -f1)
+ fname=$(echo $diag_file | cut -d'.' -f1)
+ date=$(echo $diag_file | cut -d'.' -f2)
+ gunzip $diag_file
+ fnameanl=$(echo $fname|sed 's/_ges//g')
+ mv $fname.$date* $fnameanl
+ done
+fi
#-----------------------------------------------------------------------
#
@@ -261,9 +386,9 @@ HYBRID_ENSEMBLE='ensemble_path="",'
SINGLEOB="$SINGLEOB_update"
if [ "$debug" = ".false." ]; then
- . $scripts/regression_namelists.sh rrfs_3denvar_glbens
+ . $scripts/regression_namelists.sh rrfs_3denvar_rdasens
else
- . $scripts/regression_namelists_db.sh rrfs_3denvar_glbens
+ . $scripts/regression_namelists_db.sh rrfs_3denvar_rdasens
fi
cat << EOF > gsiparm.anl
@@ -279,10 +404,6 @@ elif [[ $exp == *"contrl"* ]]; then
$ncp $gsiexec_contrl ./gsi.x
fi
-#cp $fv3_netcdf_ges/nam.t06z.satbias_pc.tm04 ./satbias_pc
-#cp $fv3_netcdf_ges/nam.t06z.satbias.tm04 ./satbias_in
-#cp $fv3_netcdf_ges/nam.t06z.radstat.tm04 ./radstat.gdas
-
# Run GSI
cd $tmpdir
echo "run gsi now"
diff --git a/regression/rrfs_enkf_conv.sh b/regression/rrfs_enkf_conv.sh
new file mode 100755
index 0000000000..21f7aacee2
--- /dev/null
+++ b/regression/rrfs_enkf_conv.sh
@@ -0,0 +1,223 @@
+
+set -x
+
+# Set variables used in script
+# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone)
+# ncp is cp replacement, currently keep as /bin/cp
+
+UNCOMPRESS=gunzip
+CLEAN=NO
+ncp=/bin/cp
+#
+# Set experiment name
+#
+exp=$jobname
+
+#-----------------------------------------------------------------------
+#
+# Extract from ADATE the starting year, month, day, and hour of the
+# forecast. These are needed below for various operations.
+#
+#-----------------------------------------------------------------------
+#
+
+adate=${rrfs_enkf_adate}
+YYYYMMDDHH=$(date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2}")
+JJJ=$(date +%j -d "${adate:0:8} ${adate:8:2}")
+
+YYYY=${YYYYMMDDHH:0:4}
+MM=${YYYYMMDDHH:4:2}
+DD=${YYYYMMDDHH:6:2}
+HH=${YYYYMMDDHH:8:2}
+YYYYMMDD=${YYYYMMDDHH:0:8}
+
+#
+#-----------------------------------------------------------------------
+#
+# go to working directory and save directory.
+# define fix and background path
+#
+#-----------------------------------------------------------------------
+# Set runtime and save directories
+tmpdir=$tmpdir/tmpreg_rrfs_enkf_conv/${exp}
+savdir=$savdir/outreg_rrfs_enkf_conv/${exp}
+
+# Set up $tmpdir
+rm -rf $tmpdir
+mkdir -p $tmpdir
+chmod 750 $tmpdir
+cd $tmpdir
+
+fixcrtm=${fixcrtm:-$CRTM_FIX}
+
+cp ${rrfs_3denvar_rdasens_ges}/fv3_coupler.res coupler.res
+cp ${rrfs_3denvar_rdasens_ges}/fv3_akbk fv3sar_tile1_akbk.nc
+cp ${rrfs_3denvar_rdasens_ges}/fv3_grid_spec fv3sar_tile1_grid_spec.nc
+
+#
+#-----------------------------------------------------------------------
+#
+# Loop through the members, link the background and copy over
+# observer output (diag*ges*) files to the running directory
+#
+#-----------------------------------------------------------------------
+#
+ob_type="conv"
+DO_ENS_RADDA="false"
+nens=${nens:-5}
+netcdf_diag=".true."
+for imem in $(seq 1 $nens) ensmean; do
+
+ if [ "${imem}" = "ensmean" ]; then
+ memchar="ensmean"
+ memcharv0="ensmean"
+ restart_prefix=""
+ else
+ memchar="mem"$(printf %04i $imem)
+ memcharv0="mem"$(printf %03i $imem)
+ restart_prefix="${YYYYMMDD}.${HH}0000."
+ fi
+ slash_ensmem_subdir=$memchar
+ bkpath=${rrfs_enkf_ges}/${slash_ensmem_subdir}/fcst_fv3lam/RESTART
+ observer_nwges_dir="${rrfs_enkf_diag}/${slash_ensmem_subdir}/observer_gsi"
+
+ cp ${bkpath}/${restart_prefix}fv_core.res.tile1.nc fv3sar_tile1_${memcharv0}_dynvars
+ cp ${bkpath}/${restart_prefix}fv_tracer.res.tile1.nc fv3sar_tile1_${memcharv0}_tracer
+ cp ${bkpath}/${restart_prefix}sfc_data.nc fv3sar_tile1_${memcharv0}_sfcdata
+ cp ${bkpath}/${restart_prefix}phy_data.nc fv3sar_tile1_${memcharv0}_phyvar
+
+ #
+#-----------------------------------------------------------------------
+#
+# Copy observer outputs (diag*ges*) to the working directory
+#
+#-----------------------------------------------------------------------
+#
+ if [ "${netcdf_diag}" = ".true." ] ; then
+ # Note, listall_rad is copied from exrrfs_run_analysis.sh
+ listall_rad="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsua_n18 amsua_n19 amsua_metop-a amsua_metop-b amsua_metop-c amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 pcp_ssmi_dmsp pcp_tmi_trmm conv sbuv2_n16 sbuv2_n17 sbuv2_n18 omi_aura ssmi_f13 ssmi_f14 ssmi_f15 hirs4_n18 hirs4_metop-a mhs_n18 mhs_n19 mhs_metop-a mhs_metop-b mhs_metop-c amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_las_f16 ssmis_uas_f16 ssmis_img_f16 ssmis_env_f16 iasi_metop-a iasi_metop-b iasi_metop-c seviri_m08 seviri_m09 seviri_m10 seviri_m11 cris_npp atms_npp ssmis_f17 cris-fsr_npp cris-fsr_n20 atms_n20 abi_g16"
+
+
+ if [ "${ob_type}" = "conv" ]; then
+ list_ob_type="conv_ps conv_q conv_t conv_uv conv_pw conv_rw conv_sst"
+
+ if [ "${DO_ENS_RADDA}" = "TRUE" ]; then
+ list_ob_type="$list_ob_type $listall_rad"
+ fi
+ fi
+
+ if [ "${ob_type}" = "radardbz" ]; then
+ if [ ${DO_GLM_FED_DA} == "TRUE" ]; then
+ list_ob_type="conv_dbz conv_fed"
+ else
+ list_ob_type="conv_dbz"
+ fi
+ fi
+ for sub_ob_type in ${list_ob_type} ; do
+ diagfile0=${observer_nwges_dir}/diag_${sub_ob_type}_ges.${YYYYMMDDHH}.nc4.gz
+ if [ -s $diagfile0 ]; then
+ diagfile=$(basename $diagfile0)
+ cp $diagfile0 $diagfile
+ gzip -d $diagfile && rm -f $diagfile
+ ncfile0=$(basename -s .gz $diagfile)
+ ncfile=$(basename -s .nc4 $ncfile0)
+ mv $ncfile0 ${ncfile}_${memcharv0}.nc4
+ fi
+ done
+ else
+ for diagfile0 in $(ls ${observer_nwges_dir}/diag*${ob_type}*ges* ) ; do
+ if [ -s $diagfile0 ]; then
+ diagfile=$(basename $diagfile0)
+ cp $diagfile0 diag_conv_ges.$memcharv0
+ fi
+ done
+ fi
+done
+
+#
+#-----------------------------------------------------------------------
+#
+# Set GSI fix files
+#
+#----------------------------------------------------------------------
+#
+found_ob_type=0
+
+CONVINFO=${fixgsi}/convinfo.rrfs
+
+if [ "${ob_type}" = "conv" ]; then
+ ANAVINFO=${fixgsi}/anavinfo.rrfs
+ found_ob_type=1
+fi
+if [ "${ob_type}" = "radardbz" ]; then
+ ANAVINFO=${fixgsi}/anavinfo.enkf.rrfs_dbz
+ CORRLENGTH="18"
+ LNSIGCUTOFF="0.5"
+ found_ob_type=1
+fi
+if [ ${found_ob_type} == 0 ]; then
+ err_exit "Unknown observation type: ${ob_type}"
+fi
+stdout_name=stdout.${ob_type}
+stderr_name=stderr.${ob_type}
+
+SATINFO=${fixgsi}/global_satinfo.txt
+OZINFO=${fixgsi}/global_ozinfo.txt
+
+cp ${ANAVINFO} anavinfo
+cp $SATINFO satinfo
+cp $CONVINFO convinfo
+cp $OZINFO ozinfo
+
+#
+#-----------------------------------------------------------------------
+#
+# Get nlons (NX_RES), nlats (NY_RES) and nlevs
+#
+#-----------------------------------------------------------------------
+#
+NX_RES=$(ncdump -h fv3sar_tile1_grid_spec.nc | grep "grid_xt =" | cut -f3 -d" " )
+NY_RES=$(ncdump -h fv3sar_tile1_grid_spec.nc | grep "grid_yt =" | cut -f3 -d" " )
+nlevs=$(ncdump -h fv3sar_tile1_mem001_tracer | grep "zaxis_1 =" | cut -f3 -d" " )
+#
+#----------------------------------------------------------------------
+#
+# Set namelist parameters for EnKF
+#
+#----------------------------------------------------------------------
+#
+EnKFTracerVars=${EnKFTracerVar:-"sphum,o3mr"}
+ldo_enscalc_option=${ldo_enscalc_option:-0}
+
+# Make gsi namelist
+
+. $scripts/regression_namelists.sh rrfs_enkf_conv
+
+#
+
+cat << EOF > enkf.nml
+
+$gsi_namelist
+
+EOF
+
+#
+#-----------------------------------------------------------------------
+#
+# Run the EnKF
+#
+#-----------------------------------------------------------------------
+#
+# Copy executable and fixed files to $tmpdir
+if [[ $exp == *"updat"* ]]; then
+ $ncp $enkfexec_updat ./enkf.x
+elif [[ $exp == *"contrl"* ]]; then
+ $ncp $enkfexec_contrl ./enkf.x
+fi
+
+# Run enkf
+cd $tmpdir
+echo "run rrfs enkf now"
+eval "$APRUN $tmpdir/enkf.x < enkf.nml > stdout 2>&1"
+rc=$?
+exit $rc
diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt
index a2eb249456..2f88b978c6 100644
--- a/src/CMakeLists.txt
+++ b/src/CMakeLists.txt
@@ -3,6 +3,11 @@ if(BUILD_GSDCLOUD)
add_subdirectory(GSD)
endif()
+if(BUILD_MGBF)
+ message(STATUS "Building MGBF library")
+ add_subdirectory(mgbf)
+endif()
+
if(BUILD_GSI)
message(STATUS "Building GSI")
add_subdirectory(gsi)
diff --git a/src/enkf/controlvec.f90 b/src/enkf/controlvec.f90
index bb2421c89c..0961549634 100644
--- a/src/enkf/controlvec.f90
+++ b/src/enkf/controlvec.f90
@@ -51,7 +51,7 @@ module controlvec
use gridinfo, only: getgridinfo, gridinfo_cleanup, &
npts, vars3d_supported, vars2d_supported
use params, only: nlevs, nbackgrounds, fgfileprefixes, reducedgrid, &
- nanals, pseudo_rh, use_qsatensmean, nlons, nlats,&
+ nanals, pseudo_rh, nlons, nlats,&
nanals_per_iotask, ntasks_io, nanal1, nanal2, &
fgsfcfileprefixes, paranc, write_fv3_incr, write_ensmean
use kinds, only: r_kind, i_kind, r_double, r_single
@@ -64,7 +64,6 @@ module controlvec
public :: read_control, write_control, controlvec_cleanup, init_controlvec
real(r_single), public, allocatable, dimension(:,:,:,:) :: grdin
real(r_double), public, allocatable, dimension(:,:,:,:) :: qsat
-real(r_double), public, allocatable, dimension(:,:,:) :: qsatmean
integer(i_kind), public :: nc2d, nc3d, ncdim
character(len=max_varname_length), allocatable, dimension(:), public :: cvars3d
@@ -131,7 +130,7 @@ subroutine init_controlvec()
cvars3d(nc3d) = trim(adjustl(var))
clevels(nc3d) = ilev + clevels(nc3d-1)
else
- if (nproc .eq. 0) print *,'Error: only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev
+ if (nproc .eq. 0) print *,'Error controlvec: only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev
call stop2(503)
endif
enddo
@@ -160,7 +159,7 @@ subroutine init_controlvec()
do i = 1, nc2d
if (getindex(vars2d_supported, cvars2d(i))<0) then
if (nproc .eq. 0) then
- print *,'Error: 2D variable ', cvars2d(i), ' is not supported in current version.'
+ print *,'Error: control 2D variable ', cvars2d(i), ' is not supported in current version.'
print *,'Supported variables: ', vars2d_supported
endif
call stop2(502)
@@ -169,7 +168,7 @@ subroutine init_controlvec()
do i = 1, nc3d
if (getindex(vars3d_supported, cvars3d(i))<0) then
if (nproc .eq. 0) then
- print *,'Error: 3D variable ', cvars3d(i), ' is not supported in current version.'
+ print *,'Error: control 3D variable ', cvars3d(i), ' is not supported in current version.'
print *,'Supported variables: ', vars3d_supported
endif
call stop2(502)
@@ -192,7 +191,6 @@ subroutine read_control()
! read ensemble members on IO tasks
implicit none
real(r_double) :: t1,t2
-real(r_double), allocatable, dimension(:) :: qsat_tmp
integer(i_kind) :: nb,nlev,ne
integer(i_kind) :: q_ind
integer(i_kind) :: ierr
@@ -212,70 +210,39 @@ subroutine read_control()
! read in whole control vector on i/o procs - keep in memory
! (needed in write_ensemble)
allocate(grdin(npts,ncdim,nbackgrounds,nanals_per_iotask))
-allocate(qsat(npts,nlevs,nbackgrounds,nanals_per_iotask))
+! if only updating the sfc fields, qsat will not be calculated in readgriddata
+! only allocate if needed.
+q_ind = getindex(cvars3d, 'q')
+if (q_ind > 0) allocate(qsat(npts,nlevs,nbackgrounds,nanals_per_iotask))
if (paranc) then
if (nproc == 0) t1 = mpi_wtime()
call readgriddata_pnc(cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds, &
fgfileprefixes,fgsfcfileprefixes,reducedgrid,grdin,qsat)
+ if (nproc == 0) then
+ t2 = mpi_wtime()
+ print *,'time in readgrid_pnc on root',t2-t1,'secs'
+ end if
end if
if (nproc <= ntasks_io-1) then
if (.not. paranc) then
if (nproc == 0) t1 = mpi_wtime()
call readgriddata(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds, &
fgfileprefixes,fgsfcfileprefixes,reducedgrid,grdin,qsat)
+ if (nproc == 0) then
+ t2 = mpi_wtime()
+ print *,'time in readgrid on root',t2-t1,'secs'
+ end if
end if
!print *,'min/max qsat',nanal,'=',minval(qsat),maxval(qsat)
- if (use_qsatensmean) then
- allocate(qsatmean(npts,nlevs,nbackgrounds))
- allocate(qsat_tmp(npts))
- ! compute ensemble mean qsat
- qsatmean = 0_r_double
- do ne=1,nanals_per_iotask
- do nb=1,nbackgrounds
- do nlev=1,nlevs
- call mpi_allreduce(qsat(:,nlev,nb,ne),qsat_tmp,npts,mpi_real8,mpi_sum,mpi_comm_io,ierr)
- qsatmean(:,nlev,nb) = qsatmean(:,nlev,nb) + qsat_tmp
- enddo
- enddo
- enddo
- deallocate(qsat_tmp)
- qsatmean = qsatmean/real(nanals)
- !print *,'min/max qsat ensmean',nanal,'=',minval(qsat),maxval(qsat)
- endif
- if (nproc == 0) then
- t2 = mpi_wtime()
- print *,'time in readgridata on root',t2-t1,'secs'
- end if
- !do ne=1,nanals_per_iotask
- ! nanal = ne + (nproc-1)*nanals_per_iotask
- ! print *,'min/max ps ens mem',nanal,'=',&
- ! minval(grdin(:,ncdim,nbackgrounds/2+1,ne)),maxval(grdin(:,ncdim,nbackgrounds/2+1,ne))
- ! print *,'min/max qsat',nanal,'=',&
- ! minval(qsat(:,:,nbackgrounds/2+1,ne)),maxval(qsat(:,:,nbackgrounds/2+1,ne))
- !enddo
- !if (use_qsatensmean) then
- ! print *,'min/max qsatmean proc',nproc,'=',&
- ! minval(qsatmean(:,:,nbackgrounds/2+1)),maxval(qsatmean(:,:,nbackgrounds/2+1))
- !endif
q_ind = getindex(cvars3d, 'q')
if (pseudo_rh .and. q_ind > 0) then
- if (use_qsatensmean) then
- do ne=1,nanals_per_iotask
- do nb=1,nbackgrounds
- ! create normalized humidity analysis variable.
- grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = &
- grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)/qsatmean(:,:,nb)
- enddo
- enddo
- else
- do ne=1,nanals_per_iotask
- do nb=1,nbackgrounds
- ! create normalized humidity analysis variable.
- grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = &
- grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)/qsat(:,:,nb,ne)
- enddo
- enddo
- endif
+ do ne=1,nanals_per_iotask
+ do nb=1,nbackgrounds
+ ! create normalized humidity analysis variable.
+ grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = &
+ grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)/qsat(:,:,nb,ne)
+ enddo
+ enddo
end if
endif
@@ -296,6 +263,18 @@ subroutine write_control(no_inflate_flag)
if (nproc <= ntasks_io-1) then
+ ! scale q by ensemble qsat, prior to averaging
+ q_ind = getindex(cvars3d, 'q')
+ if (pseudo_rh .and. q_ind > 0) then
+ do ne=1,nanals_per_iotask
+ do nb=1,nbackgrounds
+ grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = &
+ grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)*qsat(:,:,nb,ne)
+ enddo
+ enddo
+ endif
+
+
allocate(grdin_mean_tmp(npts,ncdim))
if (nproc == 0) then
allocate(grdin_mean(npts,ncdim,nbackgrounds,1))
@@ -342,34 +321,6 @@ subroutine write_control(no_inflate_flag)
100 format('ens. mean anal. increment min/max ',a,2x,g19.12,2x,g19.12)
deallocate(grdin_mean_tmp)
- q_ind = getindex(cvars3d, 'q')
- if (pseudo_rh .and. q_ind > 0) then
- if (use_qsatensmean) then
- do ne=1,nanals_per_iotask
- do nb=1,nbackgrounds
- ! re-scale normalized spfh with sat. sphf of ensmean first guess
- grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = &
- grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)*qsatmean(:,:,nb)
- enddo
- enddo
- else
- do ne=1,nanals_per_iotask
- do nb=1,nbackgrounds
- ! re-scale normalized spfh with sat. sphf of first guess
- grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne) = &
- grdin(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,ne)*qsat(:,:,nb,ne)
- enddo
- enddo
- endif
- if (nproc == 0 .and. write_ensmean) then
- ! write_ensmean implies use_qsatensmean
- do nb=1,nbackgrounds
- ! re-scale normalized spfh with sat. sphf of ensmean first guess
- grdin_mean(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,1) = &
- grdin_mean(:,(q_ind-1)*nlevs+1:q_ind*nlevs,nb,1)*qsatmean(:,:,nb)
- enddo
- endif
- end if
if (.not. paranc) then
if (write_fv3_incr) then
call writeincrement(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,grdin,no_inflate_flag)
@@ -410,7 +361,7 @@ subroutine write_control(no_inflate_flag)
endif
deallocate(grdin_mean)
t2 = mpi_wtime()
- print *,'time in write_control on root',t2-t1,'secs'
+ print *,'time in write_control paranc on root',t2-t1,'secs'
endif
end if
@@ -424,7 +375,6 @@ subroutine controlvec_cleanup()
if (allocated(index_pres)) deallocate(index_pres)
if (allocated(grdin)) deallocate(grdin)
if (allocated(qsat)) deallocate(qsat)
-if (allocated(qsatmean)) deallocate(qsatmean)
call gridinfo_cleanup()
end subroutine controlvec_cleanup
diff --git a/src/enkf/enkf.f90 b/src/enkf/enkf.f90
index c117e4ba56..479f60c019 100644
--- a/src/enkf/enkf.f90
+++ b/src/enkf/enkf.f90
@@ -51,7 +51,7 @@ module enkf
! NH, tropics and SH, and in the horizontal, vertical and time dimensions,
! using the namelist parameters corrlengthnh, corrlengthtr, corrlengthsh,
! lnsigcutoffnh, lnsigcutofftr, lnsigcutoffsh (lnsigcutoffsatnh,
-! lnsigcutoffsattr, lnsigcutoffsatsh for satellite obs, similar for ps obs)
+! lnsigcutoffsattr, lnsigcutoffsatsh for satellite obs, similar for ps and fed obs)
! obtimelnh, obtimeltr, obtimelsh. The length scales should be given in km for the
! horizontal, hours for time, and 'scale heights' (units of -log(p/pref)) in the
! vertical. The function used for localization (function taper)
@@ -97,6 +97,12 @@ module enkf
! used to be the same) and the "chunks" come from loadbal
! 2018-05-31: whitaker: add modulated ensemble model-space vertical
! localization (neigv>0) and denkf option.
+! 2022-04-01: Y. Wang and X. Wang: Add dbz_ind related if-blocks to fix spurious
+! analysis increments due to some unstable amplifying behaviors near edges of
+! strong precipitation when clear air and large reflectivity values are
+! assimilated in locations near each other (as may be the case in the leading
+! line of an MCS).
+! poc: xuguang.wang@ou.edu
!
! attributes:
! language: f95
@@ -182,7 +188,7 @@ subroutine enkf_update()
integer(i_kind) ierr
! kd-tree search results
type(kdtree2_result),dimension(:),allocatable :: sresults1,sresults2
-integer(i_kind) nanal,nn,nnn,nobm,nsame,nn1,nn2,oz_ind,nlev
+integer(i_kind) nanal,nn,nnn,nobm,nsame,nn1,nn2,oz_ind,nlev,dbz_ind
real(r_single),dimension(nlevs_pres):: taperv
logical lastiter, kdgrid, kdobs
@@ -609,6 +615,7 @@ subroutine enkf_update()
nn2 = ncdim
end if
if (nf2 > 0) then
+ dbz_ind = getindex(cvars3d, 'dbz')
!$omp parallel do schedule(dynamic,1) private(ii,i,nb,obt,nn,nnn,nlev,lnsig,kfgain,ens_tmp,taper1,taper3,taperv)
do ii=1,nf2 ! loop over nearby horiz grid points
do nb=1,nbackgrounds ! loop over background time levels
@@ -628,8 +635,13 @@ subroutine enkf_update()
! (through hpfhtcon)
kfgain=taper1*sum(ens_tmp*anal_obtmp_modens)
! update mean.
- ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + &
- kfgain*obinc_tmp
+ if ( (nn >= (dbz_ind-1)*nlevs+1 .and. nn <= (dbz_ind-1)*nlevs+nlevs) )then
+ ensmean_chunk(i,nn,nb) = max(ensmean_chunk(i,nn,nb) + &
+ kfgain*obinc_tmp,zero)
+ else
+ ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + &
+ kfgain*obinc_tmp
+ end if
! update perturbations.
anal_chunk(:,i,nn,nb) = anal_chunk(:,i,nn,nb) + &
kfgain*obganl(:)
@@ -652,7 +664,11 @@ subroutine enkf_update()
! (through hpfhtcon)
kfgain=taperv(nnn)*sum(anal_chunk(:,i,nn,nb)*anal_obtmp)
! update mean.
- ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + kfgain*obinc_tmp
+ if ( (nn >= (dbz_ind-1)*nlevs+1 .and. nn <= (dbz_ind-1)*nlevs+nlevs) )then
+ ensmean_chunk(i,nn,nb) = max(ensmean_chunk(i,nn,nb) + kfgain*obinc_tmp,zero)
+ else
+ ensmean_chunk(i,nn,nb) = ensmean_chunk(i,nn,nb) + kfgain*obinc_tmp
+ end if
! update perturbations.
anal_chunk(:,i,nn,nb) = anal_chunk(:,i,nn,nb) + kfgain*obganl(:)
end if
@@ -681,7 +697,13 @@ subroutine enkf_update()
taper(obt*obtimelinv)* &
sum(anal_obchunk_modens(:,nob2)*anal_obtmp_modens)*hpfhtcon
! update mean.
- ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp
+ nob3 = indxproc_obs(nproc+1,nob2)
+ if(trim(obtype(nob3)) == 'dbz' ) then
+ ensmean_obchunk(nob2) = max((ensmean_obchunk(nob2) + &
+ kfgain*obinc_tmp),zero)
+ else
+ ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp
+ end if
! update perturbations.
anal_obchunk(:,nob2) = anal_obchunk(:,nob2) + kfgain*obganl
anal_obchunk_modens(:,nob2) = anal_obchunk_modens(:,nob2) + kfgain*obganl_modens
@@ -707,7 +729,13 @@ subroutine enkf_update()
taper(lnsig*lnsiglinv)*taper(obt*obtimelinv)* &
sum(anal_obchunk(:,nob2)*anal_obtmp)*hpfhtcon
! update mean.
- ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp
+ nob3 = indxproc_obs(nproc+1,nob2)
+ if(trim(obtype(nob3)) == 'dbz' ) then
+ ensmean_obchunk(nob2) = max((ensmean_obchunk(nob2) + &
+ kfgain*obinc_tmp),zero)
+ else
+ ensmean_obchunk(nob2) = ensmean_obchunk(nob2) + kfgain*obinc_tmp
+ end if
! update perturbations.
anal_obchunk(:,nob2) = anal_obchunk(:,nob2) + kfgain*obganl
! recompute ob space spread ratio for unassimlated obs
@@ -758,6 +786,7 @@ subroutine enkf_update()
tend = mpi_wtime()
if (nproc .eq. 0) then
write(6,8003) niter,'timing on proc',nproc,' = ',tend-tbegin,t2,t3,t4,t5,t6,nrej
+ if(allocated(assimltd_flag))deallocate(assimltd_flag)
allocate(assimltd_flag(nobstot))
assimltd_flag = 99999
if (iassim_order == 2) then
diff --git a/src/enkf/enkf_obs_sensitivity.f90 b/src/enkf/enkf_obs_sensitivity.f90
index 6c37936f31..72296d5934 100644
--- a/src/enkf/enkf_obs_sensitivity.f90
+++ b/src/enkf/enkf_obs_sensitivity.f90
@@ -36,6 +36,7 @@ module enkf_obs_sensitivity
use params, only: efsoi_flag,latbound,nlevs,nanals,datestring, &
lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh, &
lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh, &
+ lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh, &
lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh, &
corrlengthnh,corrlengthtr,corrlengthsh, &
obtimelnh,obtimeltr,obtimelsh,letkf_flag, &
@@ -292,6 +293,8 @@ subroutine read_ob_sens
lnsigl(nob) = latval(deglat,lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh)
else if (obtype(nob)(1:3) == ' ps') then
lnsigl(nob) = latval(deglat,lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh)
+ else if (obtype(nob)(1:3) == 'fed') then
+ lnsigl(nob) = latval(deglat,lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh)
else
lnsigl(nob)=latval(deglat,lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh)
end if
diff --git a/src/enkf/enkf_obsmod.f90 b/src/enkf/enkf_obsmod.f90
index ba4b2946b1..eb4f9c8e58 100644
--- a/src/enkf/enkf_obsmod.f90
+++ b/src/enkf/enkf_obsmod.f90
@@ -109,6 +109,8 @@ module enkf_obsmod
lnsigcutoffnh, lnsigcutoffsh, lnsigcutofftr, corrlengthnh,&
corrlengthtr, corrlengthsh, obtimelnh, obtimeltr, obtimelsh,&
lnsigcutoffsatnh, lnsigcutoffsatsh, lnsigcutoffsattr,&
+ lnsigcutofffednh, lnsigcutofffedsh, lnsigcutofffedtr,&
+ corrlengthfednh, corrlengthfedtr, corrlengthfedsh, &
varqc, huber, zhuberleft, zhuberright, modelspace_vloc, &
lnsigcutoffpsnh, lnsigcutoffpssh, lnsigcutoffpstr, neigv, &
lnsigcutoffrdrnh, lnsigcutoffrdrsh, lnsigcutoffrdrtr,&
@@ -262,7 +264,6 @@ subroutine readobs()
allocate(corrlengthsq(nobstot),lnsigl(nobstot),obtimel(nobstot))
lnsigl=1.e10
do nob=1,nobstot
- oblnp(nob) = -log(obpress(nob)) ! distance measured in log(p) units
if (obloclon(nob) < zero) obloclon(nob) = obloclon(nob) + 360._r_single
radlon=deg2rad*obloclon(nob)
radlat=deg2rad*obloclat(nob)
@@ -277,16 +278,28 @@ subroutine readobs()
lnsigl(nob) = latval(deglat,lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh)
else if (obtype(nob)(1:3) == ' ps') then
lnsigl(nob) = latval(deglat,lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh)
+ else if (obtype(nob)(1:3) == 'fed') then
+ lnsigl(nob) = latval(deglat,lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh)
else if ( (obtype(nob)(1:3) == 'dbz' .or. obtype(nob)(1:3) == ' rw') .and. l_use_enkf_directZDA ) then
lnsigl(nob) = latval(deglat,lnsigcutoffrdrnh,lnsigcutoffrdrtr,lnsigcutoffrdrsh)
else
lnsigl(nob)=latval(deglat,lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh)
end if
endif
+ ! total column ozone has pressure set to zero, set to 0.001Pa
+ ! and turn vertical localization off (no effect if modelspace_vloc=T)
+ if (obpress(nob) < 0.001 .and. obtype(nob)(1:3) .eq. ' oz') then
+ lnsigl(nob) = 1.e30 ! turn ob-space vert localization off
+ obpress(nob) = 0.001 ! set to a non-zero value
+ endif
+ oblnp(nob) = -log(obpress(nob)) ! distance measured in log(p) units
corrlengthsq(nob)=latval(deglat,corrlengthnh,corrlengthtr,corrlengthsh)**2
if ( (obtype(nob)(1:3) == 'dbz' .or. obtype(nob)(1:3) == ' rw') .and. l_use_enkf_directZDA ) then
corrlengthsq(nob)=latval(deglat,corrlengthrdrnh,corrlengthrdrtr,corrlengthrdrsh)**2
end if
+ if (obtype(nob)(1:3) == 'fed') then
+ corrlengthsq(nob)=latval(deglat,corrlengthfednh,corrlengthfedtr,corrlengthfedsh)**2
+ end if
obtimel(nob)=latval(deglat,obtimelnh,obtimeltr,obtimelsh)
end do
diff --git a/src/enkf/gridinfo_fv3reg.f90 b/src/enkf/gridinfo_fv3reg.f90
index 53e5f5b3de..337c9ba682 100644
--- a/src/enkf/gridinfo_fv3reg.f90
+++ b/src/enkf/gridinfo_fv3reg.f90
@@ -43,10 +43,12 @@ module gridinfo
!
!$$$
-use mpisetup, only: nproc, mpi_integer, mpi_real4, mpi_comm_world,mpi_status
+use mpisetup, only: nproc, mpi_integer, mpi_real4,mpi_status
+use mpimod, only: mpi_comm_world
use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio, fgfileprefixes, &
fv3fixpath, nx_res,ny_res, ntiles,l_fv3reg_filecombined,paranc, &
- fv3_io_layout_nx,fv3_io_layout_ny
+ fv3_io_layout_nx,fv3_io_layout_ny,taperanalperts,taperanalperts_akbot, &
+ taperanalperts_aktop
use kinds, only: r_kind, i_kind, r_double, r_single
use constants, only: one,zero,pi,cp,rd,grav,rearth,max_varname_length
@@ -64,6 +66,7 @@ module gridinfo
public :: ak,bk,eta1_ll,eta2_ll
real(r_single),public :: ptop
real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd
+real(r_single),public, allocatable, dimension(:) :: taper_vert
! arrays passed to kdtree2 routines must be single
real(r_single),public, allocatable, dimension(:,:) :: gridloc
real(r_single),public, allocatable, dimension(:,:) :: logp
@@ -71,13 +74,15 @@ module gridinfo
integer(i_kind),public :: npts
integer(i_kind),public :: ntrunc
! supported variable names in anavinfo
-character(len=max_varname_length),public, dimension(15) :: &
+character(len=max_varname_length),public, dimension(16) :: &
vars3d_supported = [character(len=max_varname_length) :: &
'u', 'v', 'w', 't', 'q', 'oz', 'cw', 'tsen', 'prse', &
- 'ql', 'qi', 'qr', 'qs', 'qg', 'qnr']
+ 'ql', 'qi', 'qr', 'qs', 'qg', 'qnr','dbz']
character(len=max_varname_length),public, dimension(3) :: &
vars2d_supported = [character(len=max_varname_length) :: &
'ps', 'pst', 'sst']
+character(len=max_varname_length),public, dimension(8) :: &
+ vars2d_landonly = (/'', '', '', '', '', '', '', '' /)
real(r_single), allocatable, dimension(:) :: ak,bk,eta1_ll,eta2_ll
integer (i_kind),public,allocatable,dimension(:,:):: nxlocgroup,nylocgroup
integer(i_kind):: numproc_io_sub
@@ -130,7 +135,7 @@ subroutine getgridinfo(fileprefix, reducedgrid)
!when paranc=.false, fv3_io_layout_nx=fv3_io_layout_ny=1
! read data on root task
-if (nproc .eq. 0) then
+if (nproc == 0) then
! read ak,bk from ensmean fv_core.res.nc
! read nx,ny and nz from fv_core.res.nc
@@ -161,19 +166,35 @@ subroutine getgridinfo(fileprefix, reducedgrid)
eta2_ll(i)=bk(i)
enddo
-
-
-
ptop = eta1_ll(nlevsp1)
call nc_check( nf90_close(file_id),&
myname_,'close '//trim(filename) )
+
+ ! vertical taper function for ens perts
+ allocate(taper_vert(nlevs))
+ if (taperanalperts) then
+ do k=1,nlevs
+ if (k < nlevs/2 .and. (ak(k) <= taperanalperts_akbot .and. ak(k) >= taperanalperts_aktop)) then
+ taper_vert(nlevs-k+1)= log(ak(k) - taperanalperts_aktop)/log(taperanalperts_akbot - taperanalperts_aktop)
+ else if (bk(k) == zero .and. ak(k) < taperanalperts_aktop) then
+ taper_vert(nlevs-k+1) = zero
+ endif
+ enddo
+ print *,'vertical taper for anal perts:'
+ do k=1,nlevs
+ print *,k,ak(nlevs-k+1),bk(nlevs-k+1),taper_vert(k)
+ enddo
+ else
+ taper_vert = one
+ endif
+
deallocate(ak,bk)
endif ! root task
allocate(nxlocgroup(fv3_io_layout_nx,fv3_io_layout_ny))
allocate(nylocgroup(fv3_io_layout_nx,fv3_io_layout_ny))
-if(nproc.eq.0) then
+if(nproc == 0) then
ii=0
do j=1,fv3_io_layout_ny
do i=1,fv3_io_layout_nx
@@ -460,7 +481,7 @@ subroutine getgridinfo(fileprefix, reducedgrid)
allocate(gridloc(3,npts))
if (nproc .ne. 0) then
! allocate arrays on other (non-root) tasks
- allocate(latsgrd(npts),lonsgrd(npts))
+ allocate(latsgrd(npts),lonsgrd(npts),taper_vert(nlevs))
allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers
allocate(eta1_ll(nlevsp1),eta2_ll(nlevsp1))
endif
@@ -470,6 +491,7 @@ subroutine getgridinfo(fileprefix, reducedgrid)
enddo
call mpi_bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr)
call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr)
+call mpi_bcast(taper_vert,nlevs,mpi_real4,0,MPI_COMM_WORLD,ierr)
call mpi_bcast(eta1_ll,nlevsp1,mpi_real4,0,MPI_COMM_WORLD,ierr)
call mpi_bcast(eta2_ll,nlevsp1,mpi_real4,0,MPI_COMM_WORLD,ierr)
call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr)
@@ -486,6 +508,7 @@ end subroutine getgridinfo
subroutine gridinfo_cleanup()
if (allocated(lonsgrd)) deallocate(lonsgrd)
if (allocated(latsgrd)) deallocate(latsgrd)
+if (allocated(taper_vert)) deallocate(taper_vert)
if (allocated(logp)) deallocate(logp)
if (allocated(gridloc)) deallocate(gridloc)
end subroutine gridinfo_cleanup
diff --git a/src/enkf/gridinfo_gfs.f90 b/src/enkf/gridinfo_gfs.f90
index c2e2b10f57..efbd7a2959 100644
--- a/src/enkf/gridinfo_gfs.f90
+++ b/src/enkf/gridinfo_gfs.f90
@@ -45,7 +45,8 @@ module gridinfo
use mpisetup, only: nproc, mpi_integer, mpi_real4
use mpimod, only: mpi_comm_world
-use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio,use_gfs_ncio,fgfileprefixes
+use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio,use_gfs_ncio,fgfileprefixes,&
+ taperanalperts,taperanalperts_aktop,taperanalperts_akbot
use kinds, only: r_kind, i_kind, r_double, r_single
use constants, only: one,zero,pi,cp,rd,grav,rearth,max_varname_length
use specmod, only: sptezv_s, sptez_s, init_spec_vars, isinitialized, asin_gaulats, &
@@ -57,7 +58,7 @@ module gridinfo
public :: getgridinfo, gridinfo_cleanup
integer(i_kind),public :: nlevs_pres, idvc
real(r_single),public :: ptop
-real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd
+real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd, taper_vert
! arrays passed to kdtree2 routines must be single
real(r_single),public, allocatable, dimension(:,:) :: gridloc
real(r_single),public, allocatable, dimension(:,:) :: logp
@@ -66,7 +67,8 @@ module gridinfo
! supported variable names in anavinfo
character(len=max_varname_length),public, dimension(13) :: vars3d_supported = (/'u ', 'v ', 'tv ', 'q ', 'oz ', 'cw ', 'tsen', 'prse', &
'ql ', 'qi ', 'qr ', 'qs ', 'qg '/)
-character(len=max_varname_length),public, dimension(3) :: vars2d_supported = (/'ps ', 'pst', 'sst' /)
+character(len=max_varname_length),public, dimension(13) :: vars2d_supported = (/'ps ', 'pst', 'sst', 't2m', 'q2m', 'st1', 'st2', 'st3', 'st4', 'sl1', 'sl2', 'sl3', 'sl4' /)
+character(len=max_varname_length),public, dimension(8) :: vars2d_landonly = (/'st1', 'st2', 'st3', 'st4', 'sl1', 'sl2', 'sl3', 'sl4' /)
! supported variable names in anavinfo
contains
@@ -104,7 +106,7 @@ subroutine getgridinfo(fileprefix, reducedgrid)
kapr = cp/rd
kap1 = kap + one
nlevs_pres=nlevs+1
-if (nproc .eq. 0) then
+if (nproc == 0) then
filename = trim(adjustl(datapath))//trim(adjustl(fileprefix))//"ensmean"
if (use_gfs_nemsio) then
call nemsio_init(iret=iret)
@@ -167,11 +169,13 @@ subroutine getgridinfo(fileprefix, reducedgrid)
! initialize spectral module on all tasks.
if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4)
-if (nproc .eq. 0) then
+if (nproc == 0) then
! get pressure, lat/lon information from ensemble mean file.
allocate(presslmn(nlons*nlats,nlevs))
allocate(pressimn(nlons*nlats,nlevs+1))
allocate(spressmn(nlons*nlats))
+ allocate(taper_vert(nlevs))
+ taper_vert=one
if (use_gfs_nemsio) then
call nemsio_readrecv(gfile,'pres','sfc',1,nems_wrk,iret=iret)
if (iret/=0) then
@@ -220,7 +224,6 @@ subroutine getgridinfo(fileprefix, reducedgrid)
enddo
call nemsio_close(gfile, iret=iret)
ptop = ak(nlevs+1)
- deallocate(ak,bk)
else if (use_gfs_ncio) then
call read_vardata(dset, 'pressfc', values_2d,errcode=iret)
if (iret /= 0) then
@@ -237,7 +240,7 @@ subroutine getgridinfo(fileprefix, reducedgrid)
pressimn(:,k) = 0.01_r_kind*ak(nlevs-k+2)+bk(nlevs-k+2)*spressmn(:)
enddo
ptop = 0.01_r_kind*ak(1)
- deallocate(ak,bk,values_2d)
+ deallocate(values_2d)
else
! get pressure from ensemble mean,
! distribute to all processors.
@@ -277,7 +280,6 @@ subroutine getgridinfo(fileprefix, reducedgrid)
enddo
call sigio_axdata(sigdata,iret)
ptop = ak(nlevs+1)
- deallocate(ak,bk)
endif
if (reducedgrid) then
call reducedgrid_init(nlons,nlats,asin_gaulats)
@@ -333,11 +335,28 @@ subroutine getgridinfo(fileprefix, reducedgrid)
logp(:,nlevs_pres) = -log(spressmn(:))
endif
deallocate(spressmn,presslmn,pressimn)
+ ! vertical taper function for ens perts
+ if (taperanalperts) then
+ do k=1,nlevs
+ if (k < nlevs/2 .and. (ak(k) <= taperanalperts_akbot .and. ak(k) >= taperanalperts_aktop)) then
+ taper_vert(nlevs-k+1)= log(ak(k) - taperanalperts_aktop)/log(taperanalperts_akbot - taperanalperts_aktop)
+ else if (bk(k) == zero .and. ak(k) < taperanalperts_aktop) then
+ taper_vert(nlevs-k+1) = zero
+ endif
+ enddo
+ print *,'vertical taper for anal perts:'
+ do k=1,nlevs
+ print *,k,ak(nlevs-k+1),bk(nlevs-k+1),taper_vert(k)
+ enddo
+ endif
+ if (allocated(ak)) deallocate(ak)
+ if (allocated(bk)) deallocate(bk)
end if
call mpi_bcast(npts,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
if (nproc .ne. 0) then
! allocate arrays on other (non-root) tasks
allocate(latsgrd(npts),lonsgrd(npts))
+ allocate(taper_vert(nlevs))
allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers
allocate(gridloc(3,npts))
! initialize reducedgrid_mod on other tasks.
@@ -351,6 +370,7 @@ subroutine getgridinfo(fileprefix, reducedgrid)
enddo
call mpi_bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr)
call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr)
+call mpi_bcast(taper_vert,nlevs,mpi_real4,0,MPI_COMM_WORLD,ierr)
call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr)
!==> precompute cartesian coords of analysis grid points.
do nn=1,npts
@@ -364,6 +384,7 @@ end subroutine getgridinfo
subroutine gridinfo_cleanup()
if (allocated(lonsgrd)) deallocate(lonsgrd)
if (allocated(latsgrd)) deallocate(latsgrd)
+if (allocated(taper_vert)) deallocate(taper_vert)
if (allocated(logp)) deallocate(logp)
if (allocated(gridloc)) deallocate(gridloc)
end subroutine gridinfo_cleanup
diff --git a/src/enkf/gridinfo_nmmb.f90 b/src/enkf/gridinfo_nmmb.f90
index d60b077f36..33b487354e 100644
--- a/src/enkf/gridinfo_nmmb.f90
+++ b/src/enkf/gridinfo_nmmb.f90
@@ -1,6 +1,7 @@
module gridinfo
-use mpisetup
+use mpisetup, only: nproc, mpi_integer, mpi_real4
+use mpimod, only: mpi_comm_world
use params, only: datapath,nlevs,datestring,&
nmmb,regional,nlons,nlats,nbackgrounds,fgfileprefixes
use kinds, only: r_kind, i_kind, r_double, r_single
@@ -16,6 +17,7 @@ module gridinfo
integer(i_kind),public :: nlevs_pres
real(r_single),public :: ptop
real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd
+real(r_single),public, allocatable, dimension(:) :: taper_vert
! arrays passed to kdtree2 routines must be single
real(r_single),public, allocatable, dimension(:,:) :: gridloc
real(r_single),public, allocatable, dimension(:,:) :: logp
@@ -25,6 +27,8 @@ module gridinfo
'cw', 'prse', 'ql', 'qr', 'qi', &
'qli', 'dbz', 'w'/)
character(len=max_varname_length),public, dimension(2) :: vars2d_supported = (/ 'ps', 'sst' /)
+character(len=max_varname_length),public, dimension(8) :: vars2d_landonly = (/'', '', '', '', '', '', '', '' /)
+
contains
subroutine getgridinfo(fileprefix, reducedgrid)
@@ -122,6 +126,8 @@ subroutine getgridinfo(fileprefix, reducedgrid)
allocate(latsgrd(npts),lonsgrd(npts))
allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers
allocate(gridloc(3,npts))
+ allocate(taper_vert(nlevs))
+ taper_vert=one
lonsgrd = lons; latsgrd = lats
print *,'min/max lonsgrd',minval(lonsgrd),maxval(lonsgrd)
print *,'min/max latsgrd',minval(latsgrd),maxval(latsgrd)
@@ -163,6 +169,7 @@ subroutine getgridinfo(fileprefix, reducedgrid)
if (nproc .ne. 0) then
! allocate arrays on other (non-root) tasks
allocate(latsgrd(npts),lonsgrd(npts))
+ allocate(taper_vert(nlevs))
allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers
allocate(gridloc(3,npts))
endif
@@ -172,6 +179,7 @@ subroutine getgridinfo(fileprefix, reducedgrid)
enddo
call mpi_bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr)
call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr)
+call mpi_bcast(taper_vert,nlevs,mpi_real4,0,MPI_COMM_WORLD,ierr)
call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr)
!==> precompute cartesian coords of analysis grid points.
@@ -186,6 +194,7 @@ end subroutine getgridinfo
subroutine gridinfo_cleanup()
if (allocated(lonsgrd)) deallocate(lonsgrd)
if (allocated(latsgrd)) deallocate(latsgrd)
+if (allocated(taper_vert)) deallocate(taper_vert)
if (allocated(logp)) deallocate(logp)
if (allocated(gridloc)) deallocate(gridloc)
end subroutine gridinfo_cleanup
diff --git a/src/enkf/gridinfo_wrf.f90 b/src/enkf/gridinfo_wrf.f90
index f4f68a64c4..4ad80aaa60 100644
--- a/src/enkf/gridinfo_wrf.f90
+++ b/src/enkf/gridinfo_wrf.f90
@@ -32,12 +32,13 @@ module gridinfo
! Define associated modules
- use constants, only: rearth_equator, omega, pi, deg2rad, zero, rad2deg, &
+ use constants, only: rearth_equator, omega, pi, deg2rad, zero, one, rad2deg, &
rearth,max_varname_length
use kinds, only: i_kind, r_kind, r_single, i_long, r_double
use params, only: datapath, nlevs, nlons, nlats, &
arw, nmm
- use mpisetup
+ use mpisetup, only: nproc, mpi_integer, mpi_real4,mpi_status
+ use mpimod, only: mpi_comm_world
use netcdf_io
implicit none
@@ -63,6 +64,7 @@ module gridinfo
real(r_single), dimension(:,:), allocatable, public :: gridloc
real(r_single), dimension(:), allocatable, public :: lonsgrd
real(r_single), dimension(:), allocatable, public :: latsgrd
+ real(r_single), dimension(:), allocatable, public :: taper_vert
real(r_single), public :: ptop
integer(i_long), public :: npts
integer(i_kind), public :: nlevs_pres
@@ -77,6 +79,8 @@ module gridinfo
! supported variable names in anavinfo
character(len=max_varname_length),public, dimension(19) :: vars3d_supported = (/'u ', 'v ', 'tv ', 'q ', 'w ', 'cw ', 'ph ', 'ql ', 'qr ', 'qs ', 'qg ', 'qi ', 'qni ', 'qnr ', 'qnc ', 'dbz ', 'oz ', 'tsen', 'prse' /)
character(len=max_varname_length),public, dimension(2) :: vars2d_supported = (/ 'ps ', 'sst' /)
+ character(len=max_varname_length),public, dimension(8) :: vars2d_landonly = (/'', '', '', '', '', '', '', '' /)
+
contains
@@ -209,7 +213,9 @@ subroutine getgridinfo_arw(fileprefix)
! Allocate memory for global arrays
if(.not. allocated(lonsgrd)) allocate(lonsgrd(npts))
if(.not. allocated(latsgrd)) allocate(latsgrd(npts))
+ if(.not. allocated(taper_vert)) allocate(taper_vert(nlevs))
if(.not. allocated(logp)) allocate(logp(npts,nlevs_pres))
+ taper_vert = one
!======================================================================
! Begin: Ingest all grid variables required for EnKF routines and
@@ -846,6 +852,7 @@ end subroutine dot2cross
subroutine gridinfo_cleanup()
if (allocated(lonsgrd)) deallocate(lonsgrd)
if (allocated(latsgrd)) deallocate(latsgrd)
+ if (allocated(taper_vert)) deallocate(taper_vert)
if (allocated(logp)) deallocate(logp)
if (allocated(gridloc)) deallocate(gridloc)
end subroutine gridinfo_cleanup
diff --git a/src/enkf/gridio_fv3reg.f90 b/src/enkf/gridio_fv3reg.f90
index fb23a21a0c..068e6cba8b 100644
--- a/src/enkf/gridio_fv3reg.f90
+++ b/src/enkf/gridio_fv3reg.f90
@@ -24,6 +24,8 @@ module gridio
! -- add code to update 'delp' directly
! from analysis icnrements
! 2022-06- Ting -- Implement paranc=.true. for fv3-lam
+ ! 2022-04-01 Yongming Wang and X. Wang: Add interface for read in dBZ
+ ! poc: xuguang.wang@ou.edu
! attributes:
! language: f95
!
@@ -40,7 +42,7 @@ module gridio
use params, only: nlevs, cliptracers, datapath, arw, nmm, datestring
use params, only: nx_res,ny_res,nlevs,ntiles,l_fv3reg_filecombined,&
fv3_io_layout_nx,fv3_io_layout_ny,nanals
- use params, only: pseudo_rh, l_use_enkf_directZDA
+ use params, only: pseudo_rh
use mpeu_util, only: getindex
use read_fv3regional_restarts,only:read_fv3_restart_data1d,read_fv3_restart_data2d
use read_fv3regional_restarts,only:read_fv3_restart_data3d,read_fv3_restart_data4d
@@ -60,17 +62,19 @@ module gridio
!-------------------------------------------------------------------------
- integer(i_kind) ,parameter:: ndynvarslist=6, ntracerslist=8
+ integer(i_kind) ,parameter:: ndynvarslist=6, ntracerslist=8, nphysicslist=1
character(len=max_varname_length), parameter, dimension(ndynvarslist) :: &
vardynvars = [character(len=max_varname_length) :: &
'u', 'v', 'T', 'W', 'DZ', 'delp']
character(len=max_varname_length), parameter, dimension(ntracerslist) :: &
vartracers = [character(len=max_varname_length) :: &
'sphum','o3mr', 'liq_wat','ice_wat','rainwat','snowwat','graupel','rain_nc']
+ character(len=max_varname_length), parameter, dimension(nphysicslist) :: &
+ varphysics = [character(len=max_varname_length) :: 'ref_f3d']
type type_fv3lamfile
logical l_filecombined
- character(len=max_varname_length), dimension(2):: fv3lamfilename
- integer (i_kind), dimension(2):: fv3lam_fileid(2)
+ character(len=max_varname_length), dimension(3):: fv3lamfilename
+ integer (i_kind), dimension(3):: fv3lam_fileid
contains
procedure, pass(this) :: setupfile => type_bound_setupfile
procedure, pass(this):: get_idfn => type_bound_getidfn
@@ -104,9 +108,9 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
! Define local variables
character(len=500) :: filename
- character(len=:),allocatable :: fv3filename,fv3filename1
+ character(len=:),allocatable :: fv3filename,fv3filename1,fv3filename2
character(len=7) :: charnanal
- integer(i_kind) file_id,file_id1
+ integer(i_kind) file_id,file_id1,file_id2
real(r_single), dimension(:,:,:), allocatable ::workvar3d,uworkvar3d,&
vworkvar3d,tvworkvar3d,tsenworkvar3d,&
workprsi,qworkvar3d
@@ -124,6 +128,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
integer(i_kind) :: nlevsp1
integer (i_kind):: i,j, k,nn,ntile,nn_tile0, nb,nanal,ne
integer(i_kind) :: u_ind, v_ind, tv_ind,tsen_ind, q_ind, oz_ind
+ integer(i_kind) :: dbz_ind
integer(i_kind) :: w_ind, ql_ind, qi_ind, qr_ind, qs_ind, qg_ind, qnr_ind
integer (i_kind):: ps_ind, sst_ind
integer (i_kind):: tmp_ind,ifile
@@ -147,6 +152,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
qs_ind = getindex(vars3d, 'qs') ! Q snow (3D)
qg_ind = getindex(vars3d, 'qg') ! Q graupel (3D)
qnr_ind = getindex(vars3d, 'qnr') ! N rain (3D)
+ dbz_ind = getindex(vars3d, 'dbz') ! Reflectivity (3D)
ps_ind = getindex(vars2d, 'ps') ! Ps (2D)
sst_ind = getindex(vars2d, 'sst') ! SST (2D)
@@ -191,9 +197,19 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
fv3filename1=trim(adjustl(filename))//"_tracer"
call nc_check( nf90_open(trim(adjustl(fv3filename1)),nf90_nowrite,file_id1),&
myname_,'open: '//trim(adjustl(fv3filename1)) )
- call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , &
- fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)) )
-
+ if(dbz_ind > 0) then
+ fv3filename2=trim(adjustl(filename))//"_phyvar"
+ call nc_check(nf90_open(trim(adjustl(fv3filename2)),nf90_nowrite,file_id2),&
+ myname_,'open: '//trim(adjustl(fv3filename2)) )
+ endif
+ if(dbz_ind > 0) then
+ call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , &
+ fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)),&
+ fileid3=file_id2,fv3fn3=trim(adjustl(fv3filename2)))
+ else
+ call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , &
+ fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)))
+ endif
endif
!----------------------------------------------------------------------
@@ -476,6 +492,27 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
endif
+ if (dbz_ind > 0) then
+ varstrname = 'ref_f3d'
+ call fv3lamfile%get_idfn(varstrname,file_id,fv3filename)
+ call read_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d)
+ do k=1,nlevs
+ nn = nn_tile0
+ do j=1,ny_res
+ do i=1,nx_res
+ nn=nn+1
+ vargrid(nn,levels(dbz_ind-1)+k,nb,ne)=max(workvar3d(i,j,nlevs+1-k),0.0_r_kind)
+ enddo
+ enddo
+ enddo
+ do k = levels(dbz_ind-1)+1, levels(dbz_ind)
+ if (nproc .eq. 0) &
+ write(6,*) 'READFVregional : dbz ', &
+ & k, minval(vargrid(:,k,nb,ne)), maxval(vargrid(:,k,nb,ne))
+ enddo
+
+ endif
+
! set SST to zero for now
if (sst_ind > 0) then
vargrid(:,levels(n3d)+sst_ind,nb,ne) = zero
@@ -549,7 +586,8 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
call nc_check( nf90_close(file_id),&
myname_,'close '//trim(filename) )
else
- do ifile=1,2
+ do ifile=1,3
+ if(dbz_ind <= 0 .and. ifile == 3) cycle
file_id=fv3lamfile%fv3lam_fileid(ifile)
filename=fv3lamfile%fv3lamfilename(ifile)
call nc_check( nf90_close(file_id),&
@@ -601,15 +639,15 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
!----------------------------------------------------------------------
! Define variables computed within subroutine
character(len=500) :: filename
- character(len=:),allocatable :: fv3filename,fv3filename1
+ character(len=:),allocatable :: fv3filename,fv3filename1,fv3filename2
character(len=7) :: charnanal
!----------------------------------------------------------------------
- integer(i_kind) :: u_ind, v_ind, tv_ind, tsen_ind,q_ind, ps_ind,oz_ind
- integer(i_kind) :: w_ind
+ integer(i_kind) :: u_ind, v_ind, tv_ind, tsen_ind,q_ind, ps_ind,oz_ind,dbz_ind
+ integer(i_kind) :: w_ind, cw_ind, ph_ind
integer(i_kind) :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind, qnr_ind
- integer(i_kind) file_id,file_id1
+ integer(i_kind) file_id,file_id1,file_id2
real(r_single), dimension(:,:), allocatable ::pswork
real(r_single), dimension(:,:,:), allocatable ::workvar3d,workinc3d,workinc3d2,uworkvar3d,&
vworkvar3d,tvworkvar3d,tsenworkvar3d,&
@@ -652,10 +690,11 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
qs_ind = getindex(vars3d, 'qs') ! QS (3D) for FV3
qg_ind = getindex(vars3d, 'qg') ! QG (3D) for FV3
qnr_ind = getindex(vars3d, 'qnr') ! QNR (3D) for FV3
+ dbz_ind = getindex(vars3d, 'dbz') ! Reflectivity (3D)
ps_ind = getindex(vars2d, 'ps') ! Ps (2D)
-
+ clip=tiny(clip)
!----------------------------------------------------------------------
if (nbackgrounds > 1) then
write(6,*)'gridio/writegriddata: writing multiple backgrounds not yet supported'
@@ -699,6 +738,15 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , &
fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)) )
+ if(dbz_ind > 0) then
+ call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , &
+ fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)),&
+ fileid3=file_id2,fv3fn3=trim(adjustl(fv3filename2)))
+ else
+ call fv3lamfile%setupfile(fileid1=file_id,fv3fn1=trim(adjustl(fv3filename)) , &
+ fileid2=file_id1,fv3fn2=trim(adjustl(fv3filename1)))
+ endif
+
endif
@@ -805,6 +853,8 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
varstrname = 'sphum'
call fv3lamfile%get_idfn(varstrname,file_id,fv3filename)
call read_fv3_restart_data3d(varstrname,fv3filename,file_id,qworkvar3d)
+ !enforce lower positive bound (clip) to replace negative hydrometers
+ if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip
tvworkvar3d=tsenworkvar3d*(one+fv*qworkvar3d)
tvworkvar3d=tvworkvar3d+workinc3d
if(q_ind > 0) then
@@ -818,6 +868,8 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
enddo
enddo
qworkvar3d=qworkvar3d+workinc3d
+ !enforce lower positive bound (clip) to replace negative q
+ if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip
endif
tsenworkvar3d=tvworkvar3d/(one+fv*qworkvar3d)
varstrname = 'T'
@@ -884,10 +936,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d)
endif
@@ -907,10 +956,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d)
endif
@@ -930,10 +976,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d)
endif
@@ -953,10 +996,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d)
endif
@@ -976,10 +1016,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d)
endif
@@ -998,10 +1035,26 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
+ call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d)
+
+ endif
+
+ if (dbz_ind > 0) then
+ varstrname = 'ref_f3d'
+ call fv3lamfile%get_idfn(varstrname,file_id,fv3filename)
+ call read_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d)
+ do k=1,nlevs
+ nn = nn_tile0
+ do j=1,ny_res
+ do i=1,nx_res
+ nn=nn+1
+ workinc3d(i,j,nlevs+1-k)=vargrid(nn,levels(dbz_ind-1)+k,nb,ne)
+ enddo
+ enddo
+ enddo
+ workvar3d=workvar3d+workinc3d
+ where (workvar3d < 0.0_r_kind) workvar3d = 0.0_r_kind
call write_fv3_restart_data3d(varstrname,fv3filename,file_id,workvar3d)
endif
@@ -1051,7 +1104,8 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,vargrid
call nc_check( nf90_close(file_id),&
myname_,'close '//trim(filename) )
else
- do ifile=1,2
+ do ifile=1,3
+ if(dbz_ind <=0 .and. ifile == 3) cycle
file_id=fv3lamfile%fv3lam_fileid(ifile)
filename=fv3lamfile%fv3lamfilename(ifile)
call nc_check( nf90_close(file_id),&
@@ -1820,7 +1874,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat
ps_ind = getindex(vars2d, 'ps') ! Ps (2D)
-
+ clip=tiny(clip)
allocate(my_neb(4))
!----------------------------------------------------------------------
if (nbackgrounds > 1) then
@@ -2105,6 +2159,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat
enddo
if(iope ==0 ) then
+ if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip
tvworkvar3d=tsenworkvar3d*(one+fv*qworkvar3d)
tvworkvar3d=tvworkvar3d+workinc3d
if(q_ind > 0) then
@@ -2118,6 +2173,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat
enddo
enddo
qworkvar3d=qworkvar3d+workinc3d
+ if ( cliptracers ) where (qworkvar3d < clip) qworkvar3d = clip
endif
tsenworkvar3d=tvworkvar3d/(one+fv*qworkvar3d)
endif
@@ -2213,10 +2269,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
endif
do k=1,nlevs
call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,&
@@ -2247,10 +2300,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
endif
do k=1,nlevs
call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,&
@@ -2281,10 +2331,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
endif
do k=1,nlevs
call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,&
@@ -2315,10 +2362,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
endif
do k=1,nlevs
call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,&
@@ -2349,10 +2393,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
endif
do k=1,nlevs
call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,&
@@ -2382,10 +2423,7 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat
enddo
enddo
workvar3d=workvar3d+workinc3d
- if ( l_use_enkf_directZDA .and. cliptracers ) then ! set cliptracers to remove negative hydrometers
- clip = tiny(workvar3d(1,1,1))
- where (workvar3d < clip) workvar3d = clip
- end if
+ if ( cliptracers ) where (workvar3d < clip) workvar3d = clip
endif
do k=1,nlevs
call mpi_scatterv(workvar3d(:,:,k),recvcounts2d,displs2d,mpi_real4,&
@@ -2478,19 +2516,23 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,vargrid,no_inflat
! Return calculated values
return
end subroutine writegriddata_pnc
-subroutine type_bound_setupfile(this,fileid1,fv3fn1,fileid2,fv3fn2)
+subroutine type_bound_setupfile(this,fileid1,fv3fn1,fileid2,fv3fn2,fileid3,fv3fn3)
implicit none
class (type_fv3lamfile) :: this
integer(i_kind) fileid1
- integer(i_kind), optional :: fileid2
+ integer(i_kind), optional :: fileid2,fileid3
character(len=*)::fv3fn1
- character(len=*),optional ::fv3fn2
+ character(len=*),optional ::fv3fn2,fv3fn3
if (present (fileid2)) then
this%l_filecombined=.false.
this%fv3lamfilename(1)=trim(fv3fn1)
this%fv3lamfilename(2)=trim(fv3fn2)
this%fv3lam_fileid(1)=fileid1
this%fv3lam_fileid(2)=fileid2
+ if (present (fileid3)) then
+ this%fv3lamfilename(3)=trim(fv3fn3)
+ this%fv3lam_fileid(3)=fileid3
+ endif
else
this%l_filecombined=.true.
this%fv3lamfilename(1)=fv3fn1
@@ -2509,6 +2551,9 @@ subroutine type_bound_getidfn(this,vnamloc,fileid,fv3fn)
else if(ifindstrloc(vartracers,vnamloc)> 0) then
fv3fn=trim(this%fv3lamfilename(2))
fileid=this%fv3lam_fileid(2)
+ else if(ifindstrloc(varphysics,vnamloc)> 0) then
+ fv3fn=trim(this%fv3lamfilename(3))
+ fileid=this%fv3lam_fileid(3)
else
write(6,*)"the varname ",trim(vnamloc)," is not recognized in the ype_bound_getidfn, stop"
call stop2(23)
diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90
index fe5199e395..35a0c3fbe4 100644
--- a/src/enkf/gridio_gfs.f90
+++ b/src/enkf/gridio_gfs.f90
@@ -35,6 +35,7 @@ module gridio
! a required input for EFSO calculations
! 2019-03-13 Add precipitation components
! 2019-07-10 Add convective clouds
+! 2022-07-21 Draper: added read/write for sfc file for nc io (writeincrements, and readgridata)
!
! attributes:
! language: f95
@@ -88,24 +89,33 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
real(r_kind), dimension(ndimspec) :: vrtspec,divspec
real(r_kind), allocatable, dimension(:) :: psg,pstend,ak,bk
real(r_single),allocatable,dimension(:,:,:) :: ug3d,vg3d
- type(Dataset) :: dset
+ type(Dataset) :: dset, dset_sfc
type(Dimension) :: londim,latdim,levdim
integer(i_kind) :: u_ind, v_ind, tv_ind, q_ind, oz_ind, cw_ind
integer(i_kind) :: qr_ind, qs_ind, qg_ind
integer(i_kind) :: tsen_ind, ql_ind, qi_ind, prse_ind
integer(i_kind) :: ps_ind, pst_ind, sst_ind
+ ! surface
+ integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind
+ integer(i_kind) :: soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind
integer(i_kind) :: k,iret,nb,i,imem,idvc,nlonsin,nlatsin,nlevsin,ne,nanal
+ ! surface
+ integer(i_kind) :: nlonsin_sfc,nlatsin_sfc
+
logical ice
logical use_full_hydro
integer(i_kind), allocatable, dimension(:) :: mem_pe, lev_pe1, lev_pe2, iocomms
- integer(i_kind) :: iope, ionumproc, iolevs, krev
+ integer(i_kind) :: iope, ionumproc, iolevs, krev, ierr
integer(i_kind) :: ncstart(3), nccount(3)
! mpi gatherv things
integer(i_kind), allocatable, dimension(:) :: recvcounts, displs
real(r_single), dimension(nlons,nlats,nlevs) :: ug3d_0, vg3d_0
+ logical :: read_sfc_file, read_atm_file
+
+ call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, read_sfc_file, read_atm_file)
! figure out what member to read and do MPI sub-communicator things
allocate(mem_pe(0:numproc-1))
@@ -142,6 +152,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
displs(i+1) = ((lev_pe1(i)-1)*nlons*nlats)
end do
+ if (read_atm_file) then
! loop through times and do the read
ne = 1
@@ -149,7 +160,6 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
write(charnanal,'(a3, i3.3)') 'mem', nanal
filename = trim(adjustl(datapath))//trim(adjustl(fileprefixes(nb)))//trim(charnanal)
- sfcfilename = trim(adjustl(datapath))//trim(adjustl(filesfcprefixes(nb)))//trim(charnanal)
if (use_gfs_ncio) then
dset = open_dataset(filename, paropen=.true., mpicomm=iocomms(mem_pe(nproc)))
londim = get_dim(dset,'grid_xt'); nlonsin = londim%len
@@ -157,7 +167,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
levdim = get_dim(dset,'pfull'); nlevsin = levdim%len
idvc=2
else
- print *, 'parallel read only supported for netCDF, stopping with error'
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** parallel read only supported for netCDF' , ' PROGRAM STOPS'
call stop2(23)
end if
ice = .false. ! calculate qsat w/resp to ice?
@@ -185,6 +195,9 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
sst_ind = getindex(vars2d, 'sst')
use_full_hydro = ( ql_ind > 0 .and. qi_ind > 0 .and. &
qr_ind > 0 .and. qs_ind > 0 .and. qg_ind > 0 )
+ ! Currently, we do not let precipiation to affect the enkf analysis
+ ! The following line will be removed after testing
+ use_full_hydro = .false.
if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4)
@@ -195,7 +208,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
call read_vardata(dset, 'pressfc', values_2d,errcode=iret)
if (iret /= 0) then
- print *,'error reading ps'
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading ps, iret= ',iret,' PROGRAM STOPS'
call stop2(31)
endif
psg = 0.01_r_kind*reshape(values_2d,(/nlons*nlats/))
@@ -215,12 +228,12 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
call read_vardata(dset, 'ugrd', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret)
if (iret /= 0) then
- print *,'error reading ugrd'
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading ugrd, iret= ',iret,' PROGRAM STOPS'
call stop2(22)
endif
call read_vardata(dset, 'vgrd', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret)
if (iret /= 0) then
- print *,'error reading vgrd'
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading vgrd, iret= ',iret,' PROGRAM STOPS'
call stop2(23)
endif
call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,&
@@ -247,12 +260,12 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
end if
call read_vardata(dset,'tmp', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret)
if (iret /= 0) then
- print *,'error reading tmp'
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading tmp, iret= ',iret,' PROGRAM STOPS'
call stop2(24)
endif
call read_vardata(dset,'spfh', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret)
if (iret /= 0) then
- print *,'error reading spfh'
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading spfh, iret= ',iret,' PROGRAM STOPS'
call stop2(25)
endif
call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,&
@@ -276,7 +289,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
if (oz_ind > 0) then
call read_vardata(dset, 'o3mr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret)
if (iret /= 0) then
- print *,'error reading o3mr'
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading o3mr, iret= ',iret,' PROGRAM STOPS'
call stop2(26)
endif
if (cliptracers) where (ug3d < clip) ug3d = clip
@@ -290,31 +303,122 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
end do
end if
endif
- if (cw_ind > 0 .or. ql_ind > 0 .or. qi_ind > 0) then
- call read_vardata(dset, 'clwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret)
- if (iret /= 0) then
- print *,'error reading clwmr'
- call stop2(27)
+ ! Read in hydrometeor fields based on control/state variables listed in anavinfo table
+ if (use_full_hydro) then
+ if(ql_ind > 0) then
+ call read_vardata(dset, 'clwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if (iret /= 0) then
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading clwmr, iret= ',iret,' PROGRAM STOPS'
+ call stop2(26)
+ endif
+ if (cliptracers) where (ug3d < clip) ug3d = clip
+ call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,&
+ mpi_real4, 0, iocomms(mem_pe(nproc)),iret)
+ if (iope==0) then
+ do k=1,nlevs
+ krev = nlevs-k+1
+ ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(ql_ind-1)+k,nb,ne))
+ end do
+ end if
endif
- if (imp_physics == 11) then
- call read_vardata(dset, 'icmr', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if(qi_ind > 0) then
+ call read_vardata(dset, 'icmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret)
if (iret /= 0) then
- print *,'error reading icmr'
- call stop2(28)
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading icmr, iret= ',iret,' PROGRAM STOPS'
+ call stop2(26)
endif
- ug3d = ug3d + vg3d
+ if (cliptracers) where (ug3d < clip) ug3d = clip
+ call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,&
+ mpi_real4, 0, iocomms(mem_pe(nproc)),iret)
+ if (iope==0) then
+ do k=1,nlevs
+ krev = nlevs-k+1
+ ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(qi_ind-1)+k,nb,ne))
+ end do
+ end if
+ endif
+ if(qr_ind > 0) then
+ call read_vardata(dset, 'rwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if (iret /= 0) then
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading rwmr, iret= ',iret,' PROGRAM STOPS'
+ call stop2(26)
+ endif
+ if (cliptracers) where (ug3d < clip) ug3d = clip
+ call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,&
+ mpi_real4, 0, iocomms(mem_pe(nproc)),iret)
+ if (iope==0) then
+ do k=1,nlevs
+ krev = nlevs-k+1
+ ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(qr_ind-1)+k,nb,ne))
+ end do
+ end if
+ endif
+ if(qs_ind > 0) then
+ call read_vardata(dset, 'snmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if (iret /= 0) then
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading snmr, iret= ',iret,' PROGRAM STOPS'
+ call stop2(26)
+ endif
+ if (cliptracers) where (ug3d < clip) ug3d = clip
+ call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,&
+ mpi_real4, 0, iocomms(mem_pe(nproc)),iret)
+ if (iope==0) then
+ do k=1,nlevs
+ krev = nlevs-k+1
+ ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(qs_ind-1)+k,nb,ne))
+ end do
+ end if
+ endif
+ if(qg_ind > 0) then
+ call read_vardata(dset, 'grle', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if (iret /= 0) then
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading grle, iret= ',iret,' PROGRAM STOPS'
+ call stop2(26)
+ endif
+ if (cliptracers) where (ug3d < clip) ug3d = clip
+ call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,&
+ mpi_real4, 0, iocomms(mem_pe(nproc)),iret)
+ if (iope==0) then
+ do k=1,nlevs
+ krev = nlevs-k+1
+ ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(qg_ind-1)+k,nb,ne))
+ end do
+ end if
+ endif
+ else
+ ! Handle non-precipiting hydrometeors
+ ! if control or state variable is cw, make sure combine background ql and qi to cw
+ if (cw_ind > 0 .or. ql_ind > 0 .or. qi_ind > 0) then
+ call read_vardata(dset, 'clwmr', ug3d, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if (iret /= 0) then
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading clwmr, iret= ',iret,' PROGRAM STOPS'
+ call stop2(27)
+ endif
+ if (imp_physics == 11) then
+ call read_vardata(dset, 'icmr', vg3d, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if (iret /= 0) then
+ write(6,*)'READGRIDDATA_PNC: ***FATAL ERROR*** reading icmr, iret= ',iret,' PROGRAM STOPS'
+ call stop2(28)
+ endif
+ ug3d = ug3d + vg3d
+ endif
+ if (cliptracers) where (ug3d < clip) ug3d = clip
+ call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,&
+ mpi_real4, 0, iocomms(mem_pe(nproc)),iret)
+ if (iope==0) then
+ do k=1,nlevs
+ krev = nlevs-k+1
+ ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/))
+ call copytogrdin(ug,cw(:,k))
+ if (cw_ind > 0) grdin(:,levels(cw_ind-1)+k,nb,ne) = cw(:,k)
+ end do
+ end if
endif
- if (cliptracers) where (ug3d < clip) ug3d = clip
- call mpi_gatherv(ug3d, recvcounts(iope+1), mpi_real4, ug3d_0, recvcounts, displs,&
- mpi_real4, 0, iocomms(mem_pe(nproc)),iret)
- if (iope==0) then
- do k=1,nlevs
- krev = nlevs-k+1
- ug = reshape(ug3d_0(:,:,krev),(/nlons*nlats/))
- call copytogrdin(ug,cw(:,k))
- if (cw_ind > 0) grdin(:,levels(cw_ind-1)+k,nb,ne) = cw(:,k)
- end do
- end if
endif
deallocate(ug3d,vg3d)
@@ -355,22 +459,25 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
end if
! cloud derivatives
+ ! Currently, we do not let precipiation to affect the enkf analysis
+ ! The following line will be removed after testing
+ use_full_hydro = .true.
if (.not. use_full_hydro .and. iope==0) then
- if (ql_ind > 0 .or. qi_ind > 0) then
- do k=1,nlevs
- do i = 1, npts
- qi_coef = -r0_05*(tv(i,k)/(one+fv*q(i,k))-t0c)
- qi_coef = max(zero,qi_coef)
- qi_coef = min(one,qi_coef) ! 0<=qi_coef<=1
- if (ql_ind > 0) then
- grdin(i,levels(ql_ind-1)+k,nb,ne) = cw(i,k)*(one-qi_coef)
- endif
- if (qi_ind > 0) then
- grdin(i,levels(qi_ind-1)+k,nb,ne) = cw(i,k)*qi_coef
- endif
+ if (ql_ind > 0 .or. qi_ind > 0) then
+ do k=1,nlevs
+ do i = 1, npts
+ qi_coef = -r0_05*(tv(i,k)/(one+fv*q(i,k))-t0c)
+ qi_coef = max(zero,qi_coef)
+ qi_coef = min(one,qi_coef) ! 0<=qi_coef<=1
+ if (ql_ind > 0) then
+ grdin(i,levels(ql_ind-1)+k,nb,ne) = cw(i,k)*(one-qi_coef)
+ endif
+ if (qi_ind > 0) then
+ grdin(i,levels(qi_ind-1)+k,nb,ne) = cw(i,k)*qi_coef
+ endif
+ enddo
enddo
- enddo
- endif
+ endif
endif
if (sst_ind > 0 .and. iope==0) then
@@ -389,6 +496,141 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
end do backgroundloop ! loop over backgrounds to read in
+ end if !read_atm_file
+
+ if (read_sfc_file) then
+ ! loop through times and do the read
+ ne = 1
+ sfcbackgroundloop: do nb=1,ntimes
+
+ write(charnanal,'(a3, i3.3)') 'mem', nanal
+ sfcfilename = trim(adjustl(datapath))//trim(adjustl(filesfcprefixes(nb)))//trim(charnanal)
+ if (use_gfs_ncio) then
+ dset_sfc = open_dataset(sfcfilename, paropen=.true., mpicomm=iocomms(mem_pe(nproc)))
+ else
+ write(6,*)'READGRIDDATA_PNC sfc: ***FATAL ERROR*** parallel read only supported for netCDF' , ' PROGRAM STOPS'
+ call mpi_barrier(mpi_comm_world,ierr)
+ call mpi_finalize(ierr)
+ end if
+ if ( reducedgrid ) then
+ write(6,*) "READGRIDDATA_PNC sfc: reducedgrid=T interpolation not valid for writing sfc files"
+ call mpi_barrier(mpi_comm_world,ierr)
+ call mpi_finalize(ierr)
+ endif
+
+ ! land sfc DA variables
+ tmp2m_ind = getindex(vars2d, 't2m')
+ spfh2m_ind = getindex(vars2d, 'q2m')
+ soilt1_ind = getindex(vars2d, 'st1')
+ slc1_ind = getindex(vars2d, 'sl1')
+ soilt2_ind = getindex(vars2d, 'st2')
+ slc2_ind = getindex(vars2d, 'sl2')
+ soilt3_ind = getindex(vars2d, 'st3')
+ slc3_ind = getindex(vars2d, 'sl3')
+ soilt4_ind = getindex(vars2d, 'st4')
+ slc4_ind = getindex(vars2d, 'sl4')
+
+ ! read in sfc vars, if requested
+ if (tmp2m_ind > 0) then
+ call read_vardata(dset_sfc, 'tmp2m', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'READGRIDDATA_PNC: error reading tmp2m'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + tmp2m_ind,nb,ne))
+ endif
+ if (spfh2m_ind > 0) then
+ call read_vardata(dset_sfc, 'spfh2m', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'READGRIDDATA_PNC: error reading spfh2m'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + spfh2m_ind,nb,ne))
+ endif
+ if (soilt1_ind > 0) then
+ call read_vardata(dset_sfc, 'soilt1', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'READGRIDDATA_PNC: error reading soilt1'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt1_ind,nb,ne))
+ endif
+ if (soilt2_ind > 0) then
+ call read_vardata(dset_sfc, 'soilt2', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'READGRIDDATA_PNC: error reading soilt2'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt2_ind,nb,ne))
+ endif
+ if (soilt3_ind > 0) then
+ call read_vardata(dset_sfc, 'soilt3', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'READGRIDDATA_PNC: error reading soilt3'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt3_ind,nb,ne))
+ endif
+ if (soilt4_ind > 0) then
+ call read_vardata(dset_sfc, 'soilt4', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'READGRIDDATA_PNC: error reading soilt2'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt4_ind,nb,ne))
+ endif
+ if (slc1_ind > 0) then
+ call read_vardata(dset_sfc, 'soill1', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'READGRIDDATA_PNC: error reading soill1'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc1_ind,nb,ne))
+ endif
+ if (slc2_ind > 0) then
+ call read_vardata(dset_sfc, 'soill2', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'READGRIDDATA_PNC: error reading soill2'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc2_ind,nb,ne))
+ endif
+ if (slc3_ind > 0) then
+ call read_vardata(dset_sfc, 'soill3', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'READGRIDDATA_PNC: error reading soill3'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc3_ind,nb,ne))
+ endif
+ if (slc4_ind > 0) then
+ call read_vardata(dset_sfc, 'soill4', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'READGRIDDATA_PNC: error reading soill4'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc4_ind,nb,ne))
+ endif
+
+ ! bring all the subdomains back to the main PE
+ call mpi_barrier(iocomms(mem_pe(nproc)), iret)
+ if (allocated(values_2d)) deallocate(values_2d)
+ call close_dataset(dset_sfc)
+ call mpi_barrier(iocomms(mem_pe(nproc)), iret)
+
+ end do sfcbackgroundloop ! loop over backgrounds to read in
+ end if !if (read_sfc_file)
+
! remove the sub communicators
call mpi_barrier(iocomms(mem_pe(nproc)), iret)
call mpi_comm_free(iocomms(mem_pe(nproc)), iret)
@@ -457,7 +699,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
type(sigio_head) :: sighead
type(sigio_data) :: sigdata
type(nemsio_gfile) :: gfile
- type(Dataset) :: dset
+ type(Dataset) :: dset, dset_sfc
type(Dimension) :: londim,latdim,levdim
type(nemsio_gfile) :: gfilesfc
@@ -465,14 +707,20 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
integer(i_kind) :: qr_ind, qs_ind, qg_ind
integer(i_kind) :: tsen_ind, ql_ind, qi_ind, prse_ind
integer(i_kind) :: ps_ind, pst_ind, sst_ind
+ integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind
+ integer(i_kind) :: soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind
integer(i_kind) :: k,iunitsig,iret,nb,i,idvc,nlonsin,nlatsin,nlevsin,ne,nanal
integer(i_kind) :: nlonsin_sfc,nlatsin_sfc
logical ice
logical use_full_hydro
+ logical read_sfc_file, read_atm_file
use_full_hydro = .false.
+ ! determine which files will be read in
+ call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, read_sfc_file, read_atm_file)
+
ne = 0
ensmemloop: do nanal=nanal1,nanal2
ne = ne + 1
@@ -565,6 +813,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
! print *, 'ql: ', ql_ind, ', prse: ', prse_ind
! print *, 'ps: ', ps_ind, ', pst: ', pst_ind, ', sst: ', sst_ind
! endif
+ if (read_atm_file) then
if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4)
@@ -634,7 +883,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
pressi(:,k) = 0.01_r_kind*ak(nlevs-k+2)+bk(nlevs-k+2)*psg
if (nanal .eq. 1) print *,'netcdf, min/max pressi',k,minval(pressi(:,k)),maxval(pressi(:,k))
enddo
- deallocate(ak,bk,values_2d)
+ deallocate(ak,bk)
else
vrtspec = sigdata%ps
call sptez_s(vrtspec,psg,1)
@@ -812,6 +1061,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
endif ! use_full_hydro
enddo
else if (use_gfs_ncio) then
+ clip=tiny_r_kind
call read_vardata(dset, 'ugrd', ug3d,errcode=iret)
if (iret /= 0) then
print *,'error reading ugrd'
@@ -1003,10 +1253,134 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
deallocate(pressi,pslg)
deallocate(psg)
if (pst_ind > 0) deallocate(vmassdiv,pstend)
+ endif ! read_atm_file
+
if (use_gfs_nemsio) call nemsio_close(gfile,iret=iret)
if (use_gfs_ncio) call close_dataset(dset)
if (use_gfs_nemsio) call nemsio_close(gfilesfc,iret=iret)
+ if ( read_sfc_file ) then
+
+ if ( .not. use_gfs_ncio ) then
+ write(6,*) 'griddio/griddata for sfc update vars only coded for nc io'
+ call stop2(23)
+ endif
+ if ( reducedgrid ) then
+ write(6,*) "reducedgrid=T interpolation not valid for writing sfc files"
+ call stop2(22)
+ endif
+
+ ! land sfc DA variables
+ tmp2m_ind = getindex(vars2d, 't2m')
+ spfh2m_ind = getindex(vars2d, 'q2m')
+ soilt1_ind = getindex(vars2d, 'st1')
+ slc1_ind = getindex(vars2d, 'sl1')
+ soilt2_ind = getindex(vars2d, 'st2')
+ slc2_ind = getindex(vars2d, 'sl2')
+ soilt3_ind = getindex(vars2d, 'st3')
+ slc3_ind = getindex(vars2d, 'sl3')
+ soilt4_ind = getindex(vars2d, 'st4')
+ slc4_ind = getindex(vars2d, 'sl4')
+
+ dset_sfc = open_dataset(filenamesfc)
+ ! read in sfc vars, if requested
+ if (tmp2m_ind > 0) then
+ call read_vardata(dset_sfc, 'tmp2m', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'error reading tmp2m'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(n3d) + tmp2m_ind,nb,ne))
+ endif
+ if (spfh2m_ind > 0) then
+ call read_vardata(dset_sfc, 'spfh2m', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'error reading spfh2m'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(n3d) + spfh2m_ind,nb,ne))
+ endif
+ if (soilt1_ind > 0) then
+ call read_vardata(dset_sfc, 'soilt1', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'error reading soilt1'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(n3d) + soilt1_ind,nb,ne))
+ endif
+ if (soilt2_ind > 0) then
+ call read_vardata(dset_sfc, 'soilt2', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'error reading soilt2'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(n3d) + soilt2_ind,nb,ne))
+ endif
+ if (soilt3_ind > 0) then
+ call read_vardata(dset_sfc, 'soilt3', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'error reading soilt3'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(n3d) + soilt3_ind,nb,ne))
+ endif
+ if (soilt4_ind > 0) then
+ call read_vardata(dset_sfc, 'soilt4', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'error reading soilt2'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(n3d) + soilt4_ind,nb,ne))
+ endif
+ if (slc1_ind > 0) then
+ call read_vardata(dset_sfc, 'soill1', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'error reading soill1'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(n3d) + slc1_ind,nb,ne))
+ endif
+ if (slc2_ind > 0) then
+ call read_vardata(dset_sfc, 'soill2', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'error reading soill2'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(n3d) + slc2_ind,nb,ne))
+ endif
+ if (slc3_ind > 0) then
+ call read_vardata(dset_sfc, 'soill3', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'error reading soill3'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(n3d) + slc3_ind,nb,ne))
+ endif
+ if (slc4_ind > 0) then
+ call read_vardata(dset_sfc, 'soill4', values_2d, errcode=iret)
+ if (iret /= 0) then
+ print *,'error reading soill4'
+ call stop2(22)
+ endif
+ ug = reshape(values_2d,(/nlons*nlats/))
+ call copytogrdin(ug,grdin(:,levels(n3d) + slc4_ind,nb,ne))
+ endif
+
+ call close_dataset(dset_sfc)
+
+ endif ! sfc read
+
+ if ( allocated(values_2d) ) deallocate(values_2d)
+
end do backgroundloop ! loop over backgrounds to read in
end do ensmemloop ! loop over ens members to read in
@@ -1083,6 +1457,20 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_
integer(i_kind) :: ncstart(4), nccount(4)
logical :: nocompress
+ logical :: write_sfc_file, write_atm_file
+ character(len=max_varname_length), dimension(n3d) :: no_vars3d
+ character(len=max_varname_length), dimension(n2d) :: no_vars2d
+
+ call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file)
+
+ if (write_sfc_file ) then
+ ! adding the sfc increments requires adjusting several other variables.
+ ! This is done is a separate program.
+ if (nproc == 0) write(6,*) 'gridio/writegriddata_pnc: not coded to write sfc analysis, will write increment for sfc fields'
+ no_vars3d=''
+ call writeincrement_pnc(no_vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag)
+ endif
+
nocompress = .true.
if (nccompress) nocompress = .false.
@@ -1884,6 +2272,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n
character(nemsio_charkind) :: field
character(len=nf90_max_name) :: time_units
logical :: hasfield
+ character(len=max_varname_length), dimension(n3d) :: no_vars3d
real(r_kind) kap,kapr,kap1,clip
real(r_single) compress_err
@@ -1901,6 +2290,17 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n
integer k,krev,nt,ierr,iunitsig,nb,i,ne,nanal
logical :: nocompress
+ logical :: write_sfc_file, write_atm_file
+
+ call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file)
+
+ if (write_sfc_file ) then
+ ! adding the sfc increments requires adjusting several other variables. This is done is a separate
+ ! program.
+ if (nproc == 0) write(6,*)'gridio/writegriddata: not coded to write sfc analysis, will write increment for sfc fields'
+ no_vars3d=''
+ call writeincrement(nanal1,nanal2,no_vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag)
+ endif
nocompress = .true.
if (nccompress) nocompress = .false.
@@ -3305,7 +3705,7 @@ end subroutine writegriddata
subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag)
use netcdf
use params, only: nbackgrounds,incfileprefixes,fgfileprefixes,reducedgrid,&
- datestring,nhr_anal,write_ensmean
+ datestring,nhr_anal,write_ensmean, fgsfcfileprefixes,incsfcfileprefixes
use constants, only: grav
use mpi
use module_ncio, only: Dataset, Variable, Dimension, open_dataset,&
@@ -3337,11 +3737,16 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,
integer :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind
! netcdf things
- integer(i_kind) :: dimids3(3), ncstart(3), nccount(3)
+ integer(i_kind) :: dimids3(3), ncstart(3), nccount(3), dimids2(2)
integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid
integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, &
hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, &
- tvarid, sphumvarid, liqwatvarid, o3varid, icvarid
+ tvarid, sphumvarid, liqwatvarid, o3varid, icvarid, &
+ tmp2mvarid, spfh2mvarid, soilt1varid, soilt2varid, &
+ soilt3varid, soilt4varid, slc1varid, slc2varid, &
+ slc3varid, slc4varid, maskvarid
+ integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind, &
+ soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind
integer(i_kind) :: iadateout
! fixed fields such as lat, lon, levs
@@ -3353,9 +3758,16 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,
! increment
real(r_kind), dimension(nlons*nlats) :: psinc, inc, ug, vg, work
real(r_single), allocatable, dimension(:,:,:) :: inc3d, inc3d2, inc3dout
+ real(r_single), allocatable, dimension(:,:) :: inc2d, inc2dout
real(r_single), allocatable, dimension(:,:,:) :: tv, tvanl, tmp, tmpanl, q, qanl
real(r_kind), allocatable, dimension(:,:) :: values_2d
real(r_kind), allocatable, dimension(:) :: psges, delzb, values_1d
+ ! soil / snow mask (not fixed)
+ integer(i_kind), dimension(nlons,nlats) :: mask
+ logical :: write_sfc_file, write_atm_file
+ real(r_double) :: t1,t2
+
+ call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file)
use_full_hydro = .false.
clip = tiny_r_kind
@@ -3364,6 +3776,8 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,
ncstart = (/1, 1, 1/)
nccount = (/nlons, nlats, nlevs/)
+ if ( write_atm_file) then
+ if (nproc == 0) t1 = mpi_wtime()
ne = 0
ensmemloop: do nanal=nanal1,nanal2
ne = ne + 1
@@ -3677,14 +4091,277 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,
call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), &
start = ncstart, count = nccount))
+ call close_dataset(dsfg,errcode=iret)
+ if (iret/=0) then
+ write(6,*)'gridio/writeincrement gfs model: problem closing netcdf fg dataset, iret=',iret
+ call stop2(23)
+ endif
! deallocate things
deallocate(inc3d,inc3d2,inc3dout)
deallocate(tmp,tv,q,tmpanl,tvanl,qanl)
- deallocate(delzb,psges)
+ if (allocated(delzb)) deallocate(delzb)
+ if (allocated(psges)) deallocate(psges)
end do backgroundloop ! loop over backgrounds to read in
end do ensmemloop ! loop over ens members to read in
+ if (nproc == 0) then
+ t2 = mpi_wtime()
+ print *,'time in writeincrement atm_file on root',t2-t1,'secs'
+ endif
+ endif ! write_atm_file
+
+ if (write_sfc_file) then
+
+ if (nproc == 0) t1 = mpi_wtime()
+ ne = 0
+ sfcensmemloop: do nanal=nanal1,nanal2
+ ne = ne + 1
+ write(charnanal,'(i3.3)') nanal
+ sfcbackgroundloop: do nb=1,nbackgrounds
+
+ if (nanal == 0 .and. write_ensmean) then
+ filenamein = trim(adjustl(datapath))//trim(adjustl(fgsfcfileprefixes(nb)))//"ensmean"
+ filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"ensmean"
+ else
+ if(no_inflate_flag) then
+ filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"nimem"//charnanal
+ else
+ filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"mem"//charnanal
+ end if
+ filenamein = trim(adjustl(datapath))//trim(adjustl(fgsfcfileprefixes(nb)))//"mem"//charnanal
+ endif
+
+ ! create the output netCDF increment file
+ call nccheck_incr(nf90_create(path=trim(filenameout), cmode=nf90_netcdf4, ncid=ncid_out))
+
+ ! create dimensions based on analysis resolution, not guess
+ call nccheck_incr(nf90_def_dim(ncid_out, "longitude", nlons, lon_dimid))
+ call nccheck_incr(nf90_def_dim(ncid_out, "latitude", nlats, lat_dimid))
+ dimids2 = (/ lon_dimid, lat_dimid /)
+ ! create variables
+ call nccheck_incr(nf90_def_var(ncid_out, "longitude", nf90_real, (/lon_dimid/), lonvarid))
+ call nccheck_incr(nf90_def_var(ncid_out, "latitude", nf90_real, (/lat_dimid/), latvarid))
+ call nccheck_incr(nf90_def_var(ncid_out, "tmp2m_inc", nf90_real, dimids2, tmp2mvarid))
+ call nccheck_incr(nf90_def_var(ncid_out, "spfh2m_inc", nf90_real, dimids2, spfh2mvarid))
+ call nccheck_incr(nf90_def_var(ncid_out, "soilt1_inc", nf90_real, dimids2, soilt1varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "soilt2_inc", nf90_real, dimids2, soilt2varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "soilt3_inc", nf90_real, dimids2, soilt3varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "soilt4_inc", nf90_real, dimids2, soilt4varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "slc1_inc", nf90_real, dimids2, slc1varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "slc2_inc", nf90_real, dimids2, slc2varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "slc3_inc", nf90_real, dimids2, slc3varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "slc4_inc", nf90_real, dimids2, slc4varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "soilsnow_mask", nf90_int, dimids2, maskvarid))
+ ! place global attributes to serial calc_increment output
+ call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF"))
+ call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", &
+ "global landsfc anal increment from writeincrement"))
+ call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "analysis_time", iadateout))
+ call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "IAU_hour_from_guess", nhr_anal(nb)))
+ ! add units to lat/lon because that's what the calc_increment utility has
+ call nccheck_incr(nf90_put_att(ncid_out, lonvarid, "units", "degrees_east"))
+ call nccheck_incr(nf90_put_att(ncid_out, latvarid, "units", "degrees_north"))
+ ! end the netCDF file definition
+ call nccheck_incr(nf90_enddef(ncid_out))
+
+ tmp2m_ind = getindex(vars2d, 't2m') !< indices in the state or control var arrays
+ spfh2m_ind = getindex(vars2d, 'q2m')
+ soilt1_ind = getindex(vars2d, 'st1')
+ slc1_ind = getindex(vars2d, 'sl1')
+ soilt2_ind = getindex(vars2d, 'st2')
+ slc2_ind = getindex(vars2d, 'sl2')
+ soilt3_ind = getindex(vars2d, 'st3')
+ slc3_ind = getindex(vars2d, 'sl3')
+ soilt4_ind = getindex(vars2d, 'st4')
+ slc4_ind = getindex(vars2d, 'sl4')
+
+ dsfg = open_dataset(filenamein)
+
+ ! longitudes
+ call read_vardata(dsfg, 'grid_xt', values_1d, errcode=iret)
+ deglons(:) = values_1d
+ call nccheck_incr(nf90_put_var(ncid_out, lonvarid, deglons, &
+ start = (/1/), count = (/nlons/)))
+
+ call read_vardata(dsfg, 'grid_yt', values_1d, errcode=iret)
+ ! latitudes
+ do j=1,nlats
+ deglats(nlats-j+1) = values_1d(j)
+ end do
+
+ call nccheck_incr(nf90_put_var(ncid_out, latvarid, deglats, &
+ start = (/1/), count = (/nlats/)))
+
+ ! construct mask (1 - soil, 2 - snow, 0 - not snow)
+ ! note: same logic/threshold used in global_cycle to produce
+ ! mask on model grid.
+
+ call read_vardata(dsfg, 'soill1', values_2d, errcode=iret)
+
+ mask = 0
+ do j=1,nlats
+ do i = 1, nlons
+ if (values_2d(i,j) .LT. 1.0) then
+ mask(i,nlats-j+1) = 1
+ endif
+ enddo
+ end do
+
+ call read_vardata(dsfg, 'weasd', values_2d, errcode=iret)
+ do j=1,nlats
+ do i = 1, nlons
+ if (values_2d(i,j) .GT. 0.001) then
+ mask(i,nlats-j+1) = 2
+ endif
+ enddo
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, maskvarid, mask, &
+ start = ncstart(1:2), count = nccount(1:2)))
+
+ allocate(inc2d(nlons,nlats))
+ allocate(inc2dout(nlons,nlats))
+
+ ! tmp2m increment
+ inc(:) = zero
+ if (tmp2m_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d) + tmp2m_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, tmp2mvarid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! spfh2m increment
+ inc(:) = zero
+ if (spfh2m_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+spfh2m_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, spfh2mvarid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! soilt1 increment
+ inc(:) = zero
+ if (soilt1_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+soilt1_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ inc2dout=0.
+ do j=1,nlats
+ do i = 1, nlons
+ if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j)
+ enddo
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, soilt1varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! soilt2 increment
+ inc(:) = zero
+ if (soilt2_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+soilt2_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ inc2dout=0.
+ do j=1,nlats
+ do i = 1, nlons
+ if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j)
+ enddo
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, soilt2varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! soilt3 increment
+ inc(:) = zero
+ if (soilt3_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+soilt3_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ inc2dout=0.
+ do j=1,nlats
+ do i = 1, nlons
+ if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j)
+ enddo
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, soilt3varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! soilt4 increment
+ inc(:) = zero
+ if (soilt4_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+soilt4_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ inc2dout=0.
+ do j=1,nlats
+ do i = 1, nlons
+ if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j)
+ enddo
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, soilt4varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! slc1 increment
+ inc(:) = zero
+ if (slc1_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+slc1_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, slc1varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! slc2 increment
+ inc(:) = zero
+ if (slc2_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+slc2_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, slc2varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! slc3 increment
+ inc(:) = zero
+ if (slc3_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+slc3_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, slc3varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! slc4 increment
+ inc(:) = zero
+ if (slc4_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+slc4_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, slc4varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+
+ call close_dataset(dsfg,errcode=iret)
+ if (iret/=0) then
+ write(6,*)'gridio/writeincrement gfs model: problem closing netcdf sfc fg dataset, iret=',iret
+ call stop2(23)
+ endif
+ ! deallocate things
+ deallocate(inc2d,inc2dout)
+
+ end do sfcbackgroundloop ! loop over backgrounds to read in
+ end do sfcensmemloop ! loop over ens members to read in
+ if (nproc == 0) then
+ t2 = mpi_wtime()
+ print *,'time in writeincrement sfc_file on root',t2-t1,'secs'
+ endif
+
+ endif ! write_sfc_file
+
return
contains
@@ -3708,8 +4385,9 @@ end subroutine writeincrement
subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag)
use netcdf
use params, only: nbackgrounds,incfileprefixes,fgfileprefixes,reducedgrid,&
- datestring,nhr_anal
- use constants, only: grav
+ datestring,nhr_anal, &
+ incsfcfileprefixes,fgsfcfileprefixes
+ use constants, only: grav,qcmin
use mpi
use module_ncio, only: Dataset, Variable, Dimension, open_dataset,&
read_attribute, close_dataset, get_dim, read_vardata,&
@@ -3740,11 +4418,17 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate
integer :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind
! netcdf things
- integer(i_kind) :: dimids3(3),nccount(3),ncstart(3)
+ integer(i_kind) :: dimids3(3),nccount(3),ncstart(3), dimids2(2)
integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid
integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, &
hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, &
- tvarid, sphumvarid, liqwatvarid, o3varid, icvarid
+ tvarid, sphumvarid, liqwatvarid, o3varid, icvarid, &
+ rwmrvarid, snmrvarid, grlevarid, &
+ tmp2mvarid, spfh2mvarid, soilt1varid, soilt2varid, &
+ soilt3varid, soilt4varid, slc1varid, slc2varid, &
+ slc3varid, slc4varid, maskvarid
+ integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind,soilt3_ind, &
+ soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind
integer(i_kind) :: iadateout
! fixed fields such as lat, lon, levs
@@ -3756,10 +4440,20 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate
! increment
real(r_kind), dimension(nlons*nlats) :: psinc, inc, ug, vg, work
real(r_single), allocatable, dimension(:,:,:) :: inc3d, inc3d2, inc3dout
+ real(r_single), allocatable, dimension(:,:) :: inc2d, inc2dout
real(r_single), allocatable, dimension(:,:,:) :: tv, tvanl, tmp, tmpanl, q, qanl
+ real(r_single), allocatable, dimension(:,:,:) :: q2, qanl2
real(r_kind), allocatable, dimension(:,:) :: values_2d
real(r_kind), allocatable, dimension(:) :: psges, delzb, values_1d
+ ! soil / snow mask (not fixed)
+ integer(i_kind), dimension(nlons,nlats) :: mask
+
+ logical :: write_sfc_file, write_atm_file
+ real(r_double) :: t1,t2
+
+ call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file)
+
use_full_hydro = .false.
clip = tiny_r_kind
read(datestring,*) iadateout
@@ -3798,6 +4492,9 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate
call mpi_bcast(grdin(1,1,nb,1),npts*ndim, mpi_real4, 0, iocomms(mem_pe(nproc)), iret)
enddo
+ if (write_atm_file ) then
+
+ if (nproc == 0) t1 = mpi_wtime()
! loop through times and do the read
ne = 1
backgroundloop: do nb=1,nbackgrounds
@@ -3846,6 +4543,12 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate
call nccheck_incr(nf90_var_par_access(ncid_out, o3varid, nf90_collective))
call nccheck_incr(nf90_def_var(ncid_out, "icmr_inc", nf90_real, dimids3, icvarid))
call nccheck_incr(nf90_var_par_access(ncid_out, icvarid, nf90_collective))
+ call nccheck_incr(nf90_def_var(ncid_out, "rwmr_inc", nf90_real, dimids3, rwmrvarid))
+ call nccheck_incr(nf90_var_par_access(ncid_out, rwmrvarid, nf90_collective))
+ call nccheck_incr(nf90_def_var(ncid_out, "snmr_inc", nf90_real, dimids3, snmrvarid))
+ call nccheck_incr(nf90_var_par_access(ncid_out, snmrvarid, nf90_collective))
+ call nccheck_incr(nf90_def_var(ncid_out, "grle_inc", nf90_real, dimids3, grlevarid))
+ call nccheck_incr(nf90_var_par_access(ncid_out, grlevarid, nf90_collective))
! place global attributes to parallel calc_increment output
call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF"))
call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", &
@@ -3878,7 +4581,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate
dsfg = open_dataset(filenamein, paropen=.true., mpicomm=iocomms(mem_pe(nproc)))
call read_attribute(dsfg, 'ak', values_1d,errcode=iret)
if (iret /= 0) then
- print *,'error reading ak'
+ write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading ak, iret= ',iret,' PROGRAM STOPS'
call stop2(29)
endif
do k=1,nlevs+1
@@ -3887,7 +4590,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate
enddo
call read_attribute(dsfg, 'bk', values_1d,errcode=iret)
if (iret /= 0) then
- print *,'error reading bk'
+ write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading bk, iret= ',iret,' PROGRAM STOPS'
call stop2(29)
endif
do k=1,nlevs+1
@@ -3997,7 +4700,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate
allocate(tvanl(nlons,nlats,nccount(3)),tmpanl(nlons,nlats,nccount(3)),qanl(nlons,nlats,nccount(3)))
call read_vardata(dsfg, 'spfh', q, ncstart=ncstart, nccount=nccount, errcode=iret)
if (iret /= 0) then
- print *,'error reading spfh'
+ write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading spfh, iret= ',iret,' PROGRAM STOPS'
call stop2(29)
endif
do k=lev_pe1(iope), lev_pe2(iope)
@@ -4022,7 +4725,7 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate
! t increment
call read_vardata(dsfg, 'tmp', tmp, ncstart=ncstart, nccount=nccount, errcode=iret)
if (iret /= 0) then
- print *,'error reading tmp'
+ write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading tmp, iret= ',iret,' PROGRAM STOPS'
call stop2(29)
endif
tv = tmp * ( 1.0 + fv*q)
@@ -4094,33 +4797,68 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate
call nccheck_incr(nf90_put_var(ncid_out, o3varid, sngl(inc3dout), &
start = ncstart, count = nccount))
+ ! For hydrometeors, following the treatment for specific humidity increment
+ ! Need to make sure the analysis value is not negative
+ ! Read in background + increment and make sure the minimum is qcmin
+ ! Adjust increment accordingly
+
! liq wat increment
! icmr increment
+ ! if cw increment, make sure split the cw increment into ql and qi increments
+ allocate(q2(nlons,nlats,nccount(3)),qanl2(nlons,nlats,nccount(3)))
+ call read_vardata(dsfg, 'clwmr', q, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if (iret /= 0) then
+ write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading clwmr, iret= ',iret,' PROGRAM STOPS'
+ call stop2(29)
+ endif
+ call read_vardata(dsfg, 'icmr', q2, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if (iret /= 0) then
+ write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading icmr, iret= ',iret,' PROGRAM STOPS'
+ call stop2(29)
+ endif
do k=lev_pe1(iope), lev_pe2(iope)
krev = nlevs-k+1
ki = k - lev_pe1(iope) + 1
- ug = zero
+ ug = zero; vg = zero
if (cw_ind > 0) then
call copyfromgrdin(grdin(:,levels(cw_ind-1)+krev,nb,ne),ug)
+ else if (ql_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(ql_ind-1)+krev,nb,ne),ug)
end if
- if (imp_physics == 11) then
- work = -r0_05 * (reshape(tmpanl(:,:,ki),(/nlons*nlats/)) - t0c)
- do i=1,nlons*nlats
- work(i) = max(zero,work(i))
- work(i) = min(one,work(i))
- enddo
- vg = ug * work ! cloud ice
- ug = ug * (one - work) ! cloud water
- inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/))
+ ! analysis control variable is cw, need to split cw analysis to ql and qi
+ if (cw_ind > 0) then
+ if (imp_physics == 11) then
+ work = -r0_05 * (reshape(tmpanl(:,:,ki),(/nlons*nlats/)) - t0c)
+ do i=1,nlons*nlats
+ work(i) = max(zero,work(i))
+ work(i) = min(one,work(i))
+ enddo
+ vg = ug * work ! cloud ice
+ ug = ug * (one - work) ! cloud water
+ endif
+ else if (qi_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(qi_ind-1)+krev,nb,ne),vg)
endif
- inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/))
+ inc3d(:,:,ki) = reshape(ug,(/nlons,nlats/)) ! cloud water
+ qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki)
+ inc3d2(:,:,ki) = reshape(vg,(/nlons,nlats/)) ! cloud ice
+ qanl2(:,:,ki) = q2(:,:,ki) + inc3d(:,:,ki)
enddo
+
+ ! adjust hydrometeor increment to make sure analysis is positive
+ if (cliptracers) where (qanl < qcmin) qanl = qcmin
+ inc3d = qanl - q ! ql
+ if (cliptracers) where (qanl2 < qcmin) qanl2 = qcmin
+ inc3d2 = qanl2 - q2 ! qi
+
+ ! output ql increment
do j=1,nlats
inc3dout(:,nlats-j+1,:) = inc3d(:,j,:)
end do
if (should_zero_increments_for('liq_wat_inc')) inc3dout = zero
call nccheck_incr(nf90_put_var(ncid_out, liqwatvarid, sngl(inc3dout), &
start = ncstart, count = nccount))
+ ! output qi increment
do j=1,nlats
inc3dout(:,nlats-j+1,:) = inc3d2(:,j,:)
end do
@@ -4128,16 +4866,345 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate
call nccheck_incr(nf90_put_var(ncid_out, icvarid, sngl(inc3dout), &
start = ncstart, count = nccount))
+ ! rwmr increment
+ call read_vardata(dsfg, 'rwmr', q, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if (iret /= 0) then
+ write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading rwmr, iret= ',iret,' PROGRAM STOPS'
+ call stop2(29)
+ endif
+ do k=lev_pe1(iope), lev_pe2(iope)
+ krev = nlevs-k+1
+ ki = k - lev_pe1(iope) + 1
+ inc(:) = zero
+ if (qr_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(qr_ind-1) + krev,nb,ne),inc)
+ endif
+ inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/))
+ qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki)
+ end do
+ if (cliptracers) where (qanl < qcmin) qanl = qcmin
+ inc3d = qanl - q ! updated rwmr increment
+ do j=1,nlats
+ inc3dout(:,nlats-j+1,:) = inc3d(:,j,:)
+ end do
+ if (should_zero_increments_for('rwmr_inc')) inc3dout = zero
+ call nccheck_incr(nf90_put_var(ncid_out, rwmrvarid, sngl(inc3dout), &
+ start = ncstart, count = nccount))
+
+ ! snmr increment
+ call read_vardata(dsfg, 'snmr', q, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if (iret /= 0) then
+ write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading snmr, iret= ',iret,' PROGRAM STOPS'
+ call stop2(29)
+ endif
+ do k=lev_pe1(iope), lev_pe2(iope)
+ krev = nlevs-k+1
+ ki = k - lev_pe1(iope) + 1
+ inc(:) = zero
+ if (qs_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(qs_ind-1) + krev,nb,ne),inc)
+ endif
+ inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/))
+ qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki)
+ end do
+ if (cliptracers) where (qanl < qcmin) qanl = qcmin
+ inc3d = qanl - q ! updated snmr increment
+ do j=1,nlats
+ inc3dout(:,nlats-j+1,:) = inc3d(:,j,:)
+ end do
+ if (should_zero_increments_for('snmr_inc')) inc3dout = zero
+ call nccheck_incr(nf90_put_var(ncid_out, snmrvarid, sngl(inc3dout), &
+ start = ncstart, count = nccount))
+
+ ! grle increment
+ call read_vardata(dsfg, 'grle', q, ncstart=ncstart, nccount=nccount, errcode=iret)
+ if (iret /= 0) then
+ write(6,*)'WRITEINCREMENT_PNC: ***FATAL ERROR*** reading grle, iret= ',iret,' PROGRAM STOPS'
+ call stop2(29)
+ endif
+ do k=lev_pe1(iope), lev_pe2(iope)
+ krev = nlevs-k+1
+ ki = k - lev_pe1(iope) + 1
+ inc(:) = zero
+ if (qg_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(qg_ind-1) + krev,nb,ne),inc)
+ endif
+ inc3d(:,:,ki) = reshape(inc,(/nlons,nlats/))
+ qanl(:,:,ki) = q(:,:,ki) + inc3d(:,:,ki)
+ end do
+ if (cliptracers) where (qanl < qcmin) qanl = qcmin
+ inc3d = qanl - q ! updated grle increment
+ do j=1,nlats
+ inc3dout(:,nlats-j+1,:) = inc3d(:,j,:)
+ end do
+ if (should_zero_increments_for('grle_inc')) inc3dout = zero
+ call nccheck_incr(nf90_put_var(ncid_out, grlevarid, sngl(inc3dout), &
+ start = ncstart, count = nccount))
+
call mpi_barrier(iocomms(mem_pe(nproc)), iret)
! deallocate things
deallocate(inc3d,inc3d2,inc3dout)
deallocate(tmp,tv,q,tmpanl,tvanl,qanl)
+ deallocate(q2,qanl2)
if (allocated(delzb)) deallocate(delzb)
if (allocated(psges)) deallocate(psges)
+ !closing file
+ call nccheck_incr(nf90_close(ncid_out))
end do backgroundloop ! loop over backgrounds to write out
+ if (nproc == 0) then
+ t2 = mpi_wtime()
+ print *,'time in writeincrement_pnc atm_file on root',t2-t1,'secs'
+ endif
+ end if ! if (write_atm_file)
+
+ if (write_sfc_file ) then
+
+ if (nproc == 0) t1 = mpi_wtime()
+
+ tmp2m_ind = getindex(vars2d, 't2m') !< indices in the state or control var arrays
+ spfh2m_ind = getindex(vars2d, 'q2m')
+ soilt1_ind = getindex(vars2d, 'st1')
+ slc1_ind = getindex(vars2d, 'sl1')
+ soilt2_ind = getindex(vars2d, 'st2')
+ slc2_ind = getindex(vars2d, 'sl2')
+ soilt3_ind = getindex(vars2d, 'st3')
+ slc3_ind = getindex(vars2d, 'sl3')
+ soilt4_ind = getindex(vars2d, 'st4')
+ slc4_ind = getindex(vars2d, 'sl4')
+
+ ! loop through times and do the read
+ ne = 1
+ write(charnanal,'(i3.3)') nanal
+ sfcbackgroundloop: do nb=1,nbackgrounds
+
+ if(no_inflate_flag) then
+ filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"nimem"//charnanal
+ else
+ filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"mem"//charnanal
+ end if
+ filenamein = trim(adjustl(datapath))//trim(adjustl(fgsfcfileprefixes(nb)))//"mem"//charnanal
+
+ !! note: only iope=0 is writing the outputs. Having all pes in iocomm write to a file slows it down.
+ !!
+ if (iope==0) then
+ dsfg = open_dataset(filenamein)
+ ! create the output netCDF increment file
+ call nccheck_incr(nf90_create(path=trim(filenameout), cmode=nf90_netcdf4,ncid=ncid_out))
+
+ ! create dimensions based on analysis resolution, not guess
+ call nccheck_incr(nf90_def_dim(ncid_out, "longitude", nlons, lon_dimid))
+ call nccheck_incr(nf90_def_dim(ncid_out, "latitude", nlats, lat_dimid))
+ dimids2 = (/ lon_dimid, lat_dimid /)
+ ! create variables
+ call nccheck_incr(nf90_def_var(ncid_out, "longitude", nf90_real,(/lon_dimid/), lonvarid))
+ call nccheck_incr(nf90_def_var(ncid_out, "latitude", nf90_real,(/lat_dimid/), latvarid))
+ call nccheck_incr(nf90_def_var(ncid_out, "tmp2m_inc", nf90_real, dimids2,tmp2mvarid))
+ call nccheck_incr(nf90_def_var(ncid_out, "spfh2m_inc", nf90_real, dimids2,spfh2mvarid))
+ call nccheck_incr(nf90_def_var(ncid_out, "soilt1_inc", nf90_real, dimids2,soilt1varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "soilt2_inc", nf90_real, dimids2,soilt2varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "soilt3_inc", nf90_real, dimids2,soilt3varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "soilt4_inc", nf90_real, dimids2,soilt4varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "slc1_inc", nf90_real, dimids2,slc1varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "slc2_inc", nf90_real, dimids2,slc2varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "slc3_inc", nf90_real, dimids2,slc3varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "slc4_inc", nf90_real, dimids2,slc4varid))
+ call nccheck_incr(nf90_def_var(ncid_out, "soilsnow_mask", nf90_int,dimids2, maskvarid))
+ ! place global attributes to serial calc_increment output
+ call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF"))
+ call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", &
+ "global landsfc anal increment from writeincrement"))
+ call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "analysis_time",iadateout))
+ call nccheck_incr(nf90_put_att(ncid_out, nf90_global,"IAU_hour_from_guess", nhr_anal(nb)))
+ ! add units to lat/lon because that's what the calc_increment utility has
+ call nccheck_incr(nf90_put_att(ncid_out, lonvarid, "units","degrees_east"))
+ call nccheck_incr(nf90_put_att(ncid_out, latvarid, "units","degrees_north"))
+ ! end the netCDF file definition
+ call nccheck_incr(nf90_enddef(ncid_out))
+
+ ! longitudes
+ call read_vardata(dsfg, 'grid_xt', values_1d, errcode=iret)
+ deglons(:) = values_1d
+ call nccheck_incr(nf90_put_var(ncid_out, lonvarid, deglons, &
+ start = (/1/), count = (/nlons/)))
+
+ call read_vardata(dsfg, 'grid_yt', values_1d, errcode=iret)
+ ! latitudes
+ do j=1,nlats
+ deglats(nlats-j+1) = values_1d(j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, latvarid, deglats, &
+ start = (/1/), count = (/nlats/)))
+ ! construct mask (1 - soil, 2 - snow, 0 - not snow)
+ ! note: same logic/threshold used in global_cycle to produce
+ ! mask on model grid.
+ call read_vardata(dsfg, 'soill1', values_2d, errcode=iret)
+ mask = 0
+ do j=1,nlats
+ do i = 1, nlons
+ if (values_2d(i,j) .LT. 1.0) then
+ mask(i,nlats-j+1) = 1
+ endif
+ enddo
+ end do
+ call read_vardata(dsfg, 'weasd', values_2d, errcode=iret)
+ do j=1,nlats
+ do i = 1, nlons
+ if (values_2d(i,j) .GT. 0.001) then
+ mask(i,nlats-j+1) = 2
+ endif
+ enddo
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, maskvarid, mask, &
+ start = ncstart(1:2), count = nccount(1:2)))
+
+ allocate(inc2d(nlons,nlats))
+ allocate(inc2dout(nlons,nlats))
+
+ ! tmp2m increment
+ inc(:) = zero
+ if (tmp2m_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d) + tmp2m_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, tmp2mvarid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! spfh2m increment
+ inc(:) = zero
+ if (spfh2m_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+spfh2m_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, spfh2mvarid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! soilt1 increment
+ inc(:) = zero
+ if (soilt1_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+soilt1_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ inc2dout=0.
+ do j=1,nlats
+ do i = 1, nlons
+ if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j)
+ enddo
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, soilt1varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! soilt2 increment
+ inc(:) = zero
+ if (soilt2_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+soilt2_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ inc2dout=0.
+ do j=1,nlats
+ do i = 1, nlons
+ if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j)
+ enddo
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, soilt2varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! soilt3 increment
+ inc(:) = zero
+ if (soilt3_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+soilt3_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ inc2dout=0.
+ do j=1,nlats
+ do i = 1, nlons
+ if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j)
+ enddo
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, soilt3varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! soilt4 increment
+ inc(:) = zero
+ if (soilt4_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+soilt4_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ inc2dout=0.
+ do j=1,nlats
+ do i = 1, nlons
+ if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j)
+ enddo
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, soilt4varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! slc1 increment
+ inc(:) = zero
+ if (slc1_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+slc1_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, slc1varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! slc2 increment
+ inc(:) = zero
+ if (slc2_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+slc2_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, slc2varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! slc3 increment
+ inc(:) = zero
+ if (slc3_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+slc3_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, slc3varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+ ! slc4 increment
+ inc(:) = zero
+ if (slc4_ind > 0) then
+ call copyfromgrdin(grdin(:,levels(n3d)+slc4_ind,nb,ne),inc)
+ endif
+ inc2d(:,:) = reshape(inc,(/nlons,nlats/))
+ do j=1,nlats
+ inc2dout(:,nlats-j+1) = inc2d(:,j)
+ end do
+ call nccheck_incr(nf90_put_var(ncid_out, slc4varid, sngl(inc2dout), &
+ start = ncstart(1:2), count = nccount(1:2)))
+
+ call close_dataset(dsfg,errcode=iret)
+ if (iret/=0) then
+ write(6,*)'gridio/writeincrement_par: problem closing netcdf sfc fg dataset, iret=',iret
+ call stop2(23)
+ endif
+ ! deallocate things
+ deallocate(inc2d,inc2dout)
+
+ call nccheck_incr(nf90_close(ncid_out))
+
+ end if
+
+ end do sfcbackgroundloop ! loop over backgrounds to read in
+ if (nproc == 0) then
+ t2 = mpi_wtime()
+ print *,'time in writeincrement_pnc sfc_file on root',t2-t1,'secs'
+ endif
+ endif !write_Sfc
+
! remove the sub communicators
call mpi_barrier(iocomms(mem_pe(nproc)), iret)
call mpi_comm_free(iocomms(mem_pe(nproc)), iret)
@@ -4163,6 +5230,64 @@ end subroutine copyfromgrdin
end subroutine writeincrement_pnc
+ subroutine set_ncio_file_flags(vars3d, n3d, vars2d, n2d, sfc_file, atm_file)
+ ! determine if variables are in sfc and/or atm file, for ncio case.
+ character(len=max_varname_length), dimension(n2d), intent(in) :: vars2d
+ character(len=max_varname_length), dimension(n3d), intent(in) :: vars3d
+ integer, intent(in) :: n2d, n3d
+ logical, intent(out) :: sfc_file, atm_file
+
+ integer(i_kind) :: u_ind, v_ind, tv_ind, q_ind, oz_ind, cw_ind
+ integer(i_kind) :: qr_ind, qs_ind, qg_ind
+ integer(i_kind) :: tsen_ind, ql_ind, qi_ind, prse_ind
+ integer(i_kind) :: ps_ind, pst_ind, sst_ind
+ integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind
+ integer(i_kind) :: soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind
+
+ ! atmos file variables
+ u_ind = getindex(vars3d, 'u') !< indices in the state or control var arrays
+ v_ind = getindex(vars3d, 'v') ! U and V (3D)
+ tv_ind = getindex(vars3d, 'tv') ! Tv (3D)
+ q_ind = getindex(vars3d, 'q') ! Q (3D)
+ oz_ind = getindex(vars3d, 'oz') ! Oz (3D)
+ cw_ind = getindex(vars3d, 'cw') ! CW (3D)
+ tsen_ind = getindex(vars3d, 'tsen') !sensible T (3D)
+ ql_ind = getindex(vars3d, 'ql') ! QL (3D)
+ qi_ind = getindex(vars3d, 'qi') ! QI (3D)
+ prse_ind = getindex(vars3d, 'prse')
+ qr_ind = getindex(vars3d, 'qr') ! QR (3D)
+ qs_ind = getindex(vars3d, 'qs') ! QS (3D)
+ qg_ind = getindex(vars3d, 'qg') ! QG (3D)
+ ps_ind = getindex(vars2d, 'ps') ! Ps (2D)
+ pst_ind = getindex(vars2d, 'pst') ! Ps tendency (2D) // equivalent of
+ ! old logical massbal_adjust, if non-zero
+ sst_ind = getindex(vars2d, 'sst') ! is this really in the atmos file?
+
+ ! for nc gfs io determine if requested variables are in sfc and/or atmos file
+ atm_file = ( u_ind>0 .or. v_ind>0 .or. tv_ind>0 .or. q_ind>0 .or. sst_ind>0 .or. &
+ oz_ind>0 .or. cw_ind>0 .or. tsen_ind>0 .or. ql_ind>0 .or. &
+ qi_ind>0 .or. prse_ind>0 .or. qr_ind>0 .or. qs_ind>0 .or. qg_ind>0 )
+
+ ! sfc file variables
+ tmp2m_ind = getindex(vars2d, 't2m')
+ spfh2m_ind = getindex(vars2d, 'q2m')
+ soilt1_ind = getindex(vars2d, 'st1')
+ slc1_ind = getindex(vars2d, 'sl1')
+ soilt2_ind = getindex(vars2d, 'st2')
+ slc2_ind = getindex(vars2d, 'sl2')
+ soilt3_ind = getindex(vars2d, 'st3')
+ slc3_ind = getindex(vars2d, 'sl3')
+ soilt4_ind = getindex(vars2d, 'st4')
+ slc4_ind = getindex(vars2d, 'sl4')
+
+ sfc_file = ( tmp2m_ind > 0 .or. spfh2m_ind > 0 .or. soilt1_ind > 0 .or. &
+ slc1_ind > 0 .or. soilt2_ind > 0 .or. slc2_ind > 0 .or. &
+ soilt3_ind > 0 .or. slc3_ind > 0 .or. soilt4_ind > 0 .or. &
+ slc4_ind > 0 )
+
+ end subroutine set_ncio_file_flags
+
+
logical function checkfield(field,fields,nrec) result(hasfield)
use nemsio_module, only: nemsio_charkind
integer, intent(in) :: nrec
diff --git a/src/enkf/inflation.f90 b/src/enkf/inflation.f90
index 225967028c..c80cc99c10 100644
--- a/src/enkf/inflation.f90
+++ b/src/enkf/inflation.f90
@@ -71,13 +71,14 @@ module inflation
analpertwtnh_rtpp,analpertwtsh_rtpp,analpertwttr_rtpp,&
latbound, delat, datapath, covinflatemax, save_inflation, &
covinflatemin, nlons, nlats, smoothparm, nbackgrounds,&
- covinflatenh,covinflatesh,covinflatetr,lnsigcovinfcutoff
+ covinflatenh,covinflatesh,covinflatetr,lnsigcovinfcutoff,taperanalperts
use kinds, only: r_single, i_kind
use mpeu_util, only: getindex
use constants, only: one, zero, rad2deg, deg2rad
use covlocal, only: latval, taper
-use controlvec, only: ncdim, cvars3d, cvars2d, nc3d, nc2d, clevels
-use gridinfo, only: latsgrd, logp, npts, nlevs_pres
+use controlvec, only: ncdim, cvars3d, cvars2d, nc3d, nc2d, clevels, index_pres
+! note: vars2d_landonly currently only defined for gridio_gfs, but smoothing only coded for gfs.
+use gridinfo, only: latsgrd, logp, npts, nlevs_pres, vars2d_landonly, taper_vert
use loadbal, only: indxproc, numptsperproc, npts_max, anal_chunk, anal_chunk_prior
use smooth_mod, only: smooth
@@ -101,9 +102,10 @@ subroutine inflate_ens()
real(r_single),dimension(ndiag) :: sumcoslat,suma,suma2,sumi,sumf,sumitot,sumatot, &
sumcoslattot,suma2tot,sumftot
real(r_single) fnanalsml,coslat
-integer(i_kind) i,nn,iunit,ierr,nb,nnlvl,ps_ind
+integer(i_kind) i,k,nlev,nn,iunit,ierr,nb,nnlvl,ps_ind, this_ind, ind
+integer(i_kind), dimension(8) :: soil_index
character(len=500) filename
-real(r_single), allocatable, dimension(:,:) :: tmp_chunk2,covinfglobal
+real(r_single), allocatable, dimension(:,:) :: tmp_chunk2,covinfglobal,store_presmooth
real(r_single) r
fnanalsml = one/(real(nanals-1,r_single))
@@ -111,7 +113,7 @@ subroutine inflate_ens()
if (analpertwtnh_rtpp > 1.e-5_r_single .and. &
analpertwtnh_rtpp > 1.e-5_r_single .and. &
analpertwttr_rtpp > 1.e-5_r_single) then
-if (nproc .eq. 0) print *,'performing RTPP inflation...'
+if (nproc == 0) print *,'performing RTPP inflation...'
nbloop: do nb=1,nbackgrounds ! loop over time levels in background
! First perform RTPP ensemble inflation,
! as first described in:
@@ -137,7 +139,7 @@ subroutine inflate_ens()
abs(analpertwttr) < 1.e-5_r_single .and. &
abs(analpertwtsh) < 1.e-5_r_single) return
-if (nproc .eq. 0) print *,'performing RTPS inflation...'
+if (nproc == 0) print *,'performing RTPS inflation...'
! now perform RTPS inflation
nbloop2: do nb=1,nbackgrounds ! loop over time levels in background
@@ -231,7 +233,33 @@ subroutine inflate_ens()
do nn=1,ncdim
call mpi_allreduce(mpi_in_place,covinfglobal(1,nn),npts,mpi_real4,mpi_sum,mpi_comm_world,ierr)
enddo
+ ! do not apply smoothing to soil temp. or soil moisture (not globally defined)
+
+ ind = 0
+ do i = 1,8
+ this_ind = getindex(cvars2d, vars2d_landonly(i))
+ if (this_ind>0) then
+ ind=ind+1
+ soil_index(ind)=this_ind
+ endif
+ enddo
+
+ if (ind>0) then
+ allocate(store_presmooth(npts,ind))
+ do i = 1, ind
+ store_presmooth(:,i) = covinfglobal(:,clevels(nc3d)+soil_index(i))
+ enddo
+ endif
+
call smooth(covinfglobal)
+
+ if (ind>0) then
+ do i = 1, ind
+ covinfglobal(:,clevels(nc3d) + soil_index(i)) = store_presmooth(:,i)
+ enddo
+ deallocate(store_presmooth)
+ endif
+
where (covinfglobal < covinflatemin) covinfglobal = covinflatemin
where (covinfglobal > covinflatemax) covinfglobal = covinflatemax
do i=1,numptsperproc(nproc+1)
@@ -274,11 +302,18 @@ subroutine inflate_ens()
! apply inflation.
do nn=1,ncdim
+ nlev = index_pres(nn) ! vertical index for i'th control variable
+ if (nlev == nlevs+1) nlev=-1 ! 2d field
do i=1,numptsperproc(nproc+1)
! inflate posterior perturbations.
anal_chunk(:,i,nn,nb) = tmp_chunk2(i,nn)*anal_chunk(:,i,nn,nb)
+ ! optionally 'deflate' perturbations to reduce spread near top of model
+ if (taperanalperts .and. nlev > 0) then
+ anal_chunk(:,i,nn,nb) = taper_vert(nlev)*anal_chunk(:,i,nn,nb)
+ endif
+
! area mean surface pressure posterior spread, inflation.
! (this diagnostic only makes sense for grids that are regular in longitude)
if (ps_ind > 0 .and. nn == clevels(nc3d) + ps_ind) then
diff --git a/src/enkf/innovstats.f90 b/src/enkf/innovstats.f90
index e67cf43f10..853532c9b9 100644
--- a/src/enkf/innovstats.f90
+++ b/src/enkf/innovstats.f90
@@ -45,6 +45,7 @@ subroutine print_innovstats(obfit,obsprd)
nobsspd_nh,nobsspd_sh,nobsspd_tr,&
nobsgps_nh,nobsgps_sh,nobsgps_tr,&
nobsdbz_nh,nobsdbz_sh,nobsdbz_tr,&
+ nobsfed_nh,nobsfed_sh,nobsfed_tr,&
nobsrw_nh,nobsrw_sh,nobsrw_tr,&
nobsq_nh,nobsq_sh,nobsq_tr,nobswnd_nh,nobswnd_sh,nobswnd_tr,&
nobsoz_nh,nobsoz_sh,nobsoz_tr,nobsps_sh,nobsps_nh,nobsps_tr,nob
@@ -67,6 +68,9 @@ subroutine print_innovstats(obfit,obsprd)
sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,&
sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,&
sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,&
+ sumfed_nh,biasfed_nh,sumfed_spread_nh,sumfed_oberr_nh,&
+ sumfed_sh,biasfed_sh,sumfed_spread_sh,sumfed_oberr_sh,&
+ sumfed_tr,biasfed_tr,sumfed_spread_tr,sumfed_oberr_tr,&
sumrw_nh,biasrw_nh,sumrw_spread_nh,sumrw_oberr_nh,&
sumrw_sh,biasrw_sh,sumrw_spread_sh,sumrw_oberr_sh,&
sumrw_tr,biasrw_tr,sumrw_spread_tr,sumrw_oberr_tr,&
@@ -112,6 +116,9 @@ subroutine print_innovstats(obfit,obsprd)
nobsdbz_nh = 0
nobsdbz_sh = 0
nobsdbz_tr = 0
+ nobsfed_nh = 0
+ nobsfed_sh = 0
+ nobsfed_tr = 0
nobsrw_nh = 0
nobsrw_sh = 0
nobsrw_tr = 0
@@ -168,6 +175,12 @@ subroutine print_innovstats(obfit,obsprd)
sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,&
sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,nobsdbz_sh,&
sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,nobsdbz_tr)
+ else if (obtype(nob)(1:3) == 'fed') then
+ call obstats(obfit(nob),oberrvar_orig(nob),&
+ obsprd(nob),obloclat(nob),&
+ sumfed_nh,biasfed_nh,sumfed_spread_nh,sumfed_oberr_nh,nobsfed_nh,&
+ sumfed_sh,biasfed_sh,sumfed_spread_sh,sumfed_oberr_sh,nobsfed_sh,&
+ sumfed_tr,biasfed_tr,sumfed_spread_tr,sumfed_oberr_tr,nobsfed_tr)
else if (obtype(nob)(1:3) == ' rw') then
call obstats(obfit(nob),oberrvar_orig(nob),&
obsprd(nob),obloclat(nob),&
@@ -213,9 +226,12 @@ subroutine print_innovstats(obfit,obsprd)
call printstats(' all gps',sumgps_nh,biasq_nh,sumgps_spread_nh,sumgps_oberr_nh,nobsgps_nh,&
sumgps_sh,biasgps_sh,sumgps_spread_sh,sumgps_oberr_sh,nobsgps_sh,&
sumgps_tr,biasgps_tr,sumgps_spread_tr,sumgps_oberr_tr,nobsgps_tr)
- call printstats(' all dbz',sumdbz_nh,biasq_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,&
+ call printstats(' all dbz',sumdbz_nh,biasdbz_nh,sumdbz_spread_nh,sumdbz_oberr_nh,nobsdbz_nh,&
sumdbz_sh,biasdbz_sh,sumdbz_spread_sh,sumdbz_oberr_sh,nobsdbz_sh,&
sumdbz_tr,biasdbz_tr,sumdbz_spread_tr,sumdbz_oberr_tr,nobsdbz_tr)
+ call printstats(' all fed',sumfed_nh,biasfed_nh,sumfed_spread_nh,sumfed_oberr_nh,nobsfed_nh,&
+ sumfed_sh,biasfed_sh,sumfed_spread_sh,sumfed_oberr_sh,nobsfed_sh,&
+ sumfed_tr,biasfed_tr,sumfed_spread_tr,sumfed_oberr_tr,nobsfed_tr)
call printstats(' all rw',sumrw_nh,biasq_nh,sumrw_spread_nh,sumrw_oberr_nh,nobsrw_nh,&
sumrw_sh,biasrw_sh,sumrw_spread_sh,sumrw_oberr_sh,nobsrw_sh,&
sumrw_tr,biasrw_tr,sumrw_spread_tr,sumrw_oberr_tr,nobsrw_tr)
diff --git a/src/enkf/letkf.f90 b/src/enkf/letkf.f90
index 9b74cecd75..dcd68be8ff 100644
--- a/src/enkf/letkf.f90
+++ b/src/enkf/letkf.f90
@@ -172,8 +172,8 @@ subroutine letkf_update()
if (nproc == 0) print *,'using',nthreads,' openmp threads'
! define a few frequently used parameters
-r_nanals=one/float(nanals)
-r_nanalsm1=one/float(nanals-1)
+r_nanals=one/real(nanals,r_kind)
+r_nanalsm1=one/real(nanals-1,r_kind)
mincorrlength_factsq = mincorrlength_fact**2
kdobs=associated(kdtree_obs2)
@@ -541,31 +541,34 @@ subroutine letkf_update()
enddo
!$omp end parallel do
+tmean=zero
+tmin=zero
+tmax=zero
tend = mpi_wtime()
call mpi_reduce(tend-tbegin,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr)
-tmean = tmean/numproc
+tmean = tmean/real(numproc,r_kind)
call mpi_reduce(tend-tbegin,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr)
call mpi_reduce(tend-tbegin,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr)
if (nproc .eq. 0) print *,'min/max/mean time to do letkf update ',tmin,tmax,tmean
t2 = t2/nthreads; t3 = t3/nthreads; t4 = t4/nthreads; t5 = t5/nthreads
if (nproc == 0) print *,'time to process analysis on gridpoint = ',t2,t3,t4,t5,' secs on task',nproc
call mpi_reduce(t2,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr)
-tmean = tmean/numproc
+tmean = tmean/real(numproc,r_kind)
call mpi_reduce(t2,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr)
call mpi_reduce(t2,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr)
if (nproc .eq. 0) print *,',min/max/mean t2 = ',tmin,tmax,tmean
call mpi_reduce(t3,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr)
-tmean = tmean/numproc
+tmean = tmean/real(numproc,r_kind)
call mpi_reduce(t3,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr)
call mpi_reduce(t3,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr)
if (nproc .eq. 0) print *,',min/max/mean t3 = ',tmin,tmax,tmean
call mpi_reduce(t4,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr)
-tmean = tmean/numproc
+tmean = tmean/real(numproc,r_kind)
call mpi_reduce(t4,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr)
call mpi_reduce(t4,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr)
if (nproc .eq. 0) print *,',min/max/mean t4 = ',tmin,tmax,tmean
call mpi_reduce(t5,tmean,1,mpi_real8,mpi_sum,0,mpi_comm_world,ierr)
-tmean = tmean/numproc
+tmean = tmean/real(numproc,r_kind)
call mpi_reduce(t5,tmin,1,mpi_real8,mpi_min,0,mpi_comm_world,ierr)
call mpi_reduce(t5,tmax,1,mpi_real8,mpi_max,0,mpi_comm_world,ierr)
if (nproc .eq. 0) print *,',min/max/mean t5 = ',tmin,tmax,tmean
@@ -590,7 +593,7 @@ subroutine letkf_update()
call mpi_reduce(nobslocal_max,nobslocal_maxall,1,mpi_integer,mpi_max,0,mpi_comm_world,ierr)
call mpi_reduce(nobslocal_min,nobslocal_minall,1,mpi_integer,mpi_min,0,mpi_comm_world,ierr)
call mpi_reduce(nobslocal_mean,nobslocal_meanall,1,mpi_integer,mpi_sum,0,mpi_comm_world,ierr)
- if (nproc == 0) print *,'min/max/mean number of obs in local volume',nobslocal_minall,nobslocal_maxall,nint(nobslocal_meanall/float(numproc))
+ if (nproc == 0) print *,'min/max/mean number of obs in local volume',nobslocal_minall,nobslocal_maxall,nint(nobslocal_meanall/real(numproc,r_kind))
endif
call mpi_reduce(nobslocal_max,nobslocal_maxall,1,mpi_integer,mpi_max,0,mpi_comm_world,ierr)
call mpi_reduce(nobslocal_min,nobslocal_minall,1,mpi_integer,mpi_max,0,mpi_comm_world,ierr)
diff --git a/src/enkf/observer_gfs.f90 b/src/enkf/observer_gfs.f90
index 983b25f959..07e4f58457 100644
--- a/src/enkf/observer_gfs.f90
+++ b/src/enkf/observer_gfs.f90
@@ -66,7 +66,7 @@ subroutine setup_linhx(rlat, rlon, time, ix, delx, ixp, delxp, iy, dely, &
!$$$
use kinds, only: r_kind,i_kind,r_single
use params, only: nstatefields, nlons, nlats, nhr_state, fhr_assim
- use gridinfo, only: latsgrd, lonsgrd
+ use gridinfo, only: latsgrd, lonsgrd, npts
use constants, only: zero,one,pi
use mpisetup
implicit none
@@ -76,6 +76,7 @@ subroutine setup_linhx(rlat, rlon, time, ix, delx, ixp, delxp, iy, dely, &
real(r_single) ,intent(in ) :: time ! observation time relative to middle of window
integer(i_kind), intent(out) :: ix, iy, it, ixp, iyp, itp
real(r_kind), intent(out) :: delx, dely, delxp, delyp, delt, deltp
+ integer(i_kind) :: ixnlons
! find interplation indices and deltas
@@ -87,17 +88,21 @@ subroutine setup_linhx(rlat, rlon, time, ix, delx, ixp, delxp, iy, dely, &
ix = min(ix, nlats-1)
ixp = max(ix-1, 0)
+ ixnlons = ix*nlons
+
if (ixp /= ix) then
- delx = (rlat - latsgrd(ix*nlons+1)) / (latsgrd(ixp*nlons + 1) - latsgrd(ix*nlons+1))
+ delx = (rlat - latsgrd(ixnlons+1)) / (latsgrd(ixp*nlons + 1) - latsgrd(ixnlons+1))
else
delx = one
endif
delx = max(zero,min(delx,one))
- iyp = 1
- do while (iyp <= nlons .and. lonsgrd(ix*nlons + iyp) <= rlon)
- iyp = iyp + 1
+ iyp=1
+ do while(iyp <= nlons .and. ixnlons+iyp <= npts)
+ if (lonsgrd(ixnlons+iyp) > rlon) exit
+ iyp = iyp + 1
enddo
+
iy = iyp - 1
if(iy < 1) iy = iy + nlons
if(iyp > nlons) iyp = iyp - nlons
diff --git a/src/enkf/params.f90 b/src/enkf/params.f90
index 593e5a5ec4..f2a52d9a1a 100644
--- a/src/enkf/params.f90
+++ b/src/enkf/params.f90
@@ -85,7 +85,9 @@ module params
character(len=120),dimension(7),public :: statefileprefixes
character(len=120),dimension(7),public :: statesfcfileprefixes
character(len=120),dimension(7),public :: anlfileprefixes
+character(len=120),dimension(7),public :: anlsfcfileprefixes
character(len=120),dimension(7),public :: incfileprefixes
+character(len=120),dimension(7),public :: incsfcfileprefixes
! analysis date string (YYYYMMDDHH)
character(len=10), public :: datestring
! Hour for datestring
@@ -122,6 +124,8 @@ module params
real(r_single),public :: lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh,&
lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh,&
lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh
+real(r_single),public :: corrlengthfednh,corrlengthfedtr,corrlengthfedsh, &
+ lnsigcutofffednh,lnsigcutofffedtr,lnsigcutofffedsh
real(r_single),public :: corrlengthrdrnh,corrlengthrdrtr,corrlengthrdrsh, &
lnsigcutoffrdrnh,lnsigcutoffrdrtr,lnsigcutoffrdrsh
real(r_single),public :: analpertwtnh,analpertwtsh,analpertwttr,sprd_tol,saterrfact
@@ -224,12 +228,6 @@ module params
! EFSOI calculation applications
logical,public :: efsoi_flag = .false.
-! if true, use ensemble mean qsat in definition of
-! normalized humidity analysis variable (instead of
-! qsat for each member, which is the default behavior
-! when pseudo_rh=.true. If pseudo_rh=.false, use_qsatensmean
-! is ignored.
-logical,public :: use_qsatensmean = .false.
logical,public :: write_spread_diag = .false.
! if true, use jacobian from GSI stored in diag file to compute
! ensemble perturbations in observation space.
@@ -256,17 +254,24 @@ module params
! write ensemble mean analysis (or analysis increment)
logical,public :: write_ensmean = .false.
+! taper analysis ens perturbations at top of model (gfs only)
+logical, public :: taperanalperts = .false.
+real(r_kind), public :: taperanalperts_akbot = 500.0_r_kind
+real(r_kind), public :: taperanalperts_aktop = -1.0_r_kind
+
namelist /nam_enkf/datestring,datapath,iassim_order,nvars,&
covinflatemax,covinflatemin,deterministic,sortinc,&
mincorrlength_fact,corrlengthnh,corrlengthtr,corrlengthsh,&
- varqc,huber,nlons,nlats,smoothparm,use_qsatensmean,&
+ varqc,huber,nlons,nlats,smoothparm,&
readin_localization, zhuberleft,zhuberright,&
obtimelnh,obtimeltr,obtimelsh,reducedgrid,&
lnsigcutoffnh,lnsigcutofftr,lnsigcutoffsh,&
lnsigcutoffsatnh,lnsigcutoffsattr,lnsigcutoffsatsh,&
lnsigcutoffpsnh,lnsigcutoffpstr,lnsigcutoffpssh,&
+ corrlengthfednh,corrlengthfedsh,corrlengthfedtr,&
+ lnsigcutofffednh,lnsigcutofffedsh,lnsigcutofffedtr,&
fgfileprefixes,fgsfcfileprefixes,anlfileprefixes, &
- incfileprefixes, &
+ anlsfcfileprefixes,incfileprefixes,incsfcfileprefixes,&
statefileprefixes,statesfcfileprefixes, &
covl_minfact,covl_efold,lupd_obspace_serial,letkf_novlocal,&
analpertwtnh,analpertwtsh,analpertwttr,sprd_tol,&
@@ -286,7 +291,7 @@ module params
fv3_native, paranc, nccompress, write_fv3_incr,incvars_to_zero,write_ensmean, &
corrlengthrdrnh,corrlengthrdrsh,corrlengthrdrtr,&
lnsigcutoffrdrnh,lnsigcutoffrdrsh,lnsigcutoffrdrtr,&
- l_use_enkf_directZDA
+ l_use_enkf_directZDA,taperanalperts,taperanalperts_akbot,taperanalperts_aktop
namelist /nam_wrf/arw,nmm,nmm_restart
namelist /nam_fv3/fv3fixpath,nx_res,ny_res,ntiles,l_pres_add_saved,l_fv3reg_filecombined, &
fv3_io_layout_nx,fv3_io_layout_ny
@@ -321,6 +326,10 @@ subroutine read_namelist()
corrlengthrdrnh = 10
corrlengthrdrtr = 10
corrlengthrdrsh = 10
+! corrlength (km) for GLM flash extent density
+corrlengthfednh = 30_r_single
+corrlengthfedtr = 30_r_single
+corrlengthfedsh = 30_r_single
! read in localization length scales from an external file.
readin_localization = .false.
! min and max inflation.
@@ -345,6 +354,9 @@ subroutine read_namelist()
lnsigcutoffrdrnh = 0.2_r_single ! value for radar
lnsigcutoffrdrtr = 0.2_r_single ! value for radar
lnsigcutoffrdrsh = 0.2_r_single ! value for radar
+lnsigcutofffednh = 2._r_single ! value for GLM flash extent density
+lnsigcutofffedtr = 2._r_single ! value for GLM flash extent density
+lnsigcutofffedsh = 2._r_single ! value for GLM flash extent density
! ob time localization
obtimelnh = 1.e10_r_single
obtimeltr = 1.e10_r_single
@@ -460,8 +472,8 @@ subroutine read_namelist()
! Initialize first-guess and analysis file name prefixes.
! (blank means use default names)
fgfileprefixes = ''; anlfileprefixes=''; statefileprefixes=''
-fgsfcfileprefixes = ''; statesfcfileprefixes=''
-incfileprefixes = ''
+anlsfcfileprefixes=''; fgsfcfileprefixes = ''; statesfcfileprefixes=''
+incfileprefixes = ''; incsfcfileprefixes = ''
! option for including convective clouds in the all-sky
cnvw_option=.false.
@@ -679,10 +691,6 @@ subroutine read_namelist()
letkf_flag) then
print *,'warning: no time localization in LETKF!'
endif
- if ((write_ensmean .and. pseudo_rh) .and. .not. use_qsatensmean) then
- print *,'write_ensmean=T requires use_qsatensmean=T when pseudo_rh=T'
- call stop2(19)
- endif
print *, trim(adjustl(datapath))
@@ -720,7 +728,7 @@ subroutine read_namelist()
endif
endif
if (trim(fgsfcfileprefixes(nbackgrounds+1)) .eq. "") then
- fgsfcfileprefixes(nbackgrounds+1)="sfgsfc_"//datestring//"_fhr"//charfhr_anal(nbackgrounds+1)//"_"
+ fgsfcfileprefixes(nbackgrounds+1)="bfg_"//datestring//"_fhr"//charfhr_anal(nbackgrounds+1)//"_"
end if
nbackgrounds = nbackgrounds+1
end do
@@ -742,7 +750,7 @@ subroutine read_namelist()
endif
endif
if (trim(statesfcfileprefixes(nstatefields+1)) .eq. "") then
- statesfcfileprefixes(nstatefields+1)="sfgsfc_"//datestring//"_fhr"//charfhr_state(nstatefields+1)//"_"
+ statesfcfileprefixes(nstatefields+1)="bfg_"//datestring//"_fhr"//charfhr_state(nstatefields+1)//"_"
end if
nstatefields = nstatefields+1
end do
@@ -762,6 +770,23 @@ subroutine read_namelist()
incfileprefixes(nb)="incr_"//datestring//"_fhr"//charfhr_anal(nb)//"_"
! else
! anlfileprefixes(nb)="sanl_"//datestring//"_"
+! endif
+ endif
+ endif
+ if (trim(anlsfcfileprefixes(nb)) .eq. "") then
+ ! default analysis file prefix
+ if (regional) then
+ if (nbackgrounds > 1) then
+ anlsfcfileprefixes(nb)="sfc_analysis_fhr"//charfhr_anal(nb)//"."
+ else
+ anlsfcfileprefixes(nb)="sfc_analysis."
+ endif
+ else ! global
+! if (nbackgrounds > 1) then
+ anlsfcfileprefixes(nb)="banl_"//datestring//"_fhr"//charfhr_anal(nb)//"_"
+ incsfcfileprefixes(nb)="sfcincr_"//datestring//"_fhr"//charfhr_anal(nb)//"_"
+! else
+! anlfileprefixes(nb)="sanl_"//datestring//"_"
! endif
endif
endif
@@ -804,6 +829,10 @@ subroutine read_namelist()
corrlengthrdrnh = corrlengthrdrnh * 1.e3_r_single/rearth
corrlengthrdrtr = corrlengthrdrtr * 1.e3_r_single/rearth
corrlengthrdrsh = corrlengthrdrsh * 1.e3_r_single/rearth
+! rescale covariance localization length for GLM FED
+corrlengthfednh = corrlengthfednh * 1.e3_r_single/rearth
+corrlengthfedtr = corrlengthfedtr * 1.e3_r_single/rearth
+corrlengthfedsh = corrlengthfedsh * 1.e3_r_single/rearth
! convert targe area boundary into radians
tar_minlat = tar_minlat * deg2rad
diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90
index e1977298a6..65db770b6d 100644
--- a/src/enkf/readconvobs.f90
+++ b/src/enkf/readconvobs.f90
@@ -32,7 +32,8 @@ module readconvobs
use kinds, only: r_kind,i_kind,r_single,r_double
use constants, only: one,zero,deg2rad
-use params, only: npefiles, netcdf_diag, modelspace_vloc, l_use_enkf_directZDA
+use params, only: npefiles, netcdf_diag, modelspace_vloc, &
+ l_use_enkf_directZDA
implicit none
private
@@ -40,9 +41,9 @@ module readconvobs
!> observation types to read from netcdf files
-integer(i_kind), parameter :: nobtype = 11
+integer(i_kind), parameter :: nobtype = 12
character(len=3), dimension(nobtype), parameter :: obtypes = (/' t', ' q', ' ps', ' uv', 'tcp', &
- 'gps', 'spd', ' pw', ' dw', ' rw', 'dbz' /)
+ 'gps', 'spd', ' pw', ' dw', ' rw', 'dbz', 'fed' /)
contains
@@ -77,7 +78,7 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id
integer(i_kind) :: iunit, nchar, nreal, ii, mype, ios, idate, i, ipe, ioff0
integer(i_kind),dimension(2) :: nn,nobst, nobsps, nobsq, nobsuv, nobsgps, &
nobstcp,nobstcx,nobstcy,nobstcz,nobssst, nobsspd, nobsdw, nobsrw, nobspw, &
- nobsdbz
+ nobsdbz, nobsfed
character(8),allocatable,dimension(:):: cdiagbuf
real(r_single),allocatable,dimension(:,:)::rdiagbuf
real(r_kind) :: errorlimit,errorlimit2,error,pres,obmax
@@ -102,6 +103,7 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id
nobspw = 0
nobsgps = 0
nobsdbz = 0
+ nobsfed = 0
nobstcp = 0; nobstcx = 0; nobstcy = 0; nobstcz = 0
init_pass = .true.
peloop: do ipe=0,npefiles
@@ -185,6 +187,9 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id
else if (obtype == 'dbz') then
nobsdbz = nobsdbz + nn
num_obs_tot = num_obs_tot + nn(2)
+ else if (obtype == 'fed') then
+ nobsfed = nobsfed + nn
+ num_obs_tot = num_obs_tot + nn(2)
else if (obtype == 'gps') then
nobsgps = nobsgps + nn
num_obs_tot = num_obs_tot + nn(2)
@@ -229,6 +234,7 @@ subroutine get_num_convobs_bin(obspath,datestring,num_obs_tot,num_obs_totdiag,id
write(6,100) 'dw',nobsdw(1),nobsdw(2)
write(6,100) 'rw',nobsrw(1),nobsrw(2)
write(6,100) 'dbz',nobsdbz(1),nobsdbz(2)
+ write(6,100) 'fed',nobsfed(1),nobsfed(2)
write(6,100) 'tcp',nobstcp(1),nobstcp(2)
if (nobstcx(2) .gt. 0) then
write(6,100) 'tcx',nobstcx(1),nobstcx(2)
@@ -329,7 +335,6 @@ subroutine get_num_convobs_nc(obspath,datestring,num_obs_tot,num_obs_totdiag,id)
call nc_diag_read_close(obsfile)
-
num_obs_totdiag = num_obs_totdiag + nobs_curr
do i = 1, nobs_curr
@@ -789,6 +794,9 @@ subroutine get_convobs_data_nc(obspath, datestring, nobs_max, nobs_maxdiag, &
x_obs(nob) = x_obs(nob) /Forecast_Saturation_Spec_Hum(i)
hx_mean(nob) = hx_mean(nob) /Forecast_Saturation_Spec_Hum(i)
hx_mean_nobc(nob) = hx_mean_nobc(nob) /Forecast_Saturation_Spec_Hum(i)
+ if (neigv>0) then
+ hx_modens(:,nob) = hx_modens(:,nob)/ Forecast_Saturation_Spec_Hum(i)
+ endif
endif
! for wind, also read v-component
@@ -1071,6 +1079,7 @@ subroutine get_convobs_data_bin(obspath, datestring, nobs_max, nobs_maxdiag, &
if (obtype == ' t' .or. obtype == ' uv' .or. obtype == ' ps' .or. &
obtype == 'tcp' .or. obtype == ' q' .or. obtype == 'spd' .or. &
obtype == 'sst' .or. obtype == ' rw' .or. obtype == 'dbz' .or. &
+ obtype == 'fed' .or. &
obtype == 'gps' .or. obtype == ' dw' .or. obtype == ' pw') then
! direct reflectivitiy DA has a different routine for dbz obs.
diff --git a/src/enkf/statevec.f90 b/src/enkf/statevec.f90
index d1be91af3c..44ad5df9b4 100644
--- a/src/enkf/statevec.f90
+++ b/src/enkf/statevec.f90
@@ -14,7 +14,7 @@ module statevec
!
! Public Variables:
! nanals: (integer scalar) number of ensemble members (from module params)
-! nlevs: number of analysis vertical levels (from module params).
+! nlevs: number of analysis atmos vertical levels (from module params).
! ns3d: number of 3D variables
! ns2d: number of 2D variables
! svars3d: names of 3D variables
@@ -120,7 +120,7 @@ subroutine init_statevec()
svars3d(ns3d)=trim(adjustl(var))
slevels(ns3d)=ilev + slevels(ns3d-1)
else
- if (nproc .eq. 0) print *,'Error: only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev
+ if (nproc .eq. 0) print *,'Error statevec: - only ', nlevs, ' and ', nlevs+1,' number of levels is supported in current version, got ',ilev
call stop2(503)
endif
enddo
@@ -136,7 +136,7 @@ subroutine init_statevec()
do i = 1, ns2d
if (getindex(vars2d_supported, svars2d(i))<0) then
if (nproc .eq. 0) then
- print *,'Error: 2D variable ', svars2d(i), ' is not supported in current version.'
+ print *,'Error: state 2D variable ', svars2d(i), ' is not supported in current version.'
print *,'Supported variables: ', vars2d_supported
endif
call stop2(502)
@@ -145,7 +145,7 @@ subroutine init_statevec()
do i = 1, ns3d
if (getindex(vars3d_supported, svars3d(i))<0) then
if (nproc .eq. 0) then
- print *,'Error: 3D variable ', svars3d(i), ' is not supported in current version.'
+ print *,'Error: state 3D variable ', svars3d(i), ' is not supported in current version.'
print *,'Supported variables: ', vars3d_supported
endif
call stop2(502)
diff --git a/src/gsi/CMakeLists.txt b/src/gsi/CMakeLists.txt
index af94224c05..1afb0774ca 100644
--- a/src/gsi/CMakeLists.txt
+++ b/src/gsi/CMakeLists.txt
@@ -29,6 +29,7 @@ endif()
option(OPENMP "Enable OpenMP Threading" OFF)
option(ENABLE_MKL "Use MKL for LAPACK implementation (if available)" ON)
option(USE_GSDCLOUD "Use GSD Cloud Analysis library" OFF)
+option(USE_MGBF "Use MGBF library" ON)
set(GSI_VALID_MODES "GFS" "Regional")
set(GSI_MODE "GFS" CACHE STRING "Choose the GSI Application.")
@@ -43,6 +44,7 @@ endif()
message(STATUS "GSI: OPENMP ................. ${OPENMP}")
message(STATUS "GSI: ENABLE_MKL ............. ${ENABLE_MKL}")
message(STATUS "GSI: USE_GSDCLOUD ........... ${USE_GSDCLOUD}")
+message(STATUS "GSI: USE_MGBF ............... ${USE_MGBF}")
message(STATUS "GSI: GSI_MODE ............... ${GSI_MODE}")
# Dependencies
@@ -87,6 +89,13 @@ if(USE_GSDCLOUD)
endif()
endif()
+# MGBF library dependency
+if(USE_MGBF)
+ if(NOT TARGET mgbf)
+ find_package(mgbf REQUIRED)
+ endif()
+endif()
+
# Get compiler flags for the GSI application
include(gsiapp_compiler_flags)
@@ -146,6 +155,7 @@ target_link_libraries(gsi_fortran_obj PUBLIC nemsio::nemsio)
target_link_libraries(gsi_fortran_obj PUBLIC ncio::ncio)
target_link_libraries(gsi_fortran_obj PUBLIC w3emc::w3emc_d)
target_link_libraries(gsi_fortran_obj PUBLIC sp::sp_d)
+add_library(crtm::crtm ALIAS crtm)
target_link_libraries(gsi_fortran_obj PUBLIC bufr::bufr_d)
target_link_libraries(gsi_fortran_obj PUBLIC crtm::crtm)
if(GSI_MODE MATCHES "Regional")
@@ -158,6 +168,12 @@ if(USE_GSDCLOUD)
endif()
target_link_libraries(gsi_fortran_obj PUBLIC gsdcloud::gsdcloud)
endif()
+if(USE_MGBF)
+ if(TARGET mgbf)
+ add_dependencies(gsi_fortran_obj mgbf)
+ endif()
+ target_link_libraries(gsi_fortran_obj PUBLIC mgbf::mgbf)
+endif()
if(OpenMP_Fortran_FOUND)
target_link_libraries(gsi_fortran_obj PRIVATE OpenMP::OpenMP_Fortran)
endif()
diff --git a/src/gsi/adjtest.f90 b/src/gsi/adjtest.f90
index d910d14f12..3447dec202 100644
--- a/src/gsi/adjtest.f90
+++ b/src/gsi/adjtest.f90
@@ -33,10 +33,12 @@ module adjtest
use control_vectors, only: control_vector,allocate_cv,random_cv, &
deallocate_cv,dot_product,assignment(=)
use state_vectors, only: allocate_state,deallocate_state,dot_product
+use gridmod, only : minmype
use gsi_bundlemod, only: gsi_bundle
use gsi_bundlemod, only: assignment(=)
use bias_predictors, only: predictors,allocate_preds,deallocate_preds, &
assignment(=)
+use control2state_mod, only: control2state,control2state_ad
implicit none
private
@@ -81,7 +83,7 @@ subroutine adtest(xhat)
integer(i_kind) :: ii,idig
real(r_kind) :: zz1,zz2,zz3
-if (mype==0) write(6,*)'ADTEST starting'
+if (mype==minmype) write(6,*)'ADTEST starting'
! ----------------------------------------------------------------------
! Allocate local variables
@@ -97,10 +99,10 @@ subroutine adtest(xhat)
! Initialize control space vectors
if (present(xhat)) then
xtest1=xhat
- if (mype==0) write(6,*)'ADTEST use input xhat'
+ if (mype==minmype) write(6,*)'ADTEST use input xhat'
else
call random_cv(xtest1)
- if (mype==0) write(6,*)'ADTEST use random_cv(xhat)'
+ if (mype==minmype) write(6,*)'ADTEST use random_cv(xhat)'
endif
xtest2=zero
@@ -135,18 +137,20 @@ subroutine adtest(xhat)
do ii=1,nsubwin
zz2=zz2+dot_product(stest1(ii),stest1(ii))
enddo
-DO ii=1,nrclen
+do ii=1,nrclen
zz2=zz2+sbias1%values(ii)*sbias1%values(ii)
-ENDDO
+enddo
-if ( abs(zz1+zz2) > sqrt(tiny(zz3)) ) then
- zz3=two*abs(zz1-zz2)/(zz1+zz2)
-else
- zz3=abs(zz1-zz2)
-endif
-idig= int(-log(zz3+tiny(zz3))/log(10.0_r_kind))
+if (mype==minmype) then
+ if ( abs(zz1+zz2) > sqrt(tiny(zz3)) ) then
+ zz3=two*abs(zz1-zz2)/(zz1+zz2)
+ else
+ zz3=abs(zz1-zz2)
+ end if
+ idig= int(-log(zz3+tiny(zz3))/log(10.0_r_kind))
-if (mype==0) then
+! Note that this result is not completely correct especially on processors
+! other than minmype. See issue 548.
write(6,'(A)')' ADTEST 0.123456789012345678'
write(6,'(A,ES25.18)')' ADTEST = ',zz1
write(6,'(A,ES25.18)')' ADTEST = ',zz2
@@ -166,7 +170,7 @@ subroutine adtest(xhat)
call deallocate_preds(sbias2)
! ----------------------------------------------------------------------
-if (mype==0) write(6,*)'ADTEST finished'
+if (mype==minmype) write(6,*)'ADTEST finished'
return
end subroutine adtest
diff --git a/src/gsi/adjtest_obs.f90 b/src/gsi/adjtest_obs.f90
index 67e2ff0cdd..294dc32ca0 100644
--- a/src/gsi/adjtest_obs.f90
+++ b/src/gsi/adjtest_obs.f90
@@ -78,6 +78,7 @@ subroutine adtest_obs
use m_obsdiags, only: obsLLists
use m_obsLList, only: obsLList_getTLDdotprod
+ use control2state_mod, only: control2state
implicit none
diff --git a/src/gsi/aeroinfo.f90 b/src/gsi/aeroinfo.f90
index dd8489029b..a030bdeffc 100644
--- a/src/gsi/aeroinfo.f90
+++ b/src/gsi/aeroinfo.f90
@@ -313,12 +313,10 @@ subroutine aeroinfo_read
! Successful read, return to calling routine
else
-! File does not exist, write warning message to alert users
+! File does not exist, write warning message to unit 6 to alert users
if (mype==mype_aero) then
- open(iout_aero)
- write(iout_aero,*)'AEROINFO_READ: ***WARNING*** FILE ',trim(fname),' does not exist'
- write(iout_aero,*)'AEROINFO_READ: jpch_aero=',jpch_aero
- close(iout_aero)
+ write(6,*)'AEROINFO_READ: ***WARNING*** FILE ',trim(fname),' does not exist'
+ write(6,*)'AEROINFO_READ: jpch_aero=',jpch_aero
endif
end if
diff --git a/src/gsi/aircraftinfo.f90 b/src/gsi/aircraftinfo.f90
index b84455f47c..a29f1571b1 100644
--- a/src/gsi/aircraftinfo.f90
+++ b/src/gsi/aircraftinfo.f90
@@ -57,7 +57,7 @@ module aircraftinfo
logical :: cleanup_tail ! logical to remove tail number no longer used
logical :: upd_aircraft ! indicator if update bias at 06Z & 18Z
- integer(i_kind), parameter :: max_tail=10000 ! max tail numbers
+ integer(i_kind), parameter :: max_tail=100000 ! max tail numbers
integer(i_kind) npredt ! predictor number
integer(i_kind) ntail ! total tail number
integer(i_kind) ntail_update ! new total tail number
diff --git a/src/gsi/aniso_ens_util.f90 b/src/gsi/aniso_ens_util.f90
index f118bee40f..43f81216e4 100644
--- a/src/gsi/aniso_ens_util.f90
+++ b/src/gsi/aniso_ens_util.f90
@@ -122,8 +122,8 @@ subroutine ens_uv_to_psichi(u,v,truewind)
do j=1,nlon
rlon=region_lon(i,j)
rlat=region_lat(i,j)
- dlon=float(j)*one
- dlat=float(i)*one
+ dlon=real(j,r_kind)
+ dlat=real(i,r_kind)
ue=u(i,j)
ve=v(i,j)
call rotate_wind_ll2xy(ue,ve,ug,vg,rlon,dlon,dlat)
@@ -440,13 +440,13 @@ subroutine ens_intpcoeffs_reg(ngrds,igbox,iref,jref,igbox0f,ensmask,enscoeff,gbl
yg=rlat+90._r_kind+one
end if
- dxg=xg-float(floor(xg))
- dyg=yg-float(floor(yg))
+ dxg=xg-real(floor(xg),r_kind)
+ dyg=yg-real(floor(yg),r_kind)
dxg1=one-dxg
dyg1=one-dyg
- if (xg>=one .and. xg<=float(jxp) .and. &
- yg>=one .and. yg<=float(iy) ) then
+ if (xg>=one .and. xg<=real(jxp,r_kind) .and. &
+ yg>=one .and. yg<=real(iy,r_kind) ) then
enscoeff(1,i,j,kg)=dxg1*dyg1
enscoeff(2,i,j,kg)=dxg1*dyg
@@ -479,9 +479,9 @@ subroutine ens_intpcoeffs_reg(ngrds,igbox,iref,jref,igbox0f,ensmask,enscoeff,gbl
endif
do j=1,iy
- yg=float(j)*one
+ yg=real(j,r_kind)
do i=1,jx
- xg=float(i)*one
+ xg=real(i,r_kind)
call w3fb12(xg,yg,alat1,elon1,ds,elonv,alatan,rlat,rlon,ierr8)
rlon=rlon/rad2deg
rlat=rlat/rad2deg
@@ -620,34 +620,34 @@ subroutine ens_intpcoeffs_reg(ngrds,igbox,iref,jref,igbox0f,ensmask,enscoeff,gbl
igbox(2,kg)=iimax0(kg)
igbox(3,kg)=jjmin0(kg)
igbox(4,kg)=jjmax0(kg)
- igbox0f(1,kg)=one+float((igbox(1,kg)-1))/pf2aP1%grid_ratio_lat + ijadjust
- igbox0f(2,kg)=one+float((igbox(2,kg)-1))/pf2aP1%grid_ratio_lat - ijadjust
- igbox0f(3,kg)=one+float((igbox(3,kg)-1))/pf2aP1%grid_ratio_lon + ijadjust
- igbox0f(4,kg)=one+float((igbox(4,kg)-1))/pf2aP1%grid_ratio_lon - ijadjust
+ igbox0f(1,kg)=one+real(igbox(1,kg)-1,r_kind)/pf2aP1%grid_ratio_lat + ijadjust
+ igbox0f(2,kg)=one+real(igbox(2,kg)-1,r_kind)/pf2aP1%grid_ratio_lat - ijadjust
+ igbox0f(3,kg)=one+real(igbox(3,kg)-1,r_kind)/pf2aP1%grid_ratio_lon + ijadjust
+ igbox0f(4,kg)=one+real(igbox(4,kg)-1,r_kind)/pf2aP1%grid_ratio_lon - ijadjust
end do
!==> compute blending functions
do i=1,pf2aP1%nlatf
- dist1=float(igbox0f(1,1)-i)
- dist2=float(i-igbox0f(2,1))
+ dist1=real(igbox0f(1,1)-i,r_kind)
+ dist2=real(i-igbox0f(2,1),r_kind)
gblend_b(i,1)=half*(one-tanh(dist1)) !relax to zero
gblend_t(i,1)=half*(one-tanh(dist2)) !outside 212 grid
- dist1=float(igbox0f(1,2)-i)
- dist2=float(i-igbox0f(2,2))
+ dist1=real(igbox0f(1,2)-i,r_kind)
+ dist2=real(i-igbox0f(2,2),r_kind)
gblend_b(i,2)=half*(one-tanh(dist1)) !relax to zero
gblend_t(i,2)=half*(one-tanh(dist2)) !outside 221 grid
end do
do j=1,pf2aP1%nlonf
- dist1=float(igbox0f(3,1)-j)
- dist2=float(j-igbox0f(4,1))
+ dist1=real(igbox0f(3,1)-j,r_kind)
+ dist2=real(j-igbox0f(4,1),r_kind)
gblend_l(j,1)=half*(one-tanh(dist1)) !relax to zero
gblend_r(j,1)=half*(one-tanh(dist2)) !outside 212 grid
- dist1=float(igbox0f(3,2)-j)
- dist2=float(j-igbox0f(4,2))
+ dist1=real(igbox0f(3,2)-j,r_kind)
+ dist2=real(j-igbox0f(4,2),r_kind)
gblend_l(j,2)=half*(one-tanh(dist1)) !relax to zero
gblend_r(j,2)=half*(one-tanh(dist2)) !outside 221 grid
end do
@@ -1141,10 +1141,10 @@ subroutine ens_fill(ur,na,nb,u,nxx,ny,itap,no_wgt_in)
no_wgt=.false.
if(no_wgt_in) no_wgt=.true.
- pionp1=four*atan(one)/float(itap+1)
+ pionp1=four*atan(one)/real(itap+1,r_kind)
do i=1,itap
- xi=float(i)
+ xi=real(i,r_kind)
wt(i)=half+half*cos(pionp1*xi)
enddo
diff --git a/src/gsi/anisofilter.f90 b/src/gsi/anisofilter.f90
index ec05d191ba..c05c764a05 100755
--- a/src/gsi/anisofilter.f90
+++ b/src/gsi/anisofilter.f90
@@ -596,7 +596,7 @@ subroutine anprewgt_reg(mype)
do i=indices%ips,indices%ipe
l =max(min(int(rllatf(i,j)),mlat),1)
lp=min((l+1),mlat)
- dl2=rllatf(i,j)-float(l)
+ dl2=rllatf(i,j)-real(l,r_kind)
dl1=one-dl2
if (ivar <= nrf) then
if (nrf_3d(ivar)) then
@@ -1056,7 +1056,7 @@ subroutine get_aspect_reg_pt(mype)
asp3=scalex3*asp3
endif
- rk1=float(k1-44)
+ rk1=real(k1-44,r_kind)
fblend=half*(one-tanh(rk1))! one
if (nvar_id(k) /= nrf3_loc(nrf3_q)) then
@@ -1126,7 +1126,7 @@ subroutine fact_qopt2(factk,rh,kvar)
d =20.0_r_kind * rh + one
n =int(d)
np =n+1
- dn2=d-float(n)
+ dn2=d-real(n,r_kind)
dn1=one-dn2
n =min0(max(1,n) ,25)
np=min0(max(1,np),25)
@@ -2407,7 +2407,7 @@ subroutine read_bckgstats(mype)
do k=1,nsig
vzimax(k,n)=maxval(one/vz(k,0:mlat+1,n))
vzimin(k,n)=minval(one/vz(k,0:mlat+1,n))
- vziavg(k,n)=sum((one/vz(k,0:mlat+1,n)))/float(mlat+2)
+ vziavg(k,n)=sum((one/vz(k,0:mlat+1,n)))/real(mlat+2,r_kind)
end do
if(print_verbose) then
do k=1,nsig
@@ -2428,13 +2428,13 @@ subroutine read_bckgstats(mype)
do n=1,nrf3
do k=1,nsig
- corzavg(k,n)=sum(corz(1:mlat,k,n))/float(mlat)
- hwllavg(k,n)=sum(hwll(0:mlat+1,k,n))/float(mlat+2)
+ corzavg(k,n)=sum(corz(1:mlat,k,n))/real(mlat,r_kind)
+ hwllavg(k,n)=sum(hwll(0:mlat+1,k,n))/real(mlat+2,r_kind)
end do
end do
do n=1,nvars-nrf3
- corpavg(n)=sum(corp(1:mlat,n))/float(mlat)
- hwllpavg(n)=sum(hwllp(0:mlat+1,n))/float(mlat+2)
+ corpavg(n)=sum(corp(1:mlat,n))/real(mlat,r_kind)
+ hwllpavg(n)=sum(hwllp(0:mlat+1,n))/real(mlat+2,r_kind)
end do
do j=1,mlat
@@ -2869,7 +2869,7 @@ subroutine isotropic_scales(scale1,scale2,scale3,k)
else
l =max(min(int(rllatf(i,j)),mlat),1)
lp=min((l+1),mlat)
- dl2=rllatf(i,j)-float(l)
+ dl2=rllatf(i,j)-real(l,r_kind)
dl1=one-dl2
hwll_loc=dl1*hwll(l,k1,n)+dl2*hwll(lp,k1,n)
end if
@@ -2886,7 +2886,7 @@ subroutine isotropic_scales(scale1,scale2,scale3,k)
l =max(min(int(rllatf(i,j)),mlat),1)
lp=min((l+1),mlat)
- dl2=rllatf(i,j)-float(l)
+ dl2=rllatf(i,j)-real(l,r_kind)
dl1=one-dl2
hwll_loc=cc*(dl1*hwllp(l,n)+dl2*hwllp(lp,n))
scale3(i,j)=one
@@ -2903,7 +2903,7 @@ subroutine isotropic_scales(scale1,scale2,scale3,k)
l =max(min(int(rllatf(i,j)),mlat),1)
lp=min((l+1),mlat)
- dl2=rllatf(i,j)-float(l)
+ dl2=rllatf(i,j)-real(l,r_kind)
dl1=one-dl2
hwll_loc=cc*(dl1*hwllp(l,nn)+dl2*hwllp(lp,nn))
scale3(i,j)=one
@@ -3027,7 +3027,7 @@ subroutine get_theta_corrl_lenghts(mype)
mcount0=lon2*lat2! It's OK to count buffer points
call mpi_allreduce(pbar4a,pbar4(k),1,mpi_real8,mpi_sum,mpi_comm_world,ierror)
call mpi_allreduce(mcount0,mcount,1,mpi_integer4,mpi_sum,mpi_comm_world,ierror)
- pbar4(k)=pbar4(k)/float(mcount)
+ pbar4(k)=pbar4(k)/real(mcount,r_kind)
if(print_verbose) write(6,*)'in get_theta_corrl_lenghts,k,pbar4=',k,pbar4(k)
call w3fa03(pbar4(k),hgt4(k),tbar4(k),thetabar4(k))
end do
@@ -3881,15 +3881,15 @@ subroutine get_aspect_reg_ens(mype)
do j=1,pf2aP1%nlonf
do i=1,pf2aP1%nlatf
- ensv(i,j,k,1)=(ensv(i,j,k,1)+ensv(i,j,k,2)+ensv(i,j,k,3))/sqrt(float(nt1))
- ensv(i,j,k,2)= (ensv(i,j,k,2)+ensv(i,j,k,3))/sqrt(float(nt2))
- ensv(i,j,k,3)= ensv(i,j,k,3) /sqrt(float(nt3))
+ ensv(i,j,k,1)=(ensv(i,j,k,1)+ensv(i,j,k,2)+ensv(i,j,k,3))/sqrt(real(nt1,r_kind))
+ ensv(i,j,k,2)= (ensv(i,j,k,2)+ensv(i,j,k,3))/sqrt(real(nt2,r_kind))
+ ensv(i,j,k,3)= ensv(i,j,k,3) /sqrt(real(nt3,r_kind))
if( ibldani==0 .or. ibldani==2 .or. ibldani==3 ) then
do m=1,6
- c(m,1)=(aniasp(m,i,j,k,1)+aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/float(nt1)
- c(m,2)= (aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/float(nt2)
- c(m,3)= aniasp(m,i,j,k,3) /float(nt3)
+ c(m,1)=(aniasp(m,i,j,k,1)+aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/real(nt1,r_kind)
+ c(m,2)= (aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/real(nt2,r_kind)
+ c(m,3)= aniasp(m,i,j,k,3) /real(nt3,r_kind)
end do
do igd=1,3
qlx=max(qlxmin(ivar,k1),ensv(i,j,k,igd))
@@ -3906,9 +3906,9 @@ subroutine get_aspect_reg_ens(mype)
end do
else if(ibldani==1) then
do m=1,6
- aniasp(m,i,j,k,1)=(aniasp(m,i,j,k,1)+aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/float(nt1)
- aniasp(m,i,j,k,2)= (aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/float(nt2)
- aniasp(m,i,j,k,3)= aniasp(m,i,j,k,3) /float(nt3)
+ aniasp(m,i,j,k,1)=(aniasp(m,i,j,k,1)+aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/real(nt1,r_kind)
+ aniasp(m,i,j,k,2)= (aniasp(m,i,j,k,2)+aniasp(m,i,j,k,3))/real(nt2,r_kind)
+ aniasp(m,i,j,k,3)= aniasp(m,i,j,k,3) /real(nt3,r_kind)
end do
smax=real(maxval(ensv(i,j,k,1:3)),r_kind)
aensv(1,k)=aensv(1,k)+max(smax ,qlxmin(ivar,k1))/nlatlonf
@@ -5326,7 +5326,7 @@ subroutine get2berr_reg_subdomain_option(mype)
l=max(min(int(rllatf(i,j)),mlat),1)
lp=min((l+1),mlat)
- dl2=rllatf(i,j)-float(l)
+ dl2=rllatf(i,j)-real(l,r_kind)
dl1=one-dl2
if (ivar <= nrf) then
if (nrf_3d(ivar)) then
@@ -6520,7 +6520,7 @@ subroutine isotropic_scales_subdomain_option(scale1,scale2,scale3,k,mype)
else
l=int(rllat(iglob,jglob))
lp=l+1
- dl2=rllat(iglob,jglob)-float(l)
+ dl2=rllat(iglob,jglob)-real(l,r_kind)
dl1=one-dl2
hwll_loc=dl1*hwll(l,k1,n)+dl2*hwll(lp,k1,n)
scale3(i,j)=one/vz(k1,l,n)
@@ -6536,7 +6536,7 @@ subroutine isotropic_scales_subdomain_option(scale1,scale2,scale3,k,mype)
l=int(rllat(iglob,jglob))
lp=l+1
- dl2=rllat(iglob,jglob)-float(l)
+ dl2=rllat(iglob,jglob)-real(l,r_kind)
dl1=one-dl2
hwll_loc=cc*(dl1*hwllp(l,n)+dl2*hwllp(lp,n))
scale3(i,j)=one
@@ -6553,7 +6553,7 @@ subroutine isotropic_scales_subdomain_option(scale1,scale2,scale3,k,mype)
l=int(rllat(iglob,jglob))
lp=l+1
- dl2=rllat(iglob,jglob)-float(l)
+ dl2=rllat(iglob,jglob)-real(l,r_kind)
dl1=one-dl2
hwll_loc=cc*(dl1*hwllp(l,nn)+dl2*hwllp(lp,nn))
scale3(i,j)=one
diff --git a/src/gsi/anisofilter_glb.f90 b/src/gsi/anisofilter_glb.f90
index 43e67a3baa..f79b26ab79 100644
--- a/src/gsi/anisofilter_glb.f90
+++ b/src/gsi/anisofilter_glb.f90
@@ -609,7 +609,7 @@ subroutine get_stat_factk(platf,ivar,kvar,factk,rh,dvsst)
l =int(platf)
lp=l+1
- dl2=platf-float(l)
+ dl2=platf-real(l,r_kind)
dl1=one-dl2
l = min(max(1,l ),mlat)
lp= min(max(1,lp),mlat)
@@ -971,7 +971,7 @@ subroutine read_bckgstats_glb(mype)
mcount0=lon2*lat2! It's OK to count buffer points
call mpi_allreduce(pbar4a,pbar4(k),1,mpi_real8,mpi_sum,mpi_comm_world,ierror)
call mpi_allreduce(mcount0,mcount,1,mpi_integer4,mpi_sum,mpi_comm_world,ierror)
- pbar4(k)=pbar4(k)/float(mcount)
+ pbar4(k)=pbar4(k)/real(mcount,r_kind)
end do
psfc015=r015*pbar4(1)
@@ -1160,7 +1160,7 @@ subroutine get_background_glb(mype)
do ilat=1,pf2aP2%nlatf
do ilon=1,pf2aP2%nlonf
- if(((float(ilat)-rnf2)**2+(float(ilon)-rnf2)**2)>=rnf212) then
+ if(((real(ilat,r_kind)-rnf2)**2+(real(ilon,r_kind)-rnf2)**2)>=rnf212) then
p2ilatf(ilat,ilon)=zero
p3ilatf(ilat,ilon)=zero
else
@@ -1611,7 +1611,7 @@ subroutine get_aspect_pt(mype)
cvar=='vp' .or. cvar=='VP' .or. &
cvar=='t' .or. cvar=='T'
- rk1=float(k1-kthres)
+ rk1=real(k1-kthres,r_kind)
fblend=half*(one-tanh(rk1))
!--- zonal patch
@@ -1757,7 +1757,7 @@ subroutine get_theta_corrl_lenghts_glb(mype)
mcount0=lon2*lat2! It's OK to count buffer points
call mpi_allreduce(pbar4a,pbar4(k),1,mpi_real8,mpi_sum,mpi_comm_world,ierror)
call mpi_allreduce(mcount0,mcount,1,mpi_integer4,mpi_sum,mpi_comm_world,ierror)
- pbar4(k)=pbar4(k)/float(mcount)
+ pbar4(k)=pbar4(k)/real(mcount,r_kind)
call w3fa03(pbar4(k),hgt4(k),tbar4(k),thetabar4(k))
end do
@@ -2605,9 +2605,9 @@ subroutine get_aspect_ens(mype)
nt1=max(1,(nens(k)-1))
- s1=maxval(ensv_p0(:,:,k))/float(nt1)
- s2=maxval(ensv_p2(:,:,k))/float(nt1)
- s3=maxval(ensv_p3(:,:,k))/float(nt1)
+ s1=maxval(ensv_p0(:,:,k))/real(nt1,r_kind)
+ s2=maxval(ensv_p2(:,:,k))/real(nt1,r_kind)
+ s3=maxval(ensv_p3(:,:,k))/real(nt1,r_kind)
smax=max(s1,s2,s3)
if ( nkflag(k)==1 ) then
@@ -3729,13 +3729,13 @@ subroutine ens_intpglb_coeff(iref,jref,enscoeff,mype)
xg=rlon+one
yg=rlat+90._r_kind+one
- dxg =xg-float(floor(xg))
- dyg =yg-float(floor(yg))
+ dxg =xg-real(floor(xg),r_kind)
+ dyg =yg-real(floor(yg),r_kind)
dxg1=one-dxg
dyg1=one-dyg
- if (xg >= one .and. xg <= float(jxp) .and. &
- yg >= one .and. yg <= float(iy) ) then
+ if (xg >= one .and. xg <= real(jxp,r_kind) .and. &
+ yg >= one .and. yg <= real(iy,r_kind) ) then
enscoeff(1,i,j)=dxg1*dyg1
enscoeff(2,i,j)=dxg1*dyg
enscoeff(3,i,j)=dxg *dyg1
@@ -3938,7 +3938,7 @@ subroutine ens_uv2psichi(work1,work2)
vor_s = vor_s + grid_vor( 1,ix)
vor_n = vor_n + grid_vor(ny,ix)
end do
- rnlon = one/float(nlon)
+ rnlon = one/real(nlon,r_kind)
div_s = div_s*rnlon
div_n = div_n*rnlon
vor_s = vor_s*rnlon
diff --git a/src/gsi/apply_scaledepwgts.f90 b/src/gsi/apply_scaledepwgts.f90
new file mode 100644
index 0000000000..585711c90b
--- /dev/null
+++ b/src/gsi/apply_scaledepwgts.f90
@@ -0,0 +1,210 @@
+!$$$ program documentation block
+!
+! program history:
+!
+! 2018-03-28 T. Lei and D. Kleist - consoliated and added codes
+! for the scale dependent scale localization scheme
+!
+!$$$ end documentation block
+
+function fwgtofwvlen (rvlft,rvrgt,rcons,rlen,rinput)
+!$$$ subprogram documentation block
+!
+! subprogram: fwgtofwvlen
+!
+! abstract: Calculation of spectral filter functions
+!
+!$$$ end documentation block
+
+ use kinds, only: r_kind
+ implicit none
+
+ real(r_kind),intent(in) :: rvlft,rvrgt,rcons,rlen,rinput
+ real(r_kind) :: fwgtofwvlen
+ real(r_kind) :: rlen1,rtem1,rconshalf
+
+ if(rinput > rvlft .and. rinput < rvrgt) then
+ fwgtofwvlen=rcons
+ else
+ rlen1=rlen/10.0_r_kind ! rlen corresponds to a (-5,5) region
+ rconshalf=0.5_r_kind*rcons
+ rtem1=min(abs(rinput-rvlft),abs(rinput-rvrgt))
+ fwgtofwvlen=rconshalf*(1.0_r_kind+tanh(5.0_r_kind-rtem1/rlen1))
+ endif
+
+end function fwgtofwvlen
+! . . . .
+subroutine init_mult_spc_wgts(jcap_in)
+!$$$ subprogram documentation block
+!
+! subprogram: init_mult_spc_wgts
+!
+!$$$ end documentation block
+
+ use kinds, only: r_kind,i_kind
+ use constants, only: zero,half,one,rearth,pi,tiny_r_kind
+ use mpimod, only: mype
+ use hybrid_ensemble_parameters, only: nsclgrp
+ use hybrid_ensemble_parameters, only: spc_multwgt,spcwgt_params,r_ensloccov4scl
+ implicit none
+
+ integer(i_kind),intent(in ) :: jcap_in
+
+ integer(i_kind) i,l,ks
+ integer(i_kind) ig
+ real(r_kind) :: rwv0,rtem1,rtem2
+ real(r_kind) :: fwgtofwvlen
+ real(r_kind) :: totwvlength
+ real(r_kind),dimension(0:jcap_in,nsclgrp) :: spcwgt
+ logical :: l_sum_spc_weights
+
+ ! Spectral scale decomposition is differernt between SDL-cross and SDL-nocross
+ if( r_ensloccov4scl < tiny_r_kind )then
+ l_sum_spc_weights = .false.
+ else
+ l_sum_spc_weights = .true.
+ end if
+
+ spcwgt(0,1)=one
+ do ig=2,nsclgrp
+ spcwgt(0,ig)=zero
+ end do
+
+
+ rwv0=2.0_r_kind*pi*rearth*0.001_r_kind
+ do i=1,jcap_in
+ totwvlength= rwv0/real(i)
+ rtem1=zero
+ do ig=1,nsclgrp
+ if(ig /= 2) then
+ spcwgt(i,ig)=fwgtofwvlen(spcwgt_params(1,ig),spcwgt_params(2,ig),&
+ spcwgt_params(3,ig),spcwgt_params(4,ig),totwvlength)
+ spcwgt(i,ig)=min(max(spcwgt(i,ig),zero),one)
+ if(l_sum_spc_weights) then
+ rtem1=rtem1+spcwgt(i,ig)
+ else
+ rtem1=rtem1+spcwgt(i,ig)*spcwgt(i,ig)
+ endif
+ endif
+ enddo
+ rtem2 =1.0_r_kind - rtem1
+ if(rtem2 >= zero) then
+
+ if(l_sum_spc_weights) then
+ spcwgt(i,2)=rtem2
+ else
+ spcwgt(i,2)=sqrt(rtem2)
+ endif
+ else
+ if(mype == 0)write(6,*) ' rtem2 < zero ',i,rtem2,(spcwgt(i,ig),ig=1,nsclgrp)
+ spcwgt(i,2)=zero
+ endif
+ enddo
+!! Code borrowed from spvar in splib
+
+ spc_multwgt = zero
+ do ig=1,nsclgrp
+ do i=0,jcap_in
+ ks=2*i
+ spc_multwgt(ks+1,ig)=spcwgt(i,ig)
+ end do
+ do i=0,jcap_in
+ do l=MAX(1,i-jcap_in),MIN(i,jcap_in)
+ ks=l*(2*jcap_in+1-l)+2*i
+ spc_multwgt(ks+1,ig) = spcwgt(i,ig)
+ spc_multwgt(ks+2,ig) = spcwgt(i,ig)
+ end do
+ end do
+ end do
+
+
+ return
+end subroutine init_mult_spc_wgts
+subroutine destroy_mult_spc_wgts
+!$$$ subprogram documentation block
+!
+! subprogram: destroy_mult_spc_wgts
+!
+!$$$ end documentation block
+
+ use hybrid_ensemble_parameters, only: spc_multwgt,spcwgt_params
+ implicit none
+
+ deallocate(spc_multwgt,spcwgt_params)
+
+ return
+end subroutine destroy_mult_spc_wgts
+
+
+subroutine apply_scaledepwgts(m,grd_in,sp_in)
+!
+! Program history log:
+! 2017-03-30 J. Kay, X. Wang - copied from Kleist's apply_scaledepwgts and
+! add the calculation of scale-dependent weighting for mixed resolution ensemble
+! POC: xuguang.wang@ou.edu
+!
+ use constants, only: one
+ use control_vectors, only: control_vector
+ use kinds, only: r_kind,i_kind,r_single
+ use gsi_bundlemod, only: gsi_bundle
+ use general_sub2grid_mod, only: general_sub2grid,general_grid2sub
+ use general_specmod, only: spec_vars
+ use general_sub2grid_mod, only: sub2grid_info
+ use hybrid_ensemble_parameters, only: spc_multwgt,en_perts,nsclgrp,n_ens
+ implicit none
+
+! Declare passed variables
+ integer,intent(in) :: m
+ type(spec_vars),intent (in):: sp_in
+ type(sub2grid_info),intent(in)::grd_in
+
+! Declare local variables
+ integer(i_kind) kk,ig,n,ig2,i,j
+
+ real(r_single),dimension(grd_in%nlat,grd_in%nlon,grd_in%nlevs_alloc,nsclgrp) :: hwork2
+ real(r_kind),dimension(grd_in%nlat,grd_in%nlon) :: work
+ real(r_kind),dimension(sp_in%nc,grd_in%nlevs_alloc):: spc1
+ real(r_kind),dimension(sp_in%nc):: spc2
+
+ do n=1,n_ens
+! Get from subdomains to full grid
+ call general_sub2grid(grd_in,en_perts(n,1,m)%valuesr4(:),hwork2(:,:,:,1))
+
+!$omp parallel do schedule(static,1) private(i,j,kk,work)
+ do kk=1,grd_in%nlevs_loc
+ do j=1,grd_in%nlon
+ do i=1,grd_in%nlat
+ work(i,j)=hwork2(i,j,kk,1)
+ end do
+ end do
+! Transform from physical space to spectral space
+ call general_g2s0(grd_in,sp_in,spc1(1,kk),work)
+
+ end do
+!$omp parallel do schedule(static,1) private(kk,ig,ig2,i,j,work,spc2)
+ do ig2=1,nsclgrp*grd_in%nlevs_loc
+ ig=(ig2-1)/grd_in%nlevs_loc+1
+ kk=ig2-(ig-1)*grd_in%nlevs_loc
+
+ do i=1,sp_in%nc
+ spc2(i)=spc1(i,kk)*spc_multwgt(i,ig)
+ end do
+! Apply spectral weights
+! Transform back to physical space
+ call general_s2g0(grd_in,sp_in,spc2,work)
+
+ do j=1,grd_in%nlon
+ do i=1,grd_in%nlat
+ hwork2(i,j,kk,ig)=work(i,j)
+ end do
+ end do
+ end do
+ do ig=1,nsclgrp
+
+! Transfer work back to subdomains
+ call general_grid2sub(grd_in,hwork2(:,:,:,ig),en_perts(n,ig,m)%valuesr4(:))
+ end do
+ end do
+
+ return
+end subroutine apply_scaledepwgts
diff --git a/src/gsi/atms_spatial_average_mod.f90 b/src/gsi/atms_spatial_average_mod.f90
index dd05faa23e..639bb8c99c 100644
--- a/src/gsi/atms_spatial_average_mod.f90
+++ b/src/gsi/atms_spatial_average_mod.f90
@@ -153,7 +153,7 @@ SUBROUTINE ATMS_Spatial_Average(Num_Obs, NChanl, FOV, Time, BT_InOut, &
Scanline_Back(FOV(I),Scanline(I))=I
END DO
-!$omp parallel do schedule(dynamic,1) private(ichan,iscan,ios,ifov)
+!$omp parallel do schedule(dynamic,1) private(i,ichan,iscan,ios,ifov)
DO IChan=1,nchanl
err(ichan)=0
@@ -841,7 +841,7 @@ SUBROUTINE SFFTCB( X, N, M )
END DO
J = J + K
104 CONTINUE
- XT = 1.0_r_kind / FLOAT( N )
+ XT = 1.0_r_kind / real( N,r_kind )
DO 99, I = 1, N
X(I) = XT * X(I)
99 CONTINUE
diff --git a/src/gsi/balmod.f90 b/src/gsi/balmod.f90
index 1b9fa9030b..96181864a1 100644
--- a/src/gsi/balmod.f90
+++ b/src/gsi/balmod.f90
@@ -443,7 +443,7 @@ subroutine prebal_reg(cwcoveqqcov)
do i=1,lat2
l=int(rllat1(i,j))
l2=min0(l+1,llmax)
- dl2=rllat1(i,j)-float(l)
+ dl2=rllat1(i,j)-real(l,r_kind)
dl1=one-dl2
bvk(i,j,k)=dl1*bvi(l,k)+dl2*bvi(l2,k)
end do
@@ -465,7 +465,7 @@ subroutine prebal_reg(cwcoveqqcov)
do i=1,lat2
l=int(rllat1(i,j))
l2=min0(l+1,llmax)
- dl2=rllat1(i,j)-float(l)
+ dl2=rllat1(i,j)-real(l,r_kind)
dl1=one-dl2
agvk(i,j,m,k)=dl1*agvi(l,m,k)+dl2*agvi(l2,m,k)
end do
@@ -477,7 +477,7 @@ subroutine prebal_reg(cwcoveqqcov)
do i=1,lat2
l=int(rllat1(i,j))
l2=min0(l+1,llmax)
- dl2=rllat1(i,j)-float(l)
+ dl2=rllat1(i,j)-real(l,r_kind)
dl1=one-dl2
wgvk(i,j,k)=dl1*wgvi(l,k)+dl2*wgvi(l2,k)
end do
@@ -689,13 +689,7 @@ subroutine balance(t,p,st,vp,fpsproj,fut2ps)
!! Strong balance constraint
!! Pass uvflag=.false.
- if(lsqrtb) then
- call strong_bk(st,vp,p,t,.false.)
- else
- if(tlnmc_option==1 .or. tlnmc_option==4) call strong_bk(st,vp,p,t,.false.)
- endif
-
-
+ if(lsqrtb .or. tlnmc_option==1 .or. tlnmc_option==4) call strong_bk(st,vp,p,t,.false.)
return
end subroutine balance
@@ -777,11 +771,7 @@ subroutine tbalance(t,p,st,vp,fpsproj,fut2ps)
! Adjoint of strong balance constraint
! pass uvflag=.false.
- if(lsqrtb) then
- call strong_bk_ad(st,vp,p,t,.false.)
- else
- if(tlnmc_option==1 .or. tlnmc_option==4) call strong_bk_ad(st,vp,p,t,.false.)
- endif
+ if(lsqrtb .or. tlnmc_option==1 .or. tlnmc_option==4) call strong_bk_ad(st,vp,p,t,.false.)
! REGIONAL BRANCH
if (regional) then
@@ -972,7 +962,7 @@ subroutine locatelat_reg(mype)
do j=1,nlon
do i=1,nlat
if(region_lat(i,j)>=clat_avn(mlat))then
- rllat(i,j)=float(mlat)
+ rllat(i,j)=real(mlat,r_kind)
llmax=max0(mlat,llmax)
llmin=min0(mlat,llmin)
else if(region_lat(i,j)=clat_avn(m)).and. &
(region_lat(i,j)=1.and.ltcost_) call allocate_cv(gradf)
call allocate_cv(dirw)
-!--- 'zeta' is an upper bound on the relative error of the gradient.
+if(l_hyb_ens .and. .not. aniso_a_en) then
+ if (lsqrtb) then
+ write(6,*)'l_hyb_ens: not for use with lsqrtb'
+ call stop2(317)
+ end if
+end if
+ !--- 'zeta' is an upper bound on the relative error of the gradient.
zeta = 1.0e-4_r_kind
zreqrd = preduc
diff --git a/src/gsi/bkerror.f90 b/src/gsi/bkerror.f90
index b3a0140691..7eb83b09d6 100644
--- a/src/gsi/bkerror.f90
+++ b/src/gsi/bkerror.f90
@@ -71,7 +71,6 @@ subroutine bkerror(grady)
! Declare local variables
integer(i_kind) i,ii
- integer(i_kind) i_t,i_p,i_st,i_vp
integer(i_kind) ipnts(4),istatus
! integer(i_kind) nval_lenz,ndim2d
real(r_kind),pointer,dimension(:,:,:):: p_t =>NULL()
@@ -97,11 +96,7 @@ subroutine bkerror(grady)
! Only need to get pointer for ii=1 - all other are the same
call gsi_bundlegetpointer ( grady%step(1), (/'t ','sf','vp','ps'/), &
ipnts, istatus )
- i_t = ipnts(1)
- i_st = ipnts(2)
- i_vp = ipnts(3)
- i_p = ipnts(4)
- dobal = i_t>0.and.i_p>0.and.i_st>0.and.i_vp>0
+ dobal = ipnts(1)>0 .and. ipnts(2)>0 .and. ipnts(3)>0 .and. ipnts(4)>0
! if ensemble run, multiply by sqrt_beta_s
if(l_hyb_ens) call sqrt_beta_s_mult(grady)
diff --git a/src/gsi/bkgvar_rewgt.f90 b/src/gsi/bkgvar_rewgt.f90
index ca82882af3..c463723206 100644
--- a/src/gsi/bkgvar_rewgt.f90
+++ b/src/gsi/bkgvar_rewgt.f90
@@ -99,7 +99,7 @@ subroutine bkgvar_rewgt(sfvar,vpvar,tvar,psvar,mype)
balt =zero ; bald =zero ; balps =zero
! Set count to number of global grid points in quad precision
- fcount = float(nlat)*float(nlon)
+ fcount = real(nlat*nlon,r_kind)
! Set parameter for communication
mm1=mype+1
diff --git a/src/gsi/buddycheck_mod.f90 b/src/gsi/buddycheck_mod.f90
index ae4a29cc63..9c58fd0a44 100644
--- a/src/gsi/buddycheck_mod.f90
+++ b/src/gsi/buddycheck_mod.f90
@@ -200,7 +200,7 @@ subroutine buddy_check_t(is,data,luse,mype,nele,nobs,muse,buddyuse)
end if
- rsig=float(nsig)
+ rsig=real(nsig,r_kind)
mm1=mype+1
!initialize buddyuse to 1, start by assuming all obs are good!
diff --git a/src/gsi/cads.f90 b/src/gsi/cads.f90
new file mode 100644
index 0000000000..6d7e584ef1
--- /dev/null
+++ b/src/gsi/cads.f90
@@ -0,0 +1,2230 @@
+module cads
+!$$$ module documentation block
+!
+! module: cads
+! prgmmr: Jung
+!
+! abstract: module containing subroutines for the cloud and aerosol detection software
+!
+! program history log:
+!
+!
+!
+! subroutines included:
+!
+!
+! remarks: variable definitions
+!
+!
+!$$$ end documentation block
+
+
+ use kinds, only: i_kind, r_kind
+ implicit none
+ save
+
+! set default to private
+ private
+! set routines to public
+ public :: cloud_aerosol_detection
+ public :: cads_setup_cloud
+ public :: Cloud_Detect_Type
+ public :: cads_imager_calc
+
+ public :: M__Sensor,N__Num_Bands,N__GradChkInterval,N__Band_Size,N__Bands,N__Window_Width, &
+ N__Window_Bounds,R__BT_Threshold,R__Grad_Threshold,R__Window_Grad_Threshold, L__Do_Quick_Exit, &
+ L__Do_CrossBand, N__BandToUse,L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, &
+ N__Num_Imager_Clusters,N__Imager_Chans,R__Stddev_Threshold,R__Coverage_Threshold, &
+ R__FG_Departure_Threshold
+
+ INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor
+ INTEGER(i_kind) :: N__Num_Bands ! Number of channel bands
+ INTEGER(i_kind), POINTER :: N__GradChkInterval(:) ! Window width used in gradient calculation
+ INTEGER(i_kind), POINTER :: N__Band_Size(:) ! Number of channels in each band
+ INTEGER(i_kind), POINTER :: N__Bands(:,:) ! Channel lists
+ INTEGER(i_kind), POINTER :: N__Window_Width(:) ! Smoothing filter window widths per band
+ INTEGER(i_kind), POINTER :: N__Window_Bounds(:,:) ! Channels in the spectral window gradient check
+ INTEGER(i_kind), POINTER :: N__BandToUse(:) ! Band number assignment for each channel
+ LOGICAL :: L__Do_Quick_Exit ! On/off switch for the Quick Exit scenario
+ LOGICAL :: L__Do_CrossBand ! On/off switch for the cross-band method
+ REAL(r_kind), POINTER :: R__BT_Threshold(:) ! BT threshold for cloud contamination
+ REAL(r_kind), POINTER :: R__Grad_Threshold(:) ! Gradient threshold for cloud contamination
+ REAL(r_kind), POINTER :: R__Window_Grad_Threshold(:) ! Threshold for window gradient check in QE
+
+ LOGICAL :: L__Do_Imager_Cloud_Detection ! On/off switch for the imager cloud detection
+ INTEGER(i_kind) :: N__Num_Imager_Chans ! No. of imager channels
+ INTEGER(i_kind) :: N__Num_Imager_Clusters ! No. of clusters to be expected
+ INTEGER(i_kind),POINTER :: N__Imager_Chans(:) ! List of imager channels
+ REAL(r_kind),POINTER :: R__Stddev_Threshold(:) ! St. Dev. threshold, one for each imager channel
+ REAL(r_kind) :: R__Coverage_Threshold ! Threshold for fractional coverage of a cluster
+ REAL(r_kind) :: R__FG_Departure_Threshold ! Threshold for imager FG departure
+
+
+! set passed variables to public
+
+! This software was developed within the context of the EUMETSAT
+! Satellite Application Facility on Numerical Weather Prediction
+! (NWP SAF), under the Cooperation Agreement dated 7 December 2016,
+! between EUMETSAT and the Met Office, UK, by one or more partners
+! within the NWP SAF. The partners in the NWP SAF are the Met
+! Office, ECMWF, DWD and MeteoFrance.
+!
+! Copyright 2020, EUMETSAT, All Rights Reserved.
+
+! * CADS_Module *
+! A. Collard ECMWF 01/02/06
+
+! * PURPOSE *
+! -----------
+! Sets up structures to be used in processing of advanced IR sounders.
+
+! * MODIFICATIONS *
+! -----------------
+! 01/02/06 A.Collard 1.0 Original export version.
+! 17/11/09 R.Eresmaa 1.1 Include parameters of the Quick Exit /
+! long-wave window gradient check.
+! 11/11/11 R.Eresmaa 1.2 Add processing capability for CrIS.
+! 03/12/13 R.Eresmaa 2.0 Add imager-assisted cloud detection.
+! 10/11/15 R.Eresmaa 2.2 Changed instrument ID naming convention.
+! Changed aerosol detection parameters.
+! 20/12/16 R.Eresmaa 2.3 Remove aerosol detection parameters.
+! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications.
+! 16/04/20 R.Eresmaa 3.0 Combine cloud and aerosol detection, rename.
+! Include aerosol type recognition.
+! Include land sensitivity parameters.
+! Include trace gas detection. Rename.
+
+
+ INTEGER(i_kind), PARAMETER :: INST_ID_AIRS = 11
+ INTEGER(i_kind), PARAMETER :: INST_ID_IASI = 16
+ INTEGER(i_kind), PARAMETER :: INST_ID_CRIS = 27
+ INTEGER(i_kind), PARAMETER :: INST_ID_IRS = 57
+ INTEGER(i_kind), PARAMETER :: INST_ID_IASING = 59
+ INTEGER(i_kind), PARAMETER :: INST_ID_IKFS2 = 94
+ INTEGER(i_kind), PARAMETER :: INST_ID_HIRAS = 97
+ INTEGER(i_kind), PARAMETER :: INST_ID_GIIRS = 98
+
+ INTEGER(i_kind), PARAMETER :: JP__MIN_SENSOR_INDEX = INST_ID_AIRS
+ INTEGER(i_kind), PARAMETER :: JP__MAX_SENSOR_INDEX = INST_ID_GIIRS
+
+ TYPE Aerosol_Detect_Type
+ INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor
+ INTEGER(i_kind) :: N__Num_Aerosol_Tests ! Number of aerosol detection tests
+ INTEGER(i_kind), POINTER :: N__Num_Regression(:) ! Number of conversion coefficients for AOD
+ INTEGER(i_kind), POINTER :: N__Num_Aerosol_Chans(:) ! Number of aerosol detection channels
+ INTEGER(i_kind), POINTER :: N__Aerosol_Chans(:,:) ! List of aerosol detection channels
+ INTEGER(i_kind) :: N__Mean_Aerosol_Chans ! Boxcar averaging window width
+ REAL(r_kind), POINTER :: R__Aerosol_TBD(:,:) ! Aerosol detection thresholds
+ REAL(r_kind), POINTER :: R__coef_AOD(:,:) ! Coefficients for conversion to AOD
+ REAL(r_kind) :: R__Rank_Thres_Coeff(3) ! Coefficients to restrict rejections to affected channels
+ REAL(r_kind) :: R__Unclassified_Thres ! Rejection threshold for unclassified aerosol
+ REAL(r_kind) :: R__Land_Fraction_Thres ! Threshold for land fraction in FOV
+ END TYPE Aerosol_Detect_Type
+
+ TYPE Cloud_Detect_Type
+ INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor
+ INTEGER(i_kind) :: N__Num_Bands ! Number of channel bands
+ INTEGER(i_kind), POINTER :: N__GradChkInterval(:) ! Window width used in gradient calculation
+ INTEGER(i_kind), POINTER :: N__Band_Size(:) ! Number of channels in each band
+ INTEGER(i_kind), POINTER :: N__Bands(:,:) ! Channel lists
+ INTEGER(i_kind), POINTER :: N__Window_Width(:) ! Smoothing filter window widths per band
+ INTEGER(i_kind), POINTER :: N__Window_Bounds(:,:) ! Channels in the spectral window gradient check
+ INTEGER(i_kind), POINTER :: N__BandToUse(:) ! Band number assignment for each channel
+ LOGICAL :: L__Do_Quick_Exit ! On/off switch for the Quick Exit scenario
+ LOGICAL :: L__Do_CrossBand ! On/off switch for the cross-band method
+ REAL(r_kind), POINTER :: R__BT_Threshold(:) ! BT threshold for cloud contamination
+ REAL(r_kind), POINTER :: R__Grad_Threshold(:) ! Gradient threshold for cloud contamination
+ REAL(r_kind), POINTER :: R__Window_Grad_Threshold(:) ! Threshold for window gradient check in QE
+
+ LOGICAL :: L__Do_Imager_Cloud_Detection ! On/off switch for the imager cloud detection
+ INTEGER(i_kind) :: N__Num_Imager_Chans ! No. of imager channels
+ INTEGER(i_kind) :: N__Num_Imager_Clusters ! No. of clusters to be expected
+ INTEGER(i_kind),POINTER :: N__Imager_Chans(:) ! List of imager channels
+ REAL(r_kind),POINTER :: R__Stddev_Threshold(:) ! St. Dev. threshold, one for each imager channel
+ REAL(r_kind) :: R__Coverage_Threshold ! Threshold for fractional coverage of a cluster
+ REAL(r_kind) :: R__FG_Departure_Threshold ! Threshold for imager FG departure
+ END TYPE Cloud_Detect_Type
+
+ TYPE Land_Sensitivity_Type
+ INTEGER(r_kind) :: M__Sensor ! Unique ID for sensor
+ REAL(r_kind) :: R__Land_Fraction_Thres ! Threshold on land fraction
+ REAl(r_kind) :: R__Level_Thres ! Threshold on normalized channel height assignment
+ END TYPE Land_Sensitivity_Type
+
+ TYPE Trace_Gas_Detect_Type
+ INTEGER(i_kind) :: M__Sensor ! Unique ID for sensor
+ INTEGER(i_kind) :: N__Num_Trace_Gas_Checks ! Number of trace gases to be checked
+ INTEGER(i_kind),POINTER :: N__Num_Tracer_Channels(:) ! Number of gas-sensitive channels
+ INTEGER(i_kind),POINTER :: N__Tracer_Channels(:,:) ! Gas-sensitive channels
+ INTEGER(i_kind),POINTER :: N__Num_Control_Channels(:) ! Number of control channels
+ INTEGER(i_kind),POINTER :: N__Control_Channels(:,:) ! Control channels
+ INTEGER(i_kind),POINTER :: N__Num_Flagged_Channels(:) ! Number of affected channels
+ INTEGER(i_kind),POINTER :: N__Flagged_Channels(:,:) ! Affected channels
+ REAL(r_kind),POINTER :: R__D_Obs_Threshold(:) ! Observed Tb difference threshold
+ REAL(r_kind),POINTER :: R__D_Dep_Threshold(:) ! Departure difference threshold
+ END TYPE Trace_Gas_Detect_Type
+
+
+ TYPE(Aerosol_Detect_Type) :: &
+ S__CADS_Setup_Aerosol(JP__Min_Sensor_Index:JP__Max_Sensor_Index)
+
+ TYPE(Cloud_Detect_Type) :: &
+ S__CADS_Setup_Cloud(JP__Min_Sensor_Index:JP__Max_Sensor_Index)
+
+ TYPE(Land_Sensitivity_Type) :: &
+ S__CADS_Setup_Land(JP__Min_Sensor_Index:JP__Max_Sensor_Index)
+
+ TYPE(Trace_Gas_Detect_Type) :: &
+ S__CADS_Setup_Trace_Gas(JP__Min_Sensor_Index:JP__Max_Sensor_Index)
+
+
+contains
+
+SUBROUTINE CADS_Abort(String)
+
+! This software was developed within the context of the EUMETSAT
+! Satellite Application Facility on Numerical Weather Prediction
+! (NWP SAF), under the Cooperation Agreement dated 7 December 2016,
+! between EUMETSAT and the Met Office, UK, by one or more partners
+! within the NWP SAF. The partners in the NWP SAF are the Met
+! Office, ECMWF, DWD and MeteoFrance.
+!
+! Copyright 2020, EUMETSAT, All Rights Reserved.
+
+! *CADS_Abort*
+! R. Eresmaa ECMWF 16/04/20
+
+! * PURPOSE *
+! -----------
+! Controlled abortion of running CADS when facing exceptions such as
+! necessary input files missing or they are corrupt.
+
+! * INTERFACE *
+! -------------
+! *CALL* * CADS_Abort()* from
+! CADS_Main, CADS_Setup_Aerosol, CADS_Setup_Cloud,
+! CADS_Setup_Land_Sensitivity, or CADS_Setup_Trace_Gas.
+
+ IMPLICIT NONE
+ CHARACTER(LEN=*) :: String
+
+ WRITE(*,*) String
+ STOP
+
+END SUBROUTINE CADS_Abort
+
+subroutine cloud_aerosol_detection( I__Sensor_ID, I__Num_Chans, I__Chan_ID, &
+ I__Min_Level, I__Max_Level, Z__BT_Obser, Z__BT_Model, Z__Chan_Height, K__Chan_ID_Imager, &
+ Z__Cluster_Fraction, Z__BT_in_Cluster, Z__BT_Overall_SDev, Z__BT_Model_Imager, &
+ I__Flag_Cloud, Z__Cloud_Level )
+
+!$$$ subprogram documentation block
+! . . .
+! subprogram: cloud_aerosol_detection determine clear/cloudy profiles from hyperspectral IR instruments
+!
+! prgmmr: jung org: cimss date: 2022-10-17
+!
+! abstract: determine if a profile is clear/cloudy. If cloudy, determine which channels are affected
+! This subroutine is designed for infrared hyperspectral sounders. Current code supports AIRS, IASI and CrIS.a
+! This subroutine is based on the Cloud and Aerosol Detection Software Version 3 developed within the context
+! of the EUMETSAT and Met Office, UK, by one or more partners within the Numerical Weather Predicion's
+! Satellite Application Facilities. A version of this code is operational at ECMWF.
+! COPYRIGHT 2020, EUMETSAT, ALL RIGHTS RESERVED.
+!
+! program history log:
+! 2022-10-17 jung Initial coding
+!
+! input argument list:
+! I_Sensor_ID - internal sensor identification.
+! I__Num_Chans - number of channels per obs
+! I__Chan_ID - array of actual channel numbers
+! Z__Longitude - FOV longitude
+! Z__Latitude - FOV latitude
+! Z__Land_Fraction - FOV land fraction
+! I__Min_Level - model tropopause height (start of cloud detection)
+! I__Max_Level - model top of boundary layer ( stop of cloud detection)
+! Z__BT_Obser - observaton brightness temperature
+! Z__BT_Model - model derived brightness temperature
+! Z__Chan_Height - model derived height where an opaque cloud influences the radiance.
+! also used to re-organize channels
+! Z__Cloud_Level - Cloud height assignment
+!
+! output argument list:
+! icloud_layer - model layer where cloud is detected
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+ use kinds, only: i_kind, r_kind
+ implicit none
+
+ integer(i_kind), intent(in ) :: I__Sensor_ID
+ integer(i_kind), intent(in ) :: I__Num_Chans
+ integer(i_kind),dimension(I__Num_Chans),intent(in ) :: I__Chan_ID
+ integer(i_kind), intent(in ) :: I__Min_Level !tropopause pressure
+ integer(i_kind), intent(in ) :: I__Max_Level !boundary layer pressure
+ real(r_kind), intent(in ) :: Z__BT_Obser(:) !Observation BT
+ real(r_kind), intent(in ) :: Z__BT_Model(:) !Model derived BT
+ real(r_kind), intent(in ) :: Z__Chan_Height(:) !Channel height assignmenta
+ integer(i_kind), intent(in ) :: K__Chan_ID_Imager(:) ! imager channel numbers
+ real(r_kind), intent(in ) :: Z__Cluster_Fraction(:)
+ real(r_kind), intent(in ) :: Z__BT_in_Cluster(:,:)
+ real(r_kind), intent(in ) :: Z__BT_Overall_SDev(:)
+ real(r_kind), intent(in ) :: Z__BT_Model_Imager(:)
+ real(r_kind), intent( out) :: Z__Cloud_Level ! cloud height assignment
+ integer(i_kind),dimension(I__Num_Chans),intent( out) :: I__Flag_Cloud ! cloud use flag
+
+! Interim prodcts
+
+! Diagnostics: percentages of positive detections
+! Input/Output file management
+
+ N__Num_Imager_Chans = S__CADS_Setup_Cloud(I__Sensor_ID) % N__Num_Imager_Chans
+ N__Num_Imager_Clusters = S__CADS_Setup_Cloud(I__Sensor_ID) % N__Num_Imager_Clusters
+
+ CALL CADS_Detect_Cloud( I__Sensor_ID, I__Num_Chans, I__Chan_ID,I__Min_Level, I__Max_Level, N__Num_Imager_Chans, &
+ K__Chan_ID_Imager, N__Num_Imager_Clusters, I__Flag_Cloud, Z__BT_Obser, Z__BT_Model, Z__Chan_Height, &
+ Z__Cluster_Fraction, Z__BT_in_Cluster, Z__BT_Overall_SDev, Z__BT_Model_Imager, Z__Cloud_Level )
+
+end subroutine cloud_aerosol_detection
+
+SUBROUTINE CADS_Setup_Cloud
+
+! This software was developed within the context of the EUMETSAT
+! Satellite Application Facility on Numerical Weather Prediction
+! (NWP SAF), under the Cooperation Agreement dated 7 December 2016,
+! between EUMETSAT and the Met Office, UK, by one or more partners
+! within the NWP SAF. The partners in the NWP SAF are the Met
+! Office, ECMWF, DWD and Meteo France.
+!
+! Copyright 2020, EUMETSAT, All Rights Reserved.
+
+
+! * Cloud detection setup *
+! A. Collard ECMWF 01/02/06
+
+! * PURPOSE *
+! -----------
+! Initialise cloud detection parameters for advanced infrared sounders.
+
+! * INTERFACE *
+! -------------
+! CADS_Setup_Cloud is called from CADS_Main.
+
+! * METHOD *
+! ----------
+! Default values are assigned to the cloud detections setup structure.
+
+! MODIFICATIONS
+! -------------
+! 01/02/06 A.Collard 1.0 Original code.
+! 19/10/06 A.Collard 1.1 Use IASI 300 Subset Channels.
+! 17/11/09 R.Eresmaa 1.2 Use IASI 366 Subset Channels.
+! Include parameters of the Quick Exit /
+! long-wave window gradient check parameters.
+! 11/11/11 R.Eresmaa 1.3 Default channel list for AIRS bands 3-5
+! modified.
+! Processing capability for CrIS added
+! assuming a selection of 320 channels.
+! 03/12/13 R,Eresmaa 2.0 Imager-assisted cloud detection added for
+! IASI.
+! Updated setup for CrIS.
+! 19/01/15 R.Eresmaa 2.1 Remove unused variable specifications and
+! switch aerosol detection on by default for
+! AIRS and IASI.
+! 10/11/15 R.Eresmaa 2.2 Changed instrument ID naming convention.
+! Changed parameters of aerosol detection.
+! 20/12/16 R.Eresmaa 2.3 Remove settings for aerosol detection.
+! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications.
+! Add HIRAS, GIIRS (IASING + IRS added earlier)
+! 16/04/20 R.Eresmaa 3.0 Rename, tidy up.
+
+ use kinds, only: i_kind, r_kind
+ use gsi_io, only: verbose
+ IMPLICIT NONE
+
+! Local variables
+
+ CHARACTER(LEN=6) :: CL__InstrumentName
+ CHARACTER(LEN=20) :: CL__Cloud_Detection_File
+
+ INTEGER(i_kind) :: J, J__Sensor ! Loop variables
+ INTEGER(i_kind) :: INIU1, IOS
+
+!-----------------------
+! Namelist variables
+!-----------------------
+
+! N.B. Max_Bands must be greater than 5
+ INTEGER(i_kind), PARAMETER :: JP__Max_Bands = 8
+ INTEGER(i_kind), PARAMETER :: JP__Max_Channels = 8461
+
+ INTEGER(i_kind) :: M__Sensor
+ INTEGER(i_kind) :: N__Num_Bands
+ INTEGER(i_kind) :: N__GradChkInterval(JP__Max_Bands)
+ INTEGER(i_kind) :: N__Band_Size(JP__Max_Bands)
+ INTEGER(i_kind) :: N__Bands(JP__Max_Channels,JP__Max_Bands)
+ INTEGER(i_kind) :: N__Window_Width(JP__Max_Bands)
+ INTEGER(i_kind) :: N__Window_Bounds(JP__Max_Bands,2)
+ REAL(r_kind) :: R__BT_Threshold(JP__Max_Bands)
+ REAL(r_kind) :: R__Grad_Threshold(JP__Max_Bands)
+ REAL(r_kind) :: R__Window_Grad_Threshold(JP__Max_Bands)
+ LOGICAL :: L__Do_Quick_Exit
+ LOGICAL :: L__Do_CrossBand
+ INTEGER(i_kind) :: N__BandToUse(JP__Max_Bands)
+
+! Imager-based cloud detection
+ LOGICAL :: L__Do_Imager_Cloud_Detection
+ INTEGER(i_kind) :: N__Num_Imager_Chans
+ INTEGER(i_kind) :: N__Num_Imager_Clusters
+ INTEGER(i_kind) :: N__Imager_Chans(JP__Max_Bands)
+ REAL(r_kind) :: R__Stddev_Threshold(JP__Max_Bands)
+ REAL(r_kind) :: R__Coverage_Threshold
+ REAL(r_kind) :: R__FG_Departure_Threshold
+
+! Namelist
+ NAMELIST / Cloud_Detect_Coeffs / M__Sensor, N__Num_Bands, &
+ N__Band_Size, N__Bands, N__Window_Width, N__Window_Bounds, &
+ N__GradChkInterval, R__BT_Threshold, R__Grad_Threshold, &
+ R__Window_Grad_Threshold, L__Do_Quick_Exit, &
+ L__Do_CrossBand, N__BandToUse, &
+ L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, &
+ N__Num_Imager_Clusters, N__Imager_Chans, &
+ R__Stddev_Threshold, R__Coverage_Threshold, &
+ R__FG_Departure_Threshold
+
+!============================================================================
+! Loop through sensors setting up cloud detection
+!============================================================================
+
+ SensorLoop : DO J__Sensor = JP__Min_Sensor_Index, JP__Max_Sensor_Index
+
+! SELECT CASE (I__Sensor_ID)
+ SELECT CASE (J__Sensor)
+
+ CASE(INST_ID_AIRS)
+ !====================
+ ! Set up AIRS
+ !====================
+
+ CL__InstrumentName='AIRS'
+ CL__Cloud_Detection_File = 'AIRS_CLDDET.NL'
+
+ N__Num_Bands = 5
+
+ N__Band_Size(:) = 0
+ N__Band_Size(1:N__Num_Bands) =(/138, 36, 54, 23, 65 /)
+
+ N__Bands(:,:)= 0
+
+ N__Bands(1:N__Band_Size(1),1) = &
+ (/ 1, 6, 7, 10, 11, 15, 16, 17, 20, 21, &
+ 22, 24, 27, 28, 30, 36, 39, 40, 42, 51, &
+ 52, 54, 55, 56, 59, 62, 63, 68, 69, 71, &
+ 72, 73, 74, 75, 76, 77, 78, 79, 80, 82, &
+ 83, 84, 86, 92, 93, 98, 99, 101, 104, 105, &
+ 108, 110, 111, 113, 116, 117, 123, 124, 128, 129, &
+ 138, 139, 144, 145, 150, 151, 156, 157, 159, 162, &
+ 165, 168, 169, 170, 172, 173, 174, 175, 177, 179, &
+ 180, 182, 185, 186, 190, 192, 193, 198, 201, 204, &
+ 207, 210, 213, 215, 216, 218, 221, 224, 226, 227, &
+ 232, 239, 248, 250, 251, 252, 253, 256, 257, 261, &
+ 262, 267, 272, 295, 299, 305, 308, 309, 310, &
+ 318, 321, 333, 338, 355, 362, 375, 475, &
+ 484, 497, 528, 587, 672, 787, 791, 843, 870, 914, &
+ 950 /)
+
+ N__Bands(1:N__Band_Size(2),2) = &
+ (/ 1003, 1012, 1019, 1024, 1030, 1038, 1048, 1069, 1079, 1082, &
+ 1083, 1088, 1090, 1092, 1095, 1104, 1111, 1115, 1116, 1119, &
+ 1120, 1123, 1130, 1138, 1142, 1178, 1199, 1206, 1221, 1237, &
+ 1252, 1260, 1263, 1266, 1278, 1285 /)
+
+ N__Bands(1:N__Band_Size(3),3) = &
+ (/ 1290, 1301, 1304, 1329, 1371, 1382, 1415, 1424, 1449, 1455, &
+ 1466, 1471, 1477, 1479, 1488, 1500, 1519, 1520, 1538, 1545, &
+ 1565, 1574, 1583, 1593, 1614, 1627, 1636, 1644, 1652, 1669, &
+ 1674, 1681, 1694, 1708, 1717, 1723, 1740, 1748, 1751, 1756, &
+ 1763, 1766, 1771, 1777, 1780, 1783, 1794, 1800, 1803, 1806, &
+ 1812, 1826, 1843, 1852 /)
+
+ N__Bands(1:N__Band_Size(4),4) = &
+ (/ 1865, 1866, 1867, 1868, 1869, 1872, 1873, 1875, 1876, 1877, &
+ 1881, 1882, 1883, 1884, 1897, 1901, 1911, 1917, 1918, 1921, &
+ 1923, 1924, 1928 /)
+
+ N__Bands(1:N__Band_Size(5),5) = &
+ (/ 1937, 1938, 1939, 1941, 1946, 1947, 1948, 1958, 1971, 1973, &
+ 1988, 1995, 2084, 2085, 2097, 2098, 2099, 2100, 2101, 2103, &
+ 2104, 2106, 2107, 2108, 2109, 2110, 2111, 2112, 2113, 2114, &
+ 2115, 2116, 2117, 2118, 2119, 2120, 2121, 2122, 2123, 2128, &
+ 2134, 2141, 2145, 2149, 2153, 2164, 2189, 2197, 2209, 2226, &
+ 2234, 2280, 2318, 2321, 2325, 2328, 2333, 2339, 2348, 2353, &
+ 2355, 2363, 2370, 2371, 2377 /)
+
+ N__GradChkInterval(:) = 0
+ N__GradChkInterval(1:N__Num_Bands) = (/ 5,5,5,5,5 /)
+
+ N__Window_Width(:) = 0
+ N__Window_Width(1:N__Num_Bands) = (/ 14,6,8,5,8 /)
+
+ N__Window_Bounds(:,:) = 0
+ N__Window_Bounds(1,1) = 475
+ N__Window_Bounds(1,2) = 950
+
+ R__BT_Threshold(:) = 0.0_r_kind
+ R__BT_Threshold(1:N__Num_Bands) = (/ 0.43_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind/)
+
+ R__Grad_Threshold(:) = 0.0_r_kind
+ R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind /)
+
+ R__Window_Grad_Threshold(:) = 0.0_r_kind
+ R__Window_Grad_Threshold(1) = 0.4_r_kind
+
+ L__Do_Quick_Exit = .TRUE.
+
+
+ ! This is cross-band:
+
+ L__Do_CrossBand = .TRUE.
+
+ N__BandToUse(:) = 0
+ N__BandToUse(1:N__Num_Bands) = (/ 1,1,1,4,1 /)
+
+
+ ! This is the setup for imager cloud detection
+
+ L__Do_Imager_Cloud_Detection = .FALSE.
+
+ N__Num_Imager_Chans = 0
+ N__Num_Imager_Clusters = 0
+ N__Imager_Chans(:) = 0
+
+ R__Stddev_Threshold(:) = 0.0_r_kind
+ R__Coverage_Threshold = 0.0_r_kind
+ R__FG_Departure_Threshold = 0.0_r_kind
+
+
+ CASE(INST_ID_IASI)
+ !====================
+ ! Set up IASI
+ !====================
+
+ CL__InstrumentName='IASI'
+ CL__Cloud_Detection_File = 'IASI_CLDDET.NL'
+
+ N__Num_Bands = 5
+
+ N__Band_Size(:) = 0
+ N__Band_Size(1:N__Num_Bands) =(/ 184, 15, 116, 4, 15 /)
+
+ N__Bands(:,:)= 0
+
+ ! Use the "IASI 366" Subset
+ N__Bands(1:N__Band_Size(1),1) = &
+ (/ 16, 38, 49, 51, 55, 57, 59, 61, 63, 66, &
+ 70, 72, 74, 79, 81, 83, 85, 87, 89, 92, &
+ 95, 97, 99, 101, 104, 106, 109, 111, 113, 116, &
+ 119, 122, 125, 128, 131, 133, 135, 138, 141, 144, &
+ 146, 148, 151, 154, 157, 159, 161, 163, 165, 167, &
+ 170, 173, 176, 178, 179, 180, 183, 185, 187, 189, &
+ 191, 193, 195, 197, 199, 201, 203, 205, 207, 210, &
+ 212, 214, 217, 219, 222, 224, 226, 228, 230, 232, &
+ 234, 236, 239, 241, 242, 243, 246, 249, 252, 254, &
+ 256, 258, 260, 262, 265, 267, 269, 271, 272, 273, &
+ 275, 278, 280, 282, 284, 286, 288, 290, 292, 294, &
+ 296, 299, 301, 303, 306, 308, 310, 312, 314, 316, &
+ 318, 320, 323, 325, 327, 329, 331, 333, 335, 341, &
+ 347, 350, 352, 354, 356, 358, 360, 362, 364, 366, &
+ 369, 371, 373, 375, 377, 379, 381, 386, 389, 404, &
+ 407, 410, 414, 416, 426, 428, 432, 434, 445, 457, &
+ 515, 546, 552, 566, 571, 573, 646, 662, 668, 756, &
+ 867, 921, 1027, 1090, 1133, 1191, 1194, 1271, 1805, 1884, &
+ 1946, 1991, 2094, 2239 /)
+
+ N__Bands(1:N__Band_Size(2),2) = &
+ (/ 1479, 1509, 1513, 1521, 1536, 1574, 1579, 1585, 1587, 1626, &
+ 1639, 1643, 1652, 1658, 1671 /)
+
+ N__Bands(1:N__Band_Size(3),3) = &
+ (/ 2119, 2213, 2271, 2321, 2398, 2701, 2741, 2819, 2889, 2907, &
+ 2910, 2919, 2939, 2944, 2948, 2951, 2958, 2977, 2985, 2988, &
+ 2991, 2993, 3002, 3008, 3014, 3027, 3029, 3036, 3047, 3049, &
+ 3053, 3058, 3064, 3069, 3087, 3093, 3098, 3105, 3107, 3110, &
+ 3127, 3136, 3151, 3160, 3165, 3168, 3175, 3178, 3207, 3228, &
+ 3244, 3248, 3252, 3256, 3263, 3281, 3303, 3309, 3312, 3322, &
+ 3375, 3378, 3411, 3438, 3440, 3442, 3444, 3446, 3448, 3450, &
+ 3452, 3454, 3458, 3467, 3476, 3484, 3491, 3497, 3499, 3504, &
+ 3506, 3509, 3518, 3527, 3555, 3575, 3577, 3580, 3582, 3586, &
+ 3589, 3599, 3653, 3658, 3661, 4032, 5368, 5371, 5379, 5381, &
+ 5383, 5397, 5399, 5401, 5403, 5405, 5455, 5480, 5483, 5485, &
+ 5492, 5502, 5507, 5509, 5517, 5558 /)
+
+ N__Bands(1:N__Band_Size(4),4) = &
+ (/ 5988, 5992, 5994, 6003 /)
+
+ N__Bands(1:N__Band_Size(5),5) = &
+ (/ 6982, 6985, 6987, 6989, 6991, 6993, 6995, 6997, 7267, 7269, &
+ 7424, 7426, 7428, 7885, 8007 /)
+
+ N__GradChkInterval(:) = 0
+ N__GradChkInterval(1:N__Num_Bands) = (/12,5,5,5,5 /)
+
+ N__Window_Width(:) = 0
+ N__Window_Width(1:N__Num_Bands) = (/ 10,6,8,5,8 /)
+
+ N__Window_Bounds(:,:) = 0
+ N__Window_Bounds(1,1) = 573
+ N__Window_Bounds(1,2) = 2239
+
+ R__BT_Threshold(:) = 0.0_r_kind
+ R__BT_Threshold(1:N__Num_Bands) = (/ 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind /)
+
+ R__Grad_Threshold(:) = 0.0_r_kind
+ R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind /)
+
+ R__Window_Grad_Threshold(:) = 0.0_r_kind
+ R__Window_Grad_Threshold(1) = 0.4_r_kind
+
+ L__Do_Quick_Exit = .TRUE.
+
+
+ ! This is cross-band:
+
+ L__Do_CrossBand = .TRUE.
+
+ N__BandToUse(:) = 0
+ N__BandToUse(1:N__Num_Bands) = (/ 1,1,1,1,1 /)
+
+
+ ! This is the setup for imager cloud detection
+
+ L__Do_Imager_Cloud_Detection = .TRUE.
+
+ N__Num_Imager_Chans = 2
+ N__Num_Imager_Clusters = 7
+
+ N__Imager_Chans(1:N__Num_Imager_Chans) = (/ 2, 3 /)
+
+ R__Stddev_Threshold(1:N__Num_Imager_Chans) = (/ 0.75_r_kind, 0.80_r_kind /)
+
+ R__Coverage_Threshold = 0.03_r_kind
+ R__FG_Departure_Threshold = 1.0_r_kind
+
+
+ CASE(INST_ID_CRIS)
+ !====================
+ ! Set up CRIS
+ !====================
+
+ CL__InstrumentName='CRIS'
+ CL__Cloud_Detection_File = 'CRIS_CLDDET.NL'
+
+ N__Num_Bands = 5
+
+ N__Band_Size(:) = 0
+
+ N__Band_Size(1:N__Num_Bands) =(/ 137, 123, 76, 12, 6 /)
+
+ N__Bands(:,:)= 0
+
+ ! Use the "CRIS 300" Subset
+ N__Bands(1:N__Band_Size(1),1) = &
+ (/ 1, 5, 9, 13, 17, 18, 19, 20, 21, 22, &
+ 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, &
+ 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, &
+ 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, &
+ 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, &
+ 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, &
+ 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, &
+ 83, 84, 85, 86, 87, 88, 91, 92, 93, 94, &
+ 95, 96, 97, 99, 101, 105, 107, 109, 111, 113, &
+ 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, &
+ 125, 133, 135, 137, 139, 141, 144, 147, 161, 173, &
+ 177, 181, 185, 195, 210, 221, 225, 229, 249, 257, &
+ 269, 273, 293, 301, 317, 333, 349, 369, 409, 433, &
+ 457, 481, 501, 549, 701, 705, 709 /)
+
+ N__Bands(1:N__Band_Size(2),2) = &
+ (/ 3, 6, 7, 8, 10, 12, 14, 15, 16, 89, &
+ 90, 102, 103, 104, 106, 108, 110, 114, 126, 127, &
+ 129, 132, 134, 138, 140, 143, 145, 146, 148, 149, &
+ 150, 151, 153, 155, 156, 157, 158, 159, 162, 163, &
+ 164, 165, 166, 169, 170, 171, 172, 175, 180, 189, &
+ 200, 201, 205, 206, 214, 217, 218, 226, 228, 230, &
+ 231, 233, 236, 237, 240, 241, 245, 248, 252, 264, &
+ 265, 281, 285, 297, 324, 327, 361, 378, 389, 392, &
+ 400, 473, 493, 500, 503, 511, 527, 528, 529, 530, &
+ 531, 534, 538, 542, 544, 545, 547, 550, 553, 555, &
+ 590, 594, 598, 602, 606, 610, 614, 618, 622, 626, &
+ 645, 649, 653, 657, 661, 665, 685, 702, 703, 704, &
+ 706, 707, 713 /)
+
+ N__Bands(1:N__Band_Size(3),3) = &
+ (/ 717, 725, 728, 729, 730, 731, 732, 733, 734, 735, &
+ 736, 741, 749, 757, 765, 773, 781, 789, 794, 797, &
+ 805, 806, 815, 822, 829, 839, 845, 853, 861, 868, &
+ 869, 872, 877, 885, 887, 893, 898, 900, 909, 912, &
+ 915, 917, 921, 929, 933, 941, 949, 957, 963, 965, &
+ 973, 975, 978, 981, 989, 991, 993, 996, 1005, 1014, &
+ 1025, 1029, 1037, 1042, 1053, 1061, 1073, 1077, 1085, 1093, &
+ 1101, 1109, 1117, 1125, 1133, 1141 /)
+
+ N__Bands(1:N__Band_Size(4),4) = &
+ (/ 1149, 1157, 1164, 1165, 1173, 1181, 1189, 1197, 1205, 1213, &
+ 1221, 1251 /)
+
+ N__Bands(1:N__Band_Size(5),5) = &
+ (/ 1189, 1197, 1205, 1213, 1221, 1251 /)
+
+
+ N__GradChkInterval(:) = 0
+ N__GradChkInterval(1:N__Num_Bands) = (/ 5,5,5,3,3 /)
+
+ N__Window_Width(:) = 0
+ N__Window_Width(1:N__Num_Bands) = (/ 6,6,8,3,3 /)
+
+ N__Window_Bounds(:,:) = 0
+ N__Window_Bounds(1,1) = 229
+ N__Window_Bounds(1,2) = 549
+
+ R__BT_Threshold(:) = 0.0_r_kind
+ R__BT_Threshold(1:N__Num_Bands) = (/ 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind, 0.5_r_kind /)
+
+ R__Grad_Threshold(:) = 0.0_r_kind
+ R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind, 0.02_r_kind /)
+
+ R__Window_Grad_Threshold(:) = 0.0_r_kind
+ R__Window_Grad_Threshold(1) = 0.4_r_kind
+
+ L__Do_Quick_Exit = .TRUE.
+
+
+ ! This is cross-band:
+
+ L__Do_CrossBand = .TRUE.
+
+ N__BandToUse(:) = 0
+ N__BandToUse(1:N__Num_Bands) = (/ 1,1,1,1,1 /)
+
+
+ ! This is the setup for imager cloud detection
+
+ L__Do_Imager_Cloud_Detection = .FALSE.
+
+ N__Num_Imager_Chans = 0
+ N__Num_Imager_Clusters = 0
+ N__Imager_Chans(:) = 0
+
+ R__Stddev_Threshold(:) = 0.0_r_kind
+ R__Coverage_Threshold = 0.0_r_kind
+ R__FG_Departure_Threshold = 0.0_r_kind
+
+
+ CASE(INST_ID_IRS)
+ !====================
+ ! Set up IRS
+ !====================
+
+ CL__InstrumentName='IRS'
+ CL__Cloud_Detection_File = 'IRS_CLDDET.NL'
+
+ N__Num_Bands = 1
+
+ N__Band_Size(:) = 0
+
+ N__Band_Size(1:N__Num_Bands) =(/ 138 /)
+
+ N__Bands(:,:)= 0
+
+ N__Bands(1:N__Band_Size(1),1) = &
+ (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, &
+ 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, &
+ 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, &
+ 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, &
+ 41, 42, 43, 44, 45, 46, 48, 53, 54, 55, &
+ 56, 57, 58, 60, 61, 62, 63, 65, 70, 74, &
+ 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, &
+ 85, 86, 87, 89, 90, 91, 92, 93, 94, 95, &
+ 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, &
+ 106, 107, 108, 109, 118, 119, 131, 145, 163, 169, &
+ 177, 180, 190, 195, 199, 209, 215, 221, 231, 237, &
+ 252, 262, 268, 281, 289, 298, 312, 322, 328, 341, &
+ 347, 359, 375, 384, 390, 404, 412, 421, 648, 656, &
+ 667, 678, 686, 692, 709, 750, 792, 808 /)
+
+ N__GradChkInterval(:) = 0
+ N__GradChkInterval(1:N__Num_Bands) = (/ 12 /)
+
+ N__Window_Width(:) = 0
+ N__Window_Width(1:N__Num_Bands) = (/ 10 /)
+
+ N__Window_Bounds(:,:) = 0
+ N__Window_Bounds(1,1) = 131
+ N__Window_Bounds(1,2) = 808
+
+ R__BT_Threshold(:) = 0.0_r_kind
+ R__BT_Threshold(1:N__Num_Bands) = (/ 0.4_r_kind /)
+
+ R__Grad_Threshold(:) = 0.0_r_kind
+ R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind /)
+
+ R__Window_Grad_Threshold(:) = 0.0_r_kind
+ R__Window_Grad_Threshold(1) = 0.4_r_kind
+
+ L__Do_Quick_Exit = .TRUE.
+
+
+ ! This is cross-band:
+
+ L__Do_CrossBand = .TRUE.
+
+ N__BandToUse(:) = 0
+ N__BandToUse(1:N__Num_Bands) = (/ 1 /)
+
+
+ ! This is the setup for imager cloud detection
+
+ L__Do_Imager_Cloud_Detection = .FALSE.
+
+ N__Num_Imager_Chans = 0
+ N__Num_Imager_Clusters = 0
+ N__Imager_Chans(:) = 0
+
+ R__Stddev_Threshold(:) = 0.0_r_kind
+ R__Coverage_Threshold = 0.0_r_kind
+ R__FG_Departure_Threshold = 0.0_r_kind
+
+
+ CASE(INST_ID_IASING)
+ !====================
+ ! Set up IASING
+ !====================
+
+ CL__InstrumentName='IASING'
+ CL__Cloud_Detection_File = 'IASING_CLDDET.NL'
+
+ N__Num_Bands = 1
+
+ N__Band_Size(:) = 0
+
+ N__Band_Size(1:N__Num_Bands) =(/ 254 /)
+
+ N__Bands(:,:)= 0
+
+ N__Bands(1:N__Band_Size(1),1) = &
+ (/ 31, 75, 97, 101, 109, 113, 117, 121, 125, 131, &
+ 139, 143, 147, 157, 161, 165, 169, 173, 177, 183, &
+ 189, 193, 197, 201, 207, 211, 217, 221, 225, 231, &
+ 237, 243, 249, 255, 261, 265, 269, 275, 281, 287, &
+ 291, 295, 301, 307, 313, 317, 321, 325, 329, 333, &
+ 339, 345, 351, 355, 357, 359, 365, 369, 373, 377, &
+ 381, 385, 389, 393, 397, 401, 403, 405, 407, 409, &
+ 411, 413, 415, 417, 419, 421, 423, 425, 427, 429, &
+ 431, 433, 435, 437, 439, 441, 443, 445, 447, 449, &
+ 451, 453, 455, 457, 459, 461, 463, 465, 467, 469, &
+ 471, 473, 475, 477, 479, 481, 483, 485, 487, 489, &
+ 491, 493, 495, 497, 499, 501, 503, 505, 507, 509, &
+ 511, 513, 515, 517, 519, 521, 523, 525, 527, 529, &
+ 531, 533, 535, 537, 539, 541, 543, 545, 547, 549, &
+ 551, 553, 555, 557, 559, 561, 563, 565, 567, 569, &
+ 571, 573, 575, 577, 579, 581, 583, 585, 587, 589, &
+ 591, 593, 595, 597, 601, 603, 605, 607, 609, 611, &
+ 613, 615, 617, 619, 621, 623, 625, 627, 629, 631, &
+ 633, 635, 637, 639, 641, 643, 645, 647, 649, 651, &
+ 653, 655, 657, 659, 661, 663, 665, 667, 669, 681, &
+ 693, 699, 703, 707, 711, 715, 719, 723, 727, 731, &
+ 737, 741, 745, 749, 753, 757, 761, 771, 777, 807, &
+ 813, 819, 827, 831, 851, 855, 863, 867, 889, 913, &
+ 1029, 1091, 1103, 1131, 1141, 1145, 1291, 1323, 1335, 1511, &
+ 1733, 1841, 2053, 2179, 2265, 2381, 2387, 2541, 3609, 3767, &
+ 3891, 3981, 4187, 4477 /)
+
+ N__GradChkInterval(:) = 0
+ N__GradChkInterval(1:N__Num_Bands) = (/ 25 /)
+
+ N__Window_Width(:) = 0
+ N__Window_Width(1:N__Num_Bands) = (/ 20 /)
+
+ N__Window_Bounds(:,:) = 0
+ N__Window_Bounds(1,1) = 1145
+ N__Window_Bounds(1,2) = 4477
+
+ R__BT_Threshold(:) = 0.0_r_kind
+ R__BT_Threshold(1:N__Num_Bands) = (/ 0.27_r_kind /)
+
+ R__Grad_Threshold(:) = 0.0_r_kind
+ R__Grad_Threshold(1:N__Num_Bands) = (/ 0.02_r_kind /)
+
+ R__Window_Grad_Threshold(:) = 0.0_r_kind
+ R__Window_Grad_Threshold(1) = 0.4_r_kind
+
+ L__Do_Quick_Exit = .TRUE.
+
+
+ ! This is cross-band:
+
+ L__Do_CrossBand = .TRUE.
+
+ N__BandToUse(:) = 0
+ N__BandToUse(1:N__Num_Bands) = (/ 1 /)
+
+ ! This is the setup for imager cloud detection
+
+ L__Do_Imager_Cloud_Detection = .FALSE.
+
+ N__Num_Imager_Chans = 0
+ N__Num_Imager_Clusters = 0
+ N__Imager_Chans(:) = 0
+
+ R__Stddev_Threshold(:) = 0.0_r_kind
+ R__Coverage_Threshold = 0.0_r_kind
+ R__FG_Departure_Threshold = 0.0_r_kind
+
+
+ END SELECT
+
+ !------------------------------------------------------------------
+ ! Open and read file containing cloud detection setup for the
+ ! current instrument
+ !------------------------------------------------------------------
+
+ INIU1=107
+ OPEN(INIU1,STATUS='OLD',FORM='FORMATTED', &
+ FILE=TRIM(CL__Cloud_Detection_File), IOSTAT=IOS)
+ IF (IOS == 0) THEN
+ READ(INIU1,nml=Cloud_Detect_Coeffs,IOSTAT=IOS)
+ IF (IOS == 0) THEN
+ if ( verbose ) WRITE(*,'(3X,A)') TRIM(CL__InstrumentName) // &
+ ' CLOUD DETECTION FILE READ OK'
+ ELSE
+ CALL CADS_Abort('PROBLEM READING '//TRIM(CL__InstrumentName)//&
+ 'CLOUD DETECTION FILE')
+ ENDIF
+ CLOSE(INIU1)
+ ELSE
+ if ( verbose ) WRITE(*,'(3X,A)') 'NO '//TRIM(CL__InstrumentName) // &
+ ' CLOUD DETECTION FILE : Using Default Values'
+ ENDIF
+
+ IF (MAXVAL(N__Band_Size(:)) > JP__Max_Channels) &
+ CALL CADS_Abort('Too many channels specified in cloud '//&
+ 'detection - increase JP__Max_Channels')
+
+
+ M__Sensor = J__SENSOR
+
+ !------------------------------------------------------------------
+ ! Set up the S__CADS_Setup_Cloud structure for current sensor
+ !------------------------------------------------------------------
+
+ S__CADS_Setup_Cloud(J__SENSOR) % M__SENSOR = M__Sensor
+
+ S__CADS_Setup_Cloud(J__SENSOR) % N__Num_Bands = N__Num_Bands
+
+ ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % N__Band_Size(N__Num_Bands) )
+
+ S__CADS_Setup_Cloud(J__SENSOR) % N__Band_Size(:) = &
+ N__Band_Size(1:N__Num_Bands)
+
+ ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % N__Bands &
+ (MAXVAL(N__Band_Size(:)), N__Num_Bands))
+
+ S__CADS_Setup_Cloud(J__SENSOR) % N__Bands(:,:) = 0
+
+ DO J = 1, N__Num_Bands
+ S__CADS_Setup_Cloud(J__SENSOR) % N__Bands(1:N__Band_Size(J),J) = &
+ N__Bands(1:N__Band_Size(J),J)
+ ENDDO
+
+ ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Width(N__Num_Bands) )
+
+ S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Width(:) = &
+ N__Window_Width(1:N__Num_Bands)
+
+ ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % R__BT_Threshold(N__Num_Bands) )
+ S__CADS_Setup_Cloud(J__SENSOR) % R__BT_Threshold(:) = &
+ R__BT_Threshold(1:N__Num_Bands)
+
+ ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % R__Grad_Threshold(N__Num_Bands))
+ S__CADS_Setup_Cloud(J__SENSOR) % R__Grad_Threshold(:) = &
+ R__Grad_Threshold(1:N__Num_Bands)
+
+ ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % &
+ R__Window_Grad_Threshold(N__Num_Bands))
+
+ S__CADS_Setup_Cloud(J__SENSOR) % R__Window_Grad_Threshold(:) = &
+ R__Window_Grad_Threshold(1:N__Num_Bands)
+
+ ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % N__GradChkInterval(N__Num_Bands))
+ S__CADS_Setup_Cloud(J__SENSOR) % N__GradChkInterval(:) = &
+ N__GradChkInterval(1:N__Num_Bands)
+
+ ALLOCATE(S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Bounds(N__Num_Bands,2))
+ S__CADS_Setup_Cloud(J__SENSOR) % N__Window_Bounds(:,:) = &
+ N__Window_Bounds(1:N__Num_Bands,:)
+
+ S__CADS_Setup_Cloud(J__SENSOR) % L__Do_Quick_Exit = L__Do_Quick_Exit
+
+
+ !-------------
+ ! Cross Band
+ !-------------
+
+ S__CADS_Setup_Cloud(J__SENSOR) % L__Do_CrossBand = L__Do_CrossBand
+
+ ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % N__BandToUse(N__Num_Bands) )
+ S__CADS_Setup_Cloud(J__SENSOR) % N__BandToUse(:) = &
+ N__BandToUse(1:N__Num_Bands)
+
+
+ !-------------
+ ! Imager cloud detection
+ !-------------
+
+ S__CADS_Setup_Cloud(J__SENSOR) % L__Do_Imager_Cloud_Detection = &
+ L__Do_Imager_Cloud_Detection
+
+ S__CADS_Setup_Cloud(J__SENSOR) % N__Num_Imager_Chans = &
+ N__Num_Imager_Chans
+
+ S__CADS_Setup_Cloud(J__SENSOR) % N__Num_Imager_Clusters = &
+ N__Num_Imager_Clusters
+
+ ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % &
+ N__Imager_Chans(N__Num_Imager_Chans))
+ S__CADS_Setup_Cloud(J__SENSOR) % N__Imager_Chans(:) = &
+ N__Imager_Chans(1:N__Num_Imager_Chans)
+
+ ALLOCATE( S__CADS_Setup_Cloud(J__SENSOR) % &
+ R__Stddev_Threshold(N__Num_Imager_Chans))
+ S__CADS_Setup_Cloud(J__SENSOR) % R__Stddev_Threshold(:) = &
+ R__Stddev_Threshold(1:N__Num_Imager_Chans)
+
+ S__CADS_Setup_Cloud(J__SENSOR) % R__Coverage_Threshold = &
+ R__Coverage_Threshold
+
+ S__CADS_Setup_Cloud(J__SENSOR) % R__FG_Departure_Threshold = &
+ R__FG_Departure_Threshold
+
+ ENDDO SensorLoop
+
+END SUBROUTINE CADS_SETUP_CLOUD
+
+SUBROUTINE CADS_Detect_Cloud( K__Sensor, K__NChans, K__ChanID, K__Minlev, K__Maxlev, &
+ K__Num_Imager_Chans, K__Chan_ID_Imager, K__Num_Imager_Clusters, &
+ K__Cloud_Flag, P__ObsBTs, P__ModelBTs, P__Chan_Level, P__Cluster_Fraction,&
+ P__BT_in_Cluster, P__BT_Overall_SDev, P__BT_Model_Imager, Z__Cloud_Level )
+
+! This software was developed within the context of the EUMETSAT
+! Satellite Application Facility on Numerical Weather Prediction
+! (NWP SAF), under the Cooperation Agreement dated 7 December 2016,
+! between EUMETSAT and the Met Office, UK, by one or more partners
+! within the NWP SAF. The partners in the NWP SAF are the Met
+! Office, ECMWF, DWD and MeteoFrance.
+
+! Copyright 2020, EUMETSAT, All Rights Reserved.
+
+! * CADS_Detect_Cloud *
+! Phil Watts ECMWF 21/01/02
+
+! * PURPOSE *
+! -----------
+! Flag the presence or otherwise of cloud contamination in AIRS/IASI
+! channels using a rank-sorted/model difference method. Currently
+! only a digital filter is supported.
+
+
+! * INTERFACE *
+! -------------
+! *CALL* * CADS_Detect_Cloud( )* (from CADS_Main)
+! WHERE K__Sensor : Satellite sensor (AIRS/IASI/CrIS)
+! K__NChans : Number of channels
+! K__ChanID : Channel indices of input channels
+! K__Minlev : Highest allowed starting point for the cloud search
+! K__Maxlev : Lowest allowed starting point in the initial cloud search
+! K__Num_Imager_Chans : Number of collocated imager channels
+! K__Chan_ID_Imager : Collocated imager channel indices
+! K__Num_Imager_Clusters : Number of collocated clusters
+! K__Cloud_Flag : Cloud flag by channel; 0=clear, 1=cloudy
+! P__ObsBTs : Potentially cloud-affected observed BTs
+! P__ModelBTs : Clear background brightness temperatures (BTs)
+! P__Chan_Level : Channel height assignments
+! P__Cluster_Fraction : Fractional coverage of each cluster within FOV
+! P__BT_in_Cluster : Cluster-mean brightness temperature (BT) on each channel
+! P__BT_Overall_SDev : Overall BT standard deviation on each channel
+! P__BT_Model_Imager : Forward-modelled BT on each channel
+! Z__Cloud_Level : Cloud height assignment
+
+! * EXTERNALS *
+! -------------
+! CADS_Detect_Cloud_Imager, CADS_Detect_Cloud_Heapsort,
+! CADS_Detect_Cloud_Smooth, CADS_Detect_Cloud_Scenario,
+! CADS_Detect_Cloud_Separator
+
+! * MODIFICATIONS *
+! -----------------
+! A.Collard 1.0 01/02/06 Original export version
+! A.Collard 1.0.1 03/05/06 Allow for missing channels
+! A.Collard 1.0.2 04/05/06 Allow cross-band cloud detection
+! A.Collard 1.0.3 15/01/07 Initialise with automatic cross-band for
+! all channels from band 1 for IASI
+! R.Eresmaa 1.1 17/11/09 Include parameters of the Quick Exit /
+! long-wave window gradient check.
+! Pass K__Chan_Low to CF_DIGITAL to allow
+! detecting cirrus in case of compensating
+! humidity bg error in PBL.
+! R.Eresmaa 1.2 11/11/11 Modify the cross-band option to be based
+! on the lowest clear channel rather than
+! on the highest cloud-contaminated one
+! R.Eresmaa 2.0 27/11/13 Add input cloud flag based on collocated
+! imager data
+! R.Eresmaa 2.1 13/01/15 Make array size specifications implicit.
+! R.Eresmaa 2.2 10/11/15 Instrument ID naming convention made
+! consistent with RTTOV.
+! Changed setting of the aerosol flag.
+! R.Eresmaa 2.2.1 13/11/15 Don't allow flagging missing channels clear
+! through the cross-band option.
+! R.Eresmaa 2.3 20/12/16 Remove the call to aerosol detection.
+! R.Eresmaa 2.4 05/02/19 Explicit KIND specifications.
+! R.Eresmaa 3.0 16/04/20 Move the call to imager-based detection here.
+
+ use kinds, only: i_kind, r_kind
+ use gsi_io, only: verbose
+ IMPLICIT NONE
+
+!* 0.1 Global arrays
+ INTEGER(i_kind), INTENT(IN) :: K__Sensor ! Sensor
+ INTEGER(i_kind), INTENT(IN) :: K__NChans ! No. of channels
+ INTEGER(i_kind), INTENT(IN) :: K__ChanID(:) ! Channel IDs
+ INTEGER(i_kind), INTENT(IN) :: K__Minlev ! Highest starting point for cloud search
+ INTEGER(i_kind), INTENT(IN) :: K__Maxlev ! Lowest starting point in the initial search
+ INTEGER(i_kind), INTENT(IN) :: K__Num_Imager_Chans ! No. of imager channels
+ INTEGER(i_kind), INTENT(IN) :: K__Chan_ID_Imager(:) ! Imager channel IDs
+ INTEGER(i_kind), INTENT(IN) :: K__Num_Imager_Clusters ! No. of imager clusters
+ INTEGER(i_kind), INTENT(OUT) :: K__Cloud_Flag(:) ! Output cloud flags
+ REAL(r_kind), INTENT(IN) :: P__ObsBTs(:) ! Observed BTs
+ REAL(r_kind), INTENT(IN) :: P__ModelBTs(:) ! Model clear BTs
+ REAL(r_kind), INTENT(IN) :: P__Chan_Level(:) ! Channel height assignments
+ REAL(r_kind), INTENT(IN) :: P__Cluster_Fraction(:) ! Cluster coverages
+ REAL(r_kind), INTENT(IN) :: P__BT_in_Cluster(:,:) ! Mean BT in cluster / channel
+ REAL(r_kind), INTENT(IN) :: P__BT_Overall_Sdev(:) ! St.Dev of imager BT in FOV
+ REAL(r_kind), INTENT(IN) :: P__BT_Model_Imager(:) ! Model-based estimate of imager BT
+ REAL(r_kind), INTENT(OUT) :: Z__Cloud_Level ! Cloud hight assignment
+
+!* 0.2 local variables
+ INTEGER(i_kind) :: IST,ICOUNT,J,I_K,JBAND,JBAND2
+ INTEGER(i_kind) :: I__Imager_Flag ! Preliminary cloud flag from collocated imager data
+
+!* 0.3 Local variables - band splitting details
+ INTEGER(i_kind), POINTER :: I__Bands(:,:) ! Channel bands
+ INTEGER(i_kind), POINTER :: I__Band_Size(:) ! Number of channels per band
+ INTEGER(i_kind), POINTER :: I__BandToUse(:) ! Cross-band definitions
+ INTEGER(i_kind) :: I__Num_Bands ! Number of bands
+ INTEGER(i_kind) :: I__NumFoundChans ! Number of usable channels
+ INTEGER(i_kind) :: I__BandNumber(K__NChans) ! Channel band indicator
+ INTEGER(i_kind) :: I__WindowBounds(2) ! Boundary of window
+ INTEGER(i_kind) :: I__Window_Chans(2) ! Boundary of long-wave window
+ INTEGER(i_kind), ALLOCATABLE :: I__INDEX(:) ! Channel ranking within a band
+ INTEGER(i_kind), ALLOCATABLE :: IDCHAN(:) ! Overall channel ranking
+ INTEGER(i_kind), ALLOCATABLE :: I__Cloud_Flag(:) ! Rank-sorted output cloud flags
+ INTEGER(i_kind) :: I__Scenario_Index ! 1--Quick Exit, 2--Warm Start, 3--Cold Start
+ INTEGER(i_kind) :: I__Start_Channel ! Final starting channel in the cloud search
+
+ LOGICAL :: LL__Do_CrossBand
+
+! Input array projections (handling one detection band at a time)
+ REAL(r_kind), ALLOCATABLE :: Z__DBT(:) ! Original departures
+ REAL(r_kind), ALLOCATABLE :: Z__Smooth_DBT(:) ! Smoothed departures
+ REAL(r_kind), ALLOCATABLE :: Z__LEVEL(:) ! Channel height assignments
+
+!* 0.4 Local variables - digital filter parameters
+ INTEGER(i_kind) :: I__CHAN_HIGH ! Channel at K__Minlev
+ INTEGER(i_kind) :: I__CHAN_LOW ! Channel at K__Maxlev
+ INTEGER(i_kind) :: I__FirstCloudyChannel ! Highest cloud-affected channel
+ INTEGER(i_kind) :: I__LastClearChannel ! Lowest clear channel
+ INTEGER(i_kind),POINTER :: I__Window_Width(:) ! Box-car filter width
+ INTEGER(i_kind),POINTER :: I__GradChkInterval(:) ! Gradient-check interval
+
+!======================================================================
+
+
+! Get correct processing parameters for this sensor:
+ I__Num_Bands = S__CADS_Setup_Cloud(K__Sensor) % N__Num_Bands
+ I__Band_Size => S__CADS_Setup_Cloud(K__Sensor) % N__Band_Size
+ I__Bands => S__CADS_Setup_Cloud(K__Sensor) % N__Bands
+ I__Window_Width => S__CADS_Setup_Cloud(K__Sensor) % N__Window_Width
+ I__BandToUse => S__CADS_Setup_Cloud(K__Sensor) % N__BandToUse
+ LL__Do_CrossBand = S__CADS_Setup_Cloud(K__Sensor) % L__Do_CrossBand
+ I__GradChkInterval => S__CADS_Setup_Cloud(K__Sensor) % N__GradChkInterval
+
+
+! Initialise
+ K__Cloud_Flag(:)=1 ! intialise ALL channels to cloudy
+
+
+! Imager-based cloud detection
+ I__Imager_Flag=0 ! Default assumption: no cloud affecting collocated imager data
+ CALL CADS_Detect_Cloud_Imager( K__Sensor, K__Num_Imager_Chans, K__Chan_ID_Imager, K__Num_Imager_Clusters, &
+ I__Imager_Flag, P__Cluster_Fraction, P__BT_in_Cluster, P__BT_Overall_SDev, P__BT_Model_Imager )
+
+! If using cross-band, set up an array indicating which channels correspond
+! to which bands in K__ChanID
+ IF (LL__Do_CrossBand) THEN
+ I__BandNumber(:)=-1 ! Initialise
+ DO JBAND = 1, I__Num_Bands
+ DO I_K=1,K__NChans
+ IF (ANY(I__BANDS(:,JBAND) == K__ChanID(I_K))) &
+ I__BandNumber(I_K)=JBand
+ ENDDO
+ ENDDO
+ ENDIF
+
+
+!1 Loop over bands
+ Band_Loop: DO JBAND = 1, I__Num_Bands
+
+ ! Don't bother doing the cloud detection if we're just going to use
+ ! the results from another band anyway:
+ IF (LL__Do_CrossBand) THEN
+ IF (.NOT.(ANY(I__BandToUse(:) == JBAND))) CYCLE
+ ENDIF
+
+ ALLOCATE (Z__DBT(I__Band_Size(JBAND)))
+ Z__DBT(:) = 0.0_r_kind
+
+ ALLOCATE (Z__LEVEL(I__Band_Size(JBAND)))
+ Z__LEVEL(:) = REAL(K__Maxlev)
+
+ ALLOCATE (I__Cloud_Flag(I__Band_Size(JBAND)))
+ ALLOCATE (I__INDEX(I__Band_Size(JBAND)))
+
+ ALLOCATE (IDCHAN(I__Band_Size(JBAND)))
+ IDCHAN(:) = 1
+
+
+ I__WindowBounds(:) = &
+ S__CADS_Setup_Cloud(K__Sensor) % N__Window_Bounds(JBand,:)
+
+!1.1 find channels within current band --------------------------------------
+ I__NumFoundChans = 0
+ I__Window_Chans(:) = -1
+
+ DO J=1,I__Band_Size(JBAND)
+ DO I_K=1,K__NChans
+ IF (K__ChanID(I_K) == I__BANDS(J,JBAND)) THEN
+! IF (P__ObsBTs(I_K) < 0. .OR. P__ModelBTs(I_K) < 0.) CYCLE
+ IF (P__ObsBTs(I_K) < 60.0_r_kind .OR. P__ModelBTs(I_K) < 60.0_r_kind) CYCLE ! Missing channels are set to 50.0K
+ I__NumFoundChans = I__NumFoundChans + 1
+ Z__DBT(I__NumFoundChans)=P__ObsBTs(I_K)-P__ModelBTs(I_K)
+ Z__LEVEL(I__NumFoundChans)=P__Chan_Level(I_K)
+ I__INDEX(I__NumFoundChans)=I__NumFoundChans
+ IDCHAN(I__NumFoundChans)=I_K
+ IF (K__ChanID(I_K) == I__WindowBounds(1)) &
+ I__Window_Chans(1) = I__NumFoundChans
+ IF (K__ChanID(I_K) == I__WindowBounds(2)) &
+ I__Window_Chans(2) = I__NumFoundChans
+ ENDIF
+ ENDDO
+ ENDDO
+ IF ( I__NumFoundChans == 0 ) THEN
+ if (verbose) WRITE(*,*) &
+ '**CADS_Detect_Cloud - WARNING: ' // &
+ 'CHANNELS NOT FOUND CYCLING BAND: **', JBAND
+ IF (ALLOCATED(Z__DBT)) DEALLOCATE (Z__DBT)
+ IF (ALLOCATED(Z__LEVEL)) DEALLOCATE (Z__LEVEL)
+ IF (ALLOCATED(I__Cloud_Flag)) DEALLOCATE (I__Cloud_Flag)
+ IF (ALLOCATED(I__INDEX)) DEALLOCATE (I__INDEX)
+ IF (ALLOCATED(IDCHAN)) DEALLOCATE (IDCHAN)
+ CYCLE Band_Loop
+ ENDIF
+
+!----------------------------------------------------------------------------
+ IST=0
+ ICOUNT=I__NumFoundChans
+ I__Cloud_Flag(:)=1
+
+!2. Sort according to channel height assignments
+ CALL CADS_Detect_Cloud_Heapsort(I__NumFoundChans,Z__Level,I__Index)
+
+!2.1 Find I__CHAN_LOW - lowest channel considered in the initial cloud search
+ J=1
+ DO WHILE (J < I__NumFoundChans .AND. Z__Level(I__Index(J)) < REAL(K__Maxlev))
+ J=J+1
+ ENDDO
+
+ IF (J == I__NumFoundChans) THEN
+ I__CHAN_LOW = I__NumFoundChans-1
+ ELSE
+ I__CHAN_LOW = J
+ ENDIF
+ IF(I__CHAN_LOW <= 1)I__CHAN_LOW=1
+
+!2.1a Find I__CHAN_HIGH - highest allowed channel for starting the cloud search
+ J=1
+ DO WHILE (J < I__NumFoundChans .AND. Z__Level(I__Index(J)) < REAL(K__Minlev))
+ J=J+1
+ ENDDO
+ I__CHAN_HIGH=J
+
+
+! Smoothing
+ ALLOCATE (Z__Smooth_DBT(I__NumFoundChans))
+ Z__Smooth_DBT(:) = 0.0_r_kind
+
+ CALL CADS_Detect_Cloud_Smooth( I__NumFoundChans, I__Window_Width(JBAND), Z__DBT(I__INDEX(1:I__NumFoundChans)), &
+ Z__Smooth_DBT(1:I__NumFoundChans) )
+
+
+!3. Choice of cloud detection scenario
+
+ CALL CADS_Detect_Cloud_Scenario( K__Sensor, JBAND, I__NumFoundChans, I__GradChkInterval(JBAND), I__Index(1:I__NumFoundChans), &
+ I__CHAN_HIGH, I__CHAN_LOW, I__Window_Chans, I__Imager_Flag, I__Scenario_Index, I__Start_Channel, Z__Smooth_DBT(1:I__NumFoundChans))
+
+
+!4. Identify the separation between clear/cloudy channels
+
+ CALL CADS_Detect_Cloud_Separator( K__Sensor, JBAND, I__NumFoundChans, I__GradChkInterval(JBAND), I__Index(1:I__NumFoundChans), &
+ I__Cloud_Flag, I__FirstCloudyChannel, I__LastClearChannel, I__Scenario_Index, I__Start_Channel, Z__Smooth_DBT(1:I__NumFoundChans))
+
+ K__Cloud_Flag(IDCHAN(1:I__NumFoundChans)) = &
+ I__Cloud_Flag(1:I__NumFoundChans)
+
+ ! Set cloud level for cross-band:
+ IF (I__FirstCloudyChannel == 0) THEN ! FOV is completely clear
+ Z__Cloud_Level = 1.e20_r_kind ! Large value
+ ELSE
+ Z__Cloud_Level = P__Chan_Level(IDCHAN(I__LastClearChannel))
+ ENDIF
+
+ ! Automatically do cross band cloud detection for all
+ ! interferometer channels (whether assigned a band or not) if
+ ! JBand == 1. This can be over-ridden for the other bands.
+
+ IF (K__Sensor /= INST_ID_AIRS .AND. JBand == 1) &
+ WHERE(P__Chan_Level(:) < Z__Cloud_Level) K__Cloud_Flag(:) = 0
+
+ CrossBand : IF (LL__Do_CrossBand) THEN
+ ! Cross Band:
+ ! Loop through bands applying cloud detection to those that take their
+ ! cloud detection information from the current band JBAND.
+ DO JBand2 = 1, I__Num_Bands
+ IF (I__BandToUse(JBand2) == JBand) THEN
+ WHERE(P__Chan_Level(:) < Z__Cloud_Level .AND. &
+ I__BandNumber == JBand2 .AND. &
+ P__OBSBTs(:)>0.0_r_kind ) K__Cloud_Flag(:) = 0
+ ENDIF
+ ENDDO
+ ENDIF CrossBand
+
+! Deallocate arrays
+ IF (ALLOCATED(Z__DBT)) DEALLOCATE (Z__DBT)
+ IF (ALLOCATED(Z__Smooth_DBT)) DEALLOCATE (Z__Smooth_DBT)
+ IF (ALLOCATED(Z__LEVEL)) DEALLOCATE (Z__LEVEL)
+ IF (ALLOCATED(I__Cloud_Flag)) DEALLOCATE (I__Cloud_Flag)
+ IF (ALLOCATED(I__INDEX)) DEALLOCATE (I__INDEX)
+ IF (ALLOCATED(IDCHAN)) DEALLOCATE (IDCHAN)
+
+ ENDDO Band_Loop
+
+! Nullify pointers
+ NULLIFY(I__Band_Size, I__Bands, I__Window_Width, I__BandToUse)
+
+END SUBROUTINE CADS_Detect_Cloud
+
+SUBROUTINE CADS_Detect_Cloud_Imager( K__Sensor, K__Nchans, K__Chanid, K__Nclust, K__Cloud_Flag, P__Cl_Fraction, &
+ P__Cl_Mean, P__Ov_Stddev, P__FG_BT )
+
+! This software was developed within the context of the EUMETSAT
+! Satellite Application Facility on Numerical Weather Prediction
+! (NWP SAF), under the Cooperation Agreement dated 7 December 2016,
+! between EUMETSAT and the Met Office, UK, by one or more partners
+! within the NWP SAF. The partners in the NWP SAF are the Met
+! Office, ECMWF, DWD and MeteoFrance.
+!
+! Copyright 2020, EUMETSAT, All Rights Reserved.
+
+! *CADS_Detect_Cloud_Imager*
+! R.Eresmaa ECMWF 12/02/13
+
+! * PURPOSE *
+! -----------
+! Provide additional information for the cloud detection by making use
+! of collocated imager data, such as AVHRR collocated with IASI.
+
+! * INTERFACE *
+! -------------
+! *CALL* * CADS_Detect_Cloud_Imager( )* (from CADS_Detect_Cloud)
+! WHERE K__Sensor : Satellite sensor id
+! K__Nchans : Number of channels received as input
+! K__Chanid : Provided channel IDs
+! K__Nclust : Highest possible number of clusters
+! K__Cloud_Flag : Output cloud flag (0-7, 0=clear)
+! P__Cl_Fraction : Fractional coverage of each cluster within FOV
+! P__Cl_Mean : Cluster-mean brightness temperature (BT) on each
+! channel
+! P__Ov_Stddev : Overall BT standard deviation on each channel
+! P__FG_BT : Forward-modelled BT on each channel
+
+! * METHOD *
+! ----------
+! A preliminary indicator of presence of clouds in the sounder
+! field-of-view (FOV) is derived using statistical radiance information
+! within collocated clusters of imager pixels.
+
+! * MODIFICATIONS *
+! -----------------
+! 03/12/13 R.Eresmaa 2.0 Original export version.
+! 19/01/15 R.Eresmaa 2.1 Make array size specifications implicit.
+! Verify that channels intended to be used
+! are received as input.
+! 05/02/19 R.Eresmaa 2.4 Explicit kind specifications.
+! 16/04/20 R.Eresmaa 3.0 Rename and tidy up.
+
+ use kinds, only: i_kind, r_kind
+ IMPLICIT NONE
+
+!* Global arrays
+ INTEGER(i_kind), INTENT(IN) :: K__Sensor ! Sensor id
+ INTEGER(i_kind), INTENT(IN) :: K__Nchans ! No. of channels
+ INTEGER(i_kind), INTENT(IN) :: K__Chanid(:) ! Channel IDs
+ INTEGER(i_kind), INTENT(IN) :: K__Nclust ! No. of clusters
+ INTEGER(i_kind), INTENT(OUT) :: K__Cloud_Flag ! Output cloud flag
+ REAL(r_kind), INTENT(IN) :: P__Cl_Fraction(:) ! Cluster fractions
+ REAL(r_kind), INTENT(IN) :: P__Cl_Mean(:,:) ! Cluster-mean BTs
+ REAL(r_kind), INTENT(IN) :: P__Ov_Stddev(:) ! Overall BT st.devs.
+ REAL(r_kind), INTENT(IN) :: P__FG_BT(:) ! First guess BT
+
+!* Local variables - Setup of the imager cloud detection
+ INTEGER(i_kind) :: I__Num_Imager_Chans ! No. of used channels
+ INTEGER(i_kind), POINTER :: I__Imager_Chans(:) ! List of used channels
+ REAL(r_kind), POINTER :: Z__Stddev_Threshold(:) ! Homogeneity thresholds
+ REAL(r_kind) :: Z__Coverage_Threshold ! Coverage threshold
+ REAL(r_kind) :: Z__FG_Departure_Threshold ! FG departure threshold
+
+!* Additional local variables
+ INTEGER(i_kind) :: I, J, IK, I_Temp_Flag, ICOUNT
+ INTEGER(i_kind) :: I__Chan_Index(K__Nchans)
+ REAL(r_kind) :: Z__Wsqdev, Z__Intercluster
+ REAL(r_kind),dimension(K__Nclust) :: Z__Sqdev
+
+
+
+!* 1.0 Initialize cloud flags as clear
+
+ K__Cloud_Flag=0
+
+ IF (S__CADS_Setup_Cloud(K__Sensor) % L__Do_Imager_Cloud_Detection) THEN
+
+
+!* 1.1 Setup
+
+ I__Num_Imager_Chans = &
+ S__CADS_Setup_Cloud(K__Sensor) % N__Num_Imager_Chans
+ I__Imager_Chans => &
+ S__CADS_Setup_Cloud(K__Sensor) % N__Imager_Chans
+ Z__Stddev_Threshold => &
+ S__CADS_Setup_Cloud(K__Sensor) % R__Stddev_Threshold
+ Z__Coverage_Threshold = &
+ S__CADS_Setup_Cloud(K__Sensor) % R__Coverage_Threshold
+ Z__FG_Departure_Threshold = &
+ S__CADS_Setup_Cloud(K__Sensor) % R__FG_Departure_Threshold
+
+
+
+!* 1.2 Channel indexing
+ I__Chan_Index(:) = 0
+ ICOUNT=0
+ DO I=1,K__Nchans
+ IK=0
+ DO J=1,I__Num_Imager_Chans
+ IF (K__Chanid(I)==I__Imager_Chans(J)) THEN
+ ICOUNT=ICOUNT+1
+ IK=ICOUNT
+ EXIT
+ ENDIF
+ ENDDO
+ I__Chan_Index(I)=IK
+ ENDDO
+
+
+!* 2.0 Compute squared first guess departures for each cluster
+
+ DO J=1,K__Nclust
+ Z__Sqdev(J) = 0.0_r_kind
+ DO I=1,K__Nchans
+ IF (I__Chan_Index(I)==0) CYCLE
+ Z__Sqdev(J) = Z__Sqdev(J) + (P__Cl_Mean(I,J)-P__FG_BT(I))**2
+ ENDDO
+ ENDDO
+
+!* 2.1 Homogeneity check: Do not diagnose presence of cloud if BT
+! standard deviation falls below given threshold on at least one
+! channel.
+
+ I_Temp_Flag=1
+ DO I=1,K__Nchans
+ IF (I__Chan_Index(I)==0) CYCLE
+ IF (P__Ov_Stddev(I)Z__Sqdev(J) .OR. Z__Intercluster>Z__Sqdev(IK)) THEN
+ K__Cloud_Flag=K__Cloud_Flag+2
+ Exit Consistency_Check
+ ENDIF
+ ENDDO
+ ENDDO Consistency_Check
+
+
+!* 2.3 First guess departure check: Do not diagnose presence of cloud
+! if fraction-weighted first guess departure falls below given
+! threshold.
+
+ Z__Wsqdev = SUM(P__Cl_Fraction(:)*Z__Sqdev(:))
+ IF (Z__Wsqdev>=Z__FG_Departure_Threshold) K__Cloud_Flag=K__Cloud_Flag+1
+
+ ENDIF ! L__Do_Imager_Cloud_Detection
+
+END SUBROUTINE CADS_Detect_Cloud_Imager
+
+
+SUBROUTINE CADS_Detect_Cloud_Heapsort(N, A, K_Index)
+
+! This software was developed within the context of the EUMETSAT
+! Satellite Application Facility on Numerical Weather Prediction
+! (NWP SAF), under the Cooperation Agreement dated 7 December 2016,
+! between EUMETSAT and the Met Office, UK, by one or more partners
+! within the NWP SAF. The partners in the NWP SAF are the Met
+! Office, ECMWF, DWD and MeteoFrance.
+!
+! Copyright 2020, EUMETSAT, All Rights Reserved.
+
+! * CADS_Detect_Cloud_Heapsort *
+! A.Collard ECMWF 01/02/06
+
+! * PURPOSE *
+! -----------
+! Basic heapsort algorithm.
+
+! * INTERFACE *
+! -------------
+! *CALL* * CADS_Detect_Cloud_Heapsort( )* (from CADS_Detect_Cloud)
+! WHERE N : Length of input array
+! A : Real input array
+! K_Index : Output ranked array
+
+! * MODIFICATIONS *
+! -----------------
+! 16/05/06 A.Collard 1.0 Original version.
+! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications
+! 16/04/20 R.Eresmaa 3.0 Rename as part of the big clean for CADS V3
+
+
+ use kinds, only: i_kind, r_kind
+ IMPLICIT NONE
+
+! Subroutine arguments
+ INTEGER(i_kind), INTENT(IN) :: N
+ REAL(r_kind), INTENT(IN) :: A(:)
+ INTEGER(i_kind), INTENT(INOUT) :: K_Index(:)
+
+ INTEGER(i_kind) :: I,J,RIGHT,LEFT,IDX
+ REAL(r_kind) :: TMP
+
+!------------------------------------------
+
+ IF (N <= 1) RETURN
+ LEFT = N/2+1
+ RIGHT = N
+
+ DO
+ IF (LEFT > 1) THEN
+ LEFT = LEFT - 1
+ IDX = K_Index(LEFT)
+ ELSE
+ IDX = K_Index(RIGHT)
+ K_Index(RIGHT) = K_Index(1)
+ RIGHT = RIGHT - 1
+ IF (RIGHT == 1) THEN
+ K_Index(1) = IDX
+ EXIT
+ ENDIF
+ ENDIF
+ TMP = A(IDX)
+ I = LEFT
+ J = 2*LEFT
+ DO WHILE (J <= RIGHT)
+ IF (J < RIGHT) THEN
+ IF (A(K_Index(J)) < A(K_Index(J+1))) J = J + 1
+ ENDIF
+ IF (TMP < A(K_Index(J))) THEN
+ K_Index(I) = K_Index(J)
+ I = J
+ J = 2*J
+ ELSE
+ J = RIGHT + 1
+ ENDIF
+ ENDDO
+ K_Index(I) = IDX
+ ENDDO
+
+END SUBROUTINE CADS_Detect_Cloud_Heapsort
+
+SUBROUTINE CADS_Detect_Cloud_Smooth(KV,KW,PV,PVA)
+
+! This software was developed within the context of the EUMETSAT
+! Satellite Application Facility on Numerical Weather Prediction
+! (NWP SAF), under the Cooperation Agreement dated 7 December 2016,
+! between EUMETSAT and the Met Office, UK, by one or more partners
+! within the NWP SAF. The partners in the NWP SAF are the Met
+! Office, ECMWF, DWD and MeteoFrance.
+!
+! Copyright 2020, EUMETSAT, All Rights Reserved.
+
+! * CADS_Detect_Cloud_Smooth * - Boxcar-averaging in a REAL array
+! * Phil Watts ECMWF 24/01/02
+
+! * PURPOSE *
+! -----------
+! Calculate the moving average (smoothing filter) of array
+! No error checking supplied.
+
+! * INTERFACE *
+! -------------
+! *CALL* * CADS_Detect_Cloud_Smooth( )* (from CADS_Detect_Cloud)
+! WHERE KV : Number of elements in V
+! KW : Window width for filter
+! PV : Input array to be averaged
+! PVA : Averaged array
+
+! * MODIFICATIONS *
+! -----------------
+! 01/02/06 A.Collard 1.0 Original export version.
+! 13/01/15 R.Eresmaa 2.1 Make array size specifications implicit.
+! 05/02/19 R.Eresmaa 2.4 Explicit KIND specifications.
+! 16/04/20 R.Eresmaa 3.0 Rename and tidy up.
+
+ use kinds, only: i_kind, r_kind
+ IMPLICIT NONE
+
+!* 0.1 global variables
+ INTEGER(i_kind), INTENT(IN) :: KV ! length of V
+ INTEGER(i_kind), INTENT(IN) :: KW ! length of averaging window
+ REAL(r_kind), INTENT(IN) :: PV(:) ! original array
+ REAL(r_kind), INTENT(INOUT) :: PVA(:) ! averaged array
+
+!* 0.2 local variables
+ INTEGER(i_kind) :: INJ,J,I
+
+ PVA(:)=0.0_r_kind
+
+ DO I = 1,KV ! loop over array elements
+ INJ=0
+ DO J=I-KW/2,I+KW/2,1 ! loop over window
+ IF (J > 0 .AND. J < (KV+1)) THEN ! if window element exists in
+ ! original array
+ INJ=INJ+1
+ PVA(I)=PVA(I)+PV(J) ! add value
+ ENDIF
+ ENDDO
+ PVA(I)=PVA(I)/REAL(INJ) ! mean value
+ ENDDO
+
+END SUBROUTINE CADS_Detect_Cloud_Smooth
+
+SUBROUTINE CADS_Detect_Cloud_Scenario( K__Sensor, K__Band, K__NumChans, K__GradChkInterval, K__Index, K__Chan_High, &
+ K__Chan_Low, K__Chan_Windows, K__Imager_Flag, K__Scen_Index, K__Start_Channel, P__DBT)
+
+! This software was developed within the context of the EUMETSAT
+! Satellite Application Facility on Numerical Weather Prediction
+! (NWP SAF), under the Cooperation Agreement dated 7 December 2016,
+! between EUMETSAT and the Met Office, UK, by one or more partners
+! within the NWP SAF. The partners in the NWP SAF are the Met
+! Office, ECMWF, DWD and MeteoFrance.
+!
+! Copyright 2020, EUMETSAT, All Rights Reserved.
+
+! * CADS_Detect_Cloud_Scenario *
+! PHIL WATTS ECMWF 21/01/02
+
+! * PURPOSE *
+! -----------
+! Determine which of the three possible scenarios best describes
+! the input data.
+! Quick Exit - no cloud in the FOV
+! Warm Start - warm cloud above relatively colder surface
+! Cold Start - cold cloud above relatively warmer surface (most common)
+
+! * INTERFACE *
+! -------------
+! * CALL* * CADS_Detect_Cloud_Scenario( )* (from CADS_Detect_Cloud)
+! WHERE K__Sensor : Satellite sensor (AIRS/IASI/CrIS)
+! K__Band : Band number
+! K__NumChans : Number of channels in this band
+! K__GradChkInterval : Gradient-checking interval
+! K__Index : Ranking index for the input dBT signal
+! K__Chan_High : High channel considered in initial minimum search
+! K__Chan_Low : Low channel considered in initial minimum search
+! K__Chan_Windows : Two channels defining longwave window
+! K__Imager_Flag : Input flag from collocated imager data
+! K__Scen_Index : Choice of cloud detection scenario (1, 2, or 3)
+! K__Start_Channel : Channel index for the start of final search
+! P__DBT : Input dBT signal
+
+! * MODIFICATIONS *
+! -----------------
+! 03/02/06 A.Collard 1.0 Tidy up in preparation for IASI
+! 03/05/06 A.Collard 1.0.1 Band size is now passed in (allows for
+! missing channels).
+! 04/05/06 A.Collard 1.0.2 The index of the first cloudy channel is now
+! returned to allow cross-band cloud detection
+! 16/02/07 A.Collard 1.0.3 Change to the padding to allow the bottom
+! channel to be flagged as clear in a
+! non-quickstart situation.
+! 16/01/09 A.Collard 1.1 Gradient check on quick exit
+! Start channel for cold start moved to highest
+! channel where BT threshold exceeded
+! 11/11/11 R.Eresmaa 1,2 Index of the lowest clear channel added to
+! the output parameters.
+! Change of the starting channel is no longer
+! allowed in cases where gradient > -threshold.
+! 04/12/13 R.Eresmaa 2.0 Allow quick exit only if collocated imager
+! data supports hypothesis of a clear FOV
+! 13/01/15 R.Eresmaa 2.1 Remove the need to create temporary array in
+! the call to MOVINGA.
+! the call to MOVINGA.
+! 04/02/19 R.Eresmaa 2.4 Explicit KIND specifications.
+! 16/04/20 R.Eresmaa 3.0 Divide the previous CF_Digital in two:
+! Cloud_Scenario (here) and Cloud_Separator.
+
+
+ use kinds, only: i_kind, r_kind
+ IMPLICIT NONE
+
+!* 0.1 Global arrays
+ INTEGER(i_kind), INTENT(IN) :: K__SENSOR ! Sensor
+ INTEGER(i_kind), INTENT(IN) :: K__Band ! Band number
+ INTEGER(i_kind), INTENT(IN) :: K__NumChans ! Number of usable channels in band
+ INTEGER(i_kind), INTENT(IN) :: K__GradChkInterval ! Gradient-check interval
+ INTEGER(i_kind), INTENT(IN) :: K__INDEX(:) ! Ranking index for dBT
+ INTEGER(i_kind), INTENT(IN) :: K__Chan_High ! First channel clear of high stratospheric model errors
+ INTEGER(i_kind), INTENT(IN) :: K__Chan_Low ! Last channel clear of PBL humidity errors
+ INTEGER(i_kind), INTENT(IN) :: K__Chan_Windows(2) ! Two channels defining long-wave window bounds
+ INTEGER(i_kind), INTENT(IN) :: K__Imager_Flag ! Input imager cloud flag
+ INTEGER(i_kind), INTENT(OUT) :: K__Scen_Index ! Choice of scenario
+ INTEGER(i_kind), INTENT(OUT) :: K__Start_Channel ! Final starting channel
+ REAL(r_kind), INTENT(IN) :: P__DBT(:) ! Input ranked-smoothed dBT signal
+
+! Local variables
+ REAL(r_kind), ALLOCATABLE :: Z__DBT_w_Buffer(:) ! Smoothed-ranked DBT
+ INTEGER(i_kind) :: I__Buffer ! No. of buffer channels
+ INTEGER(i_kind) :: I__Start_Channel ! Primary starting channel for cloud search
+ INTEGER(i_kind) :: I__Start_Channel_Surf ! Secondary starting channel for cloud search
+ INTEGER(i_kind) :: I__Max_Channel ! Channel corresponding to maximum of the smoothed dBT
+ INTEGER(i_kind) :: JCH,JMIN(1),JMAX(1),I
+
+ LOGICAL :: LLCOLD, LL__WINDOW_GRAD_CHECK, LL__StartChannelChanged
+ LOGICAL :: LL__Search_for_Cloud_Top
+
+! These carry the values in S__CADS_Setup_Cloud
+ REAL(r_kind) :: Z__BT_Threshold ! Solution contaminated threshold
+ REAL(r_kind) :: Z__Grad_Threshold ! Gradient threshold at which to stop filter procession
+ REAL(r_kind) :: Z__Window_Grad_Threshold ! Gradient threshold for window check
+
+
+!=============================================================================
+
+
+ Z__BT_Threshold = &
+ S__CADS_Setup_Cloud(K__SENSOR) % R__BT_Threshold(K__Band)
+ Z__Grad_Threshold = &
+ S__CADS_Setup_Cloud(K__SENSOR) % R__Grad_Threshold(K__Band)
+ Z__Window_Grad_Threshold = &
+ S__CADS_Setup_Cloud(K__SENSOR) % R__Window_Grad_Threshold(K__Band)
+
+
+!1. Include buffer channels at the start and end of the input smoothed
+! departure array
+
+ I__BUFFER = K__GradChkInterval
+ ALLOCATE(Z__DBT_w_Buffer(-I__Buffer+1:K__NumChans+1))
+
+ Z__DBT_w_Buffer(1:K__NumChans) = P__DBT(:)
+ Z__DBT_w_Buffer(-I__BUFFER+1:0) = Z__DBT_w_Buffer(1)
+ Z__DBT_w_Buffer(K__NumChans+1) = Z__DBT_w_Buffer(K__NumChans)
+
+
+!2. Prepare for the cloud search
+
+! First define a set of key channels
+
+ JMIN=MINLOC(Z__DBT_w_Buffer(K__Chan_High:K__NumChans))
+ I__Start_Channel_Surf = K__Chan_High+JMIN(1)-1
+
+ JMIN=MINLOC(Z__DBT_w_Buffer(K__Chan_High:K__Chan_Low))
+ I__Start_Channel = K__Chan_High+JMIN(1)-1
+
+! Look for highest channel with DBT<-BT_Threshold and move I__Start_Channel
+! there if higher than current I__Start_Channel:
+ JCH = I__Start_Channel
+ StartChanLoop : DO I=K__Chan_High,K__NumChans
+ IF (Z__DBT_w_Buffer(I) < -Z__BT_Threshold .OR. I == I__Start_Channel) THEN
+ JCH = I
+ Exit StartChanLoop
+ ENDIF
+ ENDDO StartChanLoop
+ I__Start_Channel = JCH
+
+! Do the same with I__Start_Channel_Surf
+ JCH = I__Start_Channel_Surf
+ StartChanLoop_Surf : DO I=K__Chan_High,K__NumChans
+ IF (Z__DBT_w_Buffer(I) < -Z__BT_Threshold .OR. I == I__Start_Channel_Surf) THEN
+ JCH = I
+ Exit StartChanLoop_Surf
+ ENDIF
+ ENDDO StartChanLoop_Surf
+ I__Start_Channel_Surf = JCH
+
+! Find the position of the equivalent maximum departure (for quick exit test)
+ JMAX=MAXLOC(Z__DBT_w_Buffer(K__Chan_High:K__NumChans))
+ I__Max_Channel = K__Chan_High+JMAX(1)-1
+
+! Long-wave window gradient check
+ LL__WINDOW_GRAD_CHECK=.TRUE.
+ IF (ALL(K__Chan_Windows > 0)) LL__WINDOW_GRAD_CHECK = &
+ (ABS(Z__DBT_w_Buffer(K__INDEX(K__Chan_Windows(1))) - &
+ Z__DBT_w_Buffer(K__INDEX(K__Chan_Windows(2)))) &
+ < Z__Window_Grad_Threshold)
+
+! Choose scenario to be followed
+ LL__Search_for_Cloud_Top=.TRUE.
+ IF (ABS(Z__DBT_w_Buffer(I__Start_Channel_Surf)) < Z__BT_Threshold .AND. &
+ ABS(Z__DBT_w_Buffer(I__Start_Channel)) < Z__BT_Threshold .AND. &
+ ABS(Z__DBT_w_Buffer(I__Max_Channel)) < Z__BT_Threshold .AND. &
+ ABS(Z__DBT_w_Buffer(K__NumChans)) < Z__BT_Threshold .AND. &
+ LL__WINDOW_GRAD_CHECK .AND. &
+ K__Imager_Flag==0 .AND. &
+ S__CADS_Setup_Cloud(K__SENSOR) % L__Do_Quick_Exit) THEN
+ !Quick exit
+ LL__Search_for_Cloud_Top=.FALSE.
+ ELSEIF (ABS(Z__DBT_w_Buffer(I__Start_Channel)) < Z__BT_Threshold .AND. &
+ Z__DBT_w_Buffer(K__NumChans) > Z__BT_Threshold ) THEN
+ !Warm cloud start at next-to-bottom channel (allowing one channel for
+ !gradient calculations).
+ LLCOLD = .FALSE.
+ I__Start_Channel = K__NumChans-1
+ ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) < -Z__BT_Threshold ) THEN
+ LLCOLD = .TRUE.
+ ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) > Z__BT_Threshold ) THEN
+ LLCOLD = .FALSE.
+ ELSE
+ LLCOLD = .TRUE.
+ ENDIF
+
+ IF (LL__Search_for_Cloud_Top) THEN ! Either cold or warm start
+ ! (but not quick exit)
+
+ JCH=I__Start_Channel
+
+! Re-evaluate the choice of scenario:
+! If the primary starting channel appears clear, and the secondary
+! starting channel is lower, start from the latter. In that case
+! re-evaluate whether cold or warm start is more appropriate.
+ IF (I__Start_Channel /= I__Start_Channel_Surf) THEN
+
+ LL__StartChannelChanged = .FALSE.
+ IF (LLCOLD .AND. ( (Z__DBT_w_Buffer(JCH-1)-Z__DBT_w_Buffer(JCH+1)) < &
+ Z__Grad_Threshold .AND. &
+ Z__DBT_w_Buffer(JCH-K__GradChkInterval)-Z__DBT_w_Buffer(JCH+1) < &
+ Z__Grad_Threshold .AND. &
+ ABS(Z__DBT_w_Buffer(JCH)) < Z__BT_Threshold)) THEN
+ I__Start_Channel = I__Start_Channel_Surf
+ LL__StartChannelChanged = .TRUE.
+ ENDIF
+
+ IF (LL__StartChannelChanged) THEN
+
+ IF (ABS(Z__DBT_w_Buffer(I__Start_Channel)) < Z__BT_Threshold .AND. &
+ Z__DBT_w_Buffer(K__NumChans) > Z__BT_Threshold ) THEN
+ !Warm cloud start at next-to-bottom channel (allowing one channel for
+ !gradient calculations).
+ LLCOLD = .FALSE.
+ I__Start_Channel = K__NumChans-1
+ ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) < -Z__BT_Threshold ) THEN
+ LLCOLD = .TRUE.
+ ELSEIF (Z__DBT_w_Buffer(I__Start_Channel) > Z__BT_Threshold ) THEN
+ LLCOLD = .FALSE.
+ ELSE
+ LLCOLD = .TRUE.
+ ENDIF
+ JCH = I__Start_Channel
+
+ ENDIF
+ ENDIF
+
+ IF (LLCOLD) THEN
+ K__Scen_Index=3
+ ELSE
+ K__Scen_Index=2
+ ENDIF
+ K__Start_Channel = JCH
+
+ ELSE
+
+ K__Scen_Index=1
+ K__Start_Channel=0
+
+ ENDIF ! Search for cloud top
+
+ IF (ALLOCATED(Z__DBT_w_Buffer)) DEALLOCATE(Z__DBT_w_Buffer)
+
+END SUBROUTINE CADS_Detect_Cloud_Scenario
+
+SUBROUTINE CADS_Detect_Cloud_Separator( K__Sensor, K__Band, K__NumChans, K__GradChkInterval, K__Index, K__Cloud_Flag, &
+ K__Cloud_Level, K__Clear_Level, K__Scen_Index, K__Start_Channel, P__DBT)
+
+! This software was developed within the context of the EUMETSAT
+! Satellite Application Facility on Numerical Weather Prediction
+! (NWP SAF), under the Cooperation Agreement dated 7 December 2016,
+! between EUMETSAT and the Met Office, UK, by one or more partners
+! within the NWP SAF. The partners in the NWP SAF are the Met
+! Office, ECMWF, DWD and MeteoFrance.
+!
+! Copyright 2020, EUMETSAT, All Rights Reserved.
+
+! * CADS_Detect_Cloud_Separator *
+! PHIL WATTS ECMWF 21/01/02
+
+! * PURPOSE *
+! -----------
+! Along the vertically-ranked and smoothed array of departures, find
+! the separating point at which all cloud-affected channels are on
+! one side and all clear channels are on the other side.
+
+! * INTERFACE *
+! ------------
+! * CALL* * CADS_Detect_Cloud_Separator( )* (from CADS_Detect_Cloud)
+! WHERE K__Sensor : Satellite sensor (AIRS/IASI/CrIS)
+! K__Band : Band number
+! K__NumChans : Number of channels in this band
+! K__GradChkInterval : Gradient-checking interval
+! K__Index : Ranking index for the input dBT signal
+! K__Cloud_Flag : Cloud flag by channel; 0=clear, 1=cloudy
+! K__Cloud_Level : Index of the highest cloud-contaminated channel
+! K__Clear_Level : Index of the lowest clear channel
+! K__Scen_Index : Choice of cloud detection scenario (1, 2, or 3)
+! K__Start_Channel : Starting channel for the cloud search
+! P__DBT : Input dBT signal
+
+! MODIFICATIONS
+! 03/02/06 A.Collard 1.0 Tidy up in preparation for IASI
+! 03/05/06 A.Collard 1.0.1 Band size is now passed in (allows for
+! missing channels).
+! 04/05/06 A.Collard 1.0.2 The index of the first cloudy channel is now
+! returned to allow cross-band cloud detection
+! 16/02/07 A.Collard 1.0.3 Change to the padding to allow the bottom
+! channel to be flagged as clear in a
+! non-quickstart situation.
+! 16/01/09 A.Collard 1.1 Gradient check on quick exit
+! Start channel for cold start moved to highest
+! channel where BT threshold exceeded
+! 11/11/11 R.Eresmaa 1,2 Index of the lowest clear channel added to
+! the output parameters.
+! Change of the starting channel is no longer
+! allowed in cases where gradient > -threshold.
+! 04/12/13 R.Eresmaa 2.0 Allow quick exit only if collocated imager
+! data supports hypothesis of a clear FOV
+! 13/01/15 R.Eresmaa 2.1 Remove the need to create temporary array in
+! the call to MOVINGA.
+! 04/02/19 R.Eresmaa 2.4 Explicit KIND specifications.
+! 16/04/20 R.Eresmaa 3.0 Divide the previous CF_Digital in two:
+! Cloud_Scenario and Cloud_Separator (here).
+
+ use kinds, only: i_kind, r_kind
+ IMPLICIT NONE
+
+!* 0.1 Global arrays
+ INTEGER(i_kind), INTENT(IN ) :: K__SENSOR ! Sensor
+ INTEGER(i_kind), INTENT(IN ) :: K__Band ! Band number
+ INTEGER(i_kind), INTENT(IN ) :: K__NumChans ! Number of usable channels in band
+ INTEGER(i_kind), INTENT(IN ) :: K__GradChkInterval ! Gradient-check interval
+ INTEGER(i_kind), INTENT(IN ) :: K__INDEX(:) ! Ranking index for dBT
+ INTEGER(i_kind), INTENT(INOUT) :: K__Cloud_Flag(:) ! Cloud flags
+ INTEGER(i_kind), INTENT( OUT) :: K__Cloud_Level ! Index of highest cloudy channel
+ INTEGER(i_kind), INTENT( OUT) :: K__Clear_Level ! Index of lowest clear channel
+ INTEGER(i_kind), INTENT(IN ) :: K__Scen_Index ! Choice of scenario
+ INTEGER(i_kind), INTENT(IN ) :: K__Start_Channel ! Choice of scenario
+ REAL(r_kind), INTENT(IN ) :: P__DBT(:) ! Input ranked dBT signal
+
+
+! Local variables
+ REAL(r_kind), ALLOCATABLE :: Z__DBT_w_Buffer(:) ! Smoothed-ranked DBT
+ INTEGER(i_kind) :: I__Buffer ! No. of buffer channels
+ INTEGER(i_kind) :: JCH
+
+! These carry the values in S__CADS_Setup_Cloud
+ REAL(r_kind) :: Z__BT_Threshold ! Solution contaminated threshold
+ REAL(r_kind) :: Z__Grad_Threshold ! Gradient threshold at which to stop
+ ! filter procession
+
+!=============================================================================
+
+
+ Z__BT_Threshold = &
+ S__CADS_Setup_Cloud(K__SENSOR) % R__BT_Threshold(K__Band)
+ Z__Grad_Threshold = &
+ S__CADS_Setup_Cloud(K__SENSOR) % R__Grad_Threshold(K__Band)
+
+ K__Cloud_Flag(:)=1
+
+!1. Include buffer channels at the start and end of the input smoothed
+! departure array
+
+ I__BUFFER = K__GradChkInterval
+ ALLOCATE(Z__DBT_w_Buffer(-I__Buffer+1:K__NumChans+1))
+
+ Z__DBT_w_Buffer(1:K__NumChans) = P__DBT(:)
+ Z__DBT_w_Buffer(-I__BUFFER+1:0) = Z__DBT_w_Buffer(1)
+ Z__DBT_w_Buffer(K__NumChans+1) = Z__DBT_w_Buffer(K__NumChans)
+
+
+!2. Search for the lowest non-contaminated channel
+
+ JCH = K__Start_Channel
+
+ SELECT CASE (K__Scen_Index)
+
+ CASE (1) ! Quick Exit
+ K__Cloud_Level = 0
+
+ CASE (2) ! Warm Start
+! In the case of Warm Start, progress towards higher channels whilst
+! -ve difference is decreasing
+ DO WHILE ( ((Z__DBT_w_Buffer(JCH-1)-Z__DBT_w_Buffer(JCH+1)) < &
+ -1.0_r_kind * Z__Grad_Threshold .OR. &
+ (Z__DBT_w_Buffer(JCH-K__GradChkInterval)-Z__DBT_w_Buffer(JCH+1)) < &
+ -1.0_r_kind * Z__Grad_Threshold .OR. &
+ ABS(Z__DBT_w_Buffer(JCH)) > Z__BT_Threshold) .AND. JCH > 1 )
+ JCH = JCH-1
+ ENDDO
+ K__Cloud_Level = JCH
+
+ CASE (3) ! Cold Start
+! In the case of Cold Start, progress towards higher channels whilst
+! -ve difference is decreasing
+ DO WHILE (( (Z__DBT_w_Buffer(JCH-1)-Z__DBT_w_Buffer(JCH+1)) > &
+ Z__Grad_Threshold .OR. &
+ (Z__DBT_w_Buffer(JCH-K__GradChkInterval)-Z__DBT_w_Buffer(JCH+1)) > &
+ Z__Grad_Threshold .OR. &
+ ABS(Z__DBT_w_Buffer(JCH)) > Z__BT_Threshold) .AND. JCH > 1 )
+ JCH = JCH-1
+ ENDDO
+ K__Cloud_Level = JCH
+
+ CASE DEFAULT
+ RETURN
+
+ END SELECT
+
+!3. Output channel indices for the highest cloud and lowest clear levels
+ IF (K__Cloud_Level > 1) THEN
+ K__Cloud_Flag(K__INDEX(1:K__Cloud_Level-1))=0
+ K__Clear_Level=K__INDEX(K__Cloud_Level-1)
+ K__Cloud_Level=K__INDEX(K__Cloud_Level)
+ ELSEIF (K__Cloud_Level>0) THEN
+ K__Clear_Level=K__INDEX(K__Cloud_Level)
+ K__Cloud_Level=K__INDEX(K__Cloud_Level)
+ ELSE
+ K__Cloud_Flag(:)=0
+ ENDIF
+
+ IF (ALLOCATED(Z__DBT_w_Buffer)) DEALLOCATE(Z__DBT_w_Buffer)
+
+END SUBROUTINE CADS_Detect_Cloud_Separator
+
+subroutine cads_imager_calc(obstype,isis,nobs,nreal,nchanl,nsig,data_s,init_pass,mype, &
+ imager_cluster_fraction,imager_cluster_bt,imager_chan_stdev, imager_model_bt)
+
+!$$$ subprogram documentation block
+!
+! subprogram: cads_imager_calc compute model equivalent to the imager channels used by CADS
+! prgmmr: Jung
+!
+! abstract: accumulate the data necessary to derive the model equivalent brightness temperatures
+! used by the cloud and aerosol detection software for the imager cloud tests.
+!
+! program history log:
+!
+!
+!
+! subroutines included:
+!
+!
+! input argument list:
+!
+! obstype - type of tb observation
+! isis - sensor/instrument/satellite id
+! nobs - number of observations
+! nreal - number of pieces of info (location, time, etc) per obs
+! nchanl - number of channels per obs
+! nsig - number of model layers
+! data_s - array containing input data information for a specific sensor
+! init_pass - state of "setup" processing
+! mype - mpi task id
+!
+! output argument list:
+
+! imager_cluster_fraction - CADS cluster fraction ( dimension 7)
+! imager_cluster_bt - avreage brightness temperature of a cluster
+! imager_chan stdev - brightness temperature standard deviation of the cluster
+! imager_model_bt - model derived brightness temperature
+!
+!
+!$$$ end documentation block
+
+ use kinds, only: i_kind, r_kind
+ use constants, only: zero
+ use radiance_mod, only: rad_obs_type
+ use radinfo, only: jpch_rad, nusis, crtm_coeffs_path, nsigradjac
+ use crtm_interface, only: init_crtm, call_crtm, destroy_crtm, itime
+ use obsmod, only: dval_use
+ use gsi_nstcouplermod, only: nstinfo
+
+ implicit none
+
+ logical, intent(in) :: init_pass
+ character(len=10), intent(in) :: obstype
+ character(len=20), intent(in) :: isis
+ integer(i_kind), intent(in) :: nobs, nreal, nchanl, nsig
+ integer(i_kind), intent(in) :: mype
+ real(r_kind),dimension(nreal+nchanl,nobs),intent(in) :: data_s
+ real(r_kind),dimension(7,nobs), intent(out) :: imager_cluster_fraction
+ real(r_kind),dimension(2,7,nobs), intent(out) :: imager_cluster_bt
+ real(r_kind),dimension(2,nobs), intent(out) :: imager_chan_stdev, imager_model_bt
+
+! local variables
+ integer(i_kind) :: jc, i, n
+ integer(i_kind) :: itmp1_cads, itmp2_cads, nchanl_cads, maxinfo, dval_info, cads_info, error_status
+ integer(i_kind),allocatable,dimension(:) :: ich_cads
+ logical :: imager_spccoeff, imager_taucoeff
+ real(r_kind) :: dtime, clw_guess, ciw_guess, rain_guess, snow_guess
+ real(r_kind) :: trop5, tzbgr, dtsavg, sfc_speed
+ real(r_kind),dimension(nsig) :: qvp, tvp, qs, prsltmp
+ real(r_kind),dimension(nsig+1) :: prsitmp
+ real(r_kind),allocatable,dimension(:) :: tsim_cads, emissivity_cads, chan_level_cads
+ real(r_kind),allocatable,dimension(:) :: ts_cads, emissivity_k_cads,data_s_cads
+ real(r_kind),allocatable,dimension(:,:) :: ptau5_cads, temp_cads, wmix_cads, jacobian_cads
+ character(len=80) :: spc_filename, tau_filename
+ character(len=20) :: isis_cads
+ character(len=10) :: obstype_cads
+
+ type(rad_obs_type) :: radmod
+
+ cads_info = 23
+ dval_info = 0
+ if (dval_use) dval_info = 2
+
+ itmp1_cads = len(trim(obstype))
+ itmp2_cads = len(trim(isis))
+
+ if ( obstype == 'iasi' ) then
+ isis_cads = 'avhrr3'//isis(itmp1_cads+1:itmp2_cads)
+ obstype_cads = 'avhrr'
+! nchanl_cads = 3 !channels 3 - 5
+ elseif ( obstype == 'cris' .or. obstype == 'cris-fsr' ) then
+! isis_cads = 'viirs-m'//isis(itmp1+1:itmp2) When naming convention becomes standarized with CrIS
+ if ( isis == 'cris-fsr_npp' .or. isis == 'cris_npp' ) then
+ isis_cads = 'viirs-m_npp'
+ elseif ( isis == 'cris-fsr_n20' ) then
+ isis_cads = 'viirs-m_n20'
+ spc_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.SpcCoeff.bin'
+ inquire(file=trim(spc_filename), exist=imager_spccoeff)
+ if ( .not. imager_spccoeff ) isis_cads = 'viirs-m_j1'
+ elseif ( isis == 'cris-fsr_n21' ) then
+ isis_cads = 'viirs-m_n21'
+ spc_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.SpcCoeff.bin'
+ inquire(file=trim(spc_filename), exist=imager_spccoeff)
+ if ( .not. imager_spccoeff ) isis_cads = 'viirs-m_j2'
+ endif
+ obstype_cads = 'viirs-m'
+! nchanl_cads = 5 ! channels 12 - 16
+ endif
+
+ spc_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.SpcCoeff.bin'
+ inquire(file=trim(spc_filename), exist=imager_spccoeff)
+ tau_filename = trim(crtm_coeffs_path)//trim(isis_cads)//'.TauCoeff.bin'
+ inquire(file=trim(tau_filename), exist=imager_taucoeff)
+
+! IF the RTM files exist allocate and setup various arrays for the RTM
+ if ( imager_spccoeff .and. imager_taucoeff) then
+ nchanl_cads = 0
+ do i=1,jpch_rad
+ if (trim(isis_cads) == nusis(i)) then
+ nchanl_cads = nchanl_cads +1
+ endif
+ end do
+
+ allocate( ich_cads(nchanl_cads) )
+ jc = 0
+ do i=1,jpch_rad
+ if (trim(isis_cads) == nusis(i)) then
+ jc = jc +1
+ ich_cads(jc) = i
+ endif
+ end do
+
+ call init_crtm(init_pass,-99,mype,nchanl_cads,nreal,isis_cads,obstype_cads,radmod)
+
+! Initialize variables needed for the infrared cloud and aerosol detection software
+ allocate(data_s_cads(nreal+nchanl_cads),tsim_cads(nchanl_cads),emissivity_cads(nchanl_cads), &
+ chan_level_cads(nchanl_cads),ptau5_cads(nsig,nchanl_cads),ts_cads(nchanl_cads),emissivity_k_cads(nchanl_cads), &
+ temp_cads(nsig,nchanl_cads),wmix_cads(nsig,nchanl_cads), jacobian_cads(nsigradjac,nchanl_cads))
+
+ do n = 1,nobs ! loop to derive imager BTs for CADS
+! Extract analysis relative observation time.
+ dtime = data_s(itime,n)
+ maxinfo = nreal - cads_info - dval_info - nstinfo
+ if ( sum(data_s(maxinfo+1:maxinfo+7,n)) > 0.90_r_kind ) then ! imager cluster information exists for this profile
+ data_s_cads = data_s(1:nreal+nchanl_cads,n)
+ call call_crtm(obstype_cads,dtime,data_s_cads,nchanl_cads,nreal,ich_cads, &
+ tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, &
+ trop5,tzbgr,dtsavg,sfc_speed,tsim_cads,emissivity_cads,chan_level_cads, &
+ ptau5_cads,ts_cads,emissivity_k_cads,temp_cads,wmix_cads,jacobian_cads,error_status)
+
+! Transfer imager data to arrays for qc_irsnd
+ imager_cluster_fraction(1:7,n) = data_s(maxinfo+1:maxinfo+7,n)
+ imager_cluster_bt(1,1:7,n) = data_s(maxinfo+8:maxinfo+14,n)
+ imager_cluster_bt(2,1:7,n) = data_s(maxinfo+15:maxinfo+21,n)
+ imager_chan_stdev(1:2,n) = data_s(maxinfo+22:maxinfo+23,n)
+ imager_model_bt(1:2,n) = tsim_cads(nchanl_cads-1:nchanl_cads)
+ endif ! imager information exists
+ end do ! End loop to derive imager BTs
+
+ call destroy_crtm
+ deallocate(data_s_cads,tsim_cads,emissivity_cads, ich_cads,chan_level_cads,ptau5_cads,&
+ ts_cads,emissivity_k_cads, temp_cads,wmix_cads, jacobian_cads)
+ endif ! RTM files exist
+
+ end subroutine cads_imager_calc
+
+end module cads
diff --git a/src/gsi/calc_fov_crosstrk.f90 b/src/gsi/calc_fov_crosstrk.f90
index 75fffb1087..6cb817b56b 100644
--- a/src/gsi/calc_fov_crosstrk.f90
+++ b/src/gsi/calc_fov_crosstrk.f90
@@ -812,7 +812,7 @@ subroutine instrument_init(instr, satid, expansion, valid)
allocate (eccen(1:maxfov(instr)))
do i = 1, npoly
- psi(i) = two*pi*float(i-1)/float(npoly-1) ! Will connect Npoly points
+ psi(i) = two*pi*real(i-1,r_kind)/real(npoly-1,r_kind) ! Will connect Npoly points
enddo
! Precompute angles and sizes for speed. For accurate representation of fov,
@@ -1287,7 +1287,7 @@ subroutine get_sat_height(satid, height, valid)
height=866._r_kind
case('npp')
height=840._r_kind
- case('n20')
+ case('n20', 'n21', 'n22', 'n23')
height=840._r_kind
case default
write(6,*) 'GET_SAT_HEIGHT: ERROR, unrecognized satellite id: ', trim(satid)
diff --git a/src/gsi/calctends.f90 b/src/gsi/calctends.f90
index 4bd2c64e24..c6c58e9f4c 100644
--- a/src/gsi/calctends.f90
+++ b/src/gsi/calctends.f90
@@ -62,6 +62,7 @@ subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency)
use gsi_bundlemod, only: gsi_bundlegetpointer
use mpeu_util, only: die
+ use turblmod, only: use_pbl
implicit none
! Declare passed variables
@@ -357,7 +358,7 @@ subroutine calctends(mype,teta,pri,guess,xderivative,yderivative,tendency)
end do
end do !end do k
- call turbl(u,v,pri,t,teta,z,u_t,v_t,t_t,jtstart(kk),jtstop(kk))
+ if(use_pbl)call turbl(u,v,pri,t,teta,z,u_t,v_t,t_t,jtstart(kk),jtstop(kk))
if(.not.wrf_nmm_regional.and..not.nems_nmmb_regional)then
do k=1,nsig
diff --git a/src/gsi/calctends_ad.f90 b/src/gsi/calctends_ad.f90
index 72b5b76ffa..4f85a74485 100644
--- a/src/gsi/calctends_ad.f90
+++ b/src/gsi/calctends_ad.f90
@@ -67,6 +67,7 @@ subroutine calctends_ad(fields,fields_dt,mype)
use mpeu_util, only: die
use derivsmod, only: gsi_xderivative_bundle
use derivsmod, only: gsi_yderivative_bundle
+ use turblmod, only: use_pbl
implicit none
! Declare passed variables
@@ -356,7 +357,7 @@ subroutine calctends_ad(fields,fields_dt,mype)
end do
end if
- call turbl_ad(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),&
+ if(use_pbl)call turbl_ad(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),&
u,v,pri,t,u_t,v_t,t_t,jtstart(kk),jtstop(kk))
do k=nsig,1,-1
diff --git a/src/gsi/calctends_no_ad.f90 b/src/gsi/calctends_no_ad.f90
index e50f96df72..af792b69a5 100644
--- a/src/gsi/calctends_no_ad.f90
+++ b/src/gsi/calctends_no_ad.f90
@@ -72,6 +72,7 @@ subroutine calctends_no_ad(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag)
use gsi_bundlemod, only: gsi_bundlegetpointer
use derivsmod, only: gsi_xderivative_bundle
use derivsmod, only: gsi_yderivative_bundle
+ use turblmod, only: use_pbl
implicit none
! Declare passed variables
@@ -210,7 +211,7 @@ subroutine calctends_no_ad(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag)
end do
end if
- call turbl_ad(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),&
+ if(use_pbl)call turbl_ad(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),&
u,v,pri,t,u_t,v_t,t_t,jtstart(kk),jtstop(kk))
do k=nsig,1,-1
diff --git a/src/gsi/calctends_no_tl.f90 b/src/gsi/calctends_no_tl.f90
index 73be86be2e..c66a2abcc6 100644
--- a/src/gsi/calctends_no_tl.f90
+++ b/src/gsi/calctends_no_tl.f90
@@ -37,7 +37,7 @@ subroutine calctends_no_tl(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag)
! v - meridional wind on subdomain
! t - virtual temperature on subdomain
! mype - task id
-! uvflag - logical, set to true for st,vp wind components, instead of stream/potential function
+! uvflag - logical, set to true for u,v wind components, instead of stream/potential function
!
! output argument list:
! u_t - time tendency of u
@@ -64,6 +64,7 @@ subroutine calctends_no_tl(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag)
use gsi_bundlemod, only: gsi_bundlegetpointer
use derivsmod, only: gsi_xderivative_bundle
use derivsmod, only: gsi_yderivative_bundle
+ use turblmod, only: use_pbl
implicit none
! Declare passed variables
@@ -244,28 +245,21 @@ subroutine calctends_no_tl(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag)
end if
end if
-! top/bottom boundary condition:
do j=jtstart(kk),jtstop(kk)
do i=1,lat2
+
+! top/bottom boundary condition:
+
what(i,j,1)=zero
what(i,j,nsig+1)=zero
- enddo
- enddo
-
! load actual dp/dt
- do j=jtstart(kk),jtstop(kk)
- do i=1,lat2
p_t(i,j)=prsth(i,j,1)
- end do
- end do
! before big k loop, zero out the km1 summation arrays
- do j=jtstart(kk),jtstop(kk)
- do i=1,lat2
sumkm1 (i,j)=zero
sum2km1 (i,j)=zero
sumvkm1 (i,j)=zero
@@ -371,7 +365,7 @@ subroutine calctends_no_tl(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag)
end do !end do j
end do !end do k
- call turbl_tl(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),&
+ if(use_pbl)call turbl_tl(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),&
u,v,pri,t,u_t,v_t,t_t,jtstart(kk),jtstop(kk))
if(.not.wrf_nmm_regional.and..not.nems_nmmb_regional)then
diff --git a/src/gsi/calctends_tl.f90 b/src/gsi/calctends_tl.f90
index 59507fc6db..f5202f5f34 100644
--- a/src/gsi/calctends_tl.f90
+++ b/src/gsi/calctends_tl.f90
@@ -69,6 +69,7 @@ subroutine calctends_tl(fields,fields_dt,mype)
use mpeu_util, only: die, getindex
use derivsmod, only: gsi_xderivative_bundle
use derivsmod, only: gsi_yderivative_bundle
+ use turblmod, only: use_pbl
implicit none
! Declare passed variables
@@ -474,7 +475,7 @@ subroutine calctends_tl(fields,fields_dt,mype)
end do !end do j
end do !end do k
- call turbl_tl(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),&
+ if(use_pbl)call turbl_tl(ges_prsi(1,1,1,it),ges_tv,ges_teta(1,1,1,it),&
u,v,pri,t,u_t,v_t,t_t,jtstart(kk),jtstop(kk))
if(.not.wrf_nmm_regional.and..not.nems_nmmb_regional)then
diff --git a/src/gsi/chemmod.f90 b/src/gsi/chemmod.f90
index 14a90c818c..06bfe6dce6 100644
--- a/src/gsi/chemmod.f90
+++ b/src/gsi/chemmod.f90
@@ -40,21 +40,23 @@ module chemmod
public :: naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3
! fv3smoke
- public :: naero_smoke_fv3,aeronames_smoke_fv3,pm2_5_innov_threshold
+ public :: naero_smoke_fv3,aeronames_smoke_fv3
+ public :: pm2_5_innov_threshold,pm2_5_urban_innov_threshold,pm2_5_bg_threshold
+ public :: pm10_innov_threshold,pm10_urban_innov_threshold,pm10_bg_threshold,pm10_obs_threshold
public :: naero_gocart_wrf,aeronames_gocart_wrf
public :: pm2_5_guess,init_pm2_5_guess,&
aerotot_guess,init_aerotot_guess
public :: init_chem
- public :: berror_chem,berror_fv3_cmaq_regional,oneobtest_chem,maginnov_chem,magoberr_chem,oneob_type_chem,conconeobs
+ public :: berror_chem,berror_fv3_cmaq_regional,berror_fv3_sd_regional,oneobtest_chem,maginnov_chem,magoberr_chem,oneob_type_chem,conconeobs
public :: oblat_chem,oblon_chem,obpres_chem,diag_incr,oneobschem
public :: site_scale,nsites
public :: tunable_error
public :: in_fname,out_fname,incr_fname,maxstr
public :: code_pm25_ncbufr,code_pm25_anowbufr
public :: code_pm10_ncbufr,code_pm10_anowbufr
-
+ public :: anowbufr_ext
public :: l_aoderr_table
public :: laeroana_gocart,laeroana_fv3cmaq,laeroana_fv3smoke,crtm_aerosol_model,crtm_aerosolcoeff_format,crtm_aerosolcoeff_file, &
@@ -79,7 +81,8 @@ module chemmod
integer(i_kind) :: icvt_cmaq_fv3
real(r_kind) :: raod_radius_mean_scale,raod_radius_std_scale
real(r_kind) :: ppmv_conv = 96.06_r_kind/28.964_r_kind*1.0e+3_r_kind
- real(r_kind) :: pm2_5_innov_threshold
+ real(r_kind) :: pm2_5_innov_threshold,pm2_5_urban_innov_threshold,pm2_5_bg_threshold
+ real(r_kind) :: pm10_innov_threshold,pm10_urban_innov_threshold,pm10_bg_threshold,pm10_obs_threshold
logical :: wrf_pm2_5
@@ -90,7 +93,9 @@ module chemmod
logical :: aero_ratios
- logical :: oneobtest_chem,diag_incr,berror_chem,berror_fv3_cmaq_regional
+ logical :: oneobtest_chem,diag_incr,berror_chem
+ logical :: berror_fv3_cmaq_regional,berror_fv3_sd_regional
+ logical :: anowbufr_ext
character(len=max_varname_length) :: oneob_type_chem
integer(i_kind), parameter :: maxstr=256
real(r_kind) :: maginnov_chem,magoberr_chem,conconeobs,&
@@ -103,7 +108,7 @@ module chemmod
real(r_kind),parameter :: pm2_5_teom_max=900.0_r_kind !ug/m3
!some parameters need to be put here since convinfo file won't
!accomodate, stands for maximum realistic value of surface pm2.5
- real(r_kind),parameter :: pm10_teom_max=150.0_r_kind !ug/m3
+ real(r_kind),parameter :: pm10_teom_max=3000.0_r_kind !ug/m3
real(r_kind),parameter :: elev_missing=-9999.0_r_kind
@@ -157,10 +162,10 @@ module chemmod
'AOLGAJ', 'AISO1J', 'AISO2J', 'AISO3J', 'ATRP1J', 'ATRP2J',&
'ASQTJ', 'AOLGBJ', 'AORGCJ']
! fv3smoke
- integer(i_kind), parameter :: naero_smoke_fv3=2
+ integer(i_kind), parameter :: naero_smoke_fv3=3
character(len=max_varname_length), dimension(naero_smoke_fv3), parameter :: &
- aeronames_smoke_fv3=[character(len=max_varname_length) :: 'smoke','dust' ]
+ aeronames_smoke_fv3=[character(len=max_varname_length) :: 'smoke','dust','coarsepm']
! FV3CMAQ
integer(i_kind), parameter :: naero_cmaq_fv3=70 ! !number of cmaq aerosol species aero6
@@ -286,8 +291,15 @@ subroutine init_chem
!initialiazes default values to &CHEM namelist parameters
berror_chem=.false.
- berror_fv3_cmaq_regional=.false. ! Set .true. to use berror for fv3_cmaq_regional, whose cv has 10 characters
+ berror_fv3_cmaq_regional=.false. ! .False. : Dont perform aerosal DA for the online RRFS_CMAQ model so dont need to read in B for RRFS_CMAQ.
+ ! .true. : Use berror for fv3_cmaq_regional, whose cv has 10 characters
+ berror_fv3_sd_regional=.false. ! .False. : Dont perform aerosal DA for the RRFS_SD model so dont need to read in B for RRFS_SD.
+ ! .true. to use berror for rrfs_sd model, whose cv has 10 characters
oneobtest_chem=.false.
+ anowbufr_ext=.false. ! .False. : use default anowbufr data
+ ! .True. : use the extented bufr data
+ ! that includes PM10, station elevation
+ ! etal in addition to pm2.5.
maginnov_chem=30_r_kind
magoberr_chem=2_r_kind
oneob_type_chem='pm2_5'
@@ -307,9 +319,15 @@ subroutine init_chem
laeroana_gocart = .false.
laeroana_fv3cmaq = .false. ! .true. for performing aerosol analysis for regional FV3-CMAQ model(Please other parameters requred in gsimod.F90)
laeroana_fv3smoke = .false.
- pm2_5_innov_threshold = 20.0_r_kind
+ pm2_5_innov_threshold = 15.0_r_kind
+ pm2_5_urban_innov_threshold = 30.0_r_kind
+ pm2_5_bg_threshold = 2.0_r_kind
+ pm10_innov_threshold = 15.0_r_kind
+ pm10_urban_innov_threshold = 30.0_r_kind
+ pm10_bg_threshold = 2.0_r_kind
+ pm10_obs_threshold = 140.0_r_kind ! Barry's manuscript
l_aoderr_table = .false.
- icvt_cmaq_fv3 = 1 ! 1. Control variable is individual aerosol specie; 2: CV is total mass per I,J,K mode
+ icvt_cmaq_fv3 = 1 ! 1: Control variable is individual aerosol specie; 2: CV is total mass per I,J,K mode
raod_radius_mean_scale = 1.0_r_kind ! Tune radius of particles when calculating AOD using CRTM
raod_radius_std_scale = 1.0_r_kind ! Tune standard deviation of particles when calculating AOD using CRTM with CMAQ LUTs.
aod_qa_limit = 3
diff --git a/src/gsi/clw_mod.f90 b/src/gsi/clw_mod.f90
index 512aaded01..49387f05eb 100644
--- a/src/gsi/clw_mod.f90
+++ b/src/gsi/clw_mod.f90
@@ -2019,7 +2019,7 @@ subroutine gmi_37pol_diff(tb37v,tb37h,tsim37v,tsim37h,clw,ierrret)
clw = one - (tb37v-tb37h)/(tsim37v-tsim37h)
clw=max(zero,clw)
- if(tb37h > tb37v) then
+ if ((tb37h > tb37v) .or. (tb37h > 500_r_kind )) then
ierrret = 1
clw= r1000
endif
diff --git a/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake b/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake
index 8ba2887da8..b1d28132dc 100644
--- a/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake
+++ b/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake
@@ -14,7 +14,7 @@ set(CMAKE_Fortran_FLAGS_RELEASE "-O3 -fp-model strict")
# DEBUG FLAGS
####################################################################
-set(CMAKE_Fortran_FLAGS_DEBUG "-O0 -fp-model source -debug -ftrapuv -warn all,nointerfaces -check all,noarg_temp_created -fp-stack-check -fstack-protector")
+set(CMAKE_Fortran_FLAGS_DEBUG "-O0 -init=snan,arrays -fp-model source -debug -ftrapuv -warn all,nointerfaces -check all,noarg_temp_created -fp-stack-check -fstack-protector")
####################################################################
# LINK FLAGS
diff --git a/src/gsi/compact_diffs.f90 b/src/gsi/compact_diffs.f90
index 14f7b8fdc5..0a65e9a515 100644
--- a/src/gsi/compact_diffs.f90
+++ b/src/gsi/compact_diffs.f90
@@ -268,7 +268,6 @@ subroutine stvp2uv(work,idim)
integer(i_kind) ix,iy
integer(i_kind) ny,i,j
real(r_kind) polsu,polnu,polnv,polsv
- real(r_kind),dimension(nlon):: grid3n,grid3s,grid1n,grid1s
real(r_kind),dimension(nlat-2,nlon):: a,b,grid1,grid2,grid3,grid4
if(idim <=1) write(6,*) ' error in call to stvp2uv ',idim
@@ -314,31 +313,21 @@ subroutine stvp2uv(work,idim)
polsu=polsu+grid3(1 ,ix)*coslon(ix)+grid1(1 ,ix)*sinlon(ix)
polsv=polsv+grid3(1 ,ix)*sinlon(ix)-grid1(1 ,ix)*coslon(ix)
end do
- polnu=polnu/float(nlon)
- polnv=polnv/float(nlon)
- polsu=polsu/float(nlon)
- polsv=polsv/float(nlon)
- do ix=1,nlon
- grid3n(ix)= polnu*coslon(ix)+polnv*sinlon(ix)
- grid1n(ix)=-polnu*sinlon(ix)+polnv*coslon(ix)
- grid3s(ix)= polsu*coslon(ix)+polsv*sinlon(ix)
- grid1s(ix)= polsu*sinlon(ix)-polsv*coslon(ix)
- end do
+ polnu=polnu/real(nlon,r_kind)
+ polnv=polnv/real(nlon,r_kind)
+ polsu=polsu/real(nlon,r_kind)
+ polsv=polsv/real(nlon,r_kind)
! work(1 is u, work(2 is v
do j=1,nlon
- do i=1,nlat
- if(i /= 1 .and. i /= nlat)then
- work(1,i,j)=grid3(i-1,j)
- work(2,i,j)=grid1(i-1,j)
- else if(i == 1)then
- work(1,i,j)=grid3s(j)
- work(2,i,j)=grid1s(j)
- else
- work(1,i,j)=grid3n(j)
- work(2,i,j)=grid1n(j)
- end if
+ do i=2,nlat-1
+ work(1,i,j)=grid3(i-1,j)
+ work(2,i,j)=grid1(i-1,j)
end do
- enddo
+ work(1,1,j)= polsu*coslon(j)+polsv*sinlon(j)
+ work(2,1,j)= polsu*sinlon(j)-polsv*coslon(j)
+ work(1,nlat,j)= polnu*coslon(j)+polnv*sinlon(j)
+ work(2,nlat,j)= -polnu*sinlon(j)+polnv*coslon(j)
+ end do
return
end subroutine stvp2uv
@@ -463,7 +452,7 @@ subroutine uv2vordiv(work1,work2)
vor_s = vor_s + grid_vor( 1,ix)
vor_n = vor_n + grid_vor(ny,ix)
end do
- rnlon = one/float(nlon)
+ rnlon = one/real(nlon,r_kind)
div_s = div_s*rnlon
div_n = div_n*rnlon
vor_s = vor_s*rnlon
@@ -749,18 +738,14 @@ subroutine tstvp2uv(work,idim)
ny=nlat-2
do j=1,nlon
- do i=1,nlat
- if(i /= 1 .and. i /= nlat)then
- grid3(i-1,j)=work(1,i,j)
- grid1(i-1,j)=work(2,i,j)
- else if(i == 1)then
- grid3s(j)=work(1,i,j)
- grid1s(j)=work(2,i,j)
- else
- grid3n(j)=work(1,i,j)
- grid1n(j)=work(2,i,j)
- end if
+ do i=2,nlat-1
+ grid3(i-1,j)=work(1,i,j)
+ grid1(i-1,j)=work(2,i,j)
end do
+ grid3s(j)=work(1,1,j)
+ grid1s(j)=work(2,1,j)
+ grid3n(j)=work(1,nlat,j)
+ grid1n(j)=work(2,nlat,j)
end do
polnu=zero
@@ -773,10 +758,10 @@ subroutine tstvp2uv(work,idim)
polnv=polnv+grid3n(ix)*sinlon(ix)+coslon(ix)*grid1n(ix)
polsv=polsv+grid3s(ix)*sinlon(ix)-coslon(ix)*grid1s(ix)
end do
- polnu=polnu/float(nlon)
- polsu=polsu/float(nlon)
- polnv=polnv/float(nlon)
- polsv=polsv/float(nlon)
+ polnu=polnu/real(nlon,r_kind)
+ polsu=polsu/real(nlon,r_kind)
+ polnv=polnv/real(nlon,r_kind)
+ polsv=polsv/real(nlon,r_kind)
do ix=1,nlon
grid3(ny,ix)=grid3(ny,ix)+polnu*coslon(ix)+polnv*sinlon(ix)
@@ -815,16 +800,15 @@ subroutine tstvp2uv(work,idim)
nlon,ny,noq)
!$omp end parallel sections
do j=1,nlon
- do i=1,nlat
- if(i /= 1 .and. i /= nlat)then
-! NOTE: Adjoint of first derivative is its negative
- work(1,i,j)=-(a(i-1,j)+d(i-1,j))
- work(2,i,j)=-(b(i-1,j)+c(i-1,j))
- else
- work(1,i,j)=zero
- work(2,i,j)=zero
- end if
+ do i=2,nlat-1
+! NOTE: Adjoint of first derivative is its negative
+ work(1,i,j)=-(a(i-1,j)+d(i-1,j))
+ work(2,i,j)=-(b(i-1,j)+c(i-1,j))
end do
+ work(1,1,j)=zero
+ work(2,1,j)=zero
+ work(1,nlat,j)=zero
+ work(2,nlat,j)=zero
end do
return
@@ -1373,9 +1357,9 @@ subroutine inisph(r,yor,tau,nx,ny)
! Load coefficient array
ri=one/r
pih=pi/two
- pi2onx=pi/float(nxh)
+ pi2onx=pi/real(nxh,r_kind)
do ix=1,nxh
- coef(lacoy1+ix-1)=(float(ix)-half)*pi2onx
+ coef(lacoy1+ix-1)=(real(ix,r_kind)-half)*pi2onx
enddo
call cdcoef(nxh,noq,zero,pi,coef(lacoy1),w&
@@ -1996,10 +1980,10 @@ subroutine compact_dlon(b,dbdx,vector)
polsu=polsu+grid3(1 ,ix)*coslon(ix)
polsv=polsv+grid3(1 ,ix)*sinlon(ix)
end do
- polnu=two*polnu/float(nlon)
- polnv=two*polnv/float(nlon)
- polsu=two*polsu/float(nlon)
- polsv=two*polsv/float(nlon)
+ polnu=two*polnu/real(nlon,r_kind)
+ polnv=two*polnv/real(nlon,r_kind)
+ polsu=two*polsu/real(nlon,r_kind)
+ polsv=two*polsv/real(nlon,r_kind)
do ix=1,nlon
grid3n(ix)= polnu*coslon(ix)+polnv*sinlon(ix)
grid3s(ix)= polsu*coslon(ix)+polsv*sinlon(ix)
@@ -2089,10 +2073,10 @@ subroutine tcompact_dlon(b,dbdx,vector)
polsu=polsu+coslon(ix)*grid3s(ix)
polsv=polsv+sinlon(ix)*grid3s(ix)
end do
- polnu=two*polnu/float(nlon)
- polnv=two*polnv/float(nlon)
- polsu=two*polsu/float(nlon)
- polsv=two*polsv/float(nlon)
+ polnu=two*polnu/real(nlon,r_kind)
+ polnv=two*polnv/real(nlon,r_kind)
+ polsu=two*polsu/real(nlon,r_kind)
+ polsv=two*polsv/real(nlon,r_kind)
do ix=1,nlon
grid3(ny,ix)=grid3(ny,ix)+coslon(ix)*polnu+sinlon(ix)*polnv
grid3(1 ,ix)=grid3(1 ,ix)+coslon(ix)*polsu+sinlon(ix)*polsv
@@ -2230,10 +2214,10 @@ subroutine compact_dlat(b,dbdy,vector)
polsu=polsu+grid4(1 ,ix)*sinlon(ix)
polsv=polsv-grid4(1 ,ix)*coslon(ix)
end do
- polnu=two*polnu/float(nlon)
- polnv=two*polnv/float(nlon)
- polsu=two*polsu/float(nlon)
- polsv=two*polsv/float(nlon)
+ polnu=two*polnu/real(nlon,r_kind)
+ polnv=two*polnv/real(nlon,r_kind)
+ polsu=two*polsu/real(nlon,r_kind)
+ polsv=two*polsv/real(nlon,r_kind)
do ix=1,nlon
grid4n(ix)=-polnu*sinlon(ix)+polnv*coslon(ix)
grid4s(ix)= polsu*sinlon(ix)-polsv*coslon(ix)
@@ -2330,10 +2314,10 @@ subroutine tcompact_dlat(b,dbdy,vector)
polsu=polsu+sinlon(ix)*grid4s(ix)
polsv=polsv-coslon(ix)*grid4s(ix)
end do
- polnu=two*polnu/float(nlon)
- polnv=two*polnv/float(nlon)
- polsu=two*polsu/float(nlon)
- polsv=two*polsv/float(nlon)
+ polnu=two*polnu/real(nlon,r_kind)
+ polnv=two*polnv/real(nlon,r_kind)
+ polsu=two*polsu/real(nlon,r_kind)
+ polsv=two*polsv/real(nlon,r_kind)
do ix=1,nlon
grid4(ny,ix)=grid4(ny,ix)-sinlon(ix)*polnu+coslon(ix)*polnv
grid4(1 ,ix)=grid4(1 ,ix)+sinlon(ix)*polsu-coslon(ix)*polsv
diff --git a/src/gsi/compute_derived.f90 b/src/gsi/compute_derived.f90
index 46413d9986..32df50445f 100644
--- a/src/gsi/compute_derived.f90
+++ b/src/gsi/compute_derived.f90
@@ -467,7 +467,7 @@ subroutine compute_derived(mype,init_pass)
do i=indices%ips,indices%ipe
l =max(min(int(rllatf(i,j)),mlat),1)
l2=min((l+1),mlat)
- dl2=rllatf(i,j)-float(l)
+ dl2=rllatf(i,j)-real(l,r_kind)
dl1=one-dl2
factk=dl1*corz(l,kvar,nrf3_q)+dl2*corz(l2,kvar,nrf3_q)
diff --git a/src/gsi/compute_qvar3d.f90 b/src/gsi/compute_qvar3d.f90
index 851212d4f5..8babcc82fe 100644
--- a/src/gsi/compute_qvar3d.f90
+++ b/src/gsi/compute_qvar3d.f90
@@ -141,7 +141,7 @@ subroutine compute_qvar3d
d=20.0_r_kind*rhgues(i,j,k) + one
n=int(d)
np=n+1
- dn2=d-float(n)
+ dn2=d-real(n,r_kind)
dn1=one-dn2
n=min0(max(1,n),maxvarq1)
np=min0(max(1,np),maxvarq1)
@@ -200,7 +200,7 @@ subroutine compute_qvar3d
d=-2.0_r_kind*log(cwtmp) + one
n=int(d)
np=n+1
- dn2=d-float(n)
+ dn2=d-real(n,r_kind)
dn1=one-dn2
n=min0(max(1,n),30)
np=min0(max(1,np),30)
diff --git a/src/gsi/constants.f90 b/src/gsi/constants.f90
index 484e46b8b8..bf2b273c5f 100644
--- a/src/gsi/constants.f90
+++ b/src/gsi/constants.f90
@@ -74,9 +74,10 @@ module constants
public :: psv_a, psv_b, psv_c, psv_d
public :: ef_alpha, ef_beta, ef_gamma
public :: max_varname_length
+ public :: max_filename_length
public :: z_w_max,tfrozen
public :: qmin,qcmin,tgmin
- public :: i_missing, r_missing
+ public :: i_missing, r_missing, s_missing
public :: tice,t_wfr,e00,rvgas,rdgas,hlv,hlf,cp_vap,c_liq,c_ice,cp_air,cv_air
public :: izero, qimin, qsmin, qgmin,qrmin
@@ -90,7 +91,8 @@ module constants
! Declare derived constants
integer(i_kind):: huge_i_kind
- integer(i_kind), parameter :: max_varname_length=64
+ integer(i_kind), parameter :: max_varname_length=20
+ integer(i_kind), parameter :: max_filename_length=80
real(r_single):: tiny_single, huge_single
real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g
real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2
@@ -287,6 +289,7 @@ module constants
! Constant used to detect missing input value
integer(i_kind),parameter:: i_missing=-9999
integer(r_kind),parameter:: r_missing=-9999._r_kind
+ real(r_single),parameter:: s_missing = -9.99e9_r_single
! Constants initialized
logical :: constants_initialized = .true.
diff --git a/src/gsi/control2state.f90 b/src/gsi/control2state.f90
index fb87c1d0ef..9dd4bca7b3 100644
--- a/src/gsi/control2state.f90
+++ b/src/gsi/control2state.f90
@@ -1,3 +1,58 @@
+!-------------------------------------------------------------------------
+! NOAA/NCEP, National Centers for Environmental Prediction GSI !
+!-------------------------------------------------------------------------
+!BOP
+!
+! !MODULE: control2state_mod --- control2state_mod variables and routines
+!
+! !INTERFACE:
+!
+module control2state_mod
+
+! !USES:
+
+
+! !DESCRIPTION: module control2state routines and variables
+
+use kinds, only: r_kind,i_kind
+use constants, only : max_varname_length, zero
+use control_vectors, only: control_vector,c2sset_flg
+use control_vectors, only: cvars3d,cvars2d
+use bias_predictors, only: predictors
+use jfunc, only: nsclen,npclen,ntclen
+use gsi_4dvar, only: nsubwin, l4dvar, lsqrtb,ladtest_obs
+use gsi_chemguess_mod, only: gsi_chemguess_get
+use gsi_metguess_mod, only: gsi_metguess_get
+use gsi_bundlemod, only: gsi_bundlegetpointer
+use gsi_bundlemod, only: gsi_bundlecreate
+use gsi_bundlemod, only: gsi_bundle
+use gsi_bundlemod, only: gsi_bundlegetvar
+use gsi_bundlemod, only: gsi_bundleputvar
+use gsi_bundlemod, only: gsi_bundledestroy
+use gsi_bundlemod, only: assignment(=)
+use gridmod, only: nems_nmmb_regional
+use gridmod, only: regional, twodvar_regional
+use gridmod, only: lat2,lon2,nsig,nlat,nlon
+use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3
+use mpeu_util, only: getindex
+
+implicit none
+
+private
+public :: control2state
+public :: control2state_ad
+
+logical :: do_getprs,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro
+logical :: do_cw_to_hydro_hwrf
+
+integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw
+integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv
+integer(i_kind) :: icsfwter,icvpwter,ictcamt,iclcbas
+integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m
+
+integer :: ngases,nclouds
+
+contains
subroutine control2state(xhat,sval,bval)
!$$$ subprogram documentation block
! . . . .
@@ -57,31 +112,11 @@ subroutine control2state(xhat,sval,bval)
! bval - Bias predictors
!
!$$$ end documentation block
-use kinds, only: r_kind,i_kind
-use control_vectors, only: control_vector
-use control_vectors, only: cvars3d,cvars2d
-use bias_predictors, only: predictors
-use gsi_4dvar, only: nsubwin, l4dvar, lsqrtb, ladtest_obs
-use gridmod, only: regional,lat2,lon2,nsig, nlat, nlon, twodvar_regional
-use jfunc, only: nsclen,npclen,ntclen
-use cwhydromod, only: cw2hydro_tl
use amassaeromod, only: amass2aero_tl
-use cwhydromod, only: cw2hydro_tl_hwrf
-use gsi_bundlemod, only: gsi_bundlecreate
-use gsi_bundlemod, only: gsi_bundle
-use gsi_bundlemod, only: gsi_bundlegetpointer
-use gsi_bundlemod, only: gsi_bundlegetvar
-use gsi_bundlemod, only: gsi_bundleputvar
-use gsi_bundlemod, only: gsi_bundledestroy
-use gsi_bundlemod, only: assignment(=)
-use gsi_chemguess_mod, only: gsi_chemguess_get
-use gsi_metguess_mod, only: gsi_metguess_get
-use mpeu_util, only: getindex
-use constants, only : max_varname_length, zero
use general_sub2grid_mod, only: general_sub2grid,general_grid2sub
use general_commvars_mod, only: s2g_cv
-use gridmod, only: nems_nmmb_regional
-use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3
+use cwhydromod, only: cw2hydro_tl
+use cwhydromod, only: cw2hydro_tl_hwrf
implicit none
! Declare passed variables
@@ -94,22 +129,9 @@ subroutine control2state(xhat,sval,bval)
character(len=max_varname_length),allocatable,dimension(:) :: gases
character(len=max_varname_length),allocatable,dimension(:) :: clouds
real(r_kind),dimension(nlat*nlon*s2g_cv%nlevs_alloc) :: hwork
-integer(i_kind) :: ii,jj,ic,id,ngases,nclouds,istatus,istatus_oz
+integer(i_kind) :: ii,jj,ic,id,istatus,istatus_oz
type(gsi_bundle):: wbundle ! work bundle
-! Note: The following does not aim to get all variables in
-! the state and control vectors, but rather the ones
-! this routines knows how to handle.
-! Declare required local control variables
-integer(i_kind), parameter :: ncvars = 9
-integer(i_kind) :: icps(ncvars)
-integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw
-integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv
-integer(i_kind) :: icsfwter,icvpwter,ictcamt,iclcbas
-integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m
-character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here
- 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /)
-logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi
real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL()
real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL()
@@ -120,14 +142,6 @@ subroutine control2state(xhat,sval,bval)
real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL()
-! Declare required local state variables
-integer(i_kind), parameter :: nsvars = 12
-integer(i_kind) :: isps(nsvars)
-character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here
- 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', &
- 'qr ', 'qs ', 'qg ', 'qh ' /)
-logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi
-logical :: ls_qr,ls_qs,ls_qg,ls_qh
real(r_kind),pointer,dimension(:,:) :: sv_ps=>NULL(),sv_sst=>NULL()
real(r_kind),pointer,dimension(:,:) :: sv_gust=>NULL(),sv_vis=>NULL(),sv_pblh=>NULL()
real(r_kind),pointer,dimension(:,:) :: sv_wspd10m=>NULL(),sv_tcamt=>NULL(),sv_lcbas=>NULL()
@@ -143,82 +157,17 @@ subroutine control2state(xhat,sval,bval)
real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter
-logical :: do_getprs_tl,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro
-logical :: do_cw_to_hydro_hwrf
-
-
-if (lsqrtb) then
- write(6,*)trim(myname),': not for sqrt(B)'
- call stop2(106)
-end if
-if (nsubwin/=1 .and. .not.l4dvar) then
- write(6,*)trim(myname),': error 3dvar',nsubwin,l4dvar
- call stop2(107)
-end if
-
-! Inquire about cloud-vars
-call gsi_metguess_get('clouds::3d',nclouds,istatus)
+if (c2sset_flg)call c2sset(xhat,sval)
if (nclouds>0) then
allocate(clouds(nclouds))
call gsi_metguess_get('clouds::3d',clouds,istatus)
end if
-! Inquire about chemistry
-call gsi_chemguess_get('dim',ngases,istatus)
if (ngases>0) then
allocate(gases(ngases))
call gsi_chemguess_get('gsinames',gases,istatus)
endif
-! Since each internal vector of xhat has the same structure, pointers are
-! the same independent of the subwindow jj
-call gsi_bundlegetpointer (xhat%step(1),mycvars,icps,istatus)
-lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0
-lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0
-lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0
-
-! Since each internal vector of xhat has the same structure, pointers are
-! the same independent of the subwindow jj
-call gsi_bundlegetpointer (sval(1),mysvars,isps,istatus)
-ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0
-ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0
-ls_qi =isps(7)>0; ls_w =isps(8)>0
-ls_qr =isps(9)>0; ls_qs =isps(10)>0
-ls_qg =isps(11)>0; ls_qh =isps(12)>0
-
-! Define what to do depending on what's in CV and SV
-do_getprs_tl =lc_ps.and.lc_t .and.ls_prse
-do_normal_rh_to_q=lc_rh.and.lc_t .and.ls_prse.and.ls_q
-do_tv_to_tsen =lc_t .and.ls_q .and.ls_tsen
-do_getuv =lc_sf.and.lc_vp.and.ls_u.and.ls_v
-
-do_cw_to_hydro=.false.
-do_cw_to_hydro_hwrf=.false.
-if (regional) then
- do_cw_to_hydro=lc_cw.and.ls_ql.and.ls_qi
- do_cw_to_hydro_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh
-else
- do_cw_to_hydro=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global
-endif
-
-call gsi_bundlegetpointer (xhat%step(1),'oz',icoz,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'gust',icgust,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'vis',icvis,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'pblh',icpblh,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'wspd10m',icwspd10m,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'td2m',ictd2m,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'mxtm',icmxtm,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'mitm',icmitm,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'pmsl',icpmsl,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'howv',ichowv,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'sfwter',icsfwter,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'vpwter',icvpwter,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'w',icw,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'tcamt',ictcamt,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'lcbas',iclcbas,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'cldch',iccldch,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'uwnd10m',icuwnd10m,istatus)
-call gsi_bundlegetpointer (xhat%step(1),'vwnd10m',icvwnd10m,istatus)
! Loop over control steps
do jj=1,nsubwin
@@ -265,23 +214,6 @@ subroutine control2state(xhat,sval,bval)
end if
end if
- if(jj == 1)then
-! Biases
- do ii=1,nsclen
- bval%predr(ii)=xhat%predr(ii)
- enddo
-
- do ii=1,npclen
- bval%predp(ii)=xhat%predp(ii)
- enddo
-
- if (ntclen>0) then
- do ii=1,ntclen
- bval%predt(ii)=xhat%predt(ii)
- enddo
- end if
- end if
-
!$omp section
! Get pointers to required state variables
call gsi_bundlegetpointer (sval(jj),'prse',sv_prse,istatus)
@@ -295,7 +227,7 @@ subroutine control2state(xhat,sval,bval)
! Copy other variables
call gsi_bundlegetvar ( wbundle, 't' , sv_tv, istatus )
! Get 3d pressure
- if(do_getprs_tl) call getprs_tl(cv_ps,cv_t,sv_prse)
+ if(do_getprs) call getprs_tl(cv_ps,cv_t,sv_prse)
! Convert input normalized RH to q
if(do_normal_rh_to_q) call normal_rh_to_q(cv_rh,cv_t,sv_prse,sv_q)
@@ -330,14 +262,57 @@ subroutine control2state(xhat,sval,bval)
call gsi_bundlegetvar ( wbundle, 'ps' , sv_ps, istatus )
!$omp section
- call gsi_bundlegetpointer (sval(jj),'sst' ,sv_sst, istatus)
- call gsi_bundlegetvar ( wbundle, 'sst', sv_sst, istatus )
call gsi_bundlegetpointer (sval(jj),'oz' ,sv_oz , istatus_oz)
if (icoz>0) then
call gsi_bundlegetvar ( wbundle, 'oz' , sv_oz, istatus )
else
if(istatus_oz==0) sv_oz=zero
end if
+
+! Same one-to-one map for chemistry-vars; take care of them together
+ if (.not.laeroana_fv3cmaq .and. icvt_cmaq_fv3 == 2) then
+ write(6,*) ' icvt_cmaq_fv3 == 2 but laeroana_fv3cmaq=false stop!!!'
+ call stop2(999)
+ endif
+ if (icvt_cmaq_fv3 == 2) then
+ call amass2aero_tl(sval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3)
+ else
+ do ic=1,ngases
+ ! take care gases and aero variables if one to one mapping
+ id=getindex(cvars3d,gases(ic))
+ if (id>0) then
+ call gsi_bundlegetpointer (sval(jj),gases(ic),sv_rank3,istatus)
+ call gsi_bundlegetvar (wbundle, gases(ic),sv_rank3,istatus)
+ endif
+ id=getindex(cvars2d,gases(ic))
+ if (id>0) then
+ call gsi_bundlegetpointer (sval(jj),gases(ic),sv_rank2,istatus)
+ call gsi_bundlegetvar (wbundle, gases(ic),sv_rank2,istatus)
+ endif
+ enddo
+ end if
+
+!$omp section
+ if(jj == 1)then
+! Biases
+ do ii=1,nsclen
+ bval%predr(ii)=xhat%predr(ii)
+ enddo
+
+ do ii=1,npclen
+ bval%predp(ii)=xhat%predp(ii)
+ enddo
+
+ if (ntclen>0) then
+ do ii=1,ntclen
+ bval%predt(ii)=xhat%predt(ii)
+ enddo
+ end if
+ end if
+
+ call gsi_bundlegetpointer (sval(jj),'sst' ,sv_sst, istatus)
+ call gsi_bundlegetvar ( wbundle, 'sst', sv_sst, istatus )
+
if (icgust>0) then
call gsi_bundlegetpointer (sval(jj),'gust' ,sv_gust, istatus)
call gsi_bundlegetvar ( wbundle, 'gust', sv_gust, istatus )
@@ -405,43 +380,491 @@ subroutine control2state(xhat,sval,bval)
call gsi_bundlegetvar ( wbundle, 'vwnd10m', sv_vwnd10m, istatus )
end if
-! Same one-to-one map for chemistry-vars; take care of them together
+
+!$omp end parallel sections
+
+! Clean up
+ call gsi_bundledestroy(wbundle,istatus)
+ if(istatus/=0) then
+ write(6,*) trim(myname), ': trouble destroying work bundle'
+ call stop2(999)
+ endif
+
+end do
+
+if (ngases>0) deallocate(gases)
+
+if (nclouds>0) deallocate(clouds)
+
+return
+end subroutine control2state
+subroutine c2sset(xhat,sval)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: c2sset
+! prgmmr: derber
+!
+! abstract: Sets flags for control2state and control2state_ad
+!
+! program history log:
+! 2022-08-30 derber - initial code from control2state
+
+! input argument list:
+! xhat - Control variable
+! sval - State variable
+!
+!$$$ end documentation block
+implicit none
+
+! Declare passed variables
+type(control_vector), intent(in) :: xhat
+type(gsi_bundle) , intent(in) :: sval(nsubwin)
+
+! Declare local variables
+character(len=*),parameter::myname='c2sset'
+integer(i_kind) :: istatus
+
+! Note: The following does not aim to get all variables in
+! the state and control vectors, but rather the ones
+! this routines knows how to handle.
+! Declare required local control variables
+integer(i_kind), parameter :: ncvars = 9
+integer(i_kind) :: icps(ncvars)
+character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here
+ 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /)
+logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi
+
+! Declare required local state variables
+integer(i_kind), parameter :: nsvars = 12
+integer(i_kind) :: isps(nsvars)
+character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here
+ 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', &
+ 'qr ', 'qs ', 'qg ', 'qh ' /)
+logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi
+logical :: ls_qr,ls_qs,ls_qg,ls_qh
+
+
+
+if (lsqrtb) then
+ write(6,*)trim(myname),': not for sqrt(B)'
+ call stop2(106)
+end if
+if (nsubwin/=1 .and. .not.l4dvar) then
+ write(6,*)trim(myname),': error 3dvar',nsubwin,l4dvar
+ call stop2(107)
+end if
+
+! Inquire about cloud-vars
+call gsi_metguess_get('clouds::3d',nclouds,istatus)
+
+! Inquire about chemistry
+call gsi_chemguess_get('dim',ngases,istatus)
+
+! Since each internal vector of xhat has the same structure, pointers are
+! the same independent of the subwindow jj
+call gsi_bundlegetpointer (xhat%step(1),mycvars,icps,istatus)
+lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0
+lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0
+lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0
+
+! Since each internal vector of sval has the same structure, pointers are
+! the same independent of the subwindow jj
+call gsi_bundlegetpointer (sval(1),mysvars,isps,istatus)
+ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0
+ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0
+ls_qi =isps(7)>0; ls_w =isps(8)>0
+ls_qr =isps(9)>0; ls_qs =isps(10)>0
+ls_qg =isps(11)>0; ls_qh =isps(12)>0
+
+! Define what to do depending on what's in CV and SV
+do_getprs =lc_ps.and.lc_t .and.ls_prse
+do_normal_rh_to_q=lc_rh.and.lc_t .and.ls_prse.and.ls_q
+do_tv_to_tsen =lc_t .and.ls_q .and.ls_tsen
+do_getuv =lc_sf.and.lc_vp.and.ls_u.and.ls_v
+
+do_cw_to_hydro=.false.
+do_cw_to_hydro_hwrf=.false.
+if (regional) then
+ do_cw_to_hydro=lc_cw.and.ls_ql.and.ls_qi
+ do_cw_to_hydro_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh
+else
+ do_cw_to_hydro=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global
+endif
+
+call gsi_bundlegetpointer (xhat%step(1),'oz',icoz,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'gust',icgust,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'vis',icvis,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'pblh',icpblh,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'wspd10m',icwspd10m,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'td2m',ictd2m,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'mxtm',icmxtm,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'mitm',icmitm,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'pmsl',icpmsl,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'howv',ichowv,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'sfwter',icsfwter,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'vpwter',icvpwter,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'w',icw,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'tcamt',ictcamt,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'lcbas',iclcbas,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'cldch',iccldch,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'uwnd10m',icuwnd10m,istatus)
+call gsi_bundlegetpointer (xhat%step(1),'vwnd10m',icvwnd10m,istatus)
+
+c2sset_flg=.false. ! set to true in setup. set to false after first (only) call to c2sset
+return
+end subroutine c2sset
+subroutine control2state_ad(rval,bval,grad)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: control2state_ad
+! prgmmr: tremolet
+!
+! abstract: Converts variables from physical space to control space
+! This is also the adjoint of control2state
+!
+! program history log:
+! 2007-04-16 tremolet - initial code
+! 2008-11-28 todling - update to GSI May 2008: add tsen and p3d
+! 2009-01-15 todling - handle predictors in quad precision
+! 2009-04-21 derber - modify call to getstvp to call to getuv
+! 2009-06-15 parrish - add call to strong_bk_ad when l_hyb_ens=.true. (hybrid ensemble run)
+! 2009-08-12 lueken - update documentation
+! 2009-11-27 parrish - for uv_hyb_ens=.true., then ensemble perturbations contain u,v instead of st,vp
+! so introduce extra code to handle this case.
+! 2010-02-20 parrish - introduce modifications to allow dual resolution capability when running
+! in hybrid ensemble mode.
+! 2010-03-24 zhu - use cstate for generalizing control variable
+! 2010-04-29 todling - update to use gsi_bundle; rename cstate to wbundle
+! 2010-05-31 todling - better consistency checks; add co/co2
+! - ready to bypass analysis of (any) meteorological fields
+! 2010-06-15 todling - generalized handling of chemistry
+! 2011-02-22 zhu - add gust,vis,pblh
+! 2011-05-15 auligne/todling - generalized cloud handling
+! 2011-07-12 zhu - add do_cw_to_hydro_ad and cw2hydro_ad
+! 2011-11-01 eliu - generalize the use of do_cw_to_hydro_ad
+! 2012-02-08 kleist - remove strong_bk_ad and ensemble_forward_model_ad and related parameters
+! 2013-05-23 zhu - add ntclen and predt for aircraft temperature bias correction
+! 2013-10-25 todling - nullify work pointers
+! 2013-10-28 todling - rename p3d to prse
+! 2014-01-31 mkim - add support for when ql and qi are CVs for all-sky mw radiance DA
+! 2014-03-19 pondeca - add wspd10m
+! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl
+! 2014-05-07 pondeca - add howv
+! 2014-06-16 carley/zhu - add tcamt and lcbas
+! 2014-12-03 derber - introduce parallel regions for optimization
+! 2015-07-10 pondeca - add cloud ceiling height (cldch)
+! 2016-05-03 pondeca - add uwnd10m, and vwnd10m
+! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu
+! 2016-08-12 lippi - add vertical velocity (w) to mycvars and mysvars.
+! 2016-05-03 pondeca - add uwnd10m, and vwnd10m
+! 2022-05-24 H.Wang - add amass2aero_ad for regional FV3-CMAQ DA when using
+! total mass as control variable.
+!
+! input argument list:
+! rval - State variable
+! bval
+! output argument list:
+! grad - Control variable
+!
+!$$$
+use amassaeromod, only: amass2aero_ad
+use cwhydromod, only: cw2hydro_ad
+use cwhydromod, only: cw2hydro_ad_hwrf
+
+implicit none
+
+! Declare passed variables
+type(gsi_bundle) , intent(inout) :: rval(nsubwin)
+type(predictors) , intent(in ) :: bval
+type(control_vector), intent(inout) :: grad
+
+! Declare local variables
+character(len=*),parameter::myname='control2state_ad'
+character(len=max_varname_length),allocatable,dimension(:) :: gases
+character(len=max_varname_length),allocatable,dimension(:) :: clouds
+integer(i_kind) :: ii,jj,ic,id,istatus,istatus_oz
+type(gsi_bundle) :: wbundle ! work bundle
+
+real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL()
+real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL()
+!real(r_kind),pointer,dimension(:,:,:) :: cv_w=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: cv_t=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL()
+
+! Declare required local state variables
+real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL(),rv_sst=>NULL()
+real(r_kind),pointer,dimension(:,:) :: rv_gust=>NULL(),rv_vis=>NULL(),rv_pblh=>NULL()
+real(r_kind),pointer,dimension(:,:) :: rv_wspd10m=>NULL(),rv_tcamt=>NULL(),rv_lcbas=>NULL()
+real(r_kind),pointer,dimension(:,:) :: rv_td2m=>NULL(),rv_mxtm=>NULL(),rv_mitm=>NULL()
+real(r_kind),pointer,dimension(:,:) :: rv_pmsl=>NULL(),rv_howv=>NULL(),rv_cldch=>NULL()
+real(r_kind),pointer,dimension(:,:) :: rv_uwnd10m=>NULL(),rv_vwnd10m=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL(),rv_v=>NULL(),rv_w=>NULL(),rv_dw=>NULL(),rv_prse=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL(),rv_tsen=>NULL(),rv_tv=>NULL(),rv_oz=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL()
+real(r_kind),pointer,dimension(:,:) :: rv_rank2=>NULL()
+
+real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter
+
+
+
+!******************************************************************************
+
+if (c2sset_flg)call c2sset(grad,rval)
+if (lsqrtb) then
+ write(6,*)trim(myname),': not for sqrt(B)'
+ call stop2(311)
+end if
+
+! Inquire about clouds
+if (nclouds>0) then
+ allocate(clouds(nclouds))
+ call gsi_metguess_get ('clouds::3d',clouds,istatus)
+endif
+
+! Inquire about chemistry
+call gsi_chemguess_get('dim',ngases,istatus)
+if (ngases>0) then
+ allocate(gases(ngases))
+ call gsi_chemguess_get('gsinames',gases,istatus)
+endif
+
+
+! Loop over control steps
+do jj=1,nsubwin
+
+! Create a work bundle similar to grad control vector's bundle
+ call gsi_bundlecreate ( wbundle, grad%step(jj), 'control2state_ad work', istatus )
+ if (istatus/=0) then
+ write(6,*) trim(myname),': trouble creating work bundle'
+ call stop2(999)
+ endif
+
+!$omp parallel sections private(istatus,ii,ic,id,istatus_oz,rv_u,rv_v,rv_prse,rv_q,rv_tsen,uland,vland,uwter,vwter)
+
+!$omp section
+
+ call gsi_bundlegetpointer (wbundle,'sf' ,cv_sf ,istatus)
+ call gsi_bundlegetpointer (wbundle,'vp' ,cv_vp ,istatus)
+ call gsi_bundlegetpointer (rval(jj),'u' ,rv_u, istatus)
+ call gsi_bundlegetpointer (rval(jj),'v' ,rv_v, istatus)
+ call gsi_bundleputvar ( wbundle, 'sf', zero, istatus )
+ call gsi_bundleputvar ( wbundle, 'vp', zero, istatus )
+! Convert RHS calculations for u,v to st/vp for application of
+! background error
+ if (do_getuv) then
+ if (twodvar_regional .and. icsfwter>0 .and. icvpwter>0) then
+ call gsi_bundlegetpointer (wbundle,'sfwter', cv_sfwter,istatus)
+ call gsi_bundlegetpointer (wbundle,'vpwter', cv_vpwter,istatus)
+ allocate(uland(lat2,lon2,nsig),vland(lat2,lon2,nsig), &
+ uwter(lat2,lon2,nsig),vwter(lat2,lon2,nsig))
+
+ uland=zero ; uwter=zero
+ vland=zero ; vwter=zero
+
+ call landlake_uvmerge(rv_u,rv_v,uland,vland,uwter,vwter,0)
+
+ call getuv(uwter,vwter,cv_sfwter,cv_vpwter,1)
+ call getuv(uland,vland,cv_sf,cv_vp,1)
+ deallocate(uland,vland,uwter,vwter)
+ else
+ call getuv(rv_u,rv_v,cv_sf,cv_vp,1)
+ endif
+ endif
+
+!$omp section
+
+! Get pointers to required control variables
+ call gsi_bundlegetpointer (wbundle,'ps' ,cv_ps ,istatus)
+ call gsi_bundlegetpointer (wbundle,'t' ,cv_t, istatus)
+ call gsi_bundlegetpointer (wbundle,'q' ,cv_rh ,istatus)
+
+! Get pointers to this subwin require state variables
+ call gsi_bundlegetpointer (rval(jj),'ps' ,rv_ps, istatus)
+ call gsi_bundlegetpointer (rval(jj),'prse',rv_prse,istatus)
+ call gsi_bundlegetpointer (rval(jj),'tv' ,rv_tv, istatus)
+ call gsi_bundlegetpointer (rval(jj),'tsen',rv_tsen,istatus)
+ call gsi_bundlegetpointer (rval(jj),'q' ,rv_q , istatus)
+
+! Adjoint of control to initial state
+ call gsi_bundleputvar ( wbundle, 't' , rv_tv, istatus )
+ call gsi_bundleputvar ( wbundle, 'q' , zero, istatus )
+ call gsi_bundleputvar ( wbundle, 'ps', rv_ps, istatus )
+
+ if (do_cw_to_hydro .and. .not.do_cw_to_hydro_hwrf) then
+! Case when cloud-vars do not map one-to-one
+! e.g. cw-to-ql&qi
+ call cw2hydro_ad(rval(jj),wbundle,clouds,nclouds)
+ elseif (do_cw_to_hydro_hwrf) then
+! Case when cloud-vars do not map one-to-one
+! e.g. cw-to-ql&qi&qr&qs&qg&qh
+ call cw2hydro_ad_hwrf(rval(jj),wbundle,rv_tsen)
+ else
+! Case when cloud-vars map one-to-one, take care of them together
+! e.g. cw-to-cw
+ do ic=1,nclouds
+ id=getindex(cvars3d,clouds(ic))
+ if (id>0) then
+ call gsi_bundlegetpointer (rval(jj),clouds(ic),rv_rank3,istatus)
+ call gsi_bundleputvar (wbundle, clouds(ic),rv_rank3,istatus)
+ endif
+ enddo
+ end if
+! Calculate sensible temperature
+ if(do_tv_to_tsen) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen)
+
+! Adjoint of convert input normalized RH to q to add contribution of moisture
+! to t, p , and normalized rh
+ if(do_normal_rh_to_q) call normal_rh_to_q_ad(cv_rh,cv_t,rv_prse,rv_q)
+
+! Adjoint to convert ps to 3-d pressure
+ if(do_getprs) call getprs_ad(cv_ps,cv_t,rv_prse)
+
+
+!$omp section
+
+
+! call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus)
+ call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus_oz)
+
+ if (icoz>0) then
+ call gsi_bundleputvar ( wbundle, 'oz', rv_oz, istatus )
+ else
+ if(istatus_oz==0) rv_oz=zero
+ end if
+
+! Same one-to-one map for chemistry-vars; take care of them together
if (.not.laeroana_fv3cmaq .and. icvt_cmaq_fv3 == 2) then
write(6,*) ' icvt_cmaq_fv3 == 2 but laeroana_fv3cmaq=false stop!!!'
call stop2(999)
endif
+
if (icvt_cmaq_fv3 == 2) then
- call amass2aero_tl(sval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3)
+ call amass2aero_ad(rval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3)
else
do ic=1,ngases
- ! take care gases and aero variables if one to one mapping
id=getindex(cvars3d,gases(ic))
if (id>0) then
- call gsi_bundlegetpointer (sval(jj),gases(ic),sv_rank3,istatus)
- call gsi_bundlegetvar (wbundle, gases(ic),sv_rank3,istatus)
+ call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank3,istatus)
+ call gsi_bundleputvar (wbundle, gases(ic),rv_rank3,istatus)
endif
+
id=getindex(cvars2d,gases(ic))
if (id>0) then
- call gsi_bundlegetpointer (sval(jj),gases(ic),sv_rank2,istatus)
- call gsi_bundlegetvar (wbundle, gases(ic),sv_rank2,istatus)
+ call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank2,istatus)
+ call gsi_bundleputvar (wbundle, gases(ic),rv_rank2,istatus)
endif
enddo
- end if
+ end if
+!$omp section
+ if(jj == 1)then
+ do ii=1,nsclen
+ grad%predr(ii)=bval%predr(ii)
+ enddo
+ do ii=1,npclen
+ grad%predp(ii)=bval%predp(ii)
+ enddo
+ if (ntclen>0) then
+ do ii=1,ntclen
+ grad%predt(ii)=bval%predt(ii)
+ enddo
+ end if
+ end if
+
+ call gsi_bundlegetpointer (rval(jj),'sst' ,rv_sst, istatus)
+ call gsi_bundleputvar ( wbundle, 'sst', rv_sst, istatus )
+
+ if (icgust>0) then
+ call gsi_bundlegetpointer (rval(jj),'gust' ,rv_gust, istatus)
+ call gsi_bundleputvar ( wbundle, 'gust', rv_gust, istatus )
+ end if
+ if (icvis >0) then
+ call gsi_bundlegetpointer (rval(jj),'vis' ,rv_vis , istatus)
+ call gsi_bundleputvar ( wbundle, 'vis' , rv_vis , istatus )
+ end if
+ if (icpblh>0)then
+ call gsi_bundlegetpointer (rval(jj),'pblh' ,rv_pblh, istatus)
+ call gsi_bundleputvar ( wbundle, 'pblh', rv_pblh, istatus )
+ end if
+ if (icwspd10m>0) then
+ call gsi_bundlegetpointer (rval(jj),'wspd10m' ,rv_wspd10m, istatus)
+ call gsi_bundleputvar ( wbundle, 'wspd10m', rv_wspd10m, istatus )
+ end if
+ if (ictd2m>0) then
+ call gsi_bundlegetpointer (rval(jj),'td2m' ,rv_td2m, istatus)
+ call gsi_bundleputvar ( wbundle, 'td2m', rv_td2m, istatus )
+ end if
+ if (icmxtm>0) then
+ call gsi_bundlegetpointer (rval(jj),'mxtm' ,rv_mxtm, istatus)
+ call gsi_bundleputvar ( wbundle, 'mxtm', rv_mxtm, istatus )
+ end if
+ if (icmitm>0) then
+ call gsi_bundlegetpointer (rval(jj),'mitm' ,rv_mitm, istatus)
+ call gsi_bundleputvar ( wbundle, 'mitm', rv_mitm, istatus )
+ end if
+ if (icpmsl>0) then
+ call gsi_bundlegetpointer (rval(jj),'pmsl' ,rv_pmsl, istatus)
+ call gsi_bundleputvar ( wbundle, 'pmsl', rv_pmsl, istatus )
+ end if
+ if (ichowv>0) then
+ call gsi_bundlegetpointer (rval(jj),'howv' ,rv_howv, istatus)
+ call gsi_bundleputvar ( wbundle, 'howv', rv_howv, istatus )
+ end if
+ if (icw>0) then
+ call gsi_bundlegetpointer (rval(jj),'w' ,rv_w, istatus)
+ call gsi_bundleputvar ( wbundle, 'w', rv_w, istatus )
+ if(nems_nmmb_regional)then
+ call gsi_bundlegetpointer (rval(jj),'dw' ,rv_dw, istatus)
+ call gsi_bundleputvar ( wbundle, 'dw', rv_dw, istatus )
+ end if
+ end if
+ if (ictcamt>0) then
+ call gsi_bundlegetpointer (rval(jj),'tcamt',rv_tcamt, istatus)
+ call gsi_bundleputvar ( wbundle, 'tcamt', rv_tcamt, istatus )
+ end if
+ if (iclcbas>0) then
+ call gsi_bundlegetpointer (wbundle,'lcbas',cv_lcbas,istatus)
+ call gsi_bundlegetpointer (rval(jj),'lcbas',rv_lcbas, istatus)
+ call gsi_bundleputvar ( wbundle, 'lcbas', zero, istatus )
+ ! Adjoint of convert loglcbas to lcbas
+ call loglcbas_to_lcbas_ad(cv_lcbas,rv_lcbas)
+ end if
+ if (iccldch >0) then
+ call gsi_bundlegetpointer (rval(jj),'cldch' ,rv_cldch , istatus)
+ call gsi_bundleputvar ( wbundle, 'cldch' , rv_cldch , istatus )
+ end if
+ if (icuwnd10m>0) then
+ call gsi_bundlegetpointer (rval(jj),'uwnd10m' ,rv_uwnd10m, istatus)
+ call gsi_bundleputvar ( wbundle, 'uwnd10m', rv_uwnd10m, istatus )
+ end if
+ if (icvwnd10m>0) then
+ call gsi_bundlegetpointer (rval(jj),'vwnd10m' ,rv_vwnd10m, istatus)
+ call gsi_bundleputvar ( wbundle, 'vwnd10m', rv_vwnd10m, istatus )
+ end if
!$omp end parallel sections
-! Clean up
+! Adjoint of transfer variables
+
+ do ii=1,wbundle%ndim
+ grad%step(jj)%values(ii)=wbundle%values(ii)+grad%step(jj)%values(ii)
+ enddo
call gsi_bundledestroy(wbundle,istatus)
- if(istatus/=0) then
- write(6,*) trim(myname), ': trouble destroying work bundle'
+ if (istatus/=0) then
+ write(6,*) trim(myname),': trouble destroying work bundle'
call stop2(999)
endif
end do
-if (ngases>0) deallocate(gases)
+! Clean up
+if (ngases>0) deallocate(gases)
if (nclouds>0) deallocate(clouds)
return
-end subroutine control2state
+end subroutine control2state_ad
+end module control2state_mod
diff --git a/src/gsi/control2state_ad.f90 b/src/gsi/control2state_ad.f90
deleted file mode 100644
index ce1e9d2cd2..0000000000
--- a/src/gsi/control2state_ad.f90
+++ /dev/null
@@ -1,441 +0,0 @@
-subroutine control2state_ad(rval,bval,grad)
-!$$$ subprogram documentation block
-! . . . .
-! subprogram: control2state_ad
-! prgmmr: tremolet
-!
-! abstract: Converts variables from physical space to control space
-! This is also the adjoint of control2state
-!
-! program history log:
-! 2007-04-16 tremolet - initial code
-! 2008-11-28 todling - update to GSI May 2008: add tsen and p3d
-! 2009-01-15 todling - handle predictors in quad precision
-! 2009-04-21 derber - modify call to getstvp to call to getuv
-! 2009-06-15 parrish - add call to strong_bk_ad when l_hyb_ens=.true. (hybrid ensemble run)
-! 2009-08-12 lueken - update documentation
-! 2009-11-27 parrish - for uv_hyb_ens=.true., then ensemble perturbations contain u,v instead of st,vp
-! so introduce extra code to handle this case.
-! 2010-02-20 parrish - introduce modifications to allow dual resolution capability when running
-! in hybrid ensemble mode.
-! 2010-03-24 zhu - use cstate for generalizing control variable
-! 2010-04-29 todling - update to use gsi_bundle; rename cstate to wbundle
-! 2010-05-31 todling - better consistency checks; add co/co2
-! - ready to bypass analysis of (any) meteorological fields
-! 2010-06-15 todling - generalized handling of chemistry
-! 2011-02-22 zhu - add gust,vis,pblh
-! 2011-05-15 auligne/todling - generalized cloud handling
-! 2011-07-12 zhu - add do_cw_to_hydro_ad and cw2hydro_ad
-! 2011-11-01 eliu - generalize the use of do_cw_to_hydro_ad
-! 2012-02-08 kleist - remove strong_bk_ad and ensemble_forward_model_ad and related parameters
-! 2013-05-23 zhu - add ntclen and predt for aircraft temperature bias correction
-! 2013-10-25 todling - nullify work pointers
-! 2013-10-28 todling - rename p3d to prse
-! 2014-01-31 mkim - add support for when ql and qi are CVs for all-sky mw radiance DA
-! 2014-03-19 pondeca - add wspd10m
-! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl
-! 2014-05-07 pondeca - add howv
-! 2014-06-16 carley/zhu - add tcamt and lcbas
-! 2014-12-03 derber - introduce parallel regions for optimization
-! 2015-07-10 pondeca - add cloud ceiling height (cldch)
-! 2016-05-03 pondeca - add uwnd10m, and vwnd10m
-! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu
-! 2016-08-12 lippi - add vertical velocity (w) to mycvars and mysvars.
-! 2016-05-03 pondeca - add uwnd10m, and vwnd10m
-! 2022-05-24 H.Wang - add amass2aero_ad for regional FV3-CMAQ DA when using
-! total mass as control variable.
-!
-! input argument list:
-! rval - State variable
-! bval
-! output argument list:
-! grad - Control variable
-!
-!$$$
-use kinds, only: i_kind,r_kind
-use control_vectors, only: control_vector
-use control_vectors, only: cvars3d,cvars2d
-use bias_predictors, only: predictors
-use gsi_4dvar, only: nsubwin, lsqrtb
-use gridmod, only: regional,lat2,lon2,nsig,twodvar_regional
-use jfunc, only: nsclen,npclen,ntclen
-use cwhydromod, only: cw2hydro_ad
-use amassaeromod, only: amass2aero_ad
-use cwhydromod, only: cw2hydro_ad_hwrf
-use gsi_bundlemod, only: gsi_bundlecreate
-use gsi_bundlemod, only: gsi_bundle
-use gsi_bundlemod, only: gsi_bundlegetpointer
-use gsi_bundlemod, only: gsi_bundlegetvar
-use gsi_bundlemod, only: gsi_bundleputvar
-use gsi_bundlemod, only: gsi_bundledestroy
-use gsi_chemguess_mod, only: gsi_chemguess_get
-use gsi_metguess_mod, only: gsi_metguess_get
-use mpeu_util, only: getindex
-use constants, only: max_varname_length,zero
-use gridmod, only: nems_nmmb_regional
-use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3
-
-implicit none
-
-! Declare passed variables
-type(gsi_bundle) , intent(inout) :: rval(nsubwin)
-type(predictors) , intent(in ) :: bval
-type(control_vector), intent(inout) :: grad
-
-! Declare local variables
-character(len=*),parameter::myname='control2state_ad'
-character(len=max_varname_length),allocatable,dimension(:) :: gases
-character(len=max_varname_length),allocatable,dimension(:) :: clouds
-integer(i_kind) :: ii,jj,ic,id,ngases,nclouds,istatus,istatus_oz
-type(gsi_bundle) :: wbundle ! work bundle
-
-! Note: The following does not aim to get all variables in
-! the state and control vectors, but rather the ones
-! this routines knows how to handle.
-integer(i_kind), parameter :: ncvars = 9
-integer(i_kind) :: icps(ncvars)
-integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw
-integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv
-integer(i_kind) :: ictcamt,iclcbas,icsfwter,icvpwter
-integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m
-character(len=3), parameter :: mycvars(ncvars) = (/ &
- 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /)
-logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi
-real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL()
-real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL()
-!real(r_kind),pointer,dimension(:,:,:) :: cv_w=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: cv_t=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL()
-
-! Declare required local state variables
-integer(i_kind), parameter :: nsvars = 12
-integer(i_kind) :: isps(nsvars)
-character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here
- 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', &
- 'qr ', 'qs ', 'qg ', 'qh ' /)
-logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi
-logical :: ls_qr,ls_qs,ls_qg,ls_qh
-real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL(),rv_sst=>NULL()
-real(r_kind),pointer,dimension(:,:) :: rv_gust=>NULL(),rv_vis=>NULL(),rv_pblh=>NULL()
-real(r_kind),pointer,dimension(:,:) :: rv_wspd10m=>NULL(),rv_tcamt=>NULL(),rv_lcbas=>NULL()
-real(r_kind),pointer,dimension(:,:) :: rv_td2m=>NULL(),rv_mxtm=>NULL(),rv_mitm=>NULL()
-real(r_kind),pointer,dimension(:,:) :: rv_pmsl=>NULL(),rv_howv=>NULL(),rv_cldch=>NULL()
-real(r_kind),pointer,dimension(:,:) :: rv_uwnd10m=>NULL(),rv_vwnd10m=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL(),rv_v=>NULL(),rv_w=>NULL(),rv_dw=>NULL(),rv_prse=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL(),rv_tsen=>NULL(),rv_tv=>NULL(),rv_oz=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL()
-real(r_kind),pointer,dimension(:,:) :: rv_rank2=>NULL()
-
-real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter
-
-logical :: do_getuv,do_tv_to_tsen_ad,do_normal_rh_to_q_ad,do_getprs_ad,do_cw_to_hydro_ad
-logical :: do_cw_to_hydro_ad_hwrf
-
-
-!******************************************************************************
-
-if (lsqrtb) then
- write(6,*)trim(myname),': not for sqrt(B)'
- call stop2(311)
-end if
-
-! Inquire about clouds
-call gsi_metguess_get ('clouds::3d',nclouds,istatus)
-if (nclouds>0) then
- allocate(clouds(nclouds))
- call gsi_metguess_get ('clouds::3d',clouds,istatus)
-endif
-
-! Inquire about chemistry
-call gsi_chemguess_get('dim',ngases,istatus)
-if (ngases>0) then
- allocate(gases(ngases))
- call gsi_chemguess_get('gsinames',gases,istatus)
-endif
-
-! Since each internal vector [step(jj)] of grad has the same structure, pointers are
-! the same independent of the subwindow jj
-call gsi_bundlegetpointer (grad%step(1),mycvars,icps,istatus)
-lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0
-lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0
-lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0
-
-! Since each internal vector of xhat has the same structure, pointers are
-! the same independent of the subwindow jj
-call gsi_bundlegetpointer (rval(1),mysvars,isps,istatus)
-ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0
-ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0
-ls_qi =isps(7)>0; ls_w =isps(8)>0
-ls_qr =isps(9)>0; ls_qs =isps(10)>0
-ls_qg =isps(11)>0; ls_qh =isps(12)>0
-
-! Define what to do depending on what's in CV and SV
-do_getuv =lc_sf.and.lc_vp.and.ls_u .and.ls_v
-do_tv_to_tsen_ad =lc_t .and.ls_q .and.ls_tsen
-do_normal_rh_to_q_ad=lc_t .and.lc_rh.and.ls_prse.and.ls_q
-do_getprs_ad =lc_t .and.lc_ps.and.ls_prse
-
-do_cw_to_hydro_ad=.false.
-do_cw_to_hydro_ad_hwrf=.false.
-if (regional) then
- do_cw_to_hydro_ad=lc_cw.and.ls_ql.and.ls_qi
- do_cw_to_hydro_ad_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh
-else
- do_cw_to_hydro_ad=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global
-endif
-
-call gsi_bundlegetpointer (grad%step(1),'oz',icoz,istatus)
-call gsi_bundlegetpointer (grad%step(1),'gust',icgust,istatus)
-call gsi_bundlegetpointer (grad%step(1),'vis',icvis,istatus)
-call gsi_bundlegetpointer (grad%step(1),'pblh',icpblh,istatus)
-call gsi_bundlegetpointer (grad%step(1),'wspd10m',icwspd10m,istatus)
-call gsi_bundlegetpointer (grad%step(1),'td2m',ictd2m,istatus)
-call gsi_bundlegetpointer (grad%step(1),'mxtm',icmxtm,istatus)
-call gsi_bundlegetpointer (grad%step(1),'mitm',icmitm,istatus)
-call gsi_bundlegetpointer (grad%step(1),'pmsl',icpmsl,istatus)
-call gsi_bundlegetpointer (grad%step(1),'howv',ichowv,istatus)
-call gsi_bundlegetpointer (grad%step(1),'sfwter',icsfwter,istatus)
-call gsi_bundlegetpointer (grad%step(1),'vpwter',icvpwter,istatus)
-call gsi_bundlegetpointer (grad%step(1),'w',icw,istatus)
-call gsi_bundlegetpointer (grad%step(1),'tcamt',ictcamt,istatus)
-call gsi_bundlegetpointer (grad%step(1),'lcbas',iclcbas,istatus)
-call gsi_bundlegetpointer (grad%step(1),'cldch',iccldch,istatus)
-call gsi_bundlegetpointer (grad%step(1),'uwnd10m',icuwnd10m,istatus)
-call gsi_bundlegetpointer (grad%step(1),'vwnd10m',icvwnd10m,istatus)
-
-! Loop over control steps
-do jj=1,nsubwin
-
-! Create a work bundle similar to grad control vector's bundle
- call gsi_bundlecreate ( wbundle, grad%step(jj), 'control2state_ad work', istatus )
- if (istatus/=0) then
- write(6,*) trim(myname),': trouble creating work bundle'
- call stop2(999)
- endif
-
-!$omp parallel sections private(istatus,ii,ic,id,istatus_oz,rv_u,rv_v,rv_prse,rv_q,rv_tsen,uland,vland,uwter,vwter)
-
-!$omp section
-
- call gsi_bundlegetpointer (wbundle,'sf' ,cv_sf ,istatus)
- call gsi_bundlegetpointer (wbundle,'vp' ,cv_vp ,istatus)
- call gsi_bundlegetpointer (rval(jj),'u' ,rv_u, istatus)
- call gsi_bundlegetpointer (rval(jj),'v' ,rv_v, istatus)
- call gsi_bundleputvar ( wbundle, 'sf', zero, istatus )
- call gsi_bundleputvar ( wbundle, 'vp', zero, istatus )
-! Convert RHS calculations for u,v to st/vp for application of
-! background error
- if (do_getuv) then
- if (twodvar_regional .and. icsfwter>0 .and. icvpwter>0) then
- call gsi_bundlegetpointer (wbundle,'sfwter', cv_sfwter,istatus)
- call gsi_bundlegetpointer (wbundle,'vpwter', cv_vpwter,istatus)
- allocate(uland(lat2,lon2,nsig),vland(lat2,lon2,nsig), &
- uwter(lat2,lon2,nsig),vwter(lat2,lon2,nsig))
-
- uland=zero ; uwter=zero
- vland=zero ; vwter=zero
-
- call landlake_uvmerge(rv_u,rv_v,uland,vland,uwter,vwter,0)
-
- call getuv(uwter,vwter,cv_sfwter,cv_vpwter,1)
- call getuv(uland,vland,cv_sf,cv_vp,1)
- deallocate(uland,vland,uwter,vwter)
- else
- call getuv(rv_u,rv_v,cv_sf,cv_vp,1)
- endif
- endif
-
- if(jj == 1)then
- do ii=1,nsclen
- grad%predr(ii)=bval%predr(ii)
- enddo
- do ii=1,npclen
- grad%predp(ii)=bval%predp(ii)
- enddo
- if (ntclen>0) then
- do ii=1,ntclen
- grad%predt(ii)=bval%predt(ii)
- enddo
- end if
- end if
-
-!$omp section
-
-! Get pointers to required control variables
- call gsi_bundlegetpointer (wbundle,'ps' ,cv_ps ,istatus)
- call gsi_bundlegetpointer (wbundle,'t' ,cv_t, istatus)
- call gsi_bundlegetpointer (wbundle,'q' ,cv_rh ,istatus)
-
-! Get pointers to this subwin require state variables
- call gsi_bundlegetpointer (rval(jj),'ps' ,rv_ps, istatus)
- call gsi_bundlegetpointer (rval(jj),'prse',rv_prse,istatus)
- call gsi_bundlegetpointer (rval(jj),'tv' ,rv_tv, istatus)
- call gsi_bundlegetpointer (rval(jj),'tsen',rv_tsen,istatus)
- call gsi_bundlegetpointer (rval(jj),'q' ,rv_q , istatus)
-
-! Adjoint of control to initial state
- call gsi_bundleputvar ( wbundle, 't' , rv_tv, istatus )
- call gsi_bundleputvar ( wbundle, 'q' , zero, istatus )
- call gsi_bundleputvar ( wbundle, 'ps', rv_ps, istatus )
-
- if (do_cw_to_hydro_ad .and. .not.do_cw_to_hydro_ad_hwrf) then
-! Case when cloud-vars do not map one-to-one
-! e.g. cw-to-ql&qi
- call cw2hydro_ad(rval(jj),wbundle,clouds,nclouds)
- elseif (do_cw_to_hydro_ad_hwrf) then
-! Case when cloud-vars do not map one-to-one
-! e.g. cw-to-ql&qi&qr&qs&qg&qh
- call cw2hydro_ad_hwrf(rval(jj),wbundle,rv_tsen)
- else
-! Case when cloud-vars map one-to-one, take care of them together
-! e.g. cw-to-cw
- do ic=1,nclouds
- id=getindex(cvars3d,clouds(ic))
- if (id>0) then
- call gsi_bundlegetpointer (rval(jj),clouds(ic),rv_rank3,istatus)
- call gsi_bundleputvar (wbundle, clouds(ic),rv_rank3,istatus)
- endif
- enddo
- end if
-! Calculate sensible temperature
- if(do_tv_to_tsen_ad) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen)
-
-! Adjoint of convert input normalized RH to q to add contribution of moisture
-! to t, p , and normalized rh
- if(do_normal_rh_to_q_ad) call normal_rh_to_q_ad(cv_rh,cv_t,rv_prse,rv_q)
-
-! Adjoint to convert ps to 3-d pressure
- if(do_getprs_ad) call getprs_ad(cv_ps,cv_t,rv_prse)
-
-
-!$omp section
-
- call gsi_bundlegetpointer (rval(jj),'sst' ,rv_sst, istatus)
- call gsi_bundleputvar ( wbundle, 'sst', rv_sst, istatus )
-
-! call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus)
- call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus_oz)
-
- if (icoz>0) then
- call gsi_bundleputvar ( wbundle, 'oz', rv_oz, istatus )
- else
- if(istatus_oz==0) rv_oz=zero
- end if
-
-! Same one-to-one map for chemistry-vars; take care of them together
- if (.not.laeroana_fv3cmaq .and. icvt_cmaq_fv3 == 2) then
- write(6,*) ' icvt_cmaq_fv3 == 2 but laeroana_fv3cmaq=false stop!!!'
- call stop2(999)
- endif
-
- if (icvt_cmaq_fv3 == 2) then
- call amass2aero_ad(rval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3)
- else
- do ic=1,ngases
- id=getindex(cvars3d,gases(ic))
- if (id>0) then
- call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank3,istatus)
- call gsi_bundleputvar (wbundle, gases(ic),rv_rank3,istatus)
- endif
-
- id=getindex(cvars2d,gases(ic))
- if (id>0) then
- call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank2,istatus)
- call gsi_bundleputvar (wbundle, gases(ic),rv_rank2,istatus)
- endif
- enddo
- end if
- if (icgust>0) then
- call gsi_bundlegetpointer (rval(jj),'gust' ,rv_gust, istatus)
- call gsi_bundleputvar ( wbundle, 'gust', rv_gust, istatus )
- end if
- if (icvis >0) then
- call gsi_bundlegetpointer (rval(jj),'vis' ,rv_vis , istatus)
- call gsi_bundleputvar ( wbundle, 'vis' , rv_vis , istatus )
- end if
- if (icpblh>0)then
- call gsi_bundlegetpointer (rval(jj),'pblh' ,rv_pblh, istatus)
- call gsi_bundleputvar ( wbundle, 'pblh', rv_pblh, istatus )
- end if
- if (icwspd10m>0) then
- call gsi_bundlegetpointer (rval(jj),'wspd10m' ,rv_wspd10m, istatus)
- call gsi_bundleputvar ( wbundle, 'wspd10m', rv_wspd10m, istatus )
- end if
- if (ictd2m>0) then
- call gsi_bundlegetpointer (rval(jj),'td2m' ,rv_td2m, istatus)
- call gsi_bundleputvar ( wbundle, 'td2m', rv_td2m, istatus )
- end if
- if (icmxtm>0) then
- call gsi_bundlegetpointer (rval(jj),'mxtm' ,rv_mxtm, istatus)
- call gsi_bundleputvar ( wbundle, 'mxtm', rv_mxtm, istatus )
- end if
- if (icmitm>0) then
- call gsi_bundlegetpointer (rval(jj),'mitm' ,rv_mitm, istatus)
- call gsi_bundleputvar ( wbundle, 'mitm', rv_mitm, istatus )
- end if
- if (icpmsl>0) then
- call gsi_bundlegetpointer (rval(jj),'pmsl' ,rv_pmsl, istatus)
- call gsi_bundleputvar ( wbundle, 'pmsl', rv_pmsl, istatus )
- end if
- if (ichowv>0) then
- call gsi_bundlegetpointer (rval(jj),'howv' ,rv_howv, istatus)
- call gsi_bundleputvar ( wbundle, 'howv', rv_howv, istatus )
- end if
- if (icw>0) then
- call gsi_bundlegetpointer (rval(jj),'w' ,rv_w, istatus)
- call gsi_bundleputvar ( wbundle, 'w', rv_w, istatus )
- if(nems_nmmb_regional)then
- call gsi_bundlegetpointer (rval(jj),'dw' ,rv_dw, istatus)
- call gsi_bundleputvar ( wbundle, 'dw', rv_dw, istatus )
- end if
- end if
- if (ictcamt>0) then
- call gsi_bundlegetpointer (rval(jj),'tcamt',rv_tcamt, istatus)
- call gsi_bundleputvar ( wbundle, 'tcamt', rv_tcamt, istatus )
- end if
- if (iclcbas>0) then
- call gsi_bundlegetpointer (wbundle,'lcbas',cv_lcbas,istatus)
- call gsi_bundlegetpointer (rval(jj),'lcbas',rv_lcbas, istatus)
- call gsi_bundleputvar ( wbundle, 'lcbas', zero, istatus )
- ! Adjoint of convert loglcbas to lcbas
- call loglcbas_to_lcbas_ad(cv_lcbas,rv_lcbas)
- end if
- if (iccldch >0) then
- call gsi_bundlegetpointer (rval(jj),'cldch' ,rv_cldch , istatus)
- call gsi_bundleputvar ( wbundle, 'cldch' , rv_cldch , istatus )
- end if
- if (icuwnd10m>0) then
- call gsi_bundlegetpointer (rval(jj),'uwnd10m' ,rv_uwnd10m, istatus)
- call gsi_bundleputvar ( wbundle, 'uwnd10m', rv_uwnd10m, istatus )
- end if
- if (icvwnd10m>0) then
- call gsi_bundlegetpointer (rval(jj),'vwnd10m' ,rv_vwnd10m, istatus)
- call gsi_bundleputvar ( wbundle, 'vwnd10m', rv_vwnd10m, istatus )
- end if
-
-!$omp end parallel sections
-
-! Adjoint of transfer variables
-
- do ii=1,wbundle%ndim
- grad%step(jj)%values(ii)=wbundle%values(ii)+grad%step(jj)%values(ii)
- enddo
- call gsi_bundledestroy(wbundle,istatus)
- if (istatus/=0) then
- write(6,*) trim(myname),': trouble destroying work bundle'
- call stop2(999)
- endif
-
-end do
-
-! Clean up
-if (ngases>0) deallocate(gases)
-
-if (nclouds>0) deallocate(clouds)
-
-return
-end subroutine control2state_ad
diff --git a/src/gsi/control_vectors.f90 b/src/gsi/control_vectors.f90
index 0847257777..af376995bd 100644
--- a/src/gsi/control_vectors.f90
+++ b/src/gsi/control_vectors.f90
@@ -83,6 +83,7 @@ module control_vectors
use hybrid_ensemble_parameters, only: beta_s0,l_hyb_ens
use hybrid_ensemble_parameters, only: grd_ens
use constants, only : max_varname_length
+use gridmod, only : minmype
use m_rerank, only : rerank
use GSI_BundleMod, only : GSI_BundleCreate
@@ -112,7 +113,7 @@ module control_vectors
public dot_product
public prt_control_norms, axpy, random_cv, setup_control_vectors, &
write_cv, read_cv, inquire_cv, maxval, qdot_prod_sub, init_anacv, &
- final_anacv
+ final_anacv,c2sset_flg,e2sset_flg
!
! Public variables
@@ -157,6 +158,7 @@ module control_vectors
integer(i_kind) :: latlon11,latlon1n,lat2,lon2,nsig,n_ens
integer(i_kind) :: nval_lenz_en
logical,save :: lsqrtb,lcalc_gfdl_cfrac
+logical :: c2sset_flg,e2sset_flg
integer(i_kind) :: m_vec_alloc, max_vec_alloc, m_allocs, m_deallocs
@@ -413,6 +415,8 @@ subroutine init_anacv
write(6,*) myname_,': ALL CONTROL VARIABLES ', nrf_var
end if
lcalc_gfdl_cfrac = .false.
+c2sset_flg = .true. ! set to true in setup. set to false after first (only) call to c2sset
+e2sset_flg = .true. ! set to true in setup. set to false after first (only) call to ensctl2state_set
end subroutine init_anacv
subroutine final_anacv
@@ -889,38 +893,40 @@ real(r_quad) function qdot_prod_sub(xcv,ycv)
end do
endif
else
+ m3d=xcv%step(1)%n3d
+ m2d=xcv%step(1)%n2d
+ itot=max(m3d,0)+max(m2d,0)
+ if(l_hyb_ens)itot=itot+n_ens*naensgrp
+ allocate(partsum(itot))
+ partsum=zero_quad
do ii=1,nsubwin
- m3d=xcv%step(ii)%n3d
- m2d=xcv%step(ii)%n2d
- itot=max(m3d,0)+max(m2d,0)
- if(l_hyb_ens)itot=itot+naensgrp*n_ens
- allocate(partsum(itot))
!$omp parallel do schedule(dynamic,1) private(i)
do i = 1,m3d
- partsum(i) = dplevs(xcv%step(ii)%r3(i)%q,ycv%step(ii)%r3(i)%q,ihalo=1)
+ partsum(i) = partsum(i)+dplevs(xcv%step(ii)%r3(i)%q,ycv%step(ii)%r3(i)%q,ihalo=1)
enddo
!$omp parallel do schedule(dynamic,1) private(i)
do i = 1,m2d
- partsum(m3d+i) = dplevs(xcv%step(ii)%r2(i)%q,ycv%step(ii)%r2(i)%q,ihalo=1)
+ partsum(m3d+i) = partsum(m3d+i)+dplevs(xcv%step(ii)%r2(i)%q,ycv%step(ii)%r2(i)%q,ihalo=1)
enddo
if(l_hyb_ens) then
do ig=1,naensgrp
nigtmp=n_ens*(ig-1)
!$omp parallel do schedule(dynamic,1) private(i)
do i = 1,n_ens
- partsum(m3d+m2d+nigtmp+i) = dplevs(xcv%aens(ii,ig,i)%r3(1)%q,ycv%aens(ii,ig,i)%r3(1)%q,ihalo=1)
+ partsum(m3d+m2d+nigtmp+i) = partsum(m3d+m2d+nigtmp+i) + &
+ dplevs(xcv%aens(ii,ig,i)%r3(1)%q,ycv%aens(ii,ig,i)%r3(1)%q,ihalo=1)
end do
end do
end if
do i=1,itot
qdot_prod_sub = qdot_prod_sub + partsum(i)
end do
- deallocate(partsum)
end do
+ deallocate(partsum)
end if
! Duplicated part of vector
- if(mype == 0)then
+ if(mype == minmype)then
do j=nclen1+1,nclen
qdot_prod_sub=qdot_prod_sub+xcv%values(j)*ycv%values(j)
end do
@@ -966,37 +972,35 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb)
character(len=*) , intent(in ) :: eb
real(r_quad) , intent( out) :: prods(nsubwin+1)
- real(r_quad) :: zz(nsubwin)
integer(i_kind) :: ii,i,nn,m3d,m2d
real(r_quad),allocatable,dimension(:) :: partsum
integer(i_kind) :: ig
integer(i_kind) ::ngtmp,nn0
prods(:)=zero_quad
- zz(:)=zero_quad
! Independent part of vector
if (lsqrtb) then
if(trim(eb) == 'cost_b') then
do ii=1,nsubwin
- zz(ii)=zz(ii)+qdot_product( xcv%step(ii)%values(:) ,ycv%step(ii)%values(:) )
+ prods(ii)=prods(ii)+qdot_product( xcv%step(ii)%values(:) ,ycv%step(ii)%values(:) )
end do
endif
if(trim(eb) == 'cost_e') then
do ig=1,naensgrp
do nn=1,n_ens
do ii=1,nsubwin
- zz(ii)=zz(ii)+qdot_product( xcv%aens(ii,ig,nn)%values(:) ,ycv%aens(ii,ig,nn)%values(:) )
+ prods(ii)=prods(ii)+qdot_product( xcv%aens(ii,ig,nn)%values(:) ,ycv%aens(ii,ig,nn)%values(:) )
end do
end do
end do
endif
else
if(trim(eb) == 'cost_b') then
+ m3d=xcv%step(1)%n3d
+ m2d=xcv%step(1)%n2d
+ allocate(partsum(m2d+m3d))
do ii=1,nsubwin
- m3d=xcv%step(ii)%n3d
- m2d=xcv%step(ii)%n2d
- allocate(partsum(m2d+m3d))
!$omp parallel do schedule(dynamic,1) private(i)
do i = 1,m3d
partsum(i)= dplevs(xcv%step(ii)%r3(i)%q,ycv%step(ii)%r3(i)%q,ihalo=1)
@@ -1006,17 +1010,17 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb)
partsum(m3d+i)= dplevs(xcv%step(ii)%r2(i)%q,ycv%step(ii)%r2(i)%q,ihalo=1)
enddo
do i = 1,m2d+m3d
- zz(ii)=zz(ii) + partsum(i)
+ prods(ii)=prods(ii) + partsum(i)
end do
- deallocate(partsum)
end do
+ deallocate(partsum)
end if
if(trim(eb) == 'cost_e') then
- do ii=1,nsubwin ! RTod: somebody could work in opt/zing this ...
- allocate(partsum(n_ens*naensgrp))
+ allocate(partsum(n_ens*naensgrp))
+ do ii=1,nsubwin
+!$omp parallel do schedule(dynamic,1) private(nn,m3d,m2d,ig,ngtmp,nn0)
do ig=1,naensgrp
ngtmp=(ig-1)*n_ens
-!$omp parallel do schedule(dynamic,1) private(nn,m3d,m2d)
do nn=1,n_ens
nn0=nn+ngtmp
partsum(nn0) = zero_quad
@@ -1031,20 +1035,17 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb)
enddo
end do
do nn=1,n_ens*naensgrp
- zz(ii)=zz(ii)+partsum(nn)
+ prods(ii)=prods(ii)+partsum(nn)
end do
- deallocate(partsum)
end do
+ deallocate(partsum)
end if
end if
- call mpl_allreduce(nsubwin,qpvals=zz)
- prods(1:nsubwin) = zz(1:nsubwin)
-
! Duplicated part of vector
- if(trim(eb) == 'cost_b') then
+ if(mype == minmype .and. trim(eb) == 'cost_b' ) then
if (nsclen>0) then
- prods(nsubwin+1) = prods(nsubwin+1) + qdot_product(xcv%predr(:),ycv%predr(:))
+ prods(nsubwin+1) = qdot_product(xcv%predr(:),ycv%predr(:))
endif
if (npclen>0) then
prods(nsubwin+1) = prods(nsubwin+1) + qdot_product(xcv%predp(:),ycv%predp(:))
@@ -1054,6 +1055,9 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb)
endif
end if
+ call mpl_allreduce(nsubwin+1,qpvals=prods)
+
+
return
end subroutine qdot_prod_vars_eb
! ----------------------------------------------------------------------
@@ -1226,7 +1230,7 @@ subroutine prt_norms(xcv,sgrep)
zt=sqrt(zt)
if (mype==0) then
- write(6,*)sgrep,' global norm =',real(zt,r_kind)
+ write(6,*)sgrep,' global norm =',zt
endif
!_RT call prt_norms_vars(xcv,sgrep) --->> this routine is hanging
diff --git a/src/gsi/convthin.f90 b/src/gsi/convthin.f90
index cc6d2ed1b5..edac1adbcf 100644
--- a/src/gsi/convthin.f90
+++ b/src/gsi/convthin.f90
@@ -12,7 +12,6 @@ module convthin
!
! subroutines included:
! make3grids
-! map3grids
! map3grids_m ! keep thinned data
! del3grids
!
@@ -31,23 +30,24 @@ module convthin
private
! set subroutines to public
public :: make3grids
- public :: map3grids
public :: map3grids_m
public :: del3grids
! set passed variables to public
public :: use_all
- integer(i_kind):: mlat
+ integer(i_kind):: mlat,itxmax,nlevp
integer(i_kind),allocatable,dimension(:):: mlon
- integer(i_kind),allocatable,dimension(:,:):: icount,icount_fore,icount_aft,ibest_obs,ibest_save
+ logical ,allocatable,dimension(:,:):: icount,icount_fore,icount_aft
+ integer(i_kind),allocatable,dimension(:,:):: ibest_obs,ibest_obs_aft,ibest_obs_fore
real(r_kind),allocatable,dimension(:):: glat
real(r_kind),allocatable,dimension(:,:):: glon,hll,score_crit,score_crit_fore,score_crit_aft
logical use_all
+ logical setfore, setaft, setnormal
contains
- subroutine make3grids(rmesh,nlevp)
+ subroutine make3grids(rmesh,nlevpp)
!$$$ subprogram documentation block
! . . . .
! subprogram: make3grids
@@ -69,7 +69,7 @@ subroutine make3grids(rmesh,nlevp)
! rmesh - mesh size (km) of thinning grid. If (rmesh <= one),
! then no thinning of the data will occur. Instead,
! all data will be used without thinning.
-! nlevp - vertical levels
+! nlevpp - vertical levels
!
! attributes:
! language: f90
@@ -82,12 +82,12 @@ subroutine make3grids(rmesh,nlevp)
implicit none
real(r_kind) ,intent(in ) :: rmesh
- integer(i_kind),intent(in ) :: nlevp
+ integer(i_kind),intent(in ) :: nlevpp
real(r_kind),parameter:: r360 = 360.0_r_kind
integer(i_kind) i,j
- integer(i_kind) mlonx,mlonj,itxmax
+ integer(i_kind) mlonx,mlonj
real(r_kind) dgv,halfpi,dx,dy
real(r_kind) twopi
@@ -95,6 +95,7 @@ subroutine make3grids(rmesh,nlevp)
real(r_kind) rkm2dg,glatm
real(r_quad) delat
+ nlevp=nlevpp
! If there is to be no thinning, simply return to calling routine
use_all=.false.
if(abs(rmesh) <= one)then
@@ -132,7 +133,7 @@ subroutine make3grids(rmesh,nlevp)
factor = abs(cos(abs(glatm)))
if (rmesh>zero) then
- mlonj = nint(mlonx*factor)
+ mlonj = nint(mlonx*factor)
mlon(j) = max(2,mlonj)
delon = dlon_grid/mlon(j)
else
@@ -155,257 +156,108 @@ subroutine make3grids(rmesh,nlevp)
enddo
end do
+ setnormal=.false.
+ setfore=.false.
+ setaft=.false.
-! Allocate and initialize arrays
+ return
+ end subroutine make3grids
+ subroutine createnormal
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: createnormal
+! prgmmr: derber org: np23 date: 2023-10-20
+!
+! abstract: This routine creates and initializes arrays for normal thinning
+!
+! program history log:
+! 2023-10-20 derber
+!
+! attributes:
+! language: f90
+! machine: ibm rs/6000 sp
+!
+!$$$
+ integer i,j
allocate(icount(itxmax,nlevp))
- allocate(icount_fore(itxmax,nlevp))
- allocate(icount_aft(itxmax,nlevp))
allocate(ibest_obs(itxmax,nlevp))
- allocate(ibest_save(itxmax,nlevp))
allocate(score_crit(itxmax,nlevp))
- allocate(score_crit_fore(itxmax,nlevp))
- allocate(score_crit_aft(itxmax,nlevp))
do j=1,nlevp
do i=1,itxmax
- icount(i,j) = 0
- icount_fore(i,j) = 0
- icount_aft(i,j) = 0
+ icount(i,j) = .false.
ibest_obs(i,j)= 0
- ibest_save(i,j)= 0
score_crit(i,j)= 9.99e6_r_kind
- score_crit_fore(i,j) = 9.99e6_r_kind
- score_crit_aft(i,j) = 9.99e6_r_kind
end do
end do
-
+ setnormal=.true.
return
- end subroutine make3grids
-
- subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs,&
- iobsout,iin,iiout,iuse,foreswp,aftswp)
-
+ end subroutine createnormal
+ subroutine createfore
!$$$ subprogram documentation block
! . . . .
-! subprogram: map3grids
-! prgmmr: treadon org: np23 date: 2002-10-17
+! subprogram: createfore
+! prgmmr: derber org: np23 date: 2023-10-20
!
-! abstract: This routine maps convential observations to a 3d thinning grid.
+! abstract: This routine creates and initializes arrays for fore thinning
!
! program history log:
-! 2002-10-17 treadon
-! 2004-06-22 treadon - update documentation
-! 2004-07-23 derber - modify code to thin obs as read in
-! 2004-12-08 li, xu - fix bug --> set iuse=.true. when use_all=.true.
-! 2005-10-14 treadon - variable name change (dlat0,dlon0) --> d*_earth
-! 2006-01-25 kistler - extend 2d to 3d
-! 2008-06-04 safford - rm unused vars
-! 2010-08-23 tong - add flg as an input argument of map3grids, so that the order of values
-! of the vertical cooridnate can either increase or decrease
-! 2012-05-25 li, wang - add TDR fore/aft sweep separation for thinning,xuguang.wang@ou.edu
-! 2013-01-23 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS)
+! 2023-10-20 derber
!
-! input argument list:
-! flg - marks order of values in vertical dirction (1=increasing, -1=decreasing)
-! pflag - type of pressure-type levels; 0 : sigma level, 1 : determined by convinfo file
-! pcoord - veritical coordinate values
-! nlevp - number of vertical levels
-! dlat_earth - earth relative observation latitude (radians)
-! dlon_earth - earth relative observation longitude (radians)
-! pob - observation pressure ob
-! crit1 - quality indicator for observation (smaller = better)
-! iin - counter of input data
-! foreswp - if true, TDR scan is fore
-! aftswp - if true, TDR scan is aft
+! attributes:
+! language: f90
+! machine: ibm rs/6000 sp
!
-! output argument list:
-! iobs - observation counter
-! iobsout- location for observation to be put
-! iuse - .true. if observation should be used
-! iiout - counter of data replaced
-!
+!$$$
+ integer i,j
+ allocate(icount_fore(itxmax,nlevp))
+ allocate(ibest_obs_fore(itxmax,nlevp))
+ allocate(score_crit_fore(itxmax,nlevp))
+
+ do j=1,nlevp
+ do i=1,itxmax
+ icount_fore(i,j) = .false.
+ ibest_obs_fore(i,j)= 0
+ score_crit_fore(i,j)= 9.99e6_r_kind
+ end do
+ end do
+ setfore=.true.
+ return
+ end subroutine createfore
+ subroutine createaft
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: createaft
+! prgmmr: derber org: np23 date: 2023-10-20
+!
+! abstract: This routine creates and initializes arrays for aft thinning
+!
+! program history log:
+! 2023-10-20 derber
!
! attributes:
! language: f90
! machine: ibm rs/6000 sp
!
!$$$
- use constants, only: one, half,two,three
- implicit none
-
- logical ,intent( out) :: iuse
- integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,iin
- integer(i_kind) ,intent(inout) :: iobs
- integer(i_kind) ,intent( out) :: iobsout,iiout
- real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob
- real(r_kind),dimension(nlevp),intent(in ) :: pcoord
-
- integer(i_kind):: ip,itx
- integer(i_kind) ix,iy
-
- real(r_kind) dlat1,dlon1,pob1
- real(r_kind) dx,dy,dp,dxx,dyy,dpp
- real(r_kind) crit!,dist1
-
- logical foreswp, aftswp
-
- iiout = 0
-
-! If using all data (no thinning), simply return to calling routine
- if(use_all)then
- iuse=.true.
- iobs=iobs+1
- iobsout=iobs
- return
- end if
-
-! Compute (i,j,k) indices of coarse mesh grid (grid number 1) which
-! contains the current observation.
- dlat1=dlat_earth
- dlon1=dlon_earth
- pob1=pob
-
- call grdcrd1(pob1,pcoord,nlevp,flg)
- ip=int(pob1)
- dp=pob1-ip
- ip=max(1,min(ip,nlevp))
-
- call grdcrd1(dlat1,glat,mlat,1)
- iy=int(dlat1)
- dy=dlat1-iy
- iy=max(1,min(iy,mlat))
-
- call grdcrd1(dlon1,glon(1,iy),mlon(iy),1)
- ix=int(dlon1)
- dx=dlon1-ix
- ix=max(1,min(ix,mlon(iy)))
-
- dxx=half-min(dx,one-dx)
- dyy=half-min(dy,one-dy)
- if( pflag == 1) then
- dpp=half-min(dp,one-dp)
- else
- dpp=min(dp,one-dp)
- endif
-
- itx=hll(ix,iy)
-
-! Compute distance metric (smaller is closer to center of cube)
-! dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half
-
-
-! Examine various cases regarding what to do with current obs.
-! Start by assuming observation will be selected.
- iuse=.true.
-
-! Determine "score" for observation. Lower score is better.
-! crit = crit1*dist1
- crit = crit1
-
-
-! TDR fore (Pseudo-dual-Doppler-radars)
-
- if(foreswp) then ! fore sweeps
-
-! Case(1): first obs at this location, keep this obs as starting point
- if (icount_fore(itx,ip)==0) then
- iobs=iobs+1
- iobsout=iobs
- score_crit_fore(itx,ip)= crit
- icount_fore(itx,ip)=icount_fore(itx,ip)+1
- ibest_obs(itx,ip) = iobs
- ibest_save(itx,ip) = iin
-
-! Case(2): obs score < best value at this location,
-! --> update score, count, and best obs counters
- elseif (icount_fore(itx,ip) > 0 .and. crit < score_crit_fore(itx,ip)) then
- score_crit_fore(itx,ip)= crit
- icount_fore(itx,ip)=icount_fore(itx,ip)+1
- iobsout=ibest_obs(itx,ip)
- iiout = ibest_save(itx,ip)
- ibest_save(itx,ip)=iin
-
-! Case(3): obs score > best value at this location,
-! --> do not use this obs, return to calling program.
- elseif (icount_fore(itx,ip) > 0 .and. crit > score_crit_fore(itx,ip)) then
- iuse=.false.
-
-! Case(4): none of the above cases are satisified, don't use this obs
- else
- iuse = .false.
- endif ! cases
-
-! TDR aft (Pseudo-dual-Doppler-radars)
- else if(aftswp) then ! aft sweeps
-
-! Case(1): first obs at this location, keep this obs as starting point
- if (icount_aft(itx,ip)==0) then
- iobs=iobs+1
- iobsout=iobs
- score_crit_aft(itx,ip)= crit
- icount_aft(itx,ip)=icount_aft(itx,ip)+1
- ibest_obs(itx,ip) = iobs
- ibest_save(itx,ip) = iin
-
-
-! Case(2): obs score < best value at this location,
-! --> update score, count, and best obs counters
- elseif (icount_aft(itx,ip) > 0 .and. crit < score_crit_aft(itx,ip)) then
- score_crit_aft(itx,ip)= crit
- icount_aft(itx,ip)=icount_aft(itx,ip)+1
- iobsout=ibest_obs(itx,ip)
- iiout = ibest_save(itx,ip)
- ibest_save(itx,ip)=iin
-
-! Case(3): obs score > best value at this location,
-! --> do not use this obs, return to calling program.
- elseif(icount_aft(itx,ip) > 0 .and. crit > score_crit_aft(itx,ip)) then
- iuse=.false.
-
-! Case(4): none of the above cases are satisified,
-! --> don't use this obs
- else
- iuse = .false.
- endif ! cases
-
- else
-! Case: obs score > best value at this location,
-! --> do not use this obs, return to calling program.
- if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then
- iuse=.false.
-
-! Case: obs score < best value at this location,
-! --> update score, count, and best obs counters
- elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then
- score_crit(itx,ip)= crit
- iobsout=ibest_obs(itx,ip)
- icount(itx,ip)=icount(itx,ip)+1
- iiout = ibest_save(itx,ip)
- ibest_save(itx,ip)=iin
-
-! Case: first obs at this location,
-! --> keep this obs as starting point
- elseif (icount(itx,ip)==0) then
- iobs=iobs+1
- iobsout=iobs
- score_crit(itx,ip)= crit
- ibest_obs(itx,ip) = iobs
- icount(itx,ip)=icount(itx,ip)+1
- ibest_save(itx,ip) = iin
-
-! Case: none of the above cases are satisified,
-! --> don't use this obs
- else
- iuse = .false.
- end if
- end if
- return
-
+ integer i,j
+ allocate(icount_aft(itxmax,nlevp))
+ allocate(ibest_obs_aft(itxmax,nlevp))
+ allocate(score_crit_aft(itxmax,nlevp))
- end subroutine map3grids
+ do j=1,nlevp
+ do i=1,itxmax
+ icount_aft(i,j) = .false.
+ ibest_obs_aft(i,j)= 0
+ score_crit_aft(i,j)= 9.99e6_r_kind
+ end do
+ end do
+ setaft=.true.
+ return
+ end subroutine createaft
- subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs,&
- iobsout,iin,iiout,iuse,maxobs,usage,rusage,foreswp,aftswp)
+ subroutine map3grids_m(flg,save_all,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs,&
+ iuse,maxobs,rthin,foreswp,aftswp)
!$$$ subprogram documentation block
! . . . .
@@ -434,9 +286,11 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io
!
! input argument list:
! flg - marks order of values in vertical dirction (1=increasing,
-! -1=decreasing)
+! -1=decreasing)
+! save_all - logical - if true save all obs. (if false some unused values
+! still get through)
! pflag - type of pressure-type levels; 0 : sigma level, 1 : determined by
-! convinfo file
+! convinfo file
! pcoord - veritical coordinate values
! nlevp - number of vertical levels
! dlat_earth - earth relative observation latitude (radians)
@@ -444,15 +298,12 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io
! pob - observation pressure ob
! crit1 - quality indicator for observation (smaller = better)
! ithin - number of obs to retain per thinning grid box
-! iin - counter of input data
! foreswp - if true, TDR scan is fore
! aftswp - if true, TDR scan is aft
!
! output argument list:
! iobs - observation counter
-! iobsout- location for observation to be put
! iuse - .true. if observation should be used
-! iiout - counter of data replaced
! attributes:
! language: f90
! machine: ibm rs/6000 sp
@@ -462,30 +313,27 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io
implicit none
logical ,intent( out) :: iuse
- integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,iin,maxobs
+ logical ,intent(in ) :: save_all
+ integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,maxobs
integer(i_kind) ,intent(inout) :: iobs
- integer(i_kind) ,intent( out) :: iobsout,iiout
- real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob,usage
+ real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob
real(r_kind),dimension(nlevp),intent(in ) :: pcoord
- real(r_kind),dimension(maxobs),intent(inout ) :: rusage
+ logical,dimension(maxobs), intent(inout) :: rthin
integer(i_kind):: ip,itx
- integer(i_kind) ix,iy
+ integer(i_kind) ix,iy,itmp
real(r_kind) dlat1,dlon1,pob1
- real(r_kind) dx,dy,dp,dxx,dyy,dpp
- real(r_kind) crit!,dist1
+ real(r_kind) dx,dy,dp
+ real(r_kind) crit !,dist1
logical foreswp, aftswp
- iiout = 0
+ iuse=.true.
! If using all data (no thinning), simply return to calling routine
if(use_all)then
- iuse=.true.
iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=usage
return
end if
@@ -510,13 +358,13 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io
dx=dlon1-ix
ix=max(1,min(ix,mlon(iy)))
- dxx=half-min(dx,one-dx)
- dyy=half-min(dy,one-dy)
- if( pflag == 1) then
- dpp=half-min(dp,one-dp)
- else
- dpp=min(dp,one-dp)
- endif
+! dxx=half-min(dx,one-dx)
+! dyy=half-min(dy,one-dy)
+! if( pflag == 1) then
+! dpp=half-min(dp,one-dp)
+! else
+! dpp=min(dp,one-dp)
+! endif
itx=hll(ix,iy)
@@ -526,7 +374,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io
! Examine various cases regarding what to do with current obs.
! Start by assuming observation will be selected.
- iuse=.true.
! Determine "score" for observation. Lower score is better.
! crit = crit1*dist1
@@ -534,127 +381,95 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io
! TDR fore/aft (Pseudo-dual-Doppler-radars)
if(foreswp) then ! fore sweeps
+ if(.not. setfore)call createfore
! Case(1): first obs at this location, keep this obs as starting point
- if (icount_fore(itx,ip)==0) then
+ if (.not. icount_fore(itx,ip)) then
iobs=iobs+1
- iobsout=iobs
score_crit_fore(itx,ip)= crit
- icount_fore(itx,ip)=icount_fore(itx,ip)+1
- ibest_obs(itx,ip) = iobs
- rusage(iobs)=usage
- ibest_save(itx,ip)=iin
+ icount_fore(itx,ip)=.true.
+ ibest_obs_fore(itx,ip) = iobs
! Case(2): obs score < best value at this location,
! --> update score, count, and best obs counters
- elseif (icount_fore(itx,ip) > 0 .and. crit < score_crit_fore(itx,ip)) then
+ elseif (icount_fore(itx,ip) .and. crit < score_crit_fore(itx,ip)) then
iobs=iobs+1
- iobsout=iobs
- score_crit(itx,ip)= crit
-! iobsout=ibest_obs(itx,ip)
- icount(itx,ip)=icount(itx,ip)+1
- iiout = ibest_save(itx,ip)
- rusage(iiout)=101.0_r_kind
- rusage(iobs)=usage
- ibest_save(itx,ip)=iobs
+ itmp=ibest_obs_fore(itx,ip)
+ rthin(itmp)=.true.
+ score_crit_fore(itx,ip)= crit
+ ibest_obs_fore(itx,ip)=iobs
! Case(3): obs score > best value at this location,
! --> do not use this obs, return to calling program.
- elseif (icount_fore(itx,ip) > 0 .and. crit > score_crit_fore(itx,ip)) then
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.1_r_kind
- iuse=.false.
-
-! Case(4): none of the above cases are satisified, don't use this obs
else
- iuse = .false.
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.1_r_kind
+ if(save_all)then
+ iobs=iobs+1
+ rthin(iobs)=.true.
+ else
+ iuse=.false.
+ end if
endif ! cases
else if(aftswp) then ! aft sweeps
+ if(.not. setaft)call createaft
! Case(1): first obs at this location, keep this obs as starting point
- if (icount_aft(itx,ip)==0) then
+ if (.not. icount_aft(itx,ip)) then
iobs=iobs+1
- iobsout=iobs
score_crit_aft(itx,ip)= crit
- icount_aft(itx,ip)=icount_aft(itx,ip)+1
- ibest_obs(itx,ip) = iobs
- ibest_save(itx,ip) = iin
+ icount_aft(itx,ip)=.true.
+ ibest_obs_aft(itx,ip) = iobs
! Case(2): obs score < best value at this location,
! --> update score, count, and best obs counters
- elseif (icount_aft(itx,ip) > 0 .and. crit < score_crit_aft(itx,ip)) then
+ elseif (icount_aft(itx,ip) .and. crit < score_crit_aft(itx,ip)) then
iobs=iobs+1
- iobsout=iobs
+ itmp=ibest_obs_aft(itx,ip)
+ rthin(itmp)=.true.
score_crit_aft(itx,ip)= crit
- icount_aft(itx,ip)=icount_aft(itx,ip)+1
- iobsout=ibest_obs(itx,ip)
- iiout = ibest_save(itx,ip)
- ibest_save(itx,ip)=iobs
- rusage(iobs)=usage
+ ibest_obs_aft(itx,ip)=iobs
! Case(3): obs score > best value at this location,
! --> do not use this obs, return to calling program.
- elseif(icount_aft(itx,ip) > 0 .and. crit > score_crit_aft(itx,ip)) then
- iuse=.false.
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.1_r_kind
-
-! Case(4): none of the above cases are satisified,
-! --> don't use this obs
else
- iuse = .false.
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.1_r_kind
+ if(save_all)then
+ iobs=iobs+1
+ rthin(iobs)=.true.
+ else
+ iuse=.false.
+ end if
endif ! cases
else
-! Case: obs score > best value at this location,
-! --> do not use this obs, return to calling program.
- if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then
- iuse=.false.
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.0_r_kind
+ if(.not. setnormal)call createnormal
! Case: obs score < best value at this location,
! --> update score, count, and best obs counters
- elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then
+ if (icount(itx,ip) .and. crit < score_crit(itx,ip)) then
iobs=iobs+1
- iobsout=iobs
+ itmp=ibest_obs(itx,ip)
+ rthin(itmp)=.true.
score_crit(itx,ip)= crit
- icount(itx,ip)=icount(itx,ip)+1
- iiout = ibest_obs(itx,ip)
- ibest_save(itx,ip)=iin
ibest_obs(itx,ip)=iobs
- rusage(iiout)=101.0_r_kind
- rusage(iobs)=usage
! Case: first obs at this location,
! --> keep this obs as starting point
- elseif (icount(itx,ip)==0) then
+ elseif (.not. icount(itx,ip)) then
iobs=iobs+1
- iobsout=iobs
score_crit(itx,ip)= crit
- ibest_obs(itx,ip) = iobs
- icount(itx,ip)=icount(itx,ip)+1
- ibest_save(itx,ip) = iin
- rusage(iobs)=usage
+ ibest_obs(itx,ip)=iobs
+ icount(itx,ip)=.true.
-! Case: none of the above cases are satisified,
-! --> don't use this obs
+! Case: obs score > best value at this location,
+! --> do not use this obs, return to calling program.
else
- iuse = .false.
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.0_r_kind
+ if(save_all)then
+ iobs=iobs+1
+ rthin(iobs)=.true.
+ else
+ iuse=.false.
+ end if
end if
end if
return
@@ -662,8 +477,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io
end subroutine map3grids_m
-
-
subroutine del3grids
!$$$ subprogram documentation block
! . . . .
@@ -689,14 +502,24 @@ subroutine del3grids
if (.not.use_all) then
deallocate(mlon,glat,glon,hll)
- deallocate(icount)
- deallocate(icount_fore)
- deallocate(icount_aft)
- deallocate(ibest_obs)
- deallocate(ibest_save)
- deallocate(score_crit)
- deallocate(score_crit_fore)
- deallocate(score_crit_aft)
+ if(setnormal)then
+ deallocate(icount)
+ deallocate(ibest_obs)
+ deallocate(score_crit)
+ setnormal=.false.
+ end if
+ if(setfore)then
+ deallocate(icount_fore)
+ deallocate(score_crit_fore)
+ deallocate(ibest_obs_fore)
+ setfore=.false.
+ end if
+ if(setaft)then
+ deallocate(icount_aft)
+ deallocate(ibest_obs_aft)
+ deallocate(score_crit_aft)
+ setaft=.false.
+ end if
endif
end subroutine del3grids
diff --git a/src/gsi/convthin_time.f90 b/src/gsi/convthin_time.f90
index 36ab178393..ae2a7bb6c3 100644
--- a/src/gsi/convthin_time.f90
+++ b/src/gsi/convthin_time.f90
@@ -8,7 +8,6 @@ module convthin_time
!
! subroutines included:
! make3grids_tm
-! map3grids_tm
! map3grids_m_tm
! del3grids_tm
!
@@ -27,24 +26,25 @@ module convthin_time
private
! set subroutines to public
public :: make3grids_tm
- public :: map3grids_tm
public :: map3grids_m_tm
public :: del3grids_tm
! set passed variables to public
public :: use_all_tm
- integer(i_kind):: mlat
+ integer(i_kind):: mlat,nlevp,ntm,itxmax
integer(i_kind),allocatable,dimension(:):: mlon
- integer(i_kind),allocatable,dimension(:,:,:):: icount_tm,icount_fore_tm,icount_aft_tm,ibest_obs_tm,ibest_save_tm
+ logical ,allocatable,dimension(:,:,:):: icount_tm,icount_fore_tm,icount_aft_tm
+ integer(i_kind),allocatable,dimension(:,:,:):: ibest_obs_tm,ibest_obs_aft_tm,ibest_obs_fore_tm
real(r_kind),allocatable,dimension(:):: glat
real(r_kind),allocatable,dimension(:,:):: glon,hll
real(r_kind),allocatable,dimension(:,:,:):: score_crit_tm,score_crit_fore_tm,score_crit_aft_tm
logical use_all_tm
+ logical setfore,setaft,setnormal
contains
- subroutine make3grids_tm(rmesh,nlevp,ntm)
+ subroutine make3grids_tm(rmesh,nlevpp,ntmm)
!$$$ subprogram documentation block
! . . . .
! subprogram: make3grids_tm
@@ -59,8 +59,8 @@ subroutine make3grids_tm(rmesh,nlevp,ntm)
! rmesh - mesh size (km) of thinning grid. If (rmesh <= one),
! then no thinning of the data will occur. Instead,
! all data will be used without thinning.
-! nlevp - vertical levels
-! ntm - tm dimension relative to analysis tm
+! nlevpp - vertical levels
+! ntmm - tm dimension relative to analysis tm
!
! attributes:
! language: f90
@@ -73,13 +73,13 @@ subroutine make3grids_tm(rmesh,nlevp,ntm)
implicit none
real(r_kind) ,intent(in ) :: rmesh
- integer(i_kind),intent(in ) :: nlevp
- integer(i_kind),intent(in ) :: ntm
+ integer(i_kind),intent(in ) :: nlevpp
+ integer(i_kind),intent(in ) :: ntmm
real(r_kind),parameter:: r360 = 360.0_r_kind
- integer(i_kind) i,j,it
- integer(i_kind) mlonx,mlonj,itxmax
+ integer(i_kind) i,j
+ integer(i_kind) mlonx,mlonj
real(r_kind) delonx,delat,dgv,halfpi,dx,dy
real(r_kind) twopi
@@ -95,6 +95,8 @@ subroutine make3grids_tm(rmesh,nlevp,ntm)
end if
! Set constants
+ ntm=ntmm
+ nlevp=nlevpp
halfpi = half*pi
twopi = two*pi
rkm2dg = r360/(twopi*rearth_equator)*1.e3_r_kind
@@ -124,7 +126,7 @@ subroutine make3grids_tm(rmesh,nlevp,ntm)
factor = abs(cos(abs(glatm)))
if (rmesh>zero) then
- mlonj = nint(mlonx*factor)
+ mlonj = nint(mlonx*factor)
mlon(j) = max(2,mlonj)
delon = dlon_grid/mlon(j)
else
@@ -145,246 +147,114 @@ subroutine make3grids_tm(rmesh,nlevp,ntm)
end do
! Allocate and initialize arrays
+ setnormal=.false.
+ setfore=.false.
+ setaft=.false.
+
+ return
+ end subroutine make3grids_tm
+ subroutine createnormal_tm
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: createnormal
+! prgmmr: derber org: np23 date: 2023-10-20
+!
+! abstract: This routine creates and initializes arrays for normal thinning
+!
+! program history log:
+! 2023-10-20 derber
+!
+! attributes:
+! language: f90
+! machine: ibm rs/6000 sp
+!
+!$$$
+ integer i,j,it
allocate(icount_tm(itxmax,nlevp,ntm))
- allocate(icount_fore_tm(itxmax,nlevp,ntm))
- allocate(icount_aft_tm(itxmax,nlevp,ntm))
allocate(ibest_obs_tm(itxmax,nlevp,ntm))
- allocate(ibest_save_tm(itxmax,nlevp,ntm))
allocate(score_crit_tm(itxmax,nlevp,ntm))
- allocate(score_crit_fore_tm(itxmax,nlevp,ntm))
- allocate(score_crit_aft_tm(itxmax,nlevp,ntm))
do j=1,nlevp
do i=1,itxmax
do it=1,ntm
- icount_tm(i,j,it) = 0
- icount_fore_tm(i,j,it) = 0
- icount_aft_tm(i,j,it) = 0
+ icount_tm(i,j,it) = .false.
ibest_obs_tm(i,j,it)= 0
- ibest_save_tm(i,j,it)= 0
score_crit_tm(i,j,it)= 9.99e6_r_kind
- score_crit_fore_tm(i,j,it)= 9.99e6_r_kind
- score_crit_aft_tm(i,j,it)= 9.99e6_r_kind
end do
end do
end do
-
+ setnormal=.true.
return
- end subroutine make3grids_tm
-
- subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,&
- pob,itm,crit1,iobs,iobsout,iin,iiout,iuse,foreswp,aftswp)
-
+ end subroutine createnormal_tm
+ subroutine createfore_tm
!$$$ subprogram documentation block
! . . . .
-! subprogram: map3grids_tm
-! prgmmr: Su org: np23 date: 2013-11-20
+! subprogram: createfore_tm
+! prgmmr: derber org: np23 date: 2023-10-20
!
-! abstract: This routine maps convential observations to a 3d thinning grid.
+! abstract: This routine creates and initializes arrays for fore thinning
!
! program history log:
+! 2023-10-20 derber
!
-! input argument list:
-! flg - marks order of values in vertical dirction (1=increasing, -1=decreasing)
-! pflag - type of pressure-type levels; 0 : sigma level, 1 : determined by convinfo file
-! pcoord - veritical coordinate values
-! nlevp - number of vertical levels
-! dlat_earth - earth relative observation latitude (radians)
-! dlon_earth - earth relative observation longitude (radians)
-! pob - observation pressure ob
-! crit1 - quality indicator for observation (smaller = better)
-! ithin - number of obs to retain per thinning grid box
-! iin - counter of input data
-! itm - tm count
+! attributes:
+! language: f90
+! machine: ibm rs/6000 sp
!
-! output argument list:
-! iobs - observation counter
-! itx - combined (i,j) index of observation on thinning grid
-! iobsout- location for observation to be put
-! ip - vertical index
-! iuse - .true. if observation should be used
-! iiout - counter of data replaced
-!
+!$$$
+ integer i,j,it
+ allocate(icount_fore_tm(itxmax,nlevp,ntm))
+ allocate(ibest_obs_fore_tm(itxmax,nlevp,ntm))
+ allocate(score_crit_fore_tm(itxmax,nlevp,ntm))
+
+ do j=1,nlevp
+ do i=1,itxmax
+ do it=1,ntm
+ icount_fore_tm(i,j,it) = .false.
+ ibest_obs_fore_tm(i,j,it)= 0
+ score_crit_fore_tm(i,j,it)= 9.99e6_r_kind
+ end do
+ end do
+ end do
+ setfore=.true.
+ return
+ end subroutine createfore_tm
+ subroutine createaft_tm
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: createaft
+! prgmmr: derber org: np23 date: 2023-10-20
+!
+! abstract: This routine creates and initializes arrays for aft thinning
+!
+! program history log:
+! 2023-10-20 derber
!
! attributes:
! language: f90
! machine: ibm rs/6000 sp
!
!$$$
- use constants, only: one, half,two,three
- implicit none
-
- logical ,intent( out) :: iuse
- integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,iin,itm
- integer(i_kind) ,intent(inout) :: iobs
- integer(i_kind) ,intent( out) :: iobsout,iiout
- real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob
-
- real(r_kind),dimension(nlevp),intent(in ) :: pcoord
-
- integer(i_kind):: ip,itx
- integer(i_kind) ix,iy
-
- real(r_kind) dlat1,dlon1,pob1
- real(r_kind) dx,dy,dp,dxx,dyy,dpp
- real(r_kind) crit!,dist1
- logical foreswp, aftswp
-
-
- iiout = 0
-
-! If using all data (no thinning), simply return to calling routine
- if(use_all_tm)then
- iuse=.true.
- iobs=iobs+1
- iobsout=iobs
- return
- end if
-
-! Compute (i,j,k) indices of coarse mesh grid (grid number 1) which
-! contains the current observation.
- dlat1=dlat_earth
- dlon1=dlon_earth
- pob1=pob
-
- call grdcrd1(pob1,pcoord,nlevp,flg)
- ip=int(pob1)
- dp=pob1-ip
- ip=max(1,min(ip,nlevp))
-
- call grdcrd1(dlat1,glat,mlat,1)
- iy=int(dlat1)
- dy=dlat1-iy
- iy=max(1,min(iy,mlat))
-
- call grdcrd1(dlon1,glon(1,iy),mlon(iy),1)
- ix=int(dlon1)
- dx=dlon1-ix
- ix=max(1,min(ix,mlon(iy)))
-
- dxx=half-min(dx,one-dx)
- dyy=half-min(dy,one-dy)
- if( pflag == 1) then
- dpp=half-min(dp,one-dp)
- else
- dpp=min(dp,one-dp)
- endif
-
- itx=hll(ix,iy)
-
-! Compute distance metric (smaller is closer to center of cube)
-! dist1=(dxx*dxx+dyy*dyy+dpp*dpp)*two/three+half
-
-
-! Examine various cases regarding what to do with current obs.
-! Start by assuming observation will be selected.
- iuse=.true.
-
-! Determine "score" for observation. Lower score is better.
-! crit = crit1*dist1
- crit = crit1
-
-! TDR fore (Pseudo-dual-Doppler-radars)
- if(foreswp) then ! fore sweeps
-
-! Case(1): first obs at this location, keep this obs as starting point
- if (icount_fore_tm(itx,ip,itm)==0) then
- iobs=iobs+1
- iobsout=iobs
- score_crit_fore_tm(itx,ip,itm)= crit
- icount_fore_tm(itx,ip,itm)=icount_fore_tm(itx,ip,itm)+1
- ibest_obs_tm(itx,ip,itm) = iobs
- ibest_save_tm(itx,ip,itm) = iin
-
-! Case(2): obs score < best value at this location,
-! --> update score, count, and best obs counters
- elseif (icount_fore_tm(itx,ip,itm) > 0 .and. crit < score_crit_fore_tm(itx,ip,itm)) then
- score_crit_fore_tm(itx,ip,itm)= crit
- icount_fore_tm(itx,ip,itm)=icount_fore_tm(itx,ip,itm)+1
- iobsout=ibest_obs_tm(itx,ip,itm)
- iiout = ibest_save_tm(itx,ip,itm)
- ibest_save_tm(itx,ip,itm)=iin
-
-! Case(3): obs score > best value at this location,
-! --> do not use this obs, return to calling program.
- elseif (icount_fore_tm(itx,ip,itm) > 0 .and. crit > score_crit_fore_tm(itx,ip,itm)) then
- iuse=.false.
-! Case(4): none of the above cases are satisified, don't use this obs
- else
- iuse = .false.
- endif ! cases
-
-! TDR aft (Pseudo-dual-Doppler-radars)
- else if(aftswp) then ! aft sweeps
-
-! Case(1): first obs at this location, keep this obs as starting point
- if (icount_aft_tm(itx,ip,itm)==0) then
- iobs=iobs+1
- iobsout=iobs
- score_crit_aft_tm(itx,ip,itm)= crit
- icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1
- ibest_obs_tm(itx,ip,itm) = iobs
- ibest_save_tm(itx,ip,itm) = iin
-
-
-! Case(2): obs score < best value at this location,
-! --> update score, count, and best obs counters
- elseif (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then
- score_crit_aft_tm(itx,ip,itm)= crit
- icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1
- iobsout=ibest_obs_tm(itx,ip,itm)
- iiout = ibest_save_tm(itx,ip,itm)
- ibest_save_tm(itx,ip,itm)=iin
-
-! Case(3): obs score > best value at this location,
-! --> do not use this obs, return to calling program.
- elseif(icount_aft_tm(itx,ip,itm) > 0 .and. crit > score_crit_aft_tm(itx,ip,itm)) then
- iuse=.false.
-
-! Case(4): none of the above cases are satisified,
-! --> don't use this obs
- else
- iuse = .false.
- endif ! cases
-
- else
-! Case: obs score > best value at this location,
-! --> do not use this obs, return to calling program.
- if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then
- iuse=.false.
-
-! Case: obs score < best value at this location,
-! --> update score, count, and best obs counters
- elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then
- score_crit_tm(itx,ip,itm)= crit
- iobsout=ibest_obs_tm(itx,ip,itm)
- icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1
- iiout = ibest_save_tm(itx,ip,itm)
- ibest_save_tm(itx,ip,itm)=iin
-
-! Case: first obs at this location,
-! --> keep this obs as starting point
- elseif (icount_tm(itx,ip,itm)==0) then
- iobs=iobs+1
- iobsout=iobs
- score_crit_tm(itx,ip,itm)= crit
- ibest_obs_tm(itx,ip,itm) = iobs
- icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1
- ibest_save_tm(itx,ip,itm) = iin
-
-! Case: none of the above cases are satisified,
-! --> don't use this obs
- else
- iuse = .false.
- end if
- end if
+ integer i,j,it
+ allocate(icount_aft_tm(itxmax,nlevp,ntm))
+ allocate(ibest_obs_aft_tm(itxmax,nlevp,ntm))
+ allocate(score_crit_aft_tm(itxmax,nlevp,ntm))
+ do j=1,nlevp
+ do i=1,itxmax
+ do it=1,ntm
+ icount_aft_tm(i,j,it) = .false.
+ ibest_obs_aft_tm(i,j,it)= 0
+ score_crit_aft_tm(i,j,it)= 9.99e6_r_kind
+ end do
+ end do
+ end do
+ setaft=.true.
return
+ end subroutine createaft_tm
- end subroutine map3grids_tm
-
- subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,crit1,iobs,&
- iobsout,iin,iiout,iuse,maxobs,usage,rusage,foreswp,aftswp)
+ subroutine map3grids_m_tm(flg,save_all,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,crit1,iobs,&
+ iuse,maxobs,rthin,foreswp,aftswp)
!$$$ subprogram documentation block
! . . . .
! subprogram: map3grids_m_tm
@@ -415,16 +285,14 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c
! pob - observation pressure ob
! crit1 - quality indicator for observation (smaller = better)
! ithin - number of obs to retain per thinning grid box
-! iin - counter of input data
+! save_all - flag to save all data (if false, some unused data will still
+ ! be saved.
!
! output argument list:
! iobs - observation counter
! itx - combined (i,j) index of observation on thinning grid
-! iobsout- location for observation to be put
! ip - vertical index
! iuse - .true. if observation should be used
-! iiout - counter of data replaced
-! usage - data usage flag, 0 to keep, 101.0 not to keep
!
!
! attributes:
@@ -436,30 +304,27 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c
implicit none
logical ,intent( out) :: iuse
- integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,iin,maxobs,itm
+ logical ,intent(in ) :: save_all
+ integer(i_kind) ,intent(in ) :: nlevp,pflag,flg,maxobs,itm
integer(i_kind) ,intent(inout) :: iobs
- integer(i_kind) ,intent( out) :: iobsout,iiout
- real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob,usage
+ real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth,crit1,pob
real(r_kind),dimension(nlevp),intent(in ) :: pcoord
- real(r_kind),dimension(maxobs),intent(inout ) :: rusage
+ logical,dimension(maxobs) ,intent(inout) :: rthin
integer(i_kind):: ip,itx
- integer(i_kind) ix,iy
+ integer(i_kind) ix,iy,itmp
real(r_kind) dlat1,dlon1,pob1
- real(r_kind) dx,dy,dp,dxx,dyy,dpp
+ real(r_kind) dx,dy,dp
+! real(r_kind) dxx,dyy,dpp
real(r_kind) crit!,dist1
logical foreswp, aftswp
- iiout = 0
-
+ iuse=.true.
! If using all data (no thinning), simply return to calling routine
if(use_all_tm)then
- iuse=.true.
iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=usage
return
end if
@@ -484,13 +349,13 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c
dx=dlon1-ix
ix=max(1,min(ix,mlon(iy)))
- dxx=half-min(dx,one-dx)
- dyy=half-min(dy,one-dy)
- if( pflag == 1) then
- dpp=half-min(dp,one-dp)
- else
- dpp=min(dp,one-dp)
- endif
+! dxx=half-min(dx,one-dx)
+! dyy=half-min(dy,one-dy)
+! if( pflag == 1) then
+! dpp=half-min(dp,one-dp)
+! else
+! dpp=min(dp,one-dp)
+! endif
itx=hll(ix,iy)
@@ -500,7 +365,6 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c
! Examine various cases regarding what to do with current obs.
! Start by assuming observation will be selected.
- iuse=.true.
! Determine "score" for observation. Lower score is better.
! crit = crit1*dist1
@@ -508,129 +372,98 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c
! TDR fore (Pseudo-dual-Doppler-radars)
if(foreswp) then ! fore sweeps
-! Case: obs score > best value at this location,
-! --> do not use this obs, return to calling program.
- if(crit > score_crit_fore_tm(itx,ip,itm) .and. icount_fore_tm(itx,ip,itm) > 0) then
- iuse=.false.
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.1_r_kind
-
+ if(.not.setfore)call createfore_tm
! Case: obs score < best value at this location,
! --> update score, count, and best obs counters
- elseif (icount_fore_tm(itx,ip,itm) > 0 .and. crit < score_crit_fore_tm(itx,ip,itm)) then
+ if (icount_fore_tm(itx,ip,itm) .and. crit < score_crit_fore_tm(itx,ip,itm)) then
iobs=iobs+1
- iobsout=iobs
+ itmp=ibest_obs_fore_tm(itx,ip,itm)
+ rthin(itmp)=.true.
+ ibest_obs_fore_tm(itx,ip,itm)=iobs
score_crit_fore_tm(itx,ip,itm)= crit
-! iobsout=ibest_obs_tm(itx,ip)
- icount_fore_tm(itx,ip,itm)=icount_fore_tm(itx,ip,itm)+1
- iiout = ibest_save_tm(itx,ip,itm)
- rusage(iiout)=101.1_r_kind
- rusage(iobs)=usage
- ibest_save_tm(itx,ip,itm)=iobs
! Case: first obs at this location,
! --> keep this obs as starting point
- elseif (icount_fore_tm(itx,ip,itm)==0) then
+ elseif (.not. icount_fore_tm(itx,ip,itm)) then
iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=usage
score_crit_fore_tm(itx,ip,itm)= crit
- ibest_obs_tm(itx,ip,itm) = iobs
- icount_fore_tm(itx,ip,itm)=icount_fore_tm(itx,ip,itm)+1
- ibest_save_tm(itx,ip,itm) = iobs
+ ibest_obs_fore_tm(itx,ip,itm) = iobs
+ icount_fore_tm(itx,ip,itm)=.true.
! Case: none of the above cases are satisified,
-! --> don't use this obs
+! Case: obs score > best value at this location,
+! --> do not use this obs, return to calling program.
else
- iuse = .false.
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.0_r_kind
+ if(save_all)then
+ iobs=iobs+1
+ rthin(iobs)=.true.
+ else
+ iuse=.false.
+ end if
end if
! TDR aft (Pseudo-dual-Doppler-radars)
else if(aftswp) then ! fore sweeps
-! Case: obs score > best value at this location,
-! --> do not use this obs, return to calling program.
- if(crit > score_crit_aft_tm(itx,ip,itm) .and. icount_aft_tm(itx,ip,itm) > 0) then
- iuse=.false.
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.0_r_kind
+ if(.not.setaft)call createaft_tm
! Case: obs score < best value at this location,
! --> update score, count, and best obs counters
- elseif (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then
+ if (icount_aft_tm(itx,ip,itm) .and. crit < score_crit_aft_tm(itx,ip,itm)) then
iobs=iobs+1
- iobsout=iobs
+ itmp=ibest_obs_aft_tm(itx,ip,itm)
+ rthin(itmp)=.true.
score_crit_aft_tm(itx,ip,itm)= crit
-! iobsout=ibest_obs_tm(itx,ip)
- icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1
- iiout = ibest_save_tm(itx,ip,itm)
- rusage(iiout)=101.0_r_kind
- rusage(iobs)=usage
- ibest_save_tm(itx,ip,itm)=iobs
+ ibest_obs_aft_tm(itx,ip,itm)=iobs
! Case: first obs at this location,
! --> keep this obs as starting point
- elseif (icount_aft_tm(itx,ip,itm)==0) then
+ elseif (.not. icount_aft_tm(itx,ip,itm)) then
iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=usage
score_crit_aft_tm(itx,ip,itm)= crit
- ibest_obs_tm(itx,ip,itm) = iobs
- icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1
- ibest_save_tm(itx,ip,itm) = iobs
+ ibest_obs_aft_tm(itx,ip,itm) = iobs
+ icount_aft_tm(itx,ip,itm)=.true.
+! Case: obs score > best value at this location,
! Case: none of the above cases are satisified,
-! --> don't use this obs
+! --> do not use this obs, return to calling program.
else
- iuse = .false.
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.1_r_kind
+ if(save_all)then
+ iobs=iobs+1
+ rthin(iobs)=.true.
+ else
+ iuse=.false.
+ end if
end if
else
-! Case: obs score > best value at this location,
-! --> do not use this obs, return to calling program.
- if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then
- iuse=.false.
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.0_r_kind
+ if(.not.setnormal)call createnormal_tm
! Case: obs score < best value at this location,
! --> update score, count, and best obs counters
- elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then
+ if (icount_tm(itx,ip,itm) .and. crit < score_crit_tm(itx,ip,itm)) then
iobs=iobs+1
- iobsout=iobs
+ itmp=ibest_obs_tm(itx,ip,itm)
+ rthin(itmp)=.true.
score_crit_tm(itx,ip,itm)= crit
- icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1
- iiout = ibest_obs_tm(itx,ip,itm)
- rusage(iiout)=101.0_r_kind
- rusage(iobs)=usage
- ibest_save_tm(itx,ip,itm)=iin
- ibest_obs_tm(itx,ip,itm)=iobs
+ ibest_obs_tm(itx,ip,itm) = iobs
! Case: first obs at this location,
! --> keep this obs as starting point
- elseif (icount_tm(itx,ip,itm)==0) then
+ elseif (.not. icount_tm(itx,ip,itm)) then
+
iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=usage
+ icount_tm(itx,ip,itm)=.true.
score_crit_tm(itx,ip,itm)= crit
- ibest_obs_tm(itx,ip,itm) = iobs
- icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1
- ibest_save_tm(itx,ip,itm) = iin
-
+ ibest_obs_tm(itx,ip,itm)=iobs
+! Case: obs score > best value at this location,
! Case: none of the above cases are satisified,
-! --> don't use this obs
+! --> do not use this obs, return to calling program.
else
- iuse = .false.
- iobs=iobs+1
- iobsout=iobs
- rusage(iobs)=101.0_r_kind
+ if(save_all)then
+ iobs=iobs+1
+ rthin(iobs)=.true.
+ else
+ iuse=.false.
+ end if
end if
end if
@@ -663,14 +496,24 @@ subroutine del3grids_tm
if (.not.use_all_tm) then
deallocate(mlon,glat,glon,hll)
- deallocate(icount_tm)
- deallocate(icount_fore_tm)
- deallocate(icount_aft_tm)
- deallocate(ibest_obs_tm)
- deallocate(ibest_save_tm)
- deallocate(score_crit_tm)
- deallocate(score_crit_fore_tm)
- deallocate(score_crit_aft_tm)
+ if(setnormal)then
+ deallocate(icount_tm)
+ deallocate(ibest_obs_tm)
+ deallocate(score_crit_tm)
+ setnormal=.false.
+ end if
+ if(setfore)then
+ deallocate(icount_fore_tm)
+ deallocate(ibest_obs_fore_tm)
+ deallocate(score_crit_fore_tm)
+ setfore=.false.
+ end if
+ if(setaft)then
+ deallocate(icount_aft_tm)
+ deallocate(ibest_obs_aft_tm)
+ deallocate(score_crit_aft_tm)
+ setaft=.false.
+ end if
endif
end subroutine del3grids_tm
diff --git a/src/gsi/correlated_obsmod.F90 b/src/gsi/correlated_obsmod.F90
index 683e13d742..17cd94efe1 100644
--- a/src/gsi/correlated_obsmod.F90
+++ b/src/gsi/correlated_obsmod.F90
@@ -961,14 +961,18 @@ subroutine upd_varch_
enddo
nchanl1=jc
- if(nchanl1==0) call die(myname_,' improperly set GSI_BundleErrorCov')
if(.not.amiset_(GSI_BundleErrorCov(itbl))) then
- if (iamroot_) write(6,*) 'WARNING: Error Covariance not set for ',trim(idnames(itbl))
+ if (iamroot_) write(6,*) trim(myname_), ' WARNING: Error Covariance not set for ',trim(idnames(itbl))
cycle read_tab
endif
nch_active=GSI_BundleErrorCov(itbl)%nch_active
- if(nch_active<0) return
+ if(nch_active<0) then
+ if (iamroot_) write(6,*) trim(myname_), ' WARNING: No active channels for ',trim(idnames(itbl))
+ return
+ endif
+
+ if(nchanl1==0) call die(myname_,' improperly set GSI_BundleErrorCov')
if(GMAO_ObsErrorCov)then
do jj=1,nch_active
@@ -977,11 +981,15 @@ subroutine upd_varch_
if(isurf==1) then
if(iamroot_)write(6,'(1x,a6,a20,2i6,2f20.15)')'>>>',idnames(itbl),jj,nn,varch(mm),sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj))
varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj))
- endif
- if(isurf==2) varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj))
- if(isurf==3) varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj))
- if(isurf==4) varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj))
- if(isurf==5) varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj))
+ else if(isurf==2) then
+ varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj))
+ else if(isurf==3) then
+ varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj))
+ else if(isurf==4) then
+ varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj))
+ else if(isurf==5) then
+ varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj))
+ end if
enddo
else
allocate(ircv(nchanl1))
@@ -1023,15 +1031,9 @@ subroutine upd_varch_
IJsubset(iii)=ijac(ii) ! subset indexes in channels presently in use
endif
enddo
- if (iii/=ncp) then
+ if (iii/=ncp .or. jjj/=ncp) then
if (iamroot_) then
- write(6,*) myname, ' iii,ncp= ',iii,ncp
- endif
- call die(myname_,' serious dimensions insconsistency, aborting')
- endif
- if (jjj/=ncp) then
- if (iamroot_) then
- write(6,*) myname, ' jjj,ncp= ',jjj,ncp
+ write(6,*) myname, ' iii,jjj,ncp= ',iii,jjj,ncp
endif
call die(myname_,' serious dimensions insconsistency, aborting')
endif
@@ -1039,11 +1041,17 @@ subroutine upd_varch_
nn=IJsubset(ii)
mm=ich1(nn)
rr=IRsubset(ii)
- if(isurf==1) varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr))
- if(isurf==2) varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr))
- if(isurf==3) varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr))
- if(isurf==4) varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr))
- if(isurf==5) varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr))
+ if(isurf==1) then
+ varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr))
+ else if(isurf==2) then
+ varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr))
+ else if(isurf==3) then
+ varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr))
+ else if(isurf==4) then
+ varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr))
+ else if(isurf==5) then
+ varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr))
+ end if
enddo
! clean up
deallocate(IJsubset)
@@ -1260,18 +1268,12 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga
IJsubset(iii)=ijac(ii) ! subset indexes in Jac/dep presently in use
endif
enddo
- if (iii/=ncp) then
+ if (iii/=ncp .and. jjj/=ncp) then
if (iamroot_) then
- write(6,*) myname, ' iii,ncp= ',iii,ncp
+ write(6,*) myname, ' iii,ncp= ',iii,jjj,ncp
endif
call die(myname_,' serious dimensions insconsistency (R), aborting')
endif
- if (jjj/=ncp) then
- if (iamroot_) then
- write(6,*) myname, ' jjj,ncp= ',jjj,ncp
- endif
- call die(myname_,' serious dimensions insconsistency (J), aborting')
- endif
if( ErrorCov%method<0 ) then
! Keep departures and Jacobian unchanged
@@ -1300,33 +1302,25 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga
! decompose the sub-matrix - returning the result in the
! structure holding the full covariance
- nsigjac=size(jacobian,1)
- allocate(row(nsigjac,ncp))
- allocate(col(ncp),col2(ncp))
- row=zero_quad
- col=zero_quad
- col2=zero_quad
-
- allocate(qcaj(ncp))
allocate(UT(ncp,ncp))
- qcaj = one
- UT = zero
if( ErrorCov%method==2 ) then
if(lqcoef)then
+ allocate(qcaj(ncp))
do jj=1,ncp
- jjj=IJsubset(jj)
- qcaj(jj) = raterr2(jjj)
+ qcaj(jj) = raterr2(IJsubset(jj))
enddo
subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd,qcaj)
+ deallocate(qcaj)
else
subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd)
endif
else if( ErrorCov%method==1 ) then
+ allocate(qcaj(ncp))
do jj=1,ncp
- jjj=IJsubset(jj)
- qcaj(jj) = varinv(jjj)
+ qcaj(jj) = varinv(IJsubset(jj))
enddo
subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd,qcaj)
+ deallocate(qcaj)
endif
if(.not.subset) then
@@ -1345,23 +1339,31 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga
do kk=ii,ncp
rinvdiag(ii)=rinvdiag(ii)+UT(ii,kk)**2
enddo
- enddo
+ end do
+ nsigjac=size(jacobian,1)
+ allocate(row(nsigjac,ncp))
+ allocate(col(ncp),col2(ncp))
+!$omp parallel do schedule(dynamic,1) private(ii,jj,nn)
do ii=1,ncp
+ row(:,ii)=zero_quad
+ col(ii)=zero_quad
+ col2(ii)=zero_quad
do jj=1,ii
nn=IJsubset(jj)
col(ii) = col(ii) + UT(jj,ii) * depart(nn)
- col2(ii) = col2(ii) + UT(jj,ii) * obs(nn)
+ col2(ii) = col2(ii) + UT(jj,ii) * obs(nn)
row(:,ii) = row(:,ii) + UT(jj,ii) * jacobian(:,nn)
enddo
enddo
+ deallocate(UT)
! Place Jacobian and departure in output arrays
- do jj=1,ncp
- mm=IJsubset(jj)
- depart(mm)=col(jj)
- obs(mm)=col2(jj)
- jacobian(:,mm)=row(:,jj)
+ do ii=1,ncp
+ mm=IJsubset(ii)
+ depart(mm)=col(ii)
+ obs(mm)=col2(ii)
+ jacobian(:,mm)=row(:,ii)
raterr2(mm) = one
err2(mm) = one
wgtjo(mm) = one
@@ -1369,8 +1371,6 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga
deallocate(col,col2)
deallocate(row)
- deallocate(qcaj)
- deallocate(UT)
else if( ErrorCov%method==3 ) then !use diag(Re) scales GSI specified errors
! inv(Rg) = inv(De*Dg)
@@ -1445,17 +1445,16 @@ logical function choleskydecom_inv_(Isubset,IJsubset,ErrorCov,UT,diagadd,qcaj)
do ii=1,ncp
UT(ii,jj) = ErrorCov%R(Isubset(ii),Isubset(jj))/sqrt(qcaj(ii)*qcaj(jj))
enddo
+ UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj))
enddo
else
do jj=1,ncp
do ii=1,ncp
UT(ii,jj) = ErrorCov%R(Isubset(ii),Isubset(jj))
enddo
+ UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj))
enddo
endif
- do jj=1,ncp
- UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj))
- enddo
if(r_kind==r_single) then ! this trick only works because this uses the f77 lapack interfaces
call SPOTRF('U', ncp, UT, ncp, info )
else if(r_kind==r_double) then
diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90
index f99ca39790..9b841f012c 100644
--- a/src/gsi/cplr_get_fv3_regional_ensperts.f90
+++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90
@@ -1,5 +1,5 @@
module get_fv3_regional_ensperts_mod
-use abstract_get_fv3_regional_ensperts_mod,only: abstract_get_fv3_regional_ensperts_class
+ use abstract_get_fv3_regional_ensperts_mod,only: abstract_get_fv3_regional_ensperts_class
use kinds, only : i_kind
use general_sub2grid_mod, only: sub2grid_info
use constants, only:max_varname_length
@@ -8,14 +8,18 @@ module get_fv3_regional_ensperts_mod
procedure, pass(this) :: get_fv3_regional_ensperts => get_fv3_regional_ensperts_run
procedure, pass(this) :: ens_spread_dualres_regional => ens_spread_dualres_regional_fv3_regional
procedure, pass(this) :: general_read_fv3_regional
+ procedure, pass(this) :: general_read_fv3_regional_parallel_over_ens
+ procedure, pass(this) :: parallel_read_fv3_step2
+ procedure, nopass :: fill_regional_2d
end type get_fv3_regional_ensperts_class
- type(sub2grid_info):: grd_fv3lam_ens_dynvar_io_nouv,grd_fv3lam_ens_tracer_io_nouv,grd_fv3lam_ens_uv
+ type(sub2grid_info):: grd_fv3lam_ens_dynvar_io_nouv,grd_fv3lam_ens_tracer_io_nouv,grd_fv3lam_ens_uv,grd_fv3lam_ens_phyvar_io_nouv
character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_ens_io_dynmetvars3d_nouv
! copy of cvars3d excluding uv 3-d fields
character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_ens_io_tracermetvars3d_nouv
! copy of cvars3d excluding uv 3-d fields
character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_ens_io_dynmetvars2d_nouv
character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_ens_io_tracermetvars2d_nouv
+ character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_ens_io_phymetvars3d_nouv
contains
subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
@@ -34,6 +38,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
!
! 2021-08-10 lei - modify for fv3-lam ensemble spread output
! 2021-11-01 lei - modify for fv3-lam parallel IO
+ ! 2022-03-01 X.Lu & X.Wang - modify for hafs dual ens. POC: xuguang.wang@ou.edu
! input argument list:
!
! output argument list:
@@ -46,9 +51,9 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
use kinds, only: r_kind,i_kind,r_single
use constants, only: zero,one,half,zero_single,rd_over_cp,one_tenth
- use mpimod, only: mpi_comm_world,ierror,mype
- use hybrid_ensemble_parameters, only: n_ens,grd_ens
- use hybrid_ensemble_parameters, only: l_both_fv3sar_gfs_ens, n_ens_gfs,n_ens_fv3sar
+ use mpimod, only: mpi_comm_world,ierror,mype,npe
+ use hybrid_ensemble_parameters, only: n_ens,grd_ens,parallelization_over_ensmembers
+ use hybrid_ensemble_parameters, only: l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_fv3sar
use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path
use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d
use gsi_bundlemod, only: gsi_bundlecreate
@@ -69,6 +74,8 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
use gsi_rfv3io_mod, only: fv3lam_io_dynmetvars2d_nouv,fv3lam_io_tracermetvars2d_nouv
use netcdf , only: nf90_open, nf90_close,nf90_nowrite,nf90_inquire,nf90_format_netcdf4
use netcdf_mod , only: nc_check
+ use gsi_rfv3io_mod, only: fv3lam_io_phymetvars3d_nouv
+ use obsmod, only: if_model_dbz,if_model_fed
implicit none
@@ -79,7 +86,11 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig):: u,v,tv,oz,rh
real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2):: ps
- real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)::w,ql,qi,qr,qg,qs,qnr
+ real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)::w,ql,qi,qr,qg,qs,qnr,dbz,fed
+ real(r_kind),dimension(:,:,:),allocatable :: gg_u,gg_v,gg_tv,gg_rh
+ real(r_kind),dimension(:,:,:),allocatable :: gg_w,gg_dbz,gg_qr,gg_qs, &
+ gg_qi,gg_qg,gg_oz,gg_cwmr,gg_fed
+ real(r_kind),dimension(:,:),allocatable :: gg_ps
real(r_single),pointer,dimension(:,:,:):: w3 =>NULL()
real(r_single),pointer,dimension(:,:):: w2 =>NULL()
@@ -96,9 +107,9 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
integer(i_kind):: i,j,k,n,mm1,istatus
integer(i_kind):: ndynvario2d,ntracerio2d
- integer(r_kind):: ndynvario3d,ntracerio3d
+ integer(r_kind):: ndynvario3d,ntracerio3d,nphyvario3d
integer(i_kind):: inner_vars,numfields
- integer(i_kind):: ilev,ic2,ic3
+ integer(i_kind):: ilev,ic2,ic3,iope
integer(i_kind):: m
integer(i_kind)::loc_id,ncfmt
@@ -107,6 +118,8 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
type(type_fv3regfilenameg)::fv3_filename
integer(i_kind):: imem_start,n_fv3sar
+ integer(i_kind):: i_caseflag
+
if(n_ens/=(n_ens_gfs+n_ens_fv3sar)) then
write(6,*)'wrong, the sum of n_ens_gfs and n_ens_fv3sar not equal n_ens, stop'
write(6,*)"n_ens, n_ens_gfs and n_ens_fv3sar are",n_ens, n_ens_gfs , n_ens_fv3sar
@@ -125,8 +138,10 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
!clt setup varnames for IO
ndynvario2d=0
ntracerio2d=0
+ nphyvario3d=0
ndynvario3d=size(fv3lam_io_dynmetvars3d_nouv)
ntracerio3d=size(fv3lam_io_tracermetvars3d_nouv)
+ nphyvario3d=size(fv3lam_io_phymetvars3d_nouv)
if (allocated(fv3lam_io_dynmetvars2d_nouv))then
ndynvario2d=size(fv3lam_io_dynmetvars2d_nouv)
endif
@@ -137,6 +152,10 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
allocate(fv3lam_ens_io_tracermetvars3d_nouv(ndynvario3d))
fv3lam_ens_io_dynmetvars3d_nouv=fv3lam_io_dynmetvars3d_nouv
fv3lam_ens_io_tracermetvars3d_nouv=fv3lam_io_tracermetvars3d_nouv
+ if ( nphyvario3d > 0 )then
+ allocate(fv3lam_ens_io_phymetvars3d_nouv(nphyvario3d))
+ fv3lam_ens_io_phymetvars3d_nouv=fv3lam_io_phymetvars3d_nouv
+ end if
if (ndynvario2d > 0 ) then
allocate(fv3lam_ens_io_dynmetvars2d_nouv(ndynvario2d))
fv3lam_ens_io_dynmetvars2d_nouv=fv3lam_io_dynmetvars2d_nouv
@@ -168,6 +187,24 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
call general_sub2grid_create_info(grd_fv3lam_ens_dynvar_io_nouv,inner_vars,grd_ens%nlat,&
grd_ens%nlon,grd_ens%nsig,numfields,regional,names=names,lnames=lnames)
+ if( nphyvario3d > 0 )then
+ inner_vars=1
+ numfields=inner_vars*(nphyvario3d*grd_ens%nsig)
+ deallocate(lnames,names)
+ allocate(lnames(1,numfields),names(1,numfields))
+ ilev=1
+ do i=1,nphyvario3d
+ do k=1,grd_ens%nsig
+ lnames(1,ilev)=k
+ names(1,ilev)=fv3lam_ens_io_phymetvars3d_nouv(i)
+ ilev=ilev+1
+ enddo
+ enddo
+
+ call general_sub2grid_create_info(grd_fv3lam_ens_phyvar_io_nouv,inner_vars,grd_ens%nlat,&
+ grd_ens%nlon,grd_ens%nsig,numfields,regional,names=names,lnames=lnames)
+ end if
+
inner_vars=1
numfields=inner_vars*(ntracerio3d*grd_ens%nsig+ntracerio2d)
deallocate(lnames,names)
@@ -254,16 +291,87 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
mm1=mype+1
kap1=rd_over_cp+one
kapr=one/rd_over_cp
+
+ if( parallelization_over_ensmembers ) then
+ if(n_ens_fv3sar>npe) then
+ parallelization_over_ensmembers=.false.
+130 format('Disabling parallelization_over_ensmembers because number of ensemble members (',I0,') is greater than number of MPI ranks (',I0,').')
+ if(mype==0) then
+ write(6,130) n_ens_fv3sar,npe
+ endif
+ endif
+ endif ! parallelization_over_ensmembers
+
+ if(parallelization_over_ensmembers .and. mype==0) then
+ write(6,'(I0,A)') mype,': will read ensemble data in parallel (parallelization_over_ensmembers=.true.)'
+ endif
+
+ if( parallelization_over_ensmembers )then
+ do n=1,n_ens_fv3sar
+ write(ensfilenam_str,22) trim(adjustl(ensemble_path)),ens_fhrlevs(m),n
+22 format(a,'fv3SAR',i2.2,'_ens_mem',i3.3)
+ iope=(n-1)*npe/n_ens_fv3sar
+ ! DEFINE INPUT FILE NAME
+ fv3_filename%grid_spec=trim(ensfilenam_str)//'-fv3_grid_spec'
+ fv3_filename%ak_bk=trim(ensfilenam_str)//'-fv3_akbk'
+ fv3_filename%dynvars=trim(ensfilenam_str)//'-fv3_dynvars'
+ fv3_filename%tracers=trim(ensfilenam_str)//"-fv3_tracer"
+ fv3_filename%phyvars=trim(ensfilenam_str)//'-fv3_phyvars'
+ fv3_filename%sfcdata=trim(ensfilenam_str)//"-fv3_sfcdata"
+ fv3_filename%couplerres=trim(ensfilenam_str)//"-coupler.res"
+
+ if( mype==iope) then
+ allocate(gg_u(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ allocate(gg_v(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ allocate(gg_tv(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ allocate(gg_rh(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ allocate(gg_oz(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ allocate(gg_ps(grd_ens%nlat,grd_ens%nlon))
+
+ if ( if_model_dbz .or. if_model_fed ) then
+ allocate(gg_w(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ allocate(gg_qr(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ allocate(gg_qs(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ allocate(gg_qi(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ allocate(gg_qg(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ allocate(gg_cwmr(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ end if
+ if ( if_model_dbz) then
+ allocate(gg_dbz(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ end if
+ if ( if_model_fed) then
+ allocate(gg_fed(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig))
+ end if
+
+ if ( if_model_dbz .and. if_model_fed) then
+ call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz,&
+ g_ql=gg_cwmr,g_qi=gg_qi,g_qr=gg_qr,g_qs=gg_qs,g_qg=gg_qg,g_w=gg_w,g_dbz=gg_dbz,g_fed=gg_fed)
+ elseif ( if_model_dbz ) then
+ call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz,&
+ g_ql=gg_cwmr,g_qi=gg_qi,g_qr=gg_qr,g_qs=gg_qs,g_qg=gg_qg,g_w=gg_w,g_dbz=gg_dbz)
+ elseif ( if_model_fed ) then
+ call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz,&
+ g_ql=gg_cwmr,g_qi=gg_qi,g_qr=gg_qr,g_qs=gg_qs,g_qg=gg_qg,g_w=gg_w,g_fed=gg_fed)
+ else
+ call this%general_read_fv3_regional_parallel_over_ens(iope,fv3_filename,gg_ps,gg_u,gg_v,gg_tv,gg_rh,gg_oz)
+ end if
+ end if !mype
+ end do
+ if(mype==0) then
+ write(6,'(I0,A)') mype,': reading ensemble data in parallel is done (parallelization_over_ensmembers=.true.)'
+ endif
+ end if
+ call MPI_Barrier(mpi_comm_world,ierror)
!
! LOOP OVER ENSEMBLE MEMBERS
do n_fv3sar=1,n_ens_fv3sar
n=n_ens_gfs+n_fv3sar
write(ensfilenam_str,22) trim(adjustl(ensemble_path)),ens_fhrlevs(m),n_fv3sar
-22 format(a,'fv3SAR',i2.2,'_ens_mem',i3.3)
! DEFINE INPUT FILE NAME
fv3_filename%grid_spec=trim(ensfilenam_str)//'-fv3_grid_spec' !exmaple thinktobe
fv3_filename%ak_bk=trim(ensfilenam_str)//'-fv3_akbk'
fv3_filename%dynvars=trim(ensfilenam_str)//'-fv3_dynvars'
+ fv3_filename%phyvars=trim(ensfilenam_str)//'-fv3_phyvars'
fv3_filename%tracers=trim(ensfilenam_str)//"-fv3_tracer"
fv3_filename%sfcdata=trim(ensfilenam_str)//"-fv3_sfcdata"
fv3_filename%couplerres=trim(ensfilenam_str)//"-coupler.res"
@@ -299,15 +407,134 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
endif
!
! READ ENEMBLE MEMBERS DATA
- if (mype == 0) write(6,'(a,a)') &
- 'CALL READ_FV3_REGIONAL_ENSPERTS FOR ENS DATA with the filename str : ',trim(ensfilenam_str)
- if (.not.l_use_dbz_directDA ) then ! Read additional hydrometers and w for dirZDA
- call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz)
- else
- call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, &
- g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w)
+ !
+ ! There are three options to control the list of variables that
+ ! will be read in along with the basic variables, ps,u,v,tv,rh,oz.
+
+ ! parallelization_over_ensmembers=.True. only works for cases when l_use_dbz_directDA=.False.
+ ! Noted that l_use_dbz_directDA and if_modle_dbz couldn't be true at the same time
+
+ !
+ ! I_CASEFLAG defination
+ !
+
+ ! default: all the three options ( l_use_dbz_directDA, if_model_dbz, if_model_fed) are turned off .i.e.,
+ ! if(.not. (l_use_dbz_directDA .or. if_model_dbz .or. if_model_fed ))
+ ! read in ps,u,v,tv,rh,oz
+ i_caseflag=0
+
+ ! only l_use_dbz_directDA is true
+ if (l_use_dbz_directDA .and. .not.if_model_dbz .and. .not.if_model_fed) i_caseflag=1
+
+ ! only if_model_dbz is true
+ if(.not.l_use_dbz_directDA .and. if_model_dbz .and. .not.if_model_fed) i_caseflag=2
+
+ ! only if_model_fed is true
+ if(.not.l_use_dbz_directDA .and. .not.if_model_dbz .and. if_model_fed) i_caseflag=3
+
+ ! l_use_dbz_directDA=.true. and if_model_fed=.true.
+ if(l_use_dbz_directDA .and. .not.if_model_dbz .and. if_model_fed) i_caseflag=4
+
+ ! if_model_dbz=.true. and if_model_fed=.true.
+ if(.not. l_use_dbz_directDA.and. if_model_dbz .and. if_model_fed) i_caseflag=5
+
+
+ !--------------------------------------------------
+ ! When .not. parallelization_over_ensmembers=.True.
+ ! All the above 6 cases (i_caseflag=0,1,2,3,4,5) are valid in
+ ! the current applications as of Oct 20 2023.
+
+ !--------------------------------------------
+ ! When parallelization_over_ensmembers=.True.
+ ! Only i_flagcase=0,2,3,5 are vaild choices.
+
+
+ if( .not. parallelization_over_ensmembers )then
+ if (mype == 0) write(6,'(a,a)') &
+ 'CALL READ_FV3_REGIONAL_ENSPERTS FOR ENS DATA with the filename str : ',trim(ensfilenam_str)
+
+ select case (i_caseflag)
+ case (0)
+ call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz)
+ case (1)
+ call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, &
+ g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w)
+ case (2)
+ call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, &
+ g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w,g_dbz=dbz)
+ case (3)
+ call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, &
+ g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_w=w,g_fed=fed)
+ case (4)
+ call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, &
+ g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w,g_fed=fed)
+ case (5)
+ call this%general_read_fv3_regional(fv3_filename,ps,u,v,tv,rh,oz, &
+ g_ql=ql,g_qi=qi,g_qr=qr,g_qs=qs,g_qg=qg,g_qnr=qnr,g_w=w,g_dbz=dbz,g_fed=fed)
+ end select
end if
-
+
+ if( parallelization_over_ensmembers )then
+ iope=(n_fv3sar-1)*npe/n_ens_fv3sar
+ if(mype==iope) then
+ write(0,'(I0,A,I0,A)') mype,': scatter member ',n_fv3sar,' to other ranks...'
+ select case (i_caseflag)
+ case (0)
+ call this%parallel_read_fv3_step2(mype,iope,&
+ g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,g_oz=oz, &
+ gg_ps=gg_ps,gg_tv=gg_tv,gg_u=gg_u,gg_v=gg_v,gg_rh=gg_rh)
+ case (2)
+ call this%parallel_read_fv3_step2(mype,iope,&
+ g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,&
+ g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_dbz=dbz,&
+ gg_ps=gg_ps,gg_tv=gg_tv,gg_u=gg_u,gg_v=gg_v,&
+ gg_rh=gg_rh,gg_w=gg_w,gg_dbz=gg_dbz,gg_qr=gg_qr,&
+ gg_qs=gg_qs,gg_qi=gg_qi,gg_qg=gg_qg,gg_ql=gg_cwmr)
+ case (3)
+ call this%parallel_read_fv3_step2(mype,iope,&
+ g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,&
+ g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_fed=fed,&
+ gg_ps=gg_ps,gg_tv=gg_tv,gg_u=gg_u,gg_v=gg_v,&
+ gg_rh=gg_rh,gg_w=gg_w,gg_fed=gg_fed,gg_qr=gg_qr,&
+ gg_qs=gg_qs,gg_qi=gg_qi,gg_qg=gg_qg,gg_ql=gg_cwmr)
+ case (5)
+ call this%parallel_read_fv3_step2(mype,iope,&
+ g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,&
+ g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_dbz=dbz,g_fed=fed,&
+ gg_ps=gg_ps,gg_tv=gg_tv,gg_u=gg_u,gg_v=gg_v,&
+ gg_rh=gg_rh,gg_w=gg_w,gg_dbz=gg_dbz,gg_fed=gg_fed,gg_qr=gg_qr,&
+ gg_qs=gg_qs,gg_qi=gg_qi,gg_qg=gg_qg,gg_ql=gg_cwmr)
+ case (1,4)
+ write(6,*)'i_case_flag=1 or 4 is not a valid choice for parallelization_over_ensmembers=.T. Stop(8880) '
+ call stop2(8880)
+ end select
+ else
+ select case (i_caseflag)
+ case (0)
+ call this%parallel_read_fv3_step2(mype,iope,&
+ g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,g_oz=oz)
+ case (2)
+ call this%parallel_read_fv3_step2(mype,iope,&
+ g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,&
+ g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_dbz=dbz)
+ case (3)
+ call this%parallel_read_fv3_step2(mype,iope,&
+ g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,&
+ g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_fed=fed)
+ case (5)
+ call this%parallel_read_fv3_step2(mype,iope,&
+ g_ps=ps,g_u=u,g_v=v,g_tv=tv,g_rh=rh,g_ql=ql,&
+ g_oz=oz,g_w=w,g_qr=qr,g_qs=qs,g_qi=qi,g_qg=qg,g_dbz=dbz,g_fed=fed)
+ case (1,4)
+ write(6,*)'i_case_flag=1 or 4 is not a valid choice for parallelization_over_ensmembers=.T. Stop(8880) '
+ call stop2(8880)
+ end select
+
+ endif
+
+ call MPI_Barrier(mpi_comm_world,ierror)
+ end if
+
! SAVE ENSEMBLE MEMBER DATA IN COLUMN VECTOR
do ic3=1,nc3d
@@ -463,6 +690,26 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
end do
end do
end do
+
+ case('dbz','DBZ')
+ do k=1,grd_ens%nsig
+ do i=1,grd_ens%lon2
+ do j=1,grd_ens%lat2
+ w3(j,i,k) = dbz(j,i,k)
+ x3(j,i,k)=x3(j,i,k)+dbz(j,i,k)
+ end do
+ end do
+ end do
+
+ case('fed','FED')
+ do k=1,grd_ens%nsig
+ do i=1,grd_ens%lon2
+ do j=1,grd_ens%lat2
+ w3(j,i,k) = fed(j,i,k)
+ x3(j,i,k)=x3(j,i,k)+fed(j,i,k)
+ end do
+ end do
+ end do
end select
@@ -508,7 +755,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
enddo
!
! CALCULATE ENSEMBLE MEAN
- bar_norm = one/float(n_ens_fv3sar)
+ bar_norm = one/real(n_ens_fv3sar,r_kind)
en_bar(m)%values=en_bar(m)%values*bar_norm
! Copy pbar to module array. ps_bar may be needed for vertical localization
@@ -536,7 +783,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
!
!
! CONVERT ENSEMBLE MEMBERS TO ENSEMBLE PERTURBATIONS
- sig_norm=sqrt(one/max(one,n_ens_fv3sar-one))
+ sig_norm=sqrt(weight_ens_fv3sar/max(one,n_ens_fv3sar-one))
do n=imem_start,n_ens
do i=1,nelen
@@ -546,7 +793,6 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
enddo ! it 4d loop
! CALCULATE ENSEMBLE SPREAD
- write_ens_sprd=.true.
if(write_ens_sprd ) then
call this%ens_spread_dualres_regional(mype,en_perts,nelen)
call mpi_barrier(mpi_comm_world,ierror) ! do we need this mpi_barrier here?
@@ -572,7 +818,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
end subroutine get_fv3_regional_ensperts_run
subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g_rh,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,g_qnr,g_w)
+ g_ql,g_qi,g_qr,g_qs,g_qg,g_qnr,g_w,g_dbz,g_fed)
!$$$ subprogram documentation block
! first compied from general_read_arw_regional . . . .
! subprogram: general_read_fv3_regional read fv3sar model ensemble members
@@ -603,7 +849,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g
use gridmod, only: eta1_ll,eta2_ll
use constants, only: zero,one,fv,zero_single,one_tenth,h300
use hybrid_ensemble_parameters, only: grd_ens,q_hyb_ens
- use hybrid_ensemble_parameters, only: fv3sar_ensemble_opt
+ use hybrid_ensemble_parameters, only: fv3sar_ensemble_opt,dual_res
use mpimod, only: mpi_comm_world,mpi_rtype
use gsi_rfv3io_mod,only: type_fv3regfilenameg
@@ -623,7 +869,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g
use hybrid_ensemble_parameters, only: grd_ens
use directDA_radaruse_mod, only: l_use_cvpqx, cvpqx_pval, cld_nt_updt
use directDA_radaruse_mod, only: l_cvpnr, cvpnr_pval
-
+ use obsmod, only:if_model_dbz,if_model_fed
implicit none
@@ -632,7 +878,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g
class(get_fv3_regional_ensperts_class), intent(inout) :: this
type (type_fv3regfilenameg) , intent (in) :: fv3_filenameginput
real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out)::g_u,g_v,g_tv,g_rh,g_oz
- real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),optional,intent(out)::g_ql,g_qi,g_qr
+ real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),optional,intent(out)::g_ql,g_qi,g_qr,g_dbz,g_fed
real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),optional,intent(out)::g_qs,g_qg,g_qnr,g_w
real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(out):: g_ps
@@ -656,11 +902,13 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g
character(len=24),parameter :: myname_ = 'general_read_fv3_regional'
type(gsi_bundle) :: gsibundle_fv3lam_ens_dynvar_nouv
type(gsi_bundle) :: gsibundle_fv3lam_ens_tracer_nouv
+ type(gsi_bundle) :: gsibundle_fv3lam_ens_phyvar_nouv
type(gsi_grid):: grid_ens
character(len=:),allocatable :: grid_spec !='fv3_grid_spec'
character(len=:),allocatable :: ak_bk !='fv3_akbk'
character(len=:),allocatable :: dynvars !='fv3_dynvars'
+ character(len=:),allocatable :: phyvars !='fv3_phyvars'
character(len=:),allocatable :: tracers !='fv3_tracer'
character(len=:),allocatable :: sfcdata !='fv3_sfcdata'
character(len=:),allocatable :: couplerres!='coupler.res'
@@ -676,6 +924,7 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g
grid_spec=fv3_filenameginput%grid_spec
ak_bk=fv3_filenameginput%ak_bk
dynvars=fv3_filenameginput%dynvars
+ phyvars=fv3_filenameginput%phyvars
tracers=fv3_filenameginput%tracers
sfcdata=fv3_filenameginput%sfcdata
couplerres=fv3_filenameginput%couplerres
@@ -701,37 +950,49 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g
endif
-
+ if(allocated(fv3lam_ens_io_phymetvars3d_nouv))then
+ call gsi_bundlecreate(gsibundle_fv3lam_ens_phyvar_nouv,grid_ens,'gsibundle_fv3lam_ens_phyvar_nouv',istatus, &
+ names3d=fv3lam_ens_io_phymetvars3d_nouv)
+ end if
if(fv3sar_ensemble_opt == 0 ) then
- call gsi_fv3ncdf_readuv(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput)
+ call gsi_fv3ncdf_readuv(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput,dual_res)
else
- call gsi_fv3ncdf_readuv_v1(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput)
+ call gsi_fv3ncdf_readuv_v1(grd_fv3lam_ens_uv,g_u,g_v,fv3_filenameginput,dual_res)
endif
if(fv3sar_ensemble_opt == 0) then
call gsi_fv3ncdf_read(grd_fv3lam_ens_dynvar_io_nouv,gsibundle_fv3lam_ens_dynvar_nouv,&
- fv3_filenameginput%dynvars,fv3_filenameginput)
+ fv3_filenameginput%dynvars,fv3_filenameginput,dual_res)
call gsi_fv3ncdf_read(grd_fv3lam_ens_tracer_io_nouv,gsibundle_fv3lam_ens_tracer_nouv,&
- fv3_filenameginput%tracers,fv3_filenameginput)
+ fv3_filenameginput%tracers,fv3_filenameginput,dual_res)
+ if( if_model_dbz .or. if_model_fed ) then
+ call gsi_fv3ncdf_read(grd_fv3lam_ens_phyvar_io_nouv,gsibundle_fv3lam_ens_phyvar_nouv,&
+ fv3_filenameginput%phyvars,fv3_filenameginput,dual_res)
+ end if
else
call gsi_fv3ncdf_read_v1(grd_fv3lam_ens_dynvar_io_nouv,gsibundle_fv3lam_ens_dynvar_nouv,&
- fv3_filenameginput%dynvars,fv3_filenameginput)
+ fv3_filenameginput%dynvars,fv3_filenameginput,dual_res)
call gsi_fv3ncdf_read_v1(grd_fv3lam_ens_tracer_io_nouv,gsibundle_fv3lam_ens_tracer_nouv,&
- fv3_filenameginput%tracers,fv3_filenameginput)
+ fv3_filenameginput%tracers,fv3_filenameginput,dual_res)
endif
ier=0
call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_dynvar_nouv, 'tsen' ,g_tsen ,istatus );ier=ier+istatus
- call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'q' ,g_q ,istatus );ier=ier+istatus
- call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'oz' ,g_oz ,istatus );ier=ier+istatus
- if (l_use_dbz_directDA) then
+ call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'q' ,g_q ,istatus );ier=ier+istatus
+ call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'oz' ,g_oz ,istatus );ier=ier+istatus
+ if (l_use_dbz_directDA .or. if_model_dbz .or. if_model_fed) then
call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'ql' ,g_ql ,istatus );ier=ier+istatus
call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qi' ,g_qi ,istatus );ier=ier+istatus
call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qr' ,g_qr ,istatus );ier=ier+istatus
call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qs' ,g_qs ,istatus );ier=ier+istatus
call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qg' ,g_qg ,istatus );ier=ier+istatus
+ if (l_use_dbz_directDA) &
call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_tracer_nouv, 'qnr',g_qnr ,istatus );ier=ier+istatus
call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_dynvar_nouv, 'w' , g_w ,istatus );ier=ier+istatus
+ if( if_model_dbz )&
+ call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_phyvar_nouv, 'dbz' , g_dbz ,istatus );ier=ier+istatus
+ if( if_model_fed )&
+ call GSI_Bundlegetvar ( gsibundle_fv3lam_ens_phyvar_nouv, 'fed' , g_fed, istatus );ier=ier+istatus
end if
@@ -834,11 +1095,349 @@ subroutine general_read_fv3_regional(this,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g
enddo
call gsi_bundledestroy(gsibundle_fv3lam_ens_dynvar_nouv)
call gsi_bundledestroy(gsibundle_fv3lam_ens_tracer_nouv)
-
+ call gsi_bundledestroy(gsibundle_fv3lam_ens_phyvar_nouv)
return
end subroutine general_read_fv3_regional
+ subroutine general_read_fv3_regional_parallel_over_ens(this,iope,fv3_filenameginput,g_ps,g_u,g_v,g_tv,g_rh,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,g_qnr,g_w,g_dbz,g_fed)
+ !$$$ subprogram documentation block
+ ! first compied from general_read_arw_regional . . . .
+ ! subprogram: general_read_fv3_regional read fv3sar model ensemble members
+ ! prgmmr: Ting org: emc/ncep date: 2018
+ !
+ ! abstract: read ensemble members from the fv3sar model in "restart" or "cold start" netcdf format
+ ! for use with hybrid ensemble option.
+ !
+ ! program history log:
+ ! 2018- Ting - intial versions
+ ! 2022-04-01 Y. Wang and X. Wang - read all fields for each member for
+ ! parallel ensemble IO capability
+ ! poc: xuguang.wang@ou.edu
+ !
+ ! input argument list:
+ !
+ ! output argument list:
+ !
+ ! attributes:
+ ! language: f90
+ ! machine: ibm RS/6000 SP
+ !
+ !$$$ end documentation block
+
+ use netcdf, only: nf90_nowrite
+ use netcdf, only: nf90_open,nf90_close
+ use netcdf, only: nf90_inq_dimid,nf90_inquire_dimension
+ use netcdf, only: nf90_inq_varid,nf90_inquire_variable,nf90_get_var
+ use kinds, only: r_kind,r_single,i_kind
+ use gridmod, only: eta1_ll
+ use constants, only: zero,one,fv,zero_single,one_tenth,h300
+ use hybrid_ensemble_parameters, only: grd_ens,q_hyb_ens
+ use hybrid_ensemble_parameters, only: fv3sar_ensemble_opt
+
+ use mpimod, only: mpi_comm_world,mpi_rtype,mype
+ use netcdf_mod, only: nc_check
+ use gsi_rfv3io_mod,only: type_fv3regfilenameg
+ use gsi_rfv3io_mod,only:n2d
+ use constants, only: half,zero
+ use gsi_rfv3io_mod, only: gsi_fv3ncdf_read
+ use gsi_rfv3io_mod, only: gsi_fv3ncdf_read_v1
+ use gsi_rfv3io_mod, only: gsi_fv3ncdf_readuv
+ use gsi_rfv3io_mod, only: gsi_fv3ncdf_readuv_v1
+ use gsi_rfv3io_mod, only: gsi_fv3ncdf2d_read_v1
+ use gsi_bundlemod, only: gsi_gridcreate
+ use gsi_bundlemod, only: gsi_grid
+ use gsi_bundlemod, only: gsi_bundlecreate,gsi_bundledestroy
+ use gsi_bundlemod, only: gsi_bundlegetvar
+ use obsmod, only: if_model_dbz,if_model_fed
+ use gsi_rfv3io_mod, only: gsi_fv3ncdf_read_ens_parallel_over_ens,gsi_fv3ncdf_readuv_ens_parallel_over_ens
+
+
+
+ implicit none
+!
+! Declare passed variables
+ class(get_fv3_regional_ensperts_class), intent(inout) :: this
+ integer(i_kind), intent (in) :: iope
+ type (type_fv3regfilenameg) , intent (in) :: fv3_filenameginput
+ real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig),intent(out)::g_u,g_v,g_tv,g_rh,g_oz
+ real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig),optional,intent(out)::g_ql,g_qi,g_qr,g_dbz,g_fed
+ real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig),optional,intent(out)::g_qs,g_qg,g_qnr,g_w
+
+ real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon),intent(out):: g_ps
+ real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig+1) ::g_prsi
+ real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig) ::g_prsl ,g_tsen,g_q,g_delp
+!
+! Declare local parameters
+ real(r_kind),parameter:: r0_01 = 0.01_r_kind
+ real(r_kind),parameter:: r10 = 10.0_r_kind
+ real(r_kind),parameter:: r100 = 100.0_r_kind
+ !
+! Declare local variables
+
+ integer(i_kind):: i,j,k,kp
+
+ integer(i_kind) iderivative
+
+
+ logical ice
+
+ character(len=24),parameter :: myname_ = 'general_read_fv3_regional'
+
+ character(len=:),allocatable :: grid_spec !='fv3_grid_spec'
+ character(len=:),allocatable :: ak_bk !='fv3_akbk'
+ character(len=:),allocatable :: dynvars !='fv3_dynvars'
+ character(len=:),allocatable :: phyvars !='fv3_phyvars'
+ character(len=:),allocatable :: tracers !='fv3_tracer'
+ character(len=:),allocatable :: sfcdata !='fv3_sfcdata'
+ character(len=:),allocatable :: couplerres!='coupler.res'
+
+
+ associate( this => this ) ! eliminates warning for unused dummy argument needed for binding
+ end associate
+
+ if( mype == iope )then
+ grid_spec=fv3_filenameginput%grid_spec
+ ak_bk=fv3_filenameginput%ak_bk
+ dynvars=fv3_filenameginput%dynvars
+ phyvars=fv3_filenameginput%phyvars
+ tracers=fv3_filenameginput%tracers
+ sfcdata=fv3_filenameginput%sfcdata
+ couplerres=fv3_filenameginput%couplerres
+
+ if(fv3sar_ensemble_opt == 0 ) then
+ call gsi_fv3ncdf_readuv_ens_parallel_over_ens(g_u,g_v,fv3_filenameginput,iope)
+ else
+ write(6,*) "Warning: we can only grab fields from restart files not cold start files for ensemble!"
+ endif
+
+ if(fv3sar_ensemble_opt == 0) then
+ if (if_model_dbz .or. if_model_fed) then
+ call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%dynvars,fv3_filenameginput,delp=g_delp,tsen=g_tsen,w=g_w,iope=iope)
+ call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%tracers,fv3_filenameginput,q=g_q,oz=g_oz,ql=g_ql,qr=g_qr,&
+ qs=g_qs,qi=g_qi,qg=g_qg,iope=iope)
+ if(if_model_dbz .and. if_model_fed) then
+ call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%phyvars,fv3_filenameginput,dbz=g_dbz,fed=g_fed,iope=iope)
+ elseif(if_model_dbz) then
+ call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%phyvars,fv3_filenameginput,dbz=g_dbz,iope=iope)
+ elseif(if_model_fed) then
+ call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%phyvars,fv3_filenameginput,fed=g_fed,iope=iope)
+ end if
+ else
+ call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%dynvars,fv3_filenameginput,delp=g_delp,tsen=g_tsen,iope=iope)
+ call gsi_fv3ncdf_read_ens_parallel_over_ens(fv3_filenameginput%tracers,fv3_filenameginput,q=g_q,oz=g_oz,iope=iope)
+ end if
+ else
+ write(6,*) "Warning: we can only grab fields from restart files not cold start files for ensemble!"
+ endif
+
+
+ if (fv3sar_ensemble_opt == 0) then
+ g_prsi(:,:,grd_ens%nsig+1)=eta1_ll(grd_ens%nsig+1) !thinkto be done , should use eta1_ll from ensemble grid
+ do i=grd_ens%nsig,1,-1
+ g_prsi(:,:,i)=g_delp(:,:,i)*0.001_r_kind+g_prsi(:,:,i+1)
+ enddo
+ g_ps(:,:)=g_prsi(:,:,1)
+
+ endif
+
+ !! tsen2tv !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do k=1,grd_ens%nsig
+ do j=1,grd_ens%nlon
+ do i=1,grd_ens%nlat
+ g_tv(i,j,k)=g_tsen(i,j,k)*(one+fv*g_q(i,j,k))
+ enddo
+ enddo
+ enddo
+ if (.not.q_hyb_ens) then
+ ice=.true.
+ iderivative=0
+ do k=1,grd_ens%nsig
+ kp=k+1
+ do j=1,grd_ens%nlon
+ do i=1,grd_ens%nlat
+ g_prsl(i,j,k)=(g_prsi(i,j,k)+g_prsi(i,j,kp))*half
+ end do
+ end do
+ end do
+ call genqsat(g_rh,g_tsen(1,1,1),g_prsl(1,1,1),grd_ens%nlat,grd_ens%nlon,grd_ens%nsig,ice,iderivative)
+ do k=1,grd_ens%nsig
+ do j=1,grd_ens%nlon
+ do i=1,grd_ens%nlat
+ g_rh(i,j,k) = g_q(i,j,k)/g_rh(i,j,k)
+ end do
+ end do
+ end do
+ else
+ do k=1,grd_ens%nsig
+ do j=1,grd_ens%nlon
+ do i=1,grd_ens%nlat
+ g_rh(i,j,k) = g_q(i,j,k)
+ end do
+ end do
+ end do
+ end if
+ end if ! mype
+
+ return
+ end subroutine general_read_fv3_regional_parallel_over_ens
+
+
+ subroutine parallel_read_fv3_step2(this,mype,iope, &
+ g_ps,g_u,g_v,g_tv,g_rh,g_ql,g_oz,g_w,g_qr,g_qs,g_qi,&
+ g_qg,g_dbz,g_fed, &
+ gg_ps,gg_tv,gg_u,gg_v,gg_rh,gg_w,gg_dbz,gg_fed,gg_qr,&
+ gg_qs,gg_qi,gg_qg,gg_ql)
+
+ !$$$ subprogram documentation block
+ ! .
+ ! subprogram: parallel_read_fv3_step2 distribute all fields into all tasks
+ ! prgmmr: Y. Wang and X. Wang org: OU/MAP date: 2022-04-01
+ !
+ ! abstract: All fields have been read in by general_read_fv3_regional_parallel_over_ens.
+ ! Different tasks contain the data from different members.
+ ! This program will divided the full-domain fields into subdomains
+ ! and assign them to all tasks. poc: xuguang.wang@ou.edu
+ !
+ ! program history log:
+ !
+ ! 2022-04-01 Y. Wang and X. Wang - Changed from the code for WRF-ARW
+ !
+ ! input argument list:
+ !
+ ! output argument list:
+ !
+ ! attributes:
+ ! language: f90
+ ! machine: ibm RS/6000 SP
+ !
+ !$$$ end documentation block
+
+ use hybrid_ensemble_parameters, only: grd_ens
+ use mpimod, only: mpi_comm_world,ierror,mpi_rtype
+ use kinds, only: r_kind,r_single,i_kind
+ use constants, only: half,zero
+
+ implicit none
+
+ !
+ ! Declare passed variables
+ class(get_fv3_regional_ensperts_class), intent(inout) :: this
+ real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out):: &
+ g_u,g_v,g_tv,g_rh,g_ql,g_oz
+ real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig),intent(out),optional::&
+ g_w,g_qr,g_qs,g_qi,g_qg,g_dbz,g_fed
+ integer(i_kind), intent(in) :: mype, iope
+ real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(out):: g_ps
+
+ ! The gg_ arrays are only sent by the rank doing I/O (mype==iope)
+ real(r_kind),optional,dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig) :: &
+ gg_u,gg_v,gg_tv,gg_rh
+
+ real(r_kind),optional,dimension(grd_ens%nlat,grd_ens%nlon,grd_ens%nsig) :: &
+ gg_w,gg_dbz,gg_fed,gg_qr,gg_qs,gg_qi,gg_qg,gg_ql
+ real(r_kind),optional,dimension(grd_ens%nlat,grd_ens%nlon):: gg_ps
+
+ ! Declare local variables
+ real(r_kind),allocatable,dimension(:):: wrk_send_2d
+ integer(i_kind) :: k
+
+ ! transfer data from root to subdomains on each task
+ ! scatterv used, since full grids exist only on root task.
+ allocate(wrk_send_2d(grd_ens%itotsub))
+ g_oz=zero
+ ! first PS (output from fill_regional_2d is a column vector with a halo)
+ if(mype==iope) call this%fill_regional_2d(gg_ps,wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, &
+ g_ps,grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ ! then TV,U,V,RH
+ do k=1,grd_ens%nsig
+ if (mype==iope) then
+ call this%fill_regional_2d(gg_tv(:,:,k),wrk_send_2d)
+ endif
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, &
+ g_tv(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ if (mype==iope) call this%fill_regional_2d(gg_u(1,1,k),wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, &
+ g_u(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ if (mype==iope) call this%fill_regional_2d(gg_v(1,1,k),wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, &
+ g_v(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ if (mype==iope) call this%fill_regional_2d(gg_rh(1,1,k),wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, &
+ g_rh(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ if( present(g_dbz) .or. present(g_fed) )then
+ if (mype==iope) call this%fill_regional_2d(gg_w(1,1,k),wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, &
+ g_w(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ if (mype==iope) call this%fill_regional_2d(gg_qr(1,1,k),wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,&
+ g_qr(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ if (mype==iope) call this%fill_regional_2d(gg_qs(1,1,k),wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,&
+ g_qs(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ if (mype==iope) call this%fill_regional_2d(gg_qi(1,1,k),wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,&
+ g_qi(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ if (mype==iope) call this%fill_regional_2d(gg_qg(1,1,k),wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype, &
+ g_qg(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ if (mype==iope) call this%fill_regional_2d(gg_ql(1,1,k),wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,&
+ g_ql(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ if( present(g_dbz)) then
+ if (mype==iope) call this%fill_regional_2d(gg_dbz(1,1,k),wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,&
+ g_dbz(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ end if
+ if( present(g_fed)) then
+ if (mype==iope) call this%fill_regional_2d(gg_fed(1,1,k),wrk_send_2d)
+ call mpi_scatterv(wrk_send_2d,grd_ens%ijn_s,grd_ens%displs_s,mpi_rtype,&
+ g_fed(1,1,k),grd_ens%ijn_s(mype+1),mpi_rtype,iope,mpi_comm_world,ierror)
+ end if
+ end if
+ enddo
+ deallocate(wrk_send_2d)
+ end subroutine parallel_read_fv3_step2
+
+ subroutine fill_regional_2d(fld_in,fld_out)
+ !$$$ subprogram documentation block
+ ! . . . .
+ ! subprogram: fill_regional_2d
+ ! prgmmr: mizzi org: ncar/mmm date: 2010-08-11
+ !
+ ! abstract: create a column vector for the subdomain (including halo)
+ ! from global 2d grid.
+ !
+ !
+ ! program history log:
+ ! 2010-08-11 parrish, initial documentation
+ ! 2012-03-12 whitaker, remove nx,ny,itotsub from argument list.
+ !
+ ! input argument list:
+ !
+ ! output argument list:
+ !
+ ! attributes:
+ ! language: f90
+ ! machine: ibm RS/6000 SP
+ !
+ !$$$ end documentation block
+ use kinds, only: r_kind,i_kind
+ use hybrid_ensemble_parameters, only: grd_ens
+ implicit none
+ real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon)::fld_in
+ real(r_kind),dimension(grd_ens%itotsub)::fld_out
+ integer(i_kind):: i,j,k
+ do k=1,grd_ens%itotsub
+ i=grd_ens%ltosj_s(k)
+ j=grd_ens%ltosi_s(k)
+ fld_out(k)=fld_in(j,i)
+ enddo
+ return
+ end subroutine fill_regional_2d
+
subroutine ens_spread_dualres_regional_fv3_regional(this,mype,en_perts,nelen)
!$$$ subprogram documentation block
! . . . .
@@ -914,7 +1513,7 @@ subroutine ens_spread_dualres_regional_fv3_regional(this,mype,en_perts,nelen)
call stop2(9999)
endif
- sp_norm=(one/float(n_ens))
+ sp_norm=one/real(n_ens,r_kind)
sube%values=zero
!
diff --git a/src/gsi/cplr_get_pseudo_ensperts.f90 b/src/gsi/cplr_get_pseudo_ensperts.f90
index 9d12165409..f9566c1f45 100644
--- a/src/gsi/cplr_get_pseudo_ensperts.f90
+++ b/src/gsi/cplr_get_pseudo_ensperts.f90
@@ -487,7 +487,7 @@ subroutine get_pseudo_ensperts_wrf(this,en_perts,nelen)
deallocate(blend)
! Convert to mean
- bar_norm = one/float(n_ens)
+ bar_norm = one/real(n_ens,r_kind)
en_bar%values=en_bar%values*bar_norm
if(write_ens_sprd)then
@@ -1064,15 +1064,15 @@ subroutine get_bgtc_center(bc_lon,bc_lat)
close(32)
if(sn == 'S')then
- clat=- one * float(iclat)/10.0_r_kind
+ clat=- one * real(iclat,r_kind)/10.0_r_kind
else
- clat=float(iclat)/10.0_r_kind
+ clat=real(iclat,r_kind)/10.0_r_kind
endif
if(ew == 'W')then
- clon=360._r_kind - float(iclon)/10.0_r_kind
+ clon=360._r_kind - real(iclon,r_kind)/10.0_r_kind
else
- clon=float(iclon)/10.0_r_kind
+ clon=real(iclon,r_kind)/10.0_r_kind
endif
diff --git a/src/gsi/cplr_get_wrf_mass_ensperts.f90 b/src/gsi/cplr_get_wrf_mass_ensperts.f90
index 775c9c4195..7b6b3b9aa1 100644
--- a/src/gsi/cplr_get_wrf_mass_ensperts.f90
+++ b/src/gsi/cplr_get_wrf_mass_ensperts.f90
@@ -480,7 +480,7 @@ subroutine get_wrf_mass_ensperts_wrf(this,en_perts,nelen,ps_bar)
!
! CALCULATE ENSEMBLE MEAN
- bar_norm = one/float(n_ens)
+ bar_norm = one/real(n_ens,r_kind)
en_bar%values=en_bar%values*bar_norm
! Copy pbar to module array. ps_bar may be needed for vertical localization
@@ -2189,7 +2189,7 @@ subroutine ens_spread_dualres_regional_wrf(this,mype,en_perts,nelen,en_bar)
call stop2(999)
endif
- sp_norm=(one/float(n_ens))
+ sp_norm=one/real(n_ens,r_kind)
sube%values=zero
!
diff --git a/src/gsi/cplr_get_wrf_nmm_ensperts.f90 b/src/gsi/cplr_get_wrf_nmm_ensperts.f90
index 3e30822639..c9179eedb9 100644
--- a/src/gsi/cplr_get_wrf_nmm_ensperts.f90
+++ b/src/gsi/cplr_get_wrf_nmm_ensperts.f90
@@ -859,7 +859,7 @@ subroutine get_wrf_nmm_ensperts_wrf(this,en_perts,nelen,region_lat_ens,region_lo
!
! CALCULATE ENSEMBLE MEAN
- bar_norm = one/float(n_ens)
+ bar_norm = one/real(n_ens,r_kind)
en_bar%values=en_bar%values*bar_norm
! Copy pbar to module array. ps_bar may be needed for vertical localization
diff --git a/src/gsi/cplr_gfs_ensmod.f90 b/src/gsi/cplr_gfs_ensmod.f90
index c16c0e8c0e..55ac32fce4 100644
--- a/src/gsi/cplr_gfs_ensmod.f90
+++ b/src/gsi/cplr_gfs_ensmod.f90
@@ -16,12 +16,23 @@ module get_gfs_ensmod_mod
! machine: ibm RS/6000 SP
!
!$$$
+ use kinds, only: i_kind,r_kind,r_single
use mpeu_util, only: die
use mpimod, only: mype,npe
use abstract_ensmod, only: this_ens_class => abstractEnsemble
+ use genex_mod, only: genex_info
implicit none
private
+
+ integer(i_kind) :: ias,iae,iasm,iaem,iaemz,jas,jae,jasm,jaem,jaemz
+ integer(i_kind) :: kas,kae,kasm,kaem,kaemz,mas,mae,masm,maem,maemz
+ integer(i_kind) :: ibs,ibe,ibsm,ibem,ibemz,jbs,jbe,jbsm,jbem,jbemz
+ integer(i_kind) :: kbs,kbe,kbsm,kbem,kbemz,mbs,mbe,mbsm,mbem,mbemz
+ integer(i_kind) :: icw,iql,iqi,iqr,iqs,iqg
+ integer(i_kind) :: n2d
+ type(genex_info) :: s_a2b
+
public :: ensemble
public :: ensemble_typemold
@@ -84,7 +95,6 @@ subroutine get_gfs_Nens(this,grd,members,ntindex,atm_bundle,iret)
!
!$$$
- use kinds, only: i_kind,r_kind,r_single
use gridmod, only: use_gfs_nemsio, use_gfs_ncio
use general_sub2grid_mod, only: sub2grid_info
use hybrid_ensemble_parameters, only: ens_fast_read
@@ -153,10 +163,10 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, &
!
! input argument list:
! ntindex - time index for ensemble
-! ens_atm_bundle - atm bundle w/ fields for ensemble
+! atm_bundle - atm bundle w/ fields for ensemble
!
! output argument list:
-! ens_atm_bundle - atm bundle w/ fields for ensemble
+! atm_bundle - atm bundle w/ fields for ensemble
! iret - return code, 0 for successful read.
!
! attributes:
@@ -166,18 +176,18 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, &
!$$$
use mpimod, only: mpi_comm_world,ierror,mpi_real8,mpi_integer4,mpi_max
- use kinds, only: i_kind,r_single,r_kind
use constants, only: zero
use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_destroy_info
use gsi_4dvar, only: ens_fhrlevs
use gsi_bundlemod, only: gsi_bundle
- use hybrid_ensemble_parameters, only: n_ens,grd_ens
+ use gsi_bundlemod, only : assignment(=)
+ use hybrid_ensemble_parameters, only: n_ens,grd_ens,ntlevs_ens
use hybrid_ensemble_parameters, only: ensemble_path
- use control_vectors, only: nc2d,nc3d
- !use control_vectors, only: cvars2d,cvars3d
- use genex_mod, only: genex_info,genex_create_info,genex,genex_destroy_info
+ use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d
+ use genex_mod, only: genex_create_info,genex,genex_destroy_info
use gridmod, only: use_gfs_nemsio
use jfunc, only: cnvw_option
+ use mpeu_util, only: getindex
implicit none
@@ -193,18 +203,13 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, &
character(len=*),parameter :: myname_='get_user_ens_gfs_fastread_'
character(len=70) :: filename
character(len=70) :: filenamesfc
- integer(i_kind) :: i,ii,j,jj,k,n
+ integer(i_kind) :: i,ii,j,k,n
integer(i_kind) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens
- integer(i_kind) :: ip,ips,ipe,jps,jpe
- integer(i_kind) :: ias,iae,iasm,iaem,iaemz,jas,jae,jasm,jaem,jaemz
- integer(i_kind) :: kas,kae,kasm,kaem,kaemz,mas,mae,masm,maem,maemz
- integer(i_kind) :: ibs,ibe,ibsm,ibem,ibemz,jbs,jbe,jbsm,jbem,jbemz
- integer(i_kind) :: kbs,kbe,kbsm,kbem,kbemz,mbs,mbe,mbsm,mbem,mbemz
- integer(i_kind) :: n2d
+ integer(i_kind) :: ip
integer(i_kind) :: nlon,nlat,nsig
- type(genex_info) :: s_a2b
+ integer(i_kind),dimension(n_ens) :: io_pe0,iretx
real(r_single),allocatable,dimension(:,:,:,:) :: en_full,en_loc
- real(r_kind),allocatable,dimension(:,:,:) :: en_loc3
+ real(r_single),allocatable,dimension(:,:,:) :: sloc
integer(i_kind),allocatable,dimension(:) :: m_cvars2dw,m_cvars3dw
integer(i_kind) :: m_cvars2d(nc2d),m_cvars3d(nc3d)
type(sub2grid_info) :: grd3d
@@ -214,61 +219,72 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, &
nlon=grd_ens%nlon
nsig=grd_ens%nsig
+ if(ntindex == 1)then
! set up partition of available processors for parallel read
- if ( n_ens > npe ) &
- call die(myname_, ': ***ERROR*** CANNOT READ ENSEMBLE n_ens > npe, increase npe >= n_ens', 99)
+ if ( n_ens > npe ) &
+ call die(myname_, ': ***ERROR*** CANNOT READ ENSEMBLE n_ens > npe, increase npe >= n_ens', 99)
- call ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens)
- ! setup communicator for scatter to subdomains:
+ call ens_io_partition_(n_ens,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,io_pe0,i_ens)
- ! first, define gsi subdomain boundaries in global units:
-
- ip=1 ! halo width is hardwired at 1
- ips=grd_ens%istart(mype+1)
- ipe=ips+grd_ens%lat1-1
- jps=grd_ens%jstart(mype+1)
- jpe=jps+grd_ens%lon1-1
+ ! setup communicator for scatter to subdomains:
+ ! first, define gsi subdomain boundaries in global units:
!!!!!!!!!!!!NOTE--FOLLOWING HAS MANY VARS TO BE DEFINED--NLAT,NLON ARE ENSEMBLE DOMAIN DIMS
!!!!!!!!for example, n2d = nc3d*nsig + nc2d
- n2d=nc3d*grd_ens%nsig+nc2d
- ias=1 ; iae=0 ; jas=1 ; jae=0 ; kas=1 ; kae=0 ; mas=1 ; mae=0
- if(mype==io_pe) then
- iae=nlat
- jae=nlon
- kae=n2d
- mas=n_io_pe_s ; mae=n_io_pe_em
- endif
- iasm=ias ; iaem=iae ; jasm=jas ; jaem=jae ; kasm=kas ; kaem=kae ; masm=mas ; maem=mae
-
- ibs =ips ; ibe =ipe ; jbs =jps ; jbe =jpe
- ibsm=ibs-ip ; ibem=ibe+ip ; jbsm=jbs-ip ; jbem=jbe+ip
- kbs =1 ; kbe =n2d ; mbs =1 ; mbe =n_ens
- kbsm=kbs ; kbem=kbe ; mbsm=mbs ; mbem=mbe
- iaemz=max(iasm,iaem) ; jaemz=max(jasm,jaem)
- kaemz=max(kasm,kaem) ; maemz=max(masm,maem)
- ibemz=max(ibsm,ibem) ; jbemz=max(jbsm,jbem)
- kbemz=max(kbsm,kbem) ; mbemz=max(mbsm,mbem)
- call genex_create_info(s_a2b,ias ,iae ,jas ,jae ,kas ,kae ,mas ,mae , &
- ibs ,ibe ,jbs ,jbe ,kbs ,kbe ,mbs ,mbe , &
- iasm,iaem,jasm,jaem,kasm,kaem,masm,maem, &
- ibsm,ibem,jbsm,jbem,kbsm,kbem,mbsm,mbem)
-
- write(filename,22) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas
-22 format(a,'sigf',i2.2,'_ens_mem',i3.3)
+ n2d=nc3d*grd_ens%nsig+nc2d
+ ias=0 ; iae=0 ; jas=0 ; jae=0 ; kas=1 ; kae=0 ; mas=1 ; mae=0
+ if(mype==io_pe) then
+ iae=nlat+1
+ jae=nlon+1
+ kae=n2d
+ mas=n_io_pe_s ; mae=n_io_pe_em
+ endif
+ iasm=ias ; iaem=iae ; jasm=jas ; jaem=jae ; kasm=kas ; kaem=kae ; masm=mas ; maem=mae
+
+ ip=1 ! halo width is hardwired at 1
+ ibs=grd_ens%istart(mype+1)
+ ibe=ibs+grd_ens%lat1-1
+ jbs=grd_ens%jstart(mype+1)
+ jbe=jbs+grd_ens%lon1-1
+ jbs=jbs-1
+ jbe=jbe+1
+ ibs=ibs-1
+ ibe=ibe+1
+
+ ibsm=ibs ; ibem=ibe ; jbsm=jbs ; jbem=jbe
+
+ kbs =1 ; kbe =n2d ; mbs =1 ; mbe =n_ens
+ kbsm=kbs ; kbem=kbe ; mbsm=mbs ; mbem=mbe
+ iaemz=max(iasm,iaem) ; jaemz=max(jasm,jaem)
+ kaemz=max(kasm,kaem) ; maemz=max(masm,maem)
+ ibemz=max(ibsm,ibem) ; jbemz=max(jbsm,jbem)
+ kbemz=max(kbsm,kbem) ; mbemz=max(mbsm,mbem)
+ call genex_create_info(s_a2b,ias ,iae ,jas ,jae ,kas ,kae ,mas ,mae , &
+ ibs ,ibe ,jbs ,jbe ,kbs ,kbe ,mbs ,mbe , &
+ iasm,iaem,jasm,jaem,kasm,kaem,masm,maem, &
+ ibsm,ibem,jbsm,jbem,kbsm,kbem,mbsm,mbem)
+
+ if(mype==0)then
+ do n=1,n_ens
+ write(6,'(3(a,1x,i5,1x))') 'reading ensemble member', n,'on pe', io_pe0(n)
+ enddo
+ end if
+ end if
+ if(mype==0) write(6,*) ' reading time level ',ntindex
allocate(m_cvars2dw(nc2din),m_cvars3dw(nc3din))
m_cvars2dw=-999
m_cvars3dw=-999
- allocate(en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz))
-
!! read ensembles
if ( mas == mae ) then
+ allocate(en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz))
+ write(filename,22) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas
+22 format(a,'sigf',i2.2,'_ens_mem',i3.3)
if ( use_gfs_nemsio ) then
if (cnvw_option) then
write(filenamesfc,23) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas
@@ -284,50 +300,61 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, &
filename,.true.)
end if
else
- call parallel_read_gfsnc_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, &
+ call parallel_read_gfsnc_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, &
ias,jas,mas, &
iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, &
filename)
end if
+ else
+ allocate(en_full(1,1,1,1))
end if
+! scatter to subdomains:
+
call mpi_allreduce(m_cvars2dw,m_cvars2d,nc2d,mpi_integer4,mpi_max,mpi_comm_world,ierror)
call mpi_allreduce(m_cvars3dw,m_cvars3d,nc3d,mpi_integer4,mpi_max,mpi_comm_world,ierror)
-
deallocate(m_cvars2dw,m_cvars3dw)
-! scatter to subdomains:
- allocate(en_loc(ibsm:ibemz,jbsm:jbemz,kbsm:kbemz,mbsm:mbemz))
+ ! Check hydrometeors in control variables
+ icw=getindex(cvars3d,'cw')
+ iql=getindex(cvars3d,'ql')
+ iqi=getindex(cvars3d,'qi')
+ iqr=getindex(cvars3d,'qr')
+ iqs=getindex(cvars3d,'qs')
+ iqg=getindex(cvars3d,'qg')
+
+! en_loc=zero
- en_loc=zero
+ allocate(en_loc(ibsm:ibemz,jbsm:jbemz,kbsm:kbemz,mbsm:mbemz))
call genex(s_a2b,en_full,en_loc)
deallocate(en_full)
- call genex_destroy_info(s_a2b) ! check on actual routine name
-! transfer en_loc to en_loc3 then to atm_bundle
+ if(ntindex == ntlevs_ens)call genex_destroy_info(s_a2b)
- allocate(en_loc3(lat2in,lon2in,nc2d+nc3d*nsig))
- iret = 0
call create_grd23d_(grd3d,nc2d+nc3d*grd%nsig)
+
+
+ allocate(sloc(grd3d%lat2,grd3d%lon2,grd3d%num_fields))
+ iretx=0
+!$omp parallel do schedule(dynamic,1) private(n,k,j,i,sloc)
do n=1,n_ens
- do k=1,nc2d+nc3d*nsig
- jj=0
- do j=jbsm,jbem
- jj=jj+1
- ii=0
- do i=ibsm,ibem
- ii=ii+1
- en_loc3(ii,jj,k)=en_loc(i,j,k,n)
+ do k=1,grd3d%num_fields
+ do j=1,grd3d%lon2
+ do i=1,grd3d%lat2
+ sloc(i,j,k)=en_loc(i+ibsm-1,j+jbsm-1,k,n)
enddo
enddo
enddo
- call move2bundle_(grd3d,en_loc3,atm_bundle(n),m_cvars2d,m_cvars3d,iret)
+ call move2bundle_(grd3d,sloc,atm_bundle(n),m_cvars2d,m_cvars3d,iretx(n))
enddo
+ iret=iretx(1)
+ do n=2,n_ens
+ iret=iret+iretx(n)
+ end do
+ deallocate(en_loc,sloc)
call general_sub2grid_destroy_info(grd3d,grd)
- deallocate(en_loc,en_loc3)
-
end subroutine get_user_ens_gfs_fastread_
@@ -347,7 +374,7 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret)
!
! input argument list:
! grd - grd info for ensemble
-! en_loc3 - ensemble member
+! sloc - ensemble member
! atm_bundle - empty atm bundle
! m_cvars2d - maps 3rd index in en_loc3 for start of each 2d variable
! m_cvars3d - maps 3rd index in en_loc3 for start of each 3d variable
@@ -361,56 +388,36 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret)
!
!$$$
- use kinds, only: i_kind,r_kind,r_single
- use constants, only: zero,one,two,fv
use general_sub2grid_mod, only: sub2grid_info
use hybrid_ensemble_parameters, only: en_perts
use gsi_bundlemod, only: gsi_bundle
use gsi_bundlemod, only: gsi_bundlegetpointer
- use gsi_bundlemod, only : assignment(=)
use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d
- use mpeu_util, only: getindex
implicit none
! Declare passed variables
type(sub2grid_info), intent(in ) :: grd3d
- real(r_kind), intent(inout) :: en_loc3(grd3d%lat2,grd3d%lon2,nc2d+nc3d*grd3d%nsig)
type(gsi_bundle), intent(inout) :: atm_bundle
+ real(r_single), intent(inout) :: en_loc3(grd3d%lat2,grd3d%lon2,grd3d%num_fields)
integer(i_kind), intent(in ) :: m_cvars2d(nc2d),m_cvars3d(nc3d)
- integer(i_kind), intent( out) :: iret
+ integer(i_kind), intent(inout) :: iret
! Declare internal variables
character(len=*),parameter :: myname_='move2bundle_'
- character(len=70) :: filename
- integer(i_kind) :: ierr
- integer(i_kind) :: km,m
- integer(i_kind) :: icw,iql,iqi,iqr,iqs,iqg
- real(r_kind),pointer,dimension(:,:) :: ps
+ integer(i_kind) :: ierr,i,j
+ integer(i_kind) :: km1,m
+ real(r_single),pointer,dimension(:,:) :: ps
!real(r_kind),pointer,dimension(:,:) :: sst
- real(r_kind),pointer,dimension(:,:,:) :: u,v,tv,q,oz,cwmr
- real(r_kind),pointer,dimension(:,:,:) :: qlmr,qimr,qrmr,qsmr,qgmr
- real(r_kind),parameter :: r0_001 = 0.001_r_kind
+ real(r_single),pointer,dimension(:,:,:) :: u,v,tv,q,oz,cwmr
+ real(r_single),pointer,dimension(:,:,:) :: qlmr,qimr,qrmr,qsmr,qgmr
-
-!--- now update halo values of all variables using general_sub2grid
- call update_halos_(grd3d,en_loc3)
-
- ! Check hydrometeors in control variables
- icw=getindex(cvars3d,'cw')
- iql=getindex(cvars3d,'ql')
- iqi=getindex(cvars3d,'qi')
- iqr=getindex(cvars3d,'qr')
- iqs=getindex(cvars3d,'qs')
- iqg=getindex(cvars3d,'qg')
-
-! initialize atm_bundle to zero
-
- atm_bundle=zero
+! atm_bundle to zero done earlier
call gsi_bundlegetpointer(atm_bundle,'ps',ps, ierr); iret = ierr
- !call gsi_bundlegetpointer(atm_bundle,'sst',sst, ierr); iret = ierr
+ !call gsi_bundlegetpointer(atm_bundle,'sst',sst, ierr); iret = iret+ierr
+
call gsi_bundlegetpointer(atm_bundle,'sf',u , ierr); iret = ierr + iret
call gsi_bundlegetpointer(atm_bundle,'vp',v , ierr); iret = ierr + iret
call gsi_bundlegetpointer(atm_bundle,'t' ,tv, ierr); iret = ierr + iret
@@ -425,59 +432,54 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret)
if ( iret /= 0 ) then
if ( mype == 0 ) then
write(6,'(A)') trim(myname_) // ': ERROR!'
- write(6,'(A)') trim(myname_) // ': For now, GFS requires all MetFields: ps,u,v,(sf,vp)tv,q,oz,cw'
+ write(6,'(A)') trim(myname_) // ': For now, GFS requires all MetFields: ps,u,v,(sf,vp)tv,q,oz'
write(6,'(A)') trim(myname_) // ': but some have not been found. Aborting ... '
write(6,'(A)') trim(myname_) // ': WARNING!'
- write(6,'(3A,I5)') trim(myname_) // ': Trouble reading ensemble file : ', trim(filename), ', IRET = ', iret
endif
return
endif
-
do m=1,nc2d
! convert ps from Pa to cb
- if(trim(cvars2d(m))=='ps') ps=r0_001*en_loc3(:,:,m_cvars2d(m))
+ if(trim(cvars2d(m))=='ps') ps=en_loc3(:,:,m_cvars2d(m))
! if(trim(cvars2d(m))=='sst') sst=en_loc3(:,:,m_cvars2d(m)) !no sst for now
enddo
- km = en_perts(1,1,1)%grid%km
-!$omp parallel do schedule(dynamic,1) private(m)
+ km1 = en_perts(1,1,1)%grid%km - 1
do m=1,nc3d
if(trim(cvars3d(m))=='sf')then
- u = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km)
+ u = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1)
else if(trim(cvars3d(m))=='vp') then
- v = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km)
+ v = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1)
else if(trim(cvars3d(m))=='t') then
- tv = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km)
+! Note tv here is sensible temperature. Converted to virtual temperature
+! later.
+ tv = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1)
else if(trim(cvars3d(m))=='q') then
- q = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km)
+ q = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1)
else if(trim(cvars3d(m))=='oz') then
- oz = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km)
+ oz = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1)
else if(trim(cvars3d(m))=='cw') then
- cwmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km)
+ cwmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1)
else if(trim(cvars3d(m))=='ql') then
- qlmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km)
+ qlmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1)
else if(trim(cvars3d(m))=='qi') then
- qimr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km)
+ qimr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1)
else if(trim(cvars3d(m))=='qr') then
- qrmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km)
+ qrmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1)
else if(trim(cvars3d(m))=='qs') then
- qsmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km)
+ qsmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1)
else if(trim(cvars3d(m))=='qg') then
- qgmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km)
+ qgmr = en_loc3(:,:,m_cvars3d(m):m_cvars3d(m)+km1)
end if
enddo
-! convert t to virtual temperature
- tv=tv*(one+fv*q)
-
return
end subroutine move2bundle_
subroutine create_grd23d_(grd23d,nvert)
- use kinds, only: i_kind
use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info
use hybrid_ensemble_parameters, only: grd_ens
@@ -498,83 +500,28 @@ subroutine create_grd23d_(grd23d,nvert)
end subroutine create_grd23d_
-subroutine update_halos_(grd,s)
-
- use kinds, only: i_kind,r_kind
- use general_sub2grid_mod, only: sub2grid_info,general_sub2grid,general_grid2sub
-
- implicit none
-
- ! Declare passed variables
- type(sub2grid_info), intent(in ) :: grd
- real(r_kind), intent(inout) :: s(grd%lat2,grd%lon2,grd%num_fields)
-
- ! Declare local variables
- integer(i_kind) inner_vars,lat2,lon2,nlat,nlon,nvert,kbegin_loc,kend_loc,kend_alloc
- integer(i_kind) ii,i,j,k
- real(r_kind),allocatable,dimension(:) :: sloc
- real(r_kind),allocatable,dimension(:,:,:,:) :: work
-
- lat2=grd%lat2
- lon2=grd%lon2
- nlat=grd%nlat
- nlon=grd%nlon
- nvert=grd%num_fields
- inner_vars=grd%inner_vars
- kbegin_loc=grd%kbegin_loc
- kend_loc=grd%kend_loc
- kend_alloc=grd%kend_alloc
- allocate(sloc(lat2*lon2*nvert))
- allocate(work(inner_vars,nlat,nlon,kbegin_loc:kend_alloc))
- ii=0
- do k=1,nvert
- do j=1,lon2
- do i=1,lat2
- ii=ii+1
- sloc(ii)=s(i,j,k)
- enddo
- enddo
- enddo
- call general_sub2grid(grd,sloc,work)
-
- call general_grid2sub(grd,work,sloc)
- ii=0
- do k=1,nvert
- do j=1,lon2
- do i=1,lat2
- ii=ii+1
- s(i,j,k)=sloc(ii)
- enddo
- enddo
- enddo
-
- deallocate(sloc,work)
-
-end subroutine update_halos_
-
-subroutine ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens)
+subroutine ens_io_partition_(n_ens,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,io_pe0,i_ens)
! do computation on all processors, then assign final local processor
! values.
- use kinds, only: r_kind,i_kind
use constants, only: half
implicit none
! Declare passed variables
- integer(i_kind),intent(in ) :: n_ens,ntindex
+ integer(i_kind),intent(in ) :: n_ens
integer(i_kind),intent( out) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens
+ integer(i_kind),intent( out) :: io_pe0(n_ens)
! Declare local variables
- integer(i_kind) :: io_pe0(n_ens)
integer(i_kind) :: iskip,jskip,nextra,ipe,n
integer(i_kind) :: nsig
i_ens=-1
nsig=1
iskip=npe/n_ens
- nextra=npe-iskip*n_ens
+ nextra=npe-iskip*(n_ens-1)-1
jskip=iskip
io_pe=-1
io_pe0=-1
@@ -589,13 +536,12 @@ subroutine ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,
else
jskip=iskip
endif
+ if(ipe > npe) then
+ write(6,*)' ens_io_partition_: ***ERROR*** ',ipe,jskip,' processor error: PROGRAM STOPS'
+ call stop2(999)
+ end if
ipe=ipe+jskip
enddo
- if(mype==0)then
- do n=1,n_ens
- write(6,'(3(a,1x,i5,1x))') 'reading ensemble member', n,' time level',ntindex,'on pe', io_pe0(n)
- enddo
- end if
do n=1,n_ens
if(mype==io_pe0(n)) then
@@ -609,12 +555,11 @@ subroutine ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,
end subroutine ens_io_partition_
-subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig, &
+subroutine parallel_read_nemsio_state_(en_full,m_cvars2dw,m_cvars3d,nlon,nlat,nsig, &
ias,jas,mas, &
iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, &
filename,init_head,filenamesfc)
- use kinds, only: i_kind,r_kind,r_single
use constants, only: r60,r3600,zero,one,half,deg2rad
use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close
use ncepnems_io, only: error_msg,imp_physics
@@ -632,7 +577,7 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi
integer(i_kind), intent(in ) :: nlon,nlat,nsig
integer(i_kind), intent(in ) :: ias,jas,mas
integer(i_kind), intent(in ) :: iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz
- integer(i_kind), intent(inout) :: m_cvars2d(nc2d),m_cvars3d(nc3d)
+ integer(i_kind), intent(inout) :: m_cvars2dw(nc2d),m_cvars3d(nc3d)
real(r_single), intent(inout) :: en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz)
character(len=*), intent(in ) :: filename
character(len=*), optional, intent(in) :: filenamesfc
@@ -641,7 +586,6 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi
! Declare local variables
integer(i_kind) i,ii,j,jj,k,lonb,latb,levs,latb2,lonb2
integer(i_kind) k2,k3,k3u,k3v,k3t,k3q,k3cw,k3oz,kf
- integer(i_kind) k3ql,k3qi,k3qr,k3qs,k3qg
integer(i_kind) iret
integer(i_kind) :: istop = 101
integer(i_kind),dimension(7):: idate
@@ -717,7 +661,8 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi
enddo
deallocate(rlons)
- fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
odate(3) = idate(3) !day
@@ -726,23 +671,40 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi
allocate(work(nlon*(nlat-2)))
if (imp_physics == 11) allocate(work2(nlon*(nlat-2)))
allocate(temp3(nlat,nlon,nsig,nc3d))
- allocate(temp2(nlat,nlon,nc2d))
+ temp3=zero
k3u=0 ; k3v=0 ; k3t=0 ; k3q=0 ; k3cw=0 ; k3oz=0
- k3ql=0; k3qi=0; k3qr=0; k3qs=0; k3qg=0
do k3=1,nc3d
- if(cvars3d(k3)=='sf') k3u=k3
- if(cvars3d(k3)=='vp') k3v=k3
- if(cvars3d(k3)=='t') k3t=k3
- if(cvars3d(k3)=='q') k3q=k3
- if(cvars3d(k3)=='cw') k3cw=k3
- if(cvars3d(k3)=='oz') k3oz=k3
- if(cvars3d(k3)=='ql') k3ql=k3
- if(cvars3d(k3)=='qi') k3qi=k3
- if(cvars3d(k3)=='qr') k3qr=k3
- if(cvars3d(k3)=='qs') k3qs=k3
- if(cvars3d(k3)=='qg') k3qg=k3
do k=1,nsig
- if(trim(cvars3d(k3))=='cw') then
+ if(trim(cvars3d(k3))=='t') then
+ k3t=k3
+ call nemsio_readrecv(gfile,'tmp','mid layer',k,work,iret=iret)
+ if (iret /= 0) call error_msg(trim(myname_),trim(filename),'tmp','read',istop+3,iret,.true.)
+ call move1_(work,temp3(:,:,k,k3),nlon,nlat)
+ call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
+ elseif(trim(cvars3d(k3))=='sf') then
+ k3u=k3
+ call nemsio_readrecv(gfile,'ugrd','mid layer',k,work,iret=iret)
+ if (iret /= 0) call error_msg(trim(myname_),trim(filename),'ugrd','read',istop+1,iret,.true.)
+ call move1_(work,temp3(:,:,k,k3),nlon,nlat)
+ elseif(trim(cvars3d(k3))=='vp') then
+ k3v=k3
+ call nemsio_readrecv(gfile,'vgrd','mid layer',k,work,iret=iret)
+ if (iret /= 0) call error_msg(trim(myname_),trim(filename),'vgrd','read',istop+2,iret,.true.)
+ call move1_(work,temp3(:,:,k,k3),nlon,nlat)
+ elseif(trim(cvars3d(k3))=='q') then
+ k3q=k3
+ call nemsio_readrecv(gfile,'spfh','mid layer',k,work,iret=iret)
+ if (iret /= 0) call error_msg(trim(myname_),trim(filename),trim(cvars3d(k3)),'read',istop+4,iret,.true.)
+ call move1_(work,temp3(:,:,k,k3),nlon,nlat)
+ call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
+ elseif(trim(cvars3d(k3))=='oz') then
+ k3oz=k3
+ call nemsio_readrecv(gfile,'o3mr','mid layer',k,work,iret=iret)
+ if (iret /= 0) call error_msg(trim(myname_),trim(filename),'o3mr','read',istop+5,iret,.true.)
+ call move1_(work,temp3(:,:,k,k3),nlon,nlat)
+ call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
+ elseif(trim(cvars3d(k3))=='cw') then
+ k3cw=k3
call nemsio_readrecv(gfile,'clwmr','mid layer',k,work,iret=iret)
if (iret /= 0) call error_msg(trim(myname_),trim(filename),'clwmr','read',istop+6,iret,.true.)
if (imp_physics == 11) then
@@ -789,30 +751,7 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi
if (iret /= 0) call error_msg(trim(myname_),trim(filename),'grle','read',istop+12,iret)
call move1_(work,temp3(:,:,k,k3),nlon,nlat)
call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- elseif(trim(cvars3d(k3))=='oz') then
- call nemsio_readrecv(gfile,'o3mr','mid layer',k,work,iret=iret)
- if (iret /= 0) call error_msg(trim(myname_),trim(filename),'o3mr','read',istop+5,iret,.true.)
- call move1_(work,temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- elseif(trim(cvars3d(k3))=='q') then
- call nemsio_readrecv(gfile,'spfh','mid layer',k,work,iret=iret)
- if (iret /= 0) call error_msg(trim(myname_),trim(filename),trim(cvars3d(k3)),'read',istop+4,iret,.true.)
- call move1_(work,temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- elseif(trim(cvars3d(k3))=='t') then
- call nemsio_readrecv(gfile,'tmp','mid layer',k,work,iret=iret)
- if (iret /= 0) call error_msg(trim(myname_),trim(filename),'tmp','read',istop+3,iret,.true.)
- call move1_(work,temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- elseif(trim(cvars3d(k3))=='sf') then
- call nemsio_readrecv(gfile,'ugrd','mid layer',k,work,iret=iret)
- if (iret /= 0) call error_msg(trim(myname_),trim(filename),'ugrd','read',istop+1,iret,.true.)
- call move1_(work,temp3(:,:,k,k3),nlon,nlat)
- elseif(trim(cvars3d(k3))=='vp') then
- call nemsio_readrecv(gfile,'vgrd','mid layer',k,work,iret=iret)
- if (iret /= 0) call error_msg(trim(myname_),trim(filename),'vgrd','read',istop+2,iret,.true.)
- call move1_(work,temp3(:,:,k,k3),nlon,nlat)
- endif
+ end if
enddo
enddo
do k=1,nsig
@@ -822,10 +761,41 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi
if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3oz==0) &
write(6,'(" WARNING, problem with one of k3-")')
+! move temp3 to en_full
+ kf=0
+ do k3=1,nc3d
+ m_cvars3d(k3)=kf+1
+ do k=1,nsig
+ kf=kf+1
+ jj=jas
+ do j=1,nlon
+ jj=jj+1
+ ii=ias
+ do i=1,nlat
+ ii=ii+1
+ en_full(ii,jj,kf,mas)=temp3(i,j,k,k3)
+ enddo
+ enddo
+ ii=ias
+ do i=1,nlat
+ ii=ii+1
+ en_full(ii,jasm,kf,mas)=en_full(ii,jaem-1,kf,mas)
+ en_full(ii,jaem,kf,mas)=en_full(ii,jasm+1,kf,mas)
+ enddo
+ jj=jas-1
+ do j=jasm,jaem
+ jj=jj+1
+ en_full(iasm,jj,kf,mas)=en_full(iasm+1,jj,kf,mas)
+ en_full(iaem,jj,kf,mas)=en_full(iaem-1,jj,kf,mas)
+ end do
+ enddo
+ enddo
+ deallocate(temp3)
! convert T to Tv: postpone this calculation
! temp3(:,:,:,k3t)=temp3(:,:,:,k3t)*(one+fv*temp3(:,:,:,k3q))
+ allocate(temp2(nlat,nlon,nc2d))
temp2=zero
do k2=1,nc2d
!if(trim(cvars2d(k2))=='sst') then
@@ -844,43 +814,38 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi
deallocate(work)
if (imp_physics == 11) deallocate(work2)
-! move temp2,temp3 to en_full
- kf=0
- do k3=1,nc3d
- m_cvars3d(k3)=kf+1
- do k=1,nsig
- kf=kf+1
- jj=jas-1
- do j=1,nlon
- jj=jj+1
- ii=ias-1
- do i=1,nlat
- ii=ii+1
- en_full(ii,jj,kf,mas)=temp3(i,j,k,k3)
- enddo
- enddo
- enddo
- enddo
- deallocate(temp3)
+! move temp2 to en_full
do k2=1,nc2d
- m_cvars2d(k2)=kf+1
+ m_cvars2dw(k2)=kf+1
kf=kf+1
- jj=jas-1
+ jj=jas
do j=1,nlon
jj=jj+1
- ii=ias-1
+ ii=ias
do i=1,nlat
ii=ii+1
en_full(ii,jj,kf,mas)=temp2(i,j,k2)
enddo
enddo
+ ii=ias
+ do i=1,nlat
+ ii=ii+1
+ en_full(ii,jasm,kf,mas)=en_full(ii,jaem-1,kf,mas)
+ en_full(ii,jaem,kf,mas)=en_full(ii,jasm+1,kf,mas)
+ enddo
+ jj=jas-1
+ do j=jasm,jaem
+ jj=jj+1
+ en_full(iasm,jj,kf,mas)=en_full(iasm+1,jj,kf,mas)
+ en_full(iaem,jj,kf,mas)=en_full(iaem-1,jj,kf,mas)
+ end do
enddo
deallocate(temp2)
end subroutine parallel_read_nemsio_state_
-subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig, &
+subroutine parallel_read_gfsnc_state_(en_full,m_cvars2dw,m_cvars3d,nlon,nlat,nsig, &
ias,jas,mas, &
iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, &
filename)
@@ -894,8 +859,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig
!
!$$$
- use kinds, only: i_kind,r_kind,r_single
- use constants, only: r60,r3600,zero,one,half,deg2rad
+ use constants, only: r60,r3600,zero,one,half,deg2rad,zero_single
use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d
use general_sub2grid_mod, only: sub2grid_info
use module_ncio, only: Dataset, Variable, Dimension, open_dataset,&
@@ -909,7 +873,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig
integer(i_kind), intent(in ) :: nlon,nlat,nsig
integer(i_kind), intent(in ) :: ias,jas,mas
integer(i_kind), intent(in ) :: iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz
- integer(i_kind), intent(inout) :: m_cvars2d(nc2d),m_cvars3d(nc3d)
+ integer(i_kind), intent(inout) :: m_cvars2dw(nc2d),m_cvars3d(nc3d)
real(r_single), intent(inout) :: en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz)
character(len=*), intent(in ) :: filename
@@ -917,7 +881,6 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig
logical :: file_exist
integer(i_kind) i,ii,j,jj,k,lonb,latb,levs,kr,ierror
integer(i_kind) k2,k3,k3u,k3v,k3t,k3q,k3cw,k3oz,kf
- integer(i_kind) k3ql,k3qi,k3qr,k3qs,k3qg
character(len=120) :: myname_ = 'parallel_read_gfsnc_state_'
real(r_single),allocatable,dimension(:,:,:) :: rwork3d1, rwork3d2
real(r_single),allocatable,dimension(:,:) :: temp2,rwork2d
@@ -935,12 +898,12 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig
call die(myname_, ': ***FATAL ERROR*** insufficient ens fcst for hybrid',999)
endif
+ ierror=0
! If file exists, open and process
atmges = open_dataset(filename,errcode=ierror)
if (ierror /=0) then
- write(6,*)' PARALLEL_READ_GFSNC_STATE: ***FATAL ERROR*** problem reading ',&
- trim(filename),' ierror= ',ierror,' PROGRAM STOPS'
- call die(myname_, ': ***FATAL ERROR*** problem reading ens fcst',999)
+ write(6,*)' PARALLEL_READ_GFSNC_STATE: ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS'
+ call stop2(999)
endif
! get dimension sizes
ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len
@@ -969,9 +932,20 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig
allocate(rwork3d1(nlon,(nlat-2),nsig))
allocate(temp3(nlat,nlon,nsig,nc3d))
k3u=0 ; k3v=0 ; k3t=0 ; k3q=0 ; k3cw=0 ; k3oz=0
- k3ql=0; k3qi=0; k3qr=0; k3qs=0; k3qg=0
do k3=1,nc3d
- if (trim(cvars3d(k3))=='cw') then
+ if(trim(cvars3d(k3))=='t') then
+ k3t=k3
+ call read_vardata(atmges, 'tmp', rwork3d1)
+ else if(trim(cvars3d(k3))=='sf') then
+ k3u=k3
+ call read_vardata(atmges, 'ugrd', rwork3d1)
+ else if(trim(cvars3d(k3))=='vp') then
+ k3v=k3
+ call read_vardata(atmges, 'vgrd', rwork3d1)
+ else if(trim(cvars3d(k3))=='q') then
+ k3q=k3
+ call read_vardata(atmges, 'spfh', rwork3d1)
+ else if (trim(cvars3d(k3))=='cw') then
k3cw=k3
call read_vardata(atmges, 'clwmr', rwork3d1)
allocate(rwork3d2(nlon,(nlat-2),nsig))
@@ -979,90 +953,25 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig
call read_vardata(atmges, 'icmr', rwork3d2)
rwork3d1 = rwork3d1 + rwork3d2
deallocate(rwork3d2)
- do k=1,nsig
- kr = levs+1-k
- call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- end do
+ else if(trim(cvars3d(k3))=='oz') then
+ k3oz=k3
+ call read_vardata(atmges, 'o3mr', rwork3d1)
else if(trim(cvars3d(k3))=='ql') then
- k3ql=k3
call read_vardata(atmges, 'clwmr', rwork3d1)
- do k=1,nsig
- kr = levs+1-k
- call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- end do
else if(trim(cvars3d(k3))=='qi') then
- k3qi=k3
call read_vardata(atmges, 'icmr', rwork3d1)
- do k=1,nsig
- kr = levs+1-k
- call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- end do
else if(trim(cvars3d(k3))=='qr') then
- k3qr=k3
call read_vardata(atmges, 'rwmr', rwork3d1)
- do k=1,nsig
- kr = levs+1-k
- call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- end do
else if(trim(cvars3d(k3))=='qs') then
- k3qs=k3
call read_vardata(atmges, 'snmr', rwork3d1)
- do k=1,nsig
- kr = levs+1-k
- call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- end do
else if(trim(cvars3d(k3))=='qg') then
- k3qg=k3
call read_vardata(atmges, 'grle', rwork3d1)
- do k=1,nsig
- kr = levs+1-k
- call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- end do
- else if(trim(cvars3d(k3))=='oz') then
- k3oz=k3
- call read_vardata(atmges, 'o3mr', rwork3d1)
- do k=1,nsig
- kr = levs+1-k
- call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- end do
- else if(trim(cvars3d(k3))=='q') then
- k3q=k3
- call read_vardata(atmges, 'spfh', rwork3d1)
- do k=1,nsig
- kr = levs+1-k
- call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- end do
- else if(trim(cvars3d(k3))=='t') then
- k3t=k3
- call read_vardata(atmges, 'tmp', rwork3d1)
- do k=1,nsig
- kr = levs+1-k
- call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
- call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
- end do
- else if(trim(cvars3d(k3))=='sf') then
- k3u=k3
- call read_vardata(atmges, 'ugrd', rwork3d1)
- do k=1,nsig
- kr = levs+1-k
- call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
- end do
- else if(trim(cvars3d(k3))=='vp') then
- k3v=k3
- call read_vardata(atmges, 'vgrd', rwork3d1)
- do k=1,nsig
- kr = levs+1-k
- call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
- end do
end if
+!$omp parallel do schedule(dynamic,1) private(k,kr)
+ do k=1,nsig
+ kr = levs+1-k
+ call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat)
+ end do
enddo
deallocate(rwork3d1)
@@ -1070,52 +979,84 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig
if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3oz==0) &
write(6,'(" WARNING, problem with one of k3-")')
+!$omp parallel do schedule(dynamic,1) private(k,k3)
do k=1,nsig
call fillpoles_sv_(temp3(:,:,k,k3u),temp3(:,:,k,k3v),nlon,nlat,clons,slons)
end do
-! move temp2,temp3 to en_full
- kf=0
+! move temp3 to en_full
+!$omp parallel do schedule(dynamic,1) private(k3,k,kf,j,jj,i,ii)
do k3=1,nc3d
+ if(k3 /= k3u .and. k3 /= k3v)then
+ do k=1,nsig
+ call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat)
+ end do
+ end if
+ kf=(k3-1)*nsig
m_cvars3d(k3)=kf+1
do k=1,nsig
kf=kf+1
- jj=jas-1
+ jj=jas
do j=1,nlon
jj=jj+1
- ii=ias-1
+ ii=ias
do i=1,nlat
ii=ii+1
en_full(ii,jj,kf,mas)=temp3(i,j,k,k3)
enddo
enddo
+ ii=ias
+ do i=1,nlat
+ ii=ii+1
+ en_full(ii,jasm,kf,mas)=en_full(ii,jaem-1,kf,mas)
+ en_full(ii,jaem,kf,mas)=en_full(ii,jasm+1,kf,mas)
+ enddo
+ jj=jas-1
+ do j=jasm,jaem
+ jj=jj+1
+ en_full(iasm,jj,kf,mas)=en_full(iasm+1,jj,kf,mas)
+ en_full(iaem,jj,kf,mas)=en_full(iaem-1,jj,kf,mas)
+ end do
enddo
enddo
deallocate(temp3)
allocate(temp2(nlat,nlon))
allocate(rwork2d(nlon,(nlat-2)))
+ kf=nc3d*nsig
do k2=1,nc2d
if(trim(cvars2d(k2))=='ps') then
call read_vardata(atmges, 'pressfc', rwork2d)
call move1_(rwork2d,temp2,nlon,nlat)
call fillpoles_ss_(temp2,nlon,nlat)
- else
- temp2=zero
- endif
- kf=kf+1
- m_cvars2d(k2)=kf
- jj=jas-1
- do j=1,nlon
- jj=jj+1
- ii=ias-1
+! move temp2 to en_full
+ kf=kf+1
+ m_cvars2dw(k2)=kf
+ jj=jas
+ do j=1,nlon
+ jj=jj+1
+ ii=ias
+ do i=1,nlat
+ ii=ii+1
+ en_full(ii,jj,kf,mas)=temp2(i,j)
+ enddo
+ enddo
+ ii=ias
do i=1,nlat
ii=ii+1
- en_full(ii,jj,kf,mas)=temp2(i,j)
+ en_full(ii,jasm,kf,mas)=en_full(ii,jaem-1,kf,mas)
+ en_full(ii,jaem,kf,mas)=en_full(ii,jasm+1,kf,mas)
enddo
- enddo
+ jj=jas-1
+ do j=jasm,jaem
+ jj=jj+1
+ en_full(iasm,jj,kf,mas)=en_full(iasm+1,jj,kf,mas)
+ en_full(iaem,jj,kf,mas)=en_full(iaem-1,jj,kf,mas)
+ end do
+ end if
enddo
+ call close_dataset(atmges)
deallocate(rwork2d)
deallocate(temp2)
@@ -1148,7 +1089,6 @@ subroutine fillpoles_ss_(temp,nlon,nlat)
!
!$$$
- use kinds, only: i_kind,r_kind,r_single
use constants, only: zero,one
implicit none
@@ -1158,6 +1098,7 @@ subroutine fillpoles_ss_(temp,nlon,nlat)
integer(i_kind) nlatm1,i
real(r_kind) sumn,sums,rnlon
+ real(r_single) sumn_sing,sums_sing
! Compute mean along southern and northern latitudes
sumn=zero
@@ -1167,14 +1108,14 @@ subroutine fillpoles_ss_(temp,nlon,nlat)
sumn=sumn+temp(nlatm1,i)
sums=sums+temp(2,i)
end do
- rnlon=one/float(nlon)
- sumn=sumn*rnlon
- sums=sums*rnlon
+ rnlon=one/real(nlon,r_kind)
+ sumn_sing=sumn*rnlon
+ sums_sing=sums*rnlon
! Load means into local work array
do i=1,nlon
- temp(1,i) =sums
- temp(nlat,i)=sumn
+ temp(1,i) =sums_sing
+ temp(nlat,i)=sumn_sing
end do
end subroutine fillpoles_ss_
@@ -1206,16 +1147,15 @@ subroutine fillpoles_sv_(tempu,tempv,nlon,nlat,clons,slons)
!
!$$$
- use kinds, only: i_kind,r_kind,r_single
use constants, only: zero
implicit none
integer(i_kind),intent(in ) :: nlon,nlat
- real(r_single), intent(inout) :: tempu(nlat,nlon),tempv(nlat,nlon)
+ real(r_single), intent(inout) :: tempu(nlat,nlon),tempv(nlat,nlon)
real(r_kind), intent(in ) :: clons(nlon),slons(nlon)
- integer(i_kind) i
+ integer(i_kind) i,nlatm
real(r_kind) polnu,polnv,polsu,polsv
! Compute mean along southern and northern latitudes
@@ -1223,16 +1163,17 @@ subroutine fillpoles_sv_(tempu,tempv,nlon,nlat,clons,slons)
polnv=zero
polsu=zero
polsv=zero
+ nlatm=nlat-1
do i=1,nlon
- polnu=polnu+tempu(nlat-1,i)*clons(i)-tempv(nlat-1,i)*slons(i)
- polnv=polnv+tempu(nlat-1,i)*slons(i)+tempv(nlat-1,i)*clons(i)
- polsu=polsu+tempu(2,i )*clons(i)+tempv(2,i )*slons(i)
- polsv=polsv+tempu(2,i )*slons(i)-tempv(2,i )*clons(i)
+ polnu=polnu+tempu(nlatm,i)*clons(i)-tempv(nlatm,i)*slons(i)
+ polnv=polnv+tempu(nlatm,i)*slons(i)+tempv(nlatm,i)*clons(i)
+ polsu=polsu+tempu(2,i )*clons(i)+tempv(2,i )*slons(i)
+ polsv=polsv+tempu(2,i )*slons(i)-tempv(2,i )*clons(i)
end do
- polnu=polnu/float(nlon)
- polnv=polnv/float(nlon)
- polsu=polsu/float(nlon)
- polsv=polsv/float(nlon)
+ polnu=polnu/real(nlon,r_kind)
+ polnv=polnv/real(nlon,r_kind)
+ polsu=polsu/real(nlon,r_kind)
+ polsv=polsv/real(nlon,r_kind)
do i=1,nlon
tempu(nlat,i)= polnu*clons(i)+polnv*slons(i)
tempv(nlat,i)=-polnu*slons(i)+polnv*clons(i)
@@ -1267,7 +1208,6 @@ subroutine move1_(work,temp,nlon,nlat)
!
!$$$
- use kinds, only: i_kind,r_kind,r_single
use constants, only: zero
implicit none
@@ -1317,7 +1257,6 @@ subroutine get_gfs_ens(this,grd,member,ntindex,atm_bundle,iret)
!
!$$$
- use kinds, only: i_kind,r_kind
use gridmod, only: use_gfs_nemsio, use_gfs_ncio
use general_sub2grid_mod, only: sub2grid_info
use gsi_4dvar, only: ens_fhrlevs
@@ -1421,7 +1360,6 @@ subroutine put_gfs_ens(this,grd,member,ntindex,pert,iret)
!
!$$$
- use kinds, only: i_kind
use general_sub2grid_mod, only: sub2grid_info
use gsi_bundlemod, only: gsi_bundle
use gsi_4dvar, only: ens_fhrlevs
@@ -1484,7 +1422,6 @@ end subroutine put_gfs_ens
subroutine non_gaussian_ens_grid_gfs(this,elats,elons)
- use kinds, only: r_kind
use hybrid_ensemble_parameters, only: sp_ens
implicit none
@@ -1516,7 +1453,6 @@ end subroutine non_gaussian_ens_grid_gfs
subroutine create_sub2grid_info(s2gi,nsig,npe,s2gi_ref)
!> Create temporary communication information object for read ensemble routines
- use kinds, only: i_kind
use gridmod, only: regional
use general_sub2grid_mod, only: sub2grid_info
use general_sub2grid_mod, only: general_sub2grid_create_info
diff --git a/src/gsi/cplr_gfs_nstmod.f90 b/src/gsi/cplr_gfs_nstmod.f90
index b482085aac..220fa55af1 100644
--- a/src/gsi/cplr_gfs_nstmod.f90
+++ b/src/gsi/cplr_gfs_nstmod.f90
@@ -139,15 +139,15 @@ subroutine deter_nst_(dlat_earth,dlon_earth,obstime,zob,tref,dtw,dtc,tz_tr)
integer(i_kind):: itnst,itnstp
integer(i_kind):: ix,iy,ixp,iyp,j
real(r_kind):: dx,dy,dx1,dy1,w00,w10,w01,w11,dtnst,dtnstp
- real(r_kind):: tref_00,tref_01,tref_10,tref_11,tr_tmp
- real(r_kind):: dt_cool_00,dt_cool_01,dt_cool_10,dt_cool_11
- real(r_kind):: z_c_00,z_c_01,z_c_10,z_c_11
- real(r_kind):: dt_warm_00,dt_warm_01,dt_warm_10,dt_warm_11
- real(r_kind):: z_w_00,z_w_01,z_w_10,z_w_11,z_w_tmp
- real(r_kind):: c_0_00,c_0_01,c_0_10,c_0_11
- real(r_kind):: c_d_00,c_d_01,c_d_10,c_d_11
- real(r_kind):: w_0_00,w_0_01,w_0_10,w_0_11
- real(r_kind):: w_d_00,w_d_01,w_d_10,w_d_11
+ real(r_kind):: tref_tt,tref2
+ real(r_kind):: dt_cool_tt
+ real(r_kind):: z_c_tt
+ real(r_kind):: dt_warm_tt
+ real(r_kind):: z_w_tt
+ real(r_kind):: c_0_tt
+ real(r_kind):: c_d_tt
+ real(r_kind):: w_0_tt
+ real(r_kind):: w_d_tt
real(r_kind):: wgtavg,dlat,dlon
logical outside
@@ -199,138 +199,137 @@ subroutine deter_nst_(dlat_earth,dlon_earth,obstime,zob,tref,dtw,dtc,tz_tr)
!
! Use the time interpolation factors for nst files
!
- tref_00 = tref_full (ix ,iy ,itnst)*dtnst + tref_full (ix ,iy ,itnstp)*dtnstp
- tref_01 = tref_full (ix ,iyp,itnst)*dtnst + tref_full (ix ,iyp,itnstp)*dtnstp
- tref_10 = tref_full (ixp,iy ,itnst)*dtnst + tref_full (ixp,iy ,itnstp)*dtnstp
- tref_11 = tref_full (ixp,iyp,itnst)*dtnst + tref_full (ixp,iyp,itnstp)*dtnstp
-
- dt_cool_00 = dt_cool_full(ix ,iy ,itnst)*dtnst + dt_cool_full(ix ,iy ,itnstp)*dtnstp
- dt_cool_01 = dt_cool_full(ix ,iyp,itnst)*dtnst + dt_cool_full(ix ,iyp,itnstp)*dtnstp
- dt_cool_10 = dt_cool_full(ixp,iy ,itnst)*dtnst + dt_cool_full(ixp,iy ,itnstp)*dtnstp
- dt_cool_11 = dt_cool_full(ixp,iyp,itnst)*dtnst + dt_cool_full(ixp,iyp,itnstp)*dtnstp
-
- z_c_00 = z_c_full (ix ,iy ,itnst)*dtnst + z_c_full (ix ,iy ,itnstp)*dtnstp
- z_c_01 = z_c_full (ix ,iyp,itnst)*dtnst + z_c_full (ix ,iyp,itnstp)*dtnstp
- z_c_10 = z_c_full (ixp,iy ,itnst)*dtnst + z_c_full (ixp,iy ,itnstp)*dtnstp
- z_c_11 = z_c_full (ixp,iyp,itnst)*dtnst + z_c_full (ixp,iyp,itnstp)*dtnstp
-
- dt_warm_00 = dt_warm_full(ix ,iy ,itnst)*dtnst + dt_warm_full(ix ,iy ,itnstp)*dtnstp
- dt_warm_01 = dt_warm_full(ix ,iyp,itnst)*dtnst + dt_warm_full(ix ,iyp,itnstp)*dtnstp
- dt_warm_10 = dt_warm_full(ixp,iy ,itnst)*dtnst + dt_warm_full(ixp,iy ,itnstp)*dtnstp
- dt_warm_11 = dt_warm_full(ixp,iyp,itnst)*dtnst + dt_warm_full(ixp,iyp,itnstp)*dtnstp
-
- z_w_00 = z_w_full (ix ,iy ,itnst)*dtnst + z_w_full (ix ,iy ,itnstp)*dtnstp
- z_w_01 = z_w_full (ix ,iyp,itnst)*dtnst + z_w_full (ix ,iyp,itnstp)*dtnstp
- z_w_10 = z_w_full (ixp,iy ,itnst)*dtnst + z_w_full (ixp,iy ,itnstp)*dtnstp
- z_w_11 = z_w_full (ixp,iyp,itnst)*dtnst + z_w_full (ixp,iyp,itnstp)*dtnstp
-
- c_0_00 = c_0_full (ix ,iy ,itnst)*dtnst + c_0_full (ix ,iy ,itnstp)*dtnstp
- c_0_01 = c_0_full (ix ,iyp,itnst)*dtnst + c_0_full (ix ,iyp,itnstp)*dtnstp
- c_0_10 = c_0_full (ixp,iy ,itnst)*dtnst + c_0_full (ixp,iy ,itnstp)*dtnstp
- c_0_11 = c_0_full (ixp,iyp,itnst)*dtnst + c_0_full (ixp,iyp,itnstp)*dtnstp
-
- c_d_00 = c_d_full (ix ,iy ,itnst)*dtnst + c_d_full (ix ,iy ,itnstp)*dtnstp
- c_d_01 = c_d_full (ix ,iyp,itnst)*dtnst + c_d_full (ix ,iyp,itnstp)*dtnstp
- c_d_10 = c_d_full (ixp,iy ,itnst)*dtnst + c_d_full (ixp,iy ,itnstp)*dtnstp
- c_d_11 = c_d_full (ixp,iyp,itnst)*dtnst + c_d_full (ixp,iyp,itnstp)*dtnstp
-
- w_0_00 = w_0_full (ix ,iy ,itnst)*dtnst + w_0_full (ix ,iy ,itnstp)*dtnstp
- w_0_01 = w_0_full (ix ,iyp,itnst)*dtnst + w_0_full (ix ,iyp,itnstp)*dtnstp
- w_0_10 = w_0_full (ixp,iy ,itnst)*dtnst + w_0_full (ixp,iy ,itnstp)*dtnstp
- w_0_11 = w_0_full (ixp,iyp,itnst)*dtnst + w_0_full (ixp,iyp,itnstp)*dtnstp
-
- w_d_00 = w_d_full (ix ,iy ,itnst)*dtnst + w_d_full (ix ,iy ,itnstp)*dtnstp
- w_d_01 = w_d_full (ix ,iyp,itnst)*dtnst + w_d_full (ix ,iyp,itnstp)*dtnstp
- w_d_10 = w_d_full (ixp,iy ,itnst)*dtnst + w_d_full (ixp,iy ,itnstp)*dtnstp
- w_d_11 = w_d_full (ixp,iyp,itnst)*dtnst + w_d_full (ixp,iyp,itnstp)*dtnstp
! Interpolate nst variables to obs location (water surface only)
wgtavg = zero
- tr_tmp = zero
+ tref2 = zero
dt_cool = zero
- z_c = zero
dt_warm = zero
- z_w_tmp = zero
+ z_c = zero
+ z_w = zero
c_0 = zero
c_d = zero
w_0 = zero
w_d = zero
+ tz_tr = one
+ dtw = zero
+ dtc = zero
if (istyp00 == 0)then
+ tref_tt = tref_full (ix ,iy ,itnst)*dtnst + tref_full (ix ,iy ,itnstp)*dtnstp
+ dt_cool_tt = dt_cool_full(ix ,iy ,itnst)*dtnst + dt_cool_full(ix ,iy ,itnstp)*dtnstp
+ dt_warm_tt = dt_warm_full(ix ,iy ,itnst)*dtnst + dt_warm_full(ix ,iy ,itnstp)*dtnstp
+ z_c_tt = z_c_full (ix ,iy ,itnst)*dtnst + z_c_full (ix ,iy ,itnstp)*dtnstp
+ z_w_tt = z_w_full (ix ,iy ,itnst)*dtnst + z_w_full (ix ,iy ,itnstp)*dtnstp
+ c_0_tt = c_0_full (ix ,iy ,itnst)*dtnst + c_0_full (ix ,iy ,itnstp)*dtnstp
+ c_d_tt = c_d_full (ix ,iy ,itnst)*dtnst + c_d_full (ix ,iy ,itnstp)*dtnstp
+ w_0_tt = w_0_full (ix ,iy ,itnst)*dtnst + w_0_full (ix ,iy ,itnstp)*dtnstp
+ w_d_tt = w_d_full (ix ,iy ,itnst)*dtnst + w_d_full (ix ,iy ,itnstp)*dtnstp
wgtavg = wgtavg + w00
- tr_tmp = tr_tmp + w00*tref_00
- dt_cool = dt_cool + w00*dt_cool_00
- z_c = z_c + w00*z_c_00
- dt_warm = dt_warm + w00*dt_warm_00
- z_w_tmp = z_w_tmp + w00*z_w_00
- c_0 = c_0 + w00*c_0_00
- c_d = c_d + w00*c_d_00
- w_0 = w_0 + w00*w_0_00
- w_d = w_d + w00*w_d_00
+ tref2 = tref2 + w00*tref_tt
+ dt_cool = dt_cool + w00*dt_cool_tt
+ dt_warm = dt_warm + w00*dt_warm_tt
+ z_c = z_c + w00*z_c_tt
+ z_w = z_w + w00*z_w_tt
+ c_0 = c_0 + w00*c_0_tt
+ c_d = c_d + w00*c_d_tt
+ w_0 = w_0 + w00*w_0_tt
+ w_d = w_d + w00*w_d_tt
endif
if(istyp01 == 0)then
+ tref_tt = tref_full (ix ,iyp,itnst)*dtnst + tref_full (ix ,iyp,itnstp)*dtnstp
+ dt_cool_tt = dt_cool_full(ix ,iyp,itnst)*dtnst + dt_cool_full(ix ,iyp,itnstp)*dtnstp
+ dt_warm_tt = dt_warm_full(ix ,iyp,itnst)*dtnst + dt_warm_full(ix ,iyp,itnstp)*dtnstp
+ z_c_tt = z_c_full (ix ,iyp,itnst)*dtnst + z_c_full (ix ,iyp,itnstp)*dtnstp
+ z_w_tt = z_w_full (ix ,iyp,itnst)*dtnst + z_w_full (ix ,iyp,itnstp)*dtnstp
+ c_0_tt = c_0_full (ix ,iyp,itnst)*dtnst + c_0_full (ix ,iyp,itnstp)*dtnstp
+ c_d_tt = c_d_full (ix ,iyp,itnst)*dtnst + c_d_full (ix ,iyp,itnstp)*dtnstp
+ w_0_tt = w_0_full (ix ,iyp,itnst)*dtnst + w_0_full (ix ,iyp,itnstp)*dtnstp
+ w_d_tt = w_d_full (ix ,iyp,itnst)*dtnst + w_d_full (ix ,iyp,itnstp)*dtnstp
wgtavg = wgtavg + w01
- tr_tmp = tr_tmp + w01*tref_01
- dt_cool = dt_cool + w01*dt_cool_01
- z_c = z_c + w01*z_c_01
- dt_warm = dt_warm + w01*dt_warm_01
- z_w_tmp = z_w_tmp + w01*z_w_01
- c_0 = c_0 + w01*c_0_01
- c_d = c_d + w01*c_d_01
- w_0 = w_0 + w01*w_0_01
- w_d = w_d + w01*w_d_01
+ tref2 = tref2 + w01*tref_tt
+ dt_cool = dt_cool + w01*dt_cool_tt
+ dt_warm = dt_warm + w01*dt_warm_tt
+ z_c = z_c + w01*z_c_tt
+ z_w = z_w + w01*z_w_tt
+ c_0 = c_0 + w01*c_0_tt
+ c_d = c_d + w01*c_d_tt
+ w_0 = w_0 + w01*w_0_tt
+ w_d = w_d + w01*w_d_tt
end if
if(istyp10 == 0)then
+ tref_tt = tref_full (ixp,iy ,itnst)*dtnst + tref_full (ixp,iy ,itnstp)*dtnstp
+ dt_cool_tt = dt_cool_full(ixp,iy ,itnst)*dtnst + dt_cool_full(ixp,iy ,itnstp)*dtnstp
+ dt_warm_tt = dt_warm_full(ixp,iy ,itnst)*dtnst + dt_warm_full(ixp,iy ,itnstp)*dtnstp
+ z_c_tt = z_c_full (ixp,iy ,itnst)*dtnst + z_c_full (ixp,iy ,itnstp)*dtnstp
+ z_w_tt = z_w_full (ixp,iy ,itnst)*dtnst + z_w_full (ixp,iy ,itnstp)*dtnstp
+ c_0_tt = c_0_full (ixp,iy ,itnst)*dtnst + c_0_full (ixp,iy ,itnstp)*dtnstp
+ c_d_tt = c_d_full (ixp,iy ,itnst)*dtnst + c_d_full (ixp,iy ,itnstp)*dtnstp
+ w_0_tt = w_0_full (ixp,iy ,itnst)*dtnst + w_0_full (ixp,iy ,itnstp)*dtnstp
+ w_d_tt = w_d_full (ixp,iy ,itnst)*dtnst + w_d_full (ixp,iy ,itnstp)*dtnstp
wgtavg = wgtavg + w10
- tr_tmp = tr_tmp + w10*tref_10
- dt_cool = dt_cool + w10*dt_cool_10
- z_c = z_c + w10*z_c_10
- dt_warm = dt_warm + w10*dt_warm_10
- z_w_tmp = z_w_tmp + w10*z_w_10
- c_0 = c_0 + w10*c_0_10
- c_d = c_d + w10*c_d_10
- w_0 = w_0 + w10*w_0_10
- w_d = w_d + w10*w_d_10
+ tref2 = tref2 + w10*tref_tt
+ dt_cool = dt_cool + w10*dt_cool_tt
+ dt_warm = dt_warm + w10*dt_warm_tt
+ z_c = z_c + w10*z_c_tt
+ z_w = z_w + w10*z_w_tt
+ c_0 = c_0 + w10*c_0_tt
+ c_d = c_d + w10*c_d_tt
+ w_0 = w_0 + w10*w_0_tt
+ w_d = w_d + w10*w_d_tt
end if
if(istyp11 == 0)then
+ tref_tt = tref_full (ixp,iyp,itnst)*dtnst + tref_full (ixp,iyp,itnstp)*dtnstp
+ dt_cool_tt = dt_cool_full(ixp,iyp,itnst)*dtnst + dt_cool_full(ixp,iyp,itnstp)*dtnstp
+ dt_warm_tt = dt_warm_full(ixp,iyp,itnst)*dtnst + dt_warm_full(ixp,iyp,itnstp)*dtnstp
+ z_c_tt = z_c_full (ixp,iyp,itnst)*dtnst + z_c_full (ixp,iyp,itnstp)*dtnstp
+ z_w_tt = z_w_full (ixp,iyp,itnst)*dtnst + z_w_full (ixp,iyp,itnstp)*dtnstp
+ c_0_tt = c_0_full (ixp,iyp,itnst)*dtnst + c_0_full (ixp,iyp,itnstp)*dtnstp
+ c_d_tt = c_d_full (ixp,iyp,itnst)*dtnst + c_d_full (ixp,iyp,itnstp)*dtnstp
+ w_0_tt = w_0_full (ixp,iyp,itnst)*dtnst + w_0_full (ixp,iyp,itnstp)*dtnstp
+ w_d_tt = w_d_full (ixp,iyp,itnst)*dtnst + w_d_full (ixp,iyp,itnstp)*dtnstp
wgtavg = wgtavg + w11
- tr_tmp = tr_tmp + w11*tref_11
- dt_cool = dt_cool + w11*dt_cool_11
- z_c = z_c + w11*z_c_11
- dt_warm = dt_warm + w11*dt_warm_11
- z_w_tmp = z_w_tmp + w11*z_w_11
- c_0 = c_0 + w11*c_0_11
- c_d = c_d + w11*c_d_11
- w_0 = w_0 + w11*w_0_11
- w_d = w_d + w11*w_d_11
+ tref2 = tref2 + w11*tref_tt
+ dt_cool = dt_cool + w11*dt_cool_tt
+ dt_warm = dt_warm + w11*dt_warm_tt
+ z_c = z_c + w11*z_c_tt
+ z_w = z_w + w11*z_w_tt
+ c_0 = c_0 + w11*c_0_tt
+ c_d = c_d + w11*c_d_tt
+ w_0 = w_0 + w11*w_0_tt
+ w_d = w_d + w11*w_d_tt
end if
+ if(wgtavg < 1.e-6)return
- if(wgtavg > zero)then
- tr_tmp = tr_tmp/wgtavg
- tref = tr_tmp
-
- z_w_tmp = z_w_tmp/wgtavg
- z_w = z_w_tmp
+ tref = tref2/wgtavg
+ z_w = z_w/wgtavg
+ z_c = z_c/wgtavg
- dt_cool = dt_cool/wgtavg
- z_c = z_c/wgtavg
- dt_warm = dt_warm/wgtavg
+ if(fac_tsl == 1)then
c_0 = c_0/wgtavg
c_d = c_d/wgtavg
+ dt_cool = dt_cool/wgtavg
+ if(z_c > zero)dtc = dt_cool*(one-min(zob,z_c)/z_c)
+ else
+ c_0 = zero
+ c_d = zero
+ dt_cool = zero
+ end if
+ if(fac_dtl == 1)then
w_0 = w_0/wgtavg
w_d = w_d/wgtavg
+ dt_warm = dt_warm/wgtavg
+ if(z_w > zero)dtw = dt_warm*(one-min(zob,z_w)/z_w)
+ else
+ w_0 = zero
+ w_d = zero
+ dt_warm = zero
+ end if
- dtw = fac_dtl*dt_warm*(one-min(zob,z_w)/z_w)
- if ( z_c > zero ) then
- dtc = fac_tsl*dt_cool*(one-min(zob,z_c)/z_c)
- else
- dtc = zero
- endif
- call cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,z_c,z_w,zob,tz_tr)
+ call cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,z_c,z_w,zob,tz_tr)
- end if
end subroutine deter_nst_
!*******************************************************************************************
@@ -343,10 +342,10 @@ subroutine cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr)
!
! dt_warm : diurnal warming amount at the surface
! xz : DTL depth (M)
-! c_0 : coefficint 1 to calculate d(Tc)/d(Ts)
-! c_d : coefficint 2 to calculate d(Tc)/d(Ts)
-! w_0 : coefficint 1 to calculate d(Tw)/d(Ts)
-! w_d : coefficint 2 to calculate d(Tw)/d(Ts)
+! c_0 : coefficient 1 to calculate d(Tc)/d(Ts)
+! c_d : coefficient 2 to calculate d(Tc)/d(Ts)
+! w_0 : coefficient 1 to calculate d(Tw)/d(Ts)
+! w_d : coefficient 2 to calculate d(Tw)/d(Ts)
!
! output variables
!
@@ -354,34 +353,39 @@ subroutine cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr)
use kinds, only: r_kind
use constants, only: one,two,half,zero
- use gsi_nstcouplermod, only: fac_dtl,fac_tsl
real(kind=r_kind), intent(in) :: dt_warm,c_0,c_d,w_0,w_d,zc,zw,z
real(kind=r_kind), intent(out) :: tztr
! local variables
- real(kind=r_kind) :: c1,c2,c3
+ real(kind=r_kind) :: c1,c2,c3,fact
- c1 = one-two*(fac_dtl*w_0-fac_tsl*c_0)-(fac_dtl*w_d-fac_tsl*c_d)*z
- c2 = one-two*(fac_dtl*w_0-fac_tsl*c_0)-fac_dtl*w_d*z
- c3 = one+fac_tsl*two*c_0+fac_dtl*c_d*z
tztr = one
+ c1 = zero
+ c2 = zero
+ c3 = zero
if ( dt_warm > zero ) then
- if ( z <= zc .and. c1 /= zero ) then
- tztr = (one-fac_dtl*w_0+fac_tsl*c_0)/c1
- elseif ( z > zc .and. z < zw .and. c2 /= zero ) then
- tztr = (one-fac_dtl*w_0+fac_tsl*c_0)/c2
+ fact = (one-w_0+c_0)
+ if ( z <= zc) then
+ c1 = one-two*(w_0-c_0)-(w_d-c_d)*z
+ if ( c1 /= zero ) tztr = fact/c1
+ elseif ( z > zc .and. z < zw) then
+ c2 = one-two*(w_0-c_0)-w_d*z
+ if (c2 /= zero ) tztr = fact/c2
+ else
endif
- elseif ( dt_warm == zero .and. c3 /= zero ) then
- if ( z <= zc ) then
- tztr = (one+fac_tsl*c_0)/c3
+ elseif (dt_warm == zero) then
+ if ( z <= zc) then
+ c3 = one+two*c_0+c_d*z
+ if (c3 /= zero) tztr = (one+c_0)/c3
endif
endif
- if ( tztr <= -1.0_r_kind .or. tztr > 4.0_r_kind ) then
- write(6,100) fac_dtl,fac_tsl,c1,c2,c3,dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr
-100 format('CAL_TZTR compute ',2(i2,1x),12(g13.6,1x),' RESET tztr to 1.0')
- tztr = one
+ if ( tztr < 0.5_r_kind .or. tztr > 1.5_r_kind ) then
+ write(6,100) c1,c2,c3,dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr
+100 format('CAL_TZTR compute ',12(g13.6,1x),' RESET tztr to 0.5 .or. 1.5')
+ tztr = min(1.5_r_kind,tztr)
+ tztr = max(0.5_r_kind,tztr)
endif
end subroutine cal_tztr_
diff --git a/src/gsi/cplr_read_wrf_nmm_guess.f90 b/src/gsi/cplr_read_wrf_nmm_guess.f90
index 63b1bac54a..cc1ecf5528 100644
--- a/src/gsi/cplr_read_wrf_nmm_guess.f90
+++ b/src/gsi/cplr_read_wrf_nmm_guess.f90
@@ -2077,7 +2077,7 @@ subroutine read_nems_nmmb_guess_wrf(this,mype)
! due to interpolation
do i=1,lon2
do j=1,lat2
- veg_type(j,i,it)=float(nint(veg_type(j,i,it)))
+ veg_type(j,i,it)=real(nint(veg_type(j,i,it)),r_kind)
end do
end do
! ! veg frac
@@ -2091,7 +2091,7 @@ subroutine read_nems_nmmb_guess_wrf(this,mype)
! due to interpolation
do i=1,lon2
do j=1,lat2
- soil_type(j,i,it)=float(nint(soil_type(j,i,it)))
+ soil_type(j,i,it)=real(nint(soil_type(j,i,it)),r_kind)
end do
end do
@@ -2102,7 +2102,7 @@ subroutine read_nems_nmmb_guess_wrf(this,mype)
! due to interpolation
do i=1,lon2
do j=1,lat2
- smthis(j,i)=float(nint(smthis(j,i)))
+ smthis(j,i)=real(nint(smthis(j,i)),r_kind)
end do
end do
@@ -2113,7 +2113,7 @@ subroutine read_nems_nmmb_guess_wrf(this,mype)
! due to interpolation
do i=1,lon2
do j=1,lat2
- sicethis(j,i)=float(nint(sicethis(j,i)))
+ sicethis(j,i)=real(nint(sicethis(j,i)),r_kind)
end do
end do
diff --git a/src/gsi/cplr_wrf_netcdf_interface.f90 b/src/gsi/cplr_wrf_netcdf_interface.f90
index 5739b27b73..7c1bc400ec 100644
--- a/src/gsi/cplr_wrf_netcdf_interface.f90
+++ b/src/gsi/cplr_wrf_netcdf_interface.f90
@@ -3388,7 +3388,7 @@ subroutine update_netcdf_mass_wrf(this)
myname_,'put_att: START_DATE '//trim(flnm1) )
call nc_check( nf90_put_att(dh1,nf90_global,'SIMULATION_START_DATE',trim(DateStr1)),&
myname_,'put_att: SIMULATION_START_DATE '//trim(flnm1) )
- call nc_check( nf90_put_att(dh1,nf90_global,'GMT',float(ihour)),&
+ call nc_check( nf90_put_att(dh1,nf90_global,'GMT',real(ihour,r_single)),&
myname_,'put_att: GMT '//trim(flnm1) )
call nc_check( nf90_put_att(dh1,nf90_global,'JULYR',iyear),&
myname_,'put_att: JULYR'//trim(flnm1) )
@@ -3885,7 +3885,7 @@ subroutine update_netcdf_nmm_wrf(this)
myname_,'put_att: START_DATE '//trim(adjustl(flnm1)) )
call nc_check( nf90_put_att(dh1,nf90_global,'SIMULATION_START_DATE',trim(DateStr1)),&
myname_,'put_att: SIMULATION_START_DATE '//trim(adjustl(flnm1)) )
- call nc_check( nf90_put_att(dh1,nf90_global,'GMT',float(ihour)),&
+ call nc_check( nf90_put_att(dh1,nf90_global,'GMT',real(ihour,r_single)),&
myname_,'put_att: GMT '//trim(adjustl(flnm1)) )
call nc_check( nf90_put_att(dh1,nf90_global,'JULYR',iyear),&
myname_,'put_att: JULYR'//trim(adjustl(flnm1)) )
diff --git a/src/gsi/crtm_interface.f90 b/src/gsi/crtm_interface.f90
index 2305c84340..3f06daa315 100644
--- a/src/gsi/crtm_interface.f90
+++ b/src/gsi/crtm_interface.f90
@@ -85,6 +85,7 @@ module crtm_interface
public destroy_crtm ! Subroutine destroys initialization for crtm
public sensorindex
public surface
+public atmosphere
public isatid ! = 1 index of satellite id
public itime ! = 2 index of analysis relative obs time
public ilon ! = 3 index of grid relative obs location (x)
@@ -125,6 +126,8 @@ module crtm_interface
public idtw ! = 35/37 index of d(Tw)
public idtc ! = 36/38 index of d(Tc)
public itz_tr ! = 37/39 index of d(Tz)/d(Tr)
+public n_clouds_fwd_wk
+public n_absorbers
! For TMI and GMI
public iedge_log ! = 32 ! index, if obs is to be obleted beause of locating near scan edges.
@@ -202,6 +205,7 @@ module crtm_interface
logical ,save :: mixed_use
logical ,save :: use_gfdl_qsat
integer(i_kind), parameter :: min_n_absorbers = 2
+ integer(i_kind) :: n_absorbers
integer(i_kind),save :: iedge_log
integer(i_kind),save :: ilzen_ang2,ilazi_ang2,iscan_ang2,iszen_ang2,isazi_ang2
@@ -356,7 +360,6 @@ subroutine init_crtm(init_pass,mype_diaghdr,mype,nchanl,nreal,isis,obstype,radmo
! ...all "additional absorber" variables
integer(i_kind) :: j,icount
integer(i_kind) :: ig
- integer(i_kind) :: n_absorbers
logical quiet
logical print_verbose
@@ -977,7 +980,7 @@ end subroutine destroy_crtm
subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, &
h,q,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsl,prsi, &
trop5,tzbgr,dtsavg,sfc_speed,&
- tsim,emissivity,ptau5,ts, &
+ tsim,emissivity,chan_level,ptau5,ts, &
emissivity_k,temp,wmix,jacobian,error_status,tsim_clr,tcc, &
tcwv,hwp_ratio,stability,layer_od,jacobian_aero)
!$$$ subprogram documentation block
@@ -1097,6 +1100,7 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, &
real(r_kind) ,intent( out) :: sfc_speed,dtsavg
real(r_kind),dimension(nchanl+nreal) ,intent(in ) :: data_s
real(r_kind),dimension(nchanl) ,intent( out) :: tsim,emissivity,ts,emissivity_k
+ real(r_kind),dimension(nchanl) ,intent( out) :: chan_level
character(10) ,intent(in ) :: obstype
integer(i_kind) ,intent( out) :: error_status
real(r_kind),dimension(nsig,nchanl) ,intent( out) :: temp,ptau5,wmix
@@ -1150,6 +1154,7 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, &
real(r_kind):: sno00,sno01,sno10,sno11,secant_term
real(r_kind):: hwp_total,theta_700,theta_sfc,hs
real(r_kind):: dlon,dlat,dxx,dyy,yy,zz,garea
+ real(r_kind):: radiance, radiance_overcast, radiance_ratio
real(r_kind),dimension(0:3):: wgtavg
real(r_kind),dimension(nsig,nchanl):: omix
real(r_kind),dimension(nsig,nchanl,n_aerosols_jac):: jaero
@@ -2201,6 +2206,7 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, &
end if
endif
+
if (trim(obstype) /= 'modis_aod' .and. trim(obstype) /= 'viirs_aod' ) then
! Secant of satellite zenith angle
@@ -2217,6 +2223,8 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, &
end do
end if
+ chan_level = zero
+
!$omp parallel do schedule(dynamic,1) private(i) &
!$omp private(total_od,k,kk,m,term,ii,cwj)
do i=1,nchanl
@@ -2228,6 +2236,17 @@ subroutine call_crtm(obstype,obstime,data_s,nchanl,nreal,ich, &
wmix(k,i)=zero
end do
+ radiance=rtsolution(i,1)%radiance
+ do k=msig, 1, -1
+ radiance_overcast = rtsolution(i,1)%upwelling_overcast_radiance(k)
+ radiance_ratio = abs(radiance_overcast/radiance)
+ if (radiance_ratio < 0.99_r_kind) then
+ chan_level(i) = atmosphere(1)%pressure(k) / r10
+ exit
+ endif
+ enddo
+
+
! Simulated brightness temperatures
tsim(i)=rtsolution(i,1)%brightness_temperature
diff --git a/src/gsi/cwhydromod.f90 b/src/gsi/cwhydromod.f90
index a27bba545f..d2bde78129 100644
--- a/src/gsi/cwhydromod.f90
+++ b/src/gsi/cwhydromod.f90
@@ -100,14 +100,23 @@ subroutine cw2hydro(sval,clouds,nclouds)
call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus)
if (istatus/=0) cycle
sv_rank3=zero
- do k=1,nsig
- do j=1,lon2
- do i=1,lat2
- if (clouds(ic)=='ql') sv_rank3(i,j,k)=cwgues(i,j,k)*(one-work(i,j,k))
- if (clouds(ic)=='qi') sv_rank3(i,j,k)=cwgues(i,j,k)*work(i,j,k)
+ if (clouds(ic)=='ql') then
+ do k=1,nsig
+ do j=1,lon2
+ do i=1,lat2
+ sv_rank3(i,j,k)=cwgues(i,j,k)*(one-work(i,j,k))
+ end do
end do
end do
- end do
+ else if (clouds(ic)=='qi') then
+ do k=1,nsig
+ do j=1,lon2
+ do i=1,lat2
+ sv_rank3(i,j,k)=cwgues(i,j,k)*work(i,j,k)
+ end do
+ end do
+ end do
+ end if
end do
return
@@ -174,16 +183,25 @@ subroutine cw2hydro_tl(sval,wbundle,clouds,nclouds)
call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus)
if (istatus/=0) cycle
sv_rank3=zero
- do k=1,nsig
- do j=1,lon2
- do i=1,lat2
-! if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))-cwgues(i,j,k)*work(i,j,k)
-! if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)+cwgues(i,j,k)*work(i,j,k)
- if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))
- if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)
+ if (clouds(ic)=='ql') then
+ do k=1,nsig
+ do j=1,lon2
+ do i=1,lat2
+! sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))-cwgues(i,j,k)*work(i,j,k)
+ sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))
+ end do
end do
end do
- end do
+ else if (clouds(ic)=='qi') then
+ do k=1,nsig
+ do j=1,lon2
+ do i=1,lat2
+! sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)+cwgues(i,j,k)*work(i,j,k)
+ sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)
+ end do
+ end do
+ end do
+ end if
end do
return
@@ -226,8 +244,6 @@ subroutine cw2hydro_ad(rval,wbundle,clouds,nclouds)
real(r_kind),pointer,dimension(:,:,:) :: cv_cw
! Get pointer to required control variable
-call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus)
-cv_cw=zero
do k=1,nsig
do j=1,lon2
@@ -239,25 +255,30 @@ subroutine cw2hydro_ad(rval,wbundle,clouds,nclouds)
end do
end do
+call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus)
do ic=1,nclouds
call gsi_bundlegetpointer (rval,clouds(ic),rv_rank3,istatus)
if (istatus/=0) cycle
- do k=1,nsig
- do j=1,lon2
- do i=1,lat2
- if (clouds(ic)=='ql') then
+ if (clouds(ic)=='ql') then
+ do k=1,nsig
+ do j=1,lon2
+ do i=1,lat2
cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*(one-work0(i,j,k))
rv_rank3(i,j,k)=zero
- end if
-
- if (clouds(ic)=='qi') then
+ end do
+ end do
+ end do
+ else if (clouds(ic)=='qi') then
+ do k=1,nsig
+ do j=1,lon2
+ do i=1,lat2
cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*work0(i,j,k)
rv_rank3(i,j,k)=zero
- end if
-
+ end do
end do
end do
- end do
+ end if
+
end do
return
diff --git a/src/gsi/deter_sfc_mod.f90 b/src/gsi/deter_sfc_mod.f90
index 3c88aabb2a..271e81c5d2 100644
--- a/src/gsi/deter_sfc_mod.f90
+++ b/src/gsi/deter_sfc_mod.f90
@@ -33,7 +33,7 @@ module deter_sfc_mod
use satthin, only: sno_full,isli_full,sst_full,soil_moi_full, &
soil_temp_full,soil_type_full,veg_frac_full,veg_type_full, &
fact10_full,zs_full,sfc_rough_full,zs_full_gfs
- use constants, only: zero,one,two,one_tenth,deg2rad,rad2deg
+ use constants, only: zero,one,two,one_tenth,deg2rad,rad2deg, rearth
use gridmod, only: nlat,nlon,regional,tll2xy,nlat_sfc,nlon_sfc,rlats_sfc,rlons_sfc, &
rlats,rlons,dx_gfs,txy2ll,lpl_gfs
use guess_grids, only: nfldsfc,hrdifsfc,ntguessfc
@@ -156,7 +156,7 @@ subroutine deter_sfc(alat,alon,dlat_earth,dlon_earth,obstime,isflg, &
if(iyp==nlon_sfc+1) iyp=1
! Get time interpolation factors for surface files
- if(obstime > hrdifsfc(1) .and. obstime <= hrdifsfc(nfldsfc))then
+ if(obstime > hrdifsfc(1) .and. obstime < hrdifsfc(nfldsfc))then
do j=1,nfldsfc-1
if(obstime > hrdifsfc(j) .and. obstime <= hrdifsfc(j+1))then
itsfc=j
@@ -207,7 +207,6 @@ subroutine deter_sfc(alat,alon,dlat_earth,dlon_earth,obstime,isflg, &
sfcpct(istyp10)=sfcpct(istyp10)+w10
sfcpct(istyp11)=sfcpct(istyp11)+w11
- isflg = 0
if(sfcpct(0) > 0.99_r_kind)then
isflg = 0
else if(sfcpct(1) > 0.99_r_kind)then
@@ -465,7 +464,7 @@ subroutine deter_sfc_type(dlat_earth,dlon_earth,obstime,isflg,tsavg)
if(iyp==nlon_sfc+1) iyp=1
! Get time interpolation factors for surface files
- if(obstime > hrdifsfc(1) .and. obstime <= hrdifsfc(nfldsfc))then
+ if(obstime > hrdifsfc(1) .and. obstime < hrdifsfc(nfldsfc))then
do j=1,nfldsfc-1
if(obstime > hrdifsfc(j) .and. obstime <= hrdifsfc(j+1))then
itsfc=j
@@ -517,7 +516,6 @@ subroutine deter_sfc_type(dlat_earth,dlon_earth,obstime,isflg,tsavg)
sfcpct(istyp10)=sfcpct(istyp10)+w10
sfcpct(istyp11)=sfcpct(istyp11)+w11
- isflg = 0
if(sfcpct(0) > 0.99_r_kind)then
isflg = 0
else if(sfcpct(1) > 0.99_r_kind)then
@@ -602,7 +600,7 @@ subroutine deter_sfc2(dlat_earth,dlon_earth,obstime,idomsfc,tsavg,ff10,sfcr,zz)
! Get time interpolation factors for surface files
- if(obstime > hrdifsfc(1) .and. obstime <= hrdifsfc(nfldsfc))then
+ if(obstime > hrdifsfc(1) .and. obstime < hrdifsfc(nfldsfc))then
do j=1,nfldsfc-1
if(obstime > hrdifsfc(j) .and. obstime <= hrdifsfc(j+1))then
itsfc=j
@@ -823,7 +821,7 @@ subroutine deter_sfc_fov(fov_flag,ifov,instr,ichan,sat_aziang,dlat_earth_deg,&
! Get time interpolation factors for surface files
- if(obstime > hrdifsfc(1) .and. obstime <= hrdifsfc(nfldsfc))then
+ if(obstime > hrdifsfc(1) .and. obstime < hrdifsfc(nfldsfc))then
do j=1,nfldsfc-1
if(obstime > hrdifsfc(j) .and. obstime <= hrdifsfc(j+1))then
itsfc=j
@@ -1050,21 +1048,21 @@ subroutine deter_sfc_fov(fov_flag,ifov,instr,ichan,sat_aziang,dlat_earth_deg,&
exit loop1
endif
- mid = (float(subgrid_lengths_y)-one)/two + one
- del = one/ float(subgrid_lengths_y)
+ mid = (real(subgrid_lengths_y,r_kind)-one)/two + one
+ del = one/ real(subgrid_lengths_y,r_kind)
allocate (y_off(subgrid_lengths_y))
do i= 1, subgrid_lengths_y
- y_off(i) = (float(i)-mid)*del
+ y_off(i) = (real(i,r_kind)-mid)*del
enddo
- mid = (float(subgrid_lengths_x)-one)/two + one
- del = one / float(subgrid_lengths_x)
+ mid = (real(subgrid_lengths_x,r_kind)-one)/two + one
+ del = one / real(subgrid_lengths_x,r_kind)
allocate (x_off(subgrid_lengths_x))
do i= 1, subgrid_lengths_x
- x_off(i) = (float(i)-mid)*del
+ x_off(i) = (real(i,r_kind)-mid)*del
enddo
! Determine the surface characteristics by integrating over the
@@ -1077,9 +1075,9 @@ subroutine deter_sfc_fov(fov_flag,ifov,instr,ichan,sat_aziang,dlat_earth_deg,&
do i = min_i(j), max_i(j)
call time_int_sfc(i,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl)
do jjj = 1, subgrid_lengths_y
- y = float(j) + y_off(jjj)
+ y = real(j,r_kind) + y_off(jjj)
do iii = 1, subgrid_lengths_x
- x = float(i) + x_off(iii)
+ x = real(i,r_kind) + x_off(iii)
call txy2ll(x,y,lon_rad,lat_rad)
lat_mdl = lat_rad*rad2deg
lon_mdl = lon_rad*rad2deg
@@ -1109,7 +1107,7 @@ subroutine deter_sfc_fov(fov_flag,ifov,instr,ichan,sat_aziang,dlat_earth_deg,&
do i = min_i(j), max_i(j)
call reduce2full(i,j,ifull)
call time_int_sfc(ifull,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl)
-!$omp parallel do schedule(dynamic,1)private(jjj,iii,lat_mdl,lon_mdl)
+!$omp parallel do schedule(dynamic,1) private(jjj,iii,lat_mdl,lon_mdl)
do jjj = 1, subgrid_lengths_y
if (y_off(jjj) >= zero) then
lat_mdl = (one-y_off(jjj))*rlats_sfc(j)+y_off(jjj)*rlats_sfc(j+1)
@@ -1122,7 +1120,7 @@ subroutine deter_sfc_fov(fov_flag,ifov,instr,ichan,sat_aziang,dlat_earth_deg,&
! ok here when calculating longitude even if the value is
! greater than 360. the ellipse code works from longitude relative
! to the center of the fov.
- lon_mdl = (float(i)+x_off(iii) - one) * dx_gfs(jj)
+ lon_mdl = (real(i,r_kind)+x_off(iii) - one) * dx_gfs(jj)
if (fov_flag=="crosstrk")then
call inside_fov_crosstrk(instr,ifov,sat_aziang, &
dlat_earth_deg,dlon_earth_deg, &
@@ -1316,7 +1314,6 @@ subroutine deter_sfc_amsre_low(dlat_earth,dlon_earth,isflg,sfcpct)
! sfcpct(3)=min(sfcpct(3),sfcpct(1))
! sfcpct(1)=max(zero,sfcpct(1)-sfcpct(3))
- isflg = 0
if(sfcpct(0) > 0.99_r_kind)then
isflg = 0
else if(sfcpct(1) > 0.99_r_kind)then
@@ -1334,7 +1331,7 @@ subroutine deter_sfc_amsre_low(dlat_earth,dlon_earth,isflg,sfcpct)
end subroutine deter_sfc_amsre_low
-subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct)
+subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg)
!$$$ subprogram documentation block
! . . . .
! subprogram: deter_sfc_gmi determine land surface type
@@ -1357,11 +1354,6 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct)
! 2 sea ice
! 3 snow
! 4 mixed
-! sfcpct(0:3)- percentage of 4 surface types
-! (0) - sea percentage
-! (1) - land percentage
-! (2) - sea ice percentage
-! (3) - snow percentage
!
! attributes:
! language: f90
@@ -1373,15 +1365,11 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct)
real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth
integer(i_kind) ,intent( out) :: isflg
- real(r_kind),dimension(0:3),intent( out) :: sfcpct
-
- integer(i_kind) jsli,it
- integer(i_kind):: klat1,klon1,klatp1,klonp1
- real(r_kind):: dx,dy,dx1,dy1,w00,w10,w01,w11
- real(r_kind) :: dlat,dlon
+ integer(i_kind) jsli,it, i, j
+ integer(i_kind):: klat1,klon1,klatp1,klonp1, ksmall, klarge, n_grid
+ real(r_kind) :: dlat,dlon, grid_dist
+ integer(i_kind):: klatn,klonn,klatpn,klonpn
logical :: outside
- integer(i_kind):: klat2,klon2,klatp2,klonp2
-
!
! For interpolation, we usually use o points (4points for land sea decision)
! In case of lowfreq channel (Large FOV), add the check of x points(8 points)
@@ -1410,91 +1398,55 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct)
end if
klon1=int(dlon); klat1=int(dlat)
- dx =dlon-klon1; dy =dlat-klat1
- dx1 =one-dx; dy1 =one-dy
- w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy
klat1=min(max(1,klat1),nlat_sfc); klon1=min(max(0,klon1),nlon_sfc)
if(klon1==0) klon1=nlon_sfc
klatp1=min(nlat_sfc,klat1+1); klonp1=klon1+1
- if(klonp1==nlon_sfc+1) klonp1=1
- klonp2 = klonp1+1
- if(klonp2==nlon_sfc+1) klonp2=1
- klon2=klon1-1
- if(klon2==0)klon2=nlon_sfc
- klat2=max(1,klat1-1)
- klatp2=min(nlat_sfc,klatp1+1)
! Set surface type flag. Begin by assuming obs over ice-free water
- sfcpct = zero
-
- jsli = isli_full(klat1 ,klon1 )
- if(sno_full(klat1 ,klon1 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- jsli = isli_full(klatp1,klon1 )
- if(sno_full(klatp1 ,klon1 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- jsli = isli_full(klat1 ,klonp1)
- if(sno_full(klat1 ,klonp1 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- jsli = isli_full(klatp1,klonp1)
- if(sno_full(klatp1 ,klonp1 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- jsli = isli_full(klatp2,klon1)
- if(sno_full(klatp2 ,klon1 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- jsli = isli_full(klatp2,klonp1)
- if(sno_full(klatp2 ,klonp1 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- jsli = isli_full(klatp1,klon2)
- if(sno_full(klatp1 ,klon2 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- jsli = isli_full(klatp1,klonp2)
- if(sno_full(klatp1 ,klonp2 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- jsli = isli_full(klat1,klon2)
- if(sno_full(klat1 ,klon2 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- jsli = isli_full(klat1,klonp2)
- if(sno_full(klat1 ,klonp2 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- jsli = isli_full(klat2,klon1)
- if(sno_full(klat2 ,klon1 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- jsli = isli_full(klat2,klonp1)
- if(sno_full(klat2 ,klonp1 ,it) > one .and. jsli == 1)jsli=3
- sfcpct(jsli)=sfcpct(jsli)+one
-
- sfcpct=sfcpct/12.0_r_kind
-
-! sfcpct(3)=min(sfcpct(3),sfcpct(1))
-! sfcpct(1)=max(zero,sfcpct(1)-sfcpct(3))
-
- isflg = 0
- if(sfcpct(0) > 0.99_r_kind)then
- isflg = 0
- else if(sfcpct(1) > 0.99_r_kind)then
- isflg = 1
- else if(sfcpct(2) > 0.99_r_kind)then
- isflg = 2
- else if(sfcpct(3) > 0.99_r_kind)then
- isflg = 3
- else
- isflg = 4
- end if
+ grid_dist=rearth * (rlats_sfc(klatp1) - rlats_sfc(klat1))
+ n_grid=int(40000 / grid_dist) + 1
+ klatn = max(klat1 - n_grid, 1)
+ klonn = klon1 - n_grid
+ if (klonn < 0) klonn = nlon_sfc - klonn
+ klatpn = min((klat1 + n_grid), nlat_sfc)
+ klonpn = klon1 + n_grid
+ if (klonpn > nlon_sfc) klonpn = klonpn - nlon_sfc
+
+ isflg=0
+ outer: do i = klatn, klatpn
+ ! assume n_grid > 2
+ if (0 < klonpn - klonn .and. klonpn - klonn < nlon_sfc / 2) then
+ do j = klonn, klonpn
+ if (isli_full(i, j) /= 0) then
+ isflg = 1
+ exit outer
+ end if
+ end do
+ else
+ if (klonpn < klonn) then
+ ksmall = klonpn
+ klarge = klonn
+ else
+ ksmall = klonn
+ klarge = klonpn
+ end if
+ do j = 1, ksmall
+ if (isli_full(i, j) /= 0) then
+ isflg = 1
+ exit outer
+ endif
+ end do
+ do j = klarge, nlon_sfc
+ if (isli_full(i, j) /= 0) then
+ isflg = 1
+ exit outer
+ end if
+ end do
+ end if
+ end do outer
return
end subroutine deter_sfc_gmi
@@ -1920,7 +1872,7 @@ subroutine calc_sfc(sfc_sum,isflg,idomsfc,sfcpct,vfr,sty,vty,sm, &
vty=zero
else
itmp=lbound(sfc_sum%count_vty)-1+maxloc(sfc_sum%count_vty)
- vty=float(itmp(1))
+ vty=real(itmp(1),r_kind)
endif
! soil type is predominate type
@@ -1929,7 +1881,7 @@ subroutine calc_sfc(sfc_sum,isflg,idomsfc,sfcpct,vfr,sty,vty,sm, &
sty=zero
else
itmp=lbound(sfc_sum%count_sty)-1+maxloc(sfc_sum%count_sty)
- sty=float(itmp(1))
+ sty=real(itmp(1),r_kind)
endif
! fields for bare (non-snow covered) land
@@ -1986,7 +1938,6 @@ subroutine calc_sfc(sfc_sum,isflg,idomsfc,sfcpct,vfr,sty,vty,sm, &
sfcr = sfc_sum%sfcr/count_tot
zz = sfc_sum%zz/count_tot
- isflg = 0
if(sfcpct(0) > 0.99_r_kind)then
isflg = 0 ! open water
else if(sfcpct(1) > 0.99_r_kind)then
diff --git a/src/gsi/ens_spread_mod.f90 b/src/gsi/ens_spread_mod.f90
index da70d31ab0..c6528f64ff 100644
--- a/src/gsi/ens_spread_mod.f90
+++ b/src/gsi/ens_spread_mod.f90
@@ -78,7 +78,7 @@ subroutine ens_spread_dualres_regional(en_bar)
call stop2(999)
endif
- sp_norm=(one/float(n_ens))
+ sp_norm=(one/real(n_ens,r_kind))
sube%values=zero
!
diff --git a/src/gsi/ensctl2model.f90 b/src/gsi/ensctl2model.f90
index 12e1fe374e..8a042a1e6a 100644
--- a/src/gsi/ensctl2model.f90
+++ b/src/gsi/ensctl2model.f90
@@ -52,7 +52,7 @@ subroutine ensctl2model(xhat,mval,eval)
type(gsi_bundle) , intent(inout) :: eval(ntlevs_ens)
! Declare local variables
-character(len=*),parameter::myname='ensctl2state'
+character(len=*),parameter::myname='ensctl2model'
character(len=max_varname_length),allocatable,dimension(:) :: clouds
integer(i_kind) :: jj,ic,id,istatus,nclouds,nn
@@ -140,7 +140,7 @@ subroutine ensctl2model(xhat,mval,eval)
eval(jj)%values=zero
! Create a temporary bundle similar to xhat, and copy contents of xhat into it
- call gsi_bundlecreate ( wbundle_c, xhat%step(1), 'ensctl2state work', istatus )
+ call gsi_bundlecreate ( wbundle_c, xhat%step(1), 'ensctl2model work', istatus )
if(istatus/=0) then
write(6,*) trim(myname), ': trouble creating work bundle'
call stop2(999)
diff --git a/src/gsi/ensctl2model_ad.f90 b/src/gsi/ensctl2model_ad.f90
index 706dafc59c..4adf4486f2 100644
--- a/src/gsi/ensctl2model_ad.f90
+++ b/src/gsi/ensctl2model_ad.f90
@@ -51,7 +51,7 @@ subroutine ensctl2model_ad(eval,mval,grad)
type(gsi_bundle) , intent(in ) :: eval(ntlevs_ens)
! Declare local variables
-character(len=*),parameter::myname='ensctl2state'
+character(len=*),parameter::myname='ensctl2model_ad'
character(len=max_varname_length),allocatable,dimension(:) :: clouds
integer(i_kind) :: ii,jj,ic,id,istatus,nclouds,nn
diff --git a/src/gsi/ensctl2state.f90 b/src/gsi/ensctl2state.f90
index 0d6d3042c5..4afc87d56e 100644
--- a/src/gsi/ensctl2state.f90
+++ b/src/gsi/ensctl2state.f90
@@ -1,4 +1,66 @@
-subroutine ensctl2state(xhat,mval,eval)
+!-------------------------------------------------------------------------
+! NOAA/NCEP, National Centers for Environmental Prediction GSI !
+!-------------------------------------------------------------------------
+!BOP
+!
+! !MODULE: ensctl2state_mod --- ensctl2state_mod variables and routines
+!
+! !INTERFACE:
+!
+module ensctl2state_mod
+
+! !USES:
+
+
+! !DESCRIPTION: module ensctl2state routines and variables
+
+
+use constants, only: zero,max_varname_length
+use kinds, only: r_kind,i_kind
+use control_vectors, only: control_vector,cvars3d,e2sset_flg
+use gsi_4dvar, only: ibin_anl
+use hybrid_ensemble_parameters, only: uv_hyb_ens,dual_res,ntlevs_ens,q_hyb_ens
+use hybrid_ensemble_isotropic, only: ensemble_forward_model,ensemble_forward_model_dual_res
+use hybrid_ensemble_isotropic, only: ensemble_forward_model_ad,ensemble_forward_model_ad_dual_res
+use balmod, only: strong_bk,strong_bk_ad
+use gsi_bundlemod, only: gsi_bundlecreate
+use gsi_bundlemod, only: gsi_bundle
+use gsi_bundlemod, only: gsi_bundlegetpointer
+use gsi_bundlemod, only: gsi_bundlegetvar
+use gsi_bundlemod, only: gsi_bundleputvar
+use gsi_bundlemod, only: gsi_bundledestroy
+use gsi_bundlemod, only: self_add
+use gsi_bundlemod, only: assignment(=)
+use mpeu_util, only: getindex
+use gsi_metguess_mod, only: gsi_metguess_get
+use mod_strong, only: tlnmc_option
+use cwhydromod, only: cw2hydro_tl,cw2hydro_ad
+use cwhydromod, only: cw2hydro_tl_hwrf,cw2hydro_ad_hwrf
+use timermod, only: timer_ini,timer_fnl
+use gridmod, only: nems_nmmb_regional
+
+implicit none
+
+private
+public :: ensctl2state,ensctl2state_ad
+
+logical :: ls_u,ls_v,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi
+logical :: ls_qr,ls_qs,ls_qg,ls_qh
+logical :: ls_w,ls_dw
+
+logical :: lc_sf,lc_vp,lc_ps,lc_t,lc_rh,lc_cw
+logical :: lc_w,lc_dw
+
+logical :: do_getuv,do_tv_to_tsen,do_normal_rh_to_q,do_getprs,lstrong_bk_vars
+logical :: do_q_copy
+logical :: do_cw_to_hydro
+logical :: do_cw_to_hydro_hwrf
+
+integer(i_kind) :: nclouds,idozone,istatus
+
+
+contains
+ subroutine ensctl2state(xhat,mval,eval)
!$$$ subprogram documentation block
! . . . .
! subprogram: ensctl2state
@@ -25,28 +87,6 @@ subroutine ensctl2state(xhat,mval,eval)
!
!$$$ end documentation block
-use constants, only: zero,max_varname_length
-use kinds, only: r_kind,i_kind
-use control_vectors, only: control_vector,cvars3d
-use gsi_4dvar, only: ibin_anl
-use hybrid_ensemble_parameters, only: uv_hyb_ens,dual_res,ntlevs_ens,q_hyb_ens
-use hybrid_ensemble_isotropic, only: ensemble_forward_model,ensemble_forward_model_dual_res
-use balmod, only: strong_bk
-use gsi_bundlemod, only: gsi_bundlecreate
-use gsi_bundlemod, only: gsi_bundle
-use gsi_bundlemod, only: gsi_bundlegetpointer
-use gsi_bundlemod, only: gsi_bundlegetvar
-use gsi_bundlemod, only: gsi_bundleputvar
-use gsi_bundlemod, only: gsi_bundledestroy
-use gsi_bundlemod, only: self_add
-use gsi_bundlemod, only: assignment(=)
-use mpeu_util, only: getindex
-use gsi_metguess_mod, only: gsi_metguess_get
-use mod_strong, only: tlnmc_option
-use cwhydromod, only: cw2hydro_tl
-use cwhydromod, only: cw2hydro_tl_hwrf
-use timermod, only: timer_ini,timer_fnl
-use gridmod, only: nems_nmmb_regional
implicit none
! Declare passed variables
@@ -57,28 +97,14 @@ subroutine ensctl2state(xhat,mval,eval)
! Declare local variables
character(len=*),parameter::myname='ensctl2state'
character(len=max_varname_length),allocatable,dimension(:) :: clouds
-integer(i_kind) :: jj,ic,id,istatus,nclouds
+integer(i_kind) :: jj,ic,id
+logical :: do_tlnmc
-integer(i_kind), parameter :: ncvars = 8
-integer(i_kind) :: icps(ncvars)
type(gsi_bundle):: wbundle_c ! work bundle
-character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here
- 'sf ', 'vp ', 'ps ', 't ', &
- 'q ', 'cw ', 'w ', 'dw '/)
-logical :: lc_sf,lc_vp,lc_ps,lc_t,lc_rh,lc_cw
-logical :: lc_w,lc_dw
real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL()
! Declare required local state variables
-integer(i_kind), parameter :: nsvars = 13
-integer(i_kind) :: isps(nsvars)
-character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here
- 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ','qi ', &
- 'qr ', 'qs ', 'qg ', 'qh ', 'w ', 'dw ' /)
-logical :: ls_u,ls_v,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi
-logical :: ls_qr,ls_qs,ls_qg,ls_qh
-logical :: ls_w,ls_dw
real(r_kind),pointer,dimension(:,:) :: sv_ps=>NULL()
real(r_kind),pointer,dimension(:,:) :: sv_sst=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: sv_u=>NULL()
@@ -92,50 +118,20 @@ subroutine ensctl2state(xhat,mval,eval)
real(r_kind),pointer,dimension(:,:,:) :: sv_w=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: sv_dw=>NULL()
-logical :: do_getprs_tl,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,lstrong_bk_vars
-logical :: do_tlnmc,do_q_copy
-logical :: do_cw_to_hydro
-logical :: do_cw_to_hydro_hwrf
-
! ****************************************************************************
! Initialize timer
! call timer_ini(trim(myname))
+if(e2sset_flg)call ensctl2state_set(xhat,eval)
+
! Inquire about cloud-vars
-call gsi_metguess_get('clouds::3d',nclouds,istatus)
if (nclouds>0) then
allocate(clouds(nclouds))
call gsi_metguess_get('clouds::3d',clouds,istatus)
endif
-! Since each internal vector of xhat has the same structure, pointers are
-! the same independent of the subwindow jj
-call gsi_bundlegetpointer (xhat%step(1),mycvars,icps,istatus)
-lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0
-lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0
-lc_w =icps(7)>0; lc_dw =icps(8)>0
-
-! Since each internal vector of xhat has the same structure, pointers are
-! the same independent of the subwindow jj
-call gsi_bundlegetpointer (eval(1),mysvars,isps,istatus)
-ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0
-ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0; ls_qi =isps(7)>0
-ls_qr =isps(8)>0; ls_qs =isps(9)>0
-ls_qg =isps(10)>0; ls_qh =isps(11)>0
-ls_w =isps(12)>0; ls_dw =isps(13)>0
-! Define what to do depending on what's in CV and SV
-lstrong_bk_vars =lc_ps.and.lc_sf.and.lc_vp.and.lc_t
-do_getprs_tl =lc_ps.and.lc_t .and.ls_prse
-do_normal_rh_to_q=(.not.q_hyb_ens).and.&
- lc_rh.and.lc_t .and.ls_prse.and.ls_q
-do_q_copy=.false.
-if(.not. do_normal_rh_to_q) then
- do_q_copy = lc_rh.and.lc_t .and.ls_prse.and.ls_q.and.q_hyb_ens
-end if
-do_tv_to_tsen =lc_t .and.ls_q .and.ls_tsen
-do_getuv =lc_sf.and.lc_vp.and.ls_u.and.ls_v
! Create a temporary bundle similar to xhat, and copy contents of xhat into it
call gsi_bundlecreate ( wbundle_c, xhat%step(1), 'ensctl2state work', istatus )
if(istatus/=0) then
@@ -143,10 +139,6 @@ subroutine ensctl2state(xhat,mval,eval)
call stop2(999)
endif
-do_cw_to_hydro = .false.
-do_cw_to_hydro = lc_cw .and. ls_ql .and. ls_qi
-do_cw_to_hydro_hwrf = .false.
-do_cw_to_hydro_hwrf = lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh
! Initialize ensemble contribution to zero
!$omp parallel do schedule(dynamic,1) private(jj)
@@ -205,7 +197,7 @@ subroutine ensctl2state(xhat,mval,eval)
if(do_q_copy) then
call gsi_bundlegetvar ( wbundle_c, 'q', sv_q, istatus )
else
- if(do_getprs_tl) call getprs_tl(sv_ps,sv_tv,sv_prse)
+ if(do_getprs) call getprs_tl(sv_ps,sv_tv,sv_prse)
! Convert RH to Q
if(do_normal_rh_to_q) then
@@ -239,24 +231,23 @@ subroutine ensctl2state(xhat,mval,eval)
!$omp section
-! Get pointers to required state variables
- call gsi_bundlegetpointer (eval(jj),'oz' ,sv_oz , istatus)
+! Get pointers to required state variables and copy
call gsi_bundlegetpointer (eval(jj),'sst' ,sv_sst, istatus)
- if(ls_w)then
+ call gsi_bundlegetvar ( wbundle_c, 'sst', sv_sst, istatus )
+ if(ls_w .and. lc_w)then
call gsi_bundlegetpointer (eval(jj),'w' ,sv_w, istatus)
- if(ls_dw.and.nems_nmmb_regional)then
+ call gsi_bundlegetvar ( wbundle_c, 'w' , sv_w, istatus )
+ if(ls_dw .and. lc_dw)then
call gsi_bundlegetpointer (eval(jj),'dw' ,sv_dw, istatus)
+ call gsi_bundlegetvar ( wbundle_c, 'dw' , sv_dw, istatus )
end if
end if
-! Copy variables
- call gsi_bundlegetvar ( wbundle_c, 'oz' , sv_oz, istatus )
- call gsi_bundlegetvar ( wbundle_c, 'sst', sv_sst, istatus )
- if(lc_w)then
- call gsi_bundlegetvar ( wbundle_c, 'w' , sv_w, istatus )
- if(lc_dw.and.nems_nmmb_regional)then
- call gsi_bundlegetvar ( wbundle_c, 'dw' , sv_dw, istatus )
- end if
- end if
+
+! Get the ozone vector if it is defined
+ if(idozone > 0) then
+ call gsi_bundlegetpointer (eval(jj),'oz' ,sv_oz , istatus)
+ call gsi_bundlegetvar ( wbundle_c, 'oz' , sv_oz, istatus )
+ endif
!$omp end parallel sections
@@ -270,7 +261,7 @@ subroutine ensctl2state(xhat,mval,eval)
! Need to update 3d pressure and sensible temperature again for consistency
! Get 3d pressure
- if(do_getprs_tl) call getprs_tl(sv_ps,sv_tv,sv_prse)
+ if(do_getprs) call getprs_tl(sv_ps,sv_tv,sv_prse)
end if
@@ -292,3 +283,287 @@ subroutine ensctl2state(xhat,mval,eval)
return
end subroutine ensctl2state
+
+subroutine ensctl2state_set(xhat,eval)
+! . . . .
+! subprogram: ensctl2state_set
+! prgmmr: derber
+!
+! abstract: Sets flags for ensctl2state and ensctl2state_ad
+!
+! program history log:
+! 2022-08-30 derber - initial code from control2state
+
+! input argument list:
+! xhat - Control variable
+! sval - State variable
+!
+!$$$ end documentation block
+
+implicit none
+
+type(control_vector), intent(in) :: xhat
+type(gsi_bundle) , intent(in) :: eval(ntlevs_ens)
+
+integer(i_kind), parameter :: nsvars = 13
+integer(i_kind) :: isps(nsvars)
+character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here
+ 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ','qi ', &
+ 'qr ', 'qs ', 'qg ', 'qh ', 'w ', 'dw ' /)
+integer(i_kind), parameter :: ncvars = 8
+integer(i_kind) :: icps(ncvars)
+character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here
+ 'sf ', 'vp ', 'ps ', 't ', &
+ 'q ', 'cw ', 'w ', 'dw '/)
+! Inquire about cloud-vars
+call gsi_metguess_get('clouds::3d',nclouds,istatus)
+
+! Since each internal vector of xhat has the same structure, pointers are
+! the same independent of the subwindow jj
+call gsi_bundlegetpointer (xhat%step(1),mycvars,icps,istatus)
+lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0
+lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0
+lc_w =icps(7)>0; lc_dw =icps(8)>0
+
+! Since each internal vector of xhat has the same structure, pointers are
+! the same independent of the subwindow jj
+call gsi_bundlegetpointer (eval(1),mysvars,isps,istatus)
+ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0
+ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0; ls_qi =isps(7)>0
+ls_qr =isps(8)>0; ls_qs =isps(9)>0
+ls_qg =isps(10)>0; ls_qh =isps(11)>0
+ls_w =isps(12)>0; ls_dw =isps(13)>0.and.nems_nmmb_regional
+
+! Define what to do depending on what's in CV and SV
+lstrong_bk_vars =lc_ps.and.lc_sf.and.lc_vp.and.lc_t
+do_getprs =lc_ps.and.lc_t .and.ls_prse
+do_normal_rh_to_q=(.not.q_hyb_ens).and.&
+ lc_rh.and.lc_t .and.ls_prse.and.ls_q
+if(.not. do_normal_rh_to_q) then
+ do_q_copy = lc_rh.and.lc_t .and.ls_prse.and.ls_q.and.q_hyb_ens
+else
+ do_q_copy=.false.
+end if
+do_tv_to_tsen =lc_t .and.ls_q .and.ls_tsen
+do_getuv =lc_sf.and.lc_vp.and.ls_u.and.ls_v
+
+do_cw_to_hydro = lc_cw .and. ls_ql .and. ls_qi
+do_cw_to_hydro_hwrf = lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh
+
+
+idozone=getindex(cvars3d,"oz")
+
+e2sset_flg=.false. ! set to true in setup. set to false after first (only) call to ensctl2state_set
+
+
+return
+end subroutine ensctl2state_set
+subroutine ensctl2state_ad(eval,mval,grad)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: ensctl2state_ad
+! prgmmr: kleist
+!
+! abstract: Contribution from state space to ensemble control vector
+!
+! program history log:
+! 2011-11-17 kleist - initial code
+! 2013-10-28 todling - rename p3d to prse
+! 2013-11-22 kleist - add option for q perturbations
+! 2014-12-03 derber - introduce parallel regions for optimization
+! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu
+! 2019-07-11 Todling - there should be no need to check on the existence of w and dw
+!
+! input argument list:
+! eval - Ensemble state variable variable
+! grad - Control variable
+!
+! output argument list:
+! grad - Control variable
+!
+!$$$ end documentation block
+
+implicit none
+
+! Declare passed variables
+type(control_vector), intent(inout) :: grad
+type(gsi_bundle) , intent(inout) :: mval
+type(gsi_bundle) , intent(in ) :: eval(ntlevs_ens)
+
+! Declare local variables
+character(len=*),parameter::myname='ensctl2state_ad'
+integer(i_kind) :: jj,ic,id
+logical :: do_tlnmc
+
+character(len=max_varname_length),allocatable,dimension(:) :: clouds
+type(gsi_bundle):: wbundle_c ! work bundle
+real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL()
+! Declare required local state variables
+real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL()
+real(r_kind),pointer,dimension(:,:) :: rv_sst=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_v=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_prse=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_tsen=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_tv=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_oz=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_w=>NULL()
+real(r_kind),pointer,dimension(:,:,:) :: rv_dw=>NULL()
+
+!****************************************************************************
+
+! Initialize timer
+!call timer_ini(trim(myname))
+
+! Inquire about chemistry
+if(e2sset_flg)call ensctl2state_set(grad,eval)
+if (nclouds>0) then
+ allocate(clouds(nclouds))
+ call gsi_metguess_get('clouds::3d',clouds,istatus)
+endif
+
+! Initialize
+mval%values=zero
+! Create a temporary bundle similar to grad, and copy contents of grad into it
+call gsi_bundlecreate ( wbundle_c, grad%step(1), 'ensctl2state_ad work', istatus )
+if(istatus/=0) then
+ write(6,*) trim(myname), ': trouble creating work bundle'
+ call stop2(999)
+endif
+
+do jj=1,ntlevs_ens
+
+! If calling TLNMC, already have u,v (so set last argument to true)
+ do_tlnmc = lstrong_bk_vars .and. ( (tlnmc_option==3) .or. &
+ (jj==ibin_anl .and. tlnmc_option==2))
+
+ wbundle_c%values=zero
+
+! Get sv pointers here
+! Get pointers to required state variables
+ call gsi_bundlegetpointer (eval(jj),'u' ,rv_u, istatus)
+ call gsi_bundlegetpointer (eval(jj),'v' ,rv_v, istatus)
+ call gsi_bundlegetpointer (eval(jj),'ps' ,rv_ps, istatus)
+ call gsi_bundlegetpointer (eval(jj),'prse',rv_prse,istatus)
+ call gsi_bundlegetpointer (eval(jj),'tv' ,rv_tv, istatus)
+ call gsi_bundlegetpointer (eval(jj),'tsen',rv_tsen,istatus)
+ call gsi_bundlegetpointer (eval(jj),'q' ,rv_q , istatus)
+ call gsi_bundlegetpointer (wbundle_c,'q' ,cv_rh ,istatus)
+
+! Adjoint of consistency for sensible temperature, calculate sensible temperature
+ if(do_tv_to_tsen) call tv_to_tsen_ad(rv_tv,rv_q,rv_tsen)
+
+ if(do_tlnmc) then
+
+ ! Adjoint to convert ps to 3-d pressure
+ if(do_getprs) call getprs_ad(rv_ps,rv_tv,rv_prse)
+ rv_prse=zero
+
+ ! Adjoint of strong_bk
+ call strong_bk_ad(rv_u,rv_v,rv_ps,rv_tv,.true.)
+
+ end if
+
+ call self_add(mval,eval(jj))
+
+!$omp parallel sections private(ic,id,istatus)
+
+!$omp section
+
+! Convert RHS calculations for u,v to st/vp
+ if (do_getuv) then
+ if(uv_hyb_ens) then
+ call gsi_bundleputvar ( wbundle_c, 'sf', rv_u, istatus )
+ call gsi_bundleputvar ( wbundle_c, 'vp', rv_v, istatus )
+ else
+ call gsi_bundlegetpointer (wbundle_c,'sf' ,cv_sf ,istatus)
+ call gsi_bundlegetpointer (wbundle_c,'vp' ,cv_vp ,istatus)
+ call getuv(rv_u,rv_v,cv_sf,cv_vp,1)
+ end if
+ end if
+
+!$omp section
+
+ call gsi_bundlegetpointer (eval(jj),'sst' ,rv_sst, istatus)
+ call gsi_bundleputvar ( wbundle_c, 'sst', rv_sst, istatus )
+ if(lc_w .and. ls_w)then
+ call gsi_bundlegetpointer (eval(jj),'w' ,rv_w, istatus)
+ call gsi_bundleputvar ( wbundle_c, 'w', rv_w, istatus )
+ if(ls_dw .and. lc_dw)then
+ call gsi_bundlegetpointer (eval(jj),'dw' ,rv_dw, istatus)
+ call gsi_bundleputvar ( wbundle_c, 'dw', rv_dw, istatus )
+ end if
+ end if
+
+! Get the ozone vector if it is defined
+ if(idozone > 0) then
+ call gsi_bundlegetpointer (eval(jj),'oz' ,rv_oz , istatus)
+ call gsi_bundleputvar ( wbundle_c, 'oz', rv_oz, istatus )
+ endif
+
+!$omp section
+
+ if (do_cw_to_hydro .and. .not.do_cw_to_hydro_hwrf) then
+! Case when cloud-vars do not map one-to-one
+! e.g. cw-to-ql&qi
+ call cw2hydro_ad(eval(jj),wbundle_c,clouds,nclouds)
+ elseif (do_cw_to_hydro_hwrf) then
+!! Case when cloud-vars do not map one-to-one
+!! e.g. cw-to-ql&qi&qr&qs&qg&qh
+ call cw2hydro_ad_hwrf(eval(jj),wbundle_c,rv_tsen)
+ else
+! Since cloud-vars map one-to-one, take care of them together
+ do ic=1,nclouds
+ id=getindex(cvars3d,clouds(ic))
+ if (id>0) then
+ call gsi_bundlegetpointer (eval(jj),clouds(ic),rv_rank3,istatus)
+ call gsi_bundleputvar (wbundle_c, clouds(ic),rv_rank3,istatus)
+ endif
+ enddo
+ endif
+
+! Calculate sensible temperature
+ if(do_q_copy) then
+ call gsi_bundleputvar (wbundle_c, 'q', rv_q, istatus )
+ else
+
+! Adjoint of convert input normalized RH to q to add contribution of moisture
+! to t, p , and normalized rh
+ if(do_normal_rh_to_q) call normal_rh_to_q_ad(cv_rh,rv_tv,rv_prse,rv_q)
+
+! Adjoint to convert ps to 3-d pressure
+ if(do_getprs) call getprs_ad(rv_ps,rv_tv,rv_prse)
+ end if
+
+! Adjoint of control to initial state
+ call gsi_bundleputvar ( wbundle_c, 't' , rv_tv, istatus )
+ call gsi_bundleputvar ( wbundle_c, 'ps', rv_ps, istatus )
+! call gsi_bundleputvar ( wbundle_c, 'q' , zero, istatus ) !mjk
+!$omp end parallel sections
+
+ if(dual_res) then
+ call ensemble_forward_model_ad_dual_res(wbundle_c,grad%aens(1,:,:),jj)
+ else
+ call ensemble_forward_model_ad(wbundle_c,grad%aens(1,:,:),jj)
+ end if
+
+end do
+
+call gsi_bundledestroy(wbundle_c,istatus)
+if (istatus/=0) then
+ write(6,*) trim(myname),': trouble destroying work bundle'
+ call stop2(999)
+endif
+
+if (nclouds>0) deallocate(clouds)
+
+! Finalize timer
+!call timer_fnl(trim(myname))
+
+return
+end subroutine ensctl2state_ad
+end module ensctl2state_mod
diff --git a/src/gsi/ensctl2state_ad.f90 b/src/gsi/ensctl2state_ad.f90
deleted file mode 100644
index 4c038c8c6e..0000000000
--- a/src/gsi/ensctl2state_ad.f90
+++ /dev/null
@@ -1,282 +0,0 @@
-subroutine ensctl2state_ad(eval,mval,grad)
-!$$$ subprogram documentation block
-! . . . .
-! subprogram: ensctl2state_ad
-! prgmmr: kleist
-!
-! abstract: Contribution from state space to ensemble control vector
-!
-! program history log:
-! 2011-11-17 kleist - initial code
-! 2013-10-28 todling - rename p3d to prse
-! 2013-11-22 kleist - add option for q perturbations
-! 2014-12-03 derber - introduce parallel regions for optimization
-! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu
-! 2019-07-11 Todling - there should be no need to check on the existence of w and dw
-!
-! input argument list:
-! eval - Ensemble state variable variable
-! grad - Control variable
-!
-! output argument list:
-! grad - Control variable
-!
-!$$$ end documentation block
-
-use kinds, only: r_kind,i_kind
-use control_vectors, only: control_vector,cvars3d
-use gsi_4dvar, only: ibin_anl
-use hybrid_ensemble_parameters, only: uv_hyb_ens,dual_res,ntlevs_ens,q_hyb_ens
-use hybrid_ensemble_isotropic, only: ensemble_forward_model_ad
-use hybrid_ensemble_isotropic, only: ensemble_forward_model_ad_dual_res
-use balmod, only: strong_bk_ad
-use gsi_bundlemod, only: gsi_bundlecreate
-use gsi_bundlemod, only: gsi_bundle
-use gsi_bundlemod, only: gsi_bundlegetpointer
-use gsi_bundlemod, only: gsi_bundlegetvar
-use gsi_bundlemod, only: gsi_bundleputvar
-use gsi_bundlemod, only: gsi_bundledestroy
-use gsi_bundlemod, only: assignment(=)
-use gsi_bundlemod, only : self_add
-use constants, only: zero,max_varname_length
-use mpeu_util, only: getindex
-use gsi_metguess_mod, only: gsi_metguess_get
-use mod_strong, only: tlnmc_option
-use cwhydromod, only: cw2hydro_ad
-use cwhydromod, only: cw2hydro_ad_hwrf
-use timermod, only: timer_ini,timer_fnl
-use gridmod, only: nems_nmmb_regional
-implicit none
-
-! Declare passed variables
-type(control_vector), intent(inout) :: grad
-type(gsi_bundle) , intent(inout) :: mval
-type(gsi_bundle) , intent(in ) :: eval(ntlevs_ens)
-
-! Declare local variables
-character(len=*),parameter::myname='ensctl2state_ad'
-character(len=max_varname_length),allocatable,dimension(:) :: clouds
-integer(i_kind) :: jj,ic,id,istatus,nclouds
-
-integer(i_kind), parameter :: ncvars = 8
-integer(i_kind) :: icps(ncvars)
-type(gsi_bundle):: wbundle_c ! work bundle
-character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here
- 'sf ', 'vp ', 'ps ', 't ', &
- 'q ', 'cw ', 'w ', 'dw '/)
-logical :: lc_sf,lc_vp,lc_ps,lc_t,lc_rh,lc_cw
-logical :: lc_w,lc_dw
-real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL()
-! Declare required local state variables
-integer(i_kind), parameter :: nsvars = 13
-integer(i_kind) :: isps(nsvars)
-character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here
- 'u ', 'v ', 'prse', 'q ', 'tsen','ql ','qi ', &
- 'qr ', 'qs ', 'qg ', 'qh ', 'w ','dw ' /)
-logical :: ls_u,ls_v,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi
-logical :: ls_qr,ls_qs,ls_qg,ls_qh
-logical :: ls_w,ls_dw
-real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL()
-real(r_kind),pointer,dimension(:,:) :: rv_sst=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_v=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_prse=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_tsen=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_tv=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_oz=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_w=>NULL()
-real(r_kind),pointer,dimension(:,:,:) :: rv_dw=>NULL()
-
-logical :: do_getuv,do_tv_to_tsen_ad,do_normal_rh_to_q_ad,do_getprs_ad,lstrong_bk_vars
-logical :: do_tlnmc,do_q_copy
-logical :: do_cw_to_hydro_ad
-logical :: do_cw_to_hydro_ad_hwrf
-logical :: wdw_exist
-
-!****************************************************************************
-
-! Initialize timer
-!call timer_ini(trim(myname))
-
-! Inquire about chemistry
-call gsi_metguess_get('clouds::3d',nclouds,istatus)
-if (nclouds>0) then
- allocate(clouds(nclouds))
- call gsi_metguess_get('clouds::3d',clouds,istatus)
-endif
-
-! Since each internal vector of grad has the same structure, pointers are
-! the same independent of the subwindow jj
-call gsi_bundlegetpointer (grad%step(1),mycvars,icps,istatus)
-lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0
-lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0
-lc_w =icps(7)>0; lc_dw =icps(8)>0
-
-! Since each internal vector of grad has the same structure, pointers are
-! the same independent of the subwindow jj
-call gsi_bundlegetpointer (eval(1),mysvars,isps,istatus)
-ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0
-ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0; ls_qi =isps(7)>0
-ls_qr =isps(8)>0; ls_qs =isps(9)>0
-ls_qg =isps(10)>0; ls_qh =isps(11)>0
-ls_w =isps(12)>0; ls_dw =isps(13)>0
-
-! Define what to do depending on what's in CV and SV
-lstrong_bk_vars =lc_sf.and.lc_vp.and.lc_ps .and.lc_t
-do_getuv =lc_sf.and.lc_vp.and.ls_u .and.ls_v
-do_tv_to_tsen_ad =lc_t .and.ls_q .and.ls_tsen
-do_normal_rh_to_q_ad=(.not.q_hyb_ens).and.&
- lc_t .and.lc_rh.and.ls_prse.and.ls_q
-do_q_copy=.false.
-if(.not. do_normal_rh_to_q_ad) then
- do_q_copy = lc_rh.and.lc_t .and.ls_prse.and.ls_q.and.q_hyb_ens
-end if
-do_getprs_ad =lc_t .and.lc_ps.and.ls_prse
-
-do_cw_to_hydro_ad=.false.
-do_cw_to_hydro_ad=lc_cw.and.ls_ql.and.ls_qi
-do_cw_to_hydro_ad_hwrf=.false.
-do_cw_to_hydro_ad_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh
-
-wdw_exist = lc_w.and.lc_dw.and.ls_w.and.ls_dw
-
-! Initialize
-mval%values=zero
-! Create a temporary bundle similar to grad, and copy contents of grad into it
-call gsi_bundlecreate ( wbundle_c, grad%step(1), 'ensctl2state_ad work', istatus )
-if(istatus/=0) then
- write(6,*) trim(myname), ': trouble creating work bundle'
- call stop2(999)
-endif
-
-do jj=1,ntlevs_ens
-
-! If calling TLNMC, already have u,v (so set last argument to true)
- do_tlnmc = lstrong_bk_vars .and. ( (tlnmc_option==3) .or. &
- (jj==ibin_anl .and. tlnmc_option==2))
-
- wbundle_c%values=zero
-
-! Get sv pointers here
-! Get pointers to required state variables
- call gsi_bundlegetpointer (eval(jj),'u' ,rv_u, istatus)
- call gsi_bundlegetpointer (eval(jj),'v' ,rv_v, istatus)
- call gsi_bundlegetpointer (eval(jj),'ps' ,rv_ps, istatus)
- call gsi_bundlegetpointer (eval(jj),'prse',rv_prse,istatus)
- call gsi_bundlegetpointer (eval(jj),'tv' ,rv_tv, istatus)
- call gsi_bundlegetpointer (eval(jj),'tsen',rv_tsen,istatus)
- call gsi_bundlegetpointer (eval(jj),'q' ,rv_q , istatus)
- call gsi_bundlegetpointer (wbundle_c,'q' ,cv_rh ,istatus)
-
-! Adjoint of consistency for sensible temperature, calculate sensible temperature
- if(do_tv_to_tsen_ad) call tv_to_tsen_ad(rv_tv,rv_q,rv_tsen)
-
- if(do_tlnmc) then
-
- ! Adjoint to convert ps to 3-d pressure
- if(do_getprs_ad) call getprs_ad(rv_ps,rv_tv,rv_prse)
- rv_prse=zero
-
- ! Adjoint of strong_bk
- call strong_bk_ad(rv_u,rv_v,rv_ps,rv_tv,.true.)
-
- end if
-
- call self_add(mval,eval(jj))
-
-!$omp parallel sections private(ic,id,istatus)
-
-!$omp section
-
-! Convert RHS calculations for u,v to st/vp
- if (do_getuv) then
- if(uv_hyb_ens) then
- call gsi_bundleputvar ( wbundle_c, 'sf', rv_u, istatus )
- call gsi_bundleputvar ( wbundle_c, 'vp', rv_v, istatus )
- else
- call gsi_bundlegetpointer (wbundle_c,'sf' ,cv_sf ,istatus)
- call gsi_bundlegetpointer (wbundle_c,'vp' ,cv_vp ,istatus)
- call getuv(rv_u,rv_v,cv_sf,cv_vp,1)
- end if
- end if
-
-!$omp section
-
- call gsi_bundlegetpointer (eval(jj),'oz' ,rv_oz , istatus)
- call gsi_bundlegetpointer (eval(jj),'sst' ,rv_sst, istatus)
- call gsi_bundleputvar ( wbundle_c, 'oz', rv_oz, istatus )
- call gsi_bundleputvar ( wbundle_c, 'sst', rv_sst, istatus )
- if(wdw_exist)then
- call gsi_bundlegetpointer (eval(jj),'w' ,rv_w, istatus)
- call gsi_bundleputvar ( wbundle_c, 'w', rv_w, istatus )
- if(nems_nmmb_regional)then
- call gsi_bundlegetpointer (eval(jj),'dw' ,rv_dw, istatus)
- call gsi_bundleputvar ( wbundle_c, 'dw', rv_dw, istatus )
- end if
- end if
-
-!$omp section
-
- if (do_cw_to_hydro_ad .and. .not.do_cw_to_hydro_ad_hwrf) then
-! Case when cloud-vars do not map one-to-one
-! e.g. cw-to-ql&qi
- call cw2hydro_ad(eval(jj),wbundle_c,clouds,nclouds)
- elseif (do_cw_to_hydro_ad_hwrf) then
-!! Case when cloud-vars do not map one-to-one
-!! e.g. cw-to-ql&qi&qr&qs&qg&qh
- call cw2hydro_ad_hwrf(eval(jj),wbundle_c,rv_tsen)
- else
-! Since cloud-vars map one-to-one, take care of them together
- do ic=1,nclouds
- id=getindex(cvars3d,clouds(ic))
- if (id>0) then
- call gsi_bundlegetpointer (eval(jj),clouds(ic),rv_rank3,istatus)
- call gsi_bundleputvar (wbundle_c, clouds(ic),rv_rank3,istatus)
- endif
- enddo
- endif
-
-! Calculate sensible temperature
- if(do_q_copy) then
- call gsi_bundleputvar (wbundle_c, 'q', rv_q, istatus )
- else
-
-! Adjoint of convert input normalized RH to q to add contribution of moisture
-! to t, p , and normalized rh
- if(do_normal_rh_to_q_ad) call normal_rh_to_q_ad(cv_rh,rv_tv,rv_prse,rv_q)
-
-! Adjoint to convert ps to 3-d pressure
- if(do_getprs_ad) call getprs_ad(rv_ps,rv_tv,rv_prse)
- end if
-
-! Adjoint of control to initial state
- call gsi_bundleputvar ( wbundle_c, 't' , rv_tv, istatus )
- call gsi_bundleputvar ( wbundle_c, 'ps', rv_ps, istatus )
-! call gsi_bundleputvar ( wbundle_c, 'q' , zero, istatus ) !mjk
-!$omp end parallel sections
-
- if(dual_res) then
- call ensemble_forward_model_ad_dual_res(wbundle_c,grad%aens(1,:,:),jj)
- else
- call ensemble_forward_model_ad(wbundle_c,grad%aens(1,:,:),jj)
- end if
-
-end do
-
-call gsi_bundledestroy(wbundle_c,istatus)
-if (istatus/=0) then
- write(6,*) trim(myname),': trouble destroying work bundle'
- call stop2(999)
-endif
-
-if (nclouds>0) deallocate(clouds)
-
-! Finalize timer
-!call timer_fnl(trim(myname))
-
-return
-end subroutine ensctl2state_ad
diff --git a/src/gsi/evaljgrad.f90 b/src/gsi/evaljgrad.f90
index 788454034d..e66ca11b8c 100644
--- a/src/gsi/evaljgrad.f90
+++ b/src/gsi/evaljgrad.f90
@@ -73,6 +73,7 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby)
use xhat_vordivmod, only : xhat_vordiv_init, xhat_vordiv_calc, xhat_vordiv_clean
use mpeu_util, only: die
use mpl_allreducemod, only: mpl_allreduce
+use intradmod, only: setrad
implicit none
@@ -195,6 +196,7 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby)
end do
qpred=zero_quad
+call setrad(sval(1))
! Compare obs to solution and transpose back to grid (H^T R^{-1} H)
call intjo(rval,qpred,sval,sbias)
diff --git a/src/gsi/general_commvars_mod.f90 b/src/gsi/general_commvars_mod.f90
index daf182fbdd..f171850373 100644
--- a/src/gsi/general_commvars_mod.f90
+++ b/src/gsi/general_commvars_mod.f90
@@ -19,8 +19,8 @@ module general_commvars_mod
! def s2g_raf - used for subdomain to horizontal grid transfers of full control vector with motley variables
! def s2g_cv - used in bkerror.f90 (full control vector without motley variables)
! def s2g2 - used in getprs.f90
-! def s2g4 - used in get_derivatives2.f90
-! def s1g4 - used in get_derivatives2.f90 (uv versions)
+! def s2g4 - used in get_derivatives2.f90
+! def s1g4 - used in get_derivatives2.f90
! def s2guv - used in getuv.f90
! def s2g_d - used in get_derivatives.f90
! def g1 - used in get_derivatives.f90
@@ -255,7 +255,8 @@ subroutine init_general_commvars
num_fields=3*nsig+1
call general_sub2grid_create_info(g33p1,inner_vars,nlat,nlon,nsig,num_fields,regional,s_ref=s2g_raf)
-! create general_sub2grid structure variable s2g4, which is used in get_derivatives2.f90
+! create general_sub2grid structure variable s2g4, which is used in
+! get_derivatives2.f90
num_fields=2*nsig+1
inner_vars=2
@@ -515,7 +516,7 @@ subroutine fill_ns(grid_in,grid_out)
sumn=sumn+grid_in(i,1)
sums=sums+grid_in(i,nlatm2)
end do
- rnlon=one/float(nlon)
+ rnlon=one/real(nlon,r_kind)
sumn=sumn*rnlon
sums=sums*rnlon
@@ -620,7 +621,7 @@ subroutine fill2_ns(grid_in,grid_out,nlat,nlon)
sumn=sumn+grid_in(i,1)
sums=sums+grid_in(i,nlatm2)
end do
- rnlon=one/float(nlon)
+ rnlon=one/real(nlon,r_kind)
sumn=sumn*rnlon
sums=sums*rnlon
@@ -732,10 +733,10 @@ subroutine filluv_ns(gridu_in,gridv_in,gridu_out,gridv_out)
polsu=polsu+grid(i,2 )*coslon(i)+grid2(i,2 )*sinlon(i)
polsv=polsv+grid(i,2 )*sinlon(i)-grid2(i,2 )*coslon(i)
end do
- polnu=polnu/float(nlon)
- polnv=polnv/float(nlon)
- polsu=polsu/float(nlon)
- polsv=polsv/float(nlon)
+ polnu=polnu/real(nlon,r_kind)
+ polnv=polnv/real(nlon,r_kind)
+ polsu=polsu/real(nlon,r_kind)
+ polsv=polsv/real(nlon,r_kind)
do i=1,nlon
grid (i,nlat)= polnu*coslon(i)+polnv*sinlon(i)
grid2(i,nlat)=-polnu*sinlon(i)+polnv*coslon(i)
@@ -845,10 +846,10 @@ subroutine filluv2_ns(gridu_in,gridv_in,gridu_out,gridv_out,nlat,nlon,sinlon,cos
polsu=polsu+grid(i,2 )*coslon(i)+grid2(i,2 )*sinlon(i)
polsv=polsv+grid(i,2 )*sinlon(i)-grid2(i,2 )*coslon(i)
end do
- polnu=polnu/float(nlon)
- polnv=polnv/float(nlon)
- polsu=polsu/float(nlon)
- polsv=polsv/float(nlon)
+ polnu=polnu/real(nlon,r_kind)
+ polnv=polnv/real(nlon,r_kind)
+ polsu=polsu/real(nlon,r_kind)
+ polsv=polsv/real(nlon,r_kind)
do i=1,nlon
grid (i,nlat)= polnu*coslon(i)+polnv*sinlon(i)
grid2(i,nlat)=-polnu*sinlon(i)+polnv*coslon(i)
diff --git a/src/gsi/general_read_fv3atm.f90 b/src/gsi/general_read_fv3atm.f90
index 3d2646fbbb..d3fcfc1b6c 100644
--- a/src/gsi/general_read_fv3atm.f90
+++ b/src/gsi/general_read_fv3atm.f90
@@ -152,7 +152,8 @@ subroutine general_read_fv3atm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, &
call stop2(101)
endif
- fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
odate(3) = idate(3) !day
@@ -255,6 +256,7 @@ subroutine general_read_fv3atm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, &
call stop2(999)
endif
istatus=0
+ istatus1=0
call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus = istatus + ier
call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus = istatus + ier
call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus = istatus + ier
diff --git a/src/gsi/general_read_gfsatm.f90 b/src/gsi/general_read_gfsatm.f90
index 39db75db73..2971f27148 100755
--- a/src/gsi/general_read_gfsatm.f90
+++ b/src/gsi/general_read_gfsatm.f90
@@ -411,6 +411,77 @@ subroutine general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
return
end subroutine general_reload2
+
+! 2m reload
+subroutine general_reload_sfc(grd,g_t2m, g_q2m,g_ps,icount,iflag,work)
+! !USES:
+ use kinds, only: r_kind,i_kind
+ use mpimod, only: npe,mpi_comm_world,ierror,mpi_rtype
+ use general_sub2grid_mod, only: sub2grid_info
+
+ implicit none
+! !INPUT PARAMETERS:
+
+ type(sub2grid_info), intent(in ) :: grd
+ integer(i_kind), intent(inout) :: icount
+ integer(i_kind),dimension(npe), intent(inout) :: iflag
+ real(r_kind),dimension(grd%itotsub),intent(in ) :: work
+
+! !OUTPUT PARAMETERS:
+
+ real(r_kind),dimension(grd%lat2,grd%lon2), intent( out) :: g_t2m,&
+ g_q2m, g_ps
+
+! !DESCRIPTION: version of general_reload, for 2m variables.
+!
+! !REVISION HISTORY:
+! 2023-03-2 Draper
+!-------------------------------------------------------------------------
+
+ integer(i_kind) i,j,ij,k
+ real(r_kind),dimension(grd%lat2*grd%lon2,npe):: sub
+
+ call mpi_alltoallv(work,grd%sendcounts_s,grd%sdispls_s,mpi_rtype,&
+ sub,grd%recvcounts_s,grd%rdispls_s,mpi_rtype,&
+ mpi_comm_world,ierror)
+
+!$omp parallel do schedule(dynamic,1) private(k,i,j,ij)
+
+ do k=1,icount
+ if ( iflag(k) == 2 ) then
+ ij=0
+ do j=1,grd%lon2
+ do i=1,grd%lat2
+ ij=ij+1
+ g_t2m(i,j)=sub(ij,k)
+ enddo
+ enddo
+ elseif ( iflag(k) == 3 ) then
+ ij=0
+ do j=1,grd%lon2
+ do i=1,grd%lat2
+ ij=ij+1
+ g_q2m(i,j)=sub(ij,k)
+ enddo
+ enddo
+ elseif ( iflag(k) == 4 ) then
+ ij=0
+ do j=1,grd%lon2
+ do i=1,grd%lat2
+ ij=ij+1
+ g_ps(i,j)=sub(ij,k)
+ enddo
+ enddo
+ endif
+ enddo ! do k=1,icount
+
+ icount=0
+ iflag=0
+
+ return
+
+end subroutine general_reload_sfc
+
end module gfsreadmod
subroutine general_read_gfsatm(grd,sp_a,sp_b,filename,uvflag,vordivflag,zflag, &
@@ -431,6 +502,7 @@ subroutine general_read_gfsatm(grd,sp_a,sp_b,filename,uvflag,vordivflag,zflag, &
! 2014-11-30 todling - genelize interface to handle bundle instead of fields;
! internal code should be generalized
! 2014-12-03 derber - introduce vordivflag, zflag and optimize routines
+! 2023-03-23 draper - added option to read sfc files (for 2m variables)
!
! input argument list:
! grd - structure variable containing information about grid
@@ -1155,7 +1227,8 @@ subroutine general_read_gfsatm_nems(grd,sp_a,filename,uvflag,vordivflag,zflag, &
enddo
if (mype==0) write(6,*) trim(my_name), ' has_cf = ', has_cf
- fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
odate(3) = idate(3) !day
@@ -1892,7 +1965,7 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
use gsi_bundlemod, only: gsi_bundlegetpointer
use module_ncio, only: Dataset, Variable, Dimension, open_dataset,&
close_dataset, get_dim, read_vardata,get_idate_from_time_units
- use gfsreadmod, only: general_reload
+ use gfsreadmod, only: general_reload, general_reload_sfc
implicit none
@@ -1910,6 +1983,7 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
real(r_kind),pointer,dimension(:,:) :: ptr2d
real(r_kind),pointer,dimension(:,:,:) :: ptr3d
real(r_kind),pointer,dimension(:,:) :: g_ps
+ real(r_kind),pointer,dimension(:,:) :: g_t2m, g_q2m
real(r_kind),pointer,dimension(:,:,:) :: g_vor,g_div,&
g_cwmr,g_q,g_oz,g_tv
@@ -1942,10 +2016,9 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
logical :: procuse,diff_res,eqspace
type(egrid2agrid_parm) :: p_high
logical,dimension(1) :: vector
- type(Dataset) :: atmges
+ type(Dataset) :: filges
type(Dimension) :: ncdim
-
-
+ logical :: read_2m, read_z
!******************************************************************************
! Initialize variables used below
@@ -1959,6 +2032,19 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
mype_use=-1
icount=0
procuse=.false.
+
+ if (filename(1:3) == 'sfc') then
+ read_2m = .true.
+ read_z = .false.
+ if ( mype == 0 ) write(6,* ) &
+ trim(my_name), ': reading 2m variables from ', trim(filename)
+ else
+ read_2m = .false.
+ read_z = zflag
+ if ( mype == 0 ) write(6,* ) &
+ trim(my_name), ': reading atmos variables from ', trim(filename)
+ endif
+
if ( mype == 0 ) procuse = .true.
do i=1,npe
if ( grd%recvcounts_s(i-1) > 0 ) then
@@ -1992,23 +2078,24 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
if ( procuse ) then
- atmges = open_dataset(filename, paropen=.true., mpicomm=mpi_comm_read)
+ filges = open_dataset(filename, paropen=.true., mpicomm=mpi_comm_read)
! get dimension sizes
- ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len
- ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len
- ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len
+ ncdim = get_dim(filges, 'grid_xt'); lonb = ncdim%len
+ ncdim = get_dim(filges, 'grid_yt'); latb = ncdim%len
+ if (.not. read_2m) &
+ ncdim = get_dim(filges, 'pfull'); levs = ncdim%len
! get time information
- idate = get_idate_from_time_units(atmges)
+ idate = get_idate_from_time_units(filges)
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
odate(3) = idate(3) !day
odate(4) = idate(1) !year
- call read_vardata(atmges, 'time', fhour) ! might need to change this to attribute later
+ call read_vardata(filges, 'time', fhour) ! might need to change this to attribute later
! depends on model changes from
! Jeff Whitaker
- fhour = float(nint(fhour))
+ fhour = real(nint(fhour),r_kind)
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
@@ -2030,11 +2117,13 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
trim(my_name),grd%nlon,lonb
!call stop2(101)
endif
- if ( levs /= grd%nsig ) then
- if ( mype == 0 ) write(6, &
- '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') &
- trim(my_name),grd%nsig,levs
- call stop2(101)
+ if (.not. read_2m) then
+ if ( levs /= grd%nsig ) then
+ if ( mype == 0 ) write(6, &
+ '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') &
+ trim(my_name),grd%nsig,levs
+ call stop2(101)
+ endif
endif
allocate( spec_vor(sp_a%nc), spec_div(sp_a%nc) )
@@ -2047,8 +2136,8 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
allocate(rwork3d1(lonb,latb,1))
allocate(rwork2d(lonb,latb))
allocate(rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb))
- call read_vardata(atmges, 'grid_xt', rlons_tmp)
- call read_vardata(atmges, 'grid_yt', rlats_tmp)
+ call read_vardata(filges, 'grid_xt', rlons_tmp)
+ call read_vardata(filges, 'grid_yt', rlats_tmp)
do j=1,latb
rlats(latb+2-j)=deg2rad*rlats_tmp(j)
end do
@@ -2073,57 +2162,73 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
endif ! if ( procuse )
! Get pointer to relevant variables (this should be made flexible and general)
- iredundant=0
- call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- if ( iredundant==2 ) then
- if ( mype == 0 ) then
- write(6,*) 'general_read_gfsatm_nems: ERROR'
- write(6,*) 'cannot handle having both sf and div'
- write(6,*) 'Aborting ... '
- endif
- call stop2(999)
- endif
- iredundant=0
- call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- if ( iredundant==2 ) then
- if ( mype == 0 ) then
- write(6,*) 'general_read_gfsatm_nems: ERROR'
- write(6,*) 'cannot handle having both vp and vor'
- write(6,*) 'Aborting ... '
- endif
- call stop2(999)
- endif
- iredundant=0
- call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- if ( iredundant==2 ) then
- if ( mype == 0 ) then
- write(6,*) 'general_read_gfsatm_nems: ERROR'
- write(6,*) 'cannot handle having both t and tv'
- write(6,*) 'Aborting ... '
- endif
- call stop2(999)
- endif
- istatus=0
- call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier
- call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier
- call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier
- call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier
- if ( istatus /= 0 ) then
- if ( mype == 0 ) then
- write(6,*) 'general_read_gfsatm_nems: ERROR'
- write(6,*) 'Missing some of the required fields'
- write(6,*) 'Aborting ... '
- endif
- call stop2(999)
+ if (.not. read_2m) then
+ iredundant=0
+ call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ if ( iredundant==2 ) then
+ if ( mype == 0 ) then
+ write(6,*) 'general_read_gfsatm_nc: ERROR'
+ write(6,*) 'cannot handle having both sf and div'
+ write(6,*) 'Aborting ... '
+ endif
+ call stop2(999)
+ endif
+ iredundant=0
+ call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ if ( iredundant==2 ) then
+ if ( mype == 0 ) then
+ write(6,*) 'general_read_gfsatm_nc: ERROR'
+ write(6,*) 'cannot handle having both vp and vor'
+ write(6,*) 'Aborting ... '
+ endif
+ call stop2(999)
+ endif
+ iredundant=0
+ call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ if ( iredundant==2 ) then
+ if ( mype == 0 ) then
+ write(6,*) 'general_read_gfsatm_nc: ERROR'
+ write(6,*) 'cannot handle having both t and tv'
+ write(6,*) 'Aborting ... '
+ endif
+ call stop2(999)
+ endif
+
+ istatus=0
+ call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier
+ if ( istatus /= 0 ) then
+ if ( mype == 0 ) then
+ write(6,*) 'general_read_gfsatm_nc: ERROR'
+ write(6,*) 'Missing some of the required fields'
+ write(6,*) 'Aborting ... '
+ endif
+ call stop2(999)
+ endif
+ else ! read 2m vars
+ istatus=0
+ call gsi_bundlegetpointer(gfs_bundle,'t2m',g_t2m ,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(gfs_bundle,'q2m',g_q2m ,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier
+ if ( istatus /= 0 ) then
+ if ( mype == 0 ) then
+ write(6,*) 'general_read_gfsatm_nc: ERROR'
+ write(6,*) 'Missing 2m required variables'
+ write(6,*) 'Aborting ... '
+ endif
+ call stop2(999)
+ endif
endif
allocate(g_u(grd%lat2,grd%lon2,grd%nsig),g_v(grd%lat2,grd%lon2,grd%nsig))
allocate(g_z(grd%lat2,grd%lon2))
@@ -2135,8 +2240,8 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
! Once on the grid, fields need to be scattered from the full domain to
! sub-domains.
- ! Only read Terrain when zflag is true.
- if ( zflag ) then
+ ! Only read Terrain when read_z is true.
+ if ( read_z ) then
icount=icount+1
iflag(icount)=1
@@ -2145,7 +2250,7 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
! Terrain: spectral --> grid transform, scatter to all mpi tasks
if (mype==mype_use(icount)) then
! read hs
- call read_vardata(atmges, 'hgtsfc', rwork2d)
+ call read_vardata(filges, 'hgtsfc', rwork2d)
if ( diff_res ) then
grid_b=rwork2d
vector(1)=.false.
@@ -2161,415 +2266,498 @@ subroutine general_read_gfsatm_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
call general_fill_ns(grd,grid,work)
endif
endif
- if ( icount == icm ) then
+ if ( icount == icm ) then
call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
icount,iflag,ilev,work,uvflag,vordivflag)
endif
endif
- icount=icount+1
- iflag(icount)=2
- ilev(icount)=1
+ if (.not. read_2m) then
+
+ icount=icount+1
+ iflag(icount)=2
+ ilev(icount)=1
+
+ ! Surface pressure: same procedure as terrain
+ if (mype==mype_use(icount)) then
+ ! read ps
+ call read_vardata(filges, 'pressfc', rwork2d)
+ rwork2d = r0_001*rwork2d ! convert Pa to cb
+ if ( diff_res ) then
+ vector(1)=.false.
+ grid_b=rwork2d
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork2d
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
+ icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+
+ ! Thermodynamic variable: s-->g transform, communicate to all tasks
+ ! For multilevel fields, each task handles a given level. Periodic
+ ! mpi_alltoallv calls communicate the grids to all mpi tasks.
+ ! Finally, the grids are loaded into guess arrays used later in the
+ ! code.
+
+ do k=1,nlevs
+
+ icount=icount+1
+ iflag(icount)=3
+ ilev(icount)=k
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'spfh', rwork3d1, nslice=kr, slicedim=3)
+ call read_vardata(filges, 'tmp', rwork3d0, nslice=kr, slicedim=3)
+ rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1))
+ if ( diff_res ) then
+ grid_b=rwork2d
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork2d
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
+ icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ end do
+
+ if ( vordivflag .or. .not. uvflag ) then
+ do k=1,nlevs
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+ icount=icount+1
+ iflag(icount)=4
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
+ call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
+ ! Vorticity
+ ! Convert grid u,v to div and vor
+ if ( diff_res ) then
+ grid_b = rwork3d0(:,:,1)
+ grid_b2 = rwork3d1(:,:,1)
+ vector(1)=.true.
+ call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ do j=1,grd%nlon
+ do i=2,grd%nlat-1
+ grid(j,grd%nlat-i)=grid2(i,j,1)
+ enddo
+ enddo
+ call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work_v(kk)=grid2(i,j,1)
+ enddo
+ do j=1,grd%nlon
+ do i=2,grd%nlat-1
+ grid_v(j,grd%nlat-i)=grid2(i,j,1)
+ enddo
+ enddo
+ else
+ grid = rwork3d0(:,:,1)
+ grid_v = rwork3d1(:,:,1)
+ call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
+ endif
+ allocate( grid_vor(grd%nlon,nlatm2))
+ call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1)
+ call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1)
+ ! Load values into rows for south and north pole
+ call general_fill_ns(grd,grid_vor,work)
+ deallocate(grid_vor)
+ endif
+ if ( icount == icm ) then
+ call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
+ icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+
+ end do
+ do k=1,nlevs
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ icount=icount+1
+ iflag(icount)=5
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
+ call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
+ ! Divergence
+ ! Convert grid u,v to div and vor
+ if ( diff_res ) then
+ grid_b = rwork3d0(:,:,1)
+ grid_b2 = rwork3d1(:,:,1)
+ vector(1)=.true.
+ call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ do j=1,grd%nlon
+ do i=2,grd%nlat-1
+ grid(j,grd%nlat-i)=grid2(i,j,1)
+ enddo
+ enddo
+ call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work_v(kk)=grid2(i,j,1)
+ enddo
+ do j=1,grd%nlon
+ do i=2,grd%nlat-1
+ grid_v(j,grd%nlat-i)=grid2(i,j,1)
+ enddo
+ enddo
+ else
+ grid = rwork3d0(:,:,1)
+ grid_v = rwork3d1(:,:,1)
+ call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
+ endif
+ allocate( grid_div(grd%nlon,nlatm2) )
+ call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1)
+ call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1)
+ ! Load values into rows for south and north pole
+ call general_fill_ns(grd,grid_div,work)
+ deallocate(grid_div)
+ endif
+ if ( icount == icm ) then
+ call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
+ icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+
+ end do
+ endif ! if ( vordivflag .or. .not. uvflag )
+ if ( uvflag ) then
+ do k=1,nlevs
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+ icount=icount+1
+ iflag(icount)=6
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
+ call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
+
+ if ( diff_res ) then
+ grid_b = rwork3d0(:,:,1)
+ grid_b2 = rwork3d1(:,:,1)
+ vector(1)=.true.
+ call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid = rwork3d0(:,:,1)
+ grid_v = rwork3d1(:,:,1)
+ call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
+ icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+
+ icount=icount+1
+ iflag(icount)=7
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ ! V
+ call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
+ call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
+ if ( diff_res ) then
+ grid_b = rwork3d0(:,:,1)
+ grid_b2 = rwork3d1(:,:,1)
+ vector(1)=.true.
+ call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
+ call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid = rwork3d0(:,:,1)
+ grid_v = rwork3d1(:,:,1)
+ ! Note work_v and work are switched because output must be in work.
+ call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
+ icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ end do
+ endif ! if ( uvflag )
+ do k=1,nlevs
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+ icount=icount+1
+ iflag(icount)=8
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ ! Specific humidity
+ call read_vardata(filges, 'spfh', rwork3d0, nslice=kr, slicedim=3)
+ if ( diff_res ) then
+ grid_b=rwork3d0(:,:,1)
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid = rwork3d0(:,:,1)
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
+ icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ end do
+ do k=1,nlevs
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ icount=icount+1
+ iflag(icount)=9
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'o3mr', rwork3d0, nslice=kr, slicedim=3)
+ ! Ozone mixing ratio
+ if ( diff_res ) then
+ grid_b=rwork3d0(:,:,1)
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork3d0(:,:,1)
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
+ icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ end do
+
+ do k=1,nlevs
+ icount=icount+1
+ iflag(icount)=10
+ ilev(icount)=k
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'clwmr', rwork3d0, nslice=kr, slicedim=3)
+ call read_vardata(filges, 'icmr', rwork3d1, nslice=kr, slicedim=3)
+ ! Cloud condensate mixing ratio.
+ rwork2d = rwork3d0(:,:,1)+rwork3d1(:,:,1)
+ if ( diff_res ) then
+ grid_b=rwork2d
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork2d
+ call general_fill_ns(grd,grid,work)
+ endif
+
+ endif
+
+ if ( icount == icm .or. k == nlevs ) then
+ call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
+ icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+
+ enddo ! do k=1,nlevs
+ else ! read_2m
+
+ icount=icount+1
+ iflag(icount)=2
+
+ ! 2m temperature from sfc file
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'tmp2m', rwork2d)
+
+ if ( diff_res ) then
+ vector(1)=.false.
+ grid_b=rwork2d
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork2d
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+
+ icount=icount + 1
+ iflag(icount)=3
+
+ ! 2m humidity from sfc file
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'spfh2m', rwork2d)
+
+ if ( diff_res ) then
+ vector(1)=.false.
+ grid_b=rwork2d
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork2d
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+
+ icount=icount + 1
+ iflag(icount)=4
+
+ if (mype==mype_use(icount)) then
+ ! read ps
+ call read_vardata(filges, 'pressfc', rwork2d)
+ rwork2d = r0_001*rwork2d ! convert Pa to cb
+ if ( diff_res ) then
+ vector(1)=.false.
+ grid_b=rwork2d
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork2d
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+
+ ! not using all procs. doesn't trigger. todo: figure out trigger
+ ! for when reading fewer vars.
+ !if ( icount == icm ) then
+ call general_reload_sfc(grd,g_t2m, g_q2m, g_ps, icount,iflag,work)
+ !endif
+
+ endif ! read_2m
- ! Surface pressure: same procedure as terrain
- if (mype==mype_use(icount)) then
- ! read ps
- call read_vardata(atmges, 'pressfc', rwork2d)
- rwork2d = r0_001*rwork2d ! convert Pa to cb
- if ( diff_res ) then
- vector(1)=.false.
- grid_b=rwork2d
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork2d
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
- icount,iflag,ilev,work,uvflag,vordivflag)
+ if ( procuse ) then
+ if ( diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2)
+ call destroy_egrid2agrid(p_high)
+ deallocate(spec_div,spec_vor)
+ deallocate(rwork3d1,rwork3d0,clons,slons)
+ deallocate(rwork2d)
+ deallocate(grid,grid_v)
+ call close_dataset(filges)
endif
+ deallocate(work)
- ! Thermodynamic variable: s-->g transform, communicate to all tasks
- ! For multilevel fields, each task handles a given level. Periodic
- ! mpi_alltoallv calls communicate the grids to all mpi tasks.
- ! Finally, the grids are loaded into guess arrays used later in the
- ! code.
-
- do k=1,nlevs
+ ! Convert dry temperature to virtual temperature
+ !do k=1,grd%nsig
+ ! do j=1,grd%lon2
+ ! do i=1,grd%lat2
+ ! g_tv(i,j,k) = g_tv(i,j,k)*(one+fv*g_q(i,j,k))
+ ! enddo
+ ! enddo
+ !enddo
- icount=icount+1
- iflag(icount)=3
- ilev(icount)=k
- kr = levs+1-k ! netcdf is top to bottom, need to flip
+ ! Load u->div and v->vor slot when uv are used instead
+ if ( .not. read_2m ) then
+ if ( uvflag ) then
+ call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier)
+ if ( ier == 0 ) then
+ ptr3d=g_u
+ call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier)
+ if ( ier == 0 ) ptr3d=g_v
+ else ! in this case, overload: return u/v in sf/vp slot
+ call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier)
+ if ( ier == 0 ) then
+ ptr3d=g_u
+ call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier)
+ if ( ier == 0 ) ptr3d=g_v
+ endif
+ endif
+ else ! in this case, overload: return u/v in sf/vp slot
+ call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier)
+ if ( ier == 0 ) ptr3d=g_u
+ call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier)
+ if ( ier == 0 ) ptr3d=g_v
+ endif
+ endif ! read_2m
+ if (read_z) then
+ call gsi_bundlegetpointer(gfs_bundle,'z' ,ptr2d,ier)
+ if ( ier == 0 ) ptr2d=g_z
+ endif
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'spfh', rwork3d1, nslice=kr, slicedim=3)
- call read_vardata(atmges, 'tmp', rwork3d0, nslice=kr, slicedim=3)
- rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1))
- if ( diff_res ) then
- grid_b=rwork2d
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork2d
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
- icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- end do
+ ! Clean up
+ deallocate(g_z)
+ deallocate(g_u,g_v)
- if ( vordivflag .or. .not. uvflag ) then
- do k=1,nlevs
- kr = levs+1-k ! netcdf is top to bottom, need to flip
- icount=icount+1
- iflag(icount)=4
- ilev(icount)=k
+ ! Print date/time stamp
+ if ( mype == 0 ) then
+ write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,&
+ fhour,odate,trim(filename)
+700 format('GENERAL_READ_GFSATM_NC: read lonb,latb,levs=',&
+ 3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a)
+ endif
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
- call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
- ! Vorticity
- ! Convert grid u,v to div and vor
- if ( diff_res ) then
- grid_b = rwork3d0(:,:,1)
- grid_b2 = rwork3d1(:,:,1)
- vector(1)=.true.
- call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- do j=1,grd%nlon
- do i=2,grd%nlat-1
- grid(j,grd%nlat-i)=grid2(i,j,1)
- enddo
- enddo
- call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work_v(kk)=grid2(i,j,1)
- enddo
- do j=1,grd%nlon
- do i=2,grd%nlat-1
- grid_v(j,grd%nlat-i)=grid2(i,j,1)
- enddo
- enddo
- else
- grid = rwork3d0(:,:,1)
- grid_v = rwork3d1(:,:,1)
- call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
- endif
- allocate( grid_vor(grd%nlon,nlatm2))
- call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1)
- call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1)
- ! Load values into rows for south and north pole
- call general_fill_ns(grd,grid_vor,work)
- deallocate(grid_vor)
- endif
- if ( icount == icm ) then
- call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
- icount,iflag,ilev,work,uvflag,vordivflag)
- endif
+ return
- end do
- do k=1,nlevs
- kr = levs+1-k ! netcdf is top to bottom, need to flip
+end subroutine general_read_gfsatm_nc
- icount=icount+1
- iflag(icount)=5
- ilev(icount)=k
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
- call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
- ! Divergence
- ! Convert grid u,v to div and vor
- if ( diff_res ) then
- grid_b = rwork3d0(:,:,1)
- grid_b2 = rwork3d1(:,:,1)
- vector(1)=.true.
- call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- do j=1,grd%nlon
- do i=2,grd%nlat-1
- grid(j,grd%nlat-i)=grid2(i,j,1)
- enddo
- enddo
- call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work_v(kk)=grid2(i,j,1)
- enddo
- do j=1,grd%nlon
- do i=2,grd%nlat-1
- grid_v(j,grd%nlat-i)=grid2(i,j,1)
- enddo
- enddo
- else
- grid = rwork3d0(:,:,1)
- grid_v = rwork3d1(:,:,1)
- call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
- endif
- allocate( grid_div(grd%nlon,nlatm2) )
- call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1)
- call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1)
- ! Load values into rows for south and north pole
- call general_fill_ns(grd,grid_div,work)
- deallocate(grid_div)
- endif
- if ( icount == icm ) then
- call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
- icount,iflag,ilev,work,uvflag,vordivflag)
- endif
-
- end do
- endif ! if ( vordivflag .or. .not. uvflag )
- if ( uvflag ) then
- do k=1,nlevs
- kr = levs+1-k ! netcdf is top to bottom, need to flip
- icount=icount+1
- iflag(icount)=6
- ilev(icount)=k
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
- call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
-
- if ( diff_res ) then
- grid_b = rwork3d0(:,:,1)
- grid_b2 = rwork3d1(:,:,1)
- vector(1)=.true.
- call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid = rwork3d0(:,:,1)
- grid_v = rwork3d1(:,:,1)
- call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
- endif
- endif
- if ( icount == icm ) then
- call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
- icount,iflag,ilev,work,uvflag,vordivflag)
- endif
-
- icount=icount+1
- iflag(icount)=7
- ilev(icount)=k
-
- if (mype==mype_use(icount)) then
- ! V
- call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
- call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
- if ( diff_res ) then
- grid_b = rwork3d0(:,:,1)
- grid_b2 = rwork3d1(:,:,1)
- vector(1)=.true.
- call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
- call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid = rwork3d0(:,:,1)
- grid_v = rwork3d1(:,:,1)
- ! Note work_v and work are switched because output must be in work.
- call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
- icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- end do
- endif ! if ( uvflag )
- do k=1,nlevs
- kr = levs+1-k ! netcdf is top to bottom, need to flip
- icount=icount+1
- iflag(icount)=8
- ilev(icount)=k
-
- if (mype==mype_use(icount)) then
- ! Specific humidity
- call read_vardata(atmges, 'spfh', rwork3d0, nslice=kr, slicedim=3)
- if ( diff_res ) then
- grid_b=rwork3d0(:,:,1)
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid = rwork3d0(:,:,1)
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
- icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- end do
- do k=1,nlevs
- kr = levs+1-k ! netcdf is top to bottom, need to flip
-
- icount=icount+1
- iflag(icount)=9
- ilev(icount)=k
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'o3mr', rwork3d0, nslice=kr, slicedim=3)
- ! Ozone mixing ratio
- if ( diff_res ) then
- grid_b=rwork3d0(:,:,1)
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork3d0(:,:,1)
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
- icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- end do
-
- do k=1,nlevs
- icount=icount+1
- iflag(icount)=10
- ilev(icount)=k
- kr = levs+1-k ! netcdf is top to bottom, need to flip
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'clwmr', rwork3d0, nslice=kr, slicedim=3)
- call read_vardata(atmges, 'icmr', rwork3d1, nslice=kr, slicedim=3)
- ! Cloud condensate mixing ratio.
- rwork2d = rwork3d0(:,:,1)+rwork3d1(:,:,1)
- if ( diff_res ) then
- grid_b=rwork2d
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork2d
- call general_fill_ns(grd,grid,work)
- endif
-
- endif
-
- if ( icount == icm .or. k == nlevs ) then
- call general_reload(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz,g_cwmr, &
- icount,iflag,ilev,work,uvflag,vordivflag)
- endif
-
- enddo ! do k=1,nlevs
-
- if ( procuse ) then
- if ( diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2)
- call destroy_egrid2agrid(p_high)
- deallocate(spec_div,spec_vor)
- deallocate(rwork3d1,rwork3d0,clons,slons)
- deallocate(rwork2d)
- deallocate(grid,grid_v)
- call close_dataset(atmges)
- endif
- deallocate(work)
-
- ! Convert dry temperature to virtual temperature
- !do k=1,grd%nsig
- ! do j=1,grd%lon2
- ! do i=1,grd%lat2
- ! g_tv(i,j,k) = g_tv(i,j,k)*(one+fv*g_q(i,j,k))
- ! enddo
- ! enddo
- !enddo
-
- ! Load u->div and v->vor slot when uv are used instead
- if ( uvflag ) then
- call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier)
- if ( ier == 0 ) then
- ptr3d=g_u
- call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier)
- if ( ier == 0 ) ptr3d=g_v
- else ! in this case, overload: return u/v in sf/vp slot
- call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier)
- if ( ier == 0 ) then
- ptr3d=g_u
- call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier)
- if ( ier == 0 ) ptr3d=g_v
- endif
- endif
- else ! in this case, overload: return u/v in sf/vp slot
- call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier)
- if ( ier == 0 ) ptr3d=g_u
- call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier)
- if ( ier == 0 ) ptr3d=g_v
- endif
- if (zflag) then
- call gsi_bundlegetpointer(gfs_bundle,'z' ,ptr2d,ier)
- if ( ier == 0 ) ptr2d=g_z
- endif
-
- ! Clean up
- deallocate(g_z)
- deallocate(g_u,g_v)
-
- ! Print date/time stamp
- if ( mype == 0 ) then
- write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,&
- fhour,odate,trim(filename)
-700 format('GENERAL_READ_GFSATM_NC: read lonb,latb,levs=',&
- 3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a)
- endif
-
- return
-
-end subroutine general_read_gfsatm_nc
subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,zflag, &
gfs_bundle,iret_read)
!$$$ subprogram documentation block
@@ -2618,7 +2806,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
use gsi_bundlemod, only: gsi_bundlegetpointer
use module_ncio, only: Dataset, Variable, Dimension, open_dataset,&
close_dataset, get_dim, read_vardata,get_idate_from_time_units
- use gfsreadmod, only: general_reload2
+ use gfsreadmod, only: general_reload2, general_reload_sfc
use ncepnems_io, only: imp_physics
implicit none
@@ -2637,6 +2825,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
real(r_kind),pointer,dimension(:,:) :: ptr2d
real(r_kind),pointer,dimension(:,:,:) :: ptr3d
real(r_kind),pointer,dimension(:,:) :: g_ps
+ real(r_kind),pointer,dimension(:,:) :: g_t2m, g_q2m
real(r_kind),pointer,dimension(:,:,:) :: g_vor,g_div,&
g_q,g_oz,g_tv
real(r_kind),pointer,dimension(:,:,:) :: g_ql,g_qi,g_qr,g_qs,g_qg
@@ -2668,8 +2857,9 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
logical :: procuse,diff_res,eqspace
type(egrid2agrid_parm) :: p_high
logical,dimension(1) :: vector
- type(Dataset) :: atmges
+ type(Dataset) :: filges
type(Dimension) :: ncdim
+ logical :: read_2m, read_z
@@ -2685,6 +2875,19 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
mype_use=-1
icount=0
procuse=.false.
+
+ if (filename(1:3) == 'sfc') then
+ read_2m = .true.
+ read_z = .false.
+ if ( mype == 0 ) write(6,* ) &
+ trim(my_name), ': reading 2m variables from ', trim(filename)
+ else
+ read_2m = .false.
+ read_z = zflag
+ if ( mype == 0 ) write(6,* ) &
+ trim(my_name), ': reading atmos variables from ', trim(filename)
+ endif
+
if ( mype == 0 ) procuse = .true.
do i=1,npe
if ( grd%recvcounts_s(i-1) > 0 ) then
@@ -2694,29 +2897,29 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
endif
enddo
icm=icount
- allocate( work(grd%itotsub),work_v(grd%itotsub) )
+ allocate( work(grd%itotsub))
work=zero
- work_v=zero
if ( procuse ) then
- atmges = open_dataset(filename, paropen=.true.)
+ filges = open_dataset(filename, paropen=.true.)
! get dimension sizes
- ncdim = get_dim(atmges, 'grid_xt'); lonb = ncdim%len
- ncdim = get_dim(atmges, 'grid_yt'); latb = ncdim%len
- ncdim = get_dim(atmges, 'pfull'); levs = ncdim%len
+ ncdim = get_dim(filges, 'grid_xt'); lonb = ncdim%len
+ ncdim = get_dim(filges, 'grid_yt'); latb = ncdim%len
+ if (.not. read_2m) &
+ ncdim = get_dim(filges, 'pfull'); levs = ncdim%len
! get time information
- idate = get_idate_from_time_units(atmges)
+ idate = get_idate_from_time_units(filges)
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
odate(3) = idate(3) !day
odate(4) = idate(1) !year
- call read_vardata(atmges, 'time', fhour) ! might need to change this to attribute later
+ call read_vardata(filges, 'time', fhour) ! might need to change this to attribute later
! depends on model changes from
! Jeff Whitaker
- fhour = float(nint(fhour))
+ fhour = real(nint(fhour),r_kind)
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
@@ -2738,11 +2941,13 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
trim(my_name),grd%nlon,lonb
!call stop2(101)
endif
- if ( levs /= grd%nsig ) then
- if ( mype == 0 ) write(6, &
- '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') &
- trim(my_name),grd%nsig,levs
- call stop2(101)
+ if (.not. read_2m) then
+ if ( levs /= grd%nsig ) then
+ if ( mype == 0 ) write(6, &
+ '(a,'': inconsistent spatial dimension nsig = '',i4,tr1,''levs = '',i4)') &
+ trim(my_name),grd%nsig,levs
+ call stop2(101)
+ endif
endif
allocate( spec_vor(sp_a%nc), spec_div(sp_a%nc) )
@@ -2755,8 +2960,8 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
allocate(rwork3d1(lonb,latb,1))
allocate(rwork2d(lonb,latb))
allocate(rlats(latb+2),rlons(lonb),clons(lonb),slons(lonb))
- call read_vardata(atmges, 'grid_xt', rlons_tmp)
- call read_vardata(atmges, 'grid_yt', rlats_tmp)
+ call read_vardata(filges, 'grid_xt', rlons_tmp)
+ call read_vardata(filges, 'grid_yt', rlats_tmp)
do j=1,latb
rlats(latb+2-j)=deg2rad*rlats_tmp(j)
end do
@@ -2781,63 +2986,79 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
endif ! if ( procuse )
! Get pointer to relevant variables (this should be made flexible and general)
- iredundant=0
- call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- if ( iredundant==2 ) then
- if ( mype == 0 ) then
- write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR'
- write(6,*) 'cannot handle having both sf and div'
- write(6,*) 'Aborting ... '
- endif
- call stop2(999)
- endif
- iredundant=0
- call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- if ( iredundant==2 ) then
- if ( mype == 0 ) then
- write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR'
- write(6,*) 'cannot handle having both vp and vor'
- write(6,*) 'Aborting ... '
- endif
- call stop2(999)
- endif
- iredundant=0
- call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier)
- if ( ier == 0 ) iredundant = iredundant + 1
- if ( iredundant==2 ) then
- if ( mype == 0 ) then
- write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR'
- write(6,*) 'cannot handle having both t and tv'
- write(6,*) 'Aborting ... '
- endif
- call stop2(999)
- endif
- istatus=0
- call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier
- call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier
- call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier
-! call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier
- call gsi_bundlegetpointer(gfs_bundle,'ql',g_ql ,ier);istatus1=istatus1+ier
- call gsi_bundlegetpointer(gfs_bundle,'qi',g_qi ,ier);istatus1=istatus1+ier
- call gsi_bundlegetpointer(gfs_bundle,'qr',g_qr ,ier);istatus1=istatus1+ier
- call gsi_bundlegetpointer(gfs_bundle,'qs',g_qs ,ier);istatus1=istatus1+ier
- call gsi_bundlegetpointer(gfs_bundle,'qg',g_qg ,ier);istatus1=istatus1+ier
-! call gsi_bundlegetpointer(gfs_bundle,'cf',g_cf ,ier);istatus1=istatus1+ier
- if ( istatus1 /= 0 ) then
- if ( mype == 0 ) then
- write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR'
- write(6,*) 'Missing some of the required hydrometeor fields for imp_physics = ', imp_physics
- write(6,*) 'Aborting ... '
- endif
- call stop2(999)
+ if (.not. read_2m) then
+ iredundant=0
+ call gsi_bundlegetpointer(gfs_bundle,'sf',g_div ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ call gsi_bundlegetpointer(gfs_bundle,'div',g_div ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ if ( iredundant==2 ) then
+ if ( mype == 0 ) then
+ write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR'
+ write(6,*) 'cannot handle having both sf and div'
+ write(6,*) 'Aborting ... '
+ endif
+ call stop2(999)
+ endif
+ iredundant=0
+ call gsi_bundlegetpointer(gfs_bundle,'vp',g_vor ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ call gsi_bundlegetpointer(gfs_bundle,'vor',g_vor ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ if ( iredundant==2 ) then
+ if ( mype == 0 ) then
+ write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR'
+ write(6,*) 'cannot handle having both vp and vor'
+ write(6,*) 'Aborting ... '
+ endif
+ call stop2(999)
+ endif
+ iredundant=0
+ call gsi_bundlegetpointer(gfs_bundle,'t' ,g_tv ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ call gsi_bundlegetpointer(gfs_bundle,'tv',g_tv ,ier)
+ if ( ier == 0 ) iredundant = iredundant + 1
+ if ( iredundant==2 ) then
+ if ( mype == 0 ) then
+ write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR'
+ write(6,*) 'cannot handle having both t and tv'
+ write(6,*) 'Aborting ... '
+ endif
+ call stop2(999)
+ endif
+ istatus=0
+ call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(gfs_bundle,'q' ,g_q ,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(gfs_bundle,'oz',g_oz ,ier);istatus=istatus+ier
+ ! call gsi_bundlegetpointer(gfs_bundle,'cw',g_cwmr,ier);istatus=istatus+ier
+ istatus1=0
+ call gsi_bundlegetpointer(gfs_bundle,'ql',g_ql ,ier);istatus1=istatus1+ier
+ call gsi_bundlegetpointer(gfs_bundle,'qi',g_qi ,ier);istatus1=istatus1+ier
+ call gsi_bundlegetpointer(gfs_bundle,'qr',g_qr ,ier);istatus1=istatus1+ier
+ call gsi_bundlegetpointer(gfs_bundle,'qs',g_qs ,ier);istatus1=istatus1+ier
+ call gsi_bundlegetpointer(gfs_bundle,'qg',g_qg ,ier);istatus1=istatus1+ier
+ ! call gsi_bundlegetpointer(gfs_bundle,'cf',g_cf ,ier);istatus1=istatus1+ier
+ if ( istatus1 /= 0 ) then
+ if ( mype == 0 ) then
+ write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR'
+ write(6,*) 'Missing some of the required hydrometeor fields for imp_physics = ', imp_physics
+ write(6,*) 'Aborting ... '
+ endif
+ call stop2(999)
+ endif
+ else ! read 2m vars
+ istatus=0
+ call gsi_bundlegetpointer(gfs_bundle,'t2m',g_t2m ,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(gfs_bundle,'q2m',g_q2m ,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(gfs_bundle,'ps',g_ps ,ier);istatus=istatus+ier
+ if ( istatus /= 0 ) then
+ if ( mype == 0 ) then
+ write(6,*) 'general_read_gfsatm_allhydro_nc: ERROR'
+ write(6,*) 'Missing 2m required variables'
+ write(6,*) 'Aborting ... '
+ endif
+ call stop2(999)
+ endif
endif
allocate(g_u(grd%lat2,grd%lon2,grd%nsig),g_v(grd%lat2,grd%lon2,grd%nsig))
@@ -2852,7 +3073,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
! Only read Terrain when zflag is true.
- if ( zflag ) then
+ if ( read_z ) then
icount=icount+1
iflag(icount)=1
@@ -2861,7 +3082,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
! Terrain: spectral --> grid transform, scatter to all mpi tasks
if (mype==mype_use(icount)) then
! read hs
- call read_vardata(atmges, 'hgtsfc', rwork2d)
+ call read_vardata(filges, 'hgtsfc', rwork2d)
if ( diff_res ) then
grid_b=rwork2d
vector(1)=.false.
@@ -2883,465 +3104,470 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
endif
endif
- icount=icount+1
- iflag(icount)=2
- ilev(icount)=1
-
- ! Surface pressure: same procedure as terrain
- if (mype==mype_use(icount)) then
- ! read ps
- call read_vardata(atmges, 'pressfc', rwork2d)
- rwork2d = r0_001*rwork2d ! convert Pa to cb
- if ( diff_res ) then
- vector(1)=.false.
- grid_b=rwork2d
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork2d
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
-
- ! Thermodynamic variable: s-->g transform, communicate to all tasks
- ! For multilevel fields, each task handles a given level. Periodic
- ! mpi_alltoallv calls communicate the grids to all mpi tasks.
- ! Finally, the grids are loaded into guess arrays used later in the
- ! code.
-
- do k=1,nlevs
-
- icount=icount+1
- iflag(icount)=3
- ilev(icount)=k
- kr = levs+1-k ! netcdf is top to bottom, need to flip
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'spfh', rwork3d1, nslice=kr, slicedim=3)
- call read_vardata(atmges, 'tmp', rwork3d0, nslice=kr, slicedim=3)
- rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1))
- if ( diff_res ) then
- grid_b=rwork2d
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork2d
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- end do
-
- if ( vordivflag .or. .not. uvflag ) then
- do k=1,nlevs
- kr = levs+1-k ! netcdf is top to bottom, need to flip
- icount=icount+1
- iflag(icount)=4
- ilev(icount)=k
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
- call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
- ! Vorticity
- ! Convert grid u,v to div and vor
- if ( diff_res ) then
- grid_b = rwork3d0(:,:,1)
- grid_b2 = rwork3d1(:,:,1)
- vector(1)=.true.
- call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- do j=1,grd%nlon
- do i=2,grd%nlat-1
- grid(j,grd%nlat-i)=grid2(i,j,1)
- enddo
- enddo
- call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work_v(kk)=grid2(i,j,1)
- enddo
- do j=1,grd%nlon
- do i=2,grd%nlat-1
- grid_v(j,grd%nlat-i)=grid2(i,j,1)
- enddo
- enddo
- else
- grid = rwork3d0(:,:,1)
- grid_v = rwork3d1(:,:,1)
- call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
- endif
- allocate( grid_vor(grd%nlon,nlatm2))
- call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1)
- call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1)
- ! Load values into rows for south and north pole
- call general_fill_ns(grd,grid_vor,work)
- deallocate(grid_vor)
- endif
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- end do
- do k=1,nlevs
- kr = levs+1-k ! netcdf is top to bottom, need to flip
-
- icount=icount+1
- iflag(icount)=5
- ilev(icount)=k
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
- call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
- ! Divergence
- ! Convert grid u,v to div and vor
- if ( diff_res ) then
- grid_b = rwork3d0(:,:,1)
- grid_b2 = rwork3d1(:,:,1)
- vector(1)=.true.
- call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- do j=1,grd%nlon
- do i=2,grd%nlat-1
- grid(j,grd%nlat-i)=grid2(i,j,1)
- enddo
- enddo
- call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work_v(kk)=grid2(i,j,1)
- enddo
- do j=1,grd%nlon
- do i=2,grd%nlat-1
- grid_v(j,grd%nlat-i)=grid2(i,j,1)
- enddo
- enddo
- else
- grid = rwork3d0(:,:,1)
- grid_v = rwork3d1(:,:,1)
- call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
- endif
- allocate( grid_div(grd%nlon,nlatm2) )
- call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1)
- call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1)
- ! Load values into rows for south and north pole
- call general_fill_ns(grd,grid_div,work)
- deallocate(grid_div)
- endif
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
-
- end do
- endif ! if ( vordivflag .or. .not. uvflag )
-
- if ( uvflag ) then
- do k=1,nlevs
- kr = levs+1-k ! netcdf is top to bottom, need to flip
- icount=icount+1
- iflag(icount)=6
- ilev(icount)=k
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
- call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
-
- if ( diff_res ) then
- grid_b = rwork3d0(:,:,1)
- grid_b2 = rwork3d1(:,:,1)
- vector(1)=.true.
- call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid = rwork3d0(:,:,1)
- grid_v = rwork3d1(:,:,1)
- call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
- endif
- endif
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
-
- icount=icount+1
- iflag(icount)=7
- ilev(icount)=k
-
- if (mype==mype_use(icount)) then
- ! V
- call read_vardata(atmges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
- call read_vardata(atmges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
- if ( diff_res ) then
- grid_b = rwork3d0(:,:,1)
- grid_b2 = rwork3d1(:,:,1)
- vector(1)=.true.
- call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
- call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid = rwork3d0(:,:,1)
- grid_v = rwork3d1(:,:,1)
- ! Note work_v and work are switched because output must be in work.
- call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- end do
- endif ! if ( uvflag )
-
- do k=1,nlevs
- kr = levs+1-k ! netcdf is top to bottom, need to flip
- icount=icount+1
- iflag(icount)=8
- ilev(icount)=k
-
- if (mype==mype_use(icount)) then
- ! Specific humidity
- call read_vardata(atmges, 'spfh', rwork3d0, nslice=kr, slicedim=3)
- if ( diff_res ) then
- grid_b=rwork3d0(:,:,1)
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid = rwork3d0(:,:,1)
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- end do
-
- do k=1,nlevs
- kr = levs+1-k ! netcdf is top to bottom, need to flip
-
- icount=icount+1
- iflag(icount)=9
- ilev(icount)=k
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'o3mr', rwork3d0, nslice=kr, slicedim=3)
- ! Ozone mixing ratio
- if ( diff_res ) then
- grid_b=rwork3d0(:,:,1)
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork3d0(:,:,1)
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- end do
-
- do k=1,nlevs
- icount=icount+1
- iflag(icount)=10
- ilev(icount)=k
- kr = levs+1-k ! netcdf is top to bottom, need to flip
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'clwmr', rwork3d0, nslice=kr, slicedim=3)
- ! Cloud liquid water mixing ratio.
- if ( diff_res ) then
- grid_b=rwork3d0(:,:,1)
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork3d0(:,:,1)
- call general_fill_ns(grd,grid,work)
- endif
- endif
-
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- enddo ! do k=1,nlevs
-
- do k=1,nlevs
- icount=icount+1
- iflag(icount)=11
- ilev(icount)=k
- kr = levs+1-k ! netcdf is top to bottom, need to flip
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'icmr', rwork3d0, nslice=kr, slicedim=3)
- ! Cloud ice water mixing ratio.
- if ( diff_res ) then
- grid_b=rwork3d0(:,:,1)
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork3d0(:,:,1)
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- enddo ! do k=1,nlevs
-
- do k=1,nlevs
- icount=icount+1
- iflag(icount)=12
- ilev(icount)=k
- kr = levs+1-k ! netcdf is top to bottom, need to flip
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'rwmr', rwork3d0, nslice=kr, slicedim=3)
- ! Rain water mixing ratio.
- if ( diff_res ) then
- grid_b=rwork3d0(:,:,1)
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork3d0(:,:,1)
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- enddo ! do k=1,nlevs
-
- do k=1,nlevs
- icount=icount+1
- iflag(icount)=13
- ilev(icount)=k
- kr = levs+1-k ! netcdf is top to bottom, need to flip
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'snmr', rwork3d0, nslice=kr, slicedim=3)
- ! Snow water mixing ratio.
- if ( diff_res ) then
- grid_b=rwork3d0(:,:,1)
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork3d0(:,:,1)
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm ) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- enddo ! do k=1,nlevs
-
- do k=1,nlevs
- icount=icount+1
- iflag(icount)=14
- ilev(icount)=k
- kr = levs+1-k ! netcdf is top to bottom, need to flip
-
- if (mype==mype_use(icount)) then
- call read_vardata(atmges, 'grle', rwork3d0, nslice=kr, slicedim=3)
- ! Graupel mixing ratio.
- if ( diff_res ) then
- grid_b=rwork3d0(:,:,1)
- vector(1)=.false.
- call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
- call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
- do kk=1,grd%itotsub
- i=grd%ltosi_s(kk)
- j=grd%ltosj_s(kk)
- work(kk)=grid2(i,j,1)
- enddo
- else
- grid=rwork3d0(:,:,1)
- call general_fill_ns(grd,grid,work)
- endif
- endif
- if ( icount == icm .or. k==nlevs) then
- call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
- g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
- endif
- enddo ! do k=1,nlevs
+ if (.not. read_2m) then
+
+ allocate( work_v(grd%itotsub) )
+ work_v=zero
+
+ icount=icount+1
+ iflag(icount)=2
+ ilev(icount)=1
+
+ ! Surface pressure: same procedure as terrain
+ if (mype==mype_use(icount)) then
+ ! read ps
+ call read_vardata(filges, 'pressfc', rwork2d)
+ rwork2d = r0_001*rwork2d ! convert Pa to cb
+ if ( diff_res ) then
+ vector(1)=.false.
+ grid_b=rwork2d
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork2d
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+
+ ! Thermodynamic variable: s-->g transform, communicate to all tasks
+ ! For multilevel fields, each task handles a given level. Periodic
+ ! mpi_alltoallv calls communicate the grids to all mpi tasks.
+ ! Finally, the grids are loaded into guess arrays used later in the
+ ! code.
+
+ do k=1,nlevs
+
+ icount=icount+1
+ iflag(icount)=3
+ ilev(icount)=k
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'spfh', rwork3d1, nslice=kr, slicedim=3)
+ call read_vardata(filges, 'tmp', rwork3d0, nslice=kr, slicedim=3)
+ rwork2d = rwork3d0(:,:,1) * (one+fv*rwork3d1(:,:,1))
+ if ( diff_res ) then
+ grid_b=rwork2d
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork2d
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ end do
+
+ if ( vordivflag .or. .not. uvflag ) then
+ do k=1,nlevs
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+ icount=icount+1
+ iflag(icount)=4
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
+ call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
+ ! Vorticity
+ ! Convert grid u,v to div and vor
+ if ( diff_res ) then
+ grid_b = rwork3d0(:,:,1)
+ grid_b2 = rwork3d1(:,:,1)
+ vector(1)=.true.
+ call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ do j=1,grd%nlon
+ do i=2,grd%nlat-1
+ grid(j,grd%nlat-i)=grid2(i,j,1)
+ enddo
+ enddo
+ call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work_v(kk)=grid2(i,j,1)
+ enddo
+ do j=1,grd%nlon
+ do i=2,grd%nlat-1
+ grid_v(j,grd%nlat-i)=grid2(i,j,1)
+ enddo
+ enddo
+ else
+ grid = rwork3d0(:,:,1)
+ grid_v = rwork3d1(:,:,1)
+ call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
+ endif
+ allocate( grid_vor(grd%nlon,nlatm2))
+ call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1)
+ call general_sptez_s_b(sp_a,sp_a,spec_vor,grid_vor,1)
+ ! Load values into rows for south and north pole
+ call general_fill_ns(grd,grid_vor,work)
+ deallocate(grid_vor)
+ endif
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ end do
+ do k=1,nlevs
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ icount=icount+1
+ iflag(icount)=5
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
+ call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
+ ! Divergence
+ ! Convert grid u,v to div and vor
+ if ( diff_res ) then
+ grid_b = rwork3d0(:,:,1)
+ grid_b2 = rwork3d1(:,:,1)
+ vector(1)=.true.
+ call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ do j=1,grd%nlon
+ do i=2,grd%nlat-1
+ grid(j,grd%nlat-i)=grid2(i,j,1)
+ enddo
+ enddo
+ call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work_v(kk)=grid2(i,j,1)
+ enddo
+ do j=1,grd%nlon
+ do i=2,grd%nlat-1
+ grid_v(j,grd%nlat-i)=grid2(i,j,1)
+ enddo
+ enddo
+ else
+ grid = rwork3d0(:,:,1)
+ grid_v = rwork3d1(:,:,1)
+ call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
+ endif
+ allocate( grid_div(grd%nlon,nlatm2) )
+ call general_sptez_v(sp_a,spec_div,spec_vor,grid,grid_v,-1)
+ call general_sptez_s_b(sp_a,sp_a,spec_div,grid_div,1)
+ ! Load values into rows for south and north pole
+ call general_fill_ns(grd,grid_div,work)
+ deallocate(grid_div)
+ endif
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+
+ end do
+ endif ! if ( vordivflag .or. .not. uvflag )
+
+ if ( uvflag ) then
+ do k=1,nlevs
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+ icount=icount+1
+ iflag(icount)=6
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
+ call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
+
+ if ( diff_res ) then
+ grid_b = rwork3d0(:,:,1)
+ grid_b2 = rwork3d1(:,:,1)
+ vector(1)=.true.
+ call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid = rwork3d0(:,:,1)
+ grid_v = rwork3d1(:,:,1)
+ call general_filluv_ns(grd,slons,clons,grid,grid_v,work,work_v)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+
+ icount=icount+1
+ iflag(icount)=7
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ ! V
+ call read_vardata(filges, 'ugrd', rwork3d0, nslice=kr, slicedim=3)
+ call read_vardata(filges, 'vgrd', rwork3d1, nslice=kr, slicedim=3)
+ if ( diff_res ) then
+ grid_b = rwork3d0(:,:,1)
+ grid_b2 = rwork3d1(:,:,1)
+ vector(1)=.true.
+ call filluv2_ns(grid_b,grid_b2,grid_c(:,:,1),grid_c2(:,:,1),latb+2,lonb,slons,clons)
+ call g_egrid2agrid(p_high,grid_c2,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid = rwork3d0(:,:,1)
+ grid_v = rwork3d1(:,:,1)
+ ! Note work_v and work are switched because output must be in work.
+ call general_filluv_ns(grd,slons,clons,grid,grid_v,work_v,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ end do
+ endif ! if ( uvflag )
+
+ do k=1,nlevs
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+ icount=icount+1
+ iflag(icount)=8
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ ! Specific humidity
+ call read_vardata(filges, 'spfh', rwork3d0, nslice=kr, slicedim=3)
+ if ( diff_res ) then
+ grid_b=rwork3d0(:,:,1)
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid = rwork3d0(:,:,1)
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ end do
+
+ do k=1,nlevs
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ icount=icount+1
+ iflag(icount)=9
+ ilev(icount)=k
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'o3mr', rwork3d0, nslice=kr, slicedim=3)
+ ! Ozone mixing ratio
+ if ( diff_res ) then
+ grid_b=rwork3d0(:,:,1)
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork3d0(:,:,1)
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ end do
+
+ do k=1,nlevs
+ icount=icount+1
+ iflag(icount)=10
+ ilev(icount)=k
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'clwmr', rwork3d0, nslice=kr, slicedim=3)
+ ! Cloud liquid water mixing ratio.
+ if ( diff_res ) then
+ grid_b=rwork3d0(:,:,1)
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork3d0(:,:,1)
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ enddo ! do k=1,nlevs
+
+ do k=1,nlevs
+ icount=icount+1
+ iflag(icount)=11
+ ilev(icount)=k
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'icmr', rwork3d0, nslice=kr, slicedim=3)
+ ! Cloud ice water mixing ratio.
+ if ( diff_res ) then
+ grid_b=rwork3d0(:,:,1)
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork3d0(:,:,1)
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ enddo ! do k=1,nlevs
+
+ do k=1,nlevs
+ icount=icount+1
+ iflag(icount)=12
+ ilev(icount)=k
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'rwmr', rwork3d0, nslice=kr, slicedim=3)
+ ! Rain water mixing ratio.
+ if ( diff_res ) then
+ grid_b=rwork3d0(:,:,1)
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork3d0(:,:,1)
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ enddo ! do k=1,nlevs
+
+ do k=1,nlevs
+ icount=icount+1
+ iflag(icount)=13
+ ilev(icount)=k
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'snmr', rwork3d0, nslice=kr, slicedim=3)
+ ! Snow water mixing ratio.
+ if ( diff_res ) then
+ grid_b=rwork3d0(:,:,1)
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork3d0(:,:,1)
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm ) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ enddo ! do k=1,nlevs
+
+ do k=1,nlevs
+ icount=icount+1
+ iflag(icount)=14
+ ilev(icount)=k
+ kr = levs+1-k ! netcdf is top to bottom, need to flip
+
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'grle', rwork3d0, nslice=kr, slicedim=3)
+ ! Graupel mixing ratio.
+ if ( diff_res ) then
+ grid_b=rwork3d0(:,:,1)
+ vector(1)=.false.
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork3d0(:,:,1)
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+ if ( icount == icm .or. k==nlevs) then
+ call general_reload2(grd,g_z,g_ps,g_tv,g_vor,g_div,g_u,g_v,g_q,g_oz, &
+ g_ql,g_qi,g_qr,g_qs,g_qg,icount,iflag,ilev,work,uvflag,vordivflag)
+ endif
+ enddo ! do k=1,nlevs
! do k=1,nlevs
! icount=icount+1
@@ -3350,7 +3576,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
! kr = levs+1-k ! netcdf is top to bottom, need to flip
!
! if (mype==mype_use(icount)) then
-! call read_vardata(atmges, 'cld_amt', rwork3d0, nslice=kr, slicedim=3)
+! call read_vardata(filges, 'cld_amt', rwork3d0, nslice=kr, slicedim=3)
! ! Cloud amount (cloud fraction).
! if ( diff_res ) then
! grid_b=rwork3d0(:,:,1)
@@ -3374,6 +3600,87 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
! endif
! enddo ! do k=1,nlevs
+ else ! read_2m
+
+ icount=icount+1
+ iflag(icount)=2
+
+ ! 2m temperature from sfc file
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'tmp2m', rwork2d)
+
+ if ( diff_res ) then
+ vector(1)=.false.
+ grid_b=rwork2d
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork2d
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+
+ icount=icount + 1
+ iflag(icount)=3
+
+ ! 2m humidity from sfc file
+ if (mype==mype_use(icount)) then
+ call read_vardata(filges, 'spfh2m', rwork2d)
+
+ if ( diff_res ) then
+ vector(1)=.false.
+ grid_b=rwork2d
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork2d
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+
+ icount=icount + 1
+ iflag(icount)=4
+
+ if (mype==mype_use(icount)) then
+ ! read ps
+ call read_vardata(filges, 'pressfc', rwork2d)
+ rwork2d = r0_001*rwork2d ! convert Pa to cb
+ if ( diff_res ) then
+ vector(1)=.false.
+ grid_b=rwork2d
+ call fill2_ns(grid_b,grid_c(:,:,1),latb+2,lonb)
+ call g_egrid2agrid(p_high,grid_c,grid2,1,1,vector)
+ do kk=1,grd%itotsub
+ i=grd%ltosi_s(kk)
+ j=grd%ltosj_s(kk)
+ work(kk)=grid2(i,j,1)
+ enddo
+ else
+ grid=rwork2d
+ call general_fill_ns(grd,grid,work)
+ endif
+ endif
+
+ ! not necessarily using all assigned tasks (fewer vars), so below doesn't trigger.
+ ! todo: figure out what icm should be here.
+ !if ( icount == icm ) then
+ call general_reload_sfc(grd,g_t2m, g_q2m, g_ps, icount,iflag,work)
+ !endif
+
+ endif ! read_2m
+
+
+
if ( procuse ) then
if ( diff_res) deallocate(grid_b,grid_b2,grid_c,grid_c2,grid2)
call destroy_egrid2agrid(p_high)
@@ -3381,9 +3688,10 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
deallocate(rwork3d1,rwork3d0,clons,slons)
deallocate(rwork2d)
deallocate(grid,grid_v)
- call close_dataset(atmges)
+ call close_dataset(filges)
endif
- deallocate(work, work_v)
+ deallocate(work)
+ if (allocated(work_v)) deallocate(work_v)
! Convert dry temperature to virtual temperature
!do k=1,grd%nsig
@@ -3395,27 +3703,29 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
!enddo
! Load u->div and v->vor slot when uv are used instead
- if ( uvflag ) then
- call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier)
- if ( ier == 0 ) then
- ptr3d=g_u
- call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier)
- if ( ier == 0 ) ptr3d=g_v
- else ! in this case, overload: return u/v in sf/vp slot
- call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier)
- if ( ier == 0 ) then
- ptr3d=g_u
- call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier)
- if ( ier == 0 ) ptr3d=g_v
- endif
- endif
- else ! in this case, overload: return u/v in sf/vp slot
- call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier)
- if ( ier == 0 ) ptr3d=g_u
- call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier)
- if ( ier == 0 ) ptr3d=g_v
- endif
- if (zflag) then
+ if ( .not. read_2m ) then
+ if ( uvflag ) then
+ call gsi_bundlegetpointer(gfs_bundle,'u' ,ptr3d,ier)
+ if ( ier == 0 ) then
+ ptr3d=g_u
+ call gsi_bundlegetpointer(gfs_bundle,'v' ,ptr3d,ier)
+ if ( ier == 0 ) ptr3d=g_v
+ else ! in this case, overload: return u/v in sf/vp slot
+ call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier)
+ if ( ier == 0 ) then
+ ptr3d=g_u
+ call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier)
+ if ( ier == 0 ) ptr3d=g_v
+ endif
+ endif
+ else ! in this case, overload: return u/v in sf/vp slot
+ call gsi_bundlegetpointer(gfs_bundle,'sf' ,ptr3d,ier)
+ if ( ier == 0 ) ptr3d=g_u
+ call gsi_bundlegetpointer(gfs_bundle,'vp' ,ptr3d,ier)
+ if ( ier == 0 ) ptr3d=g_v
+ endif
+ endif !read_2m
+ if (read_z) then
call gsi_bundlegetpointer(gfs_bundle,'z' ,ptr2d,ier)
if ( ier == 0 ) ptr2d=g_z
endif
@@ -3428,7 +3738,7 @@ subroutine general_read_gfsatm_allhydro_nc(grd,sp_a,filename,uvflag,vordivflag,z
if ( mype == 0 ) then
write(6,700) lonb,latb,nlevs,grd%nlon,nlatm2,&
fhour,odate,trim(filename)
-700 format('GENERAL_READ_GFSATM_NC: read lonb,latb,levs=',&
+700 format('GENERAL_READ_GFSATM_ALLHYDRO_NC: read lonb,latb,levs=',&
3i6,', scatter nlon,nlat=',2i6,', hour=',f6.1,', idate=',4i5,1x,a)
endif
@@ -3504,7 +3814,7 @@ subroutine general_fill_ns(grd,grid_in,grid_out)
sumn=sumn+grid_in(i,1)
sums=sums+grid_in(i,nlatm2)
enddo
- rnlon=one/float(grd%nlon)
+ rnlon=one/real(grd%nlon,r_kind)
sumn=sumn*rnlon
sums=sums*rnlon
@@ -3599,10 +3909,10 @@ subroutine general_filluv_ns(grd,slons,clons,gridu_in,gridv_in,gridu_out,gridv_o
polsu=polsu+gridu_in(i,nlatm2)*clons(i)+gridv_in(i,nlatm2)*slons(i)
polsv=polsv+gridu_in(i,nlatm2)*slons(i)-gridv_in(i,nlatm2)*clons(i)
enddo
- polnu=polnu/float(grd%nlon)
- polnv=polnv/float(grd%nlon)
- polsu=polsu/float(grd%nlon)
- polsv=polsv/float(grd%nlon)
+ polnu=polnu/real(grd%nlon,r_kind)
+ polnv=polnv/real(grd%nlon,r_kind)
+ polsu=polsu/real(grd%nlon,r_kind)
+ polsv=polsv/real(grd%nlon,r_kind)
! Transfer local work array to output grid
do k=1,grd%itotsub
@@ -3699,10 +4009,10 @@ subroutine general_fillu_ns(grd,sp,gridu_in,gridv_in,gridu_out)
polsu=polsu+gridu_in(i,nlatm2)*sp%clons(i)+gridv_in(i,nlatm2)*sp%slons(i)
polsv=polsv+gridu_in(i,nlatm2)*sp%slons(i)-gridv_in(i,nlatm2)*sp%clons(i)
enddo
- polnu=polnu/float(grd%nlon)
- polnv=polnv/float(grd%nlon)
- polsu=polsu/float(grd%nlon)
- polsv=polsv/float(grd%nlon)
+ polnu=polnu/real(grd%nlon,r_kind)
+ polnv=polnv/real(grd%nlon,r_kind)
+ polsu=polsu/real(grd%nlon,r_kind)
+ polsv=polsv/real(grd%nlon,r_kind)
! Transfer local work array to output grid
do k=1,grd%itotsub
@@ -3797,10 +4107,10 @@ subroutine general_fillv_ns(grd,sp,gridu_in,gridv_in,gridv_out)
polsu=polsu+gridu_in(i,nlatm2)*sp%clons(i)+gridv_in(i,nlatm2)*sp%slons(i)
polsv=polsv+gridu_in(i,nlatm2)*sp%slons(i)-gridv_in(i,nlatm2)*sp%clons(i)
enddo
- polnu=polnu/float(grd%nlon)
- polnv=polnv/float(grd%nlon)
- polsu=polsu/float(grd%nlon)
- polsv=polsv/float(grd%nlon)
+ polnu=polnu/real(grd%nlon,r_kind)
+ polnv=polnv/real(grd%nlon,r_kind)
+ polsu=polsu/real(grd%nlon,r_kind)
+ polsv=polsv/real(grd%nlon,r_kind)
! Transfer local work array to output grid
do k=1,grd%itotsub
diff --git a/src/gsi/general_read_nemsaero.f90 b/src/gsi/general_read_nemsaero.f90
index 721545bc65..d1e9f525fd 100644
--- a/src/gsi/general_read_nemsaero.f90
+++ b/src/gsi/general_read_nemsaero.f90
@@ -143,7 +143,8 @@ subroutine general_read_nemsaero(grd,sp_a,filename,mype,gfschem_bundle, &
call stop2(101)
end if
- fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
odate(3) = idate(3) !day
diff --git a/src/gsi/general_spectral_transforms.f90 b/src/gsi/general_spectral_transforms.f90
index d4f0959489..76f4c02c42 100644
--- a/src/gsi/general_spectral_transforms.f90
+++ b/src/gsi/general_spectral_transforms.f90
@@ -99,7 +99,7 @@ subroutine general_g2s0_ad(grd,sp,spectral_in,grid_out)
integer(i_kind) i,j,jj
do i=1,sp%nc
- spec_work(i)=spectral_in(i)/float(grd%nlon)
+ spec_work(i)=spectral_in(i)/real(grd%nlon,r_kind)
if(sp%factsml(i))spec_work(i)=zero
end do
do i=2*sp%jcap+3,sp%nc
@@ -277,7 +277,7 @@ subroutine general_s2g0_ad(grd,sp,spectral_out,grid_in)
call general_sptez_s(sp,spec_work,work,-1)
do i=1,sp%nc
- spec_work(i)=spec_work(i)*float(grd%nlon)
+ spec_work(i)=spec_work(i)*real(grd%nlon,r_kind)
end do
do i=2*sp%jcap+3,sp%nc
spec_work(i)=two*spec_work(i)
@@ -368,8 +368,7 @@ subroutine sfilter(grd,sp,filter,grid)
call general_sptez_s(sp,spec_work,work,-1)
- gnlon=float(grd%nlon)
-! gnlon=real(grd%nlon,r_kind)
+ gnlon=real(grd%nlon,r_kind)
do i=1,sp%nc
spec_work(i)=spec_work(i)*gnlon
end do
@@ -522,8 +521,8 @@ subroutine general_uvg2zds_ad(grd,sp,zsp,dsp,ugrd,vgrd)
integer(i_kind) i,j,jj
do i=1,sp%nc
- spcwrk1(i)=dsp(i)/float(grd%nlon)
- spcwrk2(i)=zsp(i)/float(grd%nlon)
+ spcwrk1(i)=dsp(i)/real(grd%nlon,r_kind)
+ spcwrk2(i)=zsp(i)/real(grd%nlon,r_kind)
if(sp%factvml(i))then
spcwrk1(i)=zero
spcwrk2(i)=zero
@@ -866,8 +865,8 @@ subroutine general_zds2uvg_ad(grd,sp,zsp,dsp,ugrd,vgrd)
end do
do i=1,sp%nc
- spcwrk1(i)=spcwrk1(i)*float(grd%nlon)
- spcwrk2(i)=spcwrk2(i)*float(grd%nlon)
+ spcwrk1(i)=spcwrk1(i)*real(grd%nlon,r_kind)
+ spcwrk2(i)=spcwrk2(i)*real(grd%nlon,r_kind)
end do
do i=2*sp%jcap+3,sp%nc
diff --git a/src/gsi/general_sub2grid_mod.f90 b/src/gsi/general_sub2grid_mod.f90
index f0548643bb..2285cab005 100644
--- a/src/gsi/general_sub2grid_mod.f90
+++ b/src/gsi/general_sub2grid_mod.f90
@@ -87,6 +87,7 @@ module general_sub2grid_mod
interface general_sub2grid
module procedure general_sub2grid_r_single_rank11
module procedure general_sub2grid_r_single_rank14
+ module procedure general_sub2grid_r_single_rank13
module procedure general_sub2grid_r_single_rank4
module procedure general_sub2grid_r_double_rank11
module procedure general_sub2grid_r_double_rank14
@@ -97,6 +98,7 @@ module general_sub2grid_mod
module procedure general_grid2sub_r_single_rank11
module procedure general_grid2sub_r_single_rank41
module procedure general_grid2sub_r_single_rank4
+ module procedure general_grid2sub_r_single_rank31
module procedure general_grid2sub_r_double_rank11
module procedure general_grid2sub_r_double_rank41
module procedure general_grid2sub_r_double_rank4
@@ -519,7 +521,7 @@ subroutine get_iuse_pe(npe,nz,iuse_pe)
else
nskip=npe-nz
if(nskip > 0)then
- skip2=float(npe)/float(nskip)
+ skip2=real(npe,r_kind)/real(nskip,r_kind)
point=zero
do i=1,nskip
ipoint=min(max(0,nint(point)),npe)
@@ -876,7 +878,7 @@ subroutine general_deter_subdomain_nolayout(npe,mype,nlat,nlon,regional, &
! Compute number of points on full grid and target number of
! point per mpi task (pe)
npts=nlat*nlon
- anperpe=float(npts)/float(npe)
+ anperpe=real(npts,r_kind)/real(npe,r_kind)
! Start with square subdomains
nrnc=sqrt(anperpe)
@@ -1019,6 +1021,93 @@ subroutine general_sub2grid_r_single_rank14(s,sub_vars,grid_vars)
end subroutine general_sub2grid_r_single_rank14
+ subroutine general_sub2grid_r_single_rank13(s,sub_vars,grid_vars)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: general_sub2grid_r_single_rank4 convert from subdomains to full horizontal grid
+! prgmmr: parrish org: np22 date: 2010-02-11
+!
+! abstract: generalized version of sub2grid--uses only gsi module kinds.
+! All information needed is contained in the structure variable
+! "s", instead of various modules. This allows
+! for easy adaptation for any collection/ordering of variables
+! defined on subdomains, which need to be made available on
+! full horizontal grid for horizontal operations.
+! The structure variable is specified by subroutine general_sub2grid_setup.
+! This version works with single precision (4-byte) real variables.
+! Input sub_vars, the desired arrays on horizontal subdomains, has one
+! halo row, for now, which is filled with zero, since for ensemble use,
+! there is no need for a halo, but is easiest for now to keep it.
+! A later version will have variable number of halo rows, filled with proper values.
+!
+! program history log:
+! 2010-02-11 parrish, initial documentation
+!
+! input argument list:
+! s - structure variable, contains all necessary information for
+! moving this set of subdomain variables sub_vars to
+! the corresponding set of full horizontal grid variables.
+! sub_vars - input grid values in vertical subdomain mode (contains one halo row)
+!
+! output argument list:
+! grid_vars - output grid values in horizontal slab mode.
+!
+! attributes:
+! language: f90
+! machine: ibm RS/6000 SP
+!
+!$$$
+ use mpimod, only: mpi_comm_world,mpi_real4
+ implicit none
+
+ type(sub2grid_info),intent(in ) :: s
+ real(r_single), intent(in ) :: sub_vars(s%lat2*s%lon2*s%num_fields)
+ real(r_single), intent( out) :: grid_vars(s%nlat,s%nlon,s%kbegin_loc:s%kend_alloc)
+
+ real(r_single) :: sub_vars_r4(s%lat2,s%lon2,s%num_fields)
+ real(r_single) :: sub_vars0(s%lat1,s%lon1,s%num_fields)
+ real(r_single) :: work(s%itotsub*(s%kend_alloc-s%kbegin_loc+1))
+ integer(i_kind) iloc,iskip,i,i0,j,j0,k,n,k_in,ilat,jlon,ierror,ioffset
+
+ sub_vars_r4 = reshape(sub_vars,(/s%lat2,s%lon2,s%num_fields/))
+! remove halo row
+!$omp parallel do schedule(dynamic,1) private(k,j,j0,i0,i)
+ do k=1,s%num_fields
+ do j=2,s%lon2-1
+ j0=j-1
+ do i=2,s%lat2-1
+ i0=i-1
+ sub_vars0(i0,j0,k)=sub_vars_r4(i,j,k)
+ end do
+ end do
+ end do
+
+ call mpi_alltoallv(sub_vars0,s%recvcounts,s%rdispls,mpi_real4, &
+ work,s%sendcounts,s%sdispls,mpi_real4,mpi_comm_world,ierror)
+
+
+ k_in=s%kend_loc-s%kbegin_loc+1
+
+! Load grid_vars array in desired order
+!$omp parallel do schedule(dynamic,1) private(k,iskip,iloc,n,i,ilat,jlon,ioffset)
+ do k=s%kbegin_loc,s%kend_loc
+ iskip=0
+ iloc=0
+ do n=1,s%npe
+ if (n/=1) then
+ iskip=iskip+s%ijn(n-1)*k_in
+ end if
+ ioffset=iskip+(k-s%kbegin_loc)*s%ijn(n)
+ do i=1,s%ijn(n)
+ iloc=iloc+1
+ ilat=s%ltosi(iloc)
+ jlon=s%ltosj(iloc)
+ grid_vars(ilat,jlon,k)=work(i + ioffset)
+ end do
+ end do
+ end do
+
+ end subroutine general_sub2grid_r_single_rank13
subroutine general_sub2grid_r_single_rank4(s,sub_vars,grid_vars)
!$$$ subprogram documentation block
! . . . .
@@ -1199,6 +1288,84 @@ subroutine general_grid2sub_r_single_rank41(s,grid_vars,sub_vars)
end subroutine general_grid2sub_r_single_rank41
+ subroutine general_grid2sub_r_single_rank31(s,grid_vars,sub_vars)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: general_sub2grid convert from subdomains to full horizontal grid
+! prgmmr: parrish org: np22 date: 2010-02-11
+!
+! abstract: generalized version of grid2sub--uses only gsi module kinds.
+! All information needed is contained in the structure variable
+! "s", instead of various modules. This allows
+! for easy adaptation for any collection/ordering of variables
+! defined on subdomains, which need to be made available on
+! full horizontal grid for horizontal operations.
+! The structure variable is specified by subroutine general_sub2grid_setup.
+! This version works with single precision (4-byte) real variables.
+! Output sub_vars, the desired arrays on horizontal subdomains, has one
+! halo row, for now, which is filled with zero, since for ensemble use,
+! there is no need for a halo, but is easiest for now to keep it.
+! A later version will have variable number of halo rows, filled with proper values.
+!
+! program history log:
+! 2010-02-11 parrish, initial documentation
+! 2010-03-02 parrish - remove setting halo to zero in output
+! 2014-12-03 derber - make similar optimization changes already in code for
+! double precision.
+!
+! input argument list:
+! s - structure variable, contains all necessary information for
+! moving this set of subdomain variables sub_vars to
+! the corresponding set of full horizontal grid variables.
+! grid_vars - input grid values in horizontal slab mode.
+!
+! output argument list:
+! sub_vars - output grid values in vertical subdomain mode
+!
+! attributes:
+! language: f90
+! machine: ibm RS/6000 SP
+!
+!$$$
+ use constants, only: zero
+ use mpimod, only: mpi_comm_world,mpi_real4
+ implicit none
+
+ type(sub2grid_info),intent(in ) :: s
+ real(r_single), intent(in ) :: grid_vars(s%nlat,s%nlon,s%kbegin_loc:s%kend_alloc)
+ real(r_single), intent( out) :: sub_vars(s%lat2*s%lon2*s%num_fields)
+
+ real(r_single) :: sub_vars_r4(s%lat2,s%lon2,s%num_fields)
+ real(r_single) :: temp(s%itotsub*(s%kend_loc-s%kbegin_loc+1))
+ integer(i_kind) iloc,i,ii,k,n,ilat,jlon,ierror,icount
+ integer(i_kind),dimension(s%npe) ::iskip
+
+! reorganize for eventual distribution to local domains
+ iskip(1)=0
+ do n=2,s%npe
+ iskip(n)=iskip(n-1)+s%ijn_s(n-1)*(s%kend_loc-s%kbegin_loc+1)
+ end do
+!$omp parallel do schedule(dynamic,1) private(n,k,i,jlon,ii,ilat,iloc,icount)
+ do k=s%kbegin_loc,s%kend_loc
+ icount=0
+ do n=1,s%npe
+ iloc=iskip(n)+(k-s%kbegin_loc)*s%ijn_s(n)
+ do i=1,s%ijn_s(n)
+ iloc=iloc+1
+ icount=icount+1
+ ilat=s%ltosi_s(icount)
+ jlon=s%ltosj_s(icount)
+ temp(iloc)=grid_vars(ilat,jlon,k)
+ end do
+ end do
+ end do
+
+
+ call mpi_alltoallv(temp,s%sendcounts_s,s%sdispls_s,mpi_real4, &
+ sub_vars_r4,s%recvcounts_s,s%rdispls_s,mpi_real4,mpi_comm_world,ierror)
+
+ sub_vars = reshape(sub_vars_r4,(/s%lat2*s%lon2*s%num_fields/))
+ end subroutine general_grid2sub_r_single_rank31
subroutine general_grid2sub_r_single_rank4(s,grid_vars,sub_vars)
!$$$ subprogram documentation block
! . . . .
diff --git a/src/gsi/gengrid_vars.f90 b/src/gsi/gengrid_vars.f90
index a2d352c0b3..adbf510313 100644
--- a/src/gsi/gengrid_vars.f90
+++ b/src/gsi/gengrid_vars.f90
@@ -60,13 +60,13 @@ subroutine gengrid_vars
! This is global run, so get global lons, lats, wgtlats, wgtfactlats
! Set local constants
- anlon=float(nlon)
+ anlon=real(nlon,r_kind)
pih=half*pi
dlon=two*pi/anlon
! Load grid lat,lon arrays. rbs2 is used in pcp.
do i=1,nlon
- rlons(i)=float(i-1)*dlon
+ rlons(i)=real(i-1,r_kind)*dlon
coslon(i)=cos(rlons(i))
sinlon(i)=sin(rlons(i))
end do
diff --git a/src/gsi/genqsat.f90 b/src/gsi/genqsat.f90
index ed0eb152e6..bc33187497 100644
--- a/src/gsi/genqsat.f90
+++ b/src/gsi/genqsat.f90
@@ -145,9 +145,9 @@ subroutine genqsat(qsat,tsen,prsl,lat2,lon2,nsig,ice,iderivative)
esw = psat * (tr**xa) * exp(xb*(one-tr))
esi = psat * (tr**xai) * exp(xbi*(one-tr))
w = (tdry - tmix) / (ttp - tmix)
-! es = w * esw + (one-w) * esi
- es = w * psat * (tr**xa) * exp(xb*(one-tr)) &
- + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr))
+ es = w * esw + (one-w) * esi
+! es = w * psat * (tr**xa) * exp(xb*(one-tr)) &
+! + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr))
endif
diff --git a/src/gsi/genstats_gps.f90 b/src/gsi/genstats_gps.f90
index ce90d06f50..576dce5d8c 100644
--- a/src/gsi/genstats_gps.f90
+++ b/src/gsi/genstats_gps.f90
@@ -64,6 +64,15 @@ module m_gpsStats
integer(i_kind) :: idv,iob ! device id and obs index for sorting
real (r_kind) :: elat, elon ! earth lat-lon for redistribution
!real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution
+ !> xuanli
+ real(r_kind),dimension(:),pointer :: tsenges => NULL()
+ real(r_kind),dimension(:),pointer :: tvirges => NULL()
+ real(r_kind),dimension(:),pointer :: sphmges => NULL()
+ real(r_kind),dimension(:),pointer :: hgtlges => NULL()
+ real(r_kind),dimension(:),pointer :: hgtiges => NULL()
+ real(r_kind),dimension(:),pointer :: prslges => NULL()
+ real(r_kind),dimension(:),pointer :: prsiges => NULL()
+ !< xuanli
end type gps_all_ob_type
type gps_all_ob_head
@@ -250,7 +259,7 @@ subroutine genstats_gps(bwork,awork,toss_gps_sub,conv_diagsave,mype)
use obsmod, only: lobsdiagsave,luse_obsdiag
use obsmod, only: binary_diag,netcdf_diag,dirname,ianldate
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
use gridmod, only: nsig,regional
use constants, only: tiny_r_kind,half,wgtlim,one,two,zero,five,four
@@ -427,7 +436,10 @@ subroutine genstats_gps(bwork,awork,toss_gps_sub,conv_diagsave,mype)
end do
END DO
if(icnt > 0)then
- nreal =22
+!> xuanli
+! nreal =22
+ nreal =35
+!< xuanli
ioff =nreal
if (lobsdiagsave) nreal=nreal+4*miter+1
if (save_jacobian) then
@@ -760,33 +772,48 @@ subroutine contents_netcdf_diag_
! Observation class
character(7),parameter :: obsclass = ' gps'
- call nc_diag_metadata("Station_ID", gps_allptr%cdiag )
- call nc_diag_metadata("Observation_Class", obsclass )
+ call nc_diag_metadata("Station_ID", gps_allptr%cdiag )
+ call nc_diag_metadata("Observation_Class", obsclass )
obstype = gps_allptr%rdiag(1)
obssubtype = gps_allptr%rdiag(2)
call nc_diag_metadata("Observation_Type", obstype )
call nc_diag_metadata("Observation_Subtype", obssubtype )
- call nc_diag_metadata("Latitude", sngl(gps_allptr%rdiag(3)) )
- call nc_diag_metadata("Longitude", sngl(gps_allptr%rdiag(4)) )
- call nc_diag_metadata("Incremental_Bending_Angle", sngl(gps_allptr%rdiag(5)) )
- call nc_diag_metadata("Pressure", sngl(gps_allptr%rdiag(6)) )
- call nc_diag_metadata("Height", sngl(gps_allptr%rdiag(7)) )
- call nc_diag_metadata("Time", sngl(gps_allptr%rdiag(8)) )
- call nc_diag_metadata("Model_Elevation", sngl(gps_allptr%rdiag(9)) )
- call nc_diag_metadata("Setup_QC_Mark", sngl(gps_allptr%rdiag(10)) )
- call nc_diag_metadata("Prep_Use_Flag", sngl(gps_allptr%rdiag(11)) )
- call nc_diag_metadata("Analysis_Use_Flag", sngl(gps_allptr%rdiag(12)) )
-
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(gps_allptr%rdiag(13)) )
- call nc_diag_metadata("Errinv_Input", sngl(gps_allptr%rdiag(14)) )
- call nc_diag_metadata("Errinv_Adjust", sngl(gps_allptr%rdiag(15)) )
- call nc_diag_metadata("Errinv_Final", sngl(gps_allptr%rdiag(16)) )
- call nc_diag_metadata("Observation", sngl(gps_allptr%rdiag(17)) )
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(gps_allptr%rdiag(17))*sngl(gps_allptr%rdiag(5)) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(gps_allptr%rdiag(17))*sngl(gps_allptr%rdiag(5)) )
- call nc_diag_metadata("GPS_Type", sngl(gps_allptr%rdiag(20)) )
- call nc_diag_metadata("Temperature_at_Obs_Location", sngl(gps_allptr%rdiag(18)) )
- call nc_diag_metadata("Specific_Humidity_at_Obs_Location", sngl(gps_allptr%rdiag(21)) )
+ call nc_diag_metadata_to_single("Latitude", gps_allptr%rdiag(3) )
+ call nc_diag_metadata_to_single("Longitude", gps_allptr%rdiag(4) )
+ call nc_diag_metadata_to_single("Incremental_Bending_Angle", gps_allptr%rdiag(5) )
+ call nc_diag_metadata_to_single("Pressure", gps_allptr%rdiag(6) )
+ call nc_diag_metadata_to_single("Impact_Height", gps_allptr%rdiag(7) )
+ call nc_diag_metadata_to_single("Time", gps_allptr%rdiag(8) )
+ call nc_diag_metadata_to_single("Model_Elevation", gps_allptr%rdiag(9) )
+ call nc_diag_metadata_to_single("Setup_QC_Mark", gps_allptr%rdiag(10) )
+ call nc_diag_metadata_to_single("Prep_Use_Flag", gps_allptr%rdiag(11) )
+ call nc_diag_metadata_to_single("Analysis_Use_Flag", gps_allptr%rdiag(12) )
+
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt", gps_allptr%rdiag(13) )
+ call nc_diag_metadata_to_single("Errinv_Input", gps_allptr%rdiag(14) )
+ call nc_diag_metadata_to_single("Errinv_Adjust", gps_allptr%rdiag(15) )
+ call nc_diag_metadata_to_single("Errinv_Final", gps_allptr%rdiag(16) )
+ call nc_diag_metadata_to_single("Observation", gps_allptr%rdiag(17) )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted", gps_allptr%rdiag(17),gps_allptr%rdiag(5),"*")
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",gps_allptr%rdiag(17),gps_allptr%rdiag(5),"*")
+ call nc_diag_metadata_to_single("GPS_Type", gps_allptr%rdiag(20) )
+ call nc_diag_metadata_to_single("Temperature_at_Obs_Location", gps_allptr%rdiag(18) )
+ call nc_diag_metadata_to_single("Specific_Humidity_at_Obs_Location",gps_allptr%rdiag(21) )
+
+ call nc_diag_metadata_to_single("impact_parameter", gps_allptr%rdiag(23))
+ call nc_diag_metadata_to_single("pccf", gps_allptr%rdiag(24))
+ call nc_diag_metadata_to_single("reference_sat_id", gps_allptr%rdiag(25))
+ call nc_diag_metadata_to_single("earth_radius_of_curvature", gps_allptr%rdiag(26))
+ call nc_diag_metadata_to_single("geoid_height_above_reference_ellipsoid", gps_allptr%rdiag(27))
+ call nc_diag_metadata_to_single("qfro", gps_allptr%rdiag(28))
+ call nc_diag_metadata_to_single("ascending_flag", gps_allptr%rdiag(29))
+ call nc_diag_metadata_to_single("sensor_azimuth_angle", gps_allptr%rdiag(30))
+ call nc_diag_metadata_to_single("sat_constellation", gps_allptr%rdiag(31))
+ call nc_diag_metadata_to_single("occulting_sat", gps_allptr%rdiag(32))
+ call nc_diag_metadata_to_single("process_center", gps_allptr%rdiag(33))
+ call nc_diag_metadata_to_single("atmospheric_refractivity", gps_allptr%rdiag(34))
+! xuanli output the altitude as height
+ call nc_diag_metadata_to_single("Height", gps_allptr%rdiag(35))
if (save_jacobian) then
call readarray(dhx_dx, gps_allptr%rdiag(ioff+1:nreal))
@@ -794,6 +821,16 @@ subroutine contents_netcdf_diag_
call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind(1:dhx_dx%nind))
call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val(1:dhx_dx%nnz),r_single))
endif
+!> xuanli
+ call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(gps_allptr%prslges))
+ call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(gps_allptr%prsiges))
+ call nc_diag_data2d("air_temperature", sngl(gps_allptr%tsenges))
+ call nc_diag_data2d("virtual_temperature", sngl(gps_allptr%tvirges))
+ call nc_diag_data2d("specific_humidity", sngl(gps_allptr%sphmges))
+ call nc_diag_data2d("geopotential_height", sngl(gps_allptr%hgtlges))
+ call nc_diag_data2d("geopotential_height_levels", sngl(gps_allptr%hgtiges))
+
+!< xuanli
diff --git a/src/gsi/gesinfo.F90 b/src/gsi/gesinfo.F90
index 792900b628..9d287de414 100644
--- a/src/gsi/gesinfo.F90
+++ b/src/gsi/gesinfo.F90
@@ -62,7 +62,8 @@ subroutine gesinfo
! nfsecondn FCST Secs (i_kind) numerator
! nfsecondd FCST Secs (i_kind) denominator
!
-! %fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+! %fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+! real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
!
! attributes:
! language: f90
@@ -148,7 +149,7 @@ subroutine gesinfo
write(filename,'("sigf",i2.2)')nhr_assimilation
inquire(file=filename,exist=fexist)
if(.not.fexist) then
- write(6,*)' GESINFO: ***ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS'
+ write(6,*)' GESINFO: ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS'
call stop2(99)
stop
end if
@@ -312,8 +313,8 @@ subroutine gesinfo
nfhour, nfminute, nfsecondn, nfsecondd
call stop2(99)
endif
- gfshead%fhour = float(nfhour) + float(nfminute)/r60 + &
- float(nfsecondn)/float(nfsecondd)/r3600
+ gfshead%fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
gfshead%idate(1) = idate(4) !hour
gfshead%idate(3) = idate(3) !day
@@ -339,12 +340,12 @@ subroutine gesinfo
! open the netCDF file
atmges = open_dataset(filename,errcode=iret)
if (iret /=0) then
- write(6,*)'GESINFO: ***ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS'
+ write(6,*)'GESINFO: ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS'
call stop2(99)
endif
sfcges = open_dataset(sfilename,errcode=iret)
if (iret /=0) then
- write(6,*)'GESINFO: ***ERROR*** ',trim(sfilename),' NOT AVAILABLE: PROGRAM STOPS'
+ write(6,*)'GESINFO: ***FATAL ERROR*** ',trim(sfilename),' NOT AVAILABLE: PROGRAM STOPS'
call stop2(99)
endif
! get dimension sizes
@@ -451,7 +452,7 @@ subroutine gesinfo
! Check for consistency with namelist settings
if (gfshead%jcap/=jcap_b.and..not.regional .or. gfshead%levs/=nsig) then
if (gfshead%levs/=nsig) then
- write(6,*)'GESINFO: ***ERROR*** guess levels inconsistent with namelist'
+ write(6,*)'GESINFO: ***FATAL ERROR*** guess levels inconsistent with namelist'
write(6,*)' guess nsig=',gfshead%levs
write(6,*)' namelist nsig=',nsig
fatal = .true.
@@ -466,7 +467,7 @@ subroutine gesinfo
fatal = .false.
else
if ( mype == mype_out ) &
- write(6,*)'GESINFO: ***ERROR*** guess jcap inconsistent with namelist'
+ write(6,*)'GESINFO: ***FATAL ERROR*** guess jcap inconsistent with namelist'
fatal = .true.
endif
if ( mype == mype_out ) &
@@ -551,7 +552,7 @@ subroutine gesinfo
ida(:)=0
jda(:)=0
fha(:)=zero
- fha(2)=-float(int(min_offset/60))
+ fha(2)=-real(int(min_offset/60),r_kind)
fha(3)=-(min_offset+fha(2)*r60)
ida(1:3)=iadate(1:3)
ida(5:6)=iadate(4:5)
@@ -582,7 +583,7 @@ subroutine gesinfo
! Get time offset
call time_4dvar(ianldate,time_offset)
#ifdef RR_CLOUDANALYSIS
- fha(2)=float(int(min_offset/60))
+ fha(2)=real(int(min_offset/60),r_kind)
fha(3)=(min_offset-fha(2)*r60)
time_offset=time_offset+fha(3)/r60
#endif
diff --git a/src/gsi/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90
index fa3d0ecbdd..ca5db84a1a 100644
--- a/src/gsi/get_gefs_ensperts_dualres.f90
+++ b/src/gsi/get_gefs_ensperts_dualres.f90
@@ -26,7 +26,7 @@ subroutine get_gefs_ensperts_dualres
!
! get_gefs_ensperts_dualres.f90(182): error #6460: This is not a field name that
! is defined in the encompassing structure. [LAT2]
-! call genqsat(qs,tsen,prsl,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,ice,iderivative)
+! call genqsat2(qs,tsen,prsl,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,ice)
! 2014-11-30 todling - partially generalized to handle any control vector
! (GFS hook needs further attention)
! - also, take SST from members of ensemble
@@ -49,10 +49,9 @@ subroutine get_gefs_ensperts_dualres
!$$$ end documentation block
use mpeu_util, only: die
- use gridmod, only: idsl5
use hybrid_ensemble_parameters, only: n_ens,write_ens_sprd,oz_univ_static,ntlevs_ens
use hybrid_ensemble_parameters, only: en_perts,ps_bar,nelen
- use constants,only: zero,zero_single,half,fv,rd_over_cp,one,qcmin
+ use constants,only: zero,zero_single,half,fv,one,qcmin
use mpimod, only: mpi_comm_world,mype,npe
use kinds, only: r_kind,i_kind,r_single
use hybrid_ensemble_parameters, only: grd_ens,q_hyb_ens,limqens
@@ -64,10 +63,12 @@ subroutine get_gefs_ensperts_dualres
use gsi_bundlemod, only: gsi_bundlegetpointer
use gsi_bundlemod, only: gsi_bundledestroy
use gsi_bundlemod, only: gsi_gridcreate
+ use gsi_bundlemod, only : assignment(=)
use gsi_enscouplermod, only: gsi_enscoupler_get_user_nens
use gsi_enscouplermod, only: gsi_enscoupler_create_sub2grid_info
use gsi_enscouplermod, only: gsi_enscoupler_destroy_sub2grid_info
use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sub2grid_destroy_info
+ use hybrid_ensemble_parameters, only: nsclgrp,sp_ens,global_spectral_filter_sd
implicit none
real(r_kind),pointer,dimension(:,:) :: ps
@@ -76,21 +77,23 @@ subroutine get_gefs_ensperts_dualres
! real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon):: sst_full,dum
real(r_kind),pointer,dimension(:,:,:):: p3
real(r_kind),pointer,dimension(:,:):: x2
- type(gsi_bundle),allocatable,dimension(:) :: en_read
+ type(gsi_bundle),allocatable,dimension(:) :: en_real8
type(gsi_bundle):: en_bar
! type(gsi_grid) :: grid_ens
- real(r_kind) bar_norm,sig_norm,kapr,kap1
+ real(r_kind) bar_norm,sig_norm
! real(r_kind),allocatable,dimension(:,:):: z,sst2
- real(r_kind),allocatable,dimension(:,:,:) :: tsen,prsl,pri,qs
+ real(r_kind),allocatable,dimension(:,:,:) :: tsen,prsl
! integer(i_kind),dimension(grd_ens%nlat,grd_ens%nlon):: idum
- integer(i_kind) istatus,iret,i,ic3,j,k,n,iderivative,im,jm,km,m,ipic
+ integer(i_kind) istatus,iret,i,ic3,j,k,n,im,jm,km,m,ipic
! integer(i_kind) mm1
integer(i_kind) ipc3d(nc3d),ipc2d(nc2d)
integer(i_kind) ier
! integer(i_kind) il,jl
logical ice,hydrometeor
type(sub2grid_info) :: grd_tmp
+ real(r_kind),parameter :: r0_001 = 0.001_r_kind
+
! Create perturbations grid and get variable names from perturbations
if(en_perts(1,1,1)%grid%im/=grd_ens%lat2.or. &
@@ -119,7 +122,7 @@ subroutine get_gefs_ensperts_dualres
im=en_perts(1,1,1)%grid%im
jm=en_perts(1,1,1)%grid%jm
km=en_perts(1,1,1)%grid%km
- bar_norm = one/float(n_ens)
+ bar_norm = one/real(n_ens,r_kind)
sig_norm=sqrt(one/max(one,n_ens-one))
! Create temporary communication information for read ensemble routines
@@ -130,31 +133,24 @@ subroutine get_gefs_ensperts_dualres
if ( istatus /= 0 ) &
call die('get_gefs_ensperts_dualres',': trouble creating en_bar bundle, istatus =',istatus)
- ! Allocate bundle used for reading members
- allocate(en_read(n_ens))
+ ! Allocate bundle used for real*8 version of members
+ allocate(en_real8(n_ens))
do n=1,n_ens
- call gsi_bundlecreate(en_read(n),en_perts(1,1,1)%grid,'ensemble member',istatus,names2d=cvars2d,names3d=cvars3d)
+ call gsi_bundlecreate(en_real8(n),en_perts(1,1,1)%grid,'ensemble member',istatus,names2d=cvars2d,names3d=cvars3d)
if ( istatus /= 0 ) &
- call die('get_gefs_ensperts_dualres',': trouble creating en_read bundle, istatus =',istatus)
+ call die('get_gefs_ensperts_dualres',': trouble creating en_real8 bundle, istatus =',istatus)
end do
+
! allocate(z(im,jm))
! allocate(sst2(im,jm))
! sst2=zero ! for now, sst not used in ensemble perturbations, so if sst array is called for
! then sst part of en_perts will be zero when sst2=zero
-!$omp parallel do schedule(dynamic,1) private(m,n)
- do m=1,ntlevs_ens
- do n=1,n_ens
- en_perts(n,1,m)%valuesr4=zero_single
- end do
- end do
-
-
ntlevs_ens_loop: do m=1,ntlevs_ens
- call gsi_enscoupler_get_user_Nens(grd_tmp,n_ens,m,en_read,iret)
+ call gsi_enscoupler_get_user_Nens(grd_tmp,n_ens,m,en_perts(:,1,m),iret)
! Check read return code. Revert to static B if read error detected
if ( iret /= 0 ) then
@@ -166,65 +162,53 @@ subroutine get_gefs_ensperts_dualres
cycle
endif
+ en_bar%values=zero
+ allocate(tsen(im,jm,km))
if (.not.q_hyb_ens) then !use RH
- kap1=rd_over_cp+one
- kapr=one/rd_over_cp
- do n=1,n_ens
+ allocate(prsl(im,jm,km))
+ end if
+ do n=1,n_ens
+ do i=1,nelen
+ en_real8(n)%values(i)=real(en_perts(n,1,m)%valuesr4(i),r_kind)
+ end do
- call gsi_bundlegetpointer(en_read(n),'ps',ps,ier);istatus=ier
- call gsi_bundlegetpointer(en_read(n),'t' ,tv,ier);istatus=istatus+ier
- call gsi_bundlegetpointer(en_read(n),'q' ,q ,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(en_real8(n),'q' ,q ,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(en_real8(n),'t' ,tv,ier);istatus=istatus+ier
+ call gsi_bundlegetpointer(en_real8(n),'ps',ps,ier);istatus=ier
+! Convert ps to correct units
+ do j=1,jm
+ do i=1,im
+ ps(i,j)=r0_001*ps(i,j)
+ end do
+ end do
+! Convert to real from single and convert tv to virtual temperature
+ do k=1,km
+ do j=1,jm
+ do i=1,im
+! Use following 3 lines for results identical to previous version
+! tv(i,j,k)= tv(i,j,k)*(one+fv*q(i,j,k))
+! q(i,j,k)=max(q(i,j,k),zero)
+! tsen(i,j,k)=tv(i,j,k)/(one+fv*q(i,j,k))
+! Remove following 3 lines for results identical to previous version
+ q(i,j,k)=max(q(i,j,k),zero)
+ tsen(i,j,k)=tv(i,j,k)
+ tv(i,j,k)= tsen(i,j,k)*(one+fv*q(i,j,k))
+ end do
+ end do
+ end do
+ if (.not.q_hyb_ens) then !use RH
+
! Compute RH
! Get 3d pressure field now on interfaces
- allocate(pri(im,jm,km+1))
- call general_getprs_glb(ps,tv,pri)
- allocate(prsl(im,jm,km),tsen(im,jm,km),qs(im,jm,km))
-! Get sensible temperature and 3d layer pressure
- if (idsl5 /= 2) then
-!$omp parallel do schedule(dynamic,1) private(k,j,i)
- do k=1,km
- do j=1,jm
- do i=1,im
- prsl(i,j,k)=((pri(i,j,k)**kap1-pri(i,j,k+1)**kap1)/&
- (kap1*(pri(i,j,k)-pri(i,j,k+1))))**kapr
- tsen(i,j,k)= tv(i,j,k)/(one+fv*max(zero,q(i,j,k)))
- end do
- end do
- end do
- else
-!$omp parallel do schedule(dynamic,1) private(k,j,i)
- do k=1,km
- do j=1,jm
- do i=1,im
- prsl(i,j,k)=(pri(i,j,k)+pri(i,j,k+1))*half
- tsen(i,j,k)= tv(i,j,k)/(one+fv*max(zero,q(i,j,k)))
- end do
- end do
- end do
- end if
- deallocate(pri)
+ call general_getprs_glb(ps,tv,prsl)
ice=.true.
- iderivative=0
- call genqsat(qs,tsen,prsl,im,jm,km,ice,iderivative)
- do k=1,km
- do j=1,jm
- do i=1,im
- q(i,j,k)=q(i,j,k)/qs(i,j,k)
- end do
- end do
- end do
- deallocate(tsen,prsl,qs)
- enddo
- end if
+ call genqsat2(q,tsen,prsl,ice)
-
- en_bar%values=zero
-
- n_ens_loop: do n=1,n_ens
+ end if
-!$omp parallel do schedule(dynamic,1) private(i,k,j,ic3,hydrometeor,istatus,p3)
+! !$omp parallel do schedule(dynamic,1) private(i,k,j,ic3,hydrometeor,istatus,p3)
do ic3=1,nc3d
hydrometeor = trim(cvars3d(ic3))=='cw' .or. trim(cvars3d(ic3))=='ql' .or. &
@@ -232,14 +216,14 @@ subroutine get_gefs_ensperts_dualres
trim(cvars3d(ic3))=='qs' .or. trim(cvars3d(ic3))=='qg' .or. &
trim(cvars3d(ic3))=='qh'
- call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus)
- if(istatus/=0) then
- write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m
- call stop2(999)
- end if
if ( hydrometeor ) then
+ call gsi_bundlegetpointer(en_real8(n),trim(cvars3d(ic3)),p3,istatus)
+ if(istatus/=0) then
+ write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m
+ call stop2(999)
+ end if
do k=1,km
do j=1,jm
do i=1,im
@@ -249,13 +233,17 @@ subroutine get_gefs_ensperts_dualres
end do
else if ( trim(cvars3d(ic3)) == 'oz' .and. oz_univ_static ) then
+ call gsi_bundlegetpointer(en_real8(n),trim(cvars3d(ic3)),p3,istatus)
+ if(istatus/=0) then
+ write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m
+ call stop2(999)
+ end if
p3 = zero
end if
end do !c3d
do i=1,nelen
- en_perts(n,1,m)%valuesr4(i)=en_read(n)%values(i)
- en_bar%values(i)=en_bar%values(i)+en_read(n)%values(i)
+ en_bar%values(i)=en_bar%values(i)+en_real8(n)%values(i)*bar_norm
end do
@@ -265,14 +253,13 @@ subroutine get_gefs_ensperts_dualres
! know who would want to commented out code below but be mindful
! of how it interacts with option sst_staticB, please - Todling.
- end do n_ens_loop ! end do over ensemble
-
- do i=1,nelen
- en_bar%values(i)=en_bar%values(i)*bar_norm
- end do
+ end do ! end do over ensembles
+ if (.not.q_hyb_ens) then !use RH
+ deallocate(prsl)
+ end if
+ deallocate(tsen)
! Before converting to perturbations, get ensemble spread
- !-- if (m == 1 .and. write_ens_sprd ) call ens_spread_dualres(en_bar,1)
!!! it is not clear of the next statement is thread/$omp safe.
if (write_ens_sprd ) call ens_spread_dualres(en_bar,m)
@@ -283,7 +270,6 @@ subroutine get_gefs_ensperts_dualres
! Copy pbar to module array. ps_bar may be needed for vertical localization
! in terms of scale heights/normalized p/p
-! Convert to mean
do j=1,jm
do i=1,im
ps_bar(i,j,m)=x2(i,j)
@@ -295,7 +281,7 @@ subroutine get_gefs_ensperts_dualres
!$omp parallel do schedule(dynamic,1) private(n,i,ic3,ipic,k,j)
do n=1,n_ens
do i=1,nelen
- en_perts(n,1,m)%valuesr4(i)=en_perts(n,1,m)%valuesr4(i)-en_bar%values(i)
+ en_perts(n,1,m)%valuesr4(i)=en_real8(n)%values(i)-en_bar%values(i)
end do
if(.not. q_hyb_ens) then
do ic3=1,nc3d
@@ -304,8 +290,8 @@ subroutine get_gefs_ensperts_dualres
do k=1,km
do j=1,jm
do i=1,im
- en_perts(n,1,m)%r3(ipic)%qr4(i,j,k) = min(en_perts(n,1,m)%r3(ipic)%qr4(i,j,k),limqens)
- en_perts(n,1,m)%r3(ipic)%qr4(i,j,k) = max(en_perts(n,1,m)%r3(ipic)%qr4(i,j,k),-limqens)
+ en_perts(n,1,m)%r3(ipic)%qr4(i,j,k) = &
+ max(min(en_perts(n,1,m)%r3(ipic)%qr4(i,j,k),limqens),-limqens)
end do
end do
end do
@@ -316,14 +302,22 @@ subroutine get_gefs_ensperts_dualres
en_perts(n,1,m)%valuesr4(i)=en_perts(n,1,m)%valuesr4(i)*sig_norm
end do
end do
+ if(nsclgrp > 1 .and. global_spectral_filter_sd) then
+ call apply_scaledepwgts(m,grd_ens,sp_ens)
+ end if
end do ntlevs_ens_loop !end do over bins
do n=n_ens,1,-1
- call gsi_bundledestroy(en_read(n),istatus)
+ call gsi_bundledestroy(en_real8(n),istatus)
if ( istatus /= 0 ) &
- call die('get_gefs_ensperts_dualres',': trouble destroying en_read bundle, istatus = ', istatus)
+ call die('get_gefs_ensperts_dualres',': trouble destroying en_real8 bundle, istatus = ', istatus)
end do
- deallocate(en_read)
+ deallocate(en_real8)
+
+ call gsi_bundledestroy(en_bar,istatus)
+
+ if(nsclgrp > 1 .and. global_spectral_filter_sd) call destroy_mult_spc_wgts
+
call gsi_enscoupler_destroy_sub2grid_info(grd_tmp)
! mm1=mype+1
@@ -449,7 +443,7 @@ subroutine ens_spread_dualres(en_bar,ibin)
call stop2(999)
endif
- sp_norm=(one/float(n_ens))
+ sp_norm=(one/real(n_ens,r_kind))
sube%values=zero
do n=1,n_ens
@@ -642,7 +636,7 @@ subroutine write_spread_dualres(ibin,bundle)
return
end subroutine write_spread_dualres
-subroutine general_getprs_glb(ps,tv,prs)
+subroutine general_getprs_glb(ps,tv,prsl)
! subprogram: getprs get 3d pressure or 3d pressure deriv
! prgmmr: kleist org: np20 date: 2005-09-29
!
@@ -674,96 +668,197 @@ subroutine general_getprs_glb(ps,tv,prs)
use kinds,only: r_kind,i_kind
use constants,only: zero,half,one_tenth,rd_over_cp,one
- use gridmod,only: nsig,ak5,bk5,ck5,tref5,idvc5
- use gridmod,only: wrf_nmm_regional,nems_nmmb_regional,eta1_ll,eta2_ll,pdtop_ll,pt_ll,&
- regional,wrf_mass_regional,twodvar_regional,fv3_regional
+ use gridmod,only: nsig,ak5,bk5,ck5,tref5,idvc5,idsl5
use hybrid_ensemble_parameters, only: grd_ens
implicit none
! Declare passed variables
- real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2) ,intent(in ) :: ps
- real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,nsig) ,intent(in ) :: tv
- real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,nsig+1),intent( out) :: prs
+ real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2) ,intent(in ) :: ps
+ real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,nsig),intent(in ) :: tv
+ real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2,nsig),intent( out) :: prsl
! Declare local variables
- real(r_kind) kapr,trk
+ real(r_kind) kapr,trk,kap1
+ real(r_kind),dimension(grd_ens%lat2,nsig+1) :: prs
integer(i_kind) i,j,k,k2 ! ,it
-! Declare local parameter
- real(r_kind),parameter:: ten = 10.0_r_kind
- kapr=one/rd_over_cp
-
- if (regional) then
- if(wrf_nmm_regional.or.nems_nmmb_regional) then
- do k=1,nsig+1
- do j=1,grd_ens%lon2
+ k2=nsig+1
+ kap1=rd_over_cp+one
+ kapr=one/rd_over_cp
+!$omp parallel do schedule(dynamic,1) private(k,j,i,trk,prs)
+ do j=1,grd_ens%lon2
+ do i=1,grd_ens%lat2
+ prs(i,1)=ps(i,j)
+ prs(i,k2)=zero
+ end do
+ if (idvc5 /= 3) then
+ do k=2,nsig
do i=1,grd_ens%lat2
- prs(i,j,k)=one_tenth* &
- (eta1_ll(k)*pdtop_ll + &
- eta2_ll(k)*(ten*ps(i,j)-pdtop_ll-pt_ll) + &
- pt_ll)
+ prs(i,k)=ak5(k)+bk5(k)*ps(i,j)
end do
end do
- end do
- elseif (fv3_regional) then
- do k=1,nsig+1
- do j=1,grd_ens%lon2
+ else
+ do k=1,nsig
do i=1,grd_ens%lat2
- prs(i,j,k)=eta1_ll(k)+ eta2_ll(k)*ps(i,j)
+ trk=(half*(tv(i,j,k-1)+tv(i,j,k))/tref5(k))**kapr
+ prs(i,k)=ak5(k)+(bk5(k)*ps(i,j))+(ck5(k)*trk)
end do
end do
- end do
-
- elseif (twodvar_regional) then
- do k=1,nsig+1
- do j=1,grd_ens%lon2
+ end if
+! Get sensible temperature and 3d layer pressure
+ if (idsl5 /= 2) then
+ do k=1,nsig
do i=1,grd_ens%lat2
- prs(i,j,k)=one_tenth*(eta1_ll(k)*(ten*ps(i,j)-pt_ll) + pt_ll)
+ prsl(i,j,k)=((prs(i,k)**kap1-prs(i,k+1)**kap1)/&
+ (kap1*(prs(i,k)-prs(i,k+1))))**kapr
end do
end do
- end do
- elseif (wrf_mass_regional) then
- do k=1,nsig+1
- do j=1,grd_ens%lon2
+ else
+ do k=1,nsig
do i=1,grd_ens%lat2
- prs(i,j,k)=one_tenth*(eta1_ll(k)*(ten*ps(i,j)-pt_ll) + &
- eta2_ll(k) + pt_ll)
+ prsl(i,j,k)=(prs(i,k)+prs(i,k+1))*half
end do
end do
- end do
- endif
- else
- k=1
- k2=nsig+1
- do j=1,grd_ens%lon2
+ end if
+ end do
+
+ return
+end subroutine general_getprs_glb
+subroutine genqsat2(q,tsen,prsl,ice)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: genqsat
+! prgmmr: derber org: np23 date: 1998-01-14
+!
+! abstract: obtain saturation specific humidity for given temperature.
+!
+! program history log:
+! 1998-01-14 derber
+! 1998-04-05 weiyu yang
+! 1999-08-24 derber, j., treadon, r., yang, w., first frozen mpp version
+! 1903-10-07 Wei Gu, bug fixes,if qs<0,then set qs=0; merge w/ GSI by R Todling
+! 2003-12-23 kleist, use guess pressure, adapt module framework
+! 2004-05-13 kleist, documentation
+! 2004-06-03 treadon, replace ggrid_g3 array with ges_* arrays
+! 2005-02-23 wu, output dlnesdtv
+! 2005-11-21 kleist, derber add dmax array to decouple moisture from temp and
+! pressure for questionable qsat
+! 2006-02-02 treadon - rename prsl as ges_prsl
+! 2006-09-18 derber - modify to limit saturated values near top
+! 2006-11-22 derber - correct bug: es 2._r_kind) .and. &
+ tsen(i,j,k) < mint(i))then
+ lmint(i)=k
+ mint(i)=tsen(i,j,k)
+ end if
end do
end do
- if (idvc5 /= 3) then
-!$omp parallel do schedule(dynamic,1) private(k,j,i)
- do k=2,nsig
- do j=1,grd_ens%lon2
- do i=1,grd_ens%lat2
- prs(i,j,k)=ak5(k)+bk5(k)*ps(i,j)
- end do
- end do
- end do
- else
-!$omp parallel do schedule(dynamic,1) private(k,j,i,trk)
- do k=2,nsig
- do j=1,grd_ens%lon2
- do i=1,grd_ens%lat2
- trk=(half*(tv(i,j,k-1)+tv(i,j,k))/tref5(k))**kapr
- prs(i,j,k)=ak5(k)+(bk5(k)*ps(i,j))+(ck5(k)*trk)
- end do
- end do
- end do
- end if
- end if
+ do i=1,grd_ens%lat2
+ tdry = mint(i)
+ tr = ttp/tdry
+ if (tdry >= ttp .or. .not. ice) then
+ estmax(i) = psat * (tr**xa) * exp(xb*(one-tr))
+ elseif (tdry < tmix) then
+ estmax(i) = psat * (tr**xai) * exp(xbi*(one-tr))
+ else
+ w = (tdry - tmix) / (ttp - tmix)
+ estmax(i) = w * psat * (tr**xa) * exp(xb*(one-tr)) &
+ + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr))
+ endif
+ end do
+ do k = 1,nsig
+ do i = 1,grd_ens%lat2
+ tdry = tsen(i,j,k)
+ tr = ttp/tdry
+ if (tdry >= ttp .or. .not. ice) then
+ es = psat * (tr**xa) * exp(xb*(one-tr))
+ elseif (tdry < tmix) then
+ es = psat * (tr**xai) * exp(xbi*(one-tr))
+ else
+ esw = psat * (tr**xa) * exp(xb*(one-tr))
+ esi = psat * (tr**xai) * exp(xbi*(one-tr))
+ w = (tdry - tmix) / (ttp - tmix)
+ es = w * esw + (one-w) * esi
+! es = w * psat * (tr**xa) * exp(xb*(one-tr)) &
+! + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr))
+
+ endif
+
+ pw = onep3*prsl(i,j,k)
+ if(lmint(i) < k)then
+ esmax=0.1_r_kind*pw
+ esmax=min(esmax,estmax(i))
+ es=min(es,esmax)
+ end if
+ qs = max(qmin, eps * es / (pw - omeps * es))
+ q(i,j,k) = q(i,j,k)/qs
+
+ end do
+ end do
+ end do
return
-end subroutine general_getprs_glb
+end subroutine genqsat2
+
diff --git a/src/gsi/get_gefs_for_regional.f90 b/src/gsi/get_gefs_for_regional.f90
index a076f0ccfd..cc5e0a2c86 100644
--- a/src/gsi/get_gefs_for_regional.f90
+++ b/src/gsi/get_gefs_for_regional.f90
@@ -41,7 +41,7 @@ subroutine get_gefs_for_regional
fv3_regional
use hybrid_ensemble_parameters, only: region_lat_ens,region_lon_ens
use hybrid_ensemble_parameters, only: en_perts,ps_bar,nelen
- use hybrid_ensemble_parameters, only: n_ens_gfs,grd_ens,grd_a1,grd_e1,p_e2a,uv_hyb_ens,dual_res
+ use hybrid_ensemble_parameters, only: n_ens_gfs,weight_ens_gfs,grd_ens,grd_a1,grd_e1,p_e2a,uv_hyb_ens,dual_res
use hybrid_ensemble_parameters, only: full_ensemble,q_hyb_ens,l_ens_in_diff_time,write_ens_sprd
use hybrid_ensemble_parameters, only: ntlevs_ens,ensemble_path,jcap_ens
use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d
@@ -304,8 +304,8 @@ subroutine get_gefs_for_regional
if (nframe /= 0) call error_msg(trim(my_name),trim(filename),'nframe', &
'getfilehead',istop,nframe)
- fhour = float(nfhour) + float(nfminute)/r60 + &
- float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
nlat_gfs=latb+2
nlon_gfs=lonb
@@ -897,8 +897,8 @@ subroutine get_gefs_for_regional
iimin=min(ii,iimin)
jjmax=max(jj,jjmax)
jjmin=min(jj,jjmin)
- dlon_ens=float(jj)
- dlat_ens=float(ii)
+ dlon_ens=real(jj,r_kind)
+ dlat_ens=real(ii,r_kind)
dlon=one+(dlon_ens-one)*ratio_x
dlat=one+(dlat_ens-one)*ratio_y
call rotate_wind_ll2xy(work_sub(1,i,j,ku),work_sub(1,i,j,kv), &
@@ -992,7 +992,7 @@ subroutine get_gefs_for_regional
end do
! Convert to mean
- bar_norm = one/float(n_ens_gfs)
+ bar_norm = one/real(n_ens_gfs,r_kind)
do k=1,grd_mix%nsig
do j=1,grd_mix%lon2
do i=1,grd_mix%lat2
@@ -1311,7 +1311,7 @@ subroutine get_gefs_for_regional
! 2*J_b = x^T * (beta1*B + beta2*P_ens)^(-1) * x
! where P_ens is the ensemble covariance which is the sum of outer products of the
! ensemble perturbations (unnormalized) divided by n_ens-1 (or n_ens, depending on who you read).
- sig_norm=sqrt(one/max(one,n_ens_temp-one))
+ sig_norm=sqrt(weight_ens_gfs/max(one,n_ens_temp-one))
! if(n_ens_temp==n_ens.and.n==n_ens+1) sig_norm=one
! if(n==1 .or. n==2 .or. n==50) then
diff --git a/src/gsi/get_nmmb_ensperts.f90 b/src/gsi/get_nmmb_ensperts.f90
index ece1780c03..4dc3254ccd 100644
--- a/src/gsi/get_nmmb_ensperts.f90
+++ b/src/gsi/get_nmmb_ensperts.f90
@@ -313,7 +313,7 @@ subroutine get_nmmb_ensperts
end do ! end do over ensemble
! Convert to mean
- bar_norm = one/float(n_ens)
+ bar_norm = one/real(n_ens,r_kind)
en_bar%values=en_bar%values*bar_norm
! Copy pbar to module array. ps_bar may be needed for vertical localization
diff --git a/src/gsi/getsiga.f90 b/src/gsi/getsiga.f90
index 788e0652d7..ad47017be1 100644
--- a/src/gsi/getsiga.f90
+++ b/src/gsi/getsiga.f90
@@ -198,6 +198,7 @@ subroutine view_cv_ad (xhat,mydate,filename,readcv)
use state_vectors, only: allocate_state,deallocate_state,prt_state_norms
use bias_predictors, only: predictors,allocate_preds,deallocate_preds,assignment(=)
use bias_predictors, only: read_preds
+use control2state_mod, only: control2state_ad
implicit none
type(control_vector) :: xhat
integer(i_kind), intent(in) :: mydate(5) ! as in iadate or ibdate, or similar
diff --git a/src/gsi/gfs_stratosphere.f90 b/src/gsi/gfs_stratosphere.f90
index 22581b2db0..6014045c76 100644
--- a/src/gsi/gfs_stratosphere.f90
+++ b/src/gsi/gfs_stratosphere.f90
@@ -308,8 +308,8 @@ subroutine mix_gfs_nmmb_vcoords(deta1 ,aeta1 ,eta1 ,deta2 ,aeta2 ,eta2 ,pdtop,pt
if (nframe /= 0) call error_msg(trim(my_name),trim(filename),'nframe', &
'getfilehead',istop,nframe)
- fhour = float(nfhour) + float(nfminute)/r60 + &
- float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
write(6,*) ' input filename=',filename
write(6,*) ' nemsio head: fhour,idate=',fhour,idate
write(6,*) ' nemsio head: levs=',levs
@@ -1183,8 +1183,8 @@ subroutine add_gfs_stratosphere
if ( nframe /= 0 ) call error_msg(trim(my_name),trim(filename),'nframe', &
'getfilehead',istop,nframe)
- fhour = float(nfhour) + float(nfminute)/r60 + &
- float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
if ( mype == 0 ) then
write(6,*) ' input filename=',filename
write(6,*) ' nemsio head: fhour,idate=',fhour,idate
@@ -1545,8 +1545,8 @@ subroutine add_gfs_stratosphere
jj=j+grd_mix%jstart(mm1)-2
ii=min(grd_mix%nlat,max(1,ii))
jj=min(grd_mix%nlon,max(1,jj))
- dlon=float(jj)
- dlat=float(ii)
+ dlon=real(jj,r_kind)
+ dlat=real(ii,r_kind)
do k=1,nsig_save
xspli_r(k)=log(prsl_r(i,j,k)*ten)
enddo
diff --git a/src/gsi/grdcrd.f90 b/src/gsi/grdcrd.f90
index c20e02ce7f..bb655fc68b 100644
--- a/src/gsi/grdcrd.f90
+++ b/src/gsi/grdcrd.f90
@@ -63,7 +63,7 @@ subroutine grdcrd(d,nd,x,nx,flg)
ix=isrchf(nx-1,x,d(id),flg)-1
end if
end if
- d(id)=float(ix)+(d(id)-x(ix))/(x(ix+1)-x(ix))
+ d(id)=real(ix,r_kind)+(d(id)-x(ix))/(x(ix+1)-x(ix))
end do
! Treat special case of nx=1
@@ -135,7 +135,7 @@ subroutine grdcrd1(d,x,nx,flg)
ix=isrchf(nx-1,x,d,flg)-1
end if
end if
- d=float(ix)+(d-x(ix))/(x(ix+1)-x(ix))
+ d=real(ix,r_kind)+(d-x(ix))/(x(ix+1)-x(ix))
! Treat special case of nx=1
elseif (nx==1) then
diff --git a/src/gsi/gridmod.F90 b/src/gsi/gridmod.F90
index 928b9e9c43..2367899ea5 100644
--- a/src/gsi/gridmod.F90
+++ b/src/gsi/gridmod.F90
@@ -93,6 +93,7 @@ module gridmod
! 2019-09-23 martin - add use_gfs_ncio to read global first guess from netCDF file
! 2020-12-18 Hu - add grid_type_fv3_regional
! 2021-12-30 Hu - add fv3_io_layout_y
+! 2022-03-01 X.Lu & X.Wang - add corresponding variables for dual ens for HAFS. POC: xuguang.wang@ou.edu
!
!
!
@@ -130,6 +131,7 @@ module gridmod
public :: vectosub
public :: reload
public :: strip_periodic
+ public :: minmype
! set passed variables to public
public :: nnnn1o,iglobal,itotsub,ijn,ijn_s,lat2,lon2,lat1,lon1,nsig,nsig_soil
@@ -145,6 +147,7 @@ module gridmod
public :: regional_fhr,region_dyi,coeffx,region_dxi,coeffy,nsig_hlf,regional_fmin
public :: nsig2,wgtlats,corlats,rbs2,ncepgfs_headv,regional_time,wgtfactlats
public :: nlat_regional,nlon_regional,update_regsfc,half_grid,gencode
+ public :: nlat_regionalens,nlon_regionalens
public :: diagnostic_reg,nmmb_reference_grid,filled_grid
public :: grid_ratio_nmmb,isd_g,isc_g,dx_gfs,lpl_gfs,nsig5,nmmb_verttype
public :: grid_ratio_fv3_regional,fv3_io_layout_y,fv3_regional,fv3_cmaq_regional,grid_type_fv3_regional
@@ -267,6 +270,7 @@ module gridmod
integer(i_kind) jcap ! spectral triangular truncation of ncep global analysis
integer(i_kind) jcap_b ! spectral triangular truncation of ncep global background
integer(i_kind) nthreads ! number of threads used (currently only used in calctends routines)
+ integer(i_kind) minmype ! processor with minimum size subdomain
logical periodic ! logical flag for periodic e/w domains
@@ -327,7 +331,7 @@ module gridmod
real(r_kind) rlon_min_dd,rlon_max_dd,rlat_min_dd,rlat_max_dd
real(r_kind) dt_ll,pdtop_ll,pt_ll
- integer(i_kind) nlon_regional,nlat_regional
+ integer(i_kind) nlon_regional,nlat_regional,nlon_regionalens,nlat_regionalens
real(r_kind) regional_fhr,regional_fmin
integer(i_kind) regional_time(6)
integer(i_kind) jcap_gfs,nlat_gfs,nlon_gfs
@@ -483,6 +487,8 @@ subroutine init_grid
update_regsfc = .false.
nlon_regional = 0
nlat_regional = 0
+ nlon_regionalens = 0
+ nlat_regionalens = 0
msig = nsig
do k=1,size(nlayers)
@@ -574,7 +580,7 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype)
integer(i_kind) n3d,n2d,nvars,tid,nth
integer(i_kind) ipsf,ipvp,jpsf,jpvp,isfb,isfe,ivpb,ivpe
integer(i_kind) istatus,icw,iql,iqi
- integer(i_kind) icw_cv,iql_cv,iqi_cv
+ integer(i_kind) icw_cv,iql_cv,iqi_cv,minmax
logical,allocatable,dimension(:):: vector
logical print_verbose
@@ -687,6 +693,8 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype)
periodic=grd_a%periodic
+ minmype=0
+ minmax=grd_a%ilat1(1)*grd_a%jlon1(1)
do i=1,npe
istart(i) =grd_a%istart(i)
jstart(i) =grd_a%jstart(i)
@@ -699,7 +707,12 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype)
displs_s(i) =grd_a%displs_s(i)
ijn(i) =grd_a%ijn(i)
displs_g(i) =grd_a%displs_g(i)
+ if(grd_a%ilat1(i)*grd_a%jlon1(i)< minmax)then
+ minmax=grd_a%ilat1(i)*grd_a%jlon1(i)
+ minmype=i-1
+ end if
end do
+ if(mype == minmype) write(6,*) ' minmype = ',minmype
!#omp parallel private(nth,tid)
nth = omp_get_max_threads()
diff --git a/src/gsi/gsd_update_mod.f90 b/src/gsi/gsd_update_mod.f90
index 7b43f55fb2..35f7663322 100644
--- a/src/gsi/gsd_update_mod.f90
+++ b/src/gsi/gsd_update_mod.f90
@@ -699,7 +699,7 @@ subroutine gsd_gen_coast_prox
nip = nip+1
end do
end do
- hcoast_prox(1,i,j) = float(nco)/float (nip)
+ hcoast_prox(1,i,j) = real(nco,r_kind)/real(nip,r_kind)
end if
end do
end do
diff --git a/src/gsi/gsdcloudanalysis.F90 b/src/gsi/gsdcloudanalysis.F90
index 21fc21b8a2..6df710cf32 100644
--- a/src/gsi/gsdcloudanalysis.F90
+++ b/src/gsi/gsdcloudanalysis.F90
@@ -65,7 +65,7 @@ subroutine gsdcloudanalysis(mype)
!
!
use constants, only: zero,one,rad2deg,fv
- use constants, only: rd_over_cp, h1000
+ use constants, only: rd_over_cp,h1000
use kinds, only: r_single,i_kind, r_kind
use gridmod, only: pt_ll,eta1_ll,aeta1_ll,eta2_ll,aeta2_ll
use gridmod, only: regional,wrf_mass_regional,regional_time
diff --git a/src/gsi/gsdcloudlib_pseudoq_mod.f90 b/src/gsi/gsdcloudlib_pseudoq_mod.f90
index b7544a860c..3b04558da7 100644
--- a/src/gsi/gsdcloudlib_pseudoq_mod.f90
+++ b/src/gsi/gsdcloudlib_pseudoq_mod.f90
@@ -192,9 +192,9 @@ SUBROUTINE cloudCover_Surface_col(mype,nsig, &
endif
! convert cloud base observation from AGL to ASL
- cl_base_ista = float(ocld(6+ic)) + Oelvtn - zh
+ cl_base_ista = real(ocld(6+ic),r_kind) + Oelvtn - zh
if(zh < 1.0_r_kind .and. Oelvtn > 20.0_r_kind &
- .and. float(ocld(6+ic)) < 250.0_r_kind) then
+ .and. real(ocld(6+ic),r_kind) < 250.0_r_kind) then
cycle ! limit the use of METAR station over oceas for low cloud base
endif
@@ -267,7 +267,7 @@ SUBROUTINE cloudCover_Surface_col(mype,nsig, &
! -- Use visibility for low-level cloud whether
if (wthr_type < 30 .and. wthr_type > 20 .and. &
ocld(13) < 5000 .and. ocld(13) > 1 ) then
- betav = 3.912_r_kind / (float(ocld(13)) / 1000._r_kind)
+ betav = 3.912_r_kind / (real(ocld(13),r_kind) / 1000._r_kind)
vis2qc = ( (betav/144.7_r_kind) ** 1.14_r_kind) / 1000._r_kind
endif ! cloud or clear
diff --git a/src/gsi/gsi_dbzOper.F90 b/src/gsi/gsi_dbzOper.F90
index 74d9bdf65d..4a63d0995f 100644
--- a/src/gsi/gsi_dbzOper.F90
+++ b/src/gsi/gsi_dbzOper.F90
@@ -83,6 +83,10 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass)
use jfunc , only: jiter
use mpeu_util, only: die
+
+ use directDA_radaruse_mod, only: l_use_dbz_directDA
+ use obsmod, only: dirname, ianldate
+
implicit none
class(dbzOper ), intent(inout):: self
integer(i_kind), intent(in):: lunin
@@ -99,8 +103,25 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass)
character(len=len_isis ):: isis
integer(i_kind):: nreal,nchanl,ier,nele
logical:: diagsave
+ integer(i_kind):: lu_diag
+ character(128):: diag_file
+ character(80):: string
+
+ if(nobs == 0) then
- if(nobs == 0) return
+ if( (mype == 0) .and. init_pass .and. (.not. l_use_dbz_directDA) ) then
+ write(string,600) jiter
+600 format('radardbz_',i2.2)
+ diag_file=trim(dirname) // trim(string)
+ write(6,*) 'write ianldate to ', diag_file
+ open(newunit=lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind')
+ write(lu_diag) ianldate
+ close(lu_diag)
+ endif
+
+ return
+
+ endif
read(lunin,iostat=ier) obstype,isis,nreal,nchanl
if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier)
diff --git a/src/gsi/gsi_fedOper.F90 b/src/gsi/gsi_fedOper.F90
new file mode 100644
index 0000000000..e704a1c056
--- /dev/null
+++ b/src/gsi/gsi_fedOper.F90
@@ -0,0 +1,184 @@
+module gsi_fedOper
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: module gsi_fedOper
+!
+! abstract: an obOper extension for fedNode type
+!
+! program history log:
+! 2023-07-10 D. Dowell - created new module for FED (flash extent
+! density); gsi_dbzOper.F90 code used as a
+! starting point for developing this new module
+! 2023-08-24 H. Wang - Turned on intfed and stpfed
+!
+! input argument list: see Fortran 90 style document below
+!
+! output argument list: see Fortran 90 style document below
+!
+! attributes:
+! language: Fortran 90 and/or above
+! machine:
+!
+!$$$ end subprogram documentation block
+
+! module interface:
+
+ use gsi_obOper, only: obOper
+ use m_fedNode , only: fedNode
+ implicit none
+ public:: fedOper ! data structure
+ public:: diag_fed
+
+ type,extends(obOper):: fedOper
+ contains
+ procedure,nopass:: mytype
+ procedure,nopass:: nodeMold
+ procedure:: setup_
+ procedure:: intjo1_
+ procedure:: stpjo1_
+ end type fedOper
+
+! def diag_fed- namelist logical to compute/write (=true) FED diag files
+ logical,save:: diag_fed=.false.
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ character(len=*),parameter :: myname='gsi_fedOper'
+ type(fedNode),save,target:: myNodeMold_
+
+contains
+ function mytype(nodetype)
+ implicit none
+ character(len=:),allocatable:: mytype
+ logical,optional, intent(in):: nodetype
+ mytype="[fedOper]"
+ if(present(nodetype)) then
+ if(nodetype) mytype=myNodeMold_%mytype()
+ endif
+ end function mytype
+
+ function nodeMold()
+ !> %nodeMold() returns a mold of its corresponding obsNode
+ use m_obsNode, only: obsNode
+ implicit none
+ class(obsNode),pointer:: nodeMold
+ nodeMold => myNodeMold_
+ end function nodeMold
+
+ subroutine setup_(self, lunin, mype, is, nobs, init_pass, last_pass)
+ use fed_setup, only: setup
+ use kinds, only: i_kind
+ use gsi_obOper, only: len_obstype
+ use gsi_obOper, only: len_isis
+
+ use m_rhs , only: awork => rhs_awork
+ use m_rhs , only: bwork => rhs_bwork
+ use m_rhs , only: iwork => i_fed
+
+ use obsmod , only: write_diag
+ use jfunc , only: jiter
+
+ use mpeu_util, only: die
+
+ use obsmod, only: dirname, ianldate
+
+ implicit none
+ class(fedOper ), intent(inout):: self
+ integer(i_kind), intent(in):: lunin
+ integer(i_kind), intent(in):: mype
+ integer(i_kind), intent(in):: is
+ integer(i_kind), intent(in):: nobs
+ logical , intent(in):: init_pass ! supporting multi-pass setup()
+ logical , intent(in):: last_pass ! with incremental backgrounds.
+
+ !----------------------------------------
+ character(len=*),parameter:: myname_=myname//"::setup_"
+
+ character(len=len_obstype):: obstype
+ character(len=len_isis ):: isis
+ integer(i_kind):: nreal,nchanl,ier,nele
+ logical:: diagsave
+ integer(i_kind):: lu_diag
+ character(128):: diag_file
+ character(80):: string
+
+ if(nobs == 0) then
+
+ if( (mype == 0) .and. init_pass ) then
+ write(string,600) jiter
+600 format('fed_',i2.2)
+ diag_file=trim(dirname) // trim(string)
+ write(6,*) 'write ianldate to ', diag_file
+ open(newunit=lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind')
+ write(lu_diag) ianldate
+ close(lu_diag)
+ endif
+
+ return
+
+ endif
+
+ read(lunin,iostat=ier) obstype,isis,nreal,nchanl
+ if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier)
+ nele = nreal+nchanl
+
+ diagsave = write_diag(jiter) .and. diag_fed
+
+ call setup(self%obsLL(:), self%odiagLL(:), &
+ lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave,init_pass)
+
+ end subroutine setup_
+
+ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias)
+ use intfedmod, only: intjo => intfed
+ use gsi_bundlemod , only: gsi_bundle
+ use bias_predictors, only: predictors
+ use m_obsNode , only: obsNode
+ use m_obsLList, only: obsLList_headNode
+ use kinds , only: i_kind, r_quad
+ implicit none
+ class(fedOper ),intent(in ):: self
+ integer(i_kind ),intent(in ):: ibin
+ type(gsi_bundle),intent(inout):: rval ! (ibin)
+ type(gsi_bundle),intent(in ):: sval ! (ibin)
+ real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin)
+ type(predictors),target, intent(in ):: sbias
+
+ !----------------------------------------
+ character(len=*),parameter:: myname_=myname//"::intjo1_"
+ class(obsNode),pointer:: headNode
+
+ headNode => obsLList_headNode(self%obsLL(ibin))
+ call intjo(headNode, rval,sval)
+ headNode => null()
+
+ end subroutine intjo1_
+
+ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias)
+ use stpfedmod, only: stpjo => stpfed
+ use gsi_bundlemod, only: gsi_bundle
+ use bias_predictors, only: predictors
+ use m_obsNode , only: obsNode
+ use m_obsLList, only: obsLList_headNode
+ use kinds, only: r_quad,r_kind,i_kind
+ implicit none
+ class(fedOper ),intent(in):: self
+ integer(i_kind ),intent(in):: ibin
+ type(gsi_bundle),intent(in):: dval
+ type(gsi_bundle),intent(in):: xval
+ real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4)
+ real(r_kind ),dimension(:),intent(in ):: sges
+ integer(i_kind),intent(in):: nstep
+
+ type(predictors),target, intent(in):: dbias
+ type(predictors),target, intent(in):: xbias
+
+ !----------------------------------------
+ character(len=*),parameter:: myname_=myname//"::stpjo1_"
+ class(obsNode),pointer:: headNode
+
+ headNode => obsLList_headNode(self%obsLL(ibin))
+ call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep)
+ headNode => null()
+ end subroutine stpjo1_
+
+end module gsi_fedOper
diff --git a/src/gsi/gsi_files.cmake b/src/gsi/gsi_files.cmake
index 461b49ddf6..95d885e2ee 100644
--- a/src/gsi/gsi_files.cmake
+++ b/src/gsi/gsi_files.cmake
@@ -87,6 +87,7 @@ anisofilter_glb.f90
antcorr_application.f90
antest_maps0.f90
antest_maps0_glb.f90
+apply_scaledepwgts.f90
atms_spatial_average_mod.f90
balmod.f90
berror.f90
@@ -100,6 +101,7 @@ bkgvar_rewgt.f90
blacklist.f90
blendmod.f90
buddycheck_mod.f90
+cads.f90
calc_fov_conical.f90
calc_fov_crosstrk.f90
calctends.f90
@@ -123,7 +125,6 @@ constants.f90
control2model.f90
control2model_ad.f90
control2state.f90
-control2state_ad.f90
control_vectors.f90
convb_ps.f90
convb_q.f90
@@ -156,7 +157,6 @@ ens_spread_mod.f90
ensctl2model.f90
ensctl2model_ad.f90
ensctl2state.f90
-ensctl2state_ad.f90
evaljgrad.f90
evaljo.f90
evalqlim.f90
@@ -217,6 +217,7 @@ gsi_colvkOper.F90
gsi_dbzOper.F90
gsi_dwOper.F90
gsi_enscouplermod.f90
+gsi_fedOper.F90
gsi_gpsbendOper.F90
gsi_gpsrefOper.F90
gsi_gustOper.F90
@@ -273,6 +274,7 @@ intaod.f90
intcldch.f90
intco.f90
intdbz.f90
+intfed.f90
intdw.f90
intgps.f90
intgust.f90
@@ -338,6 +340,7 @@ m_distance.f90
m_dtime.F90
m_dwNode.F90
m_extOzone.F90
+m_fedNode.F90
m_find.f90
m_gpsNode.F90
m_gpsrhs.F90
@@ -478,6 +481,7 @@ read_cris.f90
read_dbz_nc.f90
read_dbz_netcdf.f90
read_diag.f90
+read_fed.f90
read_files.f90
read_fl_hdob.f90
read_gfs_ozone_for_regional.f90
@@ -532,6 +536,7 @@ setupco.f90
setupdbz.f90
setupdbz_lib.f90
setupdw.f90
+setupfed.f90
setupgust.f90
setuphowv.f90
setuplag.f90
@@ -590,6 +595,7 @@ stpcalc.f90
stpcldch.f90
stpco.f90
stpdbz.f90
+stpfed.f90
stpdw.f90
stpgps.f90
stpgust.f90
diff --git a/src/gsi/gsi_obOperTypeManager.F90 b/src/gsi/gsi_obOperTypeManager.F90
index ea306953c4..6db7921905 100644
--- a/src/gsi/gsi_obOperTypeManager.F90
+++ b/src/gsi/gsi_obOperTypeManager.F90
@@ -66,6 +66,7 @@ module gsi_obOperTypeManager
use gsi_lightOper , only: lightOper
use gsi_dbzOper , only: dbzOper
+ use gsi_fedOper , only: fedOper
use gsi_cldtotOper , only: cldtotOper
use kinds , only: i_kind
@@ -136,6 +137,7 @@ module gsi_obOperTypeManager
public:: iobOper_lwcp
public:: iobOper_light
public:: iobOper_dbz
+ public:: iobOper_fed
public:: iobOper_cldtot
enum, bind(C)
@@ -181,6 +183,7 @@ module gsi_obOperTypeManager
enumerator:: iobOper_lwcp
enumerator:: iobOper_light
enumerator:: iobOper_dbz
+ enumerator:: iobOper_fed
enumerator:: iobOper_cldtot
enumerator:: iobOper_extra_
@@ -242,6 +245,7 @@ module gsi_obOperTypeManager
type( lwcpOper), target, save:: lwcpOper_mold
type( lightOper), target, save:: lightOper_mold
type( dbzOper), target, save:: dbzOper_mold
+ type( fedOper), target, save:: fedOper_mold
type( cldtotOper), target, save:: cldtotOper_mold
contains
@@ -276,6 +280,9 @@ function dtype2index_(dtype) result(index_)
case("ompstc8"); index_= iobOper_oz
case("ompsnp" ); index_= iobOper_oz
case("ompsnm" ); index_= iobOper_oz
+ case("omieff" ); index_= iobOper_oz
+ case("tomseff" ); index_= iobOper_oz
+ case("ompsnmeff"); index_= iobOper_oz
case("o3l" ,"[o3loper]" ); index_= iobOper_o3l
case("o3lev" ); index_= iobOper_o3l
@@ -283,11 +290,10 @@ function dtype2index_(dtype) result(index_)
case("mls22" ); index_= iobOper_o3l
case("mls30" ); index_= iobOper_o3l
case("mls55" ); index_= iobOper_o3l
- case("omieff" ); index_= iobOper_o3l
- case("tomseff" ); index_= iobOper_o3l
+ case("ompslp" ); index_= iobOper_o3l
case("ompslpuv" ); index_= iobOper_o3l
case("ompslpvis"); index_= iobOper_o3l
- case("ompslp" ); index_= iobOper_o3l
+ case("ompslpnc" ); index_= iobOper_o3l
case("gpsbend","[gpsbendoper]"); index_= iobOper_gpsbend
case("gps_bnd"); index_= iobOper_gpsbend
@@ -388,6 +394,7 @@ function dtype2index_(dtype) result(index_)
case("goes_glm" ); index_= iobOper_light
case("dbz" ,"[dbzoper]" ); index_= iobOper_dbz
+ case("fed" ,"[fedoper]" ); index_= iobOper_fed
case("cldtot" ,"[cldtotoper]" ); index_= iobOper_cldtot
case("mta_cld" ); index_= iobOper_cldtot
@@ -485,6 +492,7 @@ function index2vmold_(iobOper) result(vmold_)
case(iobOper_lwcp ); vmold_ => lwcpOper_mold
case(iobOper_light ); vmold_ => lightOper_mold
case(iobOper_dbz ); vmold_ => dbzOper_mold
+ case(iobOper_fed ); vmold_ => fedOper_mold
case(iobOper_cldtot ); vmold_ => cldtotOper_mold
case( obOper_undef ); vmold_ => null()
@@ -600,6 +608,7 @@ subroutine cobstype_config_()
cobstype(iobOper_lwcp ) ="lwcp " ! lwcp_ob_type
cobstype(iobOper_light ) ="light " ! light_ob_type
cobstype(iobOper_dbz ) ="dbz " ! dbz_ob_type
+ cobstype(iobOper_fed ) ="fed " ! fed_ob_type
cobstype(iobOper_cldtot ) ="cldtot " ! using q_ob_type
cobstype_configured_=.true.
diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90
index eb7a86160f..8e1c3ab98f 100644
--- a/src/gsi/gsi_rfv3io_mod.f90
+++ b/src/gsi/gsi_rfv3io_mod.f90
@@ -18,13 +18,18 @@ module gsi_rfv3io_mod
! This function is needed when fv3 model sets
! io_layout(2)>1
! 2022-02-15 Lu @ Wang - add time label it for FGAT. POC: xuguang.wang@ou.edu
+! 2022-03-01 X.Lu @ X.Wang - add gsi_rfv3io_get_ens_grid_specs for dual ens HAFS. POC: xuguang.wang@ou.edu
! 2022-03-15 Hu - add code to read/write 2m T and Q for they will be
! used as background for surface observation operator
! 2022-04-15 Wang - add IO for regional FV3-CMAQ (RRFS-CMAQ) model
! 2022-08-10 Wang - add IO for regional FV3-SMOKE (RRFS-SMOKE) model
+! 2023-07-30 Zhao - add IO for the analysis of the significant wave height
+! (SWH, aka howv in GSI) in fv3-lam based DA (eg., RRFS-3DRTMA)
+! 2024-01-24 X.Zhang - bug fix for reading the soil temp and mois from the wram start file
!
! subroutines included:
! sub gsi_rfv3io_get_grid_specs
+! sub gsi_rfv3io_get_ens_grid_specs
! sub read_fv3_files
! sub read_fv3_netcdf_guess
! sub gsi_fv3ncdf2d_read
@@ -47,8 +52,8 @@ module gsi_rfv3io_mod
!$$$ end documentation block
use kinds, only: r_kind,i_kind
- use gridmod, only: nlon_regional,nlat_regional
- use constants, only:max_varname_length
+ use gridmod, only: nlon_regional,nlat_regional,nlon_regionalens,nlat_regionalens
+ use constants, only:max_varname_length,max_filename_length
use gsi_bundlemod, only : gsi_bundle
use general_sub2grid_mod, only: sub2grid_info
use gridmod, only: fv3_io_layout_y
@@ -56,6 +61,7 @@ module gsi_rfv3io_mod
use rapidrefresh_cldsurf_mod, only: i_use_2mq4b,i_use_2mt4b
use chemmod, only: naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,laeroana_fv3cmaq
use chemmod, only: naero_smoke_fv3,aeronames_smoke_fv3,laeroana_fv3smoke
+ use rapidrefresh_cldsurf_mod, only: i_howv_3dda, i_gust_3dda
implicit none
public type_fv3regfilenameg
@@ -68,6 +74,7 @@ module gsi_rfv3io_mod
character(len=:),allocatable :: ak_bk !='fv3_akbk'
character(len=:),allocatable :: dynvars !='fv3_dynvars'
character(len=:),allocatable :: tracers !='fv3_tracer'
+ character(len=:),allocatable :: phyvars !='fv3_phyvars'
character(len=:),allocatable :: sfcdata !='fv3_sfcdata'
character(len=:),allocatable :: couplerres!='coupler.res'
contains
@@ -78,7 +85,9 @@ module gsi_rfv3io_mod
type(type_fv3regfilenameg),allocatable:: bg_fv3regfilenameg(:)
integer(i_kind) nx,ny,nz
+ integer(i_kind) nxens,nyens
integer(i_kind),dimension(:),allocatable :: ny_layout_len,ny_layout_b,ny_layout_e
+ integer(i_kind),dimension(:),allocatable :: ny_layout_lenens,ny_layout_bens,ny_layout_eens
real(r_kind),allocatable:: grid_lon(:,:),grid_lont(:,:),grid_lat(:,:),grid_latt(:,:)
real(r_kind),allocatable:: ak(:),bk(:)
integer(i_kind),allocatable:: ijns2d(:),displss2d(:),ijns(:),displss(:)
@@ -91,8 +100,9 @@ module gsi_rfv3io_mod
type(sub2grid_info) :: grd_fv3lam_tracer_ionouv
type(sub2grid_info) :: grd_fv3lam_tracerchem_ionouv
type(sub2grid_info) :: grd_fv3lam_tracersmoke_ionouv
+ type(sub2grid_info) :: grd_fv3lam_phyvar_ionouv
type(sub2grid_info) :: grd_fv3lam_uv
- integer(i_kind) ,parameter:: ndynvarslist=13, ntracerslist=8
+ integer(i_kind) ,parameter:: ndynvarslist=13, ntracerslist=8, nphyvarslist=2
character(len=max_varname_length), dimension(ndynvarslist), parameter :: &
vardynvars = [character(len=max_varname_length) :: &
@@ -100,13 +110,20 @@ module gsi_rfv3io_mod
character(len=max_varname_length), dimension(ntracerslist+naero_cmaq_fv3+7+naero_smoke_fv3), parameter :: &
vartracers = [character(len=max_varname_length) :: &
'q','oz','ql','qi','qr','qs','qg','qnr',aeronames_cmaq_fv3,'pm25at','pm25ac','pm25co','pm2_5','amassi','amassj','amassk',aeronames_smoke_fv3]
- character(len=max_varname_length), dimension(15+naero_cmaq_fv3+7+naero_smoke_fv3), parameter :: &
+ character(len=max_varname_length), dimension(nphyvarslist), parameter :: &
+ varphyvars = [character(len=max_varname_length) :: 'dbz','fed']
+ character(len=max_varname_length), dimension(16+naero_cmaq_fv3+7+naero_smoke_fv3+1), parameter :: &
varfv3name = [character(len=max_varname_length) :: &
- 'u','v','W','T','delp','sphum','o3mr','liq_wat','ice_wat','rainwat','snowwat','graupel','rain_nc','ps','DZ', &
+ 'u','v','W','T','delp','sphum','o3mr','liq_wat','ice_wat','rainwat','snowwat','graupel','rain_nc','ref_f3d','flash_extent_density','ps','DZ', &
aeronames_cmaq_fv3,'pm25at','pm25ac','pm25co','pm2_5','amassi','amassj','amassk',aeronames_smoke_fv3], &
vgsiname = [character(len=max_varname_length) :: &
- 'u','v','w','tsen','delp','q','oz','ql','qi','qr','qs','qg','qnr','ps','delzinc', &
+ 'u','v','w','tsen','delp','q','oz','ql','qi','qr','qs','qg','qnr','dbz','fed','ps','delzinc', &
aeronames_cmaq_fv3,'pm25at','pm25ac','pm25co','pm2_5','amassi','amassj','amassk',aeronames_smoke_fv3]
+
+ integer(i_kind) ,parameter:: nnonnegtracer=7
+ character(len=max_varname_length), dimension(nnonnegtracer), parameter :: &
+ vnames_nonnegativetracers = [character(len=max_varname_length) :: &
+ "sphum","o3mr","liq_wat","ice_wat","rainwat","snowwat","graupel"]
character(len=max_varname_length),dimension(:),allocatable:: name_metvars2d
character(len=max_varname_length),dimension(:),allocatable:: name_metvars3d
character(len=max_varname_length),dimension(:),allocatable:: name_chemvars3d
@@ -115,10 +132,13 @@ module gsi_rfv3io_mod
private
! set subroutines to public
public :: gsi_rfv3io_get_grid_specs
+ public :: gsi_rfv3io_get_ens_grid_specs
public :: gsi_fv3ncdf_read
public :: gsi_fv3ncdf_read_v1
public :: gsi_fv3ncdf_readuv
public :: gsi_fv3ncdf_readuv_v1
+ public :: gsi_fv3ncdf_read_ens_parallel_over_ens
+ public :: gsi_fv3ncdf_readuv_ens_parallel_over_ens
public :: read_fv3_files
public :: read_fv3_netcdf_guess
public :: wrfv3_netcdf
@@ -127,17 +147,18 @@ module gsi_rfv3io_mod
public :: mype_u,mype_v,mype_t,mype_q,mype_p,mype_oz,mype_ql
public :: mype_qi,mype_qr,mype_qs,mype_qg,mype_qnr,mype_w
public :: k_slmsk,k_tsea,k_vfrac,k_vtype,k_stype,k_zorl,k_smc,k_stc
- public :: k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m
+ public :: k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv,k_gust
public :: ijns,ijns2d,displss,displss2d,ijnz,displsz_g
public :: fv3lam_io_dynmetvars3d_nouv,fv3lam_io_tracermetvars3d_nouv
public :: fv3lam_io_tracerchemvars3d_nouv,fv3lam_io_tracersmokevars3d_nouv
+ public :: fv3lam_io_phymetvars3d_nouv
public :: fv3lam_io_dynmetvars2d_nouv,fv3lam_io_tracermetvars2d_nouv
integer(i_kind) mype_u,mype_v,mype_t,mype_q,mype_p,mype_delz,mype_oz,mype_ql
integer(i_kind) mype_qi,mype_qr,mype_qs,mype_qg,mype_qnr,mype_w
integer(i_kind) k_slmsk,k_tsea,k_vfrac,k_vtype,k_stype,k_zorl,k_smc,k_stc
- integer(i_kind) k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m
+ integer(i_kind) k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv,k_gust
parameter( &
k_f10m =1, & !fact10
k_stype=2, & !soil_type
@@ -152,12 +173,15 @@ module gsi_rfv3io_mod
k_t2m =11, & ! 2 m T
k_q2m =12, & ! 2 m Q
k_orog =13, & !terrain
- n2d=13 )
+ k_howv =14, & ! significant wave height (aka howv in GSI)
+ k_gust =15, & ! wind gust (aka gust in GSI)
+ n2d=15 )
logical :: grid_reverse_flag
character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_dynmetvars3d_nouv
! copy of cvars3d excluding uv 3-d fields
character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_tracermetvars3d_nouv
! copy of cvars3d excluding uv 3-d fields
+ character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_phymetvars3d_nouv
character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_tracerchemvars3d_nouv
character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_tracersmokevars3d_nouv
! copy of cvars3d excluding uv 3-d fields
@@ -169,17 +193,21 @@ module gsi_rfv3io_mod
!to define names in gsibundle
character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_names_gsibundle_tracer_nouv
!to define names in gsibundle
+ character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_names_gsibundle_phyvar_nouv
type(gsi_bundle):: gsibundle_fv3lam_dynvar_nouv
type(gsi_bundle):: gsibundle_fv3lam_tracer_nouv
+ type(gsi_bundle):: gsibundle_fv3lam_phyvar_nouv
type(gsi_bundle):: gsibundle_fv3lam_tracerchem_nouv
type(gsi_bundle):: gsibundle_fv3lam_tracersmoke_nouv
contains
subroutine fv3regfilename_init(this,it)
implicit None
+
class(type_fv3regfilenameg),intent(inout):: this
+ integer(i_kind), intent(in ) :: it
+
character(255):: filename
- integer(i_kind),intent(in) :: it
if (it == ntguessig) then
this%grid_spec='fv3_grid_spec'
else
@@ -204,6 +232,12 @@ subroutine fv3regfilename_init(this,it)
write(filename,"(A11,I2.2)") 'fv3_tracer_',ifilesig(it)
this%tracers=trim(filename)
endif
+ if (it == ntguessig) then
+ this%phyvars='fv3_phyvars'
+ else
+ write(filename,"(A12,I2.2)") 'fv3_phyvars_',ifilesig(it)
+ this%phyvars=trim(filename)
+ endif
if (it == ntguessig) then
this%sfcdata='fv3_sfcdata'
else
@@ -263,11 +297,12 @@ subroutine gsi_rfv3io_get_grid_specs(ierr)
use mpimod, only: mpi_comm_world,mpi_itype,mpi_rtype
implicit none
+ integer(i_kind),intent( out) :: ierr
+
integer(i_kind) gfile_grid_spec
character(:),allocatable :: grid_spec
character(:),allocatable :: ak_bk
character(len=:),allocatable :: coupler_res_filenam
- integer(i_kind),intent( out) :: ierr
integer(i_kind) i,k,ndimensions,iret,nvariables,nattributes,unlimiteddimid
integer(i_kind) len,gfile_loc
character(len=max_varname_length) :: name
@@ -480,6 +515,164 @@ subroutine gsi_rfv3io_get_grid_specs(ierr)
return
end subroutine gsi_rfv3io_get_grid_specs
+subroutine gsi_rfv3io_get_ens_grid_specs(grid_spec,ierr)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: gsi_rfv3io_get_ens_grid_specs
+! modified from gsi_rfv3io_get_grid_specs
+! pgrmmr: parrish org: np22 date: 2017-04-03
+!
+! abstract: obtain grid dimensions nx,ny and grid definitions
+! grid_x,grid_xt,grid_y,grid_yt,grid_lon,grid_lont,grid_lat,grid_latt
+! nz,ak(nz),bk(nz)
+!
+! program history log:
+! 2017-04-03 parrish - initial documentation
+! 2017-10-10 wu - setup A grid and interpolation coeff with generate_anl_grid
+! 2018-02-16 wu - read in time info from file coupler.res
+! read in lat, lon at the center and corner of the grid cell
+! from file fv3_grid_spec, and vertical grid infor from file
+! fv3_akbk
+! setup A grid and interpolation/rotation coeff
+! input argument list:
+! grid_spec
+! ak_bk
+! lendian_out
+!
+! output argument list:
+! ierr
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+ use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr
+ use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension
+ use netcdf, only: nf90_inquire_variable
+ use mpimod, only: mype
+ use mod_fv3_lola, only: definecoef_regular_grids
+ use gridmod, only:nlon_regionalens,nlat_regionalens
+ use gridmod, only:grid_type_fv3_regional
+ use kinds, only: i_kind,r_kind
+ use constants, only: half,zero
+ use mpimod, only: mpi_comm_world,mpi_itype,mpi_rtype
+ implicit none
+ character(:),allocatable,intent(in ) :: grid_spec
+ integer(i_kind), intent( out) :: ierr
+
+ integer(i_kind) gfile_grid_spec
+ integer(i_kind) k,ndimensions,iret,nvariables,nattributes,unlimiteddimid
+ integer(i_kind) gfile_loc,len
+ character(len=128) :: name
+ integer(i_kind) :: nio,nylen
+ integer(i_kind),allocatable :: gfile_loc_layout(:)
+ character(len=180) :: filename_layout
+ integer(i_kind) imiddle,jmiddle,grid_ens_type_fv3_regional
+
+
+ iret=nf90_open(trim(grid_spec),nf90_nowrite,gfile_grid_spec)
+ if(iret/=nf90_noerr) then
+ write(6,*)' problem opening1 ',trim(grid_spec),', Status = ',iret
+ ierr=1
+ return
+ endif
+ iret=nf90_inquire(gfile_grid_spec,ndimensions,nvariables,nattributes,unlimiteddimid)
+ gfile_loc=gfile_grid_spec
+ do k=1,ndimensions
+ iret=nf90_inquire_dimension(gfile_loc,k,name,len)
+ if(trim(name)=='grid_xt') nxens=len
+ if(trim(name)=='grid_yt') nyens=len
+ enddo
+ allocate(grid_lat(nxens+1,nyens+1))
+ allocate(grid_lon(nxens+1,nyens+1))
+ allocate(grid_latt(nxens,nyens))
+ allocate(grid_lont(nxens,nyens))
+ do k=ndimensions+1,nvariables
+ iret=nf90_inquire_variable(gfile_loc,k,name,len)
+ if(trim(name)=='grid_lat') then
+ iret=nf90_get_var(gfile_loc,k,grid_lat)
+ endif
+ if(trim(name)=='grid_lon') then
+ iret=nf90_get_var(gfile_loc,k,grid_lon)
+ endif
+ if(trim(name)=='grid_latt') then
+ iret=nf90_get_var(gfile_loc,k,grid_latt)
+ endif
+ if(trim(name)=='grid_lont') then
+ iret=nf90_get_var(gfile_loc,k,grid_lont)
+ endif
+ enddo
+ iret=nf90_close(gfile_loc)
+
+ nlon_regionalens=nxens
+ nlat_regionalens=nyens
+ allocate(ny_layout_lenens(0:fv3_io_layout_y-1))
+ allocate(ny_layout_bens(0:fv3_io_layout_y-1))
+ allocate(ny_layout_eens(0:fv3_io_layout_y-1))
+ ny_layout_lenens=nyens
+ ny_layout_bens=0
+ ny_layout_eens=0
+ if(fv3_io_layout_y > 1) then
+ allocate(gfile_loc_layout(0:fv3_io_layout_y-1))
+ do nio=0,fv3_io_layout_y-1
+ write(filename_layout,'(a,a,I4.4)') trim(grid_spec),'.',nio
+ iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio))
+ if(iret/=nf90_noerr) then
+ write(6,*)' problem opening ',trim(filename_layout),', Status =',iret
+ ierr=1
+ return
+ endif
+ iret=nf90_inquire(gfile_loc_layout(nio),ndimensions,nvariables,nattributes,unlimiteddimid)
+ do k=1,ndimensions
+ iret=nf90_inquire_dimension(gfile_loc_layout(nio),k,name,len)
+ if(trim(name)=='grid_yt') ny_layout_lenens(nio)=len
+ enddo
+ iret=nf90_close(gfile_loc_layout(nio))
+ enddo
+ deallocate(gfile_loc_layout)
+! figure out begin and end of each subdomain restart file
+ nylen=0
+ do nio=0,fv3_io_layout_y-1
+ ny_layout_bens(nio)=nylen + 1
+ nylen=nylen+ny_layout_lenens(nio)
+ ny_layout_eens(nio)=nylen
+ enddo
+ endif
+ if(mype==0)write(6,*),'nxens,nyens=',nxens,nyens
+ if(mype==0)write(6,*),'ny_layout_lenens=',ny_layout_lenens
+ if(mype==0)write(6,*),'ny_layout_bens=',ny_layout_bens
+ if(mype==0)write(6,*),'ny_layout_eens=',ny_layout_eens
+
+ imiddle=nxens/2
+ jmiddle=nyens/2
+ if( (grid_latt(imiddle,1) < grid_latt(imiddle,nyens)) .and. &
+ (grid_lont(1,jmiddle) < grid_lont(nxens,jmiddle)) ) then
+ grid_ens_type_fv3_regional = 2
+ else
+ grid_ens_type_fv3_regional = 1
+ endif
+! check the grid type
+ if( grid_type_fv3_regional == grid_ens_type_fv3_regional ) then
+ if(mype==0) write(6,*) 'Ensemble has the same orientation as the control, Cool!'
+ else
+ write(6,*) 'Warning! Ensemble has a different orientation as the control. This case needs further tests, Abort!'
+ call stop2(678)
+ endif
+!
+ if(grid_type_fv3_regional == 2) then
+ call reverse_grid_r(grid_lont,nxens,nyens,1)
+ call reverse_grid_r(grid_latt,nxens,nyens,1)
+ call reverse_grid_r(grid_lon,nxens+1,nyens+1,1)
+ call reverse_grid_r(grid_lat,nxens+1,nyens+1,1)
+ endif
+
+ call definecoef_regular_grids(nxens,nyens,grid_lon,grid_lont,grid_lat,grid_latt)
+ deallocate (grid_lon,grid_lat,grid_lont,grid_latt)
+ return
+end subroutine gsi_rfv3io_get_ens_grid_specs
+
+
subroutine read_fv3_files(mype)
!$$$ subprogram documentation block
! . . . .
@@ -522,7 +715,7 @@ subroutine read_fv3_files(mype)
! Declare local variables
logical(4) fexist
character(6) filename
- character(14) filenames
+ character(19) filenames
integer(i_kind) in_unit
integer(i_kind) i,j,iwan,npem1
integer(i_kind) nhr_half
@@ -557,11 +750,19 @@ subroutine read_fv3_files(mype)
in_unit=15
iwan=0
!WWWWWW setup for one first guess file for now
- do i=0,9 !place holder for FGAT
+ do i=0,9 !place holder for FGAT
if ( i == 6 ) then
- write(filenames,"(A11)") 'fv3_dynvars'
+ if(fv3_io_layout_y > 1) then
+ write(filenames,"(A16)") 'fv3_dynvars.0000'
+ else
+ write(filenames,"(A11)") 'fv3_dynvars'
+ endif
else
- write(filenames,"(A12,I2.2)") 'fv3_dynvars_',i
+ if(fv3_io_layout_y > 1) then
+ write(filenames,"(A17,I2.2)") 'fv3_dynvars.0000_',i
+ else
+ write(filenames,"(A12,I2.2)") 'fv3_dynvars_',i
+ endif
endif
INQUIRE(FILE=filenames, EXIST=fexist)
if(.not.fexist) cycle
@@ -740,6 +941,11 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
!
! abstract: read guess for FV3 regional model
! program history log:
+! 2022-04-01 Y. Wang and X. Wang - add capability to read reflectivity
+! for direct radar EnVar DA using reflectivity as state
+! variable, poc: xuguang.wang@ou.edu
+! 2023-07-30 Zhao - added code to read significant wave height (howv) field
+! from the 2D fv3-lam firstguess file (fv3_sfcdata).
! attributes:
! language: f90
! machine: ibm RS/6000 SP
@@ -768,14 +974,16 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
use gsi_metguess_mod, only: gsi_metguess_get
use netcdf, only:nf90_open,nf90_close,nf90_inquire,nf90_nowrite, nf90_format_netcdf4
use gsi_chemguess_mod, only: gsi_chemguess_get
+ use obsmod, only: if_model_dbz,if_model_fed
implicit none
type (type_fv3regfilenameg),intent (in) :: fv3filenamegin(:)
+
integer(i_kind) :: it
character(len=24),parameter :: myname = 'read_fv3_netcdf_guess'
integer(i_kind) k,i,j
- integer(i_kind) ier,istatus
+ integer(i_kind) ier,istatus,ivar
real(r_kind),dimension(:,:),pointer::ges_ps=>NULL()
real(r_kind),dimension(:,:),pointer::ges_ps_readin=>NULL()
real(r_kind),dimension(:,:),pointer::ges_z=>NULL()
@@ -788,6 +996,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
real(r_kind),pointer,dimension(:,:,:):: ges_delp =>NULL()
real(r_kind),dimension(:,:),pointer::ges_t2m=>NULL()
real(r_kind),dimension(:,:),pointer::ges_q2m=>NULL()
+ real(r_kind),dimension(:,:),pointer::ges_howv=>NULL()
+ real(r_kind),dimension(:,:),pointer::ges_gust=>NULL()
real(r_kind),dimension(:,:,:),pointer::ges_ql=>NULL()
real(r_kind),dimension(:,:,:),pointer::ges_qi=>NULL()
@@ -797,7 +1007,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
real(r_kind),dimension(:,:,:),pointer::ges_qg=>NULL()
real(r_kind),dimension(:,:,:),pointer::ges_qnr=>NULL()
real(r_kind),dimension(:,:,:),pointer::ges_w=>NULL()
-
+ real(r_kind),dimension(:,:,:),pointer::ges_dbz=>NULL()
+ real(r_kind),dimension(:,:,:),pointer::ges_fed=>NULL()
real(r_kind),dimension(:,:,:),pointer::ges_aalj=>NULL()
real(r_kind),dimension(:,:,:),pointer::ges_acaj=>NULL()
@@ -890,8 +1101,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
integer(i_kind),dimension(:,:),allocatable:: lnames
integer(i_kind),dimension(:,:),allocatable:: uvlnames
integer(i_kind):: inner_vars,numfields
- integer(i_kind):: ndynvario2d,ntracerio2d,ilev,jdynvar,jtracer
- integer(i_kind):: iuv,ndynvario3d,ntracerio3d
+ integer(i_kind):: ndynvario2d,ntracerio2d,ilev,jdynvar,jtracer,jphyvar
+ integer(i_kind):: iuv,ndynvario3d,ntracerio3d,nphyvario3d
integer(i_kind):: ntracerchemio3d,ntracersmokeio3d
integer(i_kind):: loc_id,ncfmt
@@ -957,6 +1168,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
iuv=0
ndynvario3d=0
ntracerio3d=0
+ nphyvario3d=0
do i=1,size(name_metvars3d)
vartem=trim(name_metvars3d(i))
if(trim(vartem)=='u'.or.trim(vartem)=='v') then
@@ -967,6 +1179,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
ndynvario3d=ndynvario3d+1
else if (ifindstrloc(vartracers,trim(vartem))> 0) then
ntracerio3d=ntracerio3d+1
+ else if (ifindstrloc(varphyvars,trim(vartem))> 0) then
+ nphyvario3d=nphyvario3d+1
else
write(6,*)'the metvarname1 ',trim(vartem),' has not been considered yet, stop'
call stop2(333)
@@ -978,6 +1192,13 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
write(6,*)"the set up for met variable is not as expected, abort"
call stop2(222)
endif
+
+ ivar=0 ; if (if_model_dbz) ivar=ivar+1; if(if_model_fed) ivar=ivar+1
+ if ( ivar > nphyvario3d ) then
+ write(6,*)"the set up for met variable (dbz and fed in phyvar) is not as expected,abort"
+ call stop2(223)
+ end if
+
if (fv3sar_bg_opt == 0.and.ifindstrloc(name_metvars3d,'delp') <= 0)then
ndynvario3d=ndynvario3d+1 ! for delp
endif
@@ -987,6 +1208,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
if (l_reg_update_hydro_delz.and.fv3sar_bg_opt==0) ndynvario3d=ndynvario3d+1 ! for delzinc
allocate(fv3lam_io_dynmetvars3d_nouv(ndynvario3d))
allocate(fv3lam_io_tracermetvars3d_nouv(ntracerio3d))
+ allocate(fv3lam_io_phymetvars3d_nouv(nphyvario3d))
if (laeroana_fv3cmaq) then
allocate(fv3lam_io_tracerchemvars3d_nouv(naero_cmaq_fv3+7))
@@ -998,6 +1220,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
jdynvar=0
jtracer=0
+ jphyvar=0
do i=1,size(name_metvars3d)
vartem=trim(name_metvars3d(i))
if(.not.(trim(vartem)=='u'.or.trim(vartem)=='v'.or.trim(vartem)=='iqr')) then
@@ -1012,9 +1235,11 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
else if (ifindstrloc(vartracers,trim(vartem)) > 0) then
jtracer=jtracer+1
fv3lam_io_tracermetvars3d_nouv(jtracer)=trim(vartem)
+ else if (ifindstrloc(varphyvars,trim(vartem)) > 0) then
+ jphyvar=jphyvar+1
+ fv3lam_io_phymetvars3d_nouv(jphyvar)=trim(vartem)
else
write(6,*)'the metvarname ',vartem,' is not expected, stop'
- call flush(6)
call stop2(333)
endif
endif
@@ -1027,14 +1252,14 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
jdynvar=jdynvar+1
fv3lam_io_dynmetvars3d_nouv(jdynvar)="delzinc"
endif
- if(jdynvar /= ndynvario3d.or.jtracer /= ntracerio3d ) then
+ if(jdynvar /= ndynvario3d.or.jtracer /= ntracerio3d.or.jphyvar /= nphyvario3d ) then
write(6,*)'ndynvario3d is not as expected, stop'
- call flush(6)
call stop2(333)
endif
if(mype == 0) then
write(6,*) ' fv3lam_io_dynmetvars3d_nouv is ',(trim(fv3lam_io_dynmetvars3d_nouv(i)),i=1,ndynvario3d)
write(6,*) ' fv3lam_io_tracermevars3d_nouv is ',(trim(fv3lam_io_tracermetvars3d_nouv(i)),i=1,ntracerio3d)
+ write(6,*) ' fv3lam_io_phymetvars3d_nouv is ',(trim(fv3lam_io_phymetvars3d_nouv(i)),i=1,nphyvario3d)
endif
ndynvario2d=0
@@ -1047,9 +1272,11 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
else if (ifindstrloc(vartracers,trim(vartem)) > 0) then
ntracerio2d=ntracerio2d+1
else if(trim(vartem)=='z') then
- write(6,*)'the metvarname ',trim(vartem),' will be dealt separately'
+ if(mype == 0) write(6,*)'the metvarname ',trim(vartem),' will be dealt separately'
else if(trim(vartem)=='t2m') then
else if(trim(vartem)=='q2m') then
+ else if(trim(vartem)=='howv') then
+ else if(trim(vartem)=='gust') then
else
write(6,*)'the metvarname2 ',trim(vartem),' has not been considered yet, stop'
call stop2(333)
@@ -1057,7 +1284,9 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
endif
end do
if (ndynvario2d > 0) then
- allocate(fv3lam_io_dynmetvars2d_nouv(ndynvario2d))
+ if (.not. allocated(fv3lam_io_dynmetvars2d_nouv)) then
+ allocate(fv3lam_io_dynmetvars2d_nouv(ndynvario2d))
+ end if
endif
if (ntracerio2d > 0) then
allocate(fv3lam_io_tracermetvars2d_nouv(ntracerio2d))
@@ -1067,7 +1296,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
do i=1,size(name_metvars2d)
vartem=trim(name_metvars2d(i))
if(.not.( (trim(vartem)=='ps'.and.fv3sar_bg_opt==0).or.(trim(vartem)=="z") &
- .or.(trim(vartem)=="t2m").or.(trim(vartem)=="q2m"))) then !z is treated separately
+ .or.(trim(vartem)=="t2m").or.(trim(vartem)=="q2m") &
+ .or.(trim(vartem)=="howv").or.(trim(vartem)=="gust"))) then ! z is treated separately
if (ifindstrloc(vardynvars,trim(vartem)) > 0) then
jdynvar=jdynvar+1
fv3lam_io_dynmetvars2d_nouv(jdynvar)=trim(vartem)
@@ -1084,7 +1314,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
if (allocated(fv3lam_io_dynmetvars2d_nouv)) &
write(6,*)' fv3lam_io_dynmetvars2d_nouv is ',(trim(fv3lam_io_dynmetvars2d_nouv(i)), i=1,ndynvario2d)
if (allocated(fv3lam_io_tracermetvars2d_nouv))&
- write(6,*)'fv3lam_io_dynmetvars2d_nouv is ',(trim(fv3lam_io_dynmetvars2d_nouv(i)),i=1,ntracerio3d)
+ write(6,*)'fv3lam_io_tracermetvars2d_nouv is ',(trim(fv3lam_io_tracermetvars2d_nouv(i)),i=1,ntracerio2d)
endif
if (laeroana_fv3cmaq) then
@@ -1132,7 +1362,6 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
else
if (trim(vartem) /= "pm2_5")then
write(6,*)'the chemvarname ',vartem,' is not in aeronames_smoke_fv3 !!!'
- call flush(6)
endif
endif
enddo
@@ -1165,6 +1394,11 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
ntracerio2d=0
endif
+ if( allocated(fv3lam_io_phymetvars3d_nouv) )then
+ call gsi_bundlecreate(gsibundle_fv3lam_phyvar_nouv,GSI_MetGuess_Bundle(it)%grid,'gsibundle_fv3lam_phyvar_nouv',istatus, &
+ names3d=fv3lam_io_phymetvars3d_nouv)
+ end if
+
if (laeroana_fv3cmaq) then
if (allocated(fv3lam_io_tracerchemvars3d_nouv) ) then
call gsi_bundlecreate(gsibundle_fv3lam_tracerchem_nouv,GSI_ChemGuess_Bundle(it)%grid,'gsibundle_fv3lam_tracerchem_nouv',istatus, &
@@ -1254,6 +1488,22 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
endif
+ if ( if_model_dbz .or. if_model_fed )then
+ inner_vars=1
+ numfields=inner_vars*(nphyvario3d*grd_a%nsig)
+ deallocate(lnames,names)
+ allocate(lnames(1,numfields),names(1,numfields))
+ ilev=1
+ do i=1,nphyvario3d
+ do k=1,grd_a%nsig
+ lnames(1,ilev)=k
+ names(1,ilev)=trim(fv3lam_io_phymetvars3d_nouv(i))
+ ilev=ilev+1
+ enddo
+ enddo
+ call general_sub2grid_create_info(grd_fv3lam_phyvar_ionouv,inner_vars,grd_a%nlat,&
+ grd_a%nlon,grd_a%nsig,numfields,regional,names=names,lnames=lnames)
+ end if
inner_vars=2
numfields=grd_a%nsig
@@ -1279,15 +1529,21 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'tv' ,ges_tv ,istatus );ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q ,istatus );ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'oz' ,ges_oz ,istatus );ier=ier+istatus
- if (l_use_dbz_directDA) then
+ if (l_use_dbz_directDA .or. nphyvario3d > 0) then
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ql' ,ges_ql ,istatus );ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qi' ,ges_qi ,istatus );ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qr' ,ges_qr ,istatus );ier=ier+istatus
- call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'iqr' ,ges_iqr ,istatus );ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qs' ,ges_qs ,istatus );ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qg' ,ges_qg ,istatus );ier=ier+istatus
- call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnr',ges_qnr ,istatus );ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'w' , ges_w ,istatus );ier=ier+istatus
+ if (l_use_dbz_directDA) then
+ call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'iqr' ,ges_iqr ,istatus );ier=ier+istatus
+ call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnr',ges_qnr ,istatus );ier=ier+istatus
+ end if
+ if(if_model_dbz) &
+ call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'dbz' , ges_dbz ,istatus );ier=ier+istatus
+ if(if_model_fed) &
+ call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'fed' , ges_fed ,istatus );ier=ier+istatus
end if
if (ier/=0) call die(trim(myname),'cannot get pointers for fv3 met-fields, ier =',ier)
@@ -1297,6 +1553,19 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it),'t2m',ges_t2m,istatus );ier=ier+istatus
if (ier/=0) call die(trim(myname),'cannot get pointers for t2m,ier=',ier)
endif
+
+!--- significant wave height (howv)
+ if ( i_howv_3dda == 1 ) then
+ call GSI_BundleGetPointer(GSI_MetGuess_Bundle(it),'howv',ges_howv,istatus ); ier=ier+istatus
+ if (ier/=0) call die(trim(myname),'cannot get pointers for howv, ier=',ier)
+ endif
+
+!--- wind gust (gust)
+ if ( i_gust_3dda == 1 ) then
+ call GSI_BundleGetPointer(GSI_MetGuess_Bundle(it),'gust',ges_gust,istatus ); ier=ier+istatus
+ if (ier/=0) call die(trim(myname),'cannot get pointers for gust, ier=',ier)
+ endif
+
if(mype == 0 ) then
call check(nf90_open(fv3filenamegin(it)%dynvars,nf90_nowrite,loc_id))
call check(nf90_inquire(loc_id,formatNum=ncfmt))
@@ -1333,36 +1602,40 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
end if
if( fv3sar_bg_opt == 0) then
- call gsi_fv3ncdf_readuv(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it))
+ call gsi_fv3ncdf_readuv(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.)
else
- call gsi_fv3ncdf_readuv_v1(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it))
+ call gsi_fv3ncdf_readuv_v1(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.)
endif
if( fv3sar_bg_opt == 0) then
call gsi_fv3ncdf_read(grd_fv3lam_dynvar_ionouv,gsibundle_fv3lam_dynvar_nouv &
- & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it))
+ & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it),.false.)
call gsi_fv3ncdf_read(grd_fv3lam_tracer_ionouv,gsibundle_fv3lam_tracer_nouv &
- & ,fv3filenamegin(it)%tracers,fv3filenamegin(it))
+ & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.)
+ if( nphyvario3d > 0 )then
+ call gsi_fv3ncdf_read(grd_fv3lam_phyvar_ionouv,gsibundle_fv3lam_phyvar_nouv &
+ & ,fv3filenamegin(it)%phyvars,fv3filenamegin(it),.false.)
+ end if
if (laeroana_fv3cmaq) then
call gsi_fv3ncdf_read(grd_fv3lam_tracerchem_ionouv,gsibundle_fv3lam_tracerchem_nouv &
- & ,fv3filenamegin(it)%tracers,fv3filenamegin(it))
+ & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.)
endif
if (laeroana_fv3smoke) then
call gsi_fv3ncdf_read(grd_fv3lam_tracersmoke_ionouv,gsibundle_fv3lam_tracersmoke_nouv &
- & ,fv3filenamegin(it)%tracers,fv3filenamegin(it))
+ & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.)
endif
else
call gsi_fv3ncdf_read_v1(grd_fv3lam_dynvar_ionouv,gsibundle_fv3lam_dynvar_nouv &
- & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it))
+ & ,fv3filenamegin(it)%dynvars,fv3filenamegin(it),.false.)
call gsi_fv3ncdf_read_v1(grd_fv3lam_tracer_ionouv,gsibundle_fv3lam_tracer_nouv &
- & ,fv3filenamegin(it)%tracers,fv3filenamegin(it))
+ & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.)
if (laeroana_fv3cmaq) then
call gsi_fv3ncdf_read_v1(grd_fv3lam_tracerchem_ionouv,gsibundle_fv3lam_tracerchem_nouv &
- & ,fv3filenamegin(it)%tracers,fv3filenamegin(it))
+ & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.)
endif
if (laeroana_fv3smoke) then
call gsi_fv3ncdf_read_v1(grd_fv3lam_tracersmoke_ionouv,gsibundle_fv3lam_tracersmoke_nouv &
- & ,fv3filenamegin(it)%tracers,fv3filenamegin(it))
+ & ,fv3filenamegin(it)%tracers,fv3filenamegin(it),.false.)
endif
endif
@@ -1438,7 +1711,9 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
if (laeroana_fv3smoke) then
call gsi_copy_bundle(gsibundle_fv3lam_tracersmoke_nouv,GSI_ChemGuess_Bundle(it))
endif
-
+ if ( nphyvario3d > 0 ) then
+ call gsi_copy_bundle(gsibundle_fv3lam_phyvar_nouv,GSI_MetGuess_Bundle(it))
+ end if
call GSI_BundleGetPointer ( gsibundle_fv3lam_dynvar_nouv, 'tsen' ,ges_tsen_readin ,istatus );ier=ier+istatus
!! tsen2tv !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
do k=1,nsig
@@ -1473,7 +1748,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
endif
- call gsi_fv3ncdf2d_read(fv3filenamegin(it),it,ges_z,ges_t2m,ges_q2m)
+ call gsi_fv3ncdf2d_read(fv3filenamegin(it),it,ges_z,ges_t2m,ges_q2m, &
+ ges_howv,ges_gust)
if(i_use_2mq4b > 0 .and. i_use_2mt4b > 0 ) then
! Convert 2m guess mixing ratio to specific humidity
@@ -1709,7 +1985,8 @@ end subroutine gsi_bundlegetpointer_fv3lam_tracerchem_nouv
end subroutine read_fv3_netcdf_guess
-subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
+subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m, &
+ ges_howv,ges_gust)
!$$$ subprogram documentation block
! . . . .
! subprogram: gsi_fv3ncdf2d_read
@@ -1718,6 +1995,10 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
! abstract: read in 2d fields from fv3_sfcdata file in mype_2d
! Scatter the field to each PE
! program history log:
+! 2023-02-14 Hu - Bug fix for read in subdomain surface restart files
+! 2023-07-30 Zhao - added IO to read significant wave height (howv) from 2D FV3-LAM
+! firstguess file (fv3_sfcdata)
+!
! input argument list:
! it - time index for 2d fields
!
@@ -1730,7 +2011,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
!
!$$$ end documentation block
use kinds, only: r_kind,i_kind
- use mpimod, only: ierror,mpi_comm_world,npe,mpi_rtype,mype
+ use mpimod, only: ierror,mpi_comm_world,npe,mpi_rtype,mype,mpi_itype
+ use mpeu_util, only: die
use guess_grids, only: fact10,soil_type,veg_frac,veg_type,sfc_rough, &
sfct,sno,soil_temp,soil_moi,isli
use gridmod, only: lat2,lon2,itotsub,ijn_s
@@ -1738,18 +2020,24 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr
use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension
use netcdf, only: nf90_inquire_variable
+ use netcdf, only: nf90_inq_varid
+ use netcdf, only: nf90_noerr
use mod_fv3_lola, only: fv3_h_to_ll,nxa,nya
use constants, only: grav
+ use constants, only: zero
implicit none
- integer(i_kind),intent(in) :: it
- real(r_kind),intent(in),dimension(:,:),pointer::ges_z
- real(r_kind),intent(in),dimension(:,:),pointer::ges_t2m
- real(r_kind),intent(in),dimension(:,:),pointer::ges_q2m
+ integer(i_kind), intent(in) :: it
+ real(r_kind), intent(in),dimension(:,:),pointer::ges_z
+ real(r_kind), intent(in),dimension(:,:),pointer::ges_t2m
+ real(r_kind), intent(in),dimension(:,:),pointer::ges_q2m
+ real(r_kind), intent(in),dimension(:,:),pointer::ges_howv
+ real(r_kind), intent(in),dimension(:,:),pointer::ges_gust
type (type_fv3regfilenameg),intent(in) :: fv3filenamegin
+
character(len=max_varname_length) :: name
- integer(i_kind),allocatable,dimension(:):: dim_id,dim
+ integer(i_kind),allocatable,dimension(:):: dim
real(r_kind),allocatable,dimension(:):: work
real(r_kind),allocatable,dimension(:,:):: a
real(r_kind),allocatable,dimension(:,:,:):: sfcn2d
@@ -1760,6 +2048,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
integer(i_kind) kk,n,ns,j,ii,jj,mm1
character(len=:),allocatable :: sfcdata !='fv3_sfcdata'
character(len=:),allocatable :: dynvars !='fv3_dynvars'
+! for checking the existence of howv/gust in firstguess file
+ integer(i_kind) id_howv, id_gust
+ integer(i_kind) iret_bcast
! for io_layout > 1
real(r_kind),allocatable,dimension(:,:):: sfc_fulldomain
@@ -1767,6 +2058,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
integer(i_kind),allocatable :: gfile_loc_layout(:)
character(len=180) :: filename_layout
+! for sfc 2d vaiable exist or not
+ logical, dimension(n2d) :: sfc_var_exist
+
sfcdata= fv3filenamegin%sfcdata
dynvars= fv3filenamegin%dynvars
@@ -1775,6 +2069,13 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
allocate(work(itotsub*n2d))
allocate( sfcn2d(lat2,lon2,n2d))
+!-- initialisation of the array for howv/gust
+ sfcn2d(:,:,k_howv) = zero
+ sfcn2d(:,:,k_gust) = zero
+
+!-- initialisation of the array for sfc_var_exist
+ sfc_var_exist = .false.
+
if(mype==mype_2d ) then
allocate(sfc_fulldomain(nx,ny))
@@ -1802,33 +2103,84 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
iret=nf90_inquire_dimension(gfile_loc,k,name,len)
dim(k)=len
enddo
+
+!--- check the existence of significant wave height (howv) in 2D FV3-LAM firstguess file
+! if howv is set in anavinfo (as i_howv_3dda=1), then check its existence in firstguess,
+! but if it is not found in firstguess, then stop GSI run and set i_howv_3dda = 0.
+ if ( i_howv_3dda == 1 ) then
+ iret = nf90_inq_varid(gfile_loc,'howv',id_howv)
+ if ( iret /= nf90_noerr ) then
+ iret = nf90_inq_varid(gfile_loc,'HOWV',id_howv) ! double check with name in uppercase
+ end if
+ if ( iret /= nf90_noerr ) then
+ i_howv_3dda = 0 ! howv does not exist in firstguess, then stop GSI run.
+ call die('gsi_fv3ncdf2d_read','Warning: CANNOT find howv in firstguess, aborting..., iret = ', iret)
+ else
+ write(6,'(1x,A,1x,A,1x,A,1x,I4,1x,I4,1x,A,1x,I4.4,A)') 'gsi_fv3ncdf2d_read:: Found howv in firstguess ', &
+ trim(sfcdata), ', iret, varid = ',iret, id_howv,' (on pe: ', mype,').'
+ end if
+ end if
+!--- check the existence of wind gust (gust) in 2D FV3-LAM firstguess file
+! (similar as done above for howv)
+ if ( i_gust_3dda == 1 ) then
+ iret = nf90_inq_varid(gfile_loc,'gust',id_gust)
+ if ( iret /= nf90_noerr ) then
+ iret = nf90_inq_varid(gfile_loc,'GUST',id_gust) ! double check with name in uppercase
+ end if
+ if ( iret /= nf90_noerr ) then
+ i_gust_3dda = 0 ! gust does not exist in firstguess, then stop GSI run.
+ call die('gsi_fv3ncdf2d_read','Warning: CANNOT find gust in firstguess, aborting..., iret = ', iret)
+ else
+ write(6,'(1x,A,1x,A,1x,A,1x,I4,1x,I4,1x,A,1x,I4.4,A)') 'gsi_fv3ncdf2d_read:: Found gust in firstguess ', &
+ trim(sfcdata), ', iret, varid = ',iret, id_gust,' (on pe: ', mype,').'
+ end if
+ end if
+
!!!!!!!!!!!! read in 2d variables !!!!!!!!!!!!!!!!!!!!!!!!!!
do i=ndimensions+1,nvariables
iret=nf90_inquire_variable(gfile_loc,i,name,len)
if( trim(name)=='f10m'.or.trim(name)=='F10M' ) then
k=k_f10m
+ sfc_var_exist(k) = .true.
else if( trim(name)=='stype'.or.trim(name)=='STYPE' ) then
k=k_stype
+ sfc_var_exist(k) = .true.
else if( trim(name)=='vfrac'.or.trim(name)=='VFRAC' ) then
k=k_vfrac
+ sfc_var_exist(k) = .true.
else if( trim(name)=='vtype'.or.trim(name)=='VTYPE' ) then
k=k_vtype
+ sfc_var_exist(k) = .true.
else if( trim(name)=='zorl'.or.trim(name)=='ZORL' ) then
k=k_zorl
+ sfc_var_exist(k) = .true.
else if( trim(name)=='tsea'.or.trim(name)=='TSEA' ) then
k=k_tsea
+ sfc_var_exist(k) = .true.
else if( trim(name)=='sheleg'.or.trim(name)=='SHELEG' ) then
k=k_snwdph
- else if( trim(name)=='stc'.or.trim(name)=='STC' ) then
+ sfc_var_exist(k) = .true.
+ else if( trim(name)=='stc'.or.trim(name)=='tslb' ) then
k=k_stc
- else if( trim(name)=='smc'.or.trim(name)=='SMC' ) then
+ sfc_var_exist(k) = .true.
+ else if( trim(name)=='smc'.or.trim(name)=='smois' ) then
k=k_smc
+ sfc_var_exist(k) = .true.
else if( trim(name)=='SLMSK'.or.trim(name)=='slmsk' ) then
k=k_slmsk
+ sfc_var_exist(k) = .true.
else if( trim(name)=='T2M'.or.trim(name)=='t2m' ) then
k=k_t2m
+ sfc_var_exist(k) = .true.
else if( trim(name)=='Q2M'.or.trim(name)=='q2m' ) then
k=k_q2m
+ sfc_var_exist(k) = .true.
+ else if( trim(name)=='HOWV'.or.trim(name)=='howv' ) then
+ k=k_howv
+ sfc_var_exist(k) = .true.
+ else if( trim(name)=='GUST'.or.trim(name)=='gust' ) then
+ k=k_gust
+ sfc_var_exist(k) = .true.
else
cycle
endif
@@ -1837,40 +2189,24 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
write(*,*) "wrong dimension number ndim =",ndim
call stop2(119)
endif
- if(allocated(dim_id )) deallocate(dim_id )
- allocate(dim_id(ndim))
if(fv3_io_layout_y > 1) then
do nio=0,fv3_io_layout_y-1
- iret=nf90_inquire_variable(gfile_loc_layout(nio),i,dimids=dim_id)
- if(allocated(sfc )) deallocate(sfc )
- if(dim(dim_id(1)) == nx .and. dim(dim_id(2))==ny_layout_len(nio)) then
- if(ndim >=3) then
- allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3))))
- iret=nf90_get_var(gfile_loc_layout(nio),i,sfc)
- else if (ndim == 2) then
- allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),1))
- iret=nf90_get_var(gfile_loc_layout(nio),i,sfc(:,:,1))
- endif
- else
- write(*,*) "Mismatch dimension in surfacei reading:",nx,ny_layout_len(nio),dim(dim_id(1)),dim(dim_id(2))
- call stop2(119)
- endif
- sfc_fulldomain(:,ny_layout_b(nio):ny_layout_e(nio))=sfc(:,:,1)
+ if(allocated(sfc )) deallocate(sfc )
+ allocate(sfc(nx,ny_layout_len(nio),1))
+ if(ndim >=3) then
+ iret=nf90_get_var(gfile_loc_layout(nio),i,sfc)
+ else if (ndim == 2) then
+ iret=nf90_get_var(gfile_loc_layout(nio),i,sfc(:,:,1))
+ endif
+ sfc_fulldomain(:,ny_layout_b(nio):ny_layout_e(nio))=sfc(:,:,1)
enddo
else
- iret=nf90_inquire_variable(gfile_loc,i,dimids=dim_id)
if(allocated(sfc )) deallocate(sfc )
- if(dim(dim_id(1)) == nx .and. dim(dim_id(2))==ny) then
- if(ndim >=3) then !the block of 10 lines is compied from GSL gsi.
- allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3))))
- iret=nf90_get_var(gfile_loc,i,sfc)
- else if (ndim == 2) then
- allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),1))
- iret=nf90_get_var(gfile_loc,i,sfc(:,:,1))
- endif
- else
- write(*,*) "Mismatch dimension in surfacei reading:",nx,ny,dim(dim_id(1)),dim(dim_id(2))
- call stop2(119)
+ allocate(sfc(nx,ny,1))
+ if(ndim >=3) then
+ iret=nf90_get_var(gfile_loc,i,sfc)
+ else if (ndim == 2) then
+ iret=nf90_get_var(gfile_loc,i,sfc(:,:,1))
endif
sfc_fulldomain(:,:)=sfc(:,:,1)
endif
@@ -1931,20 +2267,18 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
do k=ndimensions+1,nvariables
iret=nf90_inquire_variable(gfile_loc,k,name,len)
if(trim(name)=='PHIS' .or. trim(name)=='phis' ) then
+ sfc_var_exist(k_orog) = .true.
iret=nf90_inquire_variable(gfile_loc,k,ndims=ndim)
- if(allocated(dim_id )) deallocate(dim_id )
- allocate(dim_id(ndim))
if(fv3_io_layout_y > 1) then
do nio=0,fv3_io_layout_y-1
- iret=nf90_inquire_variable(gfile_loc_layout(nio),k,dimids=dim_id)
if(allocated(sfc1 )) deallocate(sfc1 )
- allocate(sfc1(dim(dim_id(1)),dim(dim_id(2))) )
+ allocate(sfc1(nx,ny_layout_len(nio)) )
iret=nf90_get_var(gfile_loc_layout(nio),k,sfc1)
sfc_fulldomain(:,ny_layout_b(nio):ny_layout_e(nio))=sfc1
enddo
else
- iret=nf90_inquire_variable(gfile_loc,k,dimids=dim_id)
- allocate(sfc1(dim(dim_id(1)),dim(dim_id(2))) )
+ if(allocated(sfc1 )) deallocate(sfc1 )
+ allocate(sfc1(nx,ny) )
iret=nf90_get_var(gfile_loc,k,sfc1)
sfc_fulldomain=sfc1
endif
@@ -1975,10 +2309,17 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
end do
end do
- if(allocated(sfc1) .and. allocated(sfc))deallocate (dim_id,sfc,sfc1,dim)
+ if(allocated(sfc1) .and. allocated(sfc)) deallocate (sfc,sfc1)
+ if(allocated(dim)) deallocate (dim)
if(allocated(sfc_fulldomain)) deallocate (sfc_fulldomain)
endif ! mype
+!-- broadcast the updated i_howv_3dda, i_gust_3dda to all tasks (!!!!)
+ call mpi_bcast(i_howv_3dda, 1, mpi_itype, mype_2d, mpi_comm_world, iret_bcast)
+ call mpi_bcast(i_gust_3dda, 1, mpi_itype, mype_2d, mpi_comm_world, iret_bcast)
+
+!-- broadcast the updated sfc_var_exist to all tasks (!!!!)
+ call mpi_bcast(sfc_var_exist, n2d, mpi_itype, mype_2d, mpi_comm_world, iret_bcast)
!!!!!!! scatter !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
call mpi_scatterv(work,ijns2d,displss2d,mpi_rtype,&
@@ -1986,20 +2327,26 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m)
deallocate ( work )
- fact10(:,:,it)=sfcn2d(:,:,k_f10m)
- soil_type(:,:,it)=sfcn2d(:,:,k_stype)
- veg_frac(:,:,it)=sfcn2d(:,:,k_vfrac)
- veg_type(:,:,it)=sfcn2d(:,:,k_vtype)
- sfc_rough(:,:,it)=sfcn2d(:,:,k_zorl)
- sfct(:,:,it)=sfcn2d(:,:,k_tsea)
- sno(:,:,it)=sfcn2d(:,:,k_snwdph)
- soil_temp(:,:,it)=sfcn2d(:,:,k_stc)
- soil_moi(:,:,it)=sfcn2d(:,:,k_smc)
- ges_z(:,:)=sfcn2d(:,:,k_orog)/grav
- isli(:,:,it)=nint(sfcn2d(:,:,k_slmsk))
+ if ( sfc_var_exist(k_f10m) ) fact10(:,:,it)=sfcn2d(:,:,k_f10m)
+ if ( sfc_var_exist(k_stype) ) soil_type(:,:,it)=sfcn2d(:,:,k_stype)
+ if ( sfc_var_exist(k_vfrac) ) veg_frac(:,:,it)=sfcn2d(:,:,k_vfrac)
+ if ( sfc_var_exist(k_vtype) ) veg_type(:,:,it)=sfcn2d(:,:,k_vtype)
+ if ( sfc_var_exist(k_zorl) ) sfc_rough(:,:,it)=sfcn2d(:,:,k_zorl)
+ if ( sfc_var_exist(k_tsea) ) sfct(:,:,it)=sfcn2d(:,:,k_tsea)
+ if ( sfc_var_exist(k_snwdph)) sno(:,:,it)=sfcn2d(:,:,k_snwdph)
+ if ( sfc_var_exist(k_stc) ) soil_temp(:,:,it)=sfcn2d(:,:,k_stc)
+ if ( sfc_var_exist(k_smc) ) soil_moi(:,:,it)=sfcn2d(:,:,k_smc)
+ if ( sfc_var_exist(k_orog) ) ges_z(:,:)=sfcn2d(:,:,k_orog)/grav
+ if ( sfc_var_exist(k_slmsk) ) isli(:,:,it)=nint(sfcn2d(:,:,k_slmsk))
if(i_use_2mq4b > 0 .and. i_use_2mt4b > 0 ) then
- ges_t2m(:,:)=sfcn2d(:,:,k_t2m)
- ges_q2m(:,:)=sfcn2d(:,:,k_q2m)
+ if ( sfc_var_exist(k_t2m) ) ges_t2m(:,:)=sfcn2d(:,:,k_t2m)
+ if ( sfc_var_exist(k_q2m) ) ges_q2m(:,:)=sfcn2d(:,:,k_q2m)
+ endif
+ if ( i_howv_3dda == 1 ) then
+ if ( sfc_var_exist(k_howv) ) ges_howv(:,:)=sfcn2d(:,:,k_howv)
+ endif
+ if ( i_gust_3dda == 1 ) then
+ if ( sfc_var_exist(k_gust) ) ges_gust(:,:)=sfcn2d(:,:,k_gust)
endif
deallocate (sfcn2d,a)
return
@@ -2042,8 +2389,8 @@ subroutine gsi_fv3ncdf2d_read_v1(filenamein,varname,varname2,work_sub,mype_io)
use general_commvars_mod, only: ltosi_s,ltosj_s
implicit none
- character(*) ,intent(in ) :: varname,varname2,filenamein
- real(r_kind) ,intent(out ) :: work_sub(lat2,lon2)
+ character(*) , intent(in ) :: varname,varname2,filenamein
+ real(r_kind) , intent(out ) :: work_sub(lat2,lon2)
integer(i_kind) ,intent(in ) :: mype_io
real(r_kind),allocatable,dimension(:,:,:):: uu
real(r_kind),allocatable,dimension(:):: work
@@ -2104,7 +2451,7 @@ subroutine gsi_fv3ncdf2d_read_v1(filenamein,varname,varname2,work_sub,mype_io)
return
end subroutine gsi_fv3ncdf2d_read_v1
-subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin)
+subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ensgrid)
!$$$ subprogram documentation block
! . . . .
! subprogram: gsi_fv3ncdf_read
@@ -2131,33 +2478,42 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin)
use kinds, only: r_kind,i_kind
- use mpimod, only: mpi_comm_world,mpi_rtype,mype
+ use mpimod, only: mpi_comm_world,mpi_rtype,mype,npe,setcomm,mpi_integer,mpi_max
use mpimod, only: MPI_INFO_NULL
use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr
- use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension
+ use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension
use netcdf, only: nf90_inquire_variable
use netcdf, only: nf90_inq_varid
- use mod_fv3_lola, only: fv3_h_to_ll
+ use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens
use gsi_bundlemod, only: gsi_bundle
use general_sub2grid_mod, only: sub2grid_info,general_grid2sub
implicit none
- type(sub2grid_info), intent(in):: grd_ionouv
- type(gsi_bundle),intent(inout) :: cstate_nouv
- character(*),intent(in):: filenamein
- type (type_fv3regfilenameg),intent(in) ::fv3filenamegin
+ type(sub2grid_info), intent(in ) :: grd_ionouv
+ type(gsi_bundle), intent(inout) :: cstate_nouv
+ character(*), intent(in ) :: filenamein
+ type (type_fv3regfilenameg),intent(in ) ::fv3filenamegin
+ logical, intent(in ) :: ensgrid
+
real(r_kind),allocatable,dimension(:,:):: uu2d
real(r_kind),dimension(1,grd_ionouv%nlat,grd_ionouv%nlon,grd_ionouv%kbegin_loc:grd_ionouv%kend_alloc):: hwork
character(len=max_varname_length) :: varname,vgsiname
character(len=max_varname_length) :: name
- character(len=max_varname_length) :: filenamein2
-
+ character(len=max_filename_length) :: filenamein2
+ real(r_kind),allocatable,dimension(:,:):: uu2d_tmp
+ integer(i_kind) :: countloc_tmp(4),startloc_tmp(4)
- integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3)
+ integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4)
integer(i_kind) ilev,ilevtot,inative
- integer(i_kind) kbgn,kend
+ integer(i_kind) kbgn,kend,len
+ logical :: phy_smaller_domain
integer(i_kind) gfile_loc,iret,var_id
- integer(i_kind) nz,nzp1,mm1
+ integer(i_kind) nz,nzp1,mm1,nx_phy
+
+ integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror
+ integer(i_kind),dimension(npe):: members,members_read,mype_read_rank
+ logical:: procuse
+
! for io_layout > 1
real(r_kind),allocatable,dimension(:,:):: uu2d_layout
integer(i_kind) :: nio
@@ -2167,85 +2523,155 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin)
mm1=mype+1
nloncase=grd_ionouv%nlon
nlatcase=grd_ionouv%nlat
- nxcase=nx
- nycase=ny
+ if (ensgrid) then
+ nxcase=nxens
+ nycase=nyens
+ else
+ nxcase=nx
+ nycase=ny
+ end if
kbgn=grd_ionouv%kbegin_loc
kend=grd_ionouv%kend_loc
allocate(uu2d(nxcase,nycase))
- if(fv3_io_layout_y > 1) then
- allocate(gfile_loc_layout(0:fv3_io_layout_y-1))
- do nio=0,fv3_io_layout_y-1
- write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio
- iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) !clt
- if(iret/=nf90_noerr) then
- write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret
- call flush(6)
- call stop2(333)
- endif
- enddo
- else
- iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) !clt
- if(iret/=nf90_noerr) then
- write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret
- call flush(6)
- call stop2(333)
- endif
+ procuse = .false.
+ members=-1
+ members_read=-1
+ if (kbgn<=kend) then
+ procuse = .true.
+ members(mm1) = mype
endif
- do ilevtot=kbgn,kend
- vgsiname=grd_ionouv%names(1,ilevtot)
- if(trim(vgsiname)=='delzinc') cycle !delzinc is not read from DZ ,it's started from hydrostatic height
- if(trim(vgsiname)=='amassi') cycle
- if(trim(vgsiname)=='amassj') cycle
- if(trim(vgsiname)=='amassk') cycle
- if(trim(vgsiname)=='pm2_5') cycle
- call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname)
- name=trim(varname)
- if(trim(filenamein) /= trim(filenamein2)) then
- write(6,*)'filenamein and filenamein2 are not the same as expected, stop'
- call flush(6)
- call stop2(333)
- endif
- ilev=grd_ionouv%lnames(1,ilevtot)
- nz=grd_ionouv%nsig
- nzp1=nz+1
- inative=nzp1-ilev
- startloc=(/1,1,inative/)
- countloc=(/nxcase,nycase,1/)
+ call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror)
- if(fv3_io_layout_y > 1) then
- do nio=0,fv3_io_layout_y-1
- countloc=(/nxcase,ny_layout_len(nio),1/)
- allocate(uu2d_layout(nxcase,ny_layout_len(nio)))
- iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id)
- iret=nf90_get_var(gfile_loc_layout(nio),var_id,uu2d_layout,start=startloc,count=countloc)
- uu2d(:,ny_layout_b(nio):ny_layout_e(nio))=uu2d_layout
- deallocate(uu2d_layout)
- enddo
- else
- iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id)
- iret=nf90_get_var(gfile_loc,var_id,uu2d,start=startloc,count=countloc)
- endif
+ nread=0
+ mype_read_rank=-1
+ do i=1,npe
+ if (members_read(i) >= 0) then
+ nread=nread+1
+ mype_read_rank(nread) = members_read(i)
+ endif
+ enddo
+
+ call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror)
- call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag)
- enddo ! ilevtot
+ if (procuse) then
- if(fv3_io_layout_y > 1) then
- do nio=1,fv3_io_layout_y-1
- iret=nf90_close(gfile_loc_layout(nio))
- enddo
- deallocate(gfile_loc_layout)
- else
- iret=nf90_close(gfile_loc)
+ if(fv3_io_layout_y > 1) then
+ allocate(gfile_loc_layout(0:fv3_io_layout_y-1))
+ do nio=0,fv3_io_layout_y-1
+ write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio
+ iret=nf90_open(filename_layout,ior(nf90_nowrite,nf90_mpiio),gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) !clt
+ if(iret/=nf90_noerr) then
+ write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret
+ call stop2(333)
+ endif
+ enddo
+ else
+ iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt
+ if(iret/=nf90_noerr) then
+ write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret
+ call stop2(333)
+ endif
+ endif
+ do ilevtot=kbgn,kend
+ vgsiname=grd_ionouv%names(1,ilevtot)
+ if(trim(vgsiname)=='delzinc') cycle !delzinc is not read from DZ ,it's started from hydrostatic height
+ if(trim(vgsiname)=='amassi') cycle
+ if(trim(vgsiname)=='amassj') cycle
+ if(trim(vgsiname)=='amassk') cycle
+ if(trim(vgsiname)=='pm2_5') cycle
+ call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname)
+ name=trim(varname)
+ if(trim(filenamein) /= trim(filenamein2)) then
+ write(6,*)'filenamein and filenamein2 are not the same as expected, stop'
+ call stop2(333)
+ endif
+ ilev=grd_ionouv%lnames(1,ilevtot)
+ nz=grd_ionouv%nsig
+ nzp1=nz+1
+ inative=nzp1-ilev
+ startloc=(/1,1,inative,1/)
+ countloc=(/nxcase,nycase,1,1/)
+ ! Variable ref_f3d in phy_data.nc has a smaller domain size than
+ ! dynvariables and tracers as well as a reversed order in vertical
+ if ( trim(adjustl(varname)) == 'ref_f3d' .or. trim(adjustl(varname)) == 'flash_extent_density' )then
+ iret=nf90_inquire_dimension(gfile_loc,1,name,len)
+ if(trim(name)=='xaxis_1') nx_phy=len
+ if( nx_phy == nxcase )then
+ allocate(uu2d_tmp(nxcase,nycase))
+ countloc_tmp=(/nxcase,nycase,1,1/)
+ phy_smaller_domain = .false.
+ else
+ allocate(uu2d_tmp(nxcase-6,nycase-6))
+ countloc_tmp=(/nxcase-6,nycase-6,1,1/)
+ phy_smaller_domain = .true.
+ end if
+ startloc_tmp=(/1,1,ilev,1/)
+ end if
+
+ if(fv3_io_layout_y > 1) then
+ do nio=0,fv3_io_layout_y-1
+ if (ensgrid) then
+ countloc=(/nxcase,ny_layout_lenens(nio)+1,1,1/)
+ allocate(uu2d_layout(nxcase,ny_layout_lenens(nio)+1))
+ else
+ countloc=(/nxcase,ny_layout_len(nio),1,1/)
+ allocate(uu2d_layout(nxcase,ny_layout_len(nio)))
+ end if
+ iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id)
+ iret=nf90_get_var(gfile_loc_layout(nio),var_id,uu2d_layout,start=startloc,count=countloc)
+ if (ensgrid) then
+ uu2d(:,ny_layout_bens(nio):ny_layout_eens(nio))=uu2d_layout
+ else
+ uu2d(:,ny_layout_b(nio):ny_layout_e(nio))=uu2d_layout
+ end if
+ deallocate(uu2d_layout)
+ enddo
+ else
+ iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id)
+ if ( trim(adjustl(varname)) == 'ref_f3d'.or. trim(adjustl(varname)) == 'flash_extent_density' )then
+ uu2d = 0.0_r_kind
+ iret=nf90_get_var(gfile_loc,var_id,uu2d_tmp,start=startloc_tmp,count=countloc_tmp)
+ where(uu2d_tmp < 0.0_r_kind)
+ uu2d_tmp = 0.0_r_kind
+ endwhere
+
+ if( phy_smaller_domain )then
+ uu2d(4:nxcase-3,4:nycase-3) = uu2d_tmp
+ else
+ uu2d(1:nxcase,1:nycase) = uu2d_tmp
+ end if
+ deallocate(uu2d_tmp)
+ else
+ iret=nf90_get_var(gfile_loc,var_id,uu2d,start=startloc,count=countloc)
+ end if
+ endif
+
+ if (ensgrid) then
+ call fv3_h_to_ll_ens(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag)
+ else
+ call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag)
+ endif
+ enddo ! ilevtot
+
+ if(fv3_io_layout_y > 1) then
+ do nio=1,fv3_io_layout_y-1
+ iret=nf90_close(gfile_loc_layout(nio))
+ enddo
+ deallocate(gfile_loc_layout)
+ else
+ iret=nf90_close(gfile_loc)
+ endif
endif
-
+ call mpi_barrier(mpi_comm_world,ierror)
+
deallocate (uu2d)
call general_grid2sub(grd_ionouv,hwork,cstate_nouv%values)
return
-end subroutine gsi_fv3ncdf_read
+ end subroutine gsi_fv3ncdf_read
-subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin)
+subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ensgrid)
!$$$ subprogram documentation block
! . . . .
@@ -2274,47 +2700,81 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin)
use kinds, only: r_kind,i_kind
- use mpimod, only: mpi_rtype,mpi_comm_world,mype,MPI_INFO_NULL
- use mpimod, only: mpi_comm_world,mpi_rtype,mype
+ use mpimod, only: npe,mpi_rtype,mpi_comm_world,mype,MPI_INFO_NULL
+ use mpimod, only: mpi_comm_world,mpi_rtype,mype,setcomm,mpi_integer,mpi_max
use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr
- use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension
+ use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension
use netcdf, only: nf90_inquire_variable
use netcdf, only: nf90_inq_varid
- use mod_fv3_lola, only: fv3_h_to_ll
+ use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens
use gsi_bundlemod, only: gsi_bundle
use general_sub2grid_mod, only: sub2grid_info,general_grid2sub
implicit none
- type(sub2grid_info), intent(in):: grd_ionouv
- character(*),intent(in):: filenamein
- type (type_fv3regfilenameg) :: fv3filenamegin
- type(gsi_bundle),intent(inout) :: cstate_nouv
+ type(sub2grid_info), intent(in):: grd_ionouv
+ character(*), intent(in):: filenamein
+ logical, intent(in ) :: ensgrid
+ type (type_fv3regfilenameg), intent(in) :: fv3filenamegin
+ type(gsi_bundle), intent(inout) :: cstate_nouv
+
real(r_kind),allocatable,dimension(:,:):: uu2d
real(r_kind),dimension(1,grd_ionouv%nlat,grd_ionouv%nlon,grd_ionouv%kbegin_loc:grd_ionouv%kend_alloc):: hwork
- character(len=max_varname_length) :: filenamein2
+ character(len=max_filename_length) :: filenamein2
character(len=max_varname_length) :: varname,vgsiname
- integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3)
+ integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4)
integer(i_kind) kbgn,kend
integer(i_kind) var_id
integer(i_kind) inative,ilev,ilevtot
integer(i_kind) gfile_loc,iret
integer(i_kind) nzp1,mm1
+
+ integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror
+ integer(i_kind),dimension(npe):: members,members_read,mype_read_rank
+ logical:: procuse
- mm1=mype+1
+
+
+ mm1=mype+1
nloncase=grd_ionouv%nlon
nlatcase=grd_ionouv%nlat
- nxcase=nx
- nycase=ny
+ if (ensgrid) then
+ nxcase=nxens
+ nycase=nyens
+ else
+ nxcase=nx
+ nycase=ny
+ end if
+ allocate(uu2d(nxcase,nycase))
+
kbgn=grd_ionouv%kbegin_loc
kend=grd_ionouv%kend_loc
- allocate(uu2d(nxcase,nycase))
- iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) !clt
+ procuse = .false.
+ members=-1
+ members_read=-1
+ if (kbgn<=kend) then
+ procuse = .true.
+ members(mm1) = mype
+ endif
+ call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror)
+
+ nread=0
+ mype_read_rank=-1
+ do i=1,npe
+ if (members_read(i) >= 0) then
+ nread=nread+1
+ mype_read_rank(nread) = members_read(i)
+ endif
+ enddo
+
+ call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror)
+
+ if (procuse) then
+ iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt
if(iret/=nf90_noerr) then
write(6,*)' gsi_fv3ncdf_read_v1: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret
- call flush(6)
call stop2(333)
endif
@@ -2324,15 +2784,14 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin)
call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname)
if(trim(filenamein) /= trim(filenamein2)) then
write(6,*)'filenamein and filenamein2 are not the same as expected, stop'
- call flush(6)
call stop2(333)
endif
ilev=grd_ionouv%lnames(1,ilevtot)
nz=grd_ionouv%nsig
nzp1=nz+1
inative=nzp1-ilev
- startloc=(/1,1,inative+1/)
- countloc=(/nxcase,nycase,1/)
+ startloc=(/1,1,inative+1,1/)
+ countloc=(/nxcase,nycase,1,1/)
iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id)
if(iret/=nf90_noerr) then
write(6,*)' wrong to get var_id ',var_id
@@ -2341,11 +2800,16 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin)
iret=nf90_get_var(gfile_loc,var_id,uu2d,start=startloc,count=countloc)
- call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag)
+ if (ensgrid) then
+ call fv3_h_to_ll_ens(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag)
+ else
+ call fv3_h_to_ll(uu2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag)
+ end if
enddo ! i
- call general_grid2sub(grd_ionouv,hwork,cstate_nouv%values)
iret=nf90_close(gfile_loc)
+ endif
+ call general_grid2sub(grd_ionouv,hwork,cstate_nouv%values)
deallocate (uu2d)
@@ -2353,7 +2817,7 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin)
return
end subroutine gsi_fv3ncdf_read_v1
-subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin)
+subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
!$$$ subprogram documentation block
! . . . .
! subprogram: gsi_fv3ncdf_readuv
@@ -2375,36 +2839,42 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin)
!
!$$$ end documentation block
use kinds, only: r_kind,i_kind
- use mpimod, only: mpi_comm_world,mpi_rtype,mype,mpi_info_null
+ use mpimod, only: mpi_comm_world,mpi_rtype,mype,mpi_info_null,npe,setcomm,mpi_integer,mpi_max
use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr
- use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension
+ use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension
use netcdf, only: nf90_inquire_variable
use netcdf, only: nf90_inq_varid
- use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth
+ use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth,fv3_h_to_ll_ens,fv3uv2earthens
use general_sub2grid_mod, only: sub2grid_info,general_grid2sub
implicit none
- type(sub2grid_info), intent(in):: grd_uv
+ type(sub2grid_info), intent(in):: grd_uv
real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_u
real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_v
type (type_fv3regfilenameg),intent (in) :: fv3filenamegin
+ logical, intent(in ) :: ensgrid
+
real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork
character(:), allocatable:: filenamein
real(r_kind),allocatable,dimension(:,:):: u2d,v2d
real(r_kind),allocatable,dimension(:,:):: uc2d,vc2d
- character(len=max_varname_length) :: filenamein2
+ character(len=max_filename_length) :: filenamein2
character(len=max_varname_length) :: varname,vgsiname
real(r_kind),allocatable,dimension(:,:,:,:):: worksub
integer(i_kind) u_grd_VarId,v_grd_VarId
integer(i_kind) nlatcase,nloncase
integer(i_kind) nxcase,nycase
- integer(i_kind) u_countloc(3),u_startloc(3),v_countloc(3),v_startloc(3)
+ integer(i_kind) u_countloc(4),u_startloc(4),v_countloc(4),v_startloc(4)
integer(i_kind) inative,ilev,ilevtot
integer(i_kind) kbgn,kend
integer(i_kind) gfile_loc,iret
integer(i_kind) nz,nzp1,mm1
+ integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror
+ integer(i_kind),dimension(npe):: members,members_read,mype_read_rank
+ logical:: procuse
+
! for fv3_io_layout_y > 1
real(r_kind),allocatable,dimension(:,:):: u2d_layout,v2d_layout
integer(i_kind) :: nio
@@ -2414,8 +2884,13 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin)
mm1=mype+1
nloncase=grd_uv%nlon
nlatcase=grd_uv%nlat
- nxcase=nx
- nycase=ny
+ if (ensgrid) then
+ nxcase=nxens
+ nycase=nyens
+ else
+ nxcase=nx
+ nycase=ny
+ end if
kbgn=grd_uv%kbegin_loc
kend=grd_uv%kend_loc
allocate(u2d(nxcase,nycase+1))
@@ -2425,109 +2900,156 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin)
allocate (worksub(2,grd_uv%lat2,grd_uv%lon2,grd_uv%nsig))
filenamein=fv3filenamegin%dynvars
- if(fv3_io_layout_y > 1) then
- allocate(gfile_loc_layout(0:fv3_io_layout_y-1))
- do nio=0,fv3_io_layout_y-1
- write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio
- iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL)
- if(iret/=nf90_noerr) then
- write(6,*)'problem opening6 ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret
- call flush(6)
- call stop2(333)
- endif
- enddo
- else
- iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) !clt
- if(iret/=nf90_noerr) then
- write(6,*)' problem opening6 ',trim(filenamein),', Status = ',iret
- call flush(6)
- call stop2(333)
- endif
+ procuse = .false.
+ members=-1
+ members_read=-1
+ if (kbgn<=kend) then
+ procuse = .true.
+ members(mm1) = mype
endif
- do ilevtot=kbgn,kend
- vgsiname=grd_uv%names(1,ilevtot)
- call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname)
- if(trim(filenamein) /= trim(filenamein2)) then
- write(6,*)'filenamein and filenamein2 are not the same as expected, stop'
- call flush(6)
- call stop2(333)
- endif
- ilev=grd_uv%lnames(1,ilevtot)
- nz=grd_uv%nsig
- nzp1=nz+1
- inative=nzp1-ilev
- u_countloc=(/nxcase,nycase+1,1/)
- v_countloc=(/nxcase+1,nycase,1/)
- u_startloc=(/1,1,inative/)
- v_startloc=(/1,1,inative/)
-
- if(fv3_io_layout_y > 1) then
- do nio=0,fv3_io_layout_y-1
- u_countloc=(/nxcase,ny_layout_len(nio)+1,1/)
- allocate(u2d_layout(nxcase,ny_layout_len(nio)+1))
- call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) )
- iret=nf90_get_var(gfile_loc_layout(nio),u_grd_VarId,u2d_layout,start=u_startloc,count=u_countloc)
- u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio))
- if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1)
- deallocate(u2d_layout)
-
- v_countloc=(/nxcase+1,ny_layout_len(nio),1/)
- allocate(v2d_layout(nxcase+1,ny_layout_len(nio)))
- call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) )
- iret=nf90_get_var(gfile_loc_layout(nio),v_grd_VarId,v2d_layout,start=v_startloc,count=v_countloc)
- v2d(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout
- deallocate(v2d_layout)
- enddo
- else
- call check( nf90_inq_varid(gfile_loc,'u',u_grd_VarId) )
- iret=nf90_get_var(gfile_loc,u_grd_VarId,u2d,start=u_startloc,count=u_countloc)
- call check( nf90_inq_varid(gfile_loc,'v',v_grd_VarId) )
- iret=nf90_get_var(gfile_loc,v_grd_VarId,v2d,start=v_startloc,count=v_countloc)
- endif
- if(.not.grid_reverse_flag) then
- call reverse_grid_r_uv (u2d,nxcase,nycase+1,1)
- call reverse_grid_r_uv (v2d,nxcase+1,nycase,1)
- endif
- call fv3uv2earth(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d)
+ call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror)
-! NOTE on transfor to earth u/v:
-! The u and v before transferring need to be in E-W/N-S grid, which is
-! defined as reversed grid here because it is revered from map view.
-!
-! Have set the following flag for grid orientation
-! grid_reverse_flag=true: E-W/N-S grid
-! grid_reverse_flag=false: W-E/S-N grid
-!
-! So for preparing the wind transferring, need to reverse the grid from
-! W-E/S-N grid to E-W/N-S grid when grid_reverse_flag=false:
-!
-! if(.not.grid_reverse_flag) call reverse_grid_r_uv
-!
-! and the last input parameter for fv3_h_to_ll is alway true:
-!
-!
- call fv3_h_to_ll(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.)
- call fv3_h_to_ll(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.)
- enddo ! i
+ nread=0
+ mype_read_rank=-1
+ do i=1,npe
+ if (members_read(i) >= 0) then
+ nread=nread+1
+ mype_read_rank(nread) = members_read(i)
+ endif
+ enddo
- if(fv3_io_layout_y > 1) then
- do nio=0,fv3_io_layout_y-1
- iret=nf90_close(gfile_loc_layout(nio))
- enddo
- deallocate(gfile_loc_layout)
- else
- iret=nf90_close(gfile_loc)
+ call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror)
+
+ if (procuse) then
+ if(fv3_io_layout_y > 1) then
+ allocate(gfile_loc_layout(0:fv3_io_layout_y-1))
+ do nio=0,fv3_io_layout_y-1
+ write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio
+ iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL)
+ if(iret/=nf90_noerr) then
+ write(6,*)'problem opening6 ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret
+ call stop2(333)
+ endif
+ enddo
+ else
+ iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt
+ if(iret/=nf90_noerr) then
+ write(6,*)' problem opening6 ',trim(filenamein),', Status = ',iret
+ call stop2(333)
+ endif
+ endif
+
+ do ilevtot=kbgn,kend
+ vgsiname=grd_uv%names(1,ilevtot)
+ call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname)
+ if(trim(filenamein) /= trim(filenamein2)) then
+ write(6,*)'filenamein and filenamein2 are not the same as expected, stop'
+ call stop2(333)
+ endif
+ ilev=grd_uv%lnames(1,ilevtot)
+ nz=grd_uv%nsig
+ nzp1=nz+1
+ inative=nzp1-ilev
+ u_countloc=(/nxcase,nycase+1,1,1/)
+ v_countloc=(/nxcase+1,nycase,1,1/)
+ u_startloc=(/1,1,inative,1/)
+ v_startloc=(/1,1,inative,1/)
+ if(fv3_io_layout_y > 1) then
+ do nio=0,fv3_io_layout_y-1
+ if (ensgrid) then
+ u_countloc=(/nxcase,ny_layout_lenens(nio)+1,1,1/)
+ allocate(u2d_layout(nxcase,ny_layout_lenens(nio)+1))
+ else
+ u_countloc=(/nxcase,ny_layout_len(nio)+1,1,1/)
+ allocate(u2d_layout(nxcase,ny_layout_len(nio)+1))
+ end if
+ call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) )
+ iret=nf90_get_var(gfile_loc_layout(nio),u_grd_VarId,u2d_layout,start=u_startloc,count=u_countloc)
+ if (ensgrid) then
+ u2d(:,ny_layout_bens(nio):ny_layout_eens(nio))=u2d_layout(:,1:ny_layout_lenens(nio))
+ if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_eens(nio)+1)=u2d_layout(:,ny_layout_lenens(nio)+1)
+ deallocate(u2d_layout)
+ v_countloc=(/nxcase+1,ny_layout_lenens(nio),1,1/)
+ allocate(v2d_layout(nxcase+1,ny_layout_lenens(nio)))
+ else
+ u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio))
+ if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1)
+ deallocate(u2d_layout)
+ v_countloc=(/nxcase+1,ny_layout_len(nio),1,1/)
+ allocate(v2d_layout(nxcase+1,ny_layout_len(nio)))
+ end if
+ call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) )
+ iret=nf90_get_var(gfile_loc_layout(nio),v_grd_VarId,v2d_layout,start=v_startloc,count=v_countloc)
+ if (ensgrid) then
+ v2d(:,ny_layout_bens(nio):ny_layout_eens(nio))=v2d_layout
+ else
+ v2d(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout
+ end if
+ deallocate(v2d_layout)
+ enddo
+ else
+ call check( nf90_inq_varid(gfile_loc,'u',u_grd_VarId) )
+ iret=nf90_get_var(gfile_loc,u_grd_VarId,u2d,start=u_startloc,count=u_countloc)
+ call check( nf90_inq_varid(gfile_loc,'v',v_grd_VarId) )
+ iret=nf90_get_var(gfile_loc,v_grd_VarId,v2d,start=v_startloc,count=v_countloc)
+ endif
+
+ if(.not.grid_reverse_flag) then
+ call reverse_grid_r_uv (u2d,nxcase,nycase+1,1)
+ call reverse_grid_r_uv (v2d,nxcase+1,nycase,1)
+ endif
+ if (ensgrid) then
+ call fv3uv2earthens(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d)
+ else
+ call fv3uv2earth(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d)
+ end if
+
+ ! NOTE on transfor to earth u/v:
+ ! The u and v before transferring need to be in E-W/N-S grid, which is
+ ! defined as reversed grid here because it is revered from map view.
+ !
+ ! Have set the following flag for grid orientation
+ ! grid_reverse_flag=true: E-W/N-S grid
+ ! grid_reverse_flag=false: W-E/S-N grid
+ !
+ ! So for preparing the wind transferring, need to reverse the grid from
+ ! W-E/S-N grid to E-W/N-S grid when grid_reverse_flag=false:
+ !
+ ! if(.not.grid_reverse_flag) call reverse_grid_r_uv
+ !
+ ! and the last input parameter for fv3_h_to_ll is alway true:
+ !
+ !
+ if (ensgrid) then
+ call fv3_h_to_ll_ens(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.)
+ call fv3_h_to_ll_ens(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.)
+ else
+ call fv3_h_to_ll(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.)
+ call fv3_h_to_ll(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.)
+ end if
+ enddo ! i
+
+ if(fv3_io_layout_y > 1) then
+ do nio=0,fv3_io_layout_y-1
+ iret=nf90_close(gfile_loc_layout(nio))
+ enddo
+ deallocate(gfile_loc_layout)
+ else
+ iret=nf90_close(gfile_loc)
+ endif
endif
- deallocate(u2d,v2d,uc2d,vc2d)
+ call mpi_barrier(mpi_comm_world,ierror)
+ deallocate(u2d,v2d,uc2d,vc2d)
+
call general_grid2sub(grd_uv,hwork,worksub)
ges_u=worksub(1,:,:,:)
ges_v=worksub(2,:,:,:)
deallocate(worksub)
end subroutine gsi_fv3ncdf_readuv
-subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin)
+subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
!$$$ subprogram documentation block
! subprogram: gsi_fv3ncdf_readuv_v1
! prgmmr: wu w org: np22 date: 2017-11-22
@@ -2550,25 +3072,28 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin)
!$$$ end documentation block
use constants, only: half
use kinds, only: r_kind,i_kind
- use mpimod, only: mpi_comm_world,mpi_rtype,mype,mpi_info_null
+ use mpimod, only: setcomm,mpi_integer,mpi_max, npe,mpi_comm_world,mpi_rtype,mype,mpi_info_null
use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr
- use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension
+ use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension
+ use netcdf, only: nf90_var_par_access,nf90_netcdf4
use netcdf, only: nf90_inquire_variable
use netcdf, only: nf90_inq_varid
- use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth
+ use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens
use general_sub2grid_mod, only: sub2grid_info,general_grid2sub
implicit none
- type(sub2grid_info), intent(in):: grd_uv
- real(r_kind) ,intent(out ) :: ges_u(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig)
- real(r_kind) ,intent(out ) :: ges_v(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig)
+ type(sub2grid_info), intent(in):: grd_uv
+ real(r_kind) , intent(out ) :: ges_u(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig)
+ real(r_kind) , intent(out ) :: ges_v(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig)
type (type_fv3regfilenameg),intent (in) :: fv3filenamegin
+ logical, intent(in ) :: ensgrid
+
real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork
character(len=:),allocatable :: filenamein
real(r_kind),allocatable,dimension(:,:):: us2d,vw2d
real(r_kind),allocatable,dimension(:,:):: uorv2d
real(r_kind),allocatable,dimension(:,:,:,:):: worksub
- character(len=max_varname_length) :: filenamein2
+ character(len=max_filename_length) :: filenamein2
character(len=max_varname_length) :: varname
integer(i_kind) nlatcase,nloncase
integer(i_kind) kbgn,kend
@@ -2580,22 +3105,52 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin)
integer(i_kind) nxcase,nycase
integer(i_kind) us_countloc(3),us_startloc(3)
integer(i_kind) vw_countloc(3),vw_startloc(3)
+ integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror
+ integer(i_kind),dimension(npe):: members,members_read,mype_read_rank
+ logical:: procuse
allocate (worksub(2,grd_uv%lat2,grd_uv%lon2,grd_uv%nsig))
mm1=mype+1
nloncase=grd_uv%nlon
nlatcase=grd_uv%nlat
- nxcase=nx
- nycase=ny
+ if (ensgrid) then
+ nxcase=nxens
+ nycase=nyens
+ else
+ nxcase=nx
+ nycase=ny
+ end if
kbgn=grd_uv%kbegin_loc
kend=grd_uv%kend_loc
allocate (us2d(nxcase,nycase+1),vw2d(nxcase+1,nycase))
allocate (uorv2d(nxcase,nycase))
+ procuse = .false.
+ members=-1
+ members_read=-1
+ if (kbgn<=kend) then
+ procuse = .true.
+ members(mm1) = mype
+ endif
+
+ call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror)
+
+ nread=0
+ mype_read_rank=-1
+ do i=1,npe
+ if (members_read(i) >= 0) then
+ nread=nread+1
+ mype_read_rank(nread) = members_read(i)
+ endif
+ enddo
+
+ call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror)
+
+ if (procuse) then
+
filenamein=fv3filenamegin%dynvars
- iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) !clt
+ iret=nf90_open(filenamein,ior(nf90_netcdf4,ior(nf90_nowrite,nf90_mpiio)),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt
if(iret/=nf90_noerr) then
write(6,*)' gsi_fv3ncdf_read_v1: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret
- call flush(6)
call stop2(333)
endif
@@ -2604,43 +3159,451 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin)
filenamein2=fv3filenamegin%dynvars
if(trim(filenamein) /= trim(filenamein2)) then
write(6,*)'filenamein and filenamein2 are not the same as expected, stop'
- call flush(6)
call stop2(333)
endif
ilev=grd_uv%lnames(1,ilevtot)
nz=grd_uv%nsig
nzp1=nz+1
inative=nzp1-ilev
- us_countloc= (/nlon_regional,nlat_regional+1,1/)
- vw_countloc= (/nlon_regional+1,nlat_regional,1/)
+ if (ensgrid) then
+ us_countloc= (/nlon_regionalens,nlat_regionalens+1,1/)
+ vw_countloc= (/nlon_regionalens+1,nlat_regionalens,1/)
+ else
+ us_countloc= (/nlon_regional,nlat_regional+1,1/)
+ vw_countloc= (/nlon_regional+1,nlat_regional,1/)
+ end if
us_startloc=(/1,1,inative+1/)
vw_startloc=(/1,1,inative+1/)
-! transfor to earth u/v, interpolate to analysis grid, reverse vertical order
- iret=nf90_inq_varid(gfile_loc,trim(adjustl("u_s")),var_id)
-
- iret=nf90_get_var(gfile_loc,var_id,us2d,start=us_startloc,count=us_countloc)
- iret=nf90_inq_varid(gfile_loc,trim(adjustl("v_w")),var_id)
- iret=nf90_get_var(gfile_loc,var_id,vw2d,start=vw_startloc,count=vw_countloc)
- do j=1,ny
- uorv2d(:,j)=half*(us2d(:,j)+us2d(:,j+1))
- enddo
-
- call fv3_h_to_ll(uorv2d(:,:),hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag)
- do j=1,nx
- uorv2d(j,:)=half*(vw2d(j,:)+vw2d(j+1,:))
- enddo
- call fv3_h_to_ll(uorv2d(:,:),hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag)
-
- enddo ! iilevtoto
- call general_grid2sub(grd_uv,hwork,worksub)
- ges_u=worksub(1,:,:,:)
- ges_v=worksub(2,:,:,:)
- iret=nf90_close(gfile_loc)
- deallocate (us2d,vw2d,worksub)
+! transfor to earth u/v, interpolate to analysis grid, reverse vertical order
+ call check(nf90_inq_varid(gfile_loc,trim(adjustl("u_s")),var_id))
+
+ call check(nf90_get_var(gfile_loc,var_id,us2d,start=us_startloc,count=us_countloc))
+ iret=nf90_inq_varid(gfile_loc,trim(adjustl("v_w")),var_id)
+ iret=nf90_get_var(gfile_loc,var_id,vw2d,start=vw_startloc,count=vw_countloc)
+ do j=1,ny
+ uorv2d(:,j)=half*(us2d(:,j)+us2d(:,j+1))
+ enddo
+
+ if (ensgrid) then
+ call fv3_h_to_ll_ens(uorv2d(:,:),hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.)
+ else
+ call fv3_h_to_ll(uorv2d(:,:),hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag)
+ end if
+ do j=1,nx
+ uorv2d(j,:)=half*(vw2d(j,:)+vw2d(j+1,:))
+ enddo
+ if (ensgrid) then
+ call fv3_h_to_ll_ens(uorv2d(:,:),hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.)
+ else
+ call fv3_h_to_ll(uorv2d(:,:),hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag)
+ end if
+
+ enddo ! iilevtoto
+ iret=nf90_close(gfile_loc)
+ endif !procuse
+ call general_grid2sub(grd_uv,hwork,worksub)
+ ges_u=worksub(1,:,:,:)
+ ges_v=worksub(2,:,:,:)
+ deallocate (us2d,vw2d,worksub)
+
+end subroutine gsi_fv3ncdf_readuv_v1
+
+subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, &
+ delp,tsen,w,q,oz,ql,qr,qs,qi,qg,dbz,fed,iope)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: gsi_fv3ncdf_read_ens_parallel_over_ens
+! program history log:
+! 2022-04-01 Y. Wang and X. Wang, changed from gsi_fv3ncdf_read_ens
+! for FV3LAM ensemble parallel IO in hybrid EnVar
+! poc: xuguang.wang@ou.edu
+!
+! abstract: read in fields excluding u and v
+! program history log:
+!
+! input argument list:
+! filenamein - file name to read from
+! iope - pe to read in the field
+!
+!
+! attributes:
+! language: f90
+! machine: ibm RS/6000 SP
+!
+!$$$ end documentation block
+
+
+ use kinds, only: r_kind,i_kind
+ use mpimod, only: mpi_comm_world,mpi_rtype,mype
+ use mpimod, only: MPI_INFO_NULL
+ use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr
+ use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension
+ use netcdf, only: nf90_inquire_variable
+ use netcdf, only: nf90_inq_varid
+ use gridmod, only: nsig,nlon,nlat
+ use mod_fv3_lola, only: fv3_h_to_ll
+ use gsi_bundlemod, only: gsi_bundle
+ use general_sub2grid_mod, only: sub2grid_info,general_grid2sub
+
+ implicit none
+ character(*), intent(in) :: filenamein
+ type (type_fv3regfilenameg), intent(in) ::fv3filenamegin
+ integer(i_kind) , intent(in) :: iope
+ real(r_kind),dimension(nlat,nlon,nsig),intent(out),optional:: delp,tsen,w,q,oz,ql,qr,qs,qi,qg,dbz,fed
+ real(r_kind),allocatable,dimension(:,:):: uu2d, uu2d_tmp
+ real(r_kind),dimension(nlat,nlon,nsig):: hwork
+ character(len=max_varname_length) :: varname
+ character(len=max_varname_length) :: name
+ character(len=max_filename_length), allocatable,dimension(:) :: varname_files
+
+ integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4),countloc_tmp(4),startloc_tmp(4)
+ integer(i_kind) ilev,ilevtot,inative,ivar
+ integer(i_kind) kbgn,kend
+ integer(i_kind) gfile_loc,iret,var_id
+ integer(i_kind) nz,nzp1,mm1,len,nx_phy
+ logical :: phy_smaller_domain
+! for io_layout > 1
+ real(r_kind),allocatable,dimension(:,:):: uu2d_layout
+ integer(i_kind) :: nio
+ integer(i_kind),allocatable :: gfile_loc_layout(:)
+ character(len=180) :: filename_layout
+
+ mm1=mype+1
+ nloncase=nlon
+ nlatcase=nlat
+ nxcase=nx
+ nycase=ny
+ kbgn=1
+ kend=nsig
+
+ if( mype == iope )then
+ allocate(uu2d(nxcase,nycase))
+ if( present(delp).or.present(tsen).or.present(w) )then ! dynvars
+ if( present(w) )then
+ allocate(varname_files(3))
+ varname_files = (/'T ','delp','W '/)
+ else
+ allocate(varname_files(2))
+ varname_files = (/'T ','delp'/)
+ end if
+ end if
+ if( present(q).or.present(ql).or.present(qr) )then ! tracers
+ if(present(qr))then
+ allocate(varname_files(7))
+ varname_files = (/'sphum ','o3mr ','liq_wat','ice_wat','rainwat','snowwat','graupel'/)
+ else
+ allocate(varname_files(2))
+ varname_files = (/'sphum',' o3mr'/)
+ end if
+ end if
+ if( present(dbz) .and. present(fed) )then ! phyvars: dbz, fed
+ allocate(varname_files(2))
+ varname_files = (/'ref_f3d ','flash_extent_density'/)
+ elseif( present(dbz) )then ! phyvars: dbz
+ allocate(varname_files(1))
+ varname_files = (/'ref_f3d'/)
+ elseif( present(fed) )then ! phyvars: fed
+ allocate(varname_files(1))
+ varname_files = (/'flash_extent_density'/)
+ end if
+
+
+ if(fv3_io_layout_y > 1) then
+ allocate(gfile_loc_layout(0:fv3_io_layout_y-1))
+ do nio=0,fv3_io_layout_y-1
+ write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio
+ iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL)
+ if(iret/=nf90_noerr) then
+ write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret
+ call stop2(333)
+ endif
+ enddo
+ else
+ iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc)
+ if(iret/=nf90_noerr) then
+ write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret
+ call stop2(333)
+ endif
+ endif
+ do ivar = 1, size(varname_files)
+ do ilevtot=kbgn,kend
+ ilev=ilevtot
+ nz=nsig
+ nzp1=nz+1
+ inative=nzp1-ilev
+ startloc=(/1,1,inative,1/)
+ countloc=(/nxcase,nycase,1,1/)
+ varname = trim(varname_files(ivar))
+ ! Variable ref_f3d in phy_data.nc has a smaller domain size than
+ ! dynvariables and tracers as well as a reversed order in vertical
+ if ( trim(adjustl(varname)) == 'ref_f3d' .or. trim(adjustl(varname)) == 'flash_extent_density' )then
+ iret=nf90_inquire_dimension(gfile_loc,1,name,len)
+ if(trim(name)=='xaxis_1') nx_phy=len
+ if( nx_phy == nxcase )then
+ allocate(uu2d_tmp(nxcase,nycase))
+ countloc_tmp=(/nxcase,nycase,1,1/)
+ phy_smaller_domain = .false.
+ else
+ allocate(uu2d_tmp(nxcase-6,nycase-6))
+ countloc_tmp=(/nxcase-6,nycase-6,1,1/)
+ phy_smaller_domain = .true.
+ end if
+ startloc_tmp=(/1,1,ilev,1/)
+ end if
+
+ if(fv3_io_layout_y > 1) then
+ do nio=0,fv3_io_layout_y-1
+ countloc=(/nxcase,ny_layout_len(nio),1,1/)
+ allocate(uu2d_layout(nxcase,ny_layout_len(nio)))
+ iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id)
+ iret=nf90_get_var(gfile_loc_layout(nio),var_id,uu2d_layout,start=startloc,count=countloc)
+ uu2d(:,ny_layout_b(nio):ny_layout_e(nio))=uu2d_layout
+ deallocate(uu2d_layout)
+ enddo
+ else
+ iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id)
+ if ( trim(adjustl(varname)) == 'ref_f3d' .or. trim(adjustl(varname)) == 'flash_extent_density' )then
+ uu2d = 0.0_r_kind
+ iret=nf90_get_var(gfile_loc,var_id,uu2d_tmp,start=startloc_tmp,count=countloc_tmp)
+ where(uu2d_tmp < 0.0_r_kind)
+ uu2d_tmp = 0.0_r_kind
+ endwhere
+ if(phy_smaller_domain)then
+ uu2d(4:nxcase-3,4:nycase-3) = uu2d_tmp
+ else
+ uu2d = uu2d_tmp
+ end if
+ deallocate(uu2d_tmp)
+ else
+ iret=nf90_get_var(gfile_loc,var_id,uu2d,start=startloc,count=countloc)
+ end if
+ endif
+ call fv3_h_to_ll(uu2d,hwork(:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,grid_reverse_flag)
+ enddo ! ilevtot
+ if( present(delp).or.present(tsen).or.present(w) )then ! dynvars
+ if(ivar == 1)then
+ tsen = hwork
+ else if(ivar == 2)then
+ delp = hwork
+ end if
+ if( present(w) .and. ivar == 3 )then
+ w = hwork
+ end if
+ end if
+ if( present(q).or.present(ql).or.present(qr) )then ! tracers
+ if(ivar == 1)then
+ q = hwork
+ else if(ivar == 2)then
+ oz = hwork
+ end if
+ if(present(qr))then
+ if(ivar == 3)then
+ ql = hwork
+ else if(ivar == 4)then
+ qi = hwork
+ else if(ivar == 5)then
+ qr = hwork
+ else if(ivar == 6)then
+ qs = hwork
+ else if(ivar == 7)then
+ qg = hwork
+ end if
+ end if
+ end if
+ if( present(dbz) .and. present(fed) )then ! phyvars: dbz,fed
+ if(ivar == 1) dbz = hwork
+ if(ivar == 2) fed = hwork
+ elseif( present(dbz) )then ! phyvars: dbz
+ dbz = hwork
+ elseif( present(fed) )then ! phyvars: fed
+ fed = hwork
+ end if
+
+ end do
+
+ if(fv3_io_layout_y > 1) then
+ do nio=1,fv3_io_layout_y-1
+ iret=nf90_close(gfile_loc_layout(nio))
+ enddo
+ deallocate(gfile_loc_layout)
+ else
+ iret=nf90_close(gfile_loc)
+ endif
+
+ deallocate (uu2d,varname_files)
+ end if
+
+ return
+end subroutine gsi_fv3ncdf_read_ens_parallel_over_ens
+
+subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,iope)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: gsi_fv3ncdf_readuv_ens_parallel_over_ens
+! program history log:
+! 2022-04-01 Y. Wang and X. Wang, changed from gsi_fv3ncdf_readuv_ens
+! for FV3LAM ensemble parallel IO in hybrid EnVar
+! poc: xuguang.wang@ou.edu
+!
+! abstract: read in a field from a netcdf FV3 file in mype_u,mype_v
+! then scatter the field to each PE
+! program history log:
+!
+! input argument list:
+!
+! output argument list:
+! ges_u - output sub domain u field
+! ges_v - output sub domain v field
+!
+! attributes:
+! language: f90
+! machine: ibm RS/6000 SP
+!
+!$$$ end documentation block
+ use kinds, only: r_kind,i_kind
+ use mpimod, only: mpi_comm_world,mpi_rtype,mype,mpi_info_null
+ use gridmod, only: nsig,nlon,nlat
+ use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr
+ use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension
+ use netcdf, only: nf90_inquire_variable
+ use netcdf, only: nf90_inq_varid
+ use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth
+ use general_sub2grid_mod, only: sub2grid_info,general_grid2sub
+
+ implicit none
+ real(r_kind) ,intent(out ) :: ges_u(nlat,nlon,nsig)
+ real(r_kind) ,intent(out ) :: ges_v(nlat,nlon,nsig)
+ type (type_fv3regfilenameg),intent (in) :: fv3filenamegin
+ integer(i_kind),intent(in) :: iope
+
+ real(r_kind),dimension(2,nlat,nlon,nsig):: hwork
+ character(:), allocatable:: filenamein
+ real(r_kind),allocatable,dimension(:,:):: u2d,v2d
+ real(r_kind),allocatable,dimension(:,:):: uc2d,vc2d
+ integer(i_kind) u_grd_VarId,v_grd_VarId
+ integer(i_kind) nlatcase,nloncase
+ integer(i_kind) nxcase,nycase
+ integer(i_kind) u_countloc(4),u_startloc(4),v_countloc(4),v_startloc(4)
+ integer(i_kind) inative,ilev,ilevtot
+ integer(i_kind) kbgn,kend
+
+ integer(i_kind) gfile_loc,iret
+ integer(i_kind) nz,nzp1,mm1
+
+! for fv3_io_layout_y > 1
+ real(r_kind),allocatable,dimension(:,:):: u2d_layout,v2d_layout
+ integer(i_kind) :: nio
+ integer(i_kind),allocatable :: gfile_loc_layout(:)
+ character(len=180) :: filename_layout
+
+ mm1=mype+1
+ nloncase=nlon
+ nlatcase=nlat
+ nxcase=nx
+ nycase=ny
+ kbgn=1
+ kend=nsig
+ if( mype == iope )then
+ allocate(u2d(nxcase,nycase+1))
+ allocate(v2d(nxcase+1,nycase))
+ allocate(uc2d(nxcase,nycase))
+ allocate(vc2d(nxcase,nycase))
+ filenamein=fv3filenamegin%dynvars
+
+ if(fv3_io_layout_y > 1) then
+ allocate(gfile_loc_layout(0:fv3_io_layout_y-1))
+ do nio=0,fv3_io_layout_y-1
+ write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio
+ iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL)
+ if(iret/=nf90_noerr) then
+ write(6,*)'problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret
+ call stop2(333)
+ endif
+ enddo
+ else
+ iret=nf90_open(filenamein,nf90_nowrite,gfile_loc)
+ if(iret/=nf90_noerr) then
+ write(6,*)' problem opening ',trim(filenamein),', Status = ',iret
+ call stop2(333)
+ endif
+ endif
+ do ilevtot=kbgn,kend
+ ilev=ilevtot
+ nz=nsig
+ nzp1=nz+1
+ inative=nzp1-ilev
+ u_countloc=(/nxcase,nycase+1,1,1/)
+ v_countloc=(/nxcase+1,nycase,1,1/)
+ u_startloc=(/1,1,inative,1/)
+ v_startloc=(/1,1,inative,1/)
+
+ if(fv3_io_layout_y > 1) then
+ do nio=0,fv3_io_layout_y-1
+ u_countloc=(/nxcase,ny_layout_len(nio)+1,1,1/)
+ allocate(u2d_layout(nxcase,ny_layout_len(nio)+1))
+ call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) )
+ iret=nf90_get_var(gfile_loc_layout(nio),u_grd_VarId,u2d_layout,start=u_startloc,count=u_countloc)
+ u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio))
+ if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1)
+ deallocate(u2d_layout)
+
+ v_countloc=(/nxcase+1,ny_layout_len(nio),1,1/)
+ allocate(v2d_layout(nxcase+1,ny_layout_len(nio)))
+ call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) )
+ iret=nf90_get_var(gfile_loc_layout(nio),v_grd_VarId,v2d_layout,start=v_startloc,count=v_countloc)
+ v2d(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout
+ deallocate(v2d_layout)
+ enddo
+ else
+ call check( nf90_inq_varid(gfile_loc,'u',u_grd_VarId) )
+ iret=nf90_get_var(gfile_loc,u_grd_VarId,u2d,start=u_startloc,count=u_countloc)
+ call check( nf90_inq_varid(gfile_loc,'v',v_grd_VarId) )
+ iret=nf90_get_var(gfile_loc,v_grd_VarId,v2d,start=v_startloc,count=v_countloc)
+ endif
+
+ if(.not.grid_reverse_flag) then
+ call reverse_grid_r_uv (u2d,nxcase,nycase+1,1)
+ call reverse_grid_r_uv (v2d,nxcase+1,nycase,1)
+ endif
+ call fv3uv2earth(u2d(:,:),v2d(:,:),nxcase,nycase,uc2d,vc2d)
+
+ ! NOTE on transfor to earth u/v:
+ ! The u and v before transferring need to be in E-W/N-S grid, which is
+ ! defined as reversed grid here because it is revered from map view.
+ !
+ ! Have set the following flag for grid orientation
+ ! grid_reverse_flag=true: E-W/N-S grid
+ ! grid_reverse_flag=false: W-E/S-N grid
+ !
+ ! So for preparing the wind transferring, need to reverse the grid
+ ! from
+ ! W-E/S-N grid to E-W/N-S grid when grid_reverse_flag=false:
+ !
+ ! if(.not.grid_reverse_flag) call reverse_grid_r_uv
+ !
+ ! and the last input parameter for fv3_h_to_ll is alway true:
+ !
+ !
+ call fv3_h_to_ll(uc2d,hwork(1,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.)
+ call fv3_h_to_ll(vc2d,hwork(2,:,:,ilevtot),nxcase,nycase,nloncase,nlatcase,.true.)
+ enddo ! ilevtot
+ if(fv3_io_layout_y > 1) then
+ do nio=0,fv3_io_layout_y-1
+ iret=nf90_close(gfile_loc_layout(nio))
+ enddo
+ deallocate(gfile_loc_layout)
+ else
+ iret=nf90_close(gfile_loc)
+ endif
+ deallocate(u2d,v2d,uc2d,vc2d)
+ ges_u = hwork(1,:,:,:)
+ ges_v = hwork(2,:,:,:)
+ end if ! mype
+
+end subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens
-end subroutine gsi_fv3ncdf_readuv_v1
subroutine wrfv3_netcdf(fv3filenamegin)
!$$$ subprogram documentation block
@@ -2653,7 +3616,10 @@ subroutine wrfv3_netcdf(fv3filenamegin)
! program history log:
! 2019-04-18 CAPS(C. Tong) - import direct reflectivity DA capabilities
! 2019-11-22 CAPS(C. Tong) - modify "add_saved" to properly output analyses
-! 2021-01-05 x.zhang/lei - add code for updating delz analysis in regional da
+! 2021-01-05 x.zhang/lei - add code for updating delz analysis in regional da
+! 2022-04-01 Y. Wang and X. Wang - add code for updating reflectivity
+! 2023-07-30 Zhao - added code for the output of the analysis of
+! significant wave height (howv)
!
! input argument list:
!
@@ -2680,6 +3646,7 @@ subroutine wrfv3_netcdf(fv3filenamegin)
use directDA_radaruse_mod, only: l_cvpnr, cvpnr_pval
use gridmod, only: eta1_ll,eta2_ll
use constants, only: one
+ use obsmod, only: if_model_dbz,if_model_fed
implicit none
@@ -2695,6 +3662,8 @@ subroutine wrfv3_netcdf(fv3filenamegin)
real(r_kind),pointer,dimension(:,:,:):: ges_q =>NULL()
real(r_kind),pointer,dimension(:,: ):: ges_t2m =>NULL()
real(r_kind),pointer,dimension(:,: ):: ges_q2m =>NULL()
+ real(r_kind),pointer,dimension(:,: ):: ges_howv =>NULL()
+ real(r_kind),pointer,dimension(:,: ):: ges_gust =>NULL()
integer(i_kind) i,k
@@ -2705,6 +3674,8 @@ subroutine wrfv3_netcdf(fv3filenamegin)
real(r_kind),pointer,dimension(:,:,:):: ges_qg =>NULL()
real(r_kind),pointer,dimension(:,:,:):: ges_qnr =>NULL()
real(r_kind),pointer,dimension(:,:,:):: ges_w =>NULL()
+ real(r_kind),pointer,dimension(:,:,:):: ges_dbz =>NULL()
+ real(r_kind),pointer,dimension(:,:,:):: ges_fed =>NULL()
real(r_kind),pointer,dimension(:,:,:):: ges_delzinc =>NULL()
real(r_kind),pointer,dimension(:,:,:):: ges_delp =>NULL()
real(r_kind),dimension(:,: ),allocatable:: ges_ps_write
@@ -2794,19 +3765,31 @@ subroutine wrfv3_netcdf(fv3filenamegin)
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'u' , ges_u ,istatus);ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'v' , ges_v ,istatus);ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q ,istatus);ier=ier+istatus
- if (l_use_dbz_directDA) then
+ if (l_use_dbz_directDA .or. if_model_dbz .or.if_model_fed) then
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ql' ,ges_ql ,istatus);ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qi' ,ges_qi ,istatus);ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qr' ,ges_qr ,istatus);ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qs' ,ges_qs ,istatus);ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qg' ,ges_qg ,istatus);ier=ier+istatus
+ if (l_use_dbz_directDA) &
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'qnr',ges_qnr,istatus);ier=ier+istatus
call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'w' , ges_w ,istatus);ier=ier+istatus
+ if( if_model_dbz )&
+ call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'dbz' , ges_dbz ,istatus);ier=ier+istatus
+ if( if_model_fed )&
+ call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'fed' , ges_fed ,istatus);ier=ier+istatus
end if
if(i_use_2mq4b > 0 .and. i_use_2mt4b > 0 ) then
call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'q2m',ges_q2m,istatus); ier=ier+istatus
call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'t2m',ges_t2m,istatus );ier=ier+istatus
endif
+ if ( i_howv_3dda == 1 ) then
+ call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'howv',ges_howv,istatus); ier=ier+istatus
+ endif
+ if ( i_gust_3dda == 1 ) then
+ call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'gust',ges_gust,istatus); ier=ier+istatus
+ endif
+ if (ier/=0) call die('wrfv3_netcdf','cannot get pointers for fv3 met-fields, ier =',ier)
if (laeroana_fv3cmaq) then
call GSI_BundleGetPointer ( GSI_ChemGuess_Bundle(it), 'aalj',ges_aalj,istatus );ier=ier+istatus
@@ -2931,6 +3914,7 @@ subroutine wrfv3_netcdf(fv3filenamegin)
call gsi_copy_bundle(GSI_MetGuess_Bundle(it),gsibundle_fv3lam_dynvar_nouv)
call gsi_copy_bundle(GSI_MetGuess_Bundle(it),gsibundle_fv3lam_tracer_nouv)
+ if( if_model_dbz .or. if_model_fed ) call gsi_copy_bundle(GSI_MetGuess_Bundle(it),gsibundle_fv3lam_phyvar_nouv)
if (laeroana_fv3cmaq) then
call gsi_copy_bundle(GSI_ChemGuess_Bundle(it),gsibundle_fv3lam_tracerchem_nouv)
end if
@@ -2979,6 +3963,11 @@ subroutine wrfv3_netcdf(fv3filenamegin)
add_saved,fv3filenamegin%dynvars,fv3filenamegin)
call gsi_fv3ncdf_write(grd_fv3lam_tracer_ionouv,gsibundle_fv3lam_tracer_nouv, &
add_saved,fv3filenamegin%tracers,fv3filenamegin)
+ if( if_model_dbz .or. if_model_fed ) then
+ call gsi_fv3ncdf_write(grd_fv3lam_phyvar_ionouv,gsibundle_fv3lam_phyvar_nouv,&
+ add_saved,fv3filenamegin%phyvars,fv3filenamegin)
+ end if
+
call gsi_fv3ncdf_writeuv(grd_fv3lam_uv,ges_u,ges_v,add_saved,fv3filenamegin)
if (laeroana_fv3cmaq) then
call gsi_fv3ncdf_write(grd_fv3lam_tracerchem_ionouv,gsibundle_fv3lam_tracerchem_nouv, &
@@ -3010,6 +3999,14 @@ subroutine wrfv3_netcdf(fv3filenamegin)
call gsi_fv3ncdf_write_sfc(fv3filenamegin,'t2m',ges_t2m,add_saved)
call gsi_fv3ncdf_write_sfc(fv3filenamegin,'q2m',ges_q2m,add_saved)
endif
+!-- output analysis of howv
+ if ( i_howv_3dda == 1 ) then
+ call gsi_fv3ncdf_write_sfc(fv3filenamegin,'howv',ges_howv,add_saved)
+ endif
+!-- output analysis of gust
+ if ( i_gust_3dda == 1 ) then
+ call gsi_fv3ncdf_write_sfc(fv3filenamegin,'gust',ges_gust,add_saved)
+ endif
if(allocated(g_prsi)) deallocate(g_prsi)
@@ -3045,44 +4042,50 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
!
!$$$ end documentation block
- use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null
+ use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null,npe,setcomm,mpi_integer,mpi_max
use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension
use gridmod, only: nlon_regional,nlat_regional
use mod_fv3_lola, only: fv3_ll_to_h,fv3_h_to_ll, &
fv3uv2earth,earthuv2fv3
use netcdf, only: nf90_open,nf90_close,nf90_noerr
- use netcdf, only: nf90_write,nf90_inq_varid
+ use netcdf, only: nf90_write,nf90_mpiio,nf90_inq_varid,nf90_var_par_access,nf90_collective
use netcdf, only: nf90_put_var,nf90_get_var
use general_sub2grid_mod, only: sub2grid_info,general_sub2grid
implicit none
type(sub2grid_info), intent(in):: grd_uv
- real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork
- logical ,intent(in ) :: add_saved
+ logical, intent(in ) :: add_saved
type (type_fv3regfilenameg),intent(in) ::fv3filenamegin
real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_u
real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_v
+ real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork
integer(i_kind) :: ugrd_VarId,gfile_loc,vgrd_VarId
integer(i_kind) i,j,mm1,k,nzp1
integer(i_kind) kbgn,kend
integer(i_kind) inative,ilev,ilevtot
integer(i_kind) nlatcase,nloncase
integer(i_kind) nxcase,nycase
- integer(i_kind) u_countloc(3),u_startloc(3),v_countloc(3),v_startloc(3)
+ integer(i_kind) u_countloc(4),u_startloc(4),v_countloc(4),v_startloc(4)
character(:),allocatable:: filenamein ,varname
real(r_kind),allocatable,dimension(:,:,:,:):: worksub
real(r_kind),allocatable,dimension(:,:):: work_au,work_av
- real(r_kind),allocatable,dimension(:,:):: work_bu,work_bv
+ real(r_kind),allocatable,dimension(:,:,:):: work_bu,work_bv
real(r_kind),allocatable,dimension(:,:):: u2d,v2d,workau2,workav2
real(r_kind),allocatable,dimension(:,:):: workbu2,workbv2
+ integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,ierror
+ integer(i_kind),dimension(npe):: members,members_read,mype_read_rank
+ logical:: procuse
+
! for fv3_io_layout_y > 1
- real(r_kind),allocatable,dimension(:,:):: u2d_layout,v2d_layout
+ real(r_kind),allocatable,dimension(:,:,:):: u2d_layout,v2d_layout
integer(i_kind) :: nio
integer(i_kind),allocatable :: gfile_loc_layout(:)
character(len=180) :: filename_layout
+ integer(i_kind):: kend_native,kbgn_native
+ integer(i_kind):: istat
mm1=mype+1
@@ -3094,8 +4097,6 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
kend=grd_uv%kend_loc
allocate( u2d(nlon_regional,nlat_regional+1))
allocate( v2d(nlon_regional+1,nlat_regional))
- allocate( work_bu(nlon_regional,nlat_regional+1))
- allocate( work_bv(nlon_regional+1,nlat_regional))
allocate (worksub(2,grd_uv%lat2,grd_uv%lon2,grd_uv%nsig))
allocate( work_au(nlatcase,nloncase),work_av(nlatcase,nloncase))
do k=1,grd_uv%nsig
@@ -3109,116 +4110,154 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
call general_sub2grid(grd_uv,worksub,hwork)
filenamein=fv3filenamegin%dynvars
- if(fv3_io_layout_y > 1) then
- allocate(gfile_loc_layout(0:fv3_io_layout_y-1))
- do nio=0,fv3_io_layout_y-1
- write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio
- call check( nf90_open(filename_layout,nf90_write,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) )
- enddo
- gfile_loc=gfile_loc_layout(0)
- else
- call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) )
+
+ procuse = .false.
+ members=-1
+ members_read=-1
+ if (kbgn<=kend) then
+ procuse = .true.
+ members(mm1) = mype
endif
- do ilevtot=kbgn,kend
- varname=grd_uv%names(1,ilevtot)
- ilev=grd_uv%lnames(1,ilevtot)
- nz=grd_uv%nsig
- nzp1=nz+1
- inative=nzp1-ilev
- u_countloc=(/nxcase,nycase+1,1/)
- v_countloc=(/nxcase+1,nycase,1/)
- u_startloc=(/1,1,inative/)
- v_startloc=(/1,1,inative/)
+ call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror)
- work_au=hwork(1,:,:,ilevtot)
- work_av=hwork(2,:,:,ilevtot)
+ nread=0
+ mype_read_rank=-1
+ do i=1,npe
+ if (members_read(i) >= 0) then
+ nread=nread+1
+ mype_read_rank(nread) = members_read(i)
+ endif
+ enddo
- call check( nf90_inq_varid(gfile_loc,'u',ugrd_VarId) )
- call check( nf90_inq_varid(gfile_loc,'v',vgrd_VarId) )
+ call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror)
- if(add_saved)then
- allocate( workau2(nlatcase,nloncase),workav2(nlatcase,nloncase))
- allocate( workbu2(nlon_regional,nlat_regional+1))
- allocate( workbv2(nlon_regional+1,nlat_regional))
-!!!!!!!! readin work_b !!!!!!!!!!!!!!!!
- if(fv3_io_layout_y > 1) then
+ if (procuse) then
+ if(fv3_io_layout_y > 1) then
+ allocate(gfile_loc_layout(0:fv3_io_layout_y-1))
+ do nio=0,fv3_io_layout_y-1
+ write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio
+ call check( nf90_open(filename_layout,ior(nf90_write, nf90_mpiio),gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) )
+ enddo
+ gfile_loc=gfile_loc_layout(0)
+ else
+ call check( nf90_open(filenamein,ior(nf90_write, nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) )
+ endif
+ nz=grd_uv%nsig
+ nzp1=nz+1
+ kend_native=nzp1-grd_uv%lnames(1,kbgn)
+ kbgn_native=nzp1-grd_uv%lnames(1,kend)
+ allocate( work_bu(nlon_regional,nlat_regional+1,kbgn_native:kend_native))
+ allocate( work_bv(nlon_regional+1,nlat_regional,kbgn_native:kend_native))
+ u_startloc=(/1,1,kbgn_native,1/)
+ u_countloc=(/nxcase,nycase+1,kend_native-kbgn_native+1,1/)
+ v_startloc=(/1,1,kbgn_native,1/)
+ v_countloc=(/nxcase+1,nycase,kend_native-kbgn_native+1,1/)
+ if(fv3_io_layout_y > 1) then
do nio=0,fv3_io_layout_y-1
- allocate(u2d_layout(nxcase,ny_layout_len(nio)+1))
- u_countloc=(/nxcase,ny_layout_len(nio)+1,1/)
- call check( nf90_get_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) )
- work_bu(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio))
- if(nio==fv3_io_layout_y-1) work_bu(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1)
- deallocate(u2d_layout)
-
- allocate(v2d_layout(nxcase+1,ny_layout_len(nio)))
- v_countloc=(/nxcase+1,ny_layout_len(nio),1/)
- call check( nf90_get_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) )
- work_bv(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout
- deallocate(v2d_layout)
+ allocate(u2d_layout(nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1))
+ u_countloc=(/nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1,1/)
+ call check( nf90_get_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) )
+ work_bu(:,ny_layout_b(nio):ny_layout_e(nio),:)=u2d_layout(:,1:ny_layout_len(nio),:)
+ if(nio==fv3_io_layout_y-1) work_bu(:,ny_layout_e(nio)+1,:)=u2d_layout(:,ny_layout_len(nio)+1,:)
+ deallocate(u2d_layout)
+
+ allocate(v2d_layout(nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1))
+ v_countloc=(/nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1,1/)
+ call check( nf90_get_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) )
+ work_bv(:,ny_layout_b(nio):ny_layout_e(nio),:)=v2d_layout
+ deallocate(v2d_layout)
enddo
- else
+ else
+ call check( nf90_inq_varid(gfile_loc,'u',ugrd_VarId) )
+ call check( nf90_inq_varid(gfile_loc,'v',vgrd_VarId) )
+ call check( nf90_var_par_access(gfile_loc, ugrd_VarId, nf90_collective))
+ call check( nf90_var_par_access(gfile_loc, vgrd_VarId, nf90_collective))
call check( nf90_get_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) )
call check( nf90_get_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) )
- endif
- if(.not.grid_reverse_flag) then
- call reverse_grid_r_uv(work_bu,nlon_regional,nlat_regional+1,1)
- call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1)
- endif
- call fv3uv2earth(work_bu,work_bv,nlon_regional,nlat_regional,u2d,v2d)
- call fv3_h_to_ll(u2d,workau2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.)
- call fv3_h_to_ll(v2d,workav2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.)
+ endif
+
+
+
+ do ilevtot=kbgn,kend
+ varname=grd_uv%names(1,ilevtot)
+ ilev=grd_uv%lnames(1,ilevtot)
+ inative=nzp1-ilev
+
+ work_au=hwork(1,:,:,ilevtot)
+ work_av=hwork(2,:,:,ilevtot)
+
+
+ if(add_saved)then
+ allocate( workau2(nlatcase,nloncase),workav2(nlatcase,nloncase))
+ allocate( workbu2(nlon_regional,nlat_regional+1))
+ allocate( workbv2(nlon_regional+1,nlat_regional))
+!!!!!!!! readin work_b !!!!!!!!!!!!!!!!
+
+!clt for fv3_io_layout<=1 now the nf90_get_var has been moved outside of this do loop
+!to avoid failure on hercules when L_MPI_EXTRA_FILESYSTEM=1
+ if(.not.grid_reverse_flag) then
+ call reverse_grid_r_uv(work_bu(:,:,inative),nlon_regional,nlat_regional+1,1)
+ call reverse_grid_r_uv(work_bv(:,:,inative),nlon_regional+1,nlat_regional,1)
+ endif
+ call fv3uv2earth(work_bu(:,:,inative),work_bv(:,:,inative),nlon_regional,nlat_regional,u2d,v2d)
+ call fv3_h_to_ll(u2d,workau2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.)
+ call fv3_h_to_ll(v2d,workav2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.)
!!!!!!!! find analysis_inc: work_a !!!!!!!!!!!!!!!!
- work_au(:,:)=work_au(:,:)-workau2(:,:)
- work_av(:,:)=work_av(:,:)-workav2(:,:)
- call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.)
- call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.)
- call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,workbu2,workbv2)
+ work_au(:,:)=work_au(:,:)-workau2(:,:)
+ work_av(:,:)=work_av(:,:)-workav2(:,:)
+ call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.)
+ call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.)
+ call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,workbu2,workbv2)
!!!!!!!! add analysis_inc to readin work_b !!!!!!!!!!!!!!!!
- work_bu(:,:)=work_bu(:,:)+workbu2(:,:)
- work_bv(:,:)=work_bv(:,:)+workbv2(:,:)
- deallocate(workau2,workbu2,workav2,workbv2)
- else
- call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.)
- call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.)
- call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,work_bu(:,:),work_bv(:,:))
- endif
- if(.not.grid_reverse_flag) then
- call reverse_grid_r_uv(work_bu,nlon_regional,nlat_regional+1,1)
- call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1)
- endif
-
- if(fv3_io_layout_y > 1) then
- do nio=0,fv3_io_layout_y-1
- allocate(u2d_layout(nxcase,ny_layout_len(nio)+1))
- u_countloc=(/nxcase,ny_layout_len(nio)+1,1/)
- u2d_layout=work_bu(:,ny_layout_b(nio):ny_layout_e(nio)+1)
- call check( nf90_put_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) )
- deallocate(u2d_layout)
-
- allocate(v2d_layout(nxcase+1,ny_layout_len(nio)))
- v_countloc=(/nxcase+1,ny_layout_len(nio),1/)
- v2d_layout=work_bv(:,ny_layout_b(nio):ny_layout_e(nio))
- call check( nf90_put_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) )
- deallocate(v2d_layout)
- enddo
- else
- call check( nf90_put_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) )
- call check( nf90_put_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) )
- endif
- enddo !ilevltot
+ work_bu(:,:,inative)=work_bu(:,:,inative)+workbu2(:,:)
+ work_bv(:,:,inative)=work_bv(:,:,inative)+workbv2(:,:)
+ deallocate(workau2,workbu2,workav2,workbv2)
+ else
+ call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.)
+ call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.)
+ call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,work_bu(:,:,inative),work_bv(:,:,inative))
+ endif
+ if(.not.grid_reverse_flag) then
+ call reverse_grid_r_uv(work_bu(:,:,inative),nlon_regional,nlat_regional+1,1)
+ call reverse_grid_r_uv(work_bv(:,:,inative),nlon_regional+1,nlat_regional,1)
+ endif
+ enddo !ilevltot
+
+ if(fv3_io_layout_y > 1) then
+ do nio=0,fv3_io_layout_y-1
+ allocate(u2d_layout(nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1))
+ u_countloc=(/nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1,1/)
+ u2d_layout=work_bu(:,ny_layout_b(nio):ny_layout_e(nio)+1,:)
+ call check( nf90_put_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) )
+ deallocate(u2d_layout)
+
+ allocate(v2d_layout(nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1))
+ v_countloc=(/nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1,1/)
+ v2d_layout=work_bv(:,ny_layout_b(nio):ny_layout_e(nio),:)
+ call check( nf90_put_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) )
+ deallocate(v2d_layout)
+ enddo
+ else
+ call check( nf90_put_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) )
+ call check( nf90_put_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) )
+ endif
- if(fv3_io_layout_y > 1) then
- do nio=0,fv3_io_layout_y-1
- call check( nf90_close(gfile_loc_layout(nio)) )
- enddo
- deallocate(gfile_loc_layout)
- else
- call check( nf90_close(gfile_loc) )
+ if(fv3_io_layout_y > 1) then
+ do nio=0,fv3_io_layout_y-1
+ call check( nf90_close(gfile_loc_layout(nio)) )
+ enddo
+ deallocate(gfile_loc_layout)
+ else
+ call check( nf90_close(gfile_loc) )
+ endif
+ deallocate(work_bu,work_bv)
endif
- deallocate(work_bu,work_bv,u2d,v2d)
- deallocate(work_au,work_av)
+ call mpi_barrier(mpi_comm_world,ierror)
+
+ deallocate(u2d,v2d)
+ deallocate(work_au,work_av)
end subroutine gsi_fv3ncdf_writeuv
subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
@@ -3249,20 +4288,21 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
!$$$ end documentation block
use constants, only: half,zero
- use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null
+ use mpimod, only: npe, setcomm,mpi_integer,mpi_max,mpi_rtype,mpi_comm_world,mype,mpi_info_null
use gridmod, only: nlon_regional,nlat_regional
use mod_fv3_lola, only: fv3_ll_to_h,fv3_h_to_ll, &
fv3uv2earth,earthuv2fv3
use netcdf, only: nf90_open,nf90_close,nf90_noerr
- use netcdf, only: nf90_write,nf90_inq_varid
+ use netcdf, only: nf90_write, nf90_mpiio,nf90_inq_varid,nf90_var_par_access,nf90_collective
use netcdf, only: nf90_put_var,nf90_get_var
use general_sub2grid_mod, only: sub2grid_info,general_sub2grid
implicit none
- type(sub2grid_info), intent(in):: grd_uv
+ type(sub2grid_info), intent(in) :: grd_uv
real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_u
real(r_kind),dimension(grd_uv%lat2,grd_uv%lon2,grd_uv%nsig),intent(inout)::ges_v
- logical ,intent(in ) :: add_saved
- type (type_fv3regfilenameg),intent (in) :: fv3filenamegin
+ logical, intent(in) :: add_saved
+ type (type_fv3regfilenameg),intent(in) :: fv3filenamegin
+
real(r_kind),dimension(2,grd_uv%nlat,grd_uv%nlon,grd_uv%kbegin_loc:grd_uv%kend_alloc):: hwork
character(len=:),allocatable :: filenamein
character(len=max_varname_length) :: varname
@@ -3275,14 +4315,20 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
integer(i_kind) inative,ilev,ilevtot
real(r_kind),allocatable,dimension(:,:,:,:):: worksub
real(r_kind),allocatable,dimension(:,:):: work_au,work_av
- real(r_kind),allocatable,dimension(:,:):: work_bu_s,work_bv_s
- real(r_kind),allocatable,dimension(:,:):: work_bu_w,work_bv_w
+ real(r_kind),allocatable,dimension(:,:,:):: work_bu_s,work_bv_s
+ real(r_kind),allocatable,dimension(:,:,:):: work_bu_w,work_bv_w
real(r_kind),allocatable,dimension(:,:):: u2d,v2d,workau2,workav2
real(r_kind),allocatable,dimension(:,:):: workbu_s2,workbv_s2
real(r_kind),allocatable,dimension(:,:):: workbu_w2,workbv_w2
integer(i_kind) nlatcase,nloncase,nxcase,nycase
- integer(i_kind) uw_countloc(3),us_countloc(3),uw_startloc(3),us_startloc(3)
- integer(i_kind) vw_countloc(3),vs_countloc(3),vw_startloc(3),vs_startloc(3)
+ integer(i_kind) uw_countloc(4),us_countloc(4),uw_startloc(4),us_startloc(4)
+ integer(i_kind) vw_countloc(4),vs_countloc(4),vw_startloc(4),vs_startloc(4)
+ integer(i_kind):: kend_native,kbgn_native,kdim_native
+
+
+ integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,ierror
+ integer(i_kind),dimension(npe):: members,members_read,mype_read_rank
+ logical:: procuse
mm1=mype+1
nloncase=grd_uv%nlon
@@ -3304,61 +4350,96 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
allocate( u2d(nlon_regional,nlat_regional))
allocate( v2d(nlon_regional,nlat_regional))
- allocate( work_bu_s(nlon_regional,nlat_regional+1))
- allocate( work_bv_s(nlon_regional,nlat_regional+1))
- allocate( work_bu_w(nlon_regional+1,nlat_regional))
- allocate( work_bv_w(nlon_regional+1,nlat_regional))
allocate( work_au(nlatcase,nloncase),work_av(nlatcase,nloncase))
+
if(add_saved) allocate( workau2(nlatcase,nloncase),workav2(nlatcase,nloncase))
- allocate( workbu_w2(nlon_regional+1,nlat_regional))
- allocate( workbv_w2(nlon_regional+1,nlat_regional))
- allocate( workbu_s2(nlon_regional,nlat_regional+1))
- allocate( workbv_s2(nlon_regional,nlat_regional+1))
+ allocate( workbu_w2(nlon_regional+1,nlat_regional))
+ allocate( workbv_w2(nlon_regional+1,nlat_regional))
+ allocate( workbu_s2(nlon_regional,nlat_regional+1))
+ allocate( workbv_s2(nlon_regional,nlat_regional+1))
filenamein=fv3filenamegin%dynvars
- call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) )
- do ilevtot=kbgn,kend
- varname=grd_uv%names(1,ilevtot)
- ilev=grd_uv%lnames(1,ilevtot)
- nz=grd_uv%nsig
- nzp1=nz+1
- inative=nzp1-ilev
+
+
+ procuse = .false.
+ members=-1
+ members_read=-1
+ if (kbgn<=kend) then
+ procuse = .true.
+ members(mm1) = mype
+ endif
+
+ call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror)
+
+ nread=0
+ mype_read_rank=-1
+ do i=1,npe
+ if (members_read(i) >= 0) then
+ nread=nread+1
+ mype_read_rank(nread) = members_read(i)
+ endif
+ enddo
+
+ call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror)
+
+ if (procuse) then
+
- uw_countloc= (/nlon_regional+1,nlat_regional,1/)
- us_countloc= (/nlon_regional,nlat_regional+1,1/)
- vw_countloc= (/nlon_regional+1,nlat_regional,1/)
- vs_countloc= (/nlon_regional,nlat_regional+1,1/)
+ call check( nf90_open(filenamein,ior(nf90_write, nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) )
+
+ call check( nf90_inq_varid(gfile_loc,'u_s',u_sgrd_VarId) )
+ call check( nf90_var_par_access(gfile_loc, u_sgrd_VarId, nf90_collective))
+ call check( nf90_inq_varid(gfile_loc,'u_w',u_wgrd_VarId) )
+ call check( nf90_var_par_access(gfile_loc, u_wgrd_VarId, nf90_collective))
+ call check( nf90_inq_varid(gfile_loc,'v_s',v_sgrd_VarId) )
+ call check( nf90_var_par_access(gfile_loc, v_sgrd_VarId, nf90_collective))
+ call check( nf90_inq_varid(gfile_loc,'v_w',v_wgrd_VarId) )
+ call check( nf90_var_par_access(gfile_loc, v_wgrd_VarId, nf90_collective))
+ nz=grd_uv%nsig
+ nzp1=nz+1
+ kend_native=nzp1-grd_uv%lnames(1,kbgn)
+ kbgn_native=nzp1-grd_uv%lnames(1,kend)
+ kdim_native=kend_native-kbgn_native+1
+
+ uw_countloc= (/nlon_regional+1,nlat_regional,kdim_native,1/)
+ us_countloc= (/nlon_regional,nlat_regional+1,kdim_native,1/)
+ vw_countloc= (/nlon_regional+1,nlat_regional,kdim_native,1/)
+ vs_countloc= (/nlon_regional,nlat_regional+1,kdim_native,1/)
- uw_startloc=(/1,1,inative+1/)
- us_startloc=(/1,1,inative+1/)
- vw_startloc=(/1,1,inative+1/)
- vs_startloc=(/1,1,inative+1/)
+ uw_startloc=(/1,1,kbgn_native+1,1/) !In the coldstart files, there is an extra top level
+ us_startloc=(/1,1,kbgn_native+1,1/)
+ vw_startloc=(/1,1,kbgn_native+1,1/)
+ vs_startloc=(/1,1,kbgn_native+1,1/)
+ allocate( work_bu_s(nlon_regional,nlat_regional+1,kbgn_native:kend_native))
+ allocate( work_bv_s(nlon_regional,nlat_regional+1,kbgn_native:kend_native))
+ allocate( work_bu_w(nlon_regional+1,nlat_regional,kbgn_native:kend_native))
+ allocate( work_bv_w(nlon_regional+1,nlat_regional,kbgn_native:kend_native))
+!!!!!!!! readin work_b !!!!!!!!!!!!!!!!
+ call check( nf90_get_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) )
+ call check( nf90_get_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) )
+ call check( nf90_get_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) )
+ call check( nf90_get_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) )
+ do ilevtot=kbgn,kend
+ varname=grd_uv%names(1,ilevtot)
+ ilev=grd_uv%lnames(1,ilevtot)
+ inative=nzp1-ilev
work_au=hwork(1,:,:,ilevtot)
work_av=hwork(2,:,:,ilevtot)
- call check( nf90_inq_varid(gfile_loc,'u_s',u_sgrd_VarId) )
- call check( nf90_inq_varid(gfile_loc,'u_w',u_wgrd_VarId) )
- call check( nf90_inq_varid(gfile_loc,'v_s',v_sgrd_VarId) )
- call check( nf90_inq_varid(gfile_loc,'v_w',v_wgrd_VarId) )
-!!!!!!!! readin work_b !!!!!!!!!!!!!!!!
- call check( nf90_get_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) )
- call check( nf90_get_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) )
- call check( nf90_get_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) )
- call check( nf90_get_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) )
if(add_saved)then
do j=1,nlat_regional
- u2d(:,j)=half * (work_bu_s(:,j)+ work_bu_s(:,j+1))
+ u2d(:,j)=half * (work_bu_s(:,j,inative)+ work_bu_s(:,j+1,inative))
enddo
do i=1,nlon_regional
- v2d(i,:)=half*(work_bv_w(i,:)+work_bv_w(i+1,:))
+ v2d(i,:)=half*(work_bv_w(i,:,inative)+work_bv_w(i+1,:,inative))
enddo
call fv3_h_to_ll(u2d,workau2,nlon_regional,nlat_regional,nloncase,nlatcase,grid_reverse_flag)
call fv3_h_to_ll(v2d,workav2,nlon_regional,nlat_regional,nloncase,nlatcase,grid_reverse_flag)
@@ -3388,44 +4469,46 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
- work_bu_w(:,:)=work_bu_w(:,:)+workbu_w2(:,:)
- work_bu_s(:,:)=work_bu_s(:,:)+workbu_s2(:,:)
- work_bv_w(:,:)=work_bv_w(:,:)+workbv_w2(:,:)
- work_bv_s(:,:)=work_bv_s(:,:)+workbv_s2(:,:)
+ work_bu_w(:,:,inative)=work_bu_w(:,:,inative)+workbu_w2(:,:)
+ work_bu_s(:,:,inative)=work_bu_s(:,:,inative)+workbu_s2(:,:)
+ work_bv_w(:,:,inative)=work_bv_w(:,:,inative)+workbv_w2(:,:)
+ work_bv_s(:,:,inative)=work_bv_s(:,:,inative)+workbv_s2(:,:)
else
call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag)
call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag)
do i=2,nlon_regional
- work_bu_w(i,:)=half*(u2d(i-1,:)+u2d(i,:))
- work_bv_w(i,:)=half*(v2d(i-1,:)+v2d(i,:))
+ work_bu_w(i,:,inative)=half*(u2d(i-1,:)+u2d(i,:))
+ work_bv_w(i,:,inative)=half*(v2d(i-1,:)+v2d(i,:))
enddo
- work_bu_w(1,:)=u2d(1,:)
- work_bv_w(1,:)=v2d(1,:)
- work_bu_w(nlon_regional+1,:)=u2d(nlon_regional,:)
- work_bv_w(nlon_regional+1,:)=v2d(nlon_regional,:)
+ work_bu_w(1,:,inative)=u2d(1,:)
+ work_bv_w(1,:,inative)=v2d(1,:)
+ work_bu_w(nlon_regional+1,:,inative)=u2d(nlon_regional,:)
+ work_bv_w(nlon_regional+1,:,inative)=v2d(nlon_regional,:)
do j=2,nlat_regional
- work_bu_s(:,j)=half*(u2d(:,j-1)+u2d(:,j))
- work_bv_s(:,j)=half*(v2d(:,j-1)+v2d(:,j))
+ work_bu_s(:,j,inative)=half*(u2d(:,j-1)+u2d(:,j))
+ work_bv_s(:,j,inative)=half*(v2d(:,j-1)+v2d(:,j))
enddo
- work_bu_s(:,1)=u2d(:,1)
- work_bv_s(:,1)=v2d(:,1)
- work_bu_s(:,nlat_regional+1)=u2d(:,nlat_regional)
- work_bv_s(:,nlat_regional+1)=v2d(:,nlat_regional)
+ work_bu_s(:,1,inative)=u2d(:,1)
+ work_bv_s(:,1,inative)=v2d(:,1)
+ work_bu_s(:,nlat_regional+1,inative)=u2d(:,nlat_regional)
+ work_bv_s(:,nlat_regional+1,inative)=v2d(:,nlat_regional)
endif
-
- call check( nf90_put_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) )
- call check( nf90_put_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) )
- call check( nf90_put_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) )
- call check( nf90_put_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) )
enddo !
+
+ call check( nf90_put_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) )
+ call check( nf90_put_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) )
+ call check( nf90_put_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) )
+ call check( nf90_put_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) )
call check( nf90_close(gfile_loc) )
deallocate(work_bu_w,work_bv_w)
deallocate(work_bu_s,work_bv_s)
+ endif !procuse
+
deallocate(work_au,work_av,u2d,v2d)
if(add_saved) deallocate(workau2,workav2)
if (allocated(workbu_w2)) then
@@ -3592,34 +4675,43 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file
!
!$$$ end documentation block
- use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null
+ use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null,npe,setcomm,mpi_integer,mpi_max
use mod_fv3_lola, only: fv3_ll_to_h
use mod_fv3_lola, only: fv3_h_to_ll
use netcdf, only: nf90_open,nf90_close
- use netcdf, only: nf90_write,nf90_inq_varid
- use netcdf, only: nf90_put_var,nf90_get_var
+ use netcdf, only: nf90_write,nf90_netcdf4, nf90_mpiio,nf90_inq_varid
+ use netcdf, only: nf90_put_var,nf90_get_var,nf90_independent,nf90_var_par_access
+ use netcdf, only: nf90_inquire_dimension
use gsi_bundlemod, only: gsi_bundle
use general_sub2grid_mod, only: sub2grid_info,general_sub2grid
implicit none
- type(sub2grid_info), intent(in):: grd_ionouv
- type(gsi_bundle),intent(inout) :: cstate_nouv
- logical ,intent(in ) :: add_saved
- character(len=:), allocatable, intent(in) :: filenamein
- type (type_fv3regfilenameg),intent (in) :: fv3filenamegin
+ type(sub2grid_info), intent(in) :: grd_ionouv
+ type(gsi_bundle), intent(inout):: cstate_nouv
+ logical, intent(in ):: add_saved
+ character(len=:), allocatable, intent(in) :: filenamein
+ type (type_fv3regfilenameg), intent(in) :: fv3filenamegin
+
real(r_kind),dimension(1,grd_ionouv%nlat,grd_ionouv%nlon,grd_ionouv%kbegin_loc:grd_ionouv%kend_alloc):: hwork
- character(len=max_varname_length) :: filenamein2
- character(len=max_varname_length) :: varname,vgsiname
+ character(len=max_filename_length) :: filenamein2
+ character(len=max_varname_length) :: varname,vgsiname,name
- integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3)
+ integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4)
+ integer(i_kind) countloc_tmp(4),startloc_tmp(4)
integer(i_kind) kbgn,kend
integer(i_kind) inative,ilev,ilevtot
integer(i_kind) :: VarId,gfile_loc
- integer(i_kind) mm1,nzp1
+ integer(i_kind) mm1,nzp1,len,nx_phy,iret
+ logical :: phy_smaller_domain
real(r_kind),allocatable,dimension(:,:):: work_a
real(r_kind),allocatable,dimension(:,:):: work_b
real(r_kind),allocatable,dimension(:,:):: workb2,worka2
+ real(r_kind),allocatable,dimension(:,:):: work_b_tmp
+ integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror
+ integer(i_kind),dimension(npe):: members,members_read,mype_read_rank
+ logical:: procuse
+
! for io_layout > 1
real(r_kind),allocatable,dimension(:,:):: work_b_layout
integer(i_kind) :: nio
@@ -3641,104 +4733,171 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file
allocate( workb2(nlon_regional,nlat_regional))
allocate( worka2(nlatcase,nloncase))
- if(fv3_io_layout_y > 1) then
- allocate(gfile_loc_layout(0:fv3_io_layout_y-1))
- do nio=0,fv3_io_layout_y-1
- write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio
- call check( nf90_open(filename_layout,nf90_write,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) )
- enddo
- gfile_loc=gfile_loc_layout(0)
- else
- call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) )
+ procuse = .false.
+ members=-1
+ members_read=-1
+ if (kbgn<=kend) then
+ procuse = .true.
+ members(mm1) = mype
endif
- do ilevtot=kbgn,kend
- vgsiname=grd_ionouv%names(1,ilevtot)
- if(trim(vgsiname)=='amassi') cycle
- if(trim(vgsiname)=='amassj') cycle
- if(trim(vgsiname)=='amassk') cycle
- if(trim(vgsiname)=='pm2_5') cycle
- call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname)
- if(trim(filenamein) /= trim(filenamein2)) then
- write(6,*)'filenamein and filenamein2 are not the same as expected, stop'
- call flush(6)
- call stop2(333)
- endif
- ilev=grd_ionouv%lnames(1,ilevtot)
- nz=grd_ionouv%nsig
- nzp1=nz+1
- inative=nzp1-ilev
- countloc=(/nxcase,nycase,1/)
- startloc=(/1,1,inative/)
-
- work_a=hwork(1,:,:,ilevtot)
-
+ call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror)
+ nread=0
+ mype_read_rank=-1
+ do i=1,npe
+ if (members_read(i) >= 0) then
+ nread=nread+1
+ mype_read_rank(nread) = members_read(i)
+ endif
+ enddo
- call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) )
-
+ call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror)
- if(index(vgsiname,"delzinc") > 0) then
- if(fv3_io_layout_y > 1) then
+ if (procuse) then
+ if(fv3_io_layout_y > 1) then
+ allocate(gfile_loc_layout(0:fv3_io_layout_y-1))
do nio=0,fv3_io_layout_y-1
- countloc=(/nxcase,ny_layout_len(nio),1/)
- allocate(work_b_layout(nxcase,ny_layout_len(nio)))
- call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) )
- work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout
- deallocate(work_b_layout)
+ write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio
+ call check( nf90_open(filename_layout,ior(nf90_netcdf4,ior(nf90_write, nf90_mpiio)),gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) )
enddo
- else
- call check( nf90_get_var(gfile_loc,VarId,work_b,start = startloc, count = countloc) )
- endif
- call fv3_ll_to_h(work_a(:,:),workb2,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag)
- work_b(:,:)=work_b(:,:)+workb2(:,:)
- else
- if(add_saved)then
- if(fv3_io_layout_y > 1) then
+ gfile_loc=gfile_loc_layout(0)
+ else
+ call check( nf90_open(filenamein,ior(nf90_netcdf4,ior(nf90_write, nf90_mpiio)),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) )
+ endif
+
+ do ilevtot=kbgn,kend
+ vgsiname=grd_ionouv%names(1,ilevtot)
+ if(trim(vgsiname)=='amassi') cycle
+ if(trim(vgsiname)=='amassj') cycle
+ if(trim(vgsiname)=='amassk') cycle
+ if(trim(vgsiname)=='pm2_5') cycle
+ call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname)
+ if(trim(filenamein) /= trim(filenamein2)) then
+ write(6,*)'filenamein and filenamein2 are not the same as expected, stop'
+ call stop2(333)
+ endif
+ ilev=grd_ionouv%lnames(1,ilevtot)
+ nz=grd_ionouv%nsig
+ nzp1=nz+1
+ inative=nzp1-ilev
+ countloc=(/nxcase,nycase,1,1/)
+ startloc=(/1,1,inative,1/)
+
+ work_a=hwork(1,:,:,ilevtot)
+
+ if( trim(varname) == 'ref_f3d' .or. trim(adjustl(varname)) == 'flash_extent_density' )then
+ iret=nf90_inquire_dimension(gfile_loc,1,name,len)
+ if(trim(name)=='xaxis_1') nx_phy=len
+ if( nx_phy == nxcase )then
+ allocate(work_b_tmp(nxcase,nycase))
+ countloc_tmp=(/nxcase,nycase,1,1/)
+ phy_smaller_domain = .false.
+ else
+ allocate(work_b_tmp(nxcase-6,nycase-6))
+ countloc_tmp=(/nxcase-6,nycase-6,1,1/)
+ phy_smaller_domain = .true.
+ end if
+ startloc_tmp=(/1,1,ilev,1/)
+ end if
+
+ call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) )
+ call check( nf90_var_par_access(gfile_loc, VarId, nf90_independent))
+
+
+ if(index(vgsiname,"delzinc") > 0) then
+ if(fv3_io_layout_y > 1) then
+ do nio=0,fv3_io_layout_y-1
+ countloc=(/nxcase,ny_layout_len(nio),1,1/)
+ allocate(work_b_layout(nxcase,ny_layout_len(nio)))
+ call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) )
+ work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout
+ deallocate(work_b_layout)
+ enddo
+ else
+ call check( nf90_get_var(gfile_loc,VarId,work_b,start = startloc, count = countloc) )
+ endif
+ call fv3_ll_to_h(work_a(:,:),workb2,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag)
+ work_b(:,:)=work_b(:,:)+workb2(:,:)
+ else
+ if(add_saved)then
+ if(fv3_io_layout_y > 1) then
+ do nio=0,fv3_io_layout_y-1
+ countloc=(/nxcase,ny_layout_len(nio),1,1/)
+ allocate(work_b_layout(nxcase,ny_layout_len(nio)))
+ call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) )
+ work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout
+ deallocate(work_b_layout)
+ enddo
+ else
+ if( trim(varname) == 'ref_f3d' .or. trim(varname) == 'flash_extent_density' )then
+ work_b = 0.0_r_kind
+ call check( nf90_get_var(gfile_loc,VarId,work_b_tmp,start = startloc_tmp, count = countloc_tmp) )
+ where(work_b_tmp < 0.0_r_kind)
+ work_b_tmp = 0.0_r_kind
+ end where
+ if(phy_smaller_domain)then
+ work_b(4:nxcase-3,4:nycase-3) = work_b_tmp
+ else
+ work_b(1:nxcase,1:nycase) = work_b_tmp
+ end if
+ else
+ call check( nf90_get_var(gfile_loc,VarId,work_b,start = startloc, count = countloc) )
+ end if
+ endif
+ call fv3_h_to_ll(work_b(:,:),worka2,nlon_regional,nlat_regional,nloncase,nlatcase,grid_reverse_flag)
+!!!!!!!! analysis_inc: work_a !!!!!!!!!!!!!!!!
+ work_a(:,:)=work_a(:,:)-worka2(:,:)
+ call fv3_ll_to_h(work_a(:,:),workb2,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag)
+ work_b(:,:)=work_b(:,:)+workb2(:,:)
+ else
+ call fv3_ll_to_h(work_a(:,:),work_b(:,:),nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag)
+ endif
+ endif
+ if (ifindstrloc(vnames_nonnegativetracers,trim(varname))> 0) then
+ where (work_b <0.0_r_kind) work_b=0.0_r_kind
+ endif
+ if(fv3_io_layout_y > 1) then
do nio=0,fv3_io_layout_y-1
- countloc=(/nxcase,ny_layout_len(nio),1/)
+ countloc=(/nxcase,ny_layout_len(nio),1,1/)
allocate(work_b_layout(nxcase,ny_layout_len(nio)))
- call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) )
- work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout
+ work_b_layout=work_b(:,ny_layout_b(nio):ny_layout_e(nio))
+ call check( nf90_put_var(gfile_loc_layout(nio),VarId,work_b_layout, start = startloc, count = countloc) )
deallocate(work_b_layout)
- enddo
- else
- call check( nf90_get_var(gfile_loc,VarId,work_b,start = startloc, count = countloc) )
- endif
- call fv3_h_to_ll(work_b(:,:),worka2,nlon_regional,nlat_regional,nloncase,nlatcase,grid_reverse_flag)
-!!!!!!!! analysis_inc: work_a !!!!!!!!!!!!!!!!
- work_a(:,:)=work_a(:,:)-worka2(:,:)
- call fv3_ll_to_h(work_a(:,:),workb2,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag)
- work_b(:,:)=work_b(:,:)+workb2(:,:)
- else
- call fv3_ll_to_h(work_a(:,:),work_b(:,:),nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag)
- endif
- endif
- if(fv3_io_layout_y > 1) then
- do nio=0,fv3_io_layout_y-1
- countloc=(/nxcase,ny_layout_len(nio),1/)
- allocate(work_b_layout(nxcase,ny_layout_len(nio)))
- work_b_layout=work_b(:,ny_layout_b(nio):ny_layout_e(nio))
- call check( nf90_put_var(gfile_loc_layout(nio),VarId,work_b_layout, start = startloc, count = countloc) )
- deallocate(work_b_layout)
- enddo
- else
- call check( nf90_put_var(gfile_loc,VarId,work_b, start = startloc, count = countloc) )
- endif
-
- enddo !ilevtotl loop
- if(fv3_io_layout_y > 1) then
- do nio=0,fv3_io_layout_y-1
- call check(nf90_close(gfile_loc_layout(nio)))
- enddo
- deallocate(gfile_loc_layout)
- else
- call check(nf90_close(gfile_loc))
+ enddo
+ else
+ if( trim(varname) == 'ref_f3d' .or. trim(varname) == 'flash_extent_density' )then
+ if(phy_smaller_domain)then
+ work_b_tmp = work_b(4:nxcase-3,4:nycase-3)
+ else
+ work_b_tmp = work_b(1:nxcase,1:nycase)
+ end if
+ where(work_b_tmp < 0.0_r_kind)
+ work_b_tmp = 0.0_r_kind
+ end where
+ call check( nf90_put_var(gfile_loc,VarId,work_b_tmp, start = startloc_tmp, count = countloc_tmp) )
+ deallocate(work_b_tmp)
+ else
+ call check( nf90_put_var(gfile_loc,VarId,work_b, start = startloc, count = countloc) )
+ end if
+ endif
+
+ enddo !ilevtotl loop
+ if(fv3_io_layout_y > 1) then
+ do nio=0,fv3_io_layout_y-1
+ call check(nf90_close(gfile_loc_layout(nio)))
+ enddo
+ deallocate(gfile_loc_layout)
+ else
+ call check(nf90_close(gfile_loc))
+ endif
endif
+
+ call mpi_barrier(mpi_comm_world,ierror)
+
deallocate(work_b,work_a)
deallocate(workb2,worka2)
-
end subroutine gsi_fv3ncdf_write
subroutine check(status)
use kinds, only: i_kind
@@ -3774,23 +4933,25 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f
!
!$$$ end documentation block
- use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null
+ use mpimod, only: npe, setcomm,mpi_integer,mpi_max,mpi_rtype,mpi_comm_world,mype,mpi_info_null
use mod_fv3_lola, only: fv3_ll_to_h
use mod_fv3_lola, only: fv3_h_to_ll
use netcdf, only: nf90_open,nf90_close
- use netcdf, only: nf90_write,nf90_inq_varid
+ use netcdf, only: nf90_write, nf90_netcdf4,nf90_mpiio,nf90_inq_varid
use netcdf, only: nf90_put_var,nf90_get_var
+ use netcdf, only: nf90_independent,nf90_var_par_access
use gsi_bundlemod, only: gsi_bundle
use general_sub2grid_mod, only: sub2grid_info,general_sub2grid
implicit none
- type(sub2grid_info), intent(in):: grd_ionouv
- type(gsi_bundle),intent(inout) :: cstate_nouv
- logical ,intent(in ) :: add_saved
- character(*),intent(in):: filenamein
- type (type_fv3regfilenameg),intent (in) :: fv3filenamegin
+ type(sub2grid_info), intent(in) :: grd_ionouv
+ type(gsi_bundle), intent(inout):: cstate_nouv
+ logical, intent(in ):: add_saved
+ character(*), intent(in) :: filenamein
+ type (type_fv3regfilenameg),intent(in) :: fv3filenamegin
+
real(r_kind),dimension(1,grd_ionouv%nlat,grd_ionouv%nlon,grd_ionouv%kbegin_loc:grd_ionouv%kend_alloc):: hwork
- character(len=max_varname_length) :: filenamein2
+ character(len=max_filename_length) :: filenamein2
integer(i_kind) kbgn,kend
integer(i_kind) inative,ilev,ilevtot
@@ -3802,6 +4963,10 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f
character(len=max_varname_length) :: varname,vgsiname
integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3)
+ integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror
+ integer(i_kind),dimension(npe):: members,members_read,mype_read_rank
+ logical:: procuse
+
mm1=mype+1
nloncase=grd_ionouv%nlon
@@ -3816,7 +4981,30 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f
allocate( work_b(nlon_regional,nlat_regional))
allocate( workb2(nlon_regional,nlat_regional))
allocate( worka2(nlatcase,nloncase))
- call check ( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL)) !clt
+
+ procuse = .false.
+ members=-1
+ members_read=-1
+ if (kbgn<=kend) then
+ procuse = .true.
+ members(mm1) = mype
+ endif
+
+ call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror)
+
+ nread=0
+ mype_read_rank=-1
+ do i=1,npe
+ if (members_read(i) >= 0) then
+ nread=nread+1
+ mype_read_rank(nread) = members_read(i)
+ endif
+ enddo
+
+ call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror)
+
+ if (procuse) then
+ call check ( nf90_open(filenamein,ior(nf90_netcdf4,ior(nf90_write, nf90_mpiio)),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL)) !clt
do ilevtot=kbgn,kend
vgsiname=grd_ionouv%names(1,ilevtot)
if(trim(vgsiname)=='amassi') cycle
@@ -3826,7 +5014,6 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f
call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname)
if(trim(filenamein) /= trim(filenamein2)) then
write(6,*)'filenamein and filenamein2 are not the same as expected, stop'
- call flush(6)
call stop2(333)
endif
ilev=grd_ionouv%lnames(1,ilevtot)
@@ -3840,6 +5027,7 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f
call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) )
+ call check( nf90_var_par_access(gfile_loc, VarId, nf90_independent))
call check( nf90_get_var(gfile_loc,VarId,work_b,start=startloc,count=countloc) )
if(index(vgsiname,"delzinc") > 0) then
write(6,*)'delz is not in the cold start fiels with this option, incompatible setup , stop'
@@ -3857,9 +5045,13 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f
else
call fv3_ll_to_h(work_a(:,:),work_b(:,:),nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag)
endif
+ if (ifindstrloc(vnames_nonnegativetracers,trim(varname))> 0) then
+ where (work_b <0.0_r_kind) work_b=0.0_r_kind
+ endif
call check( nf90_put_var(gfile_loc,VarId,work_b,start=startloc,count=countloc) )
enddo !ilevtot
call check(nf90_close(gfile_loc))
+ endif
deallocate(work_b,work_a)
deallocate(worka2,workb2)
@@ -3874,6 +5066,7 @@ subroutine reverse_grid_r(grid,nx,ny,nz)
implicit none
integer(i_kind), intent(in ) :: nx,ny,nz
real(r_kind), intent(inout ) :: grid(nx,ny,nz)
+
real(r_kind) :: tmp_grid(nx,ny)
integer(i_kind) :: i,j,k
!
@@ -3897,6 +5090,7 @@ subroutine reverse_grid_r_uv(grid,nx,ny,nz)
implicit none
integer(i_kind), intent(in ) :: nx,ny,nz
real(r_kind), intent(inout ) :: grid(nx,ny,nz)
+
real(r_kind) :: tmp_grid(nx,ny)
integer(i_kind) :: i,j,k
!
@@ -4313,13 +5507,13 @@ subroutine convert_cvpnx_to_nx(qnx_arr,cvpnr,cvpnr_pvalue,cloud_nt_updt,q_arr,qr
implicit none
- real(r_kind), intent(inout ) :: qnx_arr(lat2,lon2,nsig)
- logical, intent(in ) :: cvpnr
- real(r_kind), intent(in ) :: cvpnr_pvalue
- integer(i_kind), intent(in ) :: cloud_nt_updt
- real(r_kind), intent(in ) :: q_arr(lat2,lon2,nsig)
- real(r_kind), intent(in ) :: qr_arr(lat2,lon2,nsig)
- real(r_kind), intent(in ) :: ps_arr(lat2,lon2)
+ real(r_kind), intent(inout) :: qnx_arr(lat2,lon2,nsig)
+ logical, intent(in ) :: cvpnr
+ real(r_kind), intent(in ) :: cvpnr_pvalue
+ integer(i_kind), intent(in ) :: cloud_nt_updt
+ real(r_kind), intent(in ) :: q_arr(lat2,lon2,nsig)
+ real(r_kind), intent(in ) :: qr_arr(lat2,lon2,nsig)
+ real(r_kind), intent(in ) :: ps_arr(lat2,lon2)
real(r_kind), dimension(lat2,lon2,nsig) :: tmparr_qnr
integer(i_kind) :: i, j, k, it
@@ -4383,17 +5577,17 @@ subroutine gsi_copy_bundle(bundi,bundo)
! !INPUT PARAMETERS:
type(gsi_bundle), intent(in ) :: bundi
+ type(gsi_bundle), intent(inout) :: bundo
! !INPUT/OUTPUT PARAMETERS:
- type(gsi_bundle), intent(inout) :: bundo
character(len=max_varname_length),dimension(:),allocatable:: src_name_vars2d
character(len=max_varname_length),dimension(:),allocatable:: src_name_vars3d
character(len=max_varname_length),dimension(:),allocatable:: target_name_vars2d
character(len=max_varname_length),dimension(:),allocatable:: target_name_vars3d
character(len=max_varname_length) ::varname
real(r_kind),dimension(:,:,:),pointer:: pvar3d=>NULL()
- real(r_kind),dimension(:,:,:),pointer:: pvar2d =>NULL()
+ real(r_kind),dimension(:,:),pointer:: pvar2d =>NULL()
integer(i_kind):: src_nc3d,src_nc2d,target_nc3d,target_nc2d
integer(i_kind):: ivar,jvar,istatus
src_nc3d=bundi%n3d
@@ -4431,10 +5625,12 @@ subroutine gsi_copy_bundle(bundi,bundo)
return
end subroutine gsi_copy_bundle
subroutine getfv3lamfilevname(vgsinamein,fv3filenamegref,filenameout,vname)
+
type (type_fv3regfilenameg),intent (in) :: fv3filenamegref
- character(len=*):: vgsinamein
character(len=*),intent(out):: vname
character(len=*),intent(out):: filenameout
+ character(len=*),intent( in):: vgsinamein
+
if (ifindstrloc(vgsiname,vgsinamein)<= 0) then
write(6,*)'the name ',vgsinamein ,'cannot be treated correctly in getfv3lamfilevname,stop'
call stop2(333)
@@ -4443,6 +5639,8 @@ subroutine getfv3lamfilevname(vgsinamein,fv3filenamegref,filenameout,vname)
filenameout=fv3filenamegref%dynvars
else if(ifindstrloc(vartracers,vgsinamein)> 0 ) then
filenameout=fv3filenamegref%tracers
+ else if(ifindstrloc(varphyvars,vgsinamein)> 0) then
+ filenameout=fv3filenamegref%phyvars
else
write(6,*)'the filename corresponding to var ',trim(vgsinamein),' is not found, stop '
call stop2(333)
diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90
index 55d9298614..d7f5667252 100644
--- a/src/gsi/gsimod.F90
+++ b/src/gsi/gsimod.F90
@@ -21,13 +21,15 @@ module gsimod
lread_obs_save,lread_obs_skip,time_window_rad,tcp_posmatch,tcp_box, &
neutral_stability_windfact_2dvar,use_similarity_2dvar,ta2tb
use gsi_dbzOper, only: diag_radardbz
+ use gsi_fedOper, only: diag_fed
- use obsmod, only: doradaroneob,oneoblat,oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,&
+ use obsmod, only: doradaroneob,dofedoneob,oneoblat,oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,&
radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,&
- rmesh_vr,zmesh_dbz,zmesh_vr,if_vterminal, if_model_dbz,if_vrobs_raw,&
- minobrangedbz,maxobrangedbz,maxobrangevr,maxtiltvr,missing_to_nopcp,&
+ rmesh_vr,zmesh_dbz,zmesh_vr,if_vterminal, if_model_dbz,if_model_fed,innov_use_model_fed,if_vrobs_raw,if_use_w_vr,&
+ minobrangedbz,maxobrangedbz,maxobrangevr,maxtiltvr,inflate_dbz_obserr,missing_to_nopcp,&
ntilt_radarfiles,whichradar,&
- minobrangevr,maxtiltdbz,mintiltvr,mintiltdbz,l2rwthin,hurricane_radar
+ minobrangevr,maxtiltdbz,mintiltvr,mintiltdbz,l2rwthin,hurricane_radar,&
+ r_hgt_fed
use obsmod, only: lwrite_predterms, &
lwrite_peakwt,use_limit,lrun_subdirs,l_foreaft_thin,lobsdiag_forenkf,&
@@ -91,15 +93,21 @@ module gsimod
erradar_inflate,tdrerr_inflate,use_poq7,qc_satwnds,&
init_qcvars,vadfile,noiqc,c_varqc,gps_jacqc,qc_noirjaco3,qc_noirjaco3_pole,&
buddycheck_t,buddydiag_save,njqc,vqc,nvqc,hub_norm,vadwnd_l2rw_qc, &
- pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres,cao_check
+ pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres,cao_check, &
+ cris_cads, iasi_cads, airs_cads
use qcmod, only: troflg,lat_c,nrand
+ use cads, only: M__Sensor,N__Num_Bands,N__GradChkInterval,N__Band_Size,N__Bands,N__Window_Width, &
+ N__Window_Bounds,R__BT_Threshold,R__Grad_Threshold,R__Window_Grad_Threshold, L__Do_Quick_Exit, &
+ L__Do_CrossBand, N__BandToUse,L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, &
+ N__Num_Imager_Clusters,N__Imager_Chans,R__Stddev_Threshold,R__Coverage_Threshold, &
+ R__FG_Departure_Threshold, CADS_Setup_Cloud
use pcpinfo, only: npredp,diag_pcp,dtphys,deltim,init_pcp
use jfunc, only: iout_iter,iguess,miter,factqmin,factqmax,superfact,limitqobs, &
factql,factqi,factqr,factqs,factqg, &
factv,factl,factp,factg,factw10m,facthowv,factcldch,niter,niter_no_qc,biascor,&
init_jfunc,qoption,cwoption,switch_on_derivatives,tendsflag,jiterstart,jiterend,R_option,&
bcoption,diurnalbc,print_diag_pcg,tsensible,diag_precon,step_start,pseudo_q2,&
- clip_supersaturation,cnvw_option
+ clip_supersaturation,cnvw_option,hofx_2m_sfcfile
use state_vectors, only: init_anasv,final_anasv
use control_vectors, only: init_anacv,final_anacv,nrf,nvars,nrf_3d,cvars3d,cvars2d,&
nrf_var,lcalc_gfdl_cfrac,incvars_to_zero,incvars_zero_strat,incvars_efold
@@ -151,8 +159,10 @@ module gsimod
readin_beta,use_localization_grid,use_gfs_ens,q_hyb_ens,i_en_perts_io, &
l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB,limqens, &
ntotensgrp,nsclgrp,naensgrp,ngvarloc,ntlevs_ens,naensloc, &
- i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl,l_timloc_opt
- use hybrid_ensemble_parameters,only : l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar
+ r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl,l_timloc_opt,&
+ vdl_scale,vloc_varlist,&
+ global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers,l_mgbf_loc
+ use hybrid_ensemble_parameters,only : l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_gfs,weight_ens_fv3sar
use rapidrefresh_cldsurf_mod, only: init_rapidrefresh_cldsurf, &
dfi_radar_latent_heat_time_period,metar_impact_radius,&
metar_impact_radius_lowcloud,l_gsd_terrain_match_surftobs, &
@@ -173,17 +183,21 @@ module gsimod
i_coastline,i_gsdqc,qv_max_inc,ioption,l_precip_clear_only,l_fog_off,&
cld_bld_coverage,cld_clr_coverage,&
i_cloud_q_innovation,i_ens_mean,DTsTmax,&
- i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check
+ i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check, &
+ corp_howv, hwllp_howv, corp_gust, hwllp_gust, oerr_gust
use gsi_metguess_mod, only: gsi_metguess_init,gsi_metguess_final
use gsi_chemguess_mod, only: gsi_chemguess_init,gsi_chemguess_final
use tcv_mod, only: init_tcps_errvals,tcp_refps,tcp_width,tcp_ermin,tcp_ermax
use chemmod, only : init_chem,berror_chem,berror_fv3_cmaq_regional,oneobtest_chem,&
+ berror_fv3_sd_regional,&
maginnov_chem,magoberr_chem,&
oneob_type_chem,oblat_chem,&
+ anowbufr_ext,&
oblon_chem,obpres_chem,diag_incr,elev_tolerance,tunable_error,&
in_fname,out_fname,incr_fname, &
laeroana_gocart, l_aoderr_table, aod_qa_limit, luse_deepblue, lread_ext_aerosol, &
- laeroana_fv3cmaq,laeroana_fv3smoke,pm2_5_innov_threshold,crtm_aerosol_model,crtm_aerosolcoeff_format,crtm_aerosolcoeff_file, &
+ laeroana_fv3cmaq,laeroana_fv3smoke,pm2_5_innov_threshold,pm2_5_urban_innov_threshold,pm2_5_bg_threshold,&
+ crtm_aerosol_model,crtm_aerosolcoeff_format,crtm_aerosolcoeff_file, &
icvt_cmaq_fv3, raod_radius_mean_scale,raod_radius_std_scale
use chemmod, only : wrf_pm2_5,aero_ratios
@@ -195,7 +209,7 @@ module gsimod
use gsi_nstcouplermod, only: gsi_nstcoupler_init_nml
use gsi_nstcouplermod, only: nst_gsi,nstinfo,zsea1,zsea2,fac_dtl,fac_tsl
use ncepnems_io, only: init_nems,imp_physics,lupp
- use wrf_vars_mod, only: init_wrf_vars
+ use wrf_vars_mod, only: init_wrf_vars,fed_exist,dbz_exist
use gsi_rfv3io_mod,only : fv3sar_bg_opt
use radarz_cst, only: mphyopt, MFflg
use radarz_iface, only: init_mphyopt
@@ -499,7 +513,23 @@ module gsimod
! 2. fv3_regional = .true.
! 3. fv3_cmaq_regional = .true.
! 4. berror_fv3_cmaq_regional = .true.
+! 09-02-2022 Jung Added namelist entries to call a new IR cloud detection routine
+! the original cloud detection routine is the default. To use the new
+! cloud detection routine, set the flags to .true.
! 09-15-2022 yokota - add scale/variable/time-dependent localization
+! 2023-07-30 Zhao - added namelist options for analysis of significant wave height
+! (aka howv in GSI code): corp_howv, hwllp_howv
+! (in namelist session rapidrefresh_cldsurf)
+!
+! 2023-09-14 H. Wang - add namelist option for FED EnVar DA.
+! - if_model_fed=.true. : FED in background and ens. If
+! perform FED DA, this has to be true along with fed in
+! control/analysis and metguess vectors. If only run GSI observer,
+! it can be false.
+! - innov_use_model_fed=.true. : Use FED from BG to calculate innovation.
+! this requires if_model_fed=.true.
+! it works either an EnVar DA run or a GSI observer run.
+! 02-20-2024 yokota - add MGBF-based localization
!
!EOP
!-------------------------------------------------------------------------
@@ -558,6 +588,7 @@ module gsimod
! diag_co - logical to turn off or on the diagnostic carbon monoxide file (true=on)
! diag_light - logical to turn off or on the diagnostic lightning file (true=on)
! diag_radardbz - logical to turn off or on the diagnostic radar reflectivity file (true=on)
+! diag_fed - logical to turn off or on the diagnostic flash extent density file (true=on)
! write_diag - logical to write out diagnostic files on outer iteration
! lobsdiagsave - write out additional observation diagnostics
! ltlint - linearize inner loop
@@ -723,6 +754,10 @@ module gsimod
! optconv - downweighting option for iasi and cris for moisture channels to
! improve convergence. default 0.0 (no change). Larger number improves
! convergence.
+! inflate_dbz_obserr - logical that controls inflation of reflectivity ob error
+! for obs that exceed gross error magnitude
+! if true, inflate ob error
+! if false, reject ob
!
! NOTE: for now, if in regional mode, then iguess=-1 is forced internally.
! add use of guess file later for regional mode.
@@ -736,8 +771,8 @@ module gsimod
min_offset,pseudo_q2,&
iout_iter,npredp,retrieval,&
tzr_qc,tzr_bufrsave,&
- diag_rad,diag_pcp,diag_conv,diag_ozone,diag_aero,diag_co,diag_light,diag_radardbz,iguess, &
- write_diag,reduce_diag, &
+ diag_rad,diag_pcp,diag_conv,diag_ozone,diag_aero,diag_co,diag_light,diag_radardbz,diag_fed, &
+ iguess,write_diag,reduce_diag, &
oneobtest,sfcmodel,dtbduv_on,ifact10,l_foto,offtime_data,&
use_pbl,use_compress,nsig_ext,gpstop,commgpstop, commgpserrinf, &
perturb_obs,perturb_fact,oberror_tune,preserve_restart_date, &
@@ -758,17 +793,18 @@ module gsimod
use_gfs_stratosphere,pblend0,pblend1,step_start,diag_precon,lrun_subdirs,&
use_sp_eqspace,lnested_loops,lsingleradob,thin4d,use_readin_anl_sfcmask,&
luse_obsdiag,id_drifter,id_ship,verbose,print_obs_para,lsingleradar,singleradar,lnobalance, &
- missing_to_nopcp,minobrangedbz,minobrangedbz,maxobrangedbz,&
- maxobrangevr,maxtiltvr,whichradar,doradaroneob,oneoblat,&
+ inflate_dbz_obserr,missing_to_nopcp,minobrangedbz,minobrangedbz,maxobrangedbz,&
+ maxobrangevr,maxtiltvr,whichradar,doradaroneob,dofedoneob,oneoblat,&
oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,&
rmesh_vr,zmesh_dbz,zmesh_vr, ntilt_radarfiles, whichradar,&
radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,&
- minobrangevr, maxtiltdbz, mintiltvr,mintiltdbz,if_vterminal,if_vrobs_raw,&
- if_model_dbz,imp_physics,lupp,netcdf_diag,binary_diag,l_wcp_cwm,aircraft_recon,diag_version,&
+ minobrangevr, maxtiltdbz, mintiltvr,mintiltdbz,if_vterminal,if_vrobs_raw,if_use_w_vr,&
+ if_model_dbz,if_model_fed,innov_use_model_fed,imp_physics,lupp,netcdf_diag,binary_diag,l_wcp_cwm,aircraft_recon,diag_version,&
write_fv3_incr,incvars_to_zero,incvars_zero_strat,incvars_efold,diag_version,&
cao_check,lcalc_gfdl_cfrac,tau_fcst,efsoi_order,lupdqc,lqcoef,cnvw_option,l2rwthin,hurricane_radar,&
l_reg_update_hydro_delz, l_obsprvdiag,&
- l_use_dbz_directDA, l_use_rw_columntilt, ta2tb, optconv
+ l_use_dbz_directDA, l_use_rw_columntilt, ta2tb, optconv, &
+ r_hgt_fed
! GRIDOPTS (grid setup variables,including regional specific variables):
! jcap - spectral resolution
@@ -1025,6 +1061,13 @@ module gsimod
! wind observations.
! vad_near_analtime - assimilate newvadwnd obs around analysis time only
+!
+! Flags to use the new IR cloud detection routine. Flag must be set to true to use the new routine. The default
+! (no flag or .false.) will use the default.
+! airs_cads: use the clod and aerosool detection software for the AIRS instrument
+! cris_cads: use the cloud and aerosol detection software for CrIS instruments
+! iasi_cads: use the cloud and aerosol detection software for IASI instruments
+!
namelist/obsqc/dfact,dfact1,erradar_inflate,tdrerr_inflate,oberrflg,&
vadfile,noiqc,c_varqc,blacklst,use_poq7,hilbert_curve,tcp_refps,tcp_width,&
@@ -1035,7 +1078,7 @@ module gsimod
q_doe_a_136,q_doe_a_137,q_doe_b_136,q_doe_b_137, &
t_doe_a_136,t_doe_a_137,t_doe_b_136,t_doe_b_137, &
uv_doe_a_236,uv_doe_a_237,uv_doe_a_213,uv_doe_b_236,uv_doe_b_237,uv_doe_b_213, &
- vad_near_analtime
+ vad_near_analtime,airs_cads,cris_cads,iasi_cads
! OBS_INPUT (controls input data):
! dmesh(max(dthin))- thinning mesh for each group
@@ -1045,7 +1088,7 @@ module gsimod
! l_foreaft_thin - separate TDR fore/aft scan for thinning
namelist/obs_input/dmesh,time_window_max,time_window_rad, &
- ext_sonde,l_foreaft_thin
+ ext_sonde,l_foreaft_thin,hofx_2m_sfcfile
! SINGLEOB_TEST (one observation test case setup):
! maginnov - magnitude of innovation for one ob
@@ -1366,23 +1409,62 @@ module gsimod
! l_timloc_opt - if true, then turn on time-dependent localization
! ngvarloc - number of variable-dependent localization lengths
! naensloc - total number of spatial localization lengths and scale separation lengths (should be naensgrp+nsclgrp-1)
-! i_ensloccov4tim - flag of cross-temporal localization
-! =0: cross-temporal covariance is retained
-! =1: cross-temporal covariance is zero
-! i_ensloccov4var - flag of cross-variable localization
-! =0: cross-variable covariance is retained
-! =1: cross-variable covariance is zero
-! i_ensloccov4scl - flag of cross-scale localization
-! =0: cross-scale covariance is retained
-! =1: cross-scale covariance is zero
+! r_ensloccov4tim - factor multiplying to cross-time covariance
+! For example,
+! =0.0: cross-time covariance is decreased to zero
+! =0.5: cross-time covariance is decreased to half
+! =1.0: cross-time covariance is retained
+! r_ensloccov4var - factor multiplying to cross-variable covariance
+! For example,
+! =0.0: cross-variable covariance is decreased to zero
+! =0.5: cross-variable covariance is decreased to half
+! =1.0: cross-variable covariance is retained
+! r_ensloccov4scl - factor multiplying to cross-scale covariance
+! For example,
+! =0.0: cross-scale covariance is decreased to zero
+! =0.5: cross-scale covariance is decreased to half
+! =1.0: cross-scale covariance is retained
+! global_spectral_filter_sd - if true, use spectral filter function for
+! scale decomposition in the global application (Huang et al. 2021)
+! assign_vdl_nml - if true, vdl_scale, and vloc_varlist will be used for
+! assigning variable-dependent localization upon SDL in gsiparm.anl.
+! This method described in (Wang and Wang 2022, JAMES) is
+! equivalent to, but different from the method associated
+! with the parameter r_ensloccov4var.
+! vloc_varlist - list of control variables using the same localization length,
+! effective only with assign_vdl_nml=.true. For example,
+! vloc_varlist(1,:) = 'sf','vp','ps','t',
+! vloc_varlist(2,:) = 'q',
+! vloc_varlist(3,:) = 'qr','qs','qg','dbz','w','ql','qi',
+! vloc_varlist(4,:) = 'sf','vp','ps','t','q',
+! vloc_varlist(5,:) = 'qr','qs','qg','dbz','w','ql','qi',
+! This example indicates that 3 variable-groups will be adopted for VDL.
+! 'sf','vp','ps','t' will share the same localization length of v1L1;
+! 'q' will have the localization lenth of v2L1
+! 'qr','qs','qg','dbz','w','ql','qi', use the same localization length of v3L1
!
- namelist/hybrid_ensemble/l_hyb_ens,uv_hyb_ens,q_hyb_ens,aniso_a_en,generate_ens,n_ens,l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,nlon_ens,nlat_ens,jcap_ens,&
+! For L2, a different configuration of VDL can be applied:
+! ~~~~~~~~~
+! 'sf','vp','ps','t','q' will share the same localization length of v2L2;
+! 'qr','qs','qg','dbz','w','ql','qi', use the same localization length of v2L2
+! vdl_scale - number of variables in each variable-group, effective only with assign_vdl_nml=.true.
+! if 3 variable-groups with 2 separated scale is set,
+! vdl_scale = 3, 3, 3, 2, 2
+! ^ ^ ^ ^ ^
+! s_ens_h = v1L1 v2L1 v3L1 v1L2 v2L2
+! Then localization lengths will be assigned as above.
+! l_mgbf_loc - if true, multi-grid beta filter is used for localization instead of recursive filter
+!
+ namelist/hybrid_ensemble/l_hyb_ens,uv_hyb_ens,q_hyb_ens,aniso_a_en,generate_ens,n_ens,&
+ l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_gfs,weight_ens_fv3sar,nlon_ens,nlat_ens,jcap_ens,&
pseudo_hybens,merge_two_grid_ensperts,regional_ensemble_option,fv3sar_bg_opt,fv3sar_ensemble_opt,full_ensemble,pwgtflg,&
jcap_ens_test,beta_s0,beta_e0,s_ens_h,s_ens_v,readin_localization,eqspace_ensgrid,readin_beta,&
grid_ratio_ens, &
oz_univ_static,write_ens_sprd,use_localization_grid,use_gfs_ens, &
i_en_perts_io,l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB,limqens, &
- nsclgrp,l_timloc_opt,ngvarloc,naensloc,i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl
+ nsclgrp,l_timloc_opt,ngvarloc,naensloc,r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl,&
+ vdl_scale,vloc_varlist,&
+ global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers,l_mgbf_loc
! rapidrefresh_cldsurf (options for cloud analysis and surface
! enhancement for RR appilcation ):
@@ -1518,6 +1600,13 @@ module gsimod
! = 2(clean Qg as in 1, and adjustment to the retrieved Qr/Qs/Qnr throughout the whole profile)
! = 3(similar to 2, but adjustment to Qr/Qs/Qnr only below maximum reflectivity level
! and where the dbz_obs is missing);
+! corp_howv - real, static background error of howv (stddev error)
+! = 0.42 meters (default)
+! hwllp_howv - real, background error de-correlation length scale of howv
+! = 170,000.0 meters (default 170 km)
+! corp_gust - real, static background error of gust (stddev error)
+! hwllp_gust - real, background error de-correlation length scale of gust
+! oerr_gust - real, observation error of gust
!
namelist/rapidrefresh_cldsurf/dfi_radar_latent_heat_time_period, &
metar_impact_radius,metar_impact_radius_lowcloud, &
@@ -1538,11 +1627,18 @@ module gsimod
i_coastline,i_gsdqc,qv_max_inc,ioption,l_precip_clear_only,l_fog_off,&
cld_bld_coverage,cld_clr_coverage,&
i_cloud_q_innovation,i_ens_mean,DTsTmax, &
- i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check
+ i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check, &
+ corp_howv, hwllp_howv, corp_gust, hwllp_gust, oerr_gust
! chem(options for gsi chem analysis) :
! berror_chem - .true. when background for chemical species that require
! conversion to lower case and/or species names longer than 5 chars
+! berror_fv3_cmaq_regional - .true. use background error stat for online
+! RRFS_CMAQ model. Control variable
+! names extended up to 10 chars
+! berror_fv3_sd_regional - .true. use background error stat for online
+! RRFS_SD model. Control variable
+! names extended up to 10 chars
! oneobtest_chem - one-ob trigger for chem constituent analysis
! maginnov_chem - O-B make-believe residual for one-ob chem test
! magoberr_chem - make-believe obs error for one-ob chem test
@@ -1564,13 +1660,15 @@ module gsimod
! luse_deepblue - whether to use MODIS AOD from the deepblue algorithm
! lread_ext_aerosol - if true, reads aerfNN file for aerosol arrays rather than sigfNN (NGAC NEMS IO)
- namelist/chem/berror_chem,berror_fv3_cmaq_regional,oneobtest_chem,maginnov_chem,magoberr_chem,&
+ namelist/chem/berror_chem,berror_fv3_cmaq_regional,berror_fv3_sd_regional,&
+ oneobtest_chem,anowbufr_ext,maginnov_chem,magoberr_chem,&
oneob_type_chem,oblat_chem,oblon_chem,obpres_chem,&
diag_incr,elev_tolerance,tunable_error,&
in_fname,out_fname,incr_fname,&
laeroana_gocart, laeroana_fv3cmaq,laeroana_fv3smoke,l_aoderr_table, aod_qa_limit, &
crtm_aerosol_model,crtm_aerosolcoeff_format,crtm_aerosolcoeff_file, &
icvt_cmaq_fv3,pm2_5_innov_threshold, &
+ pm2_5_innov_threshold,pm2_5_urban_innov_threshold,pm2_5_bg_threshold,&
raod_radius_mean_scale,raod_radius_std_scale, luse_deepblue,&
aero_ratios,wrf_pm2_5, lread_ext_aerosol
@@ -1586,6 +1684,40 @@ module gsimod
! fac_tsl - index to apply thermal skin layer or not: 0 = no; 1 = yes.
namelist/nst/nst_gsi,nstinfo,zsea1,zsea2,fac_dtl,fac_tsl
+! Initialize the Cloud and Aerosol Detection Software (CADS)
+!
+! M__Sensor Unique ID for sensor
+! N__Num_Bands Number of channel bands
+! N__Band_Size(:) Number of channels in each band
+! N__Bands(:,:) Channel lists
+! N__Window_Width(:) Smoothing filter window widths per band
+! N__Window_Bounds(:,:) Channels in the spectral window gradient check
+! N__GradChkInterval(:) Window width used in gradient calculation
+! R__BT_Threshold(:) BT threshold for cloud contamination
+! R__Grad_Threshold(:) Gradient threshold for cloud contamination
+! R__Window_Grad_Threshold(:) Threshold for window gradient check in QE
+! L__Do_Quick_Exit On/off switch for the Quick Exit scenario
+! L__Do_CrossBand On/off switch for the cross-band method
+! N__BandToUse(:) Band number assignment for each channel
+! L__Do_Imager_Cloud_Detection On/off switch for the imager cloud detection
+! N__Num_Imager_Chans No. of imager channels
+! N__Num_Imager_Clusters No. of clusters to be expected
+! N__Imager_Chans(:) List of imager channels
+! R__Stddev_Threshold(:) St. Dev. threshold, one for each imager channel
+! R__Coverage_Threshold Threshold for fractional coverage of a cluster
+! R__FG_Departure_Threshold Threshold for imager FG departure
+
+ NAMELIST / Cloud_Detect_Coeffs / M__Sensor, N__Num_Bands, &
+ N__Band_Size, N__Bands, N__Window_Width, N__Window_Bounds, &
+ N__GradChkInterval, R__BT_Threshold, R__Grad_Threshold, &
+ R__Window_Grad_Threshold, L__Do_Quick_Exit, &
+ L__Do_CrossBand, N__BandToUse, &
+ L__Do_Imager_Cloud_Detection, N__Num_Imager_Chans, &
+ N__Num_Imager_Clusters, N__Imager_Chans, &
+ R__Stddev_Threshold, R__Coverage_Threshold, &
+ R__FG_Departure_Threshold
+
+
!EOC
!---------------------------------------------------------------------------
@@ -1672,6 +1804,7 @@ subroutine gsimain_initialize
call set_fgrid2agrid
call gsi_nstcoupler_init_nml
call init_radaruse_directDA
+ call CADS_Setup_Cloud
if(mype==0) write(6,*)' at 0 in gsimod, use_gfs_stratosphere,nems_nmmb_regional = ', &
use_gfs_stratosphere,nems_nmmb_regional
@@ -1785,9 +1918,10 @@ subroutine gsimain_initialize
n_ens_gfs=n_ens
n_ens_fv3sar=0
else
- write(6,*)'n_ens_gfs and n_ens_fv3sar won"t be used if not regional_ensemble_option==5'
+ if(mype == 0)write(6,*)'n_ens_gfs and n_ens_fv3sar won"t be used if not regional_ensemble_option==5'
endif
-
+ weight_ens_gfs=one
+ weight_ens_fv3sar=one
endif
if(ltlint) then
if(vqc .or. njqc .or. nvqc)then
@@ -1839,7 +1973,9 @@ subroutine gsimain_initialize
else
naensgrp=ntotensgrp
endif
- if(naensloc 0 and if_model_fed=.true.',332)
+ end if
+
+ if (.not. (miter == 0 .or. lobserver) .and. if_model_dbz .and. .not. dbz_exist) then
+ if(mype==0) write(6,*)' GSIMOD: .not. (miter == 0 .or. lobserver) and if_model_dbz=.true. but dbz is not in anavinfo file'
+ call die(myname_,'Please check namelist parameters and/or add dbz in anavinfo (contro/state_vector and met_guess) when miter > 0 and if_model_fed=.true.',334)
+ end if
! Ensure valid number of horizontal scales
if (nhscrf<0 .or. nhscrf>3) then
@@ -1934,6 +2096,7 @@ subroutine gsimain_initialize
diag_pcp=.false.
diag_light=.false.
diag_radardbz=.false.
+ diag_fed=.false.
use_limit = 0
end if
if(reduce_diag) use_limit = 0
@@ -2002,15 +2165,17 @@ subroutine gsimain_initialize
baldiag_inc =.false.
end if
-! If reflectivity is intended to be assimilated, beta_s0 should be zero.
+! Warning of reflectivity assimilation with static B
if ( beta_s0 > 0.0_r_kind )then
! skipped in case of direct reflectivity DA because it works in Envar and hybrid
if ( l_use_rw_columntilt .or. l_use_dbz_directDA) then
do i=1,ndat
- if ( index(dtype(i), 'dbz') /= 0 )then
- write(6,*)'beta_s0 needs to be set to zero in this GSI version, when reflectivity is directly assimilated. &
- Static B extended for radar reflectivity assimilation will be included in future version.'
- call stop2(8888)
+ if ( if_model_dbz .and. (index(dtype(i), 'dbz') /= 0) )then
+ if (mype==0) then
+ write(6,*)'GSIMOD: ***WARNING*** static B for reflectivity is regarded as zero in this GSI version &
+ even though beta_s0 =',beta_s0
+ write(6,*)'Static B extended for radar reflectivity assimilation will be included in future version.'
+ end if
end if
end do
end if
@@ -2168,7 +2333,7 @@ subroutine gsimain_initialize
endif
! Set up directories (or pe specific filenames)
- call init_directories(mype)
+ call init_directories(mype,npe)
! Initialize space for qc
call create_qcvars
diff --git a/src/gsi/gsisub.F90 b/src/gsi/gsisub.F90
index 6aef101f55..94489266ba 100644
--- a/src/gsi/gsisub.F90
+++ b/src/gsi/gsisub.F90
@@ -194,7 +194,7 @@ subroutine gsisub(init_pass,last_pass)
end if
if(last_pass) call observer_finalize()
#ifndef HAVE_ESMF
- call destroy_gesfinfo() ! paired with gesinfo()
+ call destroy_gesfinfo() ! paired with gesinfo()
#endif
else
call glbsoi
diff --git a/src/gsi/guess_grids.F90 b/src/gsi/guess_grids.F90
index e19ce93638..0601959aad 100644
--- a/src/gsi/guess_grids.F90
+++ b/src/gsi/guess_grids.F90
@@ -977,18 +977,29 @@ subroutine create_gesfinfo
nfldaer_all=nfldaer
nfldaer_now=0
extrap_intime=.true.
- allocate(hrdifsfc(nfldsfc),ifilesfc(nfldsfc), &
- hrdifnst(nfldnst),ifilenst(nfldnst), &
- hrdifsig(nfldsig),ifilesig(nfldsig), &
- hrdifaer(nfldaer),ifileaer(nfldaer), &
- hrdifsfc_all(nfldsfc_all), &
- hrdifnst_all(nfldnst_all), &
- hrdifsig_all(nfldsig_all), &
- hrdifaer_all(nfldaer_all), &
- stat=istatus)
+ if(nfldsig>0) allocate(hrdifsig(nfldsig),ifilesig(nfldsig), &
+ hrdifsig_all(nfldsig_all), &
+ stat=istatus)
if (istatus/=0) &
- write(6,*)'CREATE_GESFINFO(hrdifsfc,..): allocate error, istatus=',&
- istatus
+ call die('CREATE_GESFINFO', '(hrdifsig,..): allocate error, istatus=', istatus)
+ if(nfldsfc>0) allocate(hrdifsfc(nfldsfc),ifilesfc(nfldsfc), &
+ hrdifsfc_all(nfldsfc_all), &
+ stat=istatus)
+ if (istatus/=0) &
+ call die('CREATE_GESFINFO', '(hrdifsfc,..): allocate error, istatus=',&
+ istatus)
+ if(nfldnst>0) allocate(hrdifnst(nfldnst),ifilenst(nfldnst), &
+ hrdifnst_all(nfldnst_all), &
+ stat=istatus)
+ if (istatus/=0) &
+ call die('CREATE_GESFINFO', '(hrdifnst,..): allocate error, istatus=',&
+ istatus)
+ if(nfldnst>0) allocate(hrdifaer(nfldaer),ifileaer(nfldaer), &
+ hrdifaer_all(nfldaer_all), &
+ stat=istatus)
+ if (istatus/=0) &
+ call die('CREATE_GESFINFO', '(hrdifaer,..): allocate error, istatus=',&
+ istatus)
#endif /* HAVE_ESMF */
return
@@ -1030,11 +1041,18 @@ subroutine destroy_gesfinfo
gesfinfo_created_=.false.
#ifndef HAVE_ESMF
- deallocate(hrdifsfc,ifilesfc,hrdifnst,hrdifaer,ifilenst,hrdifsig,ifilesig,ifileaer,&
- hrdifsfc_all,hrdifnst_all,hrdifsig_all,hrdifaer_all,stat=istatus)
+ if(nfldsig>0) deallocate(hrdifsig,ifilesig,hrdifsig_all,stat=istatus)
if (istatus/=0) &
- write(6,*)'DESTROY_GESFINFO: deallocate error, istatus=',&
- istatus
+ call die('DESTROY_GESFINFO', 'deallocate error, istatus=',istatus)
+ if(nfldsfc>0) deallocate(hrdifsfc,ifilesfc,hrdifsfc_all,stat=istatus)
+ if (istatus/=0) &
+ call die('DESTROY_GESFINFO', 'deallocate error, istatus=',istatus)
+ if(nfldnst>0) deallocate(hrdifnst,ifilenst,hrdifnst_all,stat=istatus)
+ if (istatus/=0) &
+ call die('DESTROY_GESFINFO', 'deallocate error, istatus=',istatus)
+ if(nfldnst>0) deallocate(hrdifaer,ifileaer,hrdifaer_all,stat=istatus)
+ if (istatus/=0) &
+ call die('DESTROY_GESFINFO', 'deallocate error, istatus=',istatus)
nfldsfc_all=0
nfldnst_all=0
@@ -1765,7 +1783,7 @@ subroutine load_gsdpbl_hgt(mype)
k=1
DO while (abs(pbl_height(i,j,jj)) < 0.0001_r_kind)
if( thetav(k) > thsfc + 1.0_r_kind ) then
- pbl_height(i,j,jj) = float(k) - (thetav(k) - (thsfc + 1.0_r_kind))/ &
+ pbl_height(i,j,jj) = real(k,r_kind) - (thetav(k) - (thsfc + 1.0_r_kind))/ &
max((thetav(k)-thetav(k-1)),0.01_r_kind)
endif
k=k+1
@@ -2300,7 +2318,7 @@ subroutine guess_grids_stats3d_(name,a,mype)
end do
end do
end do
- work_a(nsig+1)=float(lon1*lat1)
+ work_a(nsig+1)=real(lon1*lat1,r_kind)
call mpi_allreduce(work_a,work_a1,nsig+1,mpi_rtype,mpi_sum,&
mpi_comm_world,ierror)
@@ -2368,7 +2386,7 @@ subroutine guess_grids_stats2d_(name,a,mype)
work_a(1) = work_a(1) + a(i,j)
end do
end do
- work_a(2)=float(lon1*lat1)
+ work_a(2)=real(lon1*lat1,r_kind)
call mpi_allreduce(work_a,work_a1,2,mpi_rtype,mpi_sum,&
mpi_comm_world,ierror)
diff --git a/src/gsi/hdraobmod.f90 b/src/gsi/hdraobmod.f90
index 00abeb66be..3444c96fcc 100644
--- a/src/gsi/hdraobmod.f90
+++ b/src/gsi/hdraobmod.f90
@@ -188,7 +188,7 @@ subroutine read_hdraob(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
real(r_kind),dimension(nsig):: presl,hgtl
real(r_kind),dimension(nsig-1):: dpres
real(r_kind),dimension(maxlevs)::plevs
- real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out
+ real(r_kind),allocatable,dimension(:,:):: cdata_all
real(r_kind) :: missing
real(r_double) rstation_id,r_station
@@ -580,7 +580,7 @@ subroutine read_hdraob(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! Add obs reference time, then subtract analysis time to get obs
! time relative to analysis
- time_correction=float(minobs-minan)*r60inv
+ time_correction=real(minobs-minan,r_kind)*r60inv
else
time_correction=zero
@@ -1271,20 +1271,13 @@ subroutine read_hdraob(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
close(lunin)
! Write header record and data to output file for further processing
- allocate(cdata_out(nreal,ndata))
- do i=1,ndata
- do k=1,nreal
- cdata_out(k,i)=cdata_all(k,i)
- end do
- end do
- deallocate(cdata_all)
- call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs)
+ call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata
- write(lunout) cdata_out
+ write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata)
- deallocate(cdata_out)
+ deallocate(cdata_all)
if(diagnostic_reg .and. ntest>0) write(6,*)'READ_HDRAOB: ',&
'ntest,disterrmax=',ntest,disterrmax
diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90
index 3fa827f1f6..87f3605eaf 100644
--- a/src/gsi/hybrid_ensemble_isotropic.F90
+++ b/src/gsi/hybrid_ensemble_isotropic.F90
@@ -49,6 +49,7 @@ module hybrid_ensemble_isotropic
! 2016-05-13 parrish - remove beta12mult
! 2018-02-15 wu - add code for fv3_regional option
! 2022-09-15 yokota - add scale/variable/time-dependent localization
+! 2024-02-20 yokota - add MGBF-based localization
!
! subroutines included:
! sub init_rf_z - initialize localization recursive filter (z direction)
@@ -102,6 +103,10 @@ module hybrid_ensemble_isotropic
use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d
use string_utility, only: StrUpCase
+! For MGBF
+ use mg_intstate
+ use mg_timers
+
implicit none
! set default to private
@@ -174,6 +179,12 @@ module hybrid_ensemble_isotropic
real(r_kind),allocatable,dimension(:,:,:) :: spectral_filter,sqrt_spectral_filter
integer(i_kind),allocatable,dimension(:) :: k_index
+ integer(r_kind) :: nval_loc_en
+
+! For MGBF
+ type (mg_intstate_type), allocatable, dimension(:) :: obj_mgbf
+ real(r_kind), allocatable, dimension(:,:,:) :: work_mgbf
+
! following is for special subdomain to slab variables used when internally generating ensemble members
integer(i_kind) nval2f,nscl
@@ -183,7 +194,6 @@ module hybrid_ensemble_isotropic
logical,parameter:: debug=.false.
-
contains
subroutine init_rf_z(z_len)
@@ -247,7 +257,7 @@ subroutine init_rf_z(z_len)
kap1=rd_over_cp+one
kapr=one/rd_over_cp
nxy=grd_ens%latlon11
- rnsig=float(nsig)
+ rnsig=real(nsig,r_kind)
! use new factorization:
@@ -591,7 +601,7 @@ subroutine new_factorization_rf_x(f,iadvance,iback,nlevs,ig)
ny=grd_loc%nlat ; nx=grd_loc%nlon ; nz=nlevs
if(vvlocal)then
-!$omp parallel do schedule(dynamic,1) private(k,j,i,l)
+!$omp parallel do schedule(static,1) private(k,j,i,l)
do k=1,nz
if(iadvance == 1) then
@@ -634,7 +644,7 @@ subroutine new_factorization_rf_x(f,iadvance,iback,nlevs,ig)
enddo
else
-!$omp parallel do schedule(dynamic,1) private(k,j,i,l)
+!$omp parallel do schedule(static,1) private(k,j,i,l)
do k=1,nz
if(iadvance == 1) then
@@ -1607,7 +1617,7 @@ subroutine fix_belt(z)
real(r_kind) zloc1(ny,nx)
integer(i_kind) i,ii,j,jj,k
-!$omp parallel do schedule(dynamic,1) private(j,k,i,jj,ii,zloc1)
+!$omp parallel do schedule(static,1) private(j,k,i,jj,ii,zloc1)
do j=1,nscl
do k=1,nnnn1o
i=0
@@ -1686,7 +1696,7 @@ subroutine rescale_ensemble_rh_perturbations
end if
do m=1,ntlevs_ens
do ig=1,ntotensgrp
-!$omp parallel do schedule(dynamic,1) private(n,i,j,k,w3,istatus)
+!$omp parallel do schedule(static,1) private(n,i,j,k,w3,istatus)
do n=1,n_ens
call gsi_bundlegetpointer(en_perts(n,ig,m),'q',w3,istatus)
if(istatus/=0) then
@@ -1732,6 +1742,7 @@ subroutine destroy_ensemble
use hybrid_ensemble_parameters, only: l_hyb_ens,n_ens,ntlevs_ens
use hybrid_ensemble_parameters, only: en_perts,ps_bar
use hybrid_ensemble_parameters, only: ntotensgrp
+ use hybrid_ensemble_parameters, only: l_mgbf_loc
implicit none
integer(i_kind) istatus,n,m,ig
@@ -1750,6 +1761,7 @@ subroutine destroy_ensemble
enddo
deallocate(ps_bar)
deallocate(en_perts)
+ if(l_mgbf_loc) call print_mg_timers("mgbf_timing_cpu.csv", print_cpu, mype)
end if
return
@@ -1835,7 +1847,7 @@ subroutine ensemble_forward_model(cvec,a_en,ibin)
ipx=1
-!$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ipic,ig,iaens)
+!$omp parallel do schedule(static,1) private(j,n,ic3,k,i,ipic,ig,iaens)
do k=1,km
do ic3=1,nc3d
ipic=ipc3d(ic3)
@@ -1860,7 +1872,6 @@ subroutine ensemble_forward_model(cvec,a_en,ibin)
enddo
enddo
-!$omp parallel do schedule(dynamic,1) private(j,n,k,i,ic2,ipic,ig,iaens)
do ic2=1,nc2d
ipic=ipc2d(ic2)
do j=1,jm
@@ -1883,8 +1894,8 @@ subroutine ensemble_forward_model(cvec,a_en,ibin)
iaens=ensgrp2aensgrp(ig,ic2+nc3d,ibin)
if(iaens>0) then
do n=1,n_ens
- do j=1,jm
- do k=1,km_tmp
+ do k=1,km_tmp
+ do j=1,jm
do i=1,im
cvec%r2(ipic)%q(i,j)=cvec%r2(ipic)%q(i,j) &
+a_en(iaens,n)%r3(ipx)%q(i,j,k)*en_perts(n,ig,ibin)%r2(ipic)%qr4(i,j)*pwgt(i,j,k)
@@ -2012,7 +2023,7 @@ subroutine ensemble_forward_model_dual_res(cvec,a_en,ibin)
im=work_ens%grid%im
jm=work_ens%grid%jm
km=work_ens%grid%km
-!$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ipic,ig,iaens)
+!$omp parallel do schedule(static,1) private(j,n,ic3,k,i,ipic,ig,iaens)
do k=1,km
do ic3=1,nc3d
ipic=ipc3d(ic3)
@@ -2036,7 +2047,6 @@ subroutine ensemble_forward_model_dual_res(cvec,a_en,ibin)
enddo
enddo
enddo
-!$omp parallel do schedule(dynamic,1) private(j,n,k,i,ic2,ipic,ig,iaens)
do ic2=1,nc2d
ipic=ipc2d(ic2)
do j=1,jm
@@ -2189,7 +2199,7 @@ subroutine ensemble_forward_model_ad(cvec,a_en,ibin)
endif
ipx=1
-!$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ic2,ipic,ig,iaens)
+!$omp parallel do schedule(static,1) private(j,n,ic3,k,i,ic2,ipic,ig,iaens)
do n=1,n_ens
do ig=1,ntotensgrp
do ic3=1,nc3d
@@ -2206,6 +2216,7 @@ subroutine ensemble_forward_model_ad(cvec,a_en,ibin)
enddo
endif ! iaens>0
enddo
+
do ic2=1,nc2d
iaens=ensgrp2aensgrp(ig,ic2+nc3d,ibin)
if(iaens>0) then
@@ -2354,7 +2365,7 @@ subroutine ensemble_forward_model_ad_dual_res(cvec,a_en,ibin)
im=a_en(1,1)%grid%im
jm=a_en(1,1)%grid%jm
km=a_en(1,1)%grid%km
-!$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ic2,ipic,ig,iaens)
+!$omp parallel do schedule(static,1) private(j,n,ic3,k,i,ic2,ipic,ig,iaens)
do n=1,n_ens
do ig=1,ntotensgrp
do ic3=1,nc3d
@@ -2686,7 +2697,7 @@ subroutine sqrt_beta_s_mult_cvec(grady)
endif
! multiply by sqrt_beta_s
-!$omp parallel do schedule(dynamic,1) private(ic3,ic2,k,j,i,ii)
+!$omp parallel do schedule(static,1) private(ic3,ic2,k,j,i,ii)
do j=1,lon2
do ii=1,nsubwin
do ic3=1,nc3d
@@ -2784,7 +2795,7 @@ subroutine sqrt_beta_s_mult_bundle(grady)
endif
! multiply by sqrt_beta_s
-!$omp parallel do schedule(dynamic,1) private(ic3,ic2,k,j,i)
+!$omp parallel do schedule(static,1) private(ic3,ic2,k,j,i)
do j=1,lon2
do ic3=1,nc3d
! check for ozone and skip if oz_univ_static = true
@@ -2864,12 +2875,12 @@ subroutine sqrt_beta_e_mult_cvec(grady)
call timer_ini('sqrt_beta_e_mult')
! multiply by sqrt_beta_e
-!$omp parallel do schedule(dynamic,1) private(nn,k,j,i,ii,ig)
- do j=1,grd_ens%lon2
+!$omp parallel do schedule(static,1) private(nn,k,j,i,ii,ig)
+ do nn=1,n_ens
do ii=1,nsubwin
do ig=1,naensgrp
- do nn=1,n_ens
- do k=1,nsig
+ do k=1,nsig
+ do j=1,grd_ens%lon2
do i=1,grd_ens%lat2
grady%aens(ii,ig,nn)%r3(1)%q(i,j,k) = sqrt_beta_e(k)*grady%aens(ii,ig,nn)%r3(1)%q(i,j,k)
enddo
@@ -2931,11 +2942,11 @@ subroutine sqrt_beta_e_mult_bundle(aens)
call timer_ini('sqrt_beta_e_mult')
! multiply by sqrt_beta_e
-!$omp parallel do schedule(dynamic,1) private(nn,k,j,i,ig)
- do j=1,grd_ens%lon2
+!$omp parallel do schedule(static,1) private(nn,k,j,i,ig)
+ do nn=1,n_ens
do ig=1,naensgrp
- do nn=1,n_ens
- do k=1,nsig
+ do k=1,nsig
+ do j=1,grd_ens%lon2
do i=1,grd_ens%lat2
aens(ig,nn)%r3(1)%q(i,j,k) = sqrt_beta_e(k)*aens(ig,nn)%r3(1)%q(i,j,k)
enddo
@@ -2993,19 +3004,18 @@ subroutine init_sf_xy(jcap_in)
integer(i_kind),intent(in ) :: jcap_in
- integer(i_kind) i,ii,j,k,l,n,jcap,kk,nsigend,ig
- real(r_kind),allocatable::g(:),gsave(:)
+ integer(i_kind) i,ii,j,igg,k,l,n,jcap,kk,nsigend,ig
+ real(r_kind),allocatable::g(:),gtemp(:)
real(r_kind) factor
real(r_kind),allocatable::rkm(:),f(:,:),f0(:,:)
real(r_kind) ftest(grd_loc%nlat,grd_loc%nlon,grd_loc%kbegin_loc:grd_loc%kend_alloc)
real(r_single) out1(grd_ens%nlon,grd_ens%nlat)
- real(r_single),allocatable::pn0_npole(:)
+ real(r_single) pn0_npole
real(r_kind) s_ens_h_min
real(r_kind) rlats_ens_local(grd_ens%nlat)
real(r_kind) rlons_ens_local(grd_ens%nlon)
character(5) mapname
logical make_test_maps
- logical,allocatable,dimension(:)::ksame
integer(i_kind) nord_sploc2ens
integer(i_kind) nlon_sploc0,nlon_sploc,nlat_sploc,num_fields
logical print_verbose
@@ -3157,101 +3167,107 @@ subroutine init_sf_xy(jcap_in)
if(.not.allocated(spectral_filter)) allocate(spectral_filter(naensloc,sp_loc%nc,grd_sploc%nsig))
if(.not.allocated(sqrt_spectral_filter)) allocate(sqrt_spectral_filter(naensloc,sp_loc%nc,grd_sploc%nsig))
- allocate(g(sp_loc%nc),gsave(sp_loc%nc))
- allocate(pn0_npole(0:sp_loc%jcap))
- allocate(ksame(grd_sploc%nsig))
+ allocate(g(sp_loc%nc),gtemp(sp_loc%nc))
do ig=1,naensloc
- ksame=.false.
- do k=2,grd_sploc%nsig
- if(s_ens_hv(k,ig) == s_ens_hv(k-1,ig))ksame(k)=.true.
- enddo
spectral_filter(ig,:,:)=zero
- do k=1,grd_sploc%nsig
- if(ksame(k))then
- spectral_filter(ig,:,k)=spectral_filter(ig,:,k-1)
- else
+ level_loop: do k=1,grd_sploc%nsig
+ do kk=1,k-1
+ if(s_ens_hv(k,ig) == s_ens_hv(kk,ig))then
+ spectral_filter(ig,:,k)=spectral_filter(ig,:,k-1)
+ cycle level_loop
+ end if
+ end do
+ if(ig > 1)then
+ do igg=1,ig-1
+ do kk=1,grd_sploc%nsig
+ if(s_ens_hv(k,ig) == s_ens_hv(kk,igg))then
+ spectral_filter(ig,:,k)=spectral_filter(igg,:,kk)
+ cycle level_loop
+ end if
+ end do
+ end do
+ end if
+
+ do i=1,grd_sploc%nlat
+ f0(i,1)=exp(-half*(rkm(i)/s_ens_hv(k,ig))**2)
+ enddo
+
+
+ do j=2,grd_sploc%nlon
do i=1,grd_sploc%nlat
- f0(i,1)=exp(-half*(rkm(i)/s_ens_hv(k,ig))**2)
+ f0(i,j)=f0(i,1)
enddo
+ end do
- do j=2,grd_sploc%nlon
- do i=1,grd_sploc%nlat
- f0(i,j)=f0(i,1)
- enddo
- enddo
- call general_g2s0(grd_sploc,sp_loc,g,f0)
+ call general_g2s0(grd_sploc,sp_loc,g,f0)
- call general_s2g0(grd_sploc,sp_loc,g,f)
+ call general_s2g0(grd_sploc,sp_loc,g,f)
-! adjust so value at np = 1
- f=f/f(grd_sploc%nlat,1)
- f0=f
- call general_g2s0(grd_sploc,sp_loc,g,f)
- call general_s2g0(grd_sploc,sp_loc,g,f)
- if(mype == 0)then
- nsigend=k
- do kk=k+1,grd_sploc%nsig
- if(s_ens_hv(kk,ig) /= s_ens_hv(k,ig))exit
- nsigend=nsigend+1
- enddo
- write(6,900)k,nsigend,sp_loc%jcap,s_ens_hv(k,ig),maxval(abs(f0-f))
-900 format(' in init_sf_xy, jcap,s_ens_hv(',i5,1x,'-',i5,'), max diff(f0-f)=', &
+! adjust so value at np = 1
+ f=f/f(grd_sploc%nlat,1)
+ f0=f
+ call general_g2s0(grd_sploc,sp_loc,g,f)
+ call general_s2g0(grd_sploc,sp_loc,g,f)
+ if(mype == 0)then
+ nsigend=k
+ do kk=k+1,grd_sploc%nsig
+ if(s_ens_hv(kk,ig) /= s_ens_hv(k,ig))exit
+ nsigend=nsigend+1
+ enddo
+ write(6,900)k,nsigend,sp_loc%jcap,s_ens_hv(k,ig),maxval(abs(f0-f))
+900 format(' in init_sf_xy, jcap,s_ens_hv(',i5,1x,'-',i5,'), max diff(f0-f)=', &
i10,f10.2,e20.10)
- end if
+ end if
-! correct spectrum by dividing by pn0_npole
- gsave=g
+! correct spectrum by dividing by pn0_npole
-! obtain pn0_npole
- do n=0,sp_loc%jcap
- g=zero
- g(2*n+1)=one
- call general_s2g0(grd_sploc,sp_loc,g,f)
- pn0_npole(n)=f(grd_sploc%nlat,1)
- enddo
+! obtain pn0_npole
+!$omp parallel do schedule(static,1) private(n,gtemp,f)
+ do n=0,sp_loc%jcap
+ gtemp=zero
+ gtemp(2*n+1)=one
+ call general_s2g0(grd_sploc,sp_loc,gtemp,f)
+ pn0_npole=f(grd_sploc%nlat,1)
+ g(2*n+1)=g(2*n+1)/pn0_npole
+ enddo
- g=zero
- do n=0,sp_loc%jcap
- g(2*n+1)=gsave(2*n+1)/pn0_npole(n)
- enddo
-! obtain spectral_filter
+! obtain spectral_filter
- ii=0
- do l=0,sp_loc%jcap
- if(ig>naensgrp) then
- factor=one/g(1)
+ ii=0
+ do l=0,sp_loc%jcap
+ if(ig>naensgrp) then
+ factor=one/g(1)
+ else
+ factor=one
+ if(l>0) factor=half
+ end if
+ do n=l,sp_loc%jcap
+ ii=ii+1
+ if(sp_loc%factsml(ii)) then
+ spectral_filter(ig,ii,k)=zero
else
- factor=one
- if(l>0) factor=half
+ spectral_filter(ig,ii,k)=factor*g(2*n+1)
+ end if
+ ii=ii+1
+ if(l == 0 .or. sp_loc%factsml(ii)) then
+ spectral_filter(ig,ii,k)=zero
+ else
+ spectral_filter(ig,ii,k)=factor*g(2*n+1)
end if
- do n=l,sp_loc%jcap
- ii=ii+1
- if(sp_loc%factsml(ii)) then
- spectral_filter(ig,ii,k)=zero
- else
- spectral_filter(ig,ii,k)=factor*g(2*n+1)
- end if
- ii=ii+1
- if(l == 0 .or. sp_loc%factsml(ii)) then
- spectral_filter(ig,ii,k)=zero
- else
- spectral_filter(ig,ii,k)=factor*g(2*n+1)
- end if
- enddo
enddo
- end if
- enddo
+ enddo
+ enddo level_loop
enddo !ig loop
- deallocate(g,gsave,pn0_npole,ksame)
+ deallocate(g,gtemp)
! Compute sqrt(spectral_filter). Ensure spectral_filter >=0 zero
-!$omp parallel do schedule(dynamic,1) private(k,i)
+!$omp parallel do schedule(static,1) private(k,i)
do ig=1,naensloc
do k=1,grd_sploc%nsig
do i=1,sp_loc%nc
- if (spectral_filter(ig,i,k) < zero) spectral_filter(ig,i,k)=zero
+ spectral_filter(ig,i,k) = max(spectral_filter(ig,i,k),zero)
sqrt_spectral_filter(ig,i,k) = sqrt(spectral_filter(ig,i,k))
end do
end do
@@ -3337,13 +3353,14 @@ subroutine sf_xy(ig,f,k_start,k_end)
if(.not.use_localization_grid) then
if(ig>naensgrp) then
+!$omp parallel do schedule(static,1) private(k,g)
do k=k_start,k_end
call general_g2s0(grd_ens,sp_loc,g,f(:,:,k))
g(:)=g(:)*spectral_filter(ig,:,k_index(k))
call general_s2g0(grd_ens,sp_loc,g,f(:,:,k))
enddo
else
-!$omp parallel do schedule(dynamic,1) private(k)
+!$omp parallel do schedule(static,1) private(k)
do k=k_start,k_end
call sfilter(grd_ens,sp_loc,spectral_filter(ig,:,k_index(k)),f(1,1,k))
enddo
@@ -3353,6 +3370,7 @@ subroutine sf_xy(ig,f,k_start,k_end)
vector=.false.
if(ig>naensgrp) then
+!$omp parallel do schedule(static,1) private(k,g,work)
do k=k_start,k_end
call g_agrid2egrid(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k))
call general_g2s0(grd_ens,sp_loc,g,f(:,:,k))
@@ -3361,7 +3379,7 @@ subroutine sf_xy(ig,f,k_start,k_end)
call g_egrid2agrid(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k))
enddo
else
-!$omp parallel do schedule(dynamic,1) private(k,work)
+!$omp parallel do schedule(static,1) private(k,work)
do k=k_start,k_end
call g_egrid2agrid_ad(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k))
call sfilter(grd_ens,sp_loc,spectral_filter(ig,:,k_index(k)),f(1,1,k))
@@ -3421,6 +3439,7 @@ subroutine sqrt_sf_xy(ig,z,f,k_start,k_end)
if(.not.use_localization_grid) then
+!$omp parallel do schedule(static,1) private(k,g)
do k=k_start,k_end
g(:)=z(:,k)*sqrt_spectral_filter(ig,:,k_index(k))
call general_s2g0(grd_ens,sp_loc,g,f(:,:,k))
@@ -3429,6 +3448,7 @@ subroutine sqrt_sf_xy(ig,z,f,k_start,k_end)
else
vector=.false.
+!$omp parallel do schedule(static,1) private(k,g,work)
do k=k_start,k_end
g(:)=z(:,k)*sqrt_spectral_filter(ig,:,k_index(k))
call general_s2g0(grd_sploc,sp_loc,g,work)
@@ -3488,6 +3508,7 @@ subroutine sqrt_sf_xy_ad(ig,z,f,k_start,k_end)
if(.not.use_localization_grid) then
+!$omp parallel do schedule(static,1) private(k,g)
do k=k_start,k_end
call general_s2g0_ad(grd_ens,sp_loc,g,f(:,:,k))
z(:,k)=g(:)*sqrt_spectral_filter(ig,:,k_index(k))
@@ -3496,6 +3517,7 @@ subroutine sqrt_sf_xy_ad(ig,z,f,k_start,k_end)
else
vector=.false.
+!$omp parallel do schedule(static,1) private(k,g,work)
do k=k_start,k_end
call g_egrid2agrid_ad(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k))
call general_s2g0_ad(grd_sploc,sp_loc,g,work)
@@ -3592,13 +3614,12 @@ subroutine bkerror_a_en(grady)
!$$$ end documentation block
use kinds, only: r_kind,i_kind
use constants, only: zero
- use gsi_4dvar, only: nsubwin, lsqrtb
+ use gsi_4dvar, only: nsubwin
use control_vectors, only: control_vector
use timermod, only: timer_ini,timer_fnl
use hybrid_ensemble_parameters, only: n_ens
use hybrid_ensemble_parameters, only: naensgrp
use hybrid_ensemble_parameters, only: alphacvarsclgrpmat
- use hybrid_ensemble_parameters, only: nval_lenz_en
use gsi_bundlemod,only: gsi_bundlegetpointer
implicit none
@@ -3608,12 +3629,7 @@ subroutine bkerror_a_en(grady)
! Declare local variables
integer(i_kind) ii,ip,istatus,k,ig,ig2
real(r_kind),allocatable,dimension(:,:) :: z
- real(r_kind),allocatable,dimension(:) :: ztmp
-
- if (lsqrtb) then
- write(6,*)'bkerror_a_en: not for use with lsqrtb'
- call stop2(317)
- end if
+ real(r_kind),allocatable,dimension(:) :: z2
! Initialize timer
call timer_ini('bkerror_a_en')
@@ -3629,33 +3645,29 @@ subroutine bkerror_a_en(grady)
call sqrt_beta_e_mult(grady)
! Apply variances, as well as vertical & horizontal parts of background error
- do ii=1,nsubwin
- if (naensgrp==1) then
+ if (naensgrp==1) then
+ do ii=1,nsubwin
call bkgcov_a_en_new_factorization(1,grady%aens(ii,1,1:n_ens))
- else
- allocate(z(naensgrp,nval_lenz_en))
+ end do
+ else
+ allocate(z(nval_loc_en,naensgrp))
+ allocate(z2(nval_loc_en))
+ do ii=1,nsubwin
do ig=1,naensgrp
- call ckgcov_a_en_new_factorization_ad(ig,z(ig,:),grady%aens(ii,ig,1:n_ens))
+ call ckgcov_a_en_new_factorization_ad(ig,z(1,ig),grady%aens(ii,ig,1:n_ens))
enddo
- allocate(ztmp(naensgrp))
- do k=1,nval_lenz_en
- ztmp=zero
- do ig=1,naensgrp
- do ig2=1,naensgrp
- ztmp(ig) = ztmp(ig) + z(ig2,k) * alphacvarsclgrpmat(ig,ig2)
+ do ig=1,naensgrp
+ z2=zero
+ do ig2=1,naensgrp
+ do k=1,nval_loc_en
+ z2(k) = z2(k) + z(k,ig2) * alphacvarsclgrpmat(ig,ig2)
enddo
enddo
- do ig=1,naensgrp
- z(ig,k) = ztmp(ig)
- enddo
- enddo
- deallocate(ztmp)
- do ig=1,naensgrp
- call ckgcov_a_en_new_factorization(ig,z(ig,:),grady%aens(ii,ig,1:n_ens))
+ call ckgcov_a_en_new_factorization(ig,z2,grady%aens(ii,ig,1:n_ens))
enddo
- deallocate(z)
- endif
- enddo
+ enddo
+ deallocate(z,z2)
+ endif
! multiply by sqrt_beta_e_mult
call sqrt_beta_e_mult(grady)
@@ -3698,9 +3710,11 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en)
use kinds, only: r_kind,i_kind
use gridmod, only: regional
use hybrid_ensemble_parameters, only: n_ens,grd_loc
+ use hybrid_ensemble_parameters, only: l_mgbf_loc,naensgrp
use general_sub2grid_mod, only: general_sub2grid,general_grid2sub
use gsi_bundlemod, only: gsi_bundle
use gsi_bundlemod, only: gsi_bundlegetpointer
+ use constants, only: zero
implicit none
@@ -3710,66 +3724,107 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en)
type(gsi_bundle),intent(inout) :: a_en(n_ens)
! Local Variables
- integer(i_kind) ii,k,iflg,iadvance,iback,is,ie,ipnt,istatus
+ integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus
real(r_kind) hwork(grd_loc%inner_vars,grd_loc%nlat,grd_loc%nlon,grd_loc%kbegin_loc:grd_loc%kend_alloc)
real(r_kind),allocatable,dimension(:):: a_en_work
- iflg=1
+ ipnt=1
- call gsi_bundlegetpointer(a_en(1),'a_en',ipnt,istatus)
- if(istatus/=0) then
- write(6,*)'bkgcov_a_en_new_factorization: trouble getting pointer to ensemble CV'
- call stop2(999)
- endif
+! MGBF-based localization (now available only in regional=.true.)
+! (Note that MGBF is applied only in ig<=naensgrp
+! because recursive filter is applied for ig>naensgrp
+! to separate scales for scale-dependent localization
+! even in MGBF-based localization)
+ if(l_mgbf_loc.and.ig<=naensgrp) then
+
+! Apply vertical smoother on each ensemble member
+ allocate(work_mgbf(obj_mgbf(1)%km_a_all,obj_mgbf(1)%nm,obj_mgbf(1)%mm))
+ work_mgbf=zero
+ iadvance=1 ; iback=2
+!$omp parallel do schedule(static,1) private(k,ii,is,ie)
+ do k=1,n_ens
+ ii=(k-1)*grd_loc%nsig
+ is=ii+1
+ ie=ii+grd_loc%nsig
+ if(.not.obj_mgbf(1)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,1)
+ call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,1)
+ enddo
+
+! Mapping from analysis grid to filter grid
+ call obj_mgbf(1)%anal_to_filt_allmap(work_mgbf)
+
+! Apply horizontal smoother for number of horizontal scales
+ call obj_mgbf(1)%filtering_procedure(obj_mgbf(1)%mgbf_proc,0)
+
+! Mapping from filter grid to analysis grid
+ call obj_mgbf(1)%filt_to_anal_allmap(work_mgbf)
+
+! Apply vertical smoother on each ensemble member
+ iadvance=2 ; iback=1
+!$omp parallel do schedule(static,1) private(k,ii,is,ie)
+ do k=1,n_ens
+ ii=(k-1)*grd_loc%nsig
+ is=ii+1
+ ie=ii+grd_loc%nsig
+ call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,1)
+ if(.not.obj_mgbf(1)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,1)
+ enddo
+ deallocate(work_mgbf)
+
+! Recursive/Spectral filter-based localization(ig<=naensgrp)
+! or scale-separation(ig>naensgrp)
+ else
! Apply vertical smoother on each ensemble member
! To avoid my having to touch the general sub2grid and grid2sub,
! get copy for ensemble components to work array
- allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus)
- if(istatus/=0) then
- write(6,*)'bkgcov_a_en_new_factorization: trouble in alloc(a_en_work)'
- call stop2(999)
- endif
- iadvance=1 ; iback=2
-!$omp parallel do schedule(dynamic,1) private(k,ii,is,ie)
- do k=1,n_ens
- call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
- ii=(k-1)*a_en(1)%ndim
- is=ii+1
- ie=ii+a_en(1)%ndim
- a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim)
- enddo
+ allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus)
+ if(istatus/=0) then
+ write(6,*)'bkgcov_a_en_new_factorization: trouble in alloc(a_en_work)'
+ call stop2(999)
+ endif
+ iadvance=1 ; iback=2
+!$omp parallel do schedule(static,1) private(k,ii,is,ie)
+ do k=1,n_ens
+ call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
+ ii=(k-1)*a_en(1)%ndim
+ is=ii+1
+ ie=ii+a_en(1)%ndim
+ a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim)
+ enddo
! Convert from subdomain to full horizontal field distributed among processors
- call general_sub2grid(grd_loc,a_en_work,hwork)
+ call general_sub2grid(grd_loc,a_en_work,hwork)
! Apply horizontal smoother for number of horizontal scales
- if(regional) then
- iadvance=1 ; iback=2
- call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
- call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
- iadvance=2 ; iback=1
- call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
- call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
- else
- call sf_xy(ig,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc)
- end if
+ if(regional) then
+ iadvance=1 ; iback=2
+ call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
+ call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
+ iadvance=2 ; iback=1
+ call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
+ call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
+ else
+ call sf_xy(ig,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc)
+ end if
! Put back onto subdomains
- call general_grid2sub(grd_loc,hwork,a_en_work)
+ call general_grid2sub(grd_loc,hwork,a_en_work)
! Retrieve ensemble components from long vector
! Apply vertical smoother on each ensemble member
- iadvance=2 ; iback=1
-!$omp parallel do schedule(dynamic,1) private(k,ii,is,ie)
- do k=1,n_ens
- ii=(k-1)*a_en(1)%ndim
- is=ii+1
- ie=ii+a_en(1)%ndim
- a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie)
- call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
- enddo
- deallocate(a_en_work)
+ iadvance=2 ; iback=1
+!$omp parallel do schedule(static,1) private(k,ii,is,ie)
+ do k=1,n_ens
+ ii=(k-1)*a_en(1)%ndim
+ is=ii+1
+ ie=ii+a_en(1)%ndim
+ a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie)
+ call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
+ enddo
+ deallocate(a_en_work)
+
+ endif
return
end subroutine bkgcov_a_en_new_factorization
@@ -3801,7 +3856,7 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en)
use constants, only: zero
use gridmod, only: regional
use hybrid_ensemble_parameters, only: n_ens,grd_loc
- use hybrid_ensemble_parameters, only: nval_lenz_en
+ use hybrid_ensemble_parameters, only: l_mgbf_loc
use general_sub2grid_mod, only: general_grid2sub
use gsi_bundlemod, only: gsi_bundle
use gsi_bundlemod, only: gsi_bundlegetpointer
@@ -3811,17 +3866,23 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en)
! Passed Variables
integer(i_kind),intent(in ) :: ig
type(gsi_bundle),intent(inout) :: a_en(n_ens)
- real(r_kind),dimension(nval_lenz_en),intent(in ) :: z
+ real(r_kind),dimension(nval_loc_en),intent(in ) :: z
+!NOTE:
+! nval_loc_en is the number of horizontally-filtered variables in the domain of each processor.
+! In MGBF-based localization, it is horizontally-local and vertically-global as
+! nval_loc_en = nhoriz * obj_mgbf(ig)%km_all
+! and nhoriz = ( obj_mgbf(ig)%im + obj_mgbf(ig)%hx*2 ) * ( obj_mgbf(ig)%jm + obj_mgbf(ig)%hy*2 )
+! In recursive/spectral filter-based localization, it is horizontally-global and vertically-local as
+! nval_loc_en = nhoriz * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 )
+! and nhoriz = grd_loc%nlat * grd_loc%nlon (for regional recursive filter)
+! nhoriz = ( sp_loc%jcap+1 ) * ( sp_loc%jcap+2 ) (for global spectral filter)
+! but internal array hwork always has
+! dimension grd_loc%nlat * grd_loc%nlon * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 )
+! which would be used as nval_loc_en when the recursive filter is used.
! Local Variables
- integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus
+ integer(i_kind) ii,i,j,k,iadvance,iback,is,ie,ipnt,istatus
real(r_kind) hwork(grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1))
-!NOTE: nval_lenz_en = nhoriz*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)
-! and nhoriz = grd_loc%nlat*grd_loc%nlon for regional,
-! nhoriz = (sp_loc%jcap+1)*(sp_loc%jcap+2) for global
-! but internal array hwork always has
-! dimension grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)
-! which just happens to match up with nval_lenz_en for regional case, but not global.
real(r_kind),allocatable,dimension(:):: a_en_work
call gsi_bundlegetpointer(a_en(1),'a_en',ipnt,istatus)
@@ -3830,53 +3891,90 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en)
call stop2(999)
endif
+! MGBF-based localization (now available only in regional=.true.)
+ if(l_mgbf_loc) then
+
+! Apply horizontal smoother for number of horizontal scales
+ ii=0
+ do k=1,obj_mgbf(ig)%km_all
+ do j=1-obj_mgbf(ig)%hy,obj_mgbf(ig)%jm+obj_mgbf(ig)%hy
+ do i=1-obj_mgbf(ig)%hx,obj_mgbf(ig)%im+obj_mgbf(ig)%hx
+ ii=ii+1
+ obj_mgbf(ig)%VALL(k,i,j)=z(ii)
+ enddo
+ enddo
+ enddo
+ call obj_mgbf(ig)%filtering_procedure(obj_mgbf(ig)%mgbf_proc,1)
+
+! Mapping from filter grid to analysis grid
+ allocate(work_mgbf(obj_mgbf(ig)%km_a_all,obj_mgbf(ig)%nm,obj_mgbf(ig)%mm))
+ work_mgbf=zero
+ call obj_mgbf(ig)%filt_to_anal_allmap(work_mgbf)
- if(grd_loc%kend_loc+1-grd_loc%kbegin_loc==0) then
+! Apply vertical smoother on each ensemble member
+ iadvance=2 ; iback=1
+!$omp parallel do schedule(static,1) private(k,ii,is,ie)
+ do k=1,n_ens
+ ii=(k-1)*grd_loc%nsig
+ is=ii+1
+ ie=ii+grd_loc%nsig
+ call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,ig)
+ if(.not.obj_mgbf(ig)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
+ enddo
+ deallocate(work_mgbf)
+
+! Recursive/Spectral filter-based localization
+ else
+
+ if(grd_loc%kend_loc+1-grd_loc%kbegin_loc==0) then
! no work to be done on this processor, but hwork still has allocated space, since
! grd_loc%kend_alloc = grd_loc%kbegin_loc in this case, so set to zero.
- hwork=zero
- else
+ hwork=zero
+ else
! Apply horizontal smoother for number of horizontal scales
- if(regional) then
+ if(regional) then
! Make a copy of input variable z to hwork
- hwork=z
- iadvance=2 ; iback=1
- call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
- call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
- else
+ hwork=z
+ iadvance=2 ; iback=1
+ call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
+ call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
+ else
#ifdef LATER
- call sqrt_sf_xy(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc)
+ call sqrt_sf_xy(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc)
#else
- write(6,*) ' problem with ibm compiler with "use hybrid_ensemble_isotropic, only: sqrt_sf_xy"'
+ write(6,*) ' problem with ibm compiler with "use hybrid_ensemble_isotropic, only: sqrt_sf_xy"'
#endif /*LATER*/
+ end if
end if
- end if
! Put back onto subdomains
- allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus)
- if(istatus/=0) then
- write(6,*)'ckgcov_a_en_new_factorization: trouble in alloc(a_en_work)'
- call stop2(999)
- endif
- call general_grid2sub(grd_loc,hwork,a_en_work)
+ allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus)
+ if(istatus/=0) then
+ write(6,*)'ckgcov_a_en_new_factorization: trouble in alloc(a_en_work)'
+ call stop2(999)
+ endif
+ call general_grid2sub(grd_loc,hwork,a_en_work)
! Retrieve ensemble components from long vector
- ii=0
- do k=1,n_ens
- is=ii+1
- ie=ii+a_en(1)%ndim
- a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie)
- ii=ii+a_en(1)%ndim
- enddo
- deallocate(a_en_work)
+ ii=0
+ do k=1,n_ens
+ is=ii+1
+ ie=ii+a_en(1)%ndim
+ a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie)
+ ii=ii+a_en(1)%ndim
+ enddo
+ deallocate(a_en_work)
! Apply vertical smoother on each ensemble member
- do k=1,n_ens
-
iadvance=2 ; iback=1
- call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
+!$omp parallel do schedule(static,1) private(k)
+ do k=1,n_ens
- enddo
+ call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
+
+ enddo
+
+ endif
return
end subroutine ckgcov_a_en_new_factorization
@@ -3913,7 +4011,7 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en)
use constants, only: zero
use gridmod, only: regional
use hybrid_ensemble_parameters, only: n_ens,grd_loc
- use hybrid_ensemble_parameters, only: nval_lenz_en
+ use hybrid_ensemble_parameters, only: l_mgbf_loc
use general_sub2grid_mod, only: general_sub2grid
use gsi_bundlemod, only: gsi_bundle
use gsi_bundlemod, only: gsi_bundlegetpointer
@@ -3923,17 +4021,23 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en)
! Passed Variables
integer(i_kind),intent(in ) :: ig
type(gsi_bundle),intent(inout) :: a_en(n_ens)
- real(r_kind),dimension(nval_lenz_en),intent(inout) :: z
+ real(r_kind),dimension(nval_loc_en),intent(inout) :: z
+!NOTE:
+! nval_loc_en is the number of horizontally-filtered variables in the domain of each processor.
+! In MGBF-based localization, it is horizontally-local and vertically-global as
+! nval_loc_en = nhoriz * obj_mgbf(ig)%km_all
+! and nhoriz = ( obj_mgbf(ig)%im + obj_mgbf(ig)%hx*2 ) * ( obj_mgbf(ig)%jm + obj_mgbf(ig)%hy*2 )
+! In recursive/spectral filter-based localization, it is horizontally-global and vertically-local as
+! nval_loc_en = nhoriz * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 )
+! and nhoriz = grd_loc%nlat * grd_loc%nlon (for regional recursive filter)
+! nhoriz = ( sp_loc%jcap+1 ) * ( sp_loc%jcap+2 ) (for global spectral filter)
+! but internal array hwork always has
+! dimension grd_loc%nlat * grd_loc%nlon * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 )
+! which would be used as nval_loc_en when the recursive filter is used.
! Local Variables
- integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus
+ integer(i_kind) ii,i,j,k,iadvance,iback,is,ie,ipnt,istatus
real(r_kind) hwork(grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1))
-!NOTE: nval_lenz_en = nhoriz*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)
-! and nhoriz = grd_loc%nlat*grd_loc%nlon for regional,
-! nhoriz = (sp_loc%jcap+1)*(sp_loc%jcap+2) for global
-! but internal array hwork always has
-! dimension grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)
-! which just happens to match up with nval_lenz_en for regional case, but not global.
real(r_kind),allocatable,dimension(:):: a_en_work
call gsi_bundlegetpointer(a_en(1),'a_en',ipnt,istatus)
@@ -3942,52 +4046,159 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en)
call stop2(999)
endif
+! MGBF-based localization (now available only in regional=.true.)
+ if(l_mgbf_loc) then
+
! Apply vertical smoother on each ensemble member
- do k=1,n_ens
+ allocate(work_mgbf(obj_mgbf(ig)%km_a_all,obj_mgbf(ig)%nm,obj_mgbf(ig)%mm))
+ work_mgbf=zero
+ iadvance=1 ; iback=2
+!$omp parallel do schedule(static,1) private(k,ii,is,ie)
+ do k=1,n_ens
+ ii=(k-1)*grd_loc%nsig
+ is=ii+1
+ ie=ii+grd_loc%nsig
+ if(.not.obj_mgbf(ig)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
+ call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,ig)
+ enddo
+
+! Mapping from analysis grid to filter grid
+ call obj_mgbf(ig)%anal_to_filt_allmap(work_mgbf)
+ deallocate(work_mgbf)
+! Apply horizontal smoother for number of horizontal scales
+ call obj_mgbf(ig)%filtering_procedure(obj_mgbf(ig)%mgbf_proc,-1)
+ ii=0
+ do k=1,obj_mgbf(ig)%km_all
+ do j=1-obj_mgbf(ig)%hy,obj_mgbf(ig)%jm+obj_mgbf(ig)%hy
+ do i=1-obj_mgbf(ig)%hx,obj_mgbf(ig)%im+obj_mgbf(ig)%hx
+ ii=ii+1
+ z(ii)=obj_mgbf(ig)%VALL(k,i,j)
+ enddo
+ enddo
+ enddo
+
+! Recursive/Spectral filter-based localization
+ else
+
+! Apply vertical smoother on each ensemble member
iadvance=1 ; iback=2
- call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
-
- enddo
+!$omp parallel do schedule(static,1) private(k)
+ do k=1,n_ens
+
+ call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
+
+ enddo
! To avoid my having to touch the general sub2grid and grid2sub,
! get copy for ensemble components to work array
- allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus)
- if(istatus/=0) then
- write(6,*)'ckgcov_a_en_new_factorization_ad: trouble in alloc(a_en_work)'
- call stop2(999)
- endif
- ii=0
- do k=1,n_ens
- is=ii+1
- ie=ii+a_en(1)%ndim
- a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim)
- ii=ii+a_en(1)%ndim
- enddo
+ allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus)
+ if(istatus/=0) then
+ write(6,*)'ckgcov_a_en_new_factorization_ad: trouble in alloc(a_en_work)'
+ call stop2(999)
+ endif
+ ii=0
+ do k=1,n_ens
+ is=ii+1
+ ie=ii+a_en(1)%ndim
+ a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim)
+ ii=ii+a_en(1)%ndim
+ enddo
! Convert from subdomain to full horizontal field distributed among processors
- call general_sub2grid(grd_loc,a_en_work,hwork)
- deallocate(a_en_work)
+ call general_sub2grid(grd_loc,a_en_work,hwork)
+ deallocate(a_en_work)
- if(grd_loc%kend_loc+1-grd_loc%kbegin_loc==0) then
+ if(grd_loc%kend_loc+1-grd_loc%kbegin_loc==0) then
! no work to be done on this processor, but z still has allocated space, since
! grd_loc%kend_alloc = grd_loc%kbegin_loc in this case, so set to zero.
- z=zero
- else
-! Apply horizontal smoother for number of horizontal scales
- if(regional) then
- iadvance=1 ; iback=2
- call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
- call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
- z=hwork
+ z=zero
else
- call sqrt_sf_xy_ad(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc)
+! Apply horizontal smoother for number of horizontal scales
+ if(regional) then
+ iadvance=1 ; iback=2
+ call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
+ call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig)
+ z=hwork
+ else
+ call sqrt_sf_xy_ad(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc)
+ end if
end if
- end if
+
+ endif
return
end subroutine ckgcov_a_en_new_factorization_ad
+subroutine map_work_mgbf(f,g,iadvance,ig)
+!$$$ subprogram documentation block
+! . . .
+! subprogram: map_work_mgbf
+! prgrmmr: yokota org: NCEP/EMC date: 2024-02-20
+!
+! abstract: mapping field for MGBF
+!
+! program history log:
+!
+! input argument list:
+! f - field to be filtered
+! g - field for MGBF
+! iadvance - =1 to map from f to g, =2 to map from g to f
+! ig - number for smoothing scales
+!
+! output argument list:
+! f - field to be filtered
+! g - field for MGBF
+!
+! attributes:
+! language: f90
+! machine: ibm RS/6000 SP
+!
+!$$$ end documentation block
+
+ use constants, only: zero
+ use hybrid_ensemble_parameters, only: grd_loc
+ implicit none
+
+ integer(i_kind),intent(in ) :: iadvance,ig
+ real(r_kind) ,intent(inout) :: f(grd_loc%lat2,grd_loc%lon2,grd_loc%nsig)
+ real(r_kind) ,intent(inout) :: g(grd_loc%nsig,obj_mgbf(ig)%nm,obj_mgbf(ig)%mm)
+
+ real(r_kind) :: work_tmp(grd_loc%lon2,grd_loc%lat2)
+ integer(i_kind) i,j,k
+
+ if(iadvance == 1) then
+ do k=1,grd_loc%nsig
+ do j=1,grd_loc%lat2
+ do i=1,grd_loc%lon2
+ work_tmp(i,j)=f(j,i,k)
+ enddo
+ enddo
+ do j=1,obj_mgbf(ig)%mm
+ do i=1,obj_mgbf(ig)%nm
+ g(k,i,j)=work_tmp(i+1,j+1)
+ enddo
+ enddo
+ enddo
+ elseif(iadvance == 2) then
+ do k=1,grd_loc%nsig
+ work_tmp=zero
+ do j=1,obj_mgbf(ig)%mm
+ do i=1,obj_mgbf(ig)%nm
+ work_tmp(i+1,j+1)=g(k,i,j)
+ enddo
+ enddo
+ do j=1,grd_loc%lat2
+ do i=1,grd_loc%lon2
+ f(j,i,k)=work_tmp(i,j)
+ enddo
+ enddo
+ enddo
+ endif
+ return
+
+end subroutine map_work_mgbf
+
! ------------------------------------------------------------------------------
! ------------------------------------------------------------------------------
@@ -4004,7 +4215,8 @@ subroutine hybens_grid_setup
! 2010-02-20 parrish, adapt for dual resolution
! 2011-01-30 parrish, fix so regional application depends only on parameters regional
! and dual_res. Rename subroutine get_regional_gefs_grid to get_regional_dual_res_grid.
-!
+!
+! 2022-03-01 X.Lu & X.Wang - add vars for hafs dual ens. POC: xuguang.wang@ou.edu
! input argument list:
!
! output argument list:
@@ -4029,6 +4241,9 @@ subroutine hybens_grid_setup
use constants, only: zero,one
use control_vectors, only: cvars3d,nc2d,nc3d
use gridmod, only: region_lat,region_lon,region_dx,region_dy
+ use hybrid_ensemble_parameters, only:nsclgrp,spc_multwgt,spcwgt_params,global_spectral_filter_sd
+ use hybrid_ensemble_parameters, only:regional_ensemble_option
+ use gsi_rfv3io_mod,only:gsi_rfv3io_get_ens_grid_specs
implicit none
@@ -4037,6 +4252,8 @@ subroutine hybens_grid_setup
logical,allocatable::vector(:)
real(r_kind) eps,r_e
real(r_kind) rlon_a(nlon),rlat_a(nlat),rlon_e(nlon),rlat_e(nlat)
+ character(:),allocatable:: fv3_ens_spec_grid_filename
+ integer :: ierr
nord_e2a=4 ! soon, move this to hybrid_ensemble_parameters
@@ -4080,8 +4297,8 @@ subroutine hybens_grid_setup
region_lat_ens=region_lat
end if
end if
- if(mype==0) write(6,*)' dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps=',&
- dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps
+ if(mype==0) write(6,*)' dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps=',&
+ dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps
if(nlon_ens<=0 .or. nlat_ens<=0) then
nlon_ens=nlon ; nlat_ens=nlat
@@ -4123,12 +4340,38 @@ subroutine hybens_grid_setup
else
if(dual_res) then
call get_region_dx_dy_ens(region_dx_ens,region_dy_ens)
+ if(regional_ensemble_option == 5) then
+ fv3_ens_spec_grid_filename="fv3_ens_grid_spec"
+ call gsi_rfv3io_get_ens_grid_specs(fv3_ens_spec_grid_filename,ierr)
+ endif
else
region_dx_ens=region_dx
region_dy_ens=region_dy
end if
end if
+ if(global_spectral_filter_sd .and. nsclgrp > 1)then
+ allocate(spc_multwgt(sp_ens%nc,nsclgrp))
+ allocate(spcwgt_params(4,nsclgrp))
+ spc_multwgt=1.0
+
+ ! The below parameters are used in Huang et al. (2021, MWR)
+ spcwgt_params(1,1)=4000.0_r_kind
+ spcwgt_params(2,1)=100000000.0_r_kind
+ spcwgt_params(3,1)=1.0_r_kind
+ spcwgt_params(4,1)=3000.0_r_kind
+
+ if( nsclgrp >=3 )then
+ spcwgt_params(1,3)=0.0_r_kind
+ spcwgt_params(2,3)=500.0_r_kind
+ spcwgt_params(3,3)=1.0_r_kind
+ spcwgt_params(4,3)=500.0_r_kind
+ end if
+
+ call init_mult_spc_wgts(jcap_ens)
+
+ end if
+
return
end subroutine hybens_grid_setup
@@ -4148,6 +4391,8 @@ subroutine hybens_localization_setup
! 2012-10-16 wu - only call setup_ens_wgt if necessary
! 2014-05-22 wu modification to allow vertically varying localization scales in regional
! 2022-09-15 yokota - add scale/variable/time-dependent localization
+! 2022-12-09 Y. Wang and X. Wang - add a variable-dependent localization option (assign_vdl_nml=.true.),
+! poc: xuguang.wang@ou.edu
!
! input argument list:
!
@@ -4168,9 +4413,12 @@ subroutine hybens_localization_setup
use hybrid_ensemble_parameters, only: readin_beta,beta_s,beta_e,beta_s0,beta_e0,sqrt_beta_s,sqrt_beta_e
use hybrid_ensemble_parameters, only: readin_localization,create_hybens_localization_parameters, &
vvlocal,s_ens_h,s_ens_hv,s_ens_v,s_ens_vv
- use hybrid_ensemble_parameters, only: ntotensgrp,naensgrp,naensloc,ntlevs_ens,nsclgrp
- use hybrid_ensemble_parameters, only: en_perts
+ use hybrid_ensemble_parameters, only: ntotensgrp,naensgrp,naensloc,ntlevs_ens,nsclgrp,assign_vdl_nml
+ use hybrid_ensemble_parameters, only: en_perts,vdl_scale,vloc_varlist,global_spectral_filter_sd
+ use hybrid_ensemble_parameters, only: ngvarloc
+ use hybrid_ensemble_parameters, only: l_mgbf_loc
use gsi_io, only: verbose
+ use string_utility, only: StrLowCase
implicit none
@@ -4183,9 +4431,12 @@ subroutine hybens_localization_setup
real(r_kind),allocatable:: s_ens_h_gu_x(:,:),s_ens_h_gu_y(:,:)
logical :: l_read_success
type(gsi_bundle) :: a_en(n_ens)
+ type(gsi_bundle),allocatable :: en_pertstmp(:,:),en_pertstmp1(:,:)
type(gsi_grid) :: grid_ens
real(r_kind), pointer :: values(:) => NULL()
+ integer(i_kind) :: iscl, iv, smooth_scales_num
character(len=*),parameter::myname_=myname//'*hybens_localization_setup'
+ character(len=40) :: mgbfname='mgbf_locXX.nml'
l_read_success=.false.
print_verbose=.false. .and. mype == 0
@@ -4245,10 +4496,9 @@ subroutine hybens_localization_setup
vvlocal = .true.
nz = msig
kl = grd_loc%kend_alloc-grd_loc%kbegin_loc+1
- if(.not.allocated(s_ens_h_gu_x)) allocate(s_ens_h_gu_x(grd_loc%nsig*n_ens,naensloc))
- if(.not.allocated(s_ens_h_gu_y)) allocate(s_ens_h_gu_y(grd_loc%nsig*n_ens,naensloc))
endif
+
endif ! if ( readin_localization .or. readin_beta )
100 format(I4)
@@ -4276,8 +4526,6 @@ subroutine hybens_localization_setup
if ( .not. readin_localization ) then ! assign all levels to same value, s_ens_h, s_ens_v
nz = 1
kl = 1
- if(.not.allocated(s_ens_h_gu_x)) allocate(s_ens_h_gu_x(1,naensloc))
- if(.not.allocated(s_ens_h_gu_y)) allocate(s_ens_h_gu_y(1,naensloc))
do ig=1,naensloc
s_ens_hv(:,ig) = s_ens_h(ig)
s_ens_vv(:,ig) = s_ens_v(ig)
@@ -4290,29 +4538,46 @@ subroutine hybens_localization_setup
call normal_new_factorization_rf_z
if ( regional ) then ! convert s_ens_h from km to grid units.
- if ( vvlocal ) then
- call convert_km_to_grid_units(s_ens_h_gu_x(1:nz,:),s_ens_h_gu_y(1:nz,:),nz)
- do n=2,n_ens
- nk=(n-1)*nz
- do k=1,nz
- s_ens_h_gu_x(nk+k,:)=s_ens_h_gu_x(k,:)
- s_ens_h_gu_y(nk+k,:)=s_ens_h_gu_y(k,:)
- enddo
+ if ( l_mgbf_loc ) then
+ allocate(obj_mgbf(naensgrp))
+ do ig=1,naensgrp
+ write(mgbfname(9:10),'(i2.2)') ig
+ call obj_mgbf(ig)%mg_initialize(trim(mgbfname))
enddo
- call init_rf_x(s_ens_h_gu_x(grd_loc%kbegin_loc:grd_loc%kend_alloc,:),kl)
- call init_rf_y(s_ens_h_gu_y(grd_loc%kbegin_loc:grd_loc%kend_alloc,:),kl)
- else
- call convert_km_to_grid_units(s_ens_h_gu_x,s_ens_h_gu_y,nz)
- call init_rf_x(s_ens_h_gu_x,kl)
- call init_rf_y(s_ens_h_gu_y,kl)
endif
- call normal_new_factorization_rf_x
- call normal_new_factorization_rf_y
+ ! Even for MGBF-localization, recursive filter is applied for scale-separation
+ ! in scale-dependent localization, so init_rf_[xy] should be called in nsclgrp>1
+ if( .not. l_mgbf_loc .or. nsclgrp > 1 ) then
+ if ( vvlocal ) then
+ allocate(s_ens_h_gu_x(grd_loc%nsig*n_ens,naensloc))
+ allocate(s_ens_h_gu_y(grd_loc%nsig*n_ens,naensloc))
+ call convert_km_to_grid_units(s_ens_h_gu_x(1:nz,:),s_ens_h_gu_y(1:nz,:),nz)
+ do n=2,n_ens
+ nk=(n-1)*nz
+ do k=1,nz
+ s_ens_h_gu_x(nk+k,:)=s_ens_h_gu_x(k,:)
+ s_ens_h_gu_y(nk+k,:)=s_ens_h_gu_y(k,:)
+ enddo
+ enddo
+ call init_rf_x(s_ens_h_gu_x(grd_loc%kbegin_loc:grd_loc%kend_alloc,:),kl)
+ call init_rf_y(s_ens_h_gu_y(grd_loc%kbegin_loc:grd_loc%kend_alloc,:),kl)
+ else
+ allocate(s_ens_h_gu_x(1,naensloc))
+ allocate(s_ens_h_gu_y(1,naensloc))
+ call convert_km_to_grid_units(s_ens_h_gu_x,s_ens_h_gu_y,nz)
+ call init_rf_x(s_ens_h_gu_x,kl)
+ call init_rf_y(s_ens_h_gu_y,kl)
+ endif
+ call normal_new_factorization_rf_x
+ call normal_new_factorization_rf_y
+ deallocate(s_ens_h_gu_x)
+ deallocate(s_ens_h_gu_y)
+ endif
else
call init_sf_xy(jcap_ens)
endif
- if(ntotensgrp>1) then
+ if(ntotensgrp>1 .and. (.not. global_spectral_filter_sd)) then
call gsi_bundlegetpointer(en_perts(1,1,1),cvars3d,ipc3d,istatus)
if(istatus/=0) then
write(6,*) myname_,': cannot find 3d pointers'
@@ -4326,64 +4591,162 @@ subroutine hybens_localization_setup
if(nsclgrp>1) then
call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig)
allocate(values(grd_ens%latlon11*grd_ens%nsig*n_ens))
- do ig=1,nsclgrp-1
- ii=0
- do n=1,n_ens
- a_en(n)%values => values(ii+1:ii+grd_ens%latlon11*grd_ens%nsig)
- call gsi_bundleset(a_en(n),grid_ens,'Ensemble Bundle',istatus,names3d=(/'a_en'/),bundle_kind=r_kind)
- if (istatus/=0) then
- write(6,*) myname_,': error alloc(ensemble bundle)'
- call stop2(999)
- endif
- ii=ii+grd_ens%latlon11*grd_ens%nsig
- enddo
- do m=1,ntlevs_ens
+ if( .not. assign_vdl_nml )then
+ do ig=1,nsclgrp-1
+ ii=0
do n=1,n_ens
- en_perts(n,ig+1,m)%valuesr4=en_perts(n,ig,m)%valuesr4
+ a_en(n)%values => values(ii+1:ii+grd_ens%latlon11*grd_ens%nsig)
+ call gsi_bundleset(a_en(n),grid_ens,'Ensemble Bundle',istatus,names3d=(/'a_en'/),bundle_kind=r_kind)
+ if (istatus/=0) then
+ write(6,*) myname_,': error alloc(ensemble bundle)'
+ call stop2(999)
+ endif
+ ii=ii+grd_ens%latlon11*grd_ens%nsig
enddo
- do ic3=1,nc3d
- ipic=ipc3d(ic3)
+ do m=1,ntlevs_ens
do n=1,n_ens
- do k=1,grd_ens%nsig
- a_en(n)%r3(1)%q(:,:,k)=en_perts(n,ig,m)%r3(ipic)%qr4(:,:,k)
+ en_perts(n,ig+1,m)%valuesr4=en_perts(n,ig,m)%valuesr4
+ enddo
+ do ic3=1,nc3d
+ ipic=ipc3d(ic3)
+ do n=1,n_ens
+ do k=1,grd_ens%nsig
+ a_en(n)%r3(1)%q(:,:,k)=en_perts(n,ig,m)%r3(ipic)%qr4(:,:,k)
+ enddo
+ enddo
+ call bkgcov_a_en_new_factorization(naensgrp+ig,a_en)
+ do n=1,n_ens
+ do k=1,grd_ens%nsig
+ en_perts(n,ig,m)%r3(ipic)%qr4(:,:,k)=a_en(n)%r3(1)%q(:,:,k)
+ enddo
enddo
enddo
- call bkgcov_a_en_new_factorization(naensgrp+ig,a_en)
- do n=1,n_ens
- do k=1,grd_ens%nsig
- en_perts(n,ig,m)%r3(ipic)%qr4(:,:,k)=a_en(n)%r3(1)%q(:,:,k)
+ do ic2=1,nc2d
+ ipic=ipc2d(ic2)
+ do n=1,n_ens
+ do k=1,grd_ens%nsig
+ a_en(n)%r3(1)%q(:,:,k)=en_perts(n,ig,m)%r2(ipic)%qr4(:,:)
+ enddo
+ enddo
+ call bkgcov_a_en_new_factorization(naensgrp+ig,a_en)
+ do n=1,n_ens
+ en_perts(n,ig,m)%r2(ipic)%qr4(:,:)=a_en(n)%r3(1)%q(:,:,1)
enddo
enddo
- enddo
- do ic2=1,nc2d
- ipic=ipc2d(ic2)
do n=1,n_ens
- do k=1,grd_ens%nsig
- a_en(n)%r3(1)%q(:,:,k)=en_perts(n,ig,m)%r2(ipic)%qr4(:,:)
+ en_perts(n,ig+1,m)%valuesr4=en_perts(n,ig+1,m)%valuesr4-en_perts(n,ig,m)%valuesr4
+ enddo
+ enddo
+ do n=1,n_ens
+ call gsi_bundleunset(a_en(n),istatus)
+ enddo
+ enddo
+ else ! assign_vdl_nml
+ smooth_scales_num = naensloc - naensgrp
+ ngvarloc = 1 ! forced to 1 in this option
+ allocate(en_pertstmp(n_ens,ntlevs_ens))
+ allocate(en_pertstmp1(n_ens,ntlevs_ens))
+ do n = 1, n_ens
+ do m = 1, ntlevs_ens
+ call gsi_bundlecreate(en_pertstmp(n,m),grid_ens,'ensemble2',istatus,names2d=cvars2d,names3d=cvars3d,bundle_kind=r_single)
+ call gsi_bundlecreate(en_pertstmp1(n,m),grid_ens,'ensemble1',istatus,names2d=cvars2d,names3d=cvars3d,bundle_kind=r_single)
+ end do
+ end do
+ ig = 1
+ do iscl=1,smooth_scales_num + 1
+ ii=0
+ do n=1,n_ens
+ a_en(n)%values => values(ii+1:ii+grd_ens%latlon11*grd_ens%nsig)
+ call gsi_bundleset(a_en(n),grid_ens,'Ensemble Bundle',istatus,names3d=(/'a_en'/),bundle_kind=r_kind)
+ if (istatus/=0) then
+ write(6,*) myname_,': error alloc(ensemble bundle)'
+ call stop2(999)
+ endif
+ ii=ii+grd_ens%latlon11*grd_ens%nsig
+ enddo
+
+ do m=1,ntlevs_ens
+ if( ig == 1 )then
+ do n=1,n_ens
+ en_pertstmp(n,m)%valuesr4=en_perts(n,ig,m)%valuesr4
+ enddo
+ end if
+ do ic3=1,nc3d
+ ipic=ipc3d(ic3)
+ do n=1,n_ens
+ do k=1,grd_ens%nsig
+ a_en(n)%r3(1)%q(:,:,k)=en_pertstmp(n,m)%r3(ipic)%qr4(:,:,k)
+ enddo
+ enddo
+ if(iscl <= smooth_scales_num) call bkgcov_a_en_new_factorization(naensgrp+iscl,a_en)
+ do n=1,n_ens
+ do k=1,grd_ens%nsig
+ en_pertstmp1(n,m)%r3(ipic)%qr4(:,:,k)=a_en(n)%r3(1)%q(:,:,k)
+ if( vdl_scale(ig) == 0 )then
+ en_perts(n,ig,m)%r3(ipic)%qr4(:,:,k)=a_en(n)%r3(1)%q(:,:,k)
+ else ! VDL is activated
+ do iv = 1, vdl_scale(ig)
+ en_perts(n,ig+iv-1,m)%r3(ipic)%qr4(:,:,k)=0.0_r_single
+ if( any( trim(StrLowCase(cvars3d(ic3))) == vloc_varlist(ig+iv-1,:) ) ) then
+ en_perts(n,ig+iv-1,m)%r3(ipic)%qr4(:,:,k)=a_en(n)%r3(1)%q(:,:,k)
+ end if
+ end do
+ end if
+ enddo
+ enddo
+ enddo
+ do ic2=1,nc2d
+ ipic=ipc2d(ic2)
+ do n=1,n_ens
+ do k=1,grd_ens%nsig
+ a_en(n)%r3(1)%q(:,:,k)=en_pertstmp(n,m)%r2(ipic)%qr4(:,:)
+ enddo
+ enddo
+ if(iscl <= smooth_scales_num) call bkgcov_a_en_new_factorization(naensgrp+iscl,a_en)
+ do n=1,n_ens
+ en_pertstmp1(n,m)%r2(ipic)%qr4(:,:)=a_en(n)%r3(1)%q(:,:,1)
+ if( vdl_scale(ig) == 0 )then
+ en_perts(n,ig,m)%r2(ipic)%qr4(:,:)=a_en(n)%r3(1)%q(:,:,1)
+ else ! VDL is activated
+ do iv = 1, vdl_scale(ig)
+ en_perts(n,ig+iv-1,m)%r2(ipic)%qr4(:,:)=0.0_r_single
+ if( any( trim(StrLowCase(cvars2d(ic2))) == vloc_varlist(ig+iv-1,:) ) ) then
+ en_perts(n,ig+iv-1,m)%r2(ipic)%qr4(:,:)=a_en(n)%r3(1)%q(:,:,1)
+ end if
+ end do
+ end if
enddo
enddo
- call bkgcov_a_en_new_factorization(naensgrp+ig,a_en)
do n=1,n_ens
- en_perts(n,ig,m)%r2(ipic)%qr4(:,:)=a_en(n)%r3(1)%q(:,:,1)
+ en_pertstmp(n,m)%valuesr4=en_pertstmp(n,m)%valuesr4-en_pertstmp1(n,m)%valuesr4
enddo
enddo
do n=1,n_ens
- en_perts(n,ig+1,m)%valuesr4=en_perts(n,ig+1,m)%valuesr4-en_perts(n,ig,m)%valuesr4
+ call gsi_bundleunset(a_en(n),istatus)
enddo
+ if( vdl_scale(ig) == 0 )then
+ ig = ig + 1
+ else
+ ig = ig + vdl_scale(ig)
+ end if
enddo
do n=1,n_ens
- call gsi_bundleunset(a_en(n),istatus)
- enddo
- enddo
- deallocate(values)
- endif
- do ig=nsclgrp+1,ntotensgrp
- do m=1,ntlevs_ens
- do n=1,n_ens
- en_perts(n,ig,m)%valuesr4=en_perts(n,ig-nsclgrp,m)%valuesr4
- enddo
- enddo
- enddo
+ do m=1,ntlevs_ens
+ call gsi_bundledestroy(en_pertstmp(n,m),istatus)
+ call gsi_bundledestroy(en_pertstmp1(n,m),istatus)
+ end do
+ end do
+ deallocate(en_pertstmp,en_pertstmp1)
+ end if
+ deallocate(values)
+ endif
+ do ig=nsclgrp+1,ntotensgrp
+ do m=1,ntlevs_ens
+ do n=1,n_ens
+ en_perts(n,ig,m)%valuesr4=en_perts(n,ig-nsclgrp,m)%valuesr4
+ enddo
+ enddo
+ enddo
endif
!!!!!!!! setup beta_s, beta_e!!!!!!!!!!!!
@@ -4401,6 +4764,16 @@ subroutine hybens_localization_setup
else
nval_lenz_en = sp_loc%nc*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)
endif
+ ! nval_loc_en is the number of horizontally-filtered variables in the domain of each processor,
+ ! which is the same as nval_lenz_en (horizontally-global and vertically-local) in recursive/spectral filter
+ ! but horizontally-local and vertically-global in MGBF.
+ if ( l_mgbf_loc ) then
+ nval_loc_en = maxval( obj_mgbf(1:naensgrp)%km_all &
+ & * (obj_mgbf(1:naensgrp)%im + obj_mgbf(1:naensgrp)%hx*2) &
+ & * (obj_mgbf(1:naensgrp)%jm + obj_mgbf(1:naensgrp)%hy*2) )
+ else
+ nval_loc_en = nval_lenz_en
+ endif
! setup vertical weighting for ensemble contribution to psfc
call setup_pwgt
@@ -5314,6 +5687,7 @@ subroutine acceptable_for_essl_fft(nin,nout)
nout=n_acceptable_table(i)
if(nout.ge.nin) exit
enddo
+ deallocate(n_acceptable_table)
return
end subroutine acceptable_for_essl_fft
@@ -5428,7 +5802,7 @@ subroutine setup_ensgrp2aensgrp
!
!$$$ end documentation block
use constants, only: zero,one
- use hybrid_ensemble_parameters, only: l_timloc_opt,i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl
+ use hybrid_ensemble_parameters, only: l_timloc_opt,r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl
use hybrid_ensemble_parameters, only: ensloccov4tim,ensloccov4var,ensloccov4scl
use hybrid_ensemble_parameters, only: ntotensgrp,naensgrp,ntlevs_ens,nsclgrp,ngvarloc
use hybrid_ensemble_parameters, only: ensgrp2aensgrp
@@ -5471,33 +5845,12 @@ subroutine setup_ensgrp2aensgrp
enddo
enddo
- if (i_ensloccov4tim==0) then
- ensloccov4tim=one
- elseif (i_ensloccov4tim==1)then
- ensloccov4tim=zero
- ensloccov4tim(1)=one
- else
- write(6,*)'setup_ensgrp2aensgrp: wrong i_ensloccov4tim'
- call stop2(666)
- endif
- if (i_ensloccov4var==0) then
- ensloccov4var=one
- elseif (i_ensloccov4var==1)then
- ensloccov4var=zero
- ensloccov4var(1)=one
- else
- write(6,*)'setup_ensgrp2aensgrp: wrong i_ensloccov4var'
- call stop2(666)
- endif
- if (i_ensloccov4scl==0) then
- ensloccov4scl=one
- elseif (i_ensloccov4scl==1)then
- ensloccov4scl=zero
- ensloccov4scl(1)=one
- else
- write(6,*)'setup_ensgrp2aensgrp: wrong i_ensloccov4scl'
- call stop2(666)
- endif
+ ensloccov4tim=r_ensloccov4tim
+ ensloccov4tim(1)=one
+ ensloccov4var=r_ensloccov4var
+ ensloccov4var(1)=one
+ ensloccov4scl=r_ensloccov4scl
+ ensloccov4scl(1)=one
do itim2=1,ntimloc
do itim1=1,ntimloc
diff --git a/src/gsi/hybrid_ensemble_parameters.f90 b/src/gsi/hybrid_ensemble_parameters.f90
index 7b1c963764..d31eccb7e4 100644
--- a/src/gsi/hybrid_ensemble_parameters.f90
+++ b/src/gsi/hybrid_ensemble_parameters.f90
@@ -128,20 +128,28 @@ module hybrid_ensemble_parameters
! function of z, default = .false.
! ensemble_path: path to ensemble members; default './'
! ens_fast_read: read ensemble in parallel; default '.false.'
+! parallelization_over_ensmembers: parallelly read ensemble members for FV3-LAM; default '.false'
! sst_staticB: if .true. (default) uses only static part of B error covariance for SST
! nsclgrp: number of scale-dependent localization lengths
! l_timloc_opt: if true, then turn on time-dependent localization
! ngvarloc: number of variable-dependent localization lengths
! naensloc: total number of spatial localization lengths and scale separation lengths (should be naensgrp+nsclgrp-1)
-! i_ensloccov4tim: flag of cross-temporal localization
-! =0: cross-temporal covariance is retained
-! =1: cross-temporal covariance is zero
-! i_ensloccov4var: flag of cross-variable localization
-! =0: cross-variable covariance is retained
-! =1: cross-variable covariance is zero
-! i_ensloccov4scl: flag of cross-scale localization
-! =0: cross-scale covariance is retained
-! =1: cross-scale covariance is zero
+! r_ensloccov4tim: factor multiplying to cross-time covariance
+! For example,
+! =0.0: cross-time covariance is decreased to zero
+! =0.5: cross-time covariance is decreased to half
+! =1.0: cross-time covariance is retained
+! r_ensloccov4var: factor multiplying to cross-variable covariance
+! For example,
+! =0.0: cross-variable covariance is decreased to zero
+! =0.5: cross-variable covariance is decreased to half
+! =1.0: cross-variable covariance is retained
+! r_ensloccov4scl: factor multiplying to cross-scale covariance
+! For example,
+! =0.0: cross-scale covariance is decreased to zero
+! =0.5: cross-scale covariance is decreased to half
+! =1.0: cross-scale covariance is retained
+! l_mgbf_loc: if true, multi-grid beta filter is used for localization instead of recursive filter
!=====================================================================================================
!
!
@@ -176,6 +184,7 @@ module hybrid_ensemble_parameters
! 2015-02-11 Hu - add flag l_ens_in_diff_time to force GSI hybrid use ensembles not available at analysis time
! 2015-09-18 todling - add sst_staticB to control use of ensemble SST error covariance
! 2022-09-15 yokota - add scale/variable/time-dependent localization
+! 2024-02-20 yokota - add MGBF-based localization
!
! subroutines included:
@@ -286,6 +295,7 @@ module hybrid_ensemble_parameters
public :: generate_ens,n_ens,nlon_ens,nlat_ens,jcap_ens,jcap_ens_test,l_hyb_ens,&
s_ens_h,oz_univ_static,vvlocal
public :: n_ens_gfs,n_ens_fv3sar
+ public :: weight_ens_gfs,weight_ens_fv3sar
public :: uv_hyb_ens,q_hyb_ens,s_ens_v,beta_s0,beta_e0,aniso_a_en,s_ens_hv,s_ens_vv
public :: readin_beta,beta_s,beta_e
public :: readin_localization
@@ -324,15 +334,24 @@ module hybrid_ensemble_parameters
public :: ensloccov4tim,ensloccov4var,ensloccov4scl
public :: alphacvarsclgrpmat
public :: l_timloc_opt
- public :: i_ensloccov4tim,i_ensloccov4var,i_ensloccov4scl
+ public :: r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl
+ public :: l_mgbf_loc
public :: idaen3d,idaen2d
public :: ens_fast_read
+ public :: parallelization_over_ensmembers
public :: l_both_fv3sar_gfs_ens
public :: sst_staticB
public :: limqens
+ public :: spc_multwgt
+ public :: spcwgt_params
+ public :: vdl_scale,vloc_varlist
+ public :: global_spectral_filter_sd
+ public :: assign_vdl_nml
+
logical l_hyb_ens,uv_hyb_ens,q_hyb_ens,oz_univ_static,sst_staticB
logical l_timloc_opt
+ logical l_mgbf_loc
logical aniso_a_en
logical full_ensemble,pwgtflg
logical generate_ens
@@ -348,10 +367,12 @@ module hybrid_ensemble_parameters
logical vvlocal
logical l_ens_in_diff_time
logical ens_fast_read
+ logical parallelization_over_ensmembers
logical l_both_fv3sar_gfs_ens
integer(i_kind) i_en_perts_io
integer(i_kind) n_ens,nlon_ens,nlat_ens,jcap_ens,jcap_ens_test
integer(i_kind) n_ens_gfs,n_ens_fv3sar
+ real(r_kind) weight_ens_gfs,weight_ens_fv3sar
real(r_kind) beta_s0,beta_e0,grid_ratio_ens
integer(i_kind),parameter::max_naensloc=20
integer(i_kind),parameter::max_nvars=100
@@ -384,11 +405,18 @@ module hybrid_ensemble_parameters
integer(i_kind) :: ntotensgrp=1
integer(i_kind) :: naensloc=1
integer(i_kind) :: ngvarloc=1
- integer(i_kind) :: i_ensloccov4tim=0
- integer(i_kind) :: i_ensloccov4var=0
- integer(i_kind) :: i_ensloccov4scl=0
+ real(r_kind) :: r_ensloccov4tim
+ real(r_kind) :: r_ensloccov4var
+ real(r_kind) :: r_ensloccov4scl
integer(i_kind),allocatable,dimension(:) :: idaen3d,idaen2d
+ real(r_kind),allocatable,dimension(:,:) :: spc_multwgt
+ real(r_kind),allocatable,dimension(:,:) :: spcwgt_params
+ character(len=3) vloc_varlist(max_naensloc,max_nvars)
+ integer(i_kind) vdl_scale(max_naensloc)
+ logical :: global_spectral_filter_sd
+ logical :: assign_vdl_nml
+
! following is for storage of ensemble perturbations:
! def en_perts - array of ensemble perturbations
@@ -404,6 +432,7 @@ module hybrid_ensemble_parameters
real(r_kind),allocatable:: region_lat_ens(:,:),region_lon_ens(:,:)
real(r_kind),allocatable:: region_dx_ens(:,:),region_dy_ens(:,:)
+
contains
subroutine init_hybrid_ensemble_parameters
@@ -437,6 +466,7 @@ subroutine init_hybrid_ensemble_parameters
l_hyb_ens=.false.
l_timloc_opt=.false.
+ l_mgbf_loc=.false.
full_ensemble=.false.
pwgtflg=.false.
uv_hyb_ens=.false.
@@ -476,10 +506,20 @@ subroutine init_hybrid_ensemble_parameters
i_en_perts_io=0 ! default for en_pert IO. 0 is no IO
ensemble_path = './' ! default for path to ensemble members
ens_fast_read=.false.
+ parallelization_over_ensmembers=.false.
limqens=1.0_r_single ! default for limiting ensemble RH (+/-)
l_both_fv3sar_gfs_ens=.false.
n_ens_gfs=0
n_ens_fv3sar=0
+ weight_ens_gfs=one
+ weight_ens_fv3sar=one
+ r_ensloccov4tim=one
+ r_ensloccov4var=one
+ r_ensloccov4scl=one
+ vdl_scale = 0
+ vloc_varlist = 'aaa'
+ global_spectral_filter_sd=.false.
+ assign_vdl_nml=.false.
end subroutine init_hybrid_ensemble_parameters
diff --git a/src/gsi/intall.f90 b/src/gsi/intall.f90
index 0f8faa89f8..d10eb1e7e5 100644
--- a/src/gsi/intall.f90
+++ b/src/gsi/intall.f90
@@ -184,13 +184,13 @@ subroutine intall(sval,sbias,rval,rbias)
use intjomod, only: intjo
use bias_predictors, only : predictors,assignment(=)
use state_vectors, only: allocate_state,deallocate_state
+ use state_vectors, only: qgpresent,qspresent,qrpresent,qipresent,qlpresent
+ use state_vectors, only: cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent
use intjcmod, only: intlimq,intlimg,intlimv,intlimp,intlimw10m,intlimhowv,intlimcldch,&
intliml,intjcpdry1,intjcpdry2,intjcdfi,intlimqc
use timermod, only: timer_ini,timer_fnl
use gsi_bundlemod, only: gsi_bundle
use gsi_bundlemod, only: assignment(=)
- use state_vectors, only: svars2d, svars3d
- use mpeu_util, only: getindex
use guess_grids, only: ntguessig,nfldsig
use mpl_allreducemod, only: mpl_allreduce
@@ -238,11 +238,11 @@ subroutine intall(sval,sbias,rval,rbias)
end if
if (ljclimqc) then
if (.not.ljc4tlevs) then
- if (getindex(svars3d,'ql')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'ql')
- if (getindex(svars3d,'qi')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qi')
- if (getindex(svars3d,'qr')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qr')
- if (getindex(svars3d,'qs')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qs')
- if (getindex(svars3d,'qg')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qg')
+ if (qlpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'ql')
+ if (qipresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qi')
+ if (qrpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qr')
+ if (qspresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qs')
+ if (qgpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qg')
else
do ibin=1,nobs_bins
if (nobs_bins /= nfldsig) then
@@ -250,34 +250,34 @@ subroutine intall(sval,sbias,rval,rbias)
else
it=ibin
end if
- if (getindex(svars3d,'ql')>0) call intlimqc(rval(ibin),sval(ibin),it,'ql')
- if (getindex(svars3d,'qi')>0) call intlimqc(rval(ibin),sval(ibin),it,'qi')
- if (getindex(svars3d,'qr')>0) call intlimqc(rval(ibin),sval(ibin),it,'qr')
- if (getindex(svars3d,'qs')>0) call intlimqc(rval(ibin),sval(ibin),it,'qs')
- if (getindex(svars3d,'qg')>0) call intlimqc(rval(ibin),sval(ibin),it,'qg')
+ if (qlpresent) call intlimqc(rval(ibin),sval(ibin),it,'ql')
+ if (qipresent) call intlimqc(rval(ibin),sval(ibin),it,'qi')
+ if (qrpresent) call intlimqc(rval(ibin),sval(ibin),it,'qr')
+ if (qspresent) call intlimqc(rval(ibin),sval(ibin),it,'qs')
+ if (qgpresent) call intlimqc(rval(ibin),sval(ibin),it,'qg')
end do
end if
end if ! ljclimqc
! RHS for gust constraint
- if (getindex(svars2d,'gust')>0)call intlimg(rval(1),sval(1))
+ if (gustpresent)call intlimg(rval(1),sval(1))
! RHS for vis constraint
- if (getindex(svars2d,'vis')>0) call intlimv(rval(1),sval(1))
+ if (vispresent) call intlimv(rval(1),sval(1))
! RHS for pblh constraint
- if (getindex(svars2d,'pblh')>0) call intlimp(rval(1),sval(1))
+ if (pblhpresent) call intlimp(rval(1),sval(1))
! RHS for wspd10m constraint
- if (getindex(svars2d,'wspd10m')>0) call intlimw10m(rval(1),sval(1))
+ if (wspd10mpresent) call intlimw10m(rval(1),sval(1))
! RHS for howv constraint
- if (getindex(svars2d,'howv')>0) call intlimhowv(rval(1),sval(1))
+ if (howvpresent) call intlimhowv(rval(1),sval(1))
! RHS for lcbas constraint
- if (getindex(svars2d,'lcbas')>0) call intliml(rval(1),sval(1))
+ if (lcbaspresent) call intliml(rval(1),sval(1))
! RHS for cldch constraint
- if (getindex(svars2d,'cldch')>0) call intlimcldch(rval(1),sval(1))
+ if (cldchpresent) call intlimcldch(rval(1),sval(1))
end if
@@ -296,7 +296,7 @@ subroutine intall(sval,sbias,rval,rbias)
end if
-! Take care of background error for bias correction terms
+! Sum over all processors for bias correction terms
call mpl_allreduce(nrclen,qpvals=qpred)
@@ -313,6 +313,7 @@ subroutine intall(sval,sbias,rval,rbias)
! RHS for Jc DFI
if (ljcdfi .and. nobs_bins>1) call intjcdfi(rval,sval)
+! Put bias correction terms in correct location
if(nsclen > 0)then
do i=1,nsclen
rbias%predr(i)=qpred(i)
diff --git a/src/gsi/intfed.f90 b/src/gsi/intfed.f90
new file mode 100644
index 0000000000..8cb16eba10
--- /dev/null
+++ b/src/gsi/intfed.f90
@@ -0,0 +1,187 @@
+module intfedmod
+!$$$ module documentation block
+! . . . .
+! module: intfedmod module for intfed and its tangent linear intfed_tl
+! prgmmr:
+!
+! abstract: module for intfed and its tangent linear intfed_tl
+!
+! program history log:
+! 2023-08-24 H. Wang - add tangent linear of fed operator to directly assimilate FED
+!
+! subroutines included:
+! sub intfed_
+!
+! variable definitions:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use m_obsNode, only: obsNode
+use m_fedNode, only: fedNode
+use m_fedNode, only: fedNode_typecast
+use m_fedNode, only: fedNode_nextcast
+use m_obsdiagNode, only: obsdiagNode_set
+implicit none
+
+PRIVATE
+PUBLIC intfed
+
+interface intfed; module procedure &
+ intfed_
+end interface
+
+contains
+
+subroutine intfed_(fedhead,rval,sval)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: intfed apply nonlin qc operator for GLM FED
+!
+! abstract: apply observation operator for radar winds
+! with nonlinear qc operator
+!
+! program history log:
+! 2023-08-24 H.Wang - modified based on intdbz.f90
+! - using tangent linear fed operator
+
+!
+! input argument list:
+! fedhead - obs type pointer to obs structure
+! sfed - current fed solution increment
+!
+! output argument list:
+! rfed - fed results from fed observation operator
+!
+! attributes:
+! language: f90
+! machine: ibm RS/6000 SP
+!
+!$$$
+ use kinds, only: r_kind,i_kind
+ use constants, only: half,one,tiny_r_kind,cg_term,r3600
+ use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag
+ use qcmod, only: nlnqc_iter,varqc_iter
+ use jfunc, only: jiter
+ use gsi_bundlemod, only: gsi_bundle
+ use gsi_bundlemod, only: gsi_bundlegetpointer
+ use gsi_4dvar, only: ladtest_obs
+ use wrf_vars_mod, only : fed_exist
+ implicit none
+
+! Declare passed variables
+ class(obsNode), pointer, intent(in ) :: fedhead
+ type(gsi_bundle), intent(in ) :: sval
+ type(gsi_bundle), intent(inout) :: rval
+
+! Declare local variables
+ integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,ier,istatus
+! real(r_kind) penalty
+ real(r_kind) val,w1,w2,w3,w4,w5,w6,w7,w8,valfed
+ real(r_kind) cg_fed,p0,grad,wnotgross,wgross,pg_fed
+ real(r_kind),pointer,dimension(:) :: sfed
+ real(r_kind),pointer,dimension(:) :: rfed
+ type(fedNode), pointer :: fedptr
+
+! If no fed obs type data return
+ if(.not. associated(fedhead))return
+
+! Retrieve pointers
+! Simply return if any pointer not found
+ ier=0
+ if(fed_exist)then
+ call gsi_bundlegetpointer(sval,'fed',sfed,istatus);ier=istatus+ier
+ call gsi_bundlegetpointer(rval,'fed',rfed,istatus);ier=istatus+ier
+ else
+ return
+ end if
+
+ if(ier/=0)return
+
+
+ fedptr => fedNode_typecast(fedhead)
+ do while (associated(fedptr))
+ j1=fedptr%ij(1)
+ j2=fedptr%ij(2)
+ j3=fedptr%ij(3)
+ j4=fedptr%ij(4)
+ j5=fedptr%ij(5)
+ j6=fedptr%ij(6)
+ j7=fedptr%ij(7)
+ j8=fedptr%ij(8)
+ w1=fedptr%wij(1)
+ w2=fedptr%wij(2)
+ w3=fedptr%wij(3)
+ w4=fedptr%wij(4)
+ w5=fedptr%wij(5)
+ w6=fedptr%wij(6)
+ w7=fedptr%wij(7)
+ w8=fedptr%wij(8)
+
+
+! Forward model
+ if( fed_exist )then
+ val = w1* sfed(j1)+w2* sfed(j2)+w3* sfed(j3)+w4* sfed(j4)+ &
+ w5* sfed(j5)+w6* sfed(j6)+w7* sfed(j7)+w8* sfed(j8)
+ end if
+
+ if(luse_obsdiag)then
+ if (lsaveobsens) then
+ grad = val*fedptr%raterr2*fedptr%err2
+ !-- fedptr%diags%obssen(jiter) = grad
+ call obsdiagNode_set(fedptr%diags,jiter=jiter,obssen=grad)
+
+ else
+ !-- if (fedptr%luse) fedptr%diags%tldepart(jiter)=val
+ if (fedptr%luse) call obsdiagNode_set(fedptr%diags,jiter=jiter,tldepart=val)
+ endif
+ endif
+
+ if (l_do_adjoint) then
+ if (.not. lsaveobsens) then
+ if( .not. ladtest_obs ) val=val-fedptr%res
+
+! gradient of nonlinear operator
+ if (nlnqc_iter .and. fedptr%pg > tiny_r_kind .and. &
+ fedptr%b > tiny_r_kind) then
+ pg_fed=fedptr%pg*varqc_iter
+ cg_fed=cg_term/fedptr%b
+ wnotgross= one-pg_fed
+ wgross = pg_fed*cg_fed/wnotgross
+ p0 = wgross/(wgross+exp(-half*fedptr%err2*val**2))
+ val = val*(one-p0)
+ endif
+
+ if( ladtest_obs) then
+ grad = val
+ else
+ grad = val*fedptr%raterr2*fedptr%err2
+ end if
+
+ endif
+
+! Adjoint
+ if(fed_exist)then
+ valfed = grad
+ rfed(j1)=rfed(j1)+w1*valfed
+ rfed(j2)=rfed(j2)+w2*valfed
+ rfed(j3)=rfed(j3)+w3*valfed
+ rfed(j4)=rfed(j4)+w4*valfed
+ rfed(j5)=rfed(j5)+w5*valfed
+ rfed(j6)=rfed(j6)+w6*valfed
+ rfed(j7)=rfed(j7)+w7*valfed
+ rfed(j8)=rfed(j8)+w8*valfed
+ end if
+
+ endif
+
+ !fedptr => fedptr%llpoint
+ fedptr => fedNode_nextcast(fedptr)
+ end do
+ return
+end subroutine intfed_
+
+end module intfedmod
diff --git a/src/gsi/intgps.f90 b/src/gsi/intgps.f90
index bc78db085e..16ead93d1c 100644
--- a/src/gsi/intgps.f90
+++ b/src/gsi/intgps.f90
@@ -118,6 +118,7 @@ subroutine intgps_(gpshead,rval,sval)
real(r_kind) :: w1,w2,w3,w4
real(r_kind) :: p_TL,p_AD,t_TL,t_AD,q_TL,q_AD
real(r_kind) :: val,pg_gps
+ real(r_kind),dimension(nsig) :: valk
real(r_kind) ::cg_gps,grad,p0,wnotgross,wgross
real(r_kind),pointer,dimension(:) :: st,sq
real(r_kind),pointer,dimension(:) :: rt,rq
@@ -154,16 +155,19 @@ subroutine intgps_(gpshead,rval,sval)
w3=gpsptr%wij(3)
w4=gpsptr%wij(4)
-
- val=zero
-
! local refractivity (linear operator)
+!$omp parallel do schedule(dynamic,1) private(j,t_TL,q_TL,p_TL)
+ do j=1,nsig
+ t_TL=w1*st(i1(j))+w2*st(i2(j))+w3*st(i3(j))+w4*st(i4(j))
+ q_TL=w1*sq(i1(j))+w2*sq(i2(j))+w3*sq(i3(j))+w4*sq(i4(j))
+ p_TL=w1*sp(i1(j))+w2*sp(i2(j))+w3*sp(i3(j))+w4*sp(i4(j))
+ valk(j) = p_TL*gpsptr%jac_p(j) + t_TL*gpsptr%jac_t(j)+q_TL*gpsptr%jac_q(j)
+ end do
+
+ val=zero
do j=1,nsig
- t_TL=w1* st(i1(j))+w2* st(i2(j))+w3* st(i3(j))+w4* st(i4(j))
- q_TL=w1* sq(i1(j))+w2* sq(i2(j))+w3* sq(i3(j))+w4* sq(i4(j))
- p_TL=w1* sp(i1(j))+w2* sp(i2(j))+w3* sp(i3(j))+w4* sp(i4(j))
- val = val + p_TL*gpsptr%jac_p(j) + t_TL*gpsptr%jac_t(j)+q_TL*gpsptr%jac_q(j)
+ val = val+valk(j)
end do
if (luse_obsdiag)then
@@ -204,6 +208,7 @@ subroutine intgps_(gpshead,rval,sval)
! adjoint
+!$omp parallel do schedule(dynamic,1) private(j,t_AD,q_AD,p_AD)
do j=1,nsig
t_AD = grad*gpsptr%jac_t(j)
rt(i1(j))=rt(i1(j))+w1*t_AD
diff --git a/src/gsi/intjcmod.f90 b/src/gsi/intjcmod.f90
index c0c23151ee..a3af642111 100644
--- a/src/gsi/intjcmod.f90
+++ b/src/gsi/intjcmod.f90
@@ -103,7 +103,7 @@ subroutine intlimq(rval,sval,itbin)
call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'q',ges_q_it,ier)
if(ier/=0)return
-!$omp parallel do schedule(dynamic,1) private(k,j,i,q)
+!$omp parallel do schedule(dynamic,1) private(k,j,i,ii,q)
do k = 1,nsig
do j = 2,lon1+1
do i = 2,lat1+1
@@ -180,34 +180,30 @@ subroutine intlimqc(rval,sval,itbin,cldtype)
call gsi_bundlegetpointer(sval,'ql',sqc,istatus);ier=istatus+ier
call gsi_bundlegetpointer(rval,'ql',rqc,istatus);ier=istatus+ier
call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'ql',ges_qc_it,ier1)
- endif
- if (trim(cldtype) == 'qi') then
+ else if (trim(cldtype) == 'qi') then
factqc = factqi
call gsi_bundlegetpointer(sval,'qi',sqc,istatus);ier=istatus+ier
call gsi_bundlegetpointer(rval,'qi',rqc,istatus);ier=istatus+ier
call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qi',ges_qc_it,ier1)
- endif
- if (trim(cldtype) == 'qr') then
+ else if (trim(cldtype) == 'qr') then
factqc = factqr
call gsi_bundlegetpointer(sval,'qr',sqc,istatus);ier=istatus+ier
call gsi_bundlegetpointer(rval,'qr',rqc,istatus);ier=istatus+ier
call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qr',ges_qc_it,ier1)
- endif
- if (trim(cldtype) == 'qs') then
+ else if (trim(cldtype) == 'qs') then
factqc = factqs
call gsi_bundlegetpointer(sval,'qs',sqc,istatus);ier=istatus+ier
call gsi_bundlegetpointer(rval,'qs',rqc,istatus);ier=istatus+ier
call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qs',ges_qc_it,ier1)
- endif
- if (trim(cldtype) == 'qg') then
+ else if (trim(cldtype) == 'qg') then
factqc = factqg
call gsi_bundlegetpointer(sval,'qg',sqc,istatus);ier=istatus+ier
call gsi_bundlegetpointer(rval,'qg',rqc,istatus);ier=istatus+ier
call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'qg',ges_qc_it,ier1)
endif
- if (mype==0) write(6,*) 'intlimqc: factqc = ', factqc
- if (mype==0) write(6,*) 'intlimqc: ier ier1= ', ier, ier1
if (factqc == zero) return
+ if (mype==0) write(6,*) 'intlimqc: factqc = ', factqc, trim(cldtype)
+ if (mype==0) write(6,*) 'intlimqc: ier ier1= ', ier, ier1
if (ier/=0 .or. ier1/=0) return
!$omp parallel do schedule(dynamic,1) private(k,j,i,qc)
@@ -740,7 +736,7 @@ subroutine intjcpdry(rval,sval,nbins,pjc)
it=ntguessig
mass=zero_quad
- rcon=one_quad/(two_quad*float(nlon))
+ rcon=(one_quad/(two_quad*real(nlon,r_quad)))**2
mm1=mype+1
do n=1,nbins
@@ -805,8 +801,7 @@ subroutine intjcpdry(rval,sval,nbins,pjc)
! Remove water-vapor contribution to get incremental dry ps
! if (mype==0) write(6,*)'intjcpdry: total mass =', mass(n)
! if (mype==0) write(6,*)'intjcpdry: wv mass =', mass(nbins+n)
- dmass=mass(n)-mass(nbins+n)
- dmass=bamp_jcpdry*dmass*rcon*rcon
+ dmass=bamp_jcpdry*(mass(n)-mass(nbins+n))*rcon
if(present(pjc)) then
pjc = dmass*dmass
endif
@@ -872,7 +867,7 @@ subroutine intjcpdry1(sval,nbins,mass)
!
!$$$
use mpimod, only: mype
- use gridmod, only: lat2,lon2,nsig,wgtlats,nlon,istart
+ use gridmod, only: lat2,lon2,nsig,wgtlats,istart
use guess_grids, only: ges_prsi,ntguessig
use gsi_metguess_mod, only: gsi_metguess_get
implicit none
@@ -884,7 +879,7 @@ subroutine intjcpdry1(sval,nbins,mass)
! Declare local variables
real(r_quad),dimension(nsig) :: mass2
- real(r_quad) rcon,con
+ real(r_quad) con
integer(i_kind) i,j,k,it,ii,mm1,icw,iql,iqi
integer(i_kind) iq,iqr,iqs,iqg,iqh,ips
real(r_kind),pointer,dimension(:,:,:) :: sq =>NULL()
@@ -901,13 +896,11 @@ subroutine intjcpdry1(sval,nbins,mass)
it=ntguessig
mass=zero_quad
- rcon=one_quad/(two_quad*float(nlon))
mm1=mype+1
do n=1,nbins
! Retrieve pointers
! Simply return if any pointer not found
- iq=0; icw=0; iql=0; iqi=0; iqr=0; iqs=0; iqg=0; iqh=0
call gsi_bundlegetpointer(sval(n),'q' ,sq, iq )
call gsi_bundlegetpointer(sval(n),'cw',sc, icw )
call gsi_bundlegetpointer(sval(n),'ql',sql, iql )
@@ -1023,11 +1016,10 @@ subroutine intjcpdry2(rval,nbins,mass,pjc)
integer(i_kind) :: n
it=ntguessig
- rcon=one_quad/(two_quad*float(nlon))
+ rcon=(one_quad/(two_quad*real(nlon,r_quad)))**2
mm1=mype+1
do n=1,nbins
- iq=0; icw=0; iql=0; iqi=0; iqr=0; iqs=0; iqg=0; iqh=0
call gsi_bundlegetpointer(rval(n),'q' ,rq, iq )
call gsi_bundlegetpointer(rval(n),'cw',rc, icw )
call gsi_bundlegetpointer(rval(n),'ql',rql, iql )
@@ -1037,7 +1029,7 @@ subroutine intjcpdry2(rval,nbins,mass,pjc)
call gsi_bundlegetpointer(rval(n),'qg',rqg, iqg )
call gsi_bundlegetpointer(rval(n),'qh',rqh, iqh )
call gsi_bundlegetpointer(rval(n),'ps',rp, ips )
- if( iq*ips /=0 .or. icw*(iql+iqi) /=0 ) then
+ if( ips /= 0 .or. iq /=0 .or. icw*(iql+iqi) /=0 ) then
if (mype==0) write(6,*)'intjcpdry2: warning - missing some required variables'
if (mype==0) write(6,*)'intjcpdry2: constraint for dry mass constraint not performed'
return
@@ -1045,8 +1037,7 @@ subroutine intjcpdry2(rval,nbins,mass,pjc)
! Remove water-vapor contribution to get incremental dry ps
! if (mype==0) write(6,*)'intjcpdry: total mass =', mass(n)
! if (mype==0) write(6,*)'intjcpdry: wv mass =', mass(nbins+n)
- dmass=mass(n)-mass(nbins+n)
- dmass=bamp_jcpdry*dmass*rcon*rcon
+ dmass=bamp_jcpdry*(mass(n)-mass(nbins+n))*rcon
if(present(pjc)) then
pjc = dmass*dmass
endif
diff --git a/src/gsi/intjo.f90 b/src/gsi/intjo.f90
index e514a38a22..a68355471b 100644
--- a/src/gsi/intjo.f90
+++ b/src/gsi/intjo.f90
@@ -31,7 +31,7 @@ module intjomod
use gsi_obOperTypeManager, only: &
iobOper_t, iobOper_pw, iobOper_q, &
iobOper_cldtot, iobOper_w, iobOper_dw, &
- iobOper_rw, iobOper_dbz, &
+ iobOper_rw, iobOper_dbz, iobOper_fed, &
iobOper_spd, iobOper_oz, iobOper_o3l, iobOper_colvk, &
iobOper_pm2_5, iobOper_pm10, iobOper_ps, iobOper_tcp, iobOper_sst, &
iobOper_gpsbend, iobOper_gpsref, &
@@ -60,7 +60,7 @@ module intjomod
integer(i_kind),parameter,dimension(obOper_count):: ix_obtype = (/ &
iobOper_t, iobOper_pw, iobOper_q, &
iobOper_cldtot, iobOper_w, iobOper_dw, &
- iobOper_rw, iobOper_dbz, &
+ iobOper_rw, iobOper_dbz, iobOper_fed, &
iobOper_spd, iobOper_oz, iobOper_o3l, iobOper_colvk, &
iobOper_pm2_5, iobOper_pm10, iobOper_ps, iobOper_tcp, iobOper_sst, &
iobOper_gpsbend, iobOper_gpsref, &
@@ -240,8 +240,6 @@ subroutine intjo_(rval,qpred,sval,sbias)
use m_obsdiags, only: obOper_destroy
use gsi_obOper, only: obOper
-use intradmod, only: setrad
-
implicit none
! Declare passed variables
@@ -257,7 +255,6 @@ subroutine intjo_(rval,qpred,sval,sbias)
class(obOper),pointer:: it_obOper
!******************************************************************************
- call setrad(sval(1))
! "RHS for jo", as it was labeled in intall().
!$omp parallel do schedule(dynamic,1) private(ibin,it,ix,it_obOper)
diff --git a/src/gsi/intrad.f90 b/src/gsi/intrad.f90
index 689b6c821e..b062ec953a 100644
--- a/src/gsi/intrad.f90
+++ b/src/gsi/intrad.f90
@@ -83,13 +83,14 @@ subroutine setrad(sval)
use gsi_bundlemod, only: gsi_bundlegetpointer
use gsi_metguess_mod, only: gsi_metguess_get
use mpeu_util, only: getindex
+ use mpimod, only: mype
implicit none
! Declare passed variables
type(gsi_bundle), intent(in ) :: sval
! Declare local variables
- integer(i_kind) ier,istatus,indx
+ integer(i_kind) indx
logical look
real(r_kind),pointer,dimension(:) :: st,sq,scw,soz,su,sv,sqg,sqh,sqi,sql,sqr,sqs
@@ -97,91 +98,110 @@ subroutine setrad(sval)
if(done_setting) return
-! Retrieve pointers; return when not found (except in case of non-essentials)
- ier=0; itsen=0; iqv=0; ius=0; ivs=0; isst=0; ioz=0; icw=0
- iqg=0; iqh=0; iqi=0; iql=0; iqr=0; iqs=0
- call gsi_bundlegetpointer(sval,'u', su, istatus);ius=istatus+ius
- call gsi_bundlegetpointer(sval,'v', sv, istatus);ivs=istatus+ivs
- call gsi_bundlegetpointer(sval,'tsen' ,st, istatus);itsen=istatus+itsen
- call gsi_bundlegetpointer(sval,'q', sq, istatus);iqv=istatus+iqv
- call gsi_bundlegetpointer(sval,'cw' ,scw,istatus);icw=istatus+icw
- call gsi_bundlegetpointer(sval,'oz' ,soz,istatus);ioz=istatus+ioz
- call gsi_bundlegetpointer(sval,'sst',sst,istatus);isst=istatus+isst
- call gsi_bundlegetpointer(sval,'qg' ,sqg,istatus);iqg=istatus+iqg
- call gsi_bundlegetpointer(sval,'qh' ,sqh,istatus);iqh=istatus+iqh
- call gsi_bundlegetpointer(sval,'qi' ,sqi,istatus);iqi=istatus+iqi
- call gsi_bundlegetpointer(sval,'ql' ,sql,istatus);iql=istatus+iql
- call gsi_bundlegetpointer(sval,'qr' ,sqr,istatus);iqr=istatus+iqr
- call gsi_bundlegetpointer(sval,'qs' ,sqs,istatus);iqs=istatus+iqs
- lgoback=(ius/=0).and.(ivs/=0).and.(itsen/=0).and.(iqv/=0).and.(ioz/=0).and.(icw/=0).and.(isst/=0)
- lgoback=lgoback .and.(iqg/=0).and.(iqh/=0).and.(iqi/=0).and.(iql/=0).and.(iqr/=0).and.(iqs/=0)
- if(lgoback)return
-
! check to see if variable participates in forward operator
! tsen
indx=getindex(radjacnames,'tsen')
- look=(itsen==0.and.indx>0)
itsen=-1
- if(look) itsen=radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'tsen',st, itsen)
+ look=itsen==0
+ if(look) itsen=radjacindxs(indx)
+ end if
! q
indx=getindex(radjacnames,'q')
- look=(iqv==0.and.indx>0)
iqv=-1
- if(look) iqv=radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'q', sq, iqv)
+ look=iqv==0
+ if(look) iqv=radjacindxs(indx)
+ end if
! oz
indx=getindex(radjacnames,'oz')
- look=(ioz ==0.and.indx>0)
ioz=-1
- if(look) ioz =radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'oz' , soz,ioz)
+ look=ioz ==0
+ if(look) ioz =radjacindxs(indx)
+ end if
! cw
indx=getindex(radjacnames,'cw')
- look=(icw ==0.and.indx>0)
icw=-1
- if(look) icw =radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'cw' , scw,icw)
+ look=icw ==0
+ if(look) icw =radjacindxs(indx)
+ end if
! sst
indx=getindex(radjacnames,'sst')
- look=(isst==0.and.indx>0)
isst=-1
- if(look) isst=radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'sst', sst,isst)
+ look=isst==0
+ if(look) isst=radjacindxs(indx)
+ end if
! us & vs
indx=getindex(radjacnames,'u')
- look=(ius==0.and.indx>0)
ius=-1
- if(look) ius=radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'u', su, ius)
+ look=ius==0
+ if(look) ius=radjacindxs(indx)
+ end if
indx=getindex(radjacnames,'v')
- look=(ivs==0.and.indx>0)
ivs=-1
- if(look) ivs=radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'v', sv, ivs)
+ look=ivs==0
+ if(look) ivs=radjacindxs(indx)
+ end if
! qg
indx=getindex(radjacnames,'qg')
- look=(iqg ==0.and.indx>0)
iqg=-1
- if(look) iqg =radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'qg' , sqg,iqg)
+ look=iqg ==0
+ if(look) iqg =radjacindxs(indx)
+ end if
! qh
indx=getindex(radjacnames,'qh')
- look=(iqh ==0.and.indx>0)
iqh=-1
- if(look) iqh =radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'qh' , sqh,iqh)
+ look=iqh ==0
+ if(look) iqh =radjacindxs(indx)
+ end if
! qi
indx=getindex(radjacnames,'qi')
- look=(iqi ==0.and.indx>0)
iqi=-1
- if(look) iqi =radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'qi' , sqi,iqi)
+ look=iqi ==0
+ if(look) iqi =radjacindxs(indx)
+ end if
! ql
indx=getindex(radjacnames,'ql')
- look=(iql ==0.and.indx>0)
iql=-1
- if(look) iql =radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'ql' , sql,iql)
+ look=iql ==0
+ if(look) iql =radjacindxs(indx)
+ end if
! qr
indx=getindex(radjacnames,'qr')
- look=(iqr ==0.and.indx>0)
iqr=-1
- if(look) iqr =radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'qr' , sqr,iqr)
+ look=iqr ==0
+ if(look) iqr =radjacindxs(indx)
+ end if
! qs
indx=getindex(radjacnames,'qs')
- look=(iqs ==0.and.indx>0)
iqs=-1
- if(look) iqs =radjacindxs(indx)
+ if(indx > 0)then
+ call gsi_bundlegetpointer(sval,'qs' , sqs,iqs)
+ look=iqs ==0
+ if(look) iqs =radjacindxs(indx)
+ end if
luseu=ius>=0
lusev=ivs>=0
@@ -196,6 +216,26 @@ subroutine setrad(sval)
luseqr=iqr>=0
luseqs=iqs>=0
lusesst=isst>=0
+ lgoback=.not.(luseu .or. lusev .or. luset .or. luseq .or. luseoz .or. lusecw .or. &
+ luseql .or. luseqi .or. luseqh .or. luseqg .or. luseqr .or. luseqs .or. &
+ lusesst)
+
+ if(mype == 0)then
+ write(6,*) ' following variables are used in int and stp radiance calculations '
+ if(luset) write(6,*)'tsen'
+ if(luseq) write(6,*)'q'
+ if(luseoz)write(6,*)'oz'
+ if(luseu) write(6,*)'u'
+ if(lusev) write(6,*)'v'
+ if(lusesst) write(6,*)'sst'
+ if(lusecw) write(6,*)'cw'
+ if(luseql) write(6,*)'ql'
+ if(luseqi) write(6,*)'qi'
+ if(luseqh) write(6,*)'qh'
+ if(luseqg) write(6,*)'qg'
+ if(luseqr) write(6,*)'qr'
+ if(luseqs) write(6,*)'qs'
+ end if
done_setting = .true.
@@ -308,7 +348,7 @@ subroutine intrad_(radhead,rval,sval,rpred,spred)
! Declare local variables
integer(i_kind) i1,i2,i3,i4,n,k,ic,ix,nn,mm,ncr1,ncr2
- integer(i_kind) ier,istatus
+ integer(i_kind) istatus
integer(i_kind),dimension(nsig) :: i1n,i2n,i3n,i4n
real(r_kind),allocatable,dimension(:):: val
real(r_kind) w1,w2,w3,w4
@@ -331,7 +371,6 @@ subroutine intrad_(radhead,rval,sval,rpred,spred)
call timer_ini('intrad')
! Retrieve pointers; return when not found (except in case of non-essentials)
- ier=0
if(luseu)then
call gsi_bundlegetpointer(sval,'u', su, istatus)
call gsi_bundlegetpointer(rval,'u', ru, istatus)
@@ -405,7 +444,8 @@ subroutine intrad_(radhead,rval,sval,rpred,spred)
i4n(k) = i4n(k-1)+latlon11
enddo
-!$omp parallel do schedule(dynamic,1) private(k,i1,i2,i3,i4,mm)
+ tdir=zero
+!$omp parallel do schedule(dynamic,1) private(k,i1,i2,i3,i4)
do k=1,nsig
i1 = i1n(k)
i2 = i2n(k)
@@ -468,7 +508,6 @@ subroutine intrad_(radhead,rval,sval,rpred,spred)
end do
-
! For all other configurations
! begin channel specific calculations
allocate(val(radptr%nchan))
@@ -487,10 +526,8 @@ subroutine intrad_(radhead,rval,sval,rpred,spred)
end do
end if
-!$omp parallel do schedule(dynamic,1) private(nn,ic,ix,k)
+!$omp parallel do schedule(dynamic,1) private(nn,k,ncr1,val_quad,mm)
do nn=1,radptr%nchan
- ic=radptr%icx(nn)
- ix=(ic-1)*npred
! include observation increment and lapse rate contributions to bias correction
val(nn)=zero
@@ -499,25 +536,24 @@ subroutine intrad_(radhead,rval,sval,rpred,spred)
do k=1,nsigradjac
val(nn)=val(nn)+tdir(k)*radptr%dtb_dvar(k,nn)
end do
- end do
- ncr1=0
! Include contributions from remaining bias correction terms
- do nn=1,radptr%nchan
if( .not. ladtest_obs) then
if(radptr%use_corr_obs)then
val_quad = zero_quad
do mm=1,nn
- ncr1=ncr1+1
+ ncr1=radptr%iccerr(nn)+mm
val_quad=val_quad+radptr%rsqrtinv(ncr1)*biasvect(mm)
enddo
val(nn)=val(nn) + val_quad
else
- val(nn)=val(nn)+biasvect(nn)
+ val(nn)=val(nn) + biasvect(nn)
endif
end if
+ end do
- if(luse_obsdiag)then
+ if(luse_obsdiag)then
+ do nn=1,radptr%nchan
if (lsaveobsens) then
val(nn)=val(nn)*radptr%err2(nn)*radptr%raterr2(nn)
!-- radptr%diags(nn)%ptr%obssen(jiter) = val(nn)
@@ -526,13 +562,14 @@ subroutine intrad_(radhead,rval,sval,rpred,spred)
!-- if (radptr%luse) radptr%diags(nn)%ptr%tldepart(jiter) = val(nn)
if (radptr%luse) call obsdiagNode_set(radptr%diags(nn)%ptr,jiter=jiter,tldepart=val(nn))
endif
- endif
- end do
+ end do
+ end if
if (l_do_adjoint) then
- do nn=1,radptr%nchan
- ic=radptr%icx(nn)
- if (.not. lsaveobsens) then
+ if (.not. lsaveobsens) then
+!$omp parallel do schedule(dynamic,1) private(nn,ic,cg_rad,wnotgross,wgross,p0)
+ do nn=1,radptr%nchan
+ ic=radptr%icx(nn)
if( .not. ladtest_obs) val(nn)=val(nn)-radptr%res(nn)
! Multiply by variance.
@@ -546,51 +583,45 @@ subroutine intrad_(radhead,rval,sval,rpred,spred)
endif
if(.not.ladtest_obs) val(nn) = val(nn)*radptr%err2(nn)*radptr%raterr2(nn)
- endif
- enddo
+ enddo
+ endif
! Extract contributions from bias correction terms
-! use compensated summation
if( .not. ladtest_obs) then
- if (radptr%use_corr_obs) then
- ncr1 = 0
- do mm=1,radptr%nchan
- ncr1 = ncr1 + mm
- ncr2 = ncr1
- biasvect(mm) = zero
- do nn=mm,radptr%nchan
- biasvect(mm)=biasvect(mm)+radptr%rsqrtinv(ncr2)*val(nn)
- ncr2 = ncr2 + nn
- enddo
- end do
- endif
+ if(radptr%luse)then
+ if (radptr%use_corr_obs) then
+!$omp parallel do schedule(dynamic,1) private(n,nn,ix,ncr1,ncr2,mm)
+ do nn=1,radptr%nchan
+ ncr1 = radptr%iccerr(nn)+nn
+ ncr2 = ncr1
+ biasvect(nn) = zero
+ do mm=nn,radptr%nchan
+ biasvect(nn)=biasvect(nn)+radptr%rsqrtinv(ncr2)*val(mm)
+ ncr2 = ncr2 + mm
+ enddo
- if(radptr%luse)then
- if(radptr%use_corr_obs)then
- do nn=1,radptr%nchan
- ix=(radptr%icx(nn)-1)*npred
- do n=1,npred
- rpred(ix+n)=rpred(ix+n)+biasvect(nn)*radptr%pred(n,nn)
- enddo
+ ix=(radptr%icx(nn)-1)*npred
+ do n=1,npred
+ rpred(ix+n)=rpred(ix+n)+biasvect(nn)*radptr%pred(n,nn)
enddo
- else
- do nn=1,radptr%nchan
- ix=(radptr%icx(nn)-1)*npred
- do n=1,npred
- rpred(ix+n)=rpred(ix+n)+radptr%pred(n,nn)*val(nn)
- end do
- end do
- end if
- end if
+ enddo
+ else
+!$omp parallel do schedule(dynamic,1) private(n,nn,ix)
+ do nn=1,radptr%nchan
+ ix=(radptr%icx(nn)-1)*npred
+ do n=1,npred
+ rpred(ix+n)=rpred(ix+n)+radptr%pred(n,nn)*val(nn)
+ end do
+ end do
+ end if
+ end if
- deallocate(biasvect)
+ deallocate(biasvect)
end if ! not ladtest_obs
- endif
! Begin adjoint
- if (l_do_adjoint) then
!$omp parallel do schedule(dynamic,1) private(k,nn)
do k=1,nsigradjac
tval(k)=zero
diff --git a/src/gsi/intrp2a.f90 b/src/gsi/intrp2a.f90
index 0d2926b8c7..129b48059f 100644
--- a/src/gsi/intrp2a.f90
+++ b/src/gsi/intrp2a.f90
@@ -56,8 +56,8 @@ subroutine intrp2a(f,g,dx,dy,n,nlevs,mype)
ix1=int(dx(i))
iy1=int(dy(i))
ix1=max(1,min(ix1,nlat))
- delx=dx(i)-float(ix1)
- dely=dy(i)-float(iy1)
+ delx=dx(i)-real(ix1,r_kind)
+ dely=dy(i)-real(iy1,r_kind)
delx=max(zero,min(delx,one))
ix=ix1-istart(mm1)+2
iy=iy1-jstart(mm1)+2
@@ -135,8 +135,8 @@ subroutine intrp2a1(f,g,dx,dy,nlevs,mype)
ix1=int(dx)
iy1=int(dy)
ix1=max(1,min(ix1,nlat))
- delx=dx-float(ix1)
- dely=dy-float(iy1)
+ delx=dx-real(ix1,r_kind)
+ dely=dy-real(iy1,r_kind)
delx=max(zero,min(delx,one))
ix=ix1-istart(mm1)+2
iy=iy1-jstart(mm1)+2
@@ -211,8 +211,8 @@ subroutine intrp2a11(f,g,dx,dy,mype)
ix1=int(dx)
iy1=int(dy)
ix1=max(1,min(ix1,nlat))
- delx=dx-float(ix1)
- dely=dy-float(iy1)
+ delx=dx-real(ix1,r_kind)
+ dely=dy-real(iy1,r_kind)
delx=max(zero,min(delx,one))
ix=ix1-istart(mm1)+2
iy=iy1-jstart(mm1)+2
diff --git a/src/gsi/intrw.f90 b/src/gsi/intrw.f90
index df3ec162a9..05b20e7991 100644
--- a/src/gsi/intrw.f90
+++ b/src/gsi/intrw.f90
@@ -96,7 +96,7 @@ subroutine intrw_(rwhead,rval,sval)
!$$$
use kinds, only: r_kind,i_kind
use constants, only: half,one,tiny_r_kind,cg_term,r3600
- use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag
+ use obsmod, only: lsaveobsens,l_do_adjoint,luse_obsdiag,if_use_w_vr
use qcmod, only: nlnqc_iter,varqc_iter
use jfunc, only: jiter
use gsi_bundlemod, only: gsi_bundle
@@ -127,23 +127,17 @@ subroutine intrw_(rwhead,rval,sval)
ier=0
call gsi_bundlegetpointer(sval,'u',su,istatus);ier=istatus+ier
call gsi_bundlegetpointer(sval,'v',sv,istatus);ier=istatus+ier
- call gsi_bundlegetpointer(sval,'w',sw,istatus)
- if (istatus==0) then
- include_w=.true.
- else
- include_w=.false.
- end if
call gsi_bundlegetpointer(rval,'u',ru,istatus);ier=istatus+ier
call gsi_bundlegetpointer(rval,'v',rv,istatus);ier=istatus+ier
- call gsi_bundlegetpointer(rval,'w',rw,istatus)
- if (istatus==0) then
- include_w=.true.
- else
- include_w=.false.
- end if
if(ier/=0)return
+ include_w=.false.
+ call gsi_bundlegetpointer(sval,'w',sw,istatus)
+ if (if_use_w_vr.and.istatus==0) then
+ call gsi_bundlegetpointer(rval,'w',rw,istatus)
+ if(istatus == 0)include_w=.true.
+ end if
!rwptr => rwhead
rwptr => rwNode_typecast(rwhead)
diff --git a/src/gsi/intsst.f90 b/src/gsi/intsst.f90
index d910247526..6b255d0d02 100644
--- a/src/gsi/intsst.f90
+++ b/src/gsi/intsst.f90
@@ -79,7 +79,7 @@ subroutine intsst(ssthead,rval,sval)
!
!$$$
use kinds, only: r_kind,i_kind
- use constants, only: half,one,tiny_r_kind,cg_term
+ use constants, only: zero,half,one,tiny_r_kind,cg_term
use obsmod, only: lsaveobsens, l_do_adjoint,luse_obsdiag
use qcmod, only: nlnqc_iter,varqc_iter
use gsi_nstcouplermod, only: nst_gsi
@@ -100,7 +100,6 @@ subroutine intsst(ssthead,rval,sval)
! real(r_kind) penalty
real(r_kind) w1,w2,w3,w4
real(r_kind) val
- real(r_kind) tval,tdir
real(r_kind) cg_sst,p0,grad,wnotgross,wgross,pg_sst
real(r_kind),pointer,dimension(:) :: ssst
real(r_kind),pointer,dimension(:) :: rsst
@@ -108,15 +107,14 @@ subroutine intsst(ssthead,rval,sval)
! If no sst data return
if(.not. associated(ssthead))return
+ if(.not. nst_gsi > 2) return
! Retrieve pointers
! Simply return if any pointer not found
- ier=0
- call gsi_bundlegetpointer(sval,'sst',ssst,istatus);ier=istatus+ier
+ call gsi_bundlegetpointer(sval,'sst',ssst,istatus);ier=istatus
call gsi_bundlegetpointer(rval,'sst',rsst,istatus);ier=istatus+ier
if(ier/=0)return
- !sstptr => ssthead
sstptr => sstNode_typecast(ssthead)
do while (associated(sstptr))
j1=sstptr%ij(1)
@@ -129,15 +127,9 @@ subroutine intsst(ssthead,rval,sval)
w4=sstptr%wij(4)
! Forward model
- val=w1*ssst(j1)+w2*ssst(j2)&
- +w3*ssst(j3)+w4*ssst(j4)
-
- if ( nst_gsi > 2 ) then
- tdir = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward
- val = tdir*sstptr%tz_tr ! Include contributions from Tz jacobian
- else
- val = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward
- endif
+ val=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4)
+
+ val = val*sstptr%tz_tr ! Include contributions from Tz jacobian
if(luse_obsdiag)then
@@ -173,18 +165,12 @@ subroutine intsst(ssthead,rval,sval)
endif
! Adjoint
- if ( nst_gsi > 2 ) then
- tval = sstptr%tz_tr*grad ! Extract contributions from surface jacobian
- rsst(j1)=rsst(j1)+w1*tval ! Distribute adjoint contributions over surrounding grid points
- rsst(j2)=rsst(j2)+w2*tval
- rsst(j3)=rsst(j3)+w3*tval
- rsst(j4)=rsst(j4)+w4*tval
- else
- rsst(j1)=rsst(j1)+w1*grad
- rsst(j2)=rsst(j2)+w2*grad
- rsst(j3)=rsst(j3)+w3*grad
- rsst(j4)=rsst(j4)+w4*grad
- endif
+ grad = sstptr%tz_tr*grad ! Extract contributions from surface jacobian
+
+ rsst(j1)=rsst(j1)+w1*grad
+ rsst(j2)=rsst(j2)+w2*grad
+ rsst(j3)=rsst(j3)+w3*grad
+ rsst(j4)=rsst(j4)+w4*grad
endif ! if (l_do_adjoint) then
diff --git a/src/gsi/intt.f90 b/src/gsi/intt.f90
index 9401026e47..b4082712a9 100644
--- a/src/gsi/intt.f90
+++ b/src/gsi/intt.f90
@@ -145,7 +145,7 @@ subroutine intt_(thead,rval,sval,rpred,spred)
! Declare local variables
integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,ier,istatus,isst,ix,n
- real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8,time_t
+ real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8
! real(r_kind) penalty
real(r_kind) cg_t,val,grad,rat_err2,error2,t_pg,var_jb
real(r_kind) psfc_grad,tg_grad
@@ -160,14 +160,13 @@ subroutine intt_(thead,rval,sval,rpred,spred)
! Retrieve pointers
! Simply return if any pointer not found
- ier=0; isst=0
- call gsi_bundlegetpointer(sval,'tsen', st,istatus);ier=istatus+ier
+ call gsi_bundlegetpointer(sval,'tsen', st,istatus);ier=istatus
call gsi_bundlegetpointer(sval,'tv', stv,istatus);ier=istatus+ier
call gsi_bundlegetpointer(sval,'q', sq,istatus);ier=istatus+ier
call gsi_bundlegetpointer(sval,'u', su,istatus);ier=istatus+ier
call gsi_bundlegetpointer(sval,'v', sv,istatus);ier=istatus+ier
call gsi_bundlegetpointer(sval,'prse', sp,istatus);ier=istatus+ier
- call gsi_bundlegetpointer(sval,'sst',ssst,istatus);isst=istatus+isst
+ call gsi_bundlegetpointer(sval,'sst',ssst,istatus);isst=istatus
if(ier/=0) return
call gsi_bundlegetpointer(rval,'tsen', rt,istatus);ier=istatus+ier
@@ -179,7 +178,6 @@ subroutine intt_(thead,rval,sval,rpred,spred)
call gsi_bundlegetpointer(rval,'sst',rsst,istatus);isst=istatus+isst
if(ier/=0) return
- time_t=zero
!tptr => thead
tptr => tNode_typecast(thead)
do while (associated(tptr))
@@ -205,20 +203,22 @@ subroutine intt_(thead,rval,sval,rpred,spred)
!----------use surface model----------------------
+ qs_prime0=w1* sq(j1)+w2* sq(j2)+w3* sq(j3)+w4* sq(j4)
+ us_prime0=w1* su(j1)+w2* su(j2)+w3* su(j3)+w4* su(j4)
+ vs_prime0=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4)
+ psfc_prime0=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4)
+
if(tptr%tv_ob)then
ts_prime0=w1*stv(j1)+w2*stv(j2)+w3*stv(j3)+w4*stv(j4)
else
ts_prime0=w1*st(j1)+w2*st(j2)+w3*st(j3)+w4*st(j4)
end if
+
if (isst==0) then
tg_prime0=w1* ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4)
else
tg_prime0=zero
end if
- qs_prime0=w1* sq(j1)+w2* sq(j2)+w3* sq(j3)+w4* sq(j4)
- us_prime0=w1* su(j1)+w2* su(j2)+w3* su(j3)+w4* su(j4)
- vs_prime0=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4)
- psfc_prime0=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4)
val=psfc_prime0*tptr%tlm_tsfc(1) + tg_prime0*tptr%tlm_tsfc(2) + &
ts_prime0 *tptr%tlm_tsfc(3) + qs_prime0*tptr%tlm_tsfc(4) + &
@@ -231,8 +231,8 @@ subroutine intt_(thead,rval,sval,rpred,spred)
val=w1*stv(j1)+w2*stv(j2)+w3*stv(j3)+w4*stv(j4)&
+w5*stv(j5)+w6*stv(j6)+w7*stv(j7)+w8*stv(j8)
else
- val=w1* st(j1)+w2* st(j2)+w3* st(j3)+w4* st(j4)&
- +w5* st(j5)+w6* st(j6)+w7* st(j7)+w8* st(j8)
+ val=w1*st(j1)+ w2*st(j2)+ w3*st(j3)+ w4*st(j4)&
+ +w5*st(j5)+ w6*st(j6)+ w7*st(j7)+ w8*st(j8)
end if
end if
@@ -310,21 +310,7 @@ subroutine intt_(thead,rval,sval,rpred,spred)
rp(j2)=rp(j2)+w2*psfc_grad
rp(j3)=rp(j3)+w3*psfc_grad
rp(j4)=rp(j4)+w4*psfc_grad
- vs_grad =tptr%tlm_tsfc(6)*grad
- rv(j1)=rv(j1)+w1*vs_grad
- rv(j2)=rv(j2)+w2*vs_grad
- rv(j3)=rv(j3)+w3*vs_grad
- rv(j4)=rv(j4)+w4*vs_grad
- us_grad =tptr%tlm_tsfc(5)*grad
- ru(j1)=ru(j1)+w1*us_grad
- ru(j2)=ru(j2)+w2*us_grad
- ru(j3)=ru(j3)+w3*us_grad
- ru(j4)=ru(j4)+w4*us_grad
- qs_grad =tptr%tlm_tsfc(4)*grad
- rq(j1)=rq(j1)+w1*qs_grad
- rq(j2)=rq(j2)+w2*qs_grad
- rq(j3)=rq(j3)+w3*qs_grad
- rq(j4)=rq(j4)+w4*qs_grad
+
if (isst==0) then
tg_grad =tptr%tlm_tsfc(2)*grad
rsst(j1)=rsst(j1)+w1*tg_grad
@@ -333,22 +319,39 @@ subroutine intt_(thead,rval,sval,rpred,spred)
rsst(j4)=rsst(j4)+w4*tg_grad
end if
-
ts_grad =tptr%tlm_tsfc(3)*grad
if(tptr%tv_ob)then
rtv(j1)=rtv(j1)+w1*ts_grad
rtv(j2)=rtv(j2)+w2*ts_grad
rtv(j3)=rtv(j3)+w3*ts_grad
rtv(j4)=rtv(j4)+w4*ts_grad
-
else
rt(j1)=rt(j1)+w1*ts_grad
rt(j2)=rt(j2)+w2*ts_grad
rt(j3)=rt(j3)+w3*ts_grad
rt(j4)=rt(j4)+w4*ts_grad
-
end if
+ qs_grad =tptr%tlm_tsfc(4)*grad
+ rq(j1)=rq(j1)+w1*qs_grad
+ rq(j2)=rq(j2)+w2*qs_grad
+ rq(j3)=rq(j3)+w3*qs_grad
+ rq(j4)=rq(j4)+w4*qs_grad
+
+ us_grad =tptr%tlm_tsfc(5)*grad
+ ru(j1)=ru(j1)+w1*us_grad
+ ru(j2)=ru(j2)+w2*us_grad
+ ru(j3)=ru(j3)+w3*us_grad
+ ru(j4)=ru(j4)+w4*us_grad
+
+ vs_grad =tptr%tlm_tsfc(6)*grad
+ rv(j1)=rv(j1)+w1*vs_grad
+ rv(j2)=rv(j2)+w2*vs_grad
+ rv(j3)=rv(j3)+w3*vs_grad
+ rv(j4)=rv(j4)+w4*vs_grad
+
+
+
else
!------bypass surface model--------------------------
diff --git a/src/gsi/jfunc.f90 b/src/gsi/jfunc.f90
index 1b92ad2e94..616f835218 100644
--- a/src/gsi/jfunc.f90
+++ b/src/gsi/jfunc.f90
@@ -136,10 +136,12 @@ module jfunc
public :: pseudo_q2
public :: varq
public :: cnvw_option
+ public :: hofx_2m_sfcfile
logical first,last,switch_on_derivatives,tendsflag,print_diag_pcg,tsensible,diag_precon
logical clip_supersaturation,R_option
logical pseudo_q2,limitqobs
+ logical hofx_2m_sfcfile
logical cnvw_option
integer(i_kind) iout_iter,miter,iguess,nclen,qoption,cwoption
integer(i_kind) jiter,jiterstart,jiterend,iter
@@ -249,6 +251,9 @@ subroutine init_jfunc
! option for including convective clouds in the all-sky assimilation
cnvw_option=.false.
+! option to calculate hofx for T2m and q2m by interpolating from 2m vars in sfc file
+ hofx_2m_sfcfile=.false.
+
return
end subroutine init_jfunc
diff --git a/src/gsi/jgrad.f90 b/src/gsi/jgrad.f90
index 2e32556465..6b17544300 100755
--- a/src/gsi/jgrad.f90
+++ b/src/gsi/jgrad.f90
@@ -58,6 +58,8 @@ subroutine jgrad(xhat,yhat,fjcost,gradx,lupdfgs,nprt,calledby)
use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens
use mpl_allreducemod, only: mpl_allreduce
use obs_sensitivity, only: efsoi_o2_update
+use control2state_mod, only: control2state,control2state_ad
+use ensctl2state_mod, only: ensctl2state,ensctl2state_ad
implicit none
diff --git a/src/gsi/lightinfo.f90 b/src/gsi/lightinfo.f90
index b0ebcdacfd..bdd6aee392 100755
--- a/src/gsi/lightinfo.f90
+++ b/src/gsi/lightinfo.f90
@@ -205,11 +205,13 @@ subroutine lightinfo_read
else
! File does not exist, write warning message to alert users
- if (mype==mype_light) then
- open(iout_light)
- write(iout_light,*)'LIGHTINFO_READ: ***WARNING*** FILE ',trim(fname),'does not exist'
- close(iout_light)
- endif
+! For many usages light data is not important. Write line to output.
+! if (mype==mype_light) then
+! open(iout_light)
+! write(iout_light,*)'LIGHTINFO_READ: ***WARNING*** FILE ',trim(fname),'does not exist'
+ if(mype==mype_light)write(6,*)'LIGHTINFO_READ: FILE ',trim(fname),'does not exist'
+! close(iout_light)
+! endif
end if
return
diff --git a/src/gsi/m_berror_stats.f90 b/src/gsi/m_berror_stats.f90
index 808aee9954..088a7619fe 100644
--- a/src/gsi/m_berror_stats.f90
+++ b/src/gsi/m_berror_stats.f90
@@ -646,7 +646,7 @@ subroutine setcoroz_(coroz,mype)
enddo
enddo
enddo
- work_oz(nsig+1,mm1)=float(lon1*lat1)
+ work_oz(nsig+1,mm1)=real(lon1*lat1,r_kind)
call mpi_allreduce(work_oz,work_oz1,(nsig+1)*npe,mpi_rtype,mpi_sum,&
mpi_comm_world,ierror)
@@ -869,7 +869,7 @@ subroutine setcorchem_(cname,corchem,rc)
enddo
enddo
enddo
- work_chem(nsig+1,mm1)=float(lon1*lat1)
+ work_chem(nsig+1,mm1)=real(lon1*lat1,r_kind)
call mpi_allreduce(work_chem,work_chem1,(nsig+1)*npe,mpi_rtype,mpi_sum,&
mpi_comm_world,ierror)
diff --git a/src/gsi/m_berror_stats_reg.f90 b/src/gsi/m_berror_stats_reg.f90
index 2ff8a6aa94..d7a30808e6 100644
--- a/src/gsi/m_berror_stats_reg.f90
+++ b/src/gsi/m_berror_stats_reg.f90
@@ -12,7 +12,7 @@ module m_berror_stats_reg
use kinds,only : i_kind,r_kind
use constants, only: zero,one,max_varname_length,half
use gridmod, only: nsig
- use chemmod, only : berror_chem,berror_fv3_cmaq_regional,upper2lower,lower2upper
+ use chemmod, only : berror_chem,berror_fv3_cmaq_regional,berror_fv3_sd_regional,upper2lower,lower2upper
use m_berror_stats, only: usenewgfsberror,berror_stats
implicit none
@@ -312,7 +312,8 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt
use constants, only: zero,one,ten,three
use mpeu_util,only: getindex
use radiance_mod, only: icloud_cv,n_clouds_fwd,cloud_names_fwd
- use chemmod, only: berror_fv3_cmaq_regional
+ use chemmod, only: berror_fv3_cmaq_regional,berror_fv3_sd_regional
+ use rapidrefresh_cldsurf_mod, only: corp_gust, hwllp_gust, l_rtma3d
implicit none
@@ -400,7 +401,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt
integer(i_kind) :: nrf2_td2m,nrf2_mxtm,nrf2_mitm,nrf2_pmsl,nrf2_howv,nrf2_tcamt,nrf2_lcbas,nrf2_cldch
integer(i_kind) :: nrf2_uwnd10m,nrf2_vwnd10m
integer(i_kind) :: nrf3_sfwter,nrf3_vpwter
- integer(i_kind) :: nrf3_dbz
+ integer(i_kind) :: nrf3_dbz,nrf3_fed
integer(i_kind) :: nrf3_ql,nrf3_qi,nrf3_qr,nrf3_qs,nrf3_qg,nrf3_qnr,nrf3_w
integer(i_kind) :: inerr,istat
integer(i_kind) :: nsigstat,nlatstat,isig
@@ -466,7 +467,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt
var=upper2lower(varshort)
if (trim(var) == 'pm25') var = 'pm2_5'
else
- if ( berror_fv3_cmaq_regional) then
+ if ( berror_fv3_cmaq_regional .or. berror_fv3_sd_regional) then
read(inerr,iostat=istat) varlong, isig
var=varlong
else
@@ -624,6 +625,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt
nrf3_sf =getindex(cvars3d,'sf')
nrf3_vp =getindex(cvars3d,'vp')
nrf3_dbz=getindex(cvars3d,'dbz')
+ nrf3_fed=getindex(cvars3d,'fed')
nrf2_sst=getindex(cvars2d,'sst')
nrf2_gust=getindex(cvars2d,'gust')
nrf2_vis=getindex(cvars2d,'vis')
@@ -671,6 +673,16 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt
vz(:,:,nrf3_dbz)=vz(:,:,nrf3_t)
endif
+ if( nrf3_fed>0 )then
+ if(.not. nrf3_t>0) then
+ write(6,*)'not as expect,stop'
+ stop
+ endif
+ corz(:,:,nrf3_fed)=10.0_r_kind
+ hwll(:,:,nrf3_fed)=hwll(:,:,nrf3_t)
+ vz(:,:,nrf3_fed)=vz(:,:,nrf3_t)
+ endif
+
if (nrf3_oz>0) then
factoz = 0.0002_r_kind*r25
corz(:,:,nrf3_oz)=factoz
@@ -814,11 +826,35 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt
! end if
else if (n==nrf2_gust) then
do i=1,mlat
- corp(i,n)=three
+ corp(i,n)=three ! background error stddev of wind gust = 3 m/s (default: legacy code from 2DRTMA)
end do
do i=0,mlat+1
- hwllp(i,n)=hwll(i,1,nrf3_q)
+ hwllp(i,n)=hwll(i,1,nrf3_q) ! de-correlation length of bkgd error of gust is
+ ! same as the value of q at bottom level (default: legacy code from 2DRTMA)
+ ! for other DA apps, it is recommended to change it
+ ! by setting hwllp_gust in GSI namelist.
end do
+ if ( l_rtma3d ) then ! For 3drtma only: allowing to change the stddev and
+ ! de-correlation length of bkgd error of gust:
+ ! corp_gust : set in namelist(if <=0, using default value above (3.0)
+ ! hwllp_gust: set in namelist(if <=0, using default value above (value of q)
+ if ( corp_gust .gt. 0.0_r_kind ) then
+ corp(1:mlat, n) = corp_gust
+ if (mype==0) write(6,'(1x,A,A,I5.5,A,F8.3)') &
+ myname_,"@pe=",mype," (3drtma) set b_error stddev of gust = ",corp_gust
+ else
+ if (mype==0) write(6,'(1x,A,A,I5.5,A,F8.3)') &
+ myname_,"@pe=",mype," (3drtma) set b_error stddev of gust (default) = ",three
+ end if
+ if ( hwllp_gust .gt. 0.0_r_kind ) then
+ hwllp(0:mlat+1,n) = hwllp_gust
+ if (mype==0) write(6,'(1x,A,A,I5.5,A,F12.3)') &
+ myname_,"@pe=",mype," (3drtma) set b_error de-corr length of gust = ",hwllp_gust
+ else
+ if (mype==0) write(6,'(1x,A,A,I5.5,A)') &
+ myname_,"@pe=",mype," (3drtma) set b_error de-corr length of gust is same as length of q."
+ end if
+ end if
else if (n==nrf2_vis) then
do i=1,mlat
corp(i,n)=3.0_r_kind
@@ -870,16 +906,17 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt
hwllp(i,n)=hwllp(i,nrf2_ps)
end do
else if (n==nrf2_howv) then
- call read_howv_stats(mlat,1,2,cov_dum)
+ call read_howv_stats(mlat,1,2,cov_dum,mype)
do i=1,mlat
corp(i,n)=cov_dum(i,1,1) !#ww3
hwllp(i,n) = cov_dum(i,1,2)
end do
hwllp(0,n) = hwllp(1,n)
hwllp(mlat+1,n) = hwllp(mlat,n)
-
- if (mype==0) print*, 'corp(i,n) = ', corp(:,n)
- if (mype==0) print*, ' hwllp(i,n) = ', hwllp(:,n)
+ if (mype==0) then
+ print*, myname_, ' static BE corp( :,n) (for ', trim(adjustl(cvars2d(n))), ')= ', corp(:,n)
+ print*, myname_, ' static BE hwllp(:,n) (for ', trim(adjustl(cvars2d(n))), ')= ', hwllp(:,n)
+ end if
! corp(:,n)=cov_dum(:,1)
!do i=1,mlat
! corp(i,n)=0.4_r_kind !#ww3
@@ -1055,7 +1092,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt
end subroutine berror_read_wgt_reg
!++++
-subroutine read_howv_stats(nlat,nlon,npar,arrout)
+subroutine read_howv_stats(nlat,nlon,npar,arrout,mype)
!$$$ subprogram documentation block
! . . . .
! subprogram: read_howv_stats
@@ -1090,6 +1127,9 @@ subroutine read_howv_stats(nlat,nlon,npar,arrout)
! program history log:
! 2016-08-03 stelios
! 2016-08-26 stelios : Compatible with GSI.
+! 2023-07-30 Zhao - added code to set the background error
+! standard deviation (corp_howv) and de-correlation
+! length scale (hwllp_howv) for non-2DRTMA run
! input argument list:
! filename - The name of the file
! output argument list:
@@ -1102,10 +1142,14 @@ subroutine read_howv_stats(nlat,nlon,npar,arrout)
!$$$ end documentation block
!
use kinds,only : r_kind, i_kind
+ use gridmod, only : twodvar_regional
+ use rapidrefresh_cldsurf_mod, only : corp_howv, hwllp_howv
+ use gsi_io, only : verbose
!
implicit none
! Declare passed variables
integer(i_kind), intent(in )::nlat,nlon,npar
+ integer(i_kind), intent(in ) :: mype ! "my" processor ID
real(r_kind), dimension(nlat ,nlon, npar), intent( out)::arrout
! Declare local variables
integer(i_kind) :: reclength,i,j,i_npar
@@ -1117,12 +1161,18 @@ subroutine read_howv_stats(nlat,nlon,npar,arrout)
!
filename(1) = 'howv_var_berr.bin'
filename(2) = 'howv_lng_berr.bin'
-!
- arrout(:,:,1)=0.42_r_kind
- arrout(:,:,2)=50000.0_r_kind
+!-- first, assign the pre-defined values to corp and hwllp
+ if ( twodvar_regional ) then
+ arrout(:,:,1)=0.42_r_kind ! values were specified by Manuel and Stelio for 2DRTMA
+ arrout(:,:,2)=50000.0_r_kind ! values were specified by Manuel and Stelio for 2DRTMA
+ else
+ arrout(:,:,1) = corp_howv ! 0.42_r_kind used in 3dvar (default) if not set in namelist
+ arrout(:,:,2) = hwllp_howv ! 17000.0_r_kind used in 3dvar (default) if not set in namelist
+ end if
reclength=nlat*r_kind
-!
+!-- secondly, if files for corp and hwllp are available, then read them in for
+! corp and hwllp. If the files are not found, then use the pre-defined values.
do i_npar = 1,npar
inquire(file=trim(filename(i_npar)), exist=file_exists)
if (file_exists)then
@@ -1132,9 +1182,16 @@ subroutine read_howv_stats(nlat,nlon,npar,arrout)
read(unit=lun34 ,rec=j) (arrout(i,j,i_npar), i=1,nlat)
enddo
close(unit=lun34)
+ if (verbose .and. mype .eq. 0) then
+ write(6,'(1x,A,1x,A2,1x,A)') trim(adjustl(myname)), '::', &
+ trim(filename(i_npar))//' is used for background error of howv.'
+ end if
else
- print*,myname, trim(filename(i_npar)) // ' does not exist'
+ if (verbose .and. mype .eq. 0) then
+ write(6,'(1x,A,1x,A2,1x,A)') trim(adjustl(myname)), '::', &
+ trim(filename(i_npar))//' does not exist for static BE of howv, using pre-defined values.'
+ end if
end if
end do
end subroutine read_howv_stats
diff --git a/src/gsi/m_extOzone.F90 b/src/gsi/m_extOzone.F90
index 3d4b6783c1..5dead0551a 100644
--- a/src/gsi/m_extOzone.F90
+++ b/src/gsi/m_extOzone.F90
@@ -158,32 +158,36 @@ function is_extOzone_(dfile,dtype,dplat,class)
is_extOzone_= &
ifile_==iBUFR .and. dtype == 'o3lev' .or. &
ifile_==iNC .and. dtype == 'mls55' .or. &
+ ifile_==iNC .and. dtype == 'ompslpnc' .or. &
ifile_==iNC .and. dtype == 'ompslpvis' .or. &
ifile_==iNC .and. dtype == 'ompslpuv' .or. &
- ifile_==iNC .and. dtype == 'ompslp' .or. &
ifile_==iNC .and. dtype == 'lims' .or. &
ifile_==iNC .and. dtype == 'uarsmls' .or. &
ifile_==iNC .and. dtype == 'mipas' .or. &
ifile_==iNC .and. dtype == 'omieff' .or. &
+ ifile_==iNC .and. dtype == 'ompsnmeff' .or. &
+ ifile_==iNC .and. dtype == 'ompsnpnc' .or. &
ifile_==iNC .and. dtype == 'tomseff'
case(iLEVEL)
is_extOzone_= &
ifile_==iBUFR .and. dtype == 'o3lev' .or. &
ifile_==iNC .and. dtype == 'mls55' .or. &
+ ifile_==iNC .and. dtype == 'ompslpnc' .or. &
ifile_==iNC .and. dtype == 'ompslpvis' .or. &
ifile_==iNC .and. dtype == 'ompslpuv' .or. &
- ifile_==iNC .and. dtype == 'ompslp' .or. &
ifile_==iNC .and. dtype == 'lims' .or. &
ifile_==iNC .and. dtype == 'uarsmls' .or. &
ifile_==iNC .and. dtype == 'mipas'
case(iLAYER)
- is_extOzone_= .false.
+ is_extOzone_= &
+ ifile_==iNC .and. dtype == 'ompsnpnc'
case(iTOTAL)
is_extOzone_= &
- ifile_==iNC .and. dtype == 'omieff' .or. &
+ ifile_==iNC .and. dtype == 'omieff' .or. &
+ ifile_==iNC .and. dtype == 'ompsnmeff' .or. &
ifile_==iNC .and. dtype == 'tomseff'
case default
@@ -332,7 +336,7 @@ subroutine read_(dfile,dtype,dplat,dsis, & ! intent(in), keys for type mana
endif
select case(dtype)
- case('omieff','tomseff') ! layer-ozone or total-ozone types
+ case('omieff','tomseff','ompsnmeff') ! layer-ozone or total-ozone types
select case(dfile_format(dfile))
case('nc')
call oztot_ncInquire_(nreal,nchan,ilat,ilon, &
@@ -381,7 +385,7 @@ subroutine read_(dfile,dtype,dplat,dsis, & ! intent(in), keys for type mana
jsatid, gstime,twind)
end select
- case('mls55','ompslpvis','ompslpuv','ompslp','lims','uarsmls','mipas')
+ case('mls55','ompslpnc','ompslpvis','ompslpuv','lims','uarsmls','mipas')
select case(dfile_format(dfile))
case('nc')
call ozlev_ncInquire_( nreal,nchan,ilat,ilon,maxobs)
@@ -393,6 +397,17 @@ subroutine read_(dfile,dtype,dplat,dsis, & ! intent(in), keys for type mana
end select
+ case('ompsnpnc')
+ select case(dfile_format(dfile))
+ case('nc')
+ call ozlay_ncInquire_( nreal,nchan,ilat,ilon,maxobs)
+ allocate(p_out(nreal+nchan,maxobs))
+ p_out(:,:)=RMISS
+
+ call ozlay_ncRead_(dfile,dtype, p_out,nread,npuse,nouse, gstime,twind)
+
+ end select
+
end select
if(nouse<0 .or. .not.associated(p_out)) then
@@ -706,7 +721,7 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, &
! Apply data screening based on quality flags
! Bit 10 (from the left) in TOQF represents row anomaly. All 17 bits in toqf is
! supposed to converted into array elements of binary(:), either for "tomseff" or
-! "omieff".
+! "omieff" or "ompsnmeff".
binary(:)=0
select case(dtype)
case('omieff')
@@ -731,6 +746,9 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, &
! 0 - good data, 1 - good data with SZA > 84 deg
if (toqf /= 0) cycle recloop
+ case('ompsnmeff')
+ !! data in NetCDF are prescreened
+
case default
end select
@@ -764,10 +782,10 @@ subroutine oztot_ncread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, &
ozout(7,itx)=real(toqf) ! - total ozone quality code (not used)
ozout(8,itx)=real(sza) ! solar zenith angle
ozout(9,itx)=binary(10) ! row anomaly flag, is actually fixed to 0
- ozout(10,itx)=0. ! - cloud amount (not used)
- ozout(11,itx)=0. ! - vzan (not used)
- ozout(12,itx)=0. ! - aerosol index (not used)
- ozout(13,itx)=0. ! - ascending/descending (not used)
+ ozout(10,itx)=zero ! - cloud amount (not used)
+ ozout(11,itx)=zero ! - vzan (not used)
+ ozout(12,itx)=zero ! - aerosol index (not used)
+ ozout(13,itx)=zero ! - ascending/descending (not used)
ozout(14,itx)=real(fovn) ! scan position
! "(not used)" flags above imply that they
! are not used in setupozlay().
@@ -1093,7 +1111,7 @@ subroutine ozlev_ncread_(dfile,dtype,ozout,nmrecs,ndata,nodata, gstime,twind)
ozout(8,ndata)=usage
ozout(9,ndata)=pob ! pressure
ozout(10,ndata)=obserr ! ozone mixing ratio precision in ppmv
- ozout(11,ndata)=float(ipos(ilev)) ! pointer of obs level index in ozinfo.txt
+ ozout(11,ndata)=real(ipos(ilev),r_kind) ! pointer of obs level index in ozinfo.txt
ozout(12,ndata)=levs ! # of vertical levels
ozout(13,ndata)=ppmv ! ozone mixing ratio in ppmv
endif
@@ -1406,7 +1424,7 @@ subroutine ozlev_bufrread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, &
ozout( 8,ndata)=usage1(k) !
ozout( 9,ndata)=mlspres(k) ! mls pressure in log(cb)
ozout(10,ndata)=mlsozpc(k) ! ozone mixing ratio precision in ppmv
- ozout(11,ndata)=float(ipos(k)) ! pointer of obs level index in ozinfo.txt
+ ozout(11,ndata)=real(ipos(k),r_kind) ! pointer of obs level index in ozinfo.txt
ozout(12,ndata)=nloz ! # of mls vertical levels
ozout(13,ndata)=mlsoz(k) ! ozone mixing ratio in ppmv
endif
@@ -1421,13 +1439,286 @@ subroutine ozlev_bufrread_(dfile,dtype,dsis, ozout,nmrecs,ndata,nodata, &
call warn(myname_,' actual retained =',nodata)
call warn(myname_,' size(ozout,2) =',maxobs)
endif
- call closbf(lunin)
- close(lunin)
! write(stdout,'(3a,3i8,f8.2)') mprefix('read_ozone'), &
! ' obstype,nmrecs,ndata,nodata,no/ndata = ',dtype,nmrecs,ndata,nodata,real(nodata)/ndata
-end subroutine ozlev_bufrread_
+ end subroutine ozlev_bufrread_
+
+ subroutine ozlay_ncInquire_( nreal,nchan,ilat,ilon, maxrec)
+ implicit none
+
+ integer(kind=i_kind), intent(out):: nreal ! number of real parameters per record
+ integer(kind=i_kind), intent(out):: nchan ! number of channels or levels per record
+ integer(kind=i_kind), intent(out):: ilat ! index to latitude in nreal parameters.
+ integer(kind=i_kind), intent(out):: ilon ! index to longitude in nreal parameters.
+
+ integer(kind=i_kind), intent(out):: maxrec ! extimated input record count
+
+ character(len=*), parameter:: myname_=myname//'::ozlay_ncInquire_'
+
+ ! Configure the record, they are not (dfile,dtype,dplat) dependent in this case.
+ nreal = 9
+ nchan = 22
+ ilat=4
+ ilon=3
+
+ maxrec = MAXOBS_
+ end subroutine ozlay_ncInquire_
+
+ !..................................................................................
+ subroutine ozlay_ncread_(dfile,dtype,ozout,nmrecs,ndata,nodata, gstime,twind)
+ !..................................................................................
+ use netcdf, only: nf90_open
+ use netcdf, only: nf90_nowrite
+ use netcdf, only: nf90_noerr
+ use netcdf, only: nf90_inq_dimid
+ use netcdf, only: nf90_inquire_dimension
+ use netcdf, only: nf90_inq_varid
+ use netcdf, only: nf90_get_var
+ use netcdf, only: nf90_close
+
+ use gridmod, only: nlat,nlon,regional,tll2xy,rlats,rlons
+ use gsi_4dvar, only: l4dvar,iwinbgn,winlen,l4densvar
+
+ use constants, only: deg2rad,zero,one_tenth,r60inv
+ use ozinfo, only: jpch_oz,nusis_oz,iuse_oz
+ use mpeu_util, only: perr,die
+ ! use mpeu_util, only: mprefix,stdout
+
+ implicit none
+ character(len=*), intent(in):: dfile ! obs_input filename
+ character(len=*), intent(in):: dtype ! obs_input dtype
+ real (kind=r_kind), dimension(:,:), intent(out):: ozout
+ integer(kind=i_kind), intent(out):: nmrecs ! count of records read
+ integer(kind=i_kind), intent(out):: ndata ! count of processed
+ integer(kind=i_kind), intent(out):: nodata ! count of retained
+ real (kind=r_kind), intent(in):: gstime ! analysis time (minute) from reference date
+ real (kind=r_kind), intent(in):: twind ! input group time window (hour)
+
+ character(len=*), parameter:: myname_=myname//'::ozlay_ncRead_'
+
+ integer(kind=i_kind):: ier,nprofs,levs,ikx,i,k0,ilev,iprof
+ integer(kind=i_kind):: nrecDimId,lonVarID,latVarID,yyVarID,mmVarID,levsDimId
+ integer(kind=i_kind):: szaVarID,ozoneVarID,nmind,k
+ integer(kind=i_kind):: ddVarID,hhVarID,minVarID,ssVarID,maxobs,ncid
+ real (kind=r_kind):: dlon,dlon_earth,dlon_earth_deg
+ real (kind=r_kind):: dlat,dlat_earth,dlat_earth_deg
+ real (kind=r_kind):: slons0,slats0
+ real (kind=r_kind):: tdiff,sstime,t4dv,rsat
+ integer(kind=i_kind):: idate5(5)
+ integer(kind=i_kind),allocatable,dimension(:):: ipos
+ real(r_kind),allocatable,dimension(:):: poz
+
+ integer(kind=i_kind), allocatable :: iya(:),ima(:),idda(:),ihha(:),imina(:),iseca(:)
+ real (kind=r_kind), allocatable :: slatsa(:),slonsa(:),ozone(:,:),sza(:)
+ real(r_kind) totoz
+
+ logical:: outside
+ logical:: first
+ real(r_kind),parameter:: badoz = 10000.0_r_kind
+
+ maxobs=size(ozout,2)
+ rsat=999._r_kind
+ ndata = 0
+ nmrecs=0
+ nodata=-1
+
+ ! Open file and read dimensions
+ call check(nf90_open(trim(dfile),nf90_nowrite,ncid),stat=ier)
+
+ ! ignore if the file is not actually present.
+ if(ier/=nf90_noerr) then
+ nodata = 0
+ return
+ endif
+
+ ! Get dimensions from the input file
+ call check(nf90_inq_dimid(ncid, "nrec", nrecDimId),stat=ier)
+
+ ! ignore if error
+ if(ier/=nf90_noerr) then
+ nodata = 0
+ call check(nf90_close(ncid),stat=ier)
+ return
+ endif
+
+ ! Get dimensions from the input file: # of profiles and # of levels
+ nprofs=0
+ call check(nf90_inquire_dimension(ncid, nrecDimId, len = nprofs),stat=ier)
+ ! ignore if error
+ if(ier/=nf90_noerr) then
+ call check(nf90_close(ncid),stat=ier)
+ return
+ endif
+
+ if(nprofs==0) then
+ nodata=0
+ call check(nf90_close(ncid),stat=ier)
+ return
+ endif
+
+ ! Continue the input
+ call check(nf90_inq_dimid(ncid, "nlevs", levsDimId))
+ call check(nf90_inquire_dimension(ncid, levsDimId, len = levs))
+ !!!!! if (levs /= nchan)
+
+ allocate(ipos(levs))
+ ipos=999
+ ikx = 0
+ first=.false.
+ do i=1,jpch_oz
+ if( (.not. first) .and. index(nusis_oz(i), trim(dtype))/=0) then
+ k0=i
+ first=.true.
+ end if
+ if(first.and.index(nusis_oz(i),trim(dtype))/=0) then
+ ikx=ikx+1
+ ipos(ikx)=k0+ikx-1
+ end if
+ end do
+
+ if (ikx/=levs+1) call die(myname_//': inconsistent levs for '//dtype)
+
+ ! Allocate space and read data
+ allocate(iya(nprofs),ima(nprofs),idda(nprofs),ihha(nprofs),imina(nprofs), &
+ iseca(nprofs),slatsa(nprofs),slonsa(nprofs),sza(nprofs),ozone(levs,nprofs))
+ allocate (poz(levs+1))
+
+ call check(nf90_inq_varid(ncid, "lon", lonVarId))
+ call check(nf90_get_var(ncid, lonVarId, slonsa))
+
+ call check(nf90_inq_varid(ncid, "lat", latVarId))
+ call check(nf90_get_var(ncid, latVarId, slatsa))
+
+ call check(nf90_inq_varid(ncid, "yy", yyVarId))
+ call check(nf90_get_var(ncid, yyVarId, iya))
+
+ call check(nf90_inq_varid(ncid, "mm", mmVarId))
+ call check(nf90_get_var(ncid, mmVarId, ima))
+
+ call check(nf90_inq_varid(ncid, "dd", ddVarId))
+ call check(nf90_get_var(ncid, ddVarId, idda))
+
+ call check(nf90_inq_varid(ncid, "hh", hhVarId))
+ call check(nf90_get_var(ncid, hhVarId, ihha))
+
+ call check(nf90_inq_varid(ncid, "min", minVarId))
+ call check(nf90_get_var(ncid, minVarId, imina))
+
+ call check(nf90_inq_varid(ncid, "ss", ssVarId))
+ call check(nf90_get_var(ncid, ssVarId, iseca))
+
+ call check(nf90_inq_varid(ncid, "sza", szaVarId))
+ call check(nf90_get_var(ncid, szaVarId, sza))
+
+ call check(nf90_inq_varid(ncid, "ozone", ozoneVarId))
+ call check(nf90_get_var(ncid, ozoneVarId, ozone))
+
+ ! close the data file
+ call check(nf90_close(ncid))
+
+ ! 'Unpack' the data
+ nmrecs = 0
+ nodata = 0
+ read_loop1: do iprof = 1, nprofs
+ do ilev = 1, levs
+ if (ozone(ilev, iprof) .lt. -900.0_r_kind) cycle ! undefined
+ end do
+!!$ if (iuse_oz(ipos(ilev)) < 0) then
+!!$ usage = 10000._r_kind
+!!$ else
+!!$ usage = zero
+!!$ endif
+ nmrecs=nmrecs+levs+1
+
+ ! convert observation location to radians
+ slons0=slonsa(iprof)
+ slats0=slatsa(iprof)
+ if(abs(slats0)>90._r_kind .or. abs(slons0)>r360) cycle
+ if(slons0< zero) slons0=slons0+r360
+ if(slons0==r360) slons0=zero
+ dlat_earth_deg = slats0
+ dlon_earth_deg = slons0
+ dlat_earth = slats0 * deg2rad
+ dlon_earth = slons0 * deg2rad
+
+ if(regional)then
+ call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)
+ if(outside) cycle
+ else
+ dlat = dlat_earth
+ dlon = dlon_earth
+ call grdcrd1(dlat,rlats,nlat,1)
+ call grdcrd1(dlon,rlons,nlon,1)
+ endif
+
+ idate5(1) = iya(iprof) !year
+ idate5(2) = ima(iprof) !month
+ idate5(3) = idda(iprof) !day
+ idate5(4) = ihha(iprof) !hour
+ idate5(5) = imina(iprof) !minute
+ call w3fs21(idate5,nmind)
+ t4dv=real((nmind-iwinbgn),r_kind)*r60inv
+ if (l4dvar.or.l4densvar) then
+ if (t4dvwinlen) then
+ write(6,*)'read_ozone: ', dtype,' obs time idate5=',idate5,', t4dv=',&
+ t4dv,' is outside time window, sstime=',sstime*r60inv
+ cycle
+ end if
+ else
+ sstime=real(nmind,r_kind)
+ tdiff=(sstime-gstime)*r60inv
+ if(abs(tdiff) > twind)then
+ write(6,*)'read_ozone: ',dtype,' obs time idate5=',idate5,', tdiff=',&
+ tdiff,' is outside time window=',twind
+ cycle
+ end if
+ end if
+
+ !! Compute total ozone
+ totoz=zero
+ do k=1,levs
+ poz(k) = ozone(k,iprof)
+ totoz=totoz+ozone(k,iprof)
+ end do
+ poz(levs+1) = totoz
+
+ !Check ozone layer values. If any layer value is bad, toss entire profile
+ do k=1,levs
+ if (poz(k)>badoz) cycle read_loop1
+ end do
+
+ ! Write ozone record to output file
+ ndata=min(ndata+1,maxobs)
+ if(ndata<=maxobs) then
+ nodata=nodata+levs+1
+ ozout(1,ndata)=rsat
+ ozout(2,ndata)=t4dv
+ ozout(3,ndata)=dlon ! grid relative longitude
+ ozout(4,ndata)=dlat ! grid relative latitude
+ ozout(5,ndata)=dlon_earth_deg ! earth relative longitude (degrees)
+ ozout(6,ndata)=dlat_earth_deg ! earth relative latitude (degrees)
+ ozout(7,ndata)=zero ! total ozone error flag
+ ozout(8,ndata)=zero ! profile ozone error flag
+ ozout(9,ndata)=sza(iprof) ! solar zenith angle
+ do k=1,levs+1
+ ozout(k+9,ndata)=poz(k)
+ end do
+ end if
+ end do read_loop1
+
+ deallocate(iya,ima,idda,ihha,imina,iseca,slatsa,slonsa, ozone, poz,sza)
+ deallocate(ipos)
+ if (ndata > maxobs) then
+ call perr('read_ozone','Number of layer obs reached maxobs = ', maxobs)
+ call perr(myname_,'Number of layer obs reached maxobs = ', maxobs)
+ call perr(myname_,' ndata = ', ndata)
+ call perr(myname_,' nodata = ', nodata)
+ call die(myname_)
+ endif
+
+ end subroutine ozlay_ncread_
!..................................................................................
subroutine check(status,stat)
diff --git a/src/gsi/m_fedNode.F90 b/src/gsi/m_fedNode.F90
new file mode 100644
index 0000000000..84a319cd12
--- /dev/null
+++ b/src/gsi/m_fedNode.F90
@@ -0,0 +1,248 @@
+module m_fedNode
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: module m_fedNode
+! prgmmr: YPW
+! org: CIMMS
+! date: 2019-09-24
+!
+! abstract: class-module of obs-type fedNode (GLM flash extent density)
+! Modified based on m_tdNode.f90
+!
+! program history log:
+! 2019-09-24 YPW - added this document block for the initial polymorphic
+! implementation.
+!
+! input argument list: see Fortran 90 style document below
+!
+! output argument list: see Fortran 90 style document below
+!
+! attributes:
+! language: Fortran 90 and/or above
+! machine:
+!
+!$$$ end subprogram documentation block
+
+! module interface:
+ use m_obsdiagNode, only: obs_diag
+ use m_obsdiagNode, only: obs_diags
+ use kinds , only: i_kind,r_kind
+ use mpeu_util, only: assert_,die,perr,warn,tell
+ use m_obsNode, only: obsNode
+
+ implicit none
+ private
+
+ public:: fedNode
+
+ type,extends(obsNode):: fedNode
+ type(obs_diag), pointer :: diags => NULL()
+ real(r_kind) :: res ! flash extent density residual
+ real(r_kind) :: err2 ! flash extent density error squared
+ real(r_kind) :: raterr2 ! square of ratio of final obs error
+ ! to original obs error
+ real(r_kind) :: b ! variational quality control parameter
+ real(r_kind) :: pg ! variational quality control parameter
+ real(r_kind) :: jb ! variational quality control parameter
+ real(r_kind) :: wij(8) ! horizontal interpolation weights
+ real(r_kind) :: fedpertb ! random number adding to the obs
+ integer(i_kind) :: k1 ! level of errtable 1-33
+ integer(i_kind) :: kx ! ob type
+ integer(i_kind) :: ij(8) ! horizontal locations
+
+ real (r_kind) :: dlev ! reference to the vertical grid
+ contains
+ procedure,nopass:: mytype
+ procedure:: setHop => obsNode_setHop_
+ procedure:: xread => obsNode_xread_
+ procedure:: xwrite => obsNode_xwrite_
+ procedure:: isvalid => obsNode_isvalid_
+ procedure:: gettlddp => gettlddp_
+
+ end type fedNode
+
+ public:: fedNode_typecast
+ public:: fedNode_nextcast
+ interface fedNode_typecast; module procedure typecast_ ; end interface
+ interface fedNode_nextcast; module procedure nextcast_ ; end interface
+
+ public:: fedNode_appendto
+ interface fedNode_appendto; module procedure appendto_ ; end interface
+
+ character(len=*),parameter:: MYNAME="m_fedNode"
+
+#include "myassert.H"
+#include "mytrace.H"
+contains
+function typecast_(aNode) result(ptr_)
+!-- cast a class(obsNode) to a type(tdNode)
+ use m_obsNode, only: obsNode
+ implicit none
+ type(fedNode),pointer:: ptr_
+ class(obsNode),pointer,intent(in):: aNode
+ ptr_ => null()
+ if(.not.associated(aNode)) return
+ select type(aNode)
+ type is(fedNode)
+ ptr_ => aNode
+ end select
+return
+end function typecast_
+
+function nextcast_(aNode) result(ptr_)
+!-- cast an obsNode_next(obsNode) to a type(fedNode)
+ use m_obsNode, only: obsNode,obsNode_next
+ implicit none
+ type(fedNode),pointer:: ptr_
+ class(obsNode),target,intent(in):: aNode
+
+ class(obsNode),pointer:: inode_
+ inode_ => obsNode_next(aNode)
+ ptr_ => typecast_(inode_)
+return
+end function nextcast_
+
+subroutine appendto_(aNode,oll)
+!-- append aNode to linked-list oLL
+ use m_obsNode , only: obsNode
+ use m_obsLList, only: obsLList,obsLList_appendNode
+ implicit none
+ type(fedNode),pointer,intent(in):: aNode
+ type(obsLList),intent(inout):: oLL
+
+ class(obsNode),pointer:: inode_
+ inode_ => aNode
+ call obsLList_appendNode(oLL,inode_)
+ inode_ => null()
+end subroutine appendto_
+
+! obsNode implementations
+
+function mytype()
+ implicit none
+ character(len=:),allocatable:: mytype
+ mytype="[fedNode]"
+end function mytype
+
+
+subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip)
+ use m_obsdiagNode, only: obsdiagLookup_locate
+ implicit none
+ class(fedNode),intent(inout):: aNode
+ integer(i_kind),intent(in ):: iunit
+ integer(i_kind),intent( out):: istat
+ type(obs_diags),intent(in ):: diagLookup
+ logical,optional,intent(in ):: skip
+
+ character(len=*),parameter:: myname_=MYNAME//'.obsNode_xread_'
+ logical:: skip_
+_ENTRY_(myname_)
+ skip_=.false.
+ if(present(skip)) skip_=skip
+
+ istat=0
+ if(skip_) then
+ read(iunit,iostat=istat)
+ if(istat/=0) then
+ call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat)
+ _EXIT_(myname_)
+ return
+ endif
+
+ else
+ read(iunit,iostat=istat) aNode%res , &
+ aNode%err2 , &
+ aNode%raterr2 , &
+ aNode%b , &
+ aNode%pg , &
+ aNode%jb , &
+ aNode%k1 , &
+ aNode%kx , &
+ aNode%dlev , &
+ aNode%wij , &
+ aNode%ij
+ if(istat/=0) then
+ call perr(myname_,'read(%(res,err2,...), iostat =',istat)
+ _EXIT_(myname_)
+ return
+ endif
+
+ aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind)
+ if(.not.associated(aNode%diags)) then
+ call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv)
+ call perr(myname_,' %iob =',aNode%iob)
+ call die(myname_)
+ endif
+ endif
+_EXIT_(myname_)
+return
+end subroutine obsNode_xread_
+
+subroutine obsNode_xwrite_(aNode,junit,jstat)
+ implicit none
+ class(fedNode),intent(in):: aNode
+ integer(i_kind),intent(in ):: junit
+ integer(i_kind),intent( out):: jstat
+
+ character(len=*),parameter:: myname_=MYNAME//'.obsNode_xwrite_'
+_ENTRY_(myname_)
+
+ jstat=0
+ write(junit,iostat=jstat) aNode%res , &
+ aNode%err2 , &
+ aNode%raterr2 , &
+ aNode%b , &
+ aNode%pg , &
+ aNode%jb , &
+ aNode%k1 , &
+ aNode%kx , &
+ aNode%dlev , &
+ aNode%wij , &
+ aNode%ij
+ if(jstat/=0) then
+ call perr(myname_,'write(%res,err2,...), iostat =',jstat)
+ _EXIT_(myname_)
+ return
+ endif
+_EXIT_(myname_)
+return
+end subroutine obsNode_xwrite_
+
+subroutine obsNode_setHop_(aNode)
+ use m_cvgridLookup, only: cvgridLookup_getiw
+ implicit none
+ class(fedNode),intent(inout):: aNode
+
+ character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_'
+_ENTRY_(myname_)
+ call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%dlev,aNode%ij,aNode%wij)
+_EXIT_(myname_)
+return
+end subroutine obsNode_setHop_
+
+function obsNode_isvalid_(aNode) result(isvalid_)
+ implicit none
+ logical:: isvalid_
+ class(fedNode),intent(in):: aNode
+
+ character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_'
+_ENTRY_(myname_)
+ isvalid_=associated(aNode%diags)
+_EXIT_(myname_)
+return
+end function obsNode_isvalid_
+
+pure subroutine gettlddp_(aNode,jiter,tlddp,nob)
+ use kinds, only: r_kind
+ implicit none
+ class(fedNode), intent(in):: aNode
+ integer(kind=i_kind),intent(in):: jiter
+ real(kind=r_kind),intent(inout):: tlddp
+ integer(kind=i_kind),optional,intent(inout):: nob
+
+ tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter)
+ if(present(nob)) nob=nob+1
+return
+end subroutine gettlddp_
+
+end module m_fedNode
diff --git a/src/gsi/m_obsNodeTypeManager.F90 b/src/gsi/m_obsNodeTypeManager.F90
index b5ecc6e1ba..43b42e4bf2 100644
--- a/src/gsi/m_obsNodeTypeManager.F90
+++ b/src/gsi/m_obsNodeTypeManager.F90
@@ -70,6 +70,7 @@ module m_obsNodeTypeManager
use m_lightNode, only: lightNode
use m_dbzNode , only: dbzNode
+ use m_fedNode, only: fedNode
use kinds, only: i_kind
use m_obsNode, only: obsNode
@@ -124,6 +125,7 @@ module m_obsNodeTypeManager
public:: iobsNode_light
public:: iobsNode_dbz
+ public:: iobsNode_fed
public :: obsNode_typeMold
public :: obsNode_typeIndex
@@ -179,6 +181,7 @@ module m_obsNodeTypeManager
type( lwcpNode), target, save:: lwcp_mold
type( lightNode), target, save:: light_mold
type( dbzNode), target, save:: dbz_mold
+ type( fedNode), target, save:: fed_mold
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
character(len=*),parameter :: myname='m_obsNodeTypeManager'
@@ -245,6 +248,7 @@ module m_obsNodeTypeManager
enumerator:: iobsNode_lwcp
enumerator:: iobsNode_light
enumerator:: iobsNode_dbz
+ enumerator:: iobsNode_fed
enumerator:: iobsNode_extra_
end enum
@@ -314,6 +318,7 @@ function vname2index_(vname) result(index_)
case("light","[lightnode]"); index_ = iobsNode_light
case("dbz" , "[dbznode]"); index_ = iobsNode_dbz
+ case("fed" , "[fednode]"); index_ = iobsNode_fed
end select
end function vname2index_
@@ -377,6 +382,7 @@ function vmold2index_select_(mold) result(index_)
type is(lightNode); index_ = iobsNode_light
type is( dbzNode); index_ = iobsNode_dbz
+ type is( fedNode); index_ = iobsNode_fed
end select
end function vmold2index_select_
@@ -434,6 +440,7 @@ function index2vmold_(i_obType) result(obsmold_)
case(iobsNode_light); obsmold_ => light_mold
case(iobsNode_dbz); obsmold_ => dbz_mold
+ case(iobsNode_fed); obsmold_ => fed_mold
end select
end function index2vmold_
diff --git a/src/gsi/m_radNode.F90 b/src/gsi/m_radNode.F90
index 33070e8382..ae4854920a 100644
--- a/src/gsi/m_radNode.F90
+++ b/src/gsi/m_radNode.F90
@@ -57,6 +57,7 @@ module m_radNode
! square root of inverse of R, only used
! if using correlated obs
+ integer(i_kind),dimension(:),pointer :: iccerr => NULL()
integer(i_kind),dimension(:),pointer :: icx => NULL()
integer(i_kind),dimension(:),pointer :: ich => NULL()
integer(i_kind) :: nchan ! number of channels for this profile
@@ -214,6 +215,7 @@ subroutine obsNode_clean_(aNode)
if(associated(aNode%Rpred )) deallocate(aNode%Rpred )
if(associated(aNode%rsqrtinv)) deallocate(aNode%rsqrtinv)
if(associated(aNode%icx )) deallocate(aNode%icx )
+ if(associated(aNode%iccerr )) deallocate(aNode%iccerr )
_EXIT_(myname_)
return
end subroutine obsNode_clean_
@@ -276,6 +278,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip)
if(associated(aNode%Rpred )) deallocate(aNode%Rpred)
if(associated(aNode%rsqrtinv)) deallocate(aNode%rsqrtinv)
if(associated(aNode%icx )) deallocate(aNode%icx )
+ if(associated(aNode%iccerr )) deallocate(aNode%iccerr )
nchan=aNode%nchan
allocate( aNode%diags(nchan), &
@@ -285,7 +288,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip)
aNode%pred (npred,nchan), &
aNode%dtb_dvar(nsigradjac,nchan), &
aNode%ich (nchan), &
- aNode%icx (nchan) )
+ aNode%icx (nchan), aNode%iccerr(nchan) )
read(iunit,iostat=istat) aNode%ich , &
aNode%res , &
@@ -293,6 +296,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip)
aNode%raterr2 , &
aNode%pred , &
aNode%icx , &
+ aNode%iccerr , &
aNode%dtb_dvar, &
aNode%wij , &
aNode%ij
@@ -368,6 +372,7 @@ subroutine obsNode_xwrite_(aNode,junit,jstat)
aNode%raterr2 , &
aNode%pred , &
aNode%icx , &
+ aNode%iccerr , &
aNode%dtb_dvar, &
aNode%wij , &
aNode%ij
diff --git a/src/gsi/m_rhs.F90 b/src/gsi/m_rhs.F90
index baee074688..aea417fe27 100644
--- a/src/gsi/m_rhs.F90
+++ b/src/gsi/m_rhs.F90
@@ -80,6 +80,7 @@ module m_rhs
public:: i_lwcp
public:: i_light
public:: i_dbz
+ public:: i_fed
public:: i_cldtot
public:: awork_size
@@ -146,6 +147,7 @@ module m_rhs
enumerator:: i_lwcp
enumerator:: i_light
enumerator:: i_dbz
+ enumerator:: i_fed
enumerator:: i_cldtot
enumerator:: i_outbound
diff --git a/src/gsi/mod_fv3_lola.f90 b/src/gsi/mod_fv3_lola.f90
index 84f8144968..11bb3b6e37 100644
--- a/src/gsi/mod_fv3_lola.f90
+++ b/src/gsi/mod_fv3_lola.f90
@@ -18,12 +18,17 @@ module mod_fv3_lola
! fv3_ll_to_h
! 2019-11-01 wu - add checks in generate_anl_grid to present the mean
! longitude correctly to fix problem near lon=0
+! 2022-03-01 X.Lu & X.Wang - add functions for HAFS dual ens capability. POC:
+! xuguang.wang@ou.edu
!
! subroutines included:
! sub generate_anl_grid
+! sub definecoef_regular_grids
! sub earthuv2fv3
! sub fv3uv2earth
+! sub fv3uv2earthens
! sub fv3_h_to_ll
+! sub fv3_h_to_ll_ens
! sub fv3_ll_to_h
! sub rotate2deg
! sub unrotate2deg
@@ -65,6 +70,9 @@ module mod_fv3_lola
public :: generate_anl_grid,fv3_h_to_ll,fv3_ll_to_h,fv3uv2earth,earthuv2fv3
public :: fv3dx,fv3dx1,fv3dy,fv3dy1,fv3ix,fv3ixp,fv3jy,fv3jyp,a3dx,a3dx1,a3dy,a3dy1,a3ix,a3ixp,a3jy,a3jyp
public :: nxa,nya,cangu,sangu,cangv,sangv,nx,ny,bilinear
+ public :: definecoef_regular_grids,fv3_h_to_ll_ens,fv3uv2earthens
+ public :: fv3dxens,fv3dx1ens,fv3dyens,fv3dy1ens,fv3ixens,fv3ixpens,fv3jyens,fv3jypens,a3dxens,a3dx1ens,a3dyens,a3dy1ens,a3ixens,a3ixpens,a3jyens,a3jypens
+ public :: nxe,nye,canguens,sanguens,cangvens,sangvens
logical bilinear
integer(i_kind) nxa,nya,nx,ny
@@ -73,6 +81,12 @@ module mod_fv3_lola
real(r_kind) ,allocatable,dimension(:,:):: a3dx,a3dx1,a3dy,a3dy1
real(r_kind) ,allocatable,dimension(:,:):: cangu,sangu,cangv,sangv
integer(i_kind),allocatable,dimension(:,:):: a3ix,a3ixp,a3jy,a3jyp
+ integer(i_kind) nxe,nye
+ real(r_kind) ,allocatable,dimension(:,:):: fv3dxens,fv3dx1ens,fv3dyens,fv3dy1ens
+ integer(i_kind),allocatable,dimension(:,:):: fv3ixens,fv3ixpens,fv3jyens,fv3jypens
+ real(r_kind) ,allocatable,dimension(:,:):: a3dxens,a3dx1ens,a3dyens,a3dy1ens
+ real(r_kind) ,allocatable,dimension(:,:):: canguens,sanguens,cangvens,sangvens
+ integer(i_kind),allocatable,dimension(:,:):: a3ixens,a3ixpens,a3jyens,a3jypens
contains
@@ -321,10 +335,10 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt)
!!!! define analysis A grid !!!!!!!!!!!!!
do j=1,nxa
- xa_a(j)=(float(j-nlonh)-cx)*grid_ratio_fv3_regional
+ xa_a(j)=(real(j-nlonh,r_kind)-cx)*grid_ratio_fv3_regional
end do
do i=1,nya
- ya_a(i)=(float(i-nlath)-cy)*grid_ratio_fv3_regional
+ ya_a(i)=(real(i-nlath,r_kind)-cy)*grid_ratio_fv3_regional
end do
!!!!!compute fv3 to A grid interpolation parameters !!!!!!!!!
@@ -574,8 +588,419 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt)
enddo
enddo
deallocate( xc,yc,zc,gclat,gclon,gcrlat,gcrlon)
+ deallocate(rlat_in,rlon_in)
end subroutine generate_anl_grid
+subroutine definecoef_regular_grids(nxen,nyen,grid_lon,grid_lont,grid_lat,grid_latt)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: generate_??ens_grid
+!clt modified from generate_regular_grid
+! prgmmr: parrish
+!
+! abstract: define rotated lat-lon analysis grid which is centered on fv3 tile
+! and oriented to completely cover the tile.
+!
+! program history log:
+! 2017-05-02 parrish
+! 2017-10-10 wu - 1. setup analysis A-grid,
+! 2. compute/setup FV3 to A grid interpolation parameters
+! 3. compute/setup A to FV3 grid interpolation parameters
+! 4. setup weightings for wind conversion from FV3 to earth
+! 2021-02-01 Lu & Wang - modify variable intent for HAFS dual ens. POC:
+! xuguang.wang@ou.edu
+!
+! input argument list:
+! nxen, nyen - number of cells = nxen*nyen
+! grid_lon ,grid_lat - longitudes and latitudes of fv3 grid cell corners
+! grid_lont,grid_latt - longitudes and latitudes of fv3 grid cell centers
+!
+! output argument list:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+ use kinds, only: r_kind,i_kind
+ use constants, only: quarter,one,two,half,zero,deg2rad,rearth,rad2deg
+ use gridmod, only:grid_ratio_fv3_regional
+ use mpimod, only: mype
+ use hybrid_ensemble_parameters, only: nlon_ens,nlat_ens,region_lon_ens,region_lat_ens
+ implicit none
+ real(r_kind),allocatable,dimension(:)::xbh_a,xa_a,xa_b
+ real(r_kind),allocatable,dimension(:)::ybh_a,ya_a,ya_b,yy
+ real(r_kind),allocatable,dimension(:,:)::xbh_b,ybh_b
+ real(r_kind) dlat,dlon
+
+ real(r_kind),allocatable:: region_lat_tmp(:,:),region_lon_tmp(:,:)
+ integer(i_kind), intent(in ) :: nxen,nyen ! fv3 tile x- and y-dimensions
+ real(r_kind) , intent(inout) :: grid_lon(nxen+1,nyen+1) ! fv3 cell corner longitudes
+ real(r_kind) , intent(inout) :: grid_lont(nxen,nyen) ! fv3 cell center longitudes
+ real(r_kind) , intent(inout) :: grid_lat(nxen+1,nyen+1) ! fv3 cell corner latitudes
+ real(r_kind) , intent(inout) :: grid_latt(nxen,nyen) ! fv3 cell center latitudes
+ integer(i_kind) i,j,ir,jr,n
+ real(r_kind),allocatable,dimension(:,:) :: xc,yc,zc,gclat,gclon,gcrlat,gcrlon,rlon_in,rlat_in
+ real(r_kind) xcent,ycent,zcent,rnorm,centlat,centlon
+ integer(i_kind) nxh,nyh
+ integer(i_kind) ib1,ib2,jb1,jb2,jj
+ integer (i_kind):: index0
+ integer(i_kind) nord_e2a
+ real(r_kind)gxa,gya
+
+ real(r_kind) x(nxen+1,nyen+1),y(nxen+1,nyen+1),z(nxen+1,nyen+1),xr,yr,zr,xu,yu,zu,rlat,rlon
+ real(r_kind) xv,yv,zv,vval
+ real(r_kind) uval,ewval,nsval
+
+ real(r_kind) d(4),ds
+ integer(i_kind) kk,k
+ real(r_kind) diff,sq180
+
+ nord_e2a=4
+ bilinear=.false.
+
+! create xc,yc,zc for the cell centers.
+ allocate(xc(nxen,nyen))
+ allocate(yc(nxen,nyen))
+ allocate(zc(nxen,nyen))
+ allocate(gclat(nxen,nyen))
+ allocate(gclon(nxen,nyen))
+ allocate(gcrlat(nxen,nyen))
+ allocate(gcrlon(nxen,nyen))
+ do j=1,nyen
+ do i=1,nxen
+ xc(i,j)=cos(grid_latt(i,j)*deg2rad)*cos(grid_lont(i,j)*deg2rad)
+ yc(i,j)=cos(grid_latt(i,j)*deg2rad)*sin(grid_lont(i,j)*deg2rad)
+ zc(i,j)=sin(grid_latt(i,j)*deg2rad)
+ enddo
+ enddo
+
+! compute center as average x,y,z coordinates of corners of domain --
+
+ xcent=quarter*(xc(1,1)+xc(1,nyen)+xc(nxen,1)+xc(nxen,nyen))
+ ycent=quarter*(yc(1,1)+yc(1,nyen)+yc(nxen,1)+yc(nxen,nyen))
+ zcent=quarter*(zc(1,1)+zc(1,nyen)+zc(nxen,1)+zc(nxen,nyen))
+
+ rnorm=one/sqrt(xcent**2+ycent**2+zcent**2)
+ xcent=rnorm*xcent
+ ycent=rnorm*ycent
+ zcent=rnorm*zcent
+ centlat=asin(zcent)*rad2deg
+ centlon=atan2(ycent,xcent)*rad2deg
+
+!! compute new lats, lons
+ call rotate2deg(grid_lont,grid_latt,gcrlon,gcrlat, &
+ centlon,centlat,nxen,nyen)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! compute analysis A-grid lats, lons
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!--------------------------obtain analysis grid dimensions nxe,nye
+ nxe=nlon_ens
+ nye=nlat_ens
+ if(mype==0) print *,'nlat,nlon=nye,nxe= ',nlat_ens,nlon_ens
+
+ allocate(rlat_in(nlat_ens,nlon_ens),rlon_in(nlat_ens,nlon_ens))
+ allocate(region_lon_tmp(nlat_ens,nlon_ens),region_lat_tmp(nlat_ens,nlon_ens))
+ region_lon_tmp=region_lon_ens*rad2deg
+ region_lat_tmp=region_lat_ens*rad2deg
+ call rotate2deg(region_lon_tmp,region_lat_tmp,rlon_in,rlat_in, &
+ centlon,centlat,nlat_ens,nlon_ens)
+
+!--------------------------obtain analysis grid spacing
+ dlat=(maxval(gcrlat)-minval(gcrlat))/(nyen-1)
+ dlon=(maxval(gcrlon)-minval(gcrlon))/(nxen-1)
+
+
+!-----setup analysis A-grid from center of the domain
+!--------------------compute all combinations of relative coordinates
+
+ allocate(xbh_a(nxen),xbh_b(nxen,nyen),xa_a(nxe),xa_b(nxe))
+ allocate(ybh_a(nyen),ybh_b(nxen,nyen),ya_a(nye),ya_b(nye))
+
+ nxh=nxen/2
+ nyh=nyen/2
+
+
+!!!!!! fv3 rotated grid; not equal spacing, non_orthogonal !!!!!!
+ do j=1,nyen
+ jr=nyen+1-j
+ do i=1,nxen
+ ir=nxen+1-i
+ xbh_b(ir,jr)=gcrlon(i,j)/dlon
+ end do
+ end do
+ do j=1,nyen
+ jr=nyen+1-j
+ do i=1,nxen
+ ir=nxen+1-i
+ ybh_b(ir,jr)=gcrlat(i,j)/dlat
+ end do
+ end do
+
+!!!! define analysis A grid !!!!!!!!!!!!!
+
+ index0=1
+ do j=1,nxe
+ xa_a(j)= rlon_in(index0,j)/dlon
+ end do
+ do i=1,nye
+ ya_a(i)= rlat_in(i,index0)/dlat
+ end do
+
+!!!!!compute fv3 to A grid interpolation parameters !!!!!!!!!
+ allocate (fv3dxens(nxe,nye),fv3dx1ens(nxe,nye),fv3dyens(nxe,nye),fv3dy1ens(nxe,nye))
+ allocate (fv3ixens(nxe,nye),fv3ixpens(nxe,nye),fv3jyens(nxe,nye),fv3jypens(nxe,nye))
+ allocate(yy(nyen))
+
+! iteration to find the fv3 grid cell
+ jb1=1
+ ib1=1
+ do j=1,nye
+ do i=1,nxe
+ do n=1,3
+ gxa=xa_a(i)
+ if(gxa < xbh_b(1,jb1))then
+ gxa= 1
+ else if(gxa > xbh_b(nxen,jb1))then
+ gxa= nxen
+ else
+ call grdcrd1(gxa,xbh_b(1,jb1),nxen,1)
+ endif
+ ib2=ib1
+ ib1=gxa
+ do jj=1,nyen
+ yy(jj)=ybh_b(ib1,jj)
+ enddo
+ gya=ya_a(j)
+ if(gya < yy(1))then
+ gya= 1
+ else if(gya > yy(nyen))then
+ gya= nyen
+ else
+ call grdcrd1(gya,yy,nyen,1)
+ endif
+ jb2=jb1
+ jb1=gya
+ if(ib1+1 > nxen)then !this block( 6 lines) is copied from GSL gsi repository
+ ib1=ib1-1
+ endif
+ if(jb1+1 > nyen)then
+ jb1=jb1-1
+ endif
+
+ if((ib1 == ib2) .and. (jb1 == jb2)) exit
+ if(n==3 ) then
+!!!!!!! if not converge, find the nearest corner point
+ d(1)=(xa_a(i)-xbh_b(ib1,jb1))**2+(ya_a(j)-ybh_b(ib1,jb1))**2
+ d(2)=(xa_a(i)-xbh_b(ib1+1,jb1))**2+(ya_a(j)-ybh_b(ib1+1,jb1))**2
+ d(3)=(xa_a(i)-xbh_b(ib1,jb1+1))**2+(ya_a(j)-ybh_b(ib1,jb1+1))**2
+ d(4)=(xa_a(i)-xbh_b(ib1+1,jb1+1))**2+(ya_a(j)-ybh_b(ib1+1,jb1+1))**2
+ kk=1
+ do k=2,4
+ if(d(k) xa_a(nxe))then
+ gxa= nxe
+ else
+ call grdcrd1(gxa,xa_a,nxe,1)
+ endif
+ a3ixens(j,i)=int(gxa)
+ a3ixens(j,i)=min(max(1,a3ixens(j,i)),nxe)
+ a3dxens(j,i)=max(zero,min(one,gxa-a3ixens(j,i)))
+ a3dx1ens(j,i)=one-a3dxens(j,i)
+ a3ixpens(j,i)=min(nxe,a3ixens(j,i)+1)
+ end do
+ end do
+
+ do i=1,nxen
+ do j=1,nyen
+ gya=ybh_b(i,j)
+ if(gya < ya_a(1))then
+ gya= 1
+ else if(gya > ya_a(nye))then
+ gya= nye
+ else
+ call grdcrd1(gya,ya_a,nye,1)
+ endif
+ a3jyens(j,i)=int(gya)
+ a3jyens(j,i)=min(max(1,a3jyens(j,i)),nye)
+ a3dyens(j,i)=max(zero,min(one,gya-a3jyens(j,i)))
+ a3dy1ens(j,i)=one-a3dyens(j,i)
+ a3jypens(j,i)=min(nye,a3jyens(j,i)+1)
+ end do
+ end do
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!! find coefficients for wind conversion btw FV3 & earth
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ allocate (canguens(nxen,nyen+1),sanguens(nxen,nyen+1),cangvens(nxen+1,nyen),sangvens(nxen+1,nyen))
+
+! 1. compute x,y,z at cell cornor from grid_lon, grid_lat
+
+ do j=1,nyen+1
+ do i=1,nxen+1
+ x(i,j)=cos(grid_lat(i,j)*deg2rad)*cos(grid_lon(i,j)*deg2rad)
+ y(i,j)=cos(grid_lat(i,j)*deg2rad)*sin(grid_lon(i,j)*deg2rad)
+ z(i,j)=sin(grid_lat(i,j)*deg2rad)
+ enddo
+ enddo
+
+! 2 find angles to E-W and N-S for U edges
+
+ sq180=180._r_kind**2
+ do j=1,nyen+1
+ do i=1,nxen
+! center lat/lon of the edge
+ rlat=half*(grid_lat(i,j)+grid_lat(i+1,j))
+ diff=(grid_lon(i,j)-grid_lon(i+1,j))**2
+ if(diff < sq180)then
+ rlon=half*(grid_lon(i,j)+grid_lon(i+1,j))
+ else
+ rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)-360._r_kind)
+ endif
+! vector to center of the edge
+ xr=cos(rlat*deg2rad)*cos(rlon*deg2rad)
+ yr=cos(rlat*deg2rad)*sin(rlon*deg2rad)
+ zr=sin(rlat*deg2rad)
+! vector of the edge
+ xu= x(i+1,j)-x(i,j)
+ yu= y(i+1,j)-y(i,j)
+ zu= z(i+1,j)-z(i,j)
+! find angle with cross product
+ uval=sqrt((xu**2+yu**2+zu**2))
+ ewval=sqrt((xr**2+yr**2))
+ nsval=sqrt((xr*zr)**2+(zr*yr)**2+(xr*xr+yr*yr)**2)
+ canguens(i,j)=(-yr*xu+xr*yu)/ewval/uval
+ sanguens(i,j)=(-xr*zr*xu-zr*yr*yu+(xr*xr+yr*yr)*zu) / nsval/uval
+ enddo
+ enddo
+
+! 3 find angles to E-W and N-S for V edges
+ do j=1,nyen
+ do i=1,nxen+1
+ rlat=half*(grid_lat(i,j)+grid_lat(i,j+1))
+ diff=(grid_lon(i,j)-grid_lon(i,j+1))**2
+ if(diff < sq180)then
+ rlon=half*(grid_lon(i,j)+grid_lon(i,j+1))
+ else
+ rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)-360._r_kind)
+ endif
+ xr=cos(rlat*deg2rad)*cos(rlon*deg2rad)
+ yr=cos(rlat*deg2rad)*sin(rlon*deg2rad)
+ zr=sin(rlat*deg2rad)
+ xv= x(i,j+1)-x(i,j)
+ yv= y(i,j+1)-y(i,j)
+ zv= z(i,j+1)-z(i,j)
+ vval=sqrt((xv**2+yv**2+zv**2))
+ ewval=sqrt((xr**2+yr**2))
+ nsval=sqrt((xr*zr)**2+(zr*yr)**2+(xr*xr+yr*yr)**2)
+ cangvens(i,j)=(-yr*xv+xr*yv)/ewval/vval
+ sangvens(i,j)=(-xr*zr*xv-zr*yr*yv+(xr*xr+yr*yr)*zv) / nsval/vval
+ enddo
+ enddo
+ deallocate( xc,yc,zc,gclat,gclon,gcrlat,gcrlon)
+ deallocate(rlat_in,rlon_in)
+end subroutine definecoef_regular_grids
+
subroutine earthuv2fv3(u,v,nx,ny,u_out,v_out)
!$$$ subprogram documentation block
! . . . .
@@ -679,6 +1104,51 @@ subroutine fv3uv2earth(u,v,nx,ny,u_out,v_out)
return
end subroutine fv3uv2earth
+subroutine fv3uv2earthens(u,v,nxen,nyen,u_out,v_out)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: fv3uv2earthens
+! prgmmr: wu 2017-06-15
+!
+! abstract: project fv3 UV to earth UV and interpolate to the center of the
+! cells
+!
+! program history log:
+!
+!
+! input argument list:
+! u,v - fv3 winds on the cell boundaries
+! nx,ny - dimensions
+!
+! output argument list:
+! u_out,v_out - output earth wind components at center of the cell
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+ use kinds, only: r_kind,i_kind
+ use constants, only: half
+ implicit none
+
+ integer(i_kind), intent(in ) :: nxen,nyen ! fv3 tile x- and y-dimensions
+ real(r_kind),intent(in ) :: u(nxen,nyen+1),v(nxen+1,nyen)
+ real(r_kind),intent( out) :: u_out(nxen,nyen),v_out(nxen,nyen)
+ integer(i_kind) i,j
+
+ do j=1,nyen
+ do i=1,nxen
+ u_out(i,j)=half *((u(i,j)*sangvens(i,j)-v(i,j)*sanguens(i,j))/(canguens(i,j)*sangvens(i,j)-sanguens(i,j)*cangvens(i,j)) &
+ +(u(i,j+1)*sangvens(i+1,j)-v(i+1,j)*sanguens(i,j+1))/(canguens(i,j+1)*sangvens(i+1,j)-sanguens(i,j+1)*cangvens(i+1,j)))
+ v_out(i,j)=half *((u(i,j)*cangvens(i,j)-v(i,j)*canguens(i,j))/(sanguens(i,j)*cangvens(i,j)-canguens(i,j)*sangvens(i,j)) &
+ +(u(i,j+1)*cangvens(i+1,j)-v(i+1,j)*canguens(i,j+1))/(sanguens(i,j+1)*cangvens(i+1,j)-canguens(i,j+1)*sangvens(i+1,j)))
+ end do
+ end do
+ return
+end subroutine fv3uv2earthens
+
subroutine fv3_h_to_ll(b_in,a,nb,mb,na,ma,rev_flg)
!$$$ subprogram documentation block
! . . . .
@@ -753,6 +1223,85 @@ subroutine fv3_h_to_ll(b_in,a,nb,mb,na,ma,rev_flg)
return
end subroutine fv3_h_to_ll
+subroutine fv3_h_to_ll_ens(b_in,a,nb,mb,na,ma,rev_flg)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: fv3_h_to_ll
+! prgmmr: wu 2017-05-30
+!
+! abstract: interpolate from rotated fv3 grid to A grid.
+! Interpolation choices 1)bilinear both ways
+! 2)inverse-distance weighting average
+! reverse E-W and N-S directions & reverse i,j for output array a(nlat,nlon)
+!
+! program history log:
+!
+!
+! input argument list:
+! mb,nb - fv3 dimensions
+! ma,na - a dimensions
+! b - input variable b
+! xb,yb - b array x and y coordinates
+! xa,ya - a array coordinates (xa in xb units, ya in yb units)
+!
+! output argument list:
+! a - output interpolated array
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+ use constants, only: zero,one
+ implicit none
+
+ integer(i_kind),intent(in ) :: mb,nb,ma,na
+ real(r_kind) ,intent(in ) :: b_in(nb,mb)
+ logical ,intent(in ) :: rev_flg
+ real(r_kind) ,intent( out) :: a(ma,na)
+
+ integer(i_kind) i,j,ir,jr,mbp,nbp
+ real(r_kind) b(nb,mb)
+
+ mbp=mb+1
+ nbp=nb+1
+ bilinear=.false.
+ if(rev_flg) then
+!!!!!!!!! reverse E-W and N-S
+ do j=1,mb
+ jr=mbp-j
+ do i=1,nb
+ ir=nbp-i
+ b(ir,jr)=b_in(i,j)
+ end do
+ end do
+ else
+ b(:,:)=b_in(:,:)
+ endif
+!!!!!!!!! interpolate to A grid & reverse ij for array a(lat,lon)
+ if(bilinear)then ! bilinear interpolation
+ do j=1,ma
+ do i=1,na
+ a(j,i)=fv3dx1ens(i,j)*(fv3dy1ens(i,j)*b(fv3ixens(i,j),fv3jyens(i,j)) &
+ +fv3dyens(i,j)*b(fv3ixens(i,j),fv3jypens(i,j))) &
+ +fv3dxens(i,j)*(fv3dy1ens(i,j)*b(fv3ixpens(i,j),fv3jyens(i,j)) &
+ +fv3dyens(i,j)*b(fv3ixpens(i,j),fv3jypens(i,j)))
+ end do
+ end do
+ else ! inverse-distance weighting average
+ do j=1,ma
+ do i=1,na
+ a(j,i)=fv3dxens(i,j)*b(fv3ixens(i,j),fv3jyens(i,j)) &
+ +fv3dyens(i,j)*b(fv3ixens(i,j),fv3jypens(i,j)) &
+ +fv3dx1ens(i,j)*b(fv3ixpens(i,j),fv3jyens(i,j)) &
+ +fv3dy1ens(i,j)*b(fv3ixpens(i,j),fv3jypens(i,j))
+ end do
+ end do
+ endif
+
+ return
+end subroutine fv3_h_to_ll_ens
+
subroutine fv3_ll_to_h(a,b,nxa,nya,nxb,nyb,rev_flg)
!$$$ subprogram documentation block
! . . . .
diff --git a/src/gsi/mod_vtrans.f90 b/src/gsi/mod_vtrans.f90
index 3c7d8af8f4..f9538e0735 100644
--- a/src/gsi/mod_vtrans.f90
+++ b/src/gsi/mod_vtrans.f90
@@ -269,7 +269,7 @@ subroutine create_vtrans(mype)
! count:
! Not clear if area weighting would be better.
- count=one/float(nlat*nlon)
+ count=one/real(nlat*nlon,r_kind)
ier=0
call gsi_bundlegetpointer (gsi_metguess_bundle(ntguessig),'ps',ges_ps_nt, istatus)
diff --git a/src/gsi/mod_wrfmass_to_a.f90 b/src/gsi/mod_wrfmass_to_a.f90
index 716ff37f77..594f128709 100644
--- a/src/gsi/mod_wrfmass_to_a.f90
+++ b/src/gsi/mod_wrfmass_to_a.f90
@@ -312,7 +312,7 @@ subroutine wrfmass_obs_to_a8(obsba,nreal,maxobs,ilat,ilon,numobs)
i=int(ria(n)+0.5_r_kind)
j=int(rja(n)+0.5_r_kind)
- adist=(ria(n)-float(i))*(ria(n)-float(i))+(rja(n)-float(j))*(rja(n)-float(j))
+ adist=(ria(n)-real(i,r_kind))**2+(rja(n)-real(j,r_kind))**2
if(adist < dist(i,j)) then
dist(i,j)=adist
ija(i,j)=n
@@ -324,8 +324,8 @@ subroutine wrfmass_obs_to_a8(obsba,nreal,maxobs,ilat,ilon,numobs)
do i=1,nxa
if(ija(i,j) > 0) then
n=n+1
- obsba(ilon,n)=float(i)
- obsba(ilat,n)=float(j)
+ obsba(ilon,n)=real(i,r_kind)
+ obsba(ilat,n)=real(j,r_kind)
do k=3,nreal
obsba(k,n)=obsa(k,ija(i,j))
enddo
diff --git a/src/gsi/mp_compact_diffs_mod1.f90 b/src/gsi/mp_compact_diffs_mod1.f90
index bb924441b7..292986a56a 100644
--- a/src/gsi/mp_compact_diffs_mod1.f90
+++ b/src/gsi/mp_compact_diffs_mod1.f90
@@ -1550,8 +1550,8 @@ subroutine mp_compact_dlon(b,dbdx,vector)
polu=polu+grid3(ix)*coslon(ix)
polv=polv+grid3(ix)*sinlon(ix)
end do
- polu=polu/float(nlon)
- polv=polv/float(nlon)
+ polu=polu/real(nlon,r_kind)
+ polv=polv/real(nlon,r_kind)
do ix=1,nlon
grid3pol(ix)=polu*coslon(ix)+polv*sinlon(ix)
end do
@@ -1673,8 +1673,8 @@ subroutine mp_compact_dlon_ad(b,dbdx,vector)
polu=polu+grid3pol(ix)*coslon(ix)
polv=polv+grid3pol(ix)*sinlon(ix)
end do
- polu=polu/float(nlon)
- polv=polv/float(nlon)
+ polu=polu/real(nlon,r_kind)
+ polv=polv/real(nlon,r_kind)
do ix=1,nlon
grid3(ix)=grid3(ix)+polu*coslon(ix)+polv*sinlon(ix)
end do
@@ -1977,8 +1977,8 @@ subroutine mp_uv_pole(u,v)
polsu=polsu+u(2,ix,k)*coslon(ix)+v(2,ix,k)*sinlon(ix)
polsv=polsv+u(2,ix,k)*sinlon(ix)-v(2,ix,k)*coslon(ix)
end do
- polsu=polsu/float(nlon)
- polsv=polsv/float(nlon)
+ polsu=polsu/real(nlon,r_kind)
+ polsv=polsv/real(nlon,r_kind)
do ix=1,nlon
u(1,ix,k)=polsu*coslon(ix)+polsv*sinlon(ix)
v(1,ix,k)=polsu*sinlon(ix)-polsv*coslon(ix)
@@ -1993,8 +1993,8 @@ subroutine mp_uv_pole(u,v)
polnu=polnu+u(1,ix,k)*coslon(ix)-v(1,ix,k)*sinlon(ix)
polnv=polnv+u(1,ix,k)*sinlon(ix)+v(1,ix,k)*coslon(ix)
end do
- polnu=polnu/float(nlon)
- polnv=polnv/float(nlon)
+ polnu=polnu/real(nlon,r_kind)
+ polnv=polnv/real(nlon,r_kind)
do ix=1,nlon
u(2,ix,k)= polnu*coslon(ix)+polnv*sinlon(ix)
v(2,ix,k)=-polnu*sinlon(ix)+polnv*coslon(ix)
@@ -2055,8 +2055,8 @@ subroutine mp_uv_pole_ad(u,v)
u(1,ix,k)=zero
v(1,ix,k)=zero
end do
- polsu=polsu/float(nlon)
- polsv=polsv/float(nlon)
+ polsu=polsu/real(nlon,r_kind)
+ polsv=polsv/real(nlon,r_kind)
do ix=1,nlon
u(2,ix,k)=u(2,ix,k)+polsu*coslon(ix)+polsv*sinlon(ix)
v(2,ix,k)=v(2,ix,k)+polsu*sinlon(ix)-polsv*coslon(ix)
@@ -2073,8 +2073,8 @@ subroutine mp_uv_pole_ad(u,v)
u(2,ix,k)=zero
v(2,ix,k)=zero
end do
- polnu=polnu/float(nlon)
- polnv=polnv/float(nlon)
+ polnu=polnu/real(nlon,r_kind)
+ polnv=polnv/real(nlon,r_kind)
do ix=1,nlon
u(1,ix,k)=u(1,ix,k)+polnu*coslon(ix)+polnv*sinlon(ix)
v(1,ix,k)=v(1,ix,k)-polnu*sinlon(ix)+polnv*coslon(ix)
diff --git a/src/gsi/mpeu_util.F90 b/src/gsi/mpeu_util.F90
index 960af8b71a..76271a4770 100644
--- a/src/gsi/mpeu_util.F90
+++ b/src/gsi/mpeu_util.F90
@@ -553,22 +553,6 @@ subroutine close_if_(fname,stat)
endif
end subroutine close_if_
-#ifdef _NEW_CODE_
-!! need to send outputs to variables.
-!! need to set return code (stat=).
-subroutine ls_(files) ! show information? or just inquire(exists(file))
- call system("ls "//files)
-end subroutine ls_
-subroutine rm_(files) ! delete, open();close(status='delete')
- call system("rm "//files)
-end subroutine rm_
-subroutine mkdir_(dir,mode,parents)
- call system("mkdir "//files)
-end subroutine mkdir_
-subroutine size_(file) ! faster access?
- call system("wc -c "//files)
-end subroutine size_
-#endif
#endif
function myid_(who)
diff --git a/src/gsi/ncepgfs_ghg.f90 b/src/gsi/ncepgfs_ghg.f90
index 6c5fa7bb9d..9b34d8aa6e 100644
--- a/src/gsi/ncepgfs_ghg.f90
+++ b/src/gsi/ncepgfs_ghg.f90
@@ -326,7 +326,7 @@ subroutine read_gfsco2 &
do i=1,nmxlon
co2diff= co2_sav2(i,j,k)-co2_sav1(i,j,k)
co2rate= co2diff/ndmax
- co2_Tintrp(i,j,k)= co2_sav1(i,j,k)+ co2rate*float(idd-1)
+ co2_Tintrp(i,j,k)= co2_sav1(i,j,k)+ co2rate*real(idd-1,r_kind)
enddo
enddo
enddo
@@ -558,7 +558,7 @@ subroutine read_ch4n2oco &
do i=1,nmaxlon
ghgdiff= ghg_sav2(1,j,k)-ghg_sav1(1,j,k)
ghgrate= ghgdiff/ndmax
- ghg_Tintrp(1,j,k)= ghg_sav1(1,j,k)+ ghgrate*float(idd-1)
+ ghg_Tintrp(1,j,k)= ghg_sav1(1,j,k)+ ghgrate*real(idd-1,r_kind)
enddo
enddo
enddo
diff --git a/src/gsi/ncepgfs_io.f90 b/src/gsi/ncepgfs_io.f90
index 52dcc4e1b5..dd46916039 100644
--- a/src/gsi/ncepgfs_io.f90
+++ b/src/gsi/ncepgfs_io.f90
@@ -1440,7 +1440,7 @@ subroutine write_gfs(increment,mype_atm,mype_sfc)
if ( use_gfs_nemsio ) then
if ( write_fv3_incr ) then
- call write_fv3_increment(grd_a,sp_a,filename,mype_atm, &
+ call write_fv3_increment(grd_a,filename,mype_atm, &
atm_bundle,itoutsig)
else
if (fv3_full_hydro) then
@@ -1461,7 +1461,7 @@ subroutine write_gfs(increment,mype_atm,mype_sfc)
else if ( use_gfs_ncio ) then
if ( write_fv3_incr ) then
- call write_fv3_increment(grd_a,sp_a,filename,mype_atm, &
+ call write_fv3_increment(grd_a,filename,mype_atm, &
atm_bundle,itoutsig)
else
call write_gfsncatm(grd_a,sp_a,filename,mype_atm, &
@@ -2640,9 +2640,9 @@ subroutine write_ens_sfc_nst(mype_so,dsfct)
allocate(slatx(jmax),wlatx(jmax))
allocate(rlats_ens_sfc(nlat_ens_sfc),rlons_ens_sfc(nlon_ens_sfc))
call splat(4,jmax,slatx,wlatx)
- dlon=two*pi/float(nlon_ens_sfc)
+ dlon=two*pi/real(nlon_ens_sfc,r_kind)
do i=1,nlon_ens_sfc
- rlons_ens_sfc(i)=float(i-1)*dlon
+ rlons_ens_sfc(i)=real(i-1,r_kind)*dlon
end do
do i=1,(nlat_ens_sfc-1)/2
rlats_ens_sfc(i+1)=-asin(slatx(i))
@@ -3074,9 +3074,9 @@ subroutine write_ens_dsfct(mype_so,dsfct)
allocate(slatx(jmax),wlatx(jmax))
allocate(rlats_ens_sfc(nlat_ens_sfc),rlons_ens_sfc(nlon_ens_sfc))
call splat(4,jmax,slatx,wlatx)
- dlon=two*pi/float(nlon_ens_sfc)
+ dlon=two*pi/real(nlon_ens_sfc,r_kind)
do i=1,nlon_ens_sfc
- rlons_ens_sfc(i)=float(i-1)*dlon
+ rlons_ens_sfc(i)=real(i-1,r_kind)*dlon
end do
do i=1,(nlat_ens_sfc-1)/2
rlats_ens_sfc(i+1)=-asin(slatx(i))
@@ -3247,7 +3247,7 @@ subroutine glbave(fld,ave)
enddo
enddo
enddo
- xave=xave/(two_quad*float(nlon))
+ xave=xave/(two_quad*real(nlon,r_quad))
call mpl_allreduce(size(ave,1),qpvals=xave)
ave=xave
deallocate(xave)
diff --git a/src/gsi/ncepnems_io.f90 b/src/gsi/ncepnems_io.f90
index 73f06ffd07..595f07e152 100755
--- a/src/gsi/ncepnems_io.f90
+++ b/src/gsi/ncepnems_io.f90
@@ -82,7 +82,8 @@ module ncepnems_io
! nfsecondn FCST Secs (i_kind) numerator
! nfsecondd FCST Secs (i_kind) denominator
!
-! %fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+! %fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+! real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
!
! nframe - nframe is the number of grids extend outward from the
! edge of modeling domain.
@@ -835,7 +836,8 @@ subroutine read_atm_ (grd,filename,sp_a,uvflag,vordivflag,zflag, &
call stop2(101)
end if
- fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
odate(3) = idate(3) !day
@@ -1300,7 +1302,8 @@ subroutine read_sfc_(sfct,soil_moi,sno,soil_temp,veg_frac,fact10,sfc_rough, &
call stop2(102)
end if
- fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
odate(3) = idate(3) !day
@@ -1699,7 +1702,8 @@ subroutine read_sfc_anl_(isli_anl)
call stop2(102)
end if
- fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
odate(3) = idate(3) !day
@@ -2029,7 +2033,8 @@ subroutine read_nst_ (tref,dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d)
call stop2(istop)
end if
- fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
odate(1) = idate(4) !hour
odate(2) = idate(2) !month
odate(3) = idate(3) !day
@@ -5469,8 +5474,8 @@ subroutine tran_gfssfc(ain,aout,lonb,latb)
sumn = ain(i,1) + sumn
sums = ain(i,latb) + sums
end do
- sumn = sumn/float(lonb)
- sums = sums/float(lonb)
+ sumn = sumn/real(lonb,r_kind)
+ sums = sums/real(lonb,r_kind)
! Transfer from local work array to surface guess array
do j = 1,lonb
aout(1,j)=sums
diff --git a/src/gsi/netcdfgfs_io.f90 b/src/gsi/netcdfgfs_io.f90
index ce32e13554..8aa6c4cc6a 100644
--- a/src/gsi/netcdfgfs_io.f90
+++ b/src/gsi/netcdfgfs_io.f90
@@ -105,6 +105,7 @@ subroutine read_
!
! program history log:
! 2019-09-24 Martin - create routine based on read_nems
+! 2022-03-23 Draper - add option to include T2m and q2m in MetGuess
!
! input argument list:
!
@@ -129,6 +130,7 @@ subroutine read_
use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info,general_sub2grid_destroy_info
use mpimod, only: npe,mype
use cloud_efr_mod, only: cloud_calc_gfs,set_cloud_lower_bound
+ use jfunc, only: hofx_2m_sfcfile
use gridmod, only: fv3_full_hydro
implicit none
@@ -141,6 +143,8 @@ subroutine read_
real(r_kind),pointer,dimension(:,: ):: ges_ps_it =>NULL()
real(r_kind),pointer,dimension(:,: ):: ges_z_it =>NULL()
+ real(r_kind),pointer,dimension(:,: ):: ges_t2m_it =>NULL()
+ real(r_kind),pointer,dimension(:,: ):: ges_q2m_it =>NULL()
real(r_kind),pointer,dimension(:,:,:):: ges_u_it =>NULL()
real(r_kind),pointer,dimension(:,:,:):: ges_v_it =>NULL()
real(r_kind),pointer,dimension(:,:,:):: ges_div_it =>NULL()
@@ -164,8 +168,10 @@ subroutine read_
type(gsi_grid) :: atm_grid
integer(i_kind),parameter :: n2d=2
! integer(i_kind),parameter :: n3d=8
+ integer(i_kind),parameter :: n2d_2m=4
integer(i_kind),parameter :: n3d=14
character(len=4), parameter :: vars2d(n2d) = (/ 'z ', 'ps ' /)
+ character(len=4), parameter :: vars2d_with2m(n2d_2m) = (/ 'z ', 'ps ','t2m ','q2m ' /)
! character(len=4), parameter :: vars3d(n3d) = (/ 'u ', 'v ', &
! 'vor ', 'div ', &
! 'tv ', 'q ', &
@@ -189,8 +195,11 @@ subroutine read_
! Allocate bundle used for reading members
call gsi_gridcreate(atm_grid,lat2,lon2,nsig)
-
- call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d,names3d=vars3d)
+ if (hofx_2m_sfcfile) then
+ call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d_with2m,names3d=vars3d)
+ else
+ call gsi_bundlecreate(atm_bundle,atm_grid,'aux-atm-read',istatus,names2d=vars2d,names3d=vars3d)
+ endif
if(istatus/=0) then
write(6,*) myname_,': trouble creating atm_bundle'
call stop2(999)
@@ -198,9 +207,15 @@ subroutine read_
do it=1,nfldsig
- write(filename,'(''sigf'',i2.2)') ifilesig(it)
-
! Read background fields into bundle
+ if (hofx_2m_sfcfile) then
+ if (mype==0) write(*,*) 'calling general_read_gfsatm_nc for 2m data', it
+ write(filename,'(''sfcf'',i2.2)') ifilesig(it)
+ call general_read_gfsatm_nc(grd_t,sp_a,filename,.true.,.true.,.true.,&
+ atm_bundle,.true.,istatus)
+ if (mype==0) write(*,*) 'done with general_read_gfsatm_nc for 2m data', it
+ end if
+ write(filename,'(''sigf'',i2.2)') ifilesig(it)
if (fv3_full_hydro) then
if (mype==0) write(*,*) 'calling general_read_gfsatm_allhydro_nc', it
call general_read_gfsatm_allhydro_nc(grd_t,sp_a,filename,.true.,.true.,.true.,&
@@ -273,6 +288,16 @@ subroutine set_guess_
call gsi_bundlegetpointer (gsi_metguess_bundle(it),'z' ,ges_z_it ,istatus)
if(istatus==0) ges_z_it = ptr2d
endif
+ call gsi_bundlegetpointer (atm_bundle,'t2m',ptr2d,istatus)
+ if (istatus==0) then
+ call gsi_bundlegetpointer (gsi_metguess_bundle(it),'t2m' ,ges_t2m_it ,istatus)
+ if(istatus==0) ges_t2m_it = ptr2d
+ endif
+ call gsi_bundlegetpointer (atm_bundle,'q2m',ptr2d,istatus)
+ if (istatus==0) then
+ call gsi_bundlegetpointer (gsi_metguess_bundle(it),'q2m' ,ges_q2m_it ,istatus)
+ if(istatus==0) ges_q2m_it = ptr2d
+ endif
call gsi_bundlegetpointer (atm_bundle,'u',ptr3d,istatus)
if (istatus==0) then
call gsi_bundlegetpointer (gsi_metguess_bundle(it),'u' ,ges_u_it ,istatus)
@@ -1300,7 +1325,7 @@ subroutine read_sfc_anl_(isli_anl)
! open the netCDF file
sfcges = open_dataset(filename,errcode=iret)
if (iret/=0) then
- write(6,*) trim(my_name),': ***ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS'
+ write(6,*) trim(my_name),': ***FATAL ERROR*** ',trim(filename),' NOT AVAILABLE: PROGRAM STOPS'
call stop2(999)
endif
@@ -3177,8 +3202,8 @@ subroutine tran_gfsncsfc(ain,aout,lonb,latb)
sumn = ain(i,1) + sumn
sums = ain(i,latb) + sums
end do
- sumn = sumn/float(lonb)
- sums = sums/float(lonb)
+ sumn = sumn/real(lonb,r_kind)
+ sums = sums/real(lonb,r_kind)
! Transfer from local work array to surface guess array
do j = 1,lonb
aout(1,j)=sums
diff --git a/src/gsi/nlmsas_ad.f90 b/src/gsi/nlmsas_ad.f90
index be8213b340..7ad413aa6b 100644
--- a/src/gsi/nlmsas_ad.f90
+++ b/src/gsi/nlmsas_ad.f90
@@ -707,10 +707,10 @@ subroutine nlmsas_ad_im_ix_(im,ix,km,jcap,delt,del,sl,rcs,&
pdpdwn = zero
pdetrn = 200._r_kind
xlambu = 1.e-4_r_kind
- fjcap = (float(jcap) / 126._r_kind) ** 2
+ fjcap = (real(jcap,r_kind) / 126._r_kind) ** 2
val = one
fjcap = max(fjcap,val)
- fkm = (float(km) / 28._r_kind) ** 2
+ fkm = (real(km,r_kind) / 28._r_kind) ** 2
fkm = max(fkm,one)
w1l = -8.e-3_r_kind
w2l = -4.e-2_r_kind
@@ -1058,7 +1058,7 @@ subroutine nlmsas_ad_im_ix_(im,ix,km,jcap,delt,del,sl,rcs,&
! Select cloud from ensemble
do i=1,im
- kt2(i) = nint(xkt2(i)*float(ktcon(i)-jmin(i))-half) + jmin(i) + 1
+ kt2(i) = nint(xkt2(i)*real(ktcon(i)-jmin(i),r_kind)-half) + jmin(i) + 1
tem1 = hcko(jmin(i),i) - hesol(kt2(i),i)
tem2 = sumz(kt2(i),i) * hesol(kt2(i),i) - sumh(kt2(i),i)
if (abs(tem2) > 0.000001_r_kind) then
diff --git a/src/gsi/obs_para.f90 b/src/gsi/obs_para.f90
index 530e946be6..869efa5e78 100644
--- a/src/gsi/obs_para.f90
+++ b/src/gsi/obs_para.f90
@@ -41,11 +41,10 @@ subroutine obs_para(ndata,mype)
! grid.
!
! input argument list:
-! ndata(*,1)- number of prefiles retained for further processing
+! ndata(*,1)- number of profiles retained for further processing
! ndata(*,2)- number of observations read
! ndata(*,3)- number of observations keep after read
! mype - mpi task number
-! ipoint - pointer in array containing information about all obs type to process
!
! output argument list:
!
@@ -342,7 +341,8 @@ subroutine count_obs(ndata,nn_obs,lat_data,lon_data,obs_data,nobs_s)
integer(i_kind) ,intent(in ) :: ndata,lat_data,lon_data
integer(i_kind) ,intent(in ) :: nn_obs
integer(i_kind),dimension(npe),intent(inout) :: nobs_s
- real(r_kind),dimension(nn_obs,ndata),intent(in) :: obs_data
+ real(r_kind),dimension(nn_obs,*),intent(in) :: obs_data
+! real(r_kind),dimension(nn_obs,ndata),intent(in) :: obs_data
! Declare local variables
integer(i_kind) lon,lat,n,k
diff --git a/src/gsi/obs_sensitivity.f90 b/src/gsi/obs_sensitivity.f90
index 880ee6384a..8e5a87010f 100644
--- a/src/gsi/obs_sensitivity.f90
+++ b/src/gsi/obs_sensitivity.f90
@@ -61,6 +61,8 @@ module obs_sensitivity
use hybrid_ensemble_isotropic, only: create_ensemble,load_ensemble,destroy_ensemble
use hybrid_ensemble_isotropic, only: hybens_localization_setup
use mpeu_util, only: perr,die
+use control2state_mod, only: control2state,control2state_ad
+use ensctl2state_mod, only: ensctl2state,ensctl2state_ad
! ------------------------------------------------------------------------------
implicit none
save
diff --git a/src/gsi/observer.F90 b/src/gsi/observer.F90
index 00f51448ac..52920630a4 100644
--- a/src/gsi/observer.F90
+++ b/src/gsi/observer.F90
@@ -49,8 +49,6 @@ module observermod
use gsi_4dvar, only: l4dvar
use convinfo, only: convinfo_destroy
use m_gsiBiases, only : create_bkgbias_grids, destroy_bkgbias_grids
- use m_berror_stats, only: berror_get_dims
- use m_berror_stats_reg, only: berror_get_dims_reg
use timermod, only: timer_ini, timer_fnl
use read_obsmod, only: read_obs
use lag_fields, only: lag_guessini
diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90
index 1fb03d0940..1c45c62bc8 100644
--- a/src/gsi/obsmod.F90
+++ b/src/gsi/obsmod.F90
@@ -160,6 +160,8 @@ module obsmod
! 2021-11-16 Zhao - add option l_obsprvdiag (if true) to trigger the output of
! observation provider and sub-provider information into
! obsdiags files (used for AutoObsQC)
+! 2023-07-10 Y. Wang, D. Dowell - add variables for flash extent density
+! 2023-10-10 H. Wang (GSL) - add variables for flash extent density EnVar DA
!
! Subroutines Included:
! sub init_obsmod_dflts - initialize obs related variables to default values
@@ -186,6 +188,13 @@ module obsmod
! def write_diag - namelist logical array to compute/write (=true) diag files
! def diag_radardbz- namelist logical to compute/write (=true) radar
! reflectiivty diag files
+! def diag_fed - namelist logical to compute/write (=true) flash extent density diag files
+! def innov_use_model_fed - namelist logical. True: use (the FEB in background to calculate innovation
+! False: calculate innvation use
+! the obs operator in GSI
+! def if_model_fed - namelist logical. True: Read in FED from background
+! including from ensemble.
+! def r_hgt_fed - height of fed observations
! def reduce_diag - namelist logical to produce reduced radiance diagnostic files
! def use_limit - parameter set equal to -1 if diag files produced or 0 if not diag files or reduce_diag
! def obs_setup - prefix for files passing pe relative obs data to setup routines
@@ -434,9 +443,10 @@ module obsmod
public :: ran01dom,dval_use
public :: iout_pcp,iout_rad,iadate,iadatemn,write_diag,reduce_diag,oberrflg,bflag,ndat,dthin,dmesh,l_do_adjoint
public :: diag_radardbz
+ public :: diag_fed
public :: lsaveobsens
- public :: iout_cldch, mype_cldch
- public :: nprof_gps,time_offset,ianldate,tcp_box
+ public :: iout_cldch, mype_cldch
+ public :: nprof_gps,time_offset,ianldate,tcp_box
public :: iout_oz,iout_co,dsis,ref_obs,obsfile_all,lobserver,tcp_posmatch,perturb_obs,ditype,dsfcalc,dplat
public :: time_window,dval,dtype,dfile,dirname,obs_setup,oberror_tune,offtime_data
public :: lobsdiagsave,lobsdiag_forenkf,blacklst,hilbert_curve,lobskeep,time_window_max,sfcmodel,ext_sonde
@@ -470,12 +480,13 @@ module obsmod
! ==== DBZ DA ===
public :: ntilt_radarfiles
public :: whichradar
- public :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, l2rwthin
+ public :: vr_dealisingopt, if_vterminal, if_model_dbz, if_vrobs_raw, if_use_w_vr, l2rwthin
+ public :: inflate_dbz_obserr
public :: doradaroneob,oneoblat,oneoblon
public :: oneobddiff,oneobvalue,oneobheight,oneobradid
- public :: ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz,rmesh_vr,zmesh_vr
- public :: radar_no_thinning
+ public :: ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz,rmesh_vr,zmesh_vr,pmot_dbz
+ public :: radar_no_thinning,pmot_vr
public :: mintiltvr,maxtiltvr,minobrangevr,maxobrangevr
public :: mintiltdbz,maxtiltdbz,minobrangedbz,maxobrangedbz
public :: debugmode
@@ -483,7 +494,14 @@ module obsmod
public :: iout_dbz, mype_dbz
! --- DBZ DA ---
-
+
+ ! ==== FED DA ===
+ public :: if_model_fed, innov_use_model_fed
+ public :: r_hgt_fed
+ public :: iout_fed, mype_fed
+ public :: dofedoneob
+ ! --- FED DA ---
+
public :: obsmod_init_instr_table
public :: obsmod_final_instr_table
public :: nobs_sub
@@ -572,7 +590,7 @@ module obsmod
real(r_kind) perturb_fact,time_window_max,time_offset,time_window_rad
real(r_kind),dimension(50):: dmesh
-
+ real(r_kind) r_hgt_fed
integer(i_kind) nchan_total,ianldate
integer(i_kind) ndat,ndat_types,ndat_times,nprof_gps
integer(i_kind) lunobs_obs,nloz_v6,nloz_v8,nobskeep,nloz_omi
@@ -583,12 +601,12 @@ module obsmod
integer(i_kind) iout_co,iout_gust,iout_vis,iout_pblh,iout_tcamt,iout_lcbas
integer(i_kind) iout_cldch
integer(i_kind) iout_wspd10m,iout_td2m,iout_mxtm,iout_mitm,iout_pmsl,iout_howv
- integer(i_kind) iout_uwnd10m,iout_vwnd10m
+ integer(i_kind) iout_uwnd10m,iout_vwnd10m,iout_fed
integer(i_kind) mype_t,mype_q,mype_uv,mype_ps,mype_pw, &
mype_rw,mype_dw,mype_gps,mype_sst, &
mype_tcp,mype_lag,mype_co,mype_gust,mype_vis,mype_pblh, &
mype_wspd10m,mype_td2m,mype_mxtm,mype_mitm,mype_pmsl,mype_howv,&
- mype_uwnd10m,mype_vwnd10m, mype_tcamt,mype_lcbas, mype_dbz
+ mype_uwnd10m,mype_vwnd10m, mype_tcamt,mype_lcbas, mype_dbz, mype_fed
integer(i_kind) mype_cldch
integer(i_kind) iout_swcp, iout_lwcp
integer(i_kind) mype_swcp, mype_lwcp
@@ -613,11 +631,12 @@ module obsmod
real(r_kind) ,allocatable,dimension(:):: dval
real(r_kind) ,allocatable,dimension(:):: time_window
- integer(i_kind) ntilt_radarfiles,tcp_posmatch,tcp_box
+ integer(i_kind) ntilt_radarfiles,tcp_posmatch,tcp_box,pmot_dbz,pmot_vr
logical :: ta2tb
- logical :: doradaroneob
- logical :: vr_dealisingopt, if_vterminal, if_model_dbz, inflate_obserr, if_vrobs_raw, l2rwthin
+ logical :: doradaroneob,dofedoneob
+ logical :: vr_dealisingopt, if_vterminal, if_model_dbz,if_model_fed, innov_use_model_fed, if_vrobs_raw, if_use_w_vr, l2rwthin
+ logical :: inflate_dbz_obserr
character(4) :: whichradar,oneobradid
real(r_kind) :: oneoblat,oneoblon,oneobddiff,oneobvalue,oneobheight
logical :: radar_no_thinning
@@ -638,6 +657,7 @@ module obsmod
logical lobserver,l_do_adjoint, lobsdiag_forenkf
logical,dimension(0:50):: write_diag
logical diag_radardbz
+ logical diag_fed
logical reduce_diag
logical offtime_data
logical hilbert_curve
@@ -747,12 +767,17 @@ subroutine init_obsmod_dflts
if_vterminal=.false.
l2rwthin =.false.
if_vrobs_raw=.false.
- if_model_dbz=.true.
- inflate_obserr=.false.
+ if_use_w_vr=.true.
+ if_model_dbz=.false.
+ if_model_fed=.false.
+ innov_use_model_fed=.false.
+ inflate_dbz_obserr=.false.
whichradar="KKKK"
oneobradid="KKKK"
doradaroneob=.false.
+ r_hgt_fed=6500_r_kind
+ dofedoneob=.false.
oneoblat=-999_r_kind
oneoblon=-999_r_kind
oneobddiff=-999_r_kind
@@ -763,6 +788,14 @@ subroutine init_obsmod_dflts
static_gsi_nopcp_dbz=0.0_r_kind
rmesh_dbz=2
rmesh_vr=2
+! pmot_dbz values of 0,1,2,3 will save different sets of obs output
+! pmot_dbz - all obs - thin obs
+! pmot_dbz - all obs
+! pmot_dbz - use obs
+! pmot_dbz - use obs + thin obs
+
+ pmot_dbz=0
+ pmot_vr=2
zmesh_dbz=500.0_r_kind
zmesh_vr=500.0_r_kind
minobrangedbz=10000.0_r_kind
@@ -788,6 +821,7 @@ subroutine init_obsmod_dflts
end do
write_diag(1)=.true.
diag_radardbz = .false.
+ diag_fed = .false.
reduce_diag = .false.
use_limit = -1
lobsdiagsave=.false.
@@ -831,7 +865,7 @@ subroutine init_obsmod_dflts
iout_tcp=214 ! synthetic tc-mslp
iout_lag=215 ! lagrangian tracers
iout_co=216 ! co tracers
- iout_aero=217 ! aerosol product (aod)
+ iout_aero=217 ! aerosol product (aod) CURRENTLY NOT USED
iout_gust=218 ! wind gust
iout_vis=219 ! visibility
iout_pblh=221 ! pbl height
@@ -852,6 +886,7 @@ subroutine init_obsmod_dflts
iout_lwcp=236 ! liquid-water content path
iout_light=237 ! lightning
iout_dbz=238 ! radar reflectivity
+ iout_fed=239 ! flash extent density
mype_ps = npe-1 ! surface pressure
mype_t = max(0,npe-2) ! temperature
@@ -886,6 +921,7 @@ subroutine init_obsmod_dflts
mype_lwcp=max(0,npe-31) ! liquid-water content path
mype_light=max(0,npe-32)! GOES/GLM lightning
mype_dbz=max(0,npe-33) ! radar reflectivity
+ mype_fed= max(0,npe-34) ! flash extent density
! Initialize arrays used in namelist obs_input
@@ -980,7 +1016,7 @@ subroutine init_obsmod_dflts
return
end subroutine init_obsmod_dflts
- subroutine init_directories(mype)
+ subroutine init_directories(in_pe,num_pe)
!$$$ subprogram documentation block
! . . . .
! subprogram: create sub-directories
@@ -1005,20 +1041,47 @@ subroutine init_directories(mype)
! machine: ibm rs/6000 sp
!
!$$$ end documentation block
+#ifdef __INTEL_COMPILER
+ use IFPORT
+#endif
implicit none
- integer(i_kind),intent(in ) :: mype
+ integer(i_kind),intent(in ) :: in_pe
+ integer(i_kind),intent(in ) :: num_pe
+ logical :: l_mkdir_stat, l_dir_exist
character(len=144):: command
- character(len=8):: pe_name
+ character(len=8):: pe_name, loc_pe_name
+ character(len=128):: loc_dirname
+ integer(i_kind) :: i, ierror
if (lrun_subdirs) then
- write(pe_name,'(i4.4)') mype
+ write(pe_name,'(i4.4)') in_pe
dirname = 'dir.'//trim(pe_name)//'/'
- command = 'mkdir -p -m 755 ' // trim(dirname)
- call system(command)
+! Only create directories on one PE
+ if(in_pe == 0) then
+ do i = 0, num_pe
+ write(loc_pe_name,'(i4.4)') i
+ loc_dirname = 'dir.'//trim(loc_pe_name)
+#ifdef __INTEL_COMPILER
+ INQUIRE(directory=trim(loc_dirname), exist=l_dir_exist)
+ if (.not.l_dir_exist) then
+ l_mkdir_stat = MAKEDIRQQ(trim(loc_dirname))
+ if(.not.l_mkdir_stat) then
+ ierror=GETLASTERRORQQ()
+ write(6, *) "INIT_DIRECTORIES: ***ERROR** Failed to create directory ", &
+ trim(loc_dirname)," for PE ", loc_pe_name, ' ierror= ', ierror
+ call stop2(678)
+ endif
+ endif
+#else
+ command = 'mkdir -p -m 755 ' // trim(loc_dirname)
+ call system(command)
+#endif
+ enddo
+ endif
else
- write(pe_name,100) mype
+ write(pe_name,100) in_pe
100 format('pe',i4.4,'.')
dirname= trim(pe_name)
end if
diff --git a/src/gsi/pcgsoi.f90 b/src/gsi/pcgsoi.f90
index a4ae2431b1..0b808c5c55 100644
--- a/src/gsi/pcgsoi.f90
+++ b/src/gsi/pcgsoi.f90
@@ -130,8 +130,8 @@ subroutine pcgsoi()
iguess,read_guess_solution, &
niter_no_qc,print_diag_pcg
use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar, iwrtinc, ladtest, &
- iorthomax
- use gridmod, only: twodvar_regional,periodic
+ iorthomax,lsqrtb
+ use gridmod, only: twodvar_regional,periodic,minmype
use constants, only: zero,one,tiny_r_kind
use mpimod, only: mype
use mpl_allreducemod, only: mpl_allreduce
@@ -148,15 +148,17 @@ subroutine pcgsoi()
use bias_predictors, only: update_bias_preds
use xhat_vordivmod, only : xhat_vordiv_init, xhat_vordiv_calc, xhat_vordiv_clean
use timermod, only: timer_ini,timer_fnl
- use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens
+ use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens,aniso_a_en
use gsi_bundlemod, only : gsi_bundle
use gsi_bundlemod, only : self_add,assignment(=)
use gsi_bundlemod, only : gsi_bundleprint
+ use gsi_bundlemod, only : gsi_bundlegetpointer
use gsi_4dcouplermod, only : gsi_4dcoupler_grtests
use rapidrefresh_cldsurf_mod, only: i_gsdcldanal_type
use gsi_io, only: verbose
use berror, only: vprecond
use stpjomod, only: stpjo_setup
+ use intradmod, only: setrad
implicit none
@@ -187,7 +189,7 @@ subroutine pcgsoi()
type(control_vector), allocatable, dimension(:) :: cglwork
type(control_vector), allocatable, dimension(:) :: cglworkhat
integer(i_kind) :: iortho
- logical :: print_verbose
+ logical :: print_verbose,ortho,diag_print
logical :: lanlerr,read_success
! Step size diagnostic strings
@@ -235,7 +237,9 @@ subroutine pcgsoi()
nlnqc_iter=.false.
call stpjo_setup(nobs_bins)
+ ortho=.false.
if(iorthomax>0) then
+ ortho=.true.
allocate(cglwork(iorthomax+1))
DO ii=1,iorthomax+1
CALL allocate_cv(cglwork(ii))
@@ -252,10 +256,19 @@ subroutine pcgsoi()
end do
sbias=zero
+ call setrad(sval(1))
+ if(l_hyb_ens .and. .not. aniso_a_en) then
+ if (lsqrtb) then
+ write(6,*)'l_hyb_ens: not for use with lsqrtb'
+ call stop2(317)
+ end if
+ end if
! Perform inner iteration
inner_iteration: do iter=0,niter(jiter)
+
+ diag_print= iter <= 1 .and. print_diag_pcg
-! Gradually turn on variational qc to avoid possible convergence problems
+! Gradually turn on old variational qc to avoid possible convergence problems
if(vqc) then
nlnqc_iter = iter >= niter_no_qc(jiter)
if(jiter == jiterstart) then
@@ -266,17 +279,11 @@ subroutine pcgsoi()
endif
end if
! 1. Calculate gradient
- do ii=1,nobs_bins
- rval(ii)=zero
- end do
- rbias=zero
gradx=zero
- llprt=(mype==0).and.(iter<=1)
-! Control to state
-! call c2s(xhat,sval,sbias,llprt,.true.)
+ llprt=(mype==minmype).and.(iter<=1)
- if (iter<=1 .and. print_diag_pcg) then
+ if (diag_print) then
do ii=1,nobs_bins
call prt_state_norms(sval(ii),'sval')
enddo
@@ -285,20 +292,23 @@ subroutine pcgsoi()
! Compare obs to solution and transpose back to grid
call intall(sval,sbias,rval,rbias)
- if (iter<=1 .and. print_diag_pcg) then
+ if (diag_print) then
do ii=1,nobs_bins
call prt_state_norms(rval(ii),'rval')
enddo
endif
+
! Adjoint of control to state
call c2s_ad(gradx,rval,rbias,llprt)
! Print initial Jo table
- if (iter==0 .and. print_diag_pcg .and. luse_obsdiag) then
- nprt=2
- call evaljo(zjo,iobs,nprt,llouter)
- call prt_control_norms(gradx,'gradx')
+ if (iter==0) then
+ if(print_diag_pcg .and. luse_obsdiag) then
+ nprt=2
+ call evaljo(zjo,iobs,nprt,llouter)
+ call prt_control_norms(gradx,'gradx')
+ end if
endif
! Add contribution from background term
@@ -308,7 +318,7 @@ subroutine pcgsoi()
! End of gradient calculation
! Re-orthonormalization if requested
- if(iorthomax>0) then
+ if(ortho) then
iortho=min(iorthomax,iter)
if(iter .ne. 0) then
do ii=iortho,1,-1
@@ -323,13 +333,13 @@ subroutine pcgsoi()
! 2. Multiply by background error
call multb(gradx,grady)
- if(iorthomax>0) then
+ if(ortho) then
! save gradients
if (iter <= iortho) then
- zdla = sqrt(dot_product(gradx,grady,r_quad))
+ zdla = one/sqrt(dot_product(gradx,grady,r_quad))
do i=1,nclen
- cglwork(iter+1)%values(i)=gradx%values(i)/zdla
- cglworkhat(iter+1)%values(i)=grady%values(i)/zdla
+ cglwork(iter+1)%values(i)=gradx%values(i)*zdla
+ cglworkhat(iter+1)%values(i)=grady%values(i)*zdla
end do
end if
end if
@@ -350,7 +360,7 @@ subroutine pcgsoi()
! different due to round off, so use average.
gnorm(2)=dprod(2)-0.5_r_quad*(dprod(3)+dprod(4))
gnorm(3)=dprod(2)
- if(mype == 0)then
+ if(mype == minmype)then
aindex=abs(dprod(3)/dprod(2))
write(iout_iter,*) 'NL Index ',aindex
if(aindex > 0.5_r_kind .or. print_verbose) write(iout_iter,*) 'NL Values ', dprod(3),dprod(2)
@@ -370,7 +380,7 @@ subroutine pcgsoi()
gnorm(1)=dprod(1)
- if(mype == 0)write(iout_iter,*)'Minimization iteration',iter
+ if(mype == minmype)write(iout_iter,*)'Minimization iteration',iter
! 4. Calculate b and new search direction
b=zero
@@ -378,13 +388,13 @@ subroutine pcgsoi()
if (iter > 1 .or. .not. read_success)then
if (gsave>1.e-16_r_kind) b=gnorm(2)/gsave
if (b30.0_r_kind) then
- if (mype==0) then
+ if (mype==minmype) then
if (iout_6) write(6,105) gnorm(2),gsave,b
write(iout_iter,105) gnorm(2),gsave,b
endif
b=zero
endif
- if (mype==0 .and. print_verbose) write(6,888)'pcgsoi: gnorm(1:3),b=',gnorm,b
+ if (mype==minmype .and. print_verbose) write(6,888)'pcgsoi: gnorm(1:3),b=',gnorm,b
end if
do i=1,nclen
@@ -432,22 +442,20 @@ subroutine pcgsoi()
gnormx=gnorm(1)/gnormorig
penx=penalty/penorig
- if (mype==0) then
+ if (mype==minmype) then
if (iter==0) then
zgini=gnorm(1)
zfini=penalty
write(6,888)'Initial cost function =',zfini
write(6,888)'Initial gradient norm =',sqrt(zgini)
endif
- if(print_verbose)then
- write(iout_iter,888)'pcgsoi: gnorm(1:2)',gnorm
- write(iout_iter,999)'costterms Jb,Jo,Jc,Jl =',jiter,iter,fjcost
- end if
istep=1
if (stp= pennorm .or. end_iter)then
- if(mype == 0)then
+ if(mype == minmype)then
if(iout_6) write(6,101)
write(iout_iter,101)
@@ -508,7 +516,7 @@ subroutine pcgsoi()
! End of inner iteration
! Deallocate space for renormalization
- if(iorthomax>0) then
+ if(ortho) then
do ii=1,iorthomax+1
call deallocate_cv(cglwork(ii))
enddo
@@ -521,7 +529,7 @@ subroutine pcgsoi()
! Calculate adjusted observation error factor
if( oberror_tune .and. (.not.l4dvar) ) then
- if (mype == 0) write(6,*) 'PCGSOI: call penal for obs perturbation'
+ if (mype == minmype) write(6,*) 'PCGSOI: call penal for obs perturbation'
! call c2s(xhat,sval,sbias,.false.,.false.)
call penal(sval(1))
@@ -535,17 +543,14 @@ subroutine pcgsoi()
if (l_tlnmc .and. baldiag_inc) call strong_baldiag_inc(sval,size(sval))
- llprt=(mype==0)
+ llprt=(mype==minmype)
! call c2s(xhat,sval,sbias,llprt,.false.)
if(print_diag_pcg)then
! Evaluate final cost function and gradient
- if (mype==0) write(6,*)'Minimization final diagnostics'
+ if (mype==minmype) write(6,*)'Minimization final diagnostics'
- do ii=1,nobs_bins
- rval(ii)=zero
- end do
call intall(sval,sbias,rval,rbias)
gradx=zero
call c2s_ad(gradx,rval,rbias,llprt)
@@ -575,16 +580,16 @@ subroutine pcgsoi()
! fjcost(1) = dot_product(xhatsave,yhatsave,r_quad)
end if
! fjcost(2) = zjo
- zfend=penaltynew
-! if(l_hyb_ens) zfend=zfend+fjcost_e
- if (mype==0) then
+ if (mype==minmype) then
+ zfend=penaltynew
if(l_hyb_ens) then
! If hybrid ensemble run, print out contribution to Jb and Je separately
write(iout_iter,999)'costterms Jb,Je,Jo,Jc,Jl =',jiter,iter,fjcostnew(1)- fjcost_e, &
fjcost_e,fjcostnew(2:4)
+! zfend=zfend+fjcost_e
else
write(iout_iter,999)'costterms Jb,Jo,Jc,Jl =',jiter,iter,fjcostnew
@@ -633,13 +638,7 @@ subroutine pcgsoi()
! Write output analysis files
if(.not.l4dvar) call prt_guess('analysis')
call prt_state_norms(sval(1),'increment')
- if (twodvar_regional) then
- call write_all(-1)
- else
- if(jiter == miter) then
- call write_all(-1)
- endif
- endif
+ if (twodvar_regional .or. jiter == miter) call write_all(-1)
! Overwrite guess with increment (4d-var only, for now)
if (iwrtinc>0) then
@@ -905,6 +904,8 @@ subroutine c2s(hat,val,bias,llprt,ltest)
use gsi_bundlemod, only : gsi_bundle,assignment(=)
use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar
use gsi_4dcouplermod, only : gsi_4dcoupler_grtests
+ use control2state_mod, only: control2state,control2state_ad
+ use ensctl2state_mod, only: ensctl2state
implicit none
type(control_vector) ,intent(inout) :: hat
@@ -971,6 +972,8 @@ subroutine c2s_ad(hat,val,bias,llprt)
use gsi_bundlemod, only : gsi_bundle,assignment(=)
use gsi_bundlemod, only : self_add
use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar
+ use control2state_mod, only: control2state_ad
+ use ensctl2state_mod, only: ensctl2state_ad
implicit none
type(control_vector) ,intent(inout) :: hat
diff --git a/src/gsi/polcarf.f90 b/src/gsi/polcarf.f90
index 4ed450daa1..f2038d9d95 100644
--- a/src/gsi/polcarf.f90
+++ b/src/gsi/polcarf.f90
@@ -617,7 +617,7 @@ subroutine polcas(afg,axr,nxem,norm,naxr,wtaxs,wtxrs,inaxs,inxrs,nf,mr,nr)
do i=0,naxr-1
valp=valp+axr(i,mr+1)
end do
- valp=valp/float(naxr)
+ valp=valp/real(naxr,r_kind)
do i=0,naxr-1
axr(i,mr)=valp
end do
@@ -692,7 +692,7 @@ subroutine polcasa(afg,axr,nxem,norm,naxr,wtaxs,wtxrs,inaxs,inxrs,nf,mr,nr)
do i=0,naxr-1
valp=valp+axr(i,mr)
end do
- valp=valp/float(naxr)
+ valp=valp/real(naxr,r_kind)
do i=0,naxr-1
axr(i,mr)=zero
axr(i,mr+1)=axr(i,mr+1)+valp
diff --git a/src/gsi/prewgt.f90 b/src/gsi/prewgt.f90
index 38d61050fe..7f3d2fc091 100644
--- a/src/gsi/prewgt.f90
+++ b/src/gsi/prewgt.f90
@@ -273,7 +273,7 @@ subroutine prewgt(mype)
end do
do j=1,lon2
do i=1,lat2
- temp(i,j)=float(isli2(i,j))
+ temp(i,j)=real(isli2(i,j),r_kind)
end do
end do
@@ -585,7 +585,7 @@ subroutine prewgt(mype)
! rearth_equator is the equatorial radius from a 1999 IAG report. The
! horizontal scales are defined at the equator, hence the need for the
! equatorial radius.
- s2u=(two*pi*rearth_equator)/float(nlon)
+ s2u=(two*pi*rearth_equator)/real(nlon,r_kind)
allocate(sli(ny,nx,2,nnnn1o),sli1(-nf:nf,-nf:nf,2,nnnn1o), &
diff --git a/src/gsi/prewgt_reg.f90 b/src/gsi/prewgt_reg.f90
index bde1c9dece..d79a06697e 100644
--- a/src/gsi/prewgt_reg.f90
+++ b/src/gsi/prewgt_reg.f90
@@ -164,7 +164,6 @@ subroutine prewgt_reg(mype)
real(r_kind),allocatable,dimension(:,:,:,:)::sli
real(r_quad),dimension(180,nsig):: ozmz,cnt
real(r_quad),dimension(180*nsig):: ozmz0,cnt0
- real(r_kind),dimension(180,nsig):: ozmzt,cntt
real(r_kind),dimension(:,:,:),pointer::ges_oz=>NULL()
@@ -267,13 +266,13 @@ subroutine prewgt_reg(mype)
do k=1,nsig
do ix=1,180
i=i+1
- ozmzt(ix,k)=ozmz0(i)
- cntt(ix,k)=cnt0(i)
+ ozmz(ix,k)=ozmz0(i)
+ cnt(ix,k)=cnt0(i)
end do
end do
do k=1,nsig
do i=1,180
- if(cntt(i,k)>zero) ozmzt(i,k)=sqrt(ozmzt(i,k)/cntt(i,k))
+ if(cnt(i,k)>zero) ozmz(i,k)=sqrt(ozmz(i,k)/cnt(i,k))
enddo
enddo
endif ! regional_ozone
@@ -452,10 +451,10 @@ subroutine prewgt_reg(mype)
d=region_lat(il,jl)*rad2deg+90._r_kind
l=int(d)
l2=l+1
- dl2=d-float(l)
+ dl2=d-real(l,r_kind)
dl1=one-dl2
do k=1,nsig
- dssv(i,j,k,n)=(dl1*ozmzt(l,k)+dl2*ozmzt(l2,k))*dsv(1,k,llmin)
+ dssv(i,j,k,n)=(dl1*ozmz(l,k)+dl2*ozmz(l2,k))*dsv(1,k,llmin)
end do
end do
end do
@@ -581,7 +580,7 @@ subroutine prewgt_reg(mype)
do i=1,lon2
l=int(rllat1(j,i))
l2=min0(l+1,llmax)
- dl2=rllat1(j,i)-float(l)
+ dl2=rllat1(j,i)-real(l,r_kind)
dl1=one-dl2
do k=1,nsig
dssv(j,i,k,n)=dl1*dsv(i,k,l)+dl2*dsv(i,k,l2)
@@ -604,7 +603,7 @@ subroutine prewgt_reg(mype)
do i=1,lon2
l=int(rllat1(j,i))
l2=min0(l+1,llmax)
- dl2=rllat1(j,i)-float(l)
+ dl2=rllat1(j,i)-real(l,r_kind)
dl1=one-dl2
do k=1,nsig
dssv(j,i,k,n)=dl1*dsv(i,k,l)+dl2*dsv(i,k,l2)
@@ -662,7 +661,7 @@ subroutine prewgt_reg(mype)
do i=1,lon2
l=int(rllat1(j,i))
l2=min0(l+1,llmax)
- dl2=rllat1(j,i)-float(l)
+ dl2=rllat1(j,i)-real(l,r_kind)
dl1=one-dl2
dssvs(j,i,n)=dl1*dsvs(i,l)+dl2*dsvs(i,l2)
if (mvars>=2.and.n==nrf2_sst) then
@@ -738,7 +737,7 @@ subroutine prewgt_reg(mype)
do j=1,ny
l=int(rllat(j,i))
lp=min0(l+1,llmax)
- dl2=rllat(j,i)-float(l)
+ dl2=rllat(j,i)-real(l,r_kind)
dl1=one-dl2
fact=one/(dl1*hwll(l,k1,nn)+dl2*hwll(lp,k1,nn))
slw((i-1)*ny+j,k)=slw((i-1)*ny+j,1)*fact**2
@@ -778,7 +777,7 @@ subroutine prewgt_reg(mype)
do j=1,ny
l=int(rllat(j,i))
lp=min0(l+1,llmax)
- dl2=rllat(j,i)-float(l)
+ dl2=rllat(j,i)-real(l,r_kind)
dl1=one-dl2
fact=cc/(dl1*hwllp(l,nn)+dl2*hwllp(lp,nn))
slw((i-1)*ny+j,k)=slw((i-1)*ny+j,1)*fact**2
diff --git a/src/gsi/pvqc.f90 b/src/gsi/pvqc.f90
index 81d27ba99f..3353b091a3 100755
--- a/src/gsi/pvqc.f90
+++ b/src/gsi/pvqc.f90
@@ -382,8 +382,8 @@ subroutine vqch_iii(ia,ib,ik,x,g,w)! [vqch]
g=g-ya
w=-w/xx
else
- g=-qx**2/2
- w=1
+ g=-qx**2/2_dp
+ w=1_dp
endif
g=p*g
end subroutine vqch_iii
diff --git a/src/gsi/q_diag.f90 b/src/gsi/q_diag.f90
index 925a5775ec..fe5f2f0e94 100644
--- a/src/gsi/q_diag.f90
+++ b/src/gsi/q_diag.f90
@@ -38,7 +38,7 @@ subroutine q_diag(it,mype)
use mpimod, only: mpi_rtype,mpi_comm_world,mpi_sum,ierror
use constants,only: zero,two,one,half
use gridmod, only: lat2,lon2,nsig,nlat,nlon,lat1,lon1,iglobal,&
- displs_g,ijn,wgtlats,itotsub,strip
+ displs_g,ijn,wgtlats,itotsub,strip,minmype
use derivsmod, only: cwgues
use general_commvars_mod, only: load_grid
use gridmod, only: regional
@@ -67,7 +67,7 @@ subroutine q_diag(it,mype)
real(r_kind),pointer,dimension(:,:,:):: ges_q =>NULL()
real(r_kind),pointer,dimension(:,:,:):: ges_cwmr_it=>NULL()
- mype_out=0
+ mype_out=minmype
mm1=mype+1
ier=0
@@ -147,7 +147,7 @@ subroutine q_diag(it,mype)
call load_grid(work_pw,grid_pw)
globps=zero
globpw=zero
- rlon=one/float(nlon)
+ rlon=one/real(nlon,r_kind)
do jj=2,nlat-1
j=jj-1
fmeanps=zero
diff --git a/src/gsi/qcmod.f90 b/src/gsi/qcmod.f90
index f4afdbae9d..3b685d0708 100644
--- a/src/gsi/qcmod.f90
+++ b/src/gsi/qcmod.f90
@@ -115,6 +115,9 @@ module qcmod
! def vadfile - local name of bufr file containing vad winds (used by read_radar)
! def use_poq7 - if true, accept sbuv/2 obs with profile ozone quality flag 7
! def cao_check - if true, turn on cold-air-outbreak screening
+! def airs_cads - if true, use the cloud and aerosol detection routine for Aqua/AIRS instrument
+! def cris_cads - if true, use the cloud and aerosol detection routine for CrIS instruments
+! def iasi_cads - if true, use the cloud and aerosol detection routine for IASI instruments
!
! following used for nonlinear qc:
!
@@ -147,12 +150,12 @@ module qcmod
!
!$$$ end documentation block
- use kinds, only: i_kind,r_kind,r_double
+ use kinds, only: i_kind,r_kind,r_double, r_single
use constants, only: zero,quarter,half,one,two,three,four,five,tiny_r_kind,rd,grav
use constants, only: r0_01,r0_02,r0_03,r0_04,r0_05,r10,r60,r100,h300,r400,r1000,r2000,r2400,r4000
use constants, only: deg2rad,rad2deg,t0c,one_tenth,rearth_equator
use obsmod, only: rmiss_single
- use radinfo, only: iuse_rad,passive_bc
+ use radinfo, only: iuse_rad,passive_bc,nuchan
use radinfo, only: tzr_qc
use radiance_mod, only: rad_obs_type
implicit none
@@ -183,6 +186,7 @@ module qcmod
public :: qc_gmi
public :: qc_amsr2
public :: qc_saphir
+
! set passed variables to public
public :: npres_print,nlnqc_iter,varqc_iter,pbot,ptop,c_varqc,njqc,vqc,nvqc,hub_norm
public :: use_poq7,noiqc,vadfile,dfact1,dfact,erradar_inflate,gps_jacqc
@@ -193,13 +197,14 @@ module qcmod
public :: ifail_iland_det, ifail_isnow_det, ifail_iice_det, ifail_iwater_det,&
ifail_imix_det, ifail_iomg_det, ifail_isst_det, ifail_itopo_det,&
ifail_iwndspeed_det
- public :: cao_check
+ public :: cao_check, ifail_clrfrac_geocsr_qc !emily
public :: buddycheck_t,buddydiag_save
public :: vadwnd_l2rw_qc
public :: pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres
public :: troflg
public :: lat_c
public :: nrand
+ public :: airs_cads, cris_cads, iasi_cads
logical nlnqc_iter,njqc,vqc,nvqc,hub_norm
logical noiqc
@@ -215,6 +220,7 @@ module qcmod
logical vadwnd_l2rw_qc
logical troflg
logical cao_check
+ logical airs_cads, cris_cads, iasi_cads
character(10):: vadfile
integer(i_kind) npres_print
@@ -247,6 +253,7 @@ module qcmod
integer(i_kind),parameter:: ifail_surface_qc=5
! Reject due to gross check in specific qc routine
integer(i_kind),parameter:: ifail_gross_routine_qc=6
+ integer(i_kind),parameter:: ifail_gross_routine_nonsea_qc=16
! Reject due to cloud > limit for channel in qc routine
integer(i_kind),parameter:: ifail_cloud_qc=7
! Reject due to inaccurate emissivity/surface temperature estimate in qc routine
@@ -354,8 +361,9 @@ module qcmod
! QC_geocsr
! Reject because of standard deviation in subroutine qc_geocsr
- integer(i_kind),parameter:: ifail_std_geocsr_qc=50
-
+! integer(i_kind),parameter:: ifail_std_geocsr_qc=50
+ integer(i_kind),parameter:: ifail_std_geocsr_qc=52 !emily change from 50 to 52
+ integer(i_kind),parameter:: ifail_clrfrac_geocsr_qc=51 !emily
! QC_avhrr
! Reject because of too large surface temperature physical retrieval in qc routine: tz_retrieval (see tzr_qc)
integer(i_kind),parameter:: ifail_tzr_qc=10
@@ -455,6 +463,10 @@ subroutine init_qcvars
lat_c=21.0_r_kind
nrand=13
+ airs_cads = .false.
+ cris_cads = .false.
+ iasi_cads = .false.
+
return
end subroutine init_qcvars
@@ -1085,6 +1097,15 @@ end subroutine tz_retrieval
subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, &
temp,wmix,ts,pems,ierrret,kraintype,tpwc,clw,sgagl,tzbgr, &
tbc,tbcnob,tb_ges,tnoise,ssmi,amsre_low,amsre_mid,amsre_hig,ssmis, &
+ varinv_after_grossroutinechk_over_ocean, & !emily
+ varinv_after_topo, & !emily
+ varinv_after_sfcchk, & !emily
+ varinv_after_ch2chk, & !emily
+ varinv_after_grossroutinechk,& !emily
+ varinv_after_scatteringchk, & !emily
+ varinv_after_nsstret, & !emily
+ varinv_after_jsfcchk, & !emily
+ pred9,pred10,pred11, & !emily
varinv,errf,aivals,id_qc)
! varinv,errf,aivals,id_qc,radmod) ! all-sky
@@ -1197,6 +1218,15 @@ subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, &
real(r_kind),dimension(nsig,nchanl),intent(in ) :: temp,wmix
real(r_kind) ,dimension(nchanl),intent(inout) :: varinv,errf
+ real(r_kind) ,dimension(nchanl),intent( out) :: varinv_after_grossroutinechk_over_ocean !emily
+ real(r_kind) ,dimension(nchanl),intent( out) :: varinv_after_grossroutinechk !emily
+ real(r_kind) ,dimension(nchanl),intent( out) :: varinv_after_topo !emily
+ real(r_kind) ,dimension(nchanl),intent( out) :: varinv_after_sfcchk !emily
+ real(r_kind) ,dimension(nchanl),intent( out) :: varinv_after_ch2chk !emily
+ real(r_kind) ,dimension(nchanl),intent( out) :: varinv_after_scatteringchk !emily
+ real(r_kind) ,dimension(nchanl),intent( out) :: varinv_after_nsstret !emily
+ real(r_kind) ,dimension(nchanl),intent( out) :: varinv_after_jsfcchk !emily
+ real(r_kind) ,intent( out) :: pred9,pred10,pred11 !emily
real(r_kind) ,dimension(40) ,intent(inout) :: aivals
! Declare local variables
@@ -1204,7 +1234,7 @@ subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, &
integer(i_kind) :: l,i
real(r_kind) :: efact,vfact,dtempf,dtbf,term
real(r_kind),dimension(nchanl) :: demisf_mi,clwcutofx
- real(r_kind) :: pred9,pred10,pred11
+!xxx real(r_kind) :: pred9,pred10,pred11 !emily
real(r_kind) :: dtz,ts_ave,xindx,tzchks
!------------------------------------------------------------------
@@ -1248,6 +1278,15 @@ subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, &
efact =one
vfact =one
+ do i = 1,24
+ varinv_after_grossroutinechk_over_ocean(i) = varinv(i) !emily
+ varinv_after_topo(i) = varinv(i) !emily
+ varinv_after_sfcchk(i) = varinv(i) !emily
+ varinv_after_ch2chk(i) = varinv(i) !emily
+ varinv_after_grossroutinechk(i) = varinv(i) !emily
+ enddo
+
+
! Over sea
if(sea) then
@@ -1271,6 +1310,7 @@ subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, &
varinv(i) = zero
id_qc(i) = ifail_gross_routine_qc
end if
+ varinv_after_grossroutinechk_over_ocean(i) = varinv(i) !emily
enddo
else if(amsre_low .and. sgagl < 25.0_r_kind) then
@@ -1347,6 +1387,7 @@ subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, &
do i=1,24
varinv(i)=zero
if(id_qc(i)== igood_qc) id_qc(i)=ifail_topo_ssmi_qc
+ varinv_after_topo(i) = varinv(i) !emily
enddo
else
!Use dtbc at 52.8 GHz to detect cloud-affected data
@@ -1359,7 +1400,8 @@ subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, &
varinv(i)=zero
if(id_qc(i)== igood_qc) id_qc(i)=ifail_surface_qc
end do
- else if (abs(tbc(2)) >= 1.5_r_kind) then ! the data at cloud-affected channels are not used
+ varinv_after_sfcchk(:) = varinv(:) !emily
+else if (abs(tbc(2)) >= 1.5_r_kind) then ! the data at cloud-affected channels are not used
do i =1,2
varinv(i) = zero
if(id_qc(i)== igood_qc ) id_qc(i)=ifail_ch2_qc
@@ -1368,12 +1410,14 @@ subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, &
varinv(i) = zero
if(id_qc(i)== igood_qc ) id_qc(i)=ifail_ch2_qc
end do
+ varinv_after_ch2chk(:) = varinv(:) !emily
endif
!General qc criteria for all channels
do i = 1,24
if( abs(tbcnob(i)) >= 3.5_r_kind) then
varinv(i) = zero
- if(id_qc(i)== igood_qc ) id_qc(i)=ifail_gross_routine_qc
+ ! if(id_qc(i)== igood_qc ) id_qc(i)=ifail_gross_routine_qc
+ if(id_qc(i)== igood_qc ) id_qc(i)=ifail_gross_routine_nonsea_qc !emily
end if
enddo
@@ -1392,6 +1436,13 @@ subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, &
end if
end if
+!>>emily
+ do i = 1, nchanl
+ varinv_after_scatteringchk(i) = varinv(i) !emily
+ enddo
+!< two) then
varinv(9) =zero
if(id_qc(9)== igood_qc) id_qc(9)=ifail_scatt_qc
+ varinv_after_scatteringchk(9) = varinv(9) !emily
end if
if(pred10 - tbcnob(10) - tb_ges(10) > two) then
varinv(10)=zero
if(id_qc(10)== igood_qc) id_qc(10)=ifail_scatt_qc
+ varinv_after_scatteringchk(10) = varinv(10) !emily
end if
if(pred11 - tbcnob(11) - tb_ges(11) > two) then
varinv(11)=zero
if(id_qc(11)== igood_qc) id_qc(11)=ifail_scatt_qc
+ varinv_after_scatteringchk(11) = varinv(11) !emily
end if
end if
!
@@ -1437,6 +1491,11 @@ subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, &
endif
endif
+ do l=1,nchanl
+ varinv_after_nsstret(:) = varinv(:) !emily
+ enddo
+
+
! Generate q.c. bounds and modified variances.
do l=1,nchanl
@@ -1452,6 +1511,8 @@ subroutine qc_ssmi(nchanl,nsig,ich,sfchgt,luse,sea,mixed, &
endif
+ varinv_after_jsfcchk(l) = varinv(l) !emily
+
end do ! l (ch) loop end
@@ -2065,10 +2126,11 @@ subroutine qc_saphir(nchanl,sfchgt,luse,sea, &
return
end subroutine qc_saphir
-subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
- cris, hirs, zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, &
- wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, &
- id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole)
+subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr,airs, &
+ cris,iasi,hirs,zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, &
+ wavenumber,ptau5,prsltmp,tvp,temp,wmix,chan_level,emissivity_k,ts,tsim, &
+ id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole,cluster_fraction, &
+ cluster_bt, chan_stdev, model_bt)
! id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole,radmod) ! all-sky
!$$$ subprogram documentation block
@@ -2108,6 +2170,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
! tzbgr - Tz over water
! tsavg5 - surface skin temperature
! tbc - simulated - observed BT with bias correction
+! tsim - simulated BT
! tb_obs - observed Brightness temperatures
! tnoise - channel noise array
! wavenumber - array of channel wavenumbers
@@ -2133,6 +2196,10 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
! cld - cloud fraction
! cldp - cloud pressure
! zero_irjaco3_pole - logical to control use of ozone jacobians near poles
+! cluster_fraction - size of imager derived cluster to determine clear cloudy profiles, used by CADS
+! cluster_bt - imager brightness temperature of each cluster, used by CADS
+! chan_stdev - standard deviation of cluster mean temperatures, used by CADS
+! model_bt _ brightness temperature derived from the model's clear profile. used by CADS
!
! attributes:
! language: f90
@@ -2142,11 +2209,13 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
use kinds, only: r_kind, i_kind
use radinfo, only: iomg_det, itopo_det, isst_det
+ use crtm_planck_functions, only: crtm_planck_radiance
+ use cads, only: cloud_aerosol_detection
implicit none
! Declare passed variables
- logical, intent(in ) :: sea,land,ice,snow,luse,goessndr, cris, hirs
+ logical, intent(in ) :: sea,land,ice,snow,luse,goessndr,airs,cris,hirs,iasi
logical, intent(inout) :: zero_irjaco3_pole
integer(i_kind), intent(in ) :: nsig,nchanl,ndat,is
integer(i_kind),dimension(nchanl), intent(in ) :: ich
@@ -2157,10 +2226,14 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
real(r_kind), intent( out) :: cld,cldp
real(r_kind),dimension(40,ndat), intent(inout) :: aivals
real(r_kind),dimension(nchanl), intent(in ) :: tbc,emissivity_k,ts,wavenumber,tb_obs,tbcnob
- real(r_kind),dimension(nchanl), intent(in ) :: tnoise
+ real(r_kind),dimension(nchanl), intent(in ) :: chan_level
+ real(r_kind),dimension(nchanl), intent(in ) :: tnoise,tsim
real(r_kind),dimension(nsig,nchanl),intent(in ) :: ptau5,temp,wmix
real(r_kind),dimension(nsig), intent(in ) :: prsltmp,tvp
real(r_kind),dimension(nchanl), intent(inout) :: errf,varinv,varinv_use
+ real(r_kind),dimension(7), intent(in ) :: cluster_fraction
+ real(r_kind),dimension(2,7), intent(in ) :: cluster_bt
+ real(r_kind),dimension(2), intent(in ) :: chan_stdev, model_bt
! Declare local parameters
@@ -2168,21 +2241,29 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
real(r_kind) :: demisf,dtempf,efact,dtbf,term,cenlatx,sfchgtfact
- real(r_kind) :: sum,sum2,sum3,cloudp,tmp,dts,delta
- real(r_kind),dimension(nchanl) :: dtb
- integer(i_kind) :: i,j,k,kk,lcloud,m
+ real(r_kind) :: sum1,sum2,sum3,tmp,dts,delta
+ integer(i_kind) :: i,j,lcloud,m,isurface_chan
integer(i_kind), dimension(nchanl) :: irday
real(r_kind) :: dtz,ts_ave,xindx,tzchks
real(r_kind),parameter:: tbmax = 550._r_kind
real(r_kind),parameter:: tbmin = 50._r_kind
+! for cloud_aerosol_detect
+ integer(i_kind) :: I_Sensor_ID
+ integer(i_kind),dimension(nchanl) :: chan_array, i_flag_cloud
+ integer(i_kind),dimension(2) :: imager_chans
+ integer(i_kind) :: boundary_layer_pres, tropopause_height
+ integer(i_kind) :: ichan_10_micron, ichan_12_micron
+ real(r_kind),dimension(nchanl) :: tb_bc
+ real(r_kind) :: cloud_temperature, radiance_chan, radiance_model, radiance_cloud
+ real(r_kind) :: tb_obs_10, tb_obs_12, tb_obs_diff
! Reduce weight given to obs for shortwave ir if
! solar zenith angle tiny_r_kind
irday = 1
if (pangs <= 89.0_r_kind .and. frac_sea > zero) then
! QC2 in statsrad
- if(luse)aivals(9,is) = aivals(9,is) + one
+ if(luse) aivals(9,is) = aivals(9,is) + one
do i=1,nchanl
if(wavenumber(i) > r2000)then
if(wavenumber(i) > r2400)then
@@ -2195,7 +2276,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
*max(zero,cos(pangs*deg2rad))*oneover400
varinv(i)=tmp*varinv(i)
varinv_use(i)=tmp*varinv_use(i)
- if(id_qc(i) == igood_qc)id_qc(i)=ifail_2000_qc
+!emily if(id_qc(i) == igood_qc)id_qc(i)=ifail_2000_qc
end if
end if
end do
@@ -2225,7 +2306,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
! If GOES and lza > 60. do not use
if( goessndr .and. zasat*rad2deg > r60) then
! QC5 in statsrad
- if(luse)aivals(12,is) = aivals(12,is) + one
+ if(luse) aivals(12,is) = aivals(12,is) + one
do i=1,nchanl
varinv(i) = zero
varinv_use(i)=zero
@@ -2237,7 +2318,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
sfchgtfact=one
if (zsges > r2000) then
! QC1 in statsrad
- if(luse)aivals(8,is) = aivals(8,is) + one
+ if(luse) aivals(8,is) = aivals(8,is) + one
sfchgtfact = (r2000/zsges)**4
endif
@@ -2265,119 +2346,196 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
cld=zero
cldp=r10*prsltmp(1)
- do k=1,nsig
- if(prsltmp(k) > trop5)then
- do i=1,nchanl
- dtb(i)=(tvp(k)-tsavg5)*ts(i)
- end do
- do kk=1,k-1
- do i=1,nchanl
- dtb(i)=dtb(i)+(tvp(k)-tvp(kk))*temp(kk,i)
- end do
- end do
- sum=zero
- sum2=zero
- do i=1,nchanl
- if(varinv_use(i) > tiny_r_kind)then
- sum=sum+tbc(i)*dtb(i)*varinv_use(i)
- sum2=sum2+dtb(i)*dtb(i)*varinv_use(i)
- end if
- end do
- if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2)
- cloudp=min(max(sum/sum2,zero),one)
- sum=zero
- do i=1,nchanl
- if(varinv_use(i) > tiny_r_kind)then
- tmp=tbc(i)-cloudp*dtb(i)
- sum=sum+tmp*tmp*varinv_use(i)
- end if
- end do
- if(sum < sum3)then
- sum3=sum
- lcloud=k
- cld=cloudp
- cldp=r10*prsltmp(k)
- end if
- end if
+! Cloud and aerosol detection routines (ECMWF)
+ if (cris .and. cris_cads) then
+ I_Sensor_ID = 27
+ chan_array = nuchan(ich) ! channel numbers
+ tb_bc = tbc + tsim ! observation BT with bias correction
+ boundary_layer_pres = nint(0.8_r_kind*prsltmp(1)) ! boundary layer set to be 80% of surface pressure
+ tropopause_height = nint(trop5)
+ imager_chans = (/15,16/) ! imager channel numbers (from satinfo)
+ isurface_chan = 501 ! surface channel
+ ichan_10_micron = 458 ! ~10.7 micron channel for low level cloud test
+ ichan_12_micron = 295 ! ~12.0 micron channel for low level cloud test
+
+ call cloud_aerosol_detection( I_Sensor_ID, nchanl, chan_array, &
+ tropopause_height, boundary_layer_pres, tb_bc, tsim, chan_level, imager_chans, cluster_fraction, &
+ cluster_bt, chan_stdev, model_bt, i_flag_cloud, cldp )
+
+ elseif ( iasi .and. iasi_cads ) then
+ I_Sensor_ID = 16
+ chan_array = nuchan(ich) ! channel numbers
+ tb_bc = tbc + tsim ! observation BT with bias correction
+ boundary_layer_pres = nint(0.8_r_kind*prsltmp(1)) ! boundary layer set to be 80% of surface pressure
+ tropopause_height = nint(trop5)
+ imager_chans = (/2,3/) ! imager channel numbers (from satinfo)
+ isurface_chan = 1271 ! surface channel
+ ichan_10_micron = 1173 ! ~10.7 micron channel for low level cloud test
+ ichan_12_micron = 756 ! ~12.0 micron channel for low level cloud test
+
+ call cloud_aerosol_detection( I_Sensor_ID, nchanl, chan_array, &
+ tropopause_height, boundary_layer_pres, tb_bc, tsim, chan_level, imager_chans, cluster_fraction, &
+ cluster_bt, chan_stdev, model_bt, i_flag_cloud, cldp )
+
+ elseif ( airs .and. airs_cads ) then
+ I_Sensor_ID = 11
+ chan_array = nuchan(ich) ! channel numbers
+ tb_bc = tbc + tsim ! observation BT with bias correction
+ boundary_layer_pres = nint(0.8_r_kind*prsltmp(1)) ! boundary layer set to be 80% of surface pressure
+ tropopause_height = nint(trop5)
+ isurface_chan = 914 ! surface channel
+ imager_chans = (/0,0/) ! imager channel numbers (from satinfo)
+ ichan_10_micron = 843 ! ~10.7 micron channel for low level cloud test
+ ichan_12_micron = 587 ! ~12.0 micron channel for low level cloud test
+
+ call cloud_aerosol_detection( I_Sensor_ID, nchanl, chan_array, &
+ tropopause_height, boundary_layer_pres, tb_bc, tsim, chan_level, imager_chans, cluster_fraction, &
+ cluster_bt, chan_stdev, model_bt, i_flag_cloud, cldp )
- end do
- if ( lcloud > 0 ) then ! If cloud detected, reject channels affected by it.
+ else
+ call emc_legacy_cloud_detect(nchanl,nsig,tsavg5,trop5,prsltmp,tvp,ts,tbc,temp,varinv_use,lcloud,cld,cldp)
- do i=1,nchanl
+ endif ! end of which cloud test to use
+
+! compute cloud stats
+! If using CADS
+ if ((cris .and. cris_cads) .or. (iasi .and. iasi_cads) .or. (airs .and. airs_cads)) then
+
+! Reject channels affected by clouds
+ do i=1, nchanl
+ if ( i_flag_cloud(i) == 1) then
+! QC4 in statsrad
+ if(luse) aivals(11,is) = aivals(11,is) + one
+ varinv(i) = zero
+ varinv_use(i) = zero
+ if(id_qc(i) == igood_qc) id_qc(i) = ifail_cloud_qc
+ endif
+ end do
+
+! Derive cloud amount for CADS
+ cld = zero
+ if ( cldp < prsltmp(1) ) then ! if cloud in this profile exists
+ cloud_layer: do i=2, nsig ! determine which layer the cloud exists.
+ if (prsltmp(i) < cldp) then
+ lcloud = i
+ do j=1, nchanl ! use surface channel to derive cloud amount
+ m = nuchan(ich(j))
+ if ( m == isurface_chan ) then ! interpolate cloud top temperature
+ cloud_temperature = ((tvp(lcloud) -tvp(lcloud -1)/ log(prsltmp(lcloud) / prsltmp(lcloud - 1))) &
+ * log(cldp/prsltmp(lcloud-1))) + tvp(lcloud-1)
+ call crtm_planck_radiance(1,m,tb_bc(j),radiance_chan) ! observation radiance. same as tb_obs + bias correction
+ call crtm_planck_radiance(1,m,tsim(j),radiance_model) ! model derived radiance
+ call crtm_planck_radiance(1,m,cloud_temperature,radiance_cloud) ! cloud top temperature radiance
+ cld = (radiance_chan - radiance_model) / (radiance_cloud - radiance_model)
+ cld = min(max(cld,zero),one)
+ cldp = cldp * r10
+ exit cloud_layer ! cloud layer foound and cloud amount computed
+ endif ! surface channel found
+ end do !surface_chan
+ endif ! cloud found (prsltmp(i) < cldp)
+ end do cloud_layer
+
+! If clear, do a 10.7 - 12 micron test for low level clouds
+ else ! lcloud = 0
+ do i=1, nchanl
+ if ( nuchan(ich(i)) == ichan_10_micron ) tb_obs_10 = tb_obs(i)
+ if ( nuchan(ich(i)) == ichan_12_micron ) tb_obs_12 = tb_obs(i)
+ end do
+ if ( tb_obs_10 > zero .and. tb_obs_12 > zero ) then
+ tb_obs_diff = tb_obs_10 - tb_obs_12
+ if ( tb_obs_diff > 2.20_r_kind ) then ! Assume a cloud exists
+ cldp = prsltmp(1) * r10 ! Assume near surface cloud
+ cld = one ! Assume overcast cloud
+ lcloud = 1
+ endif
+ endif
+ endif
+! If more than 2% of the transmittance comes from the cloud layer, reject the channel (0.02 is a tunable parameter).
+! or CADS flagged a channel to have cloud.
+ if ( lcloud > 0 ) then
+ do i=1, nchanl
+ if ( ptau5(lcloud,i) > 0.02_r_kind ) then
+ if(luse) aivals(11,is) = aivals(11,is) + one ! QC4 in statsrad
+ varinv(i) = zero
+ varinv_use(i) = zero
+ if(id_qc(i) == igood_qc) id_qc(i) = ifail_cloud_qc
+ end if
+ end do
+ endif
+
+! default compute cloud stats, emc_legacy_cloud_detect
+ else
+ if ( lcloud > 0 ) then
+
+ do i=1,nchanl
! reject channels with iuse_rad(j)=-1 when they are peaking below the cloud
j=ich(i)
if (passive_bc .and. iuse_rad(j)==-1) then
- if (lcloud .ge. kmax(i)) then
- if(luse)aivals(11,is) = aivals(11,is) + one
- varinv(i) = zero
- varinv_use(i) = zero
- if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc
- cycle
- end if
+ if (lcloud .ge. kmax(i)) then
+ if(luse)aivals(11,is) = aivals(11,is) + one
+ varinv(i) = zero
+ varinv_use(i) = zero
+ if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc
+ cycle
+ end if
end if
! If more than 2% of the transmittance comes from the cloud layer,
! reject the channel (0.02 is a tunable parameter)
- delta = 0.02_r_kind
if ( ptau5(lcloud,i) > 0.02_r_kind) then
-! QC4 in statsrad
- if(luse)aivals(11,is) = aivals(11,is) + one
- varinv(i) = zero
- varinv_use(i) = zero
- if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc
+! QC4 in statsrad
+ if(luse) aivals(11,is) = aivals(11,is) + one
+ varinv(i) = zero
+ varinv_use(i) = zero
+ if(id_qc(i) == igood_qc) id_qc(i) = ifail_cloud_qc
end if
- end do
+ end do
-! If no clouds check surface temperature/emissivity
-
- else ! If no cloud was detected, do surface temp/emiss checks
- sum=zero
- sum2=zero
- do i=1,nchanl
+ else ! surface consistency and sensitivity chacks. ( if lcoud = 0 )
+ sum1=zero
+ sum2=zero
+ do i=1,nchanl
if ( varinv_use(i) > tiny_r_kind .and. ts(i) > 0.0001_r_kind) then
- sum=sum+tbc(i)*ts(i)*varinv_use(i)
- sum2=sum2+ts(i)*ts(i)*varinv_use(i)
+ sum1 = sum1 +tbc(i)*ts(i)*varinv_use(i)
+ sum2 = sum2+ts(i)*ts(i)*varinv_use(i)
endif
- end do
- if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2)
- dts=abs(sum/sum2)
- if(abs(dts) > one)then
+ end do
+ if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2)
+ dts=abs(sum1/sum2)
+ if(abs(dts) > one)then
if(.not. sea)then
- dts=min(dtempf,dts)
+ dts=min(dtempf,dts)
else
- dts=min(three,dts)
+ dts=min(three,dts)
end if
do i=1,nchanl
- delta=max(r0_05*tnoise(i),r0_02)
- if(abs(dts*ts(i)) > delta)then
-! QC3 in statsrad
- if(luse .and. varinv(i) > zero) &
- aivals(10,is) = aivals(10,is) + one
- varinv(i) = zero
- if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc
- end if
- end do
- end if
- endif
+ delta=max(r0_05*tnoise(i),r0_02)
+ if(abs(dts*ts(i)) > delta)then
+! QC3 in statsrad
+ if(luse .and. varinv(i) > zero) aivals(10,is) = aivals(10,is) + one
+ varinv(i) = zero
+ if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc
+ endif
+ enddo
+ endif
+ endif
-!
! Temporary additional check for CrIS to reduce influence of land points on window channels (particularly important for bias correction)
-!
- if (cris .and. .not. sea) then
- do i=1,nchanl
- if (ts(i) > 0.2_r_kind) then
+ if (cris .and. .not. sea) then
+ do i=1,nchanl
+ if (ts(i) > 0.2_r_kind) then
! QC3 in statsrad
- if(luse .and. varinv(i) > zero) &
- aivals(10,is) = aivals(10,is) + one
- varinv(i) = zero
- if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc
- end if
- end do
- end if
-
+ if(luse .and. varinv(i) > zero) &
+ aivals(10,is) = aivals(10,is) + one
+ varinv(i) = zero
+ if(id_qc(i) == igood_qc) id_qc(i) = ifail_sfcir_qc
+ end if
+ end do
+ end if
+ endif ! derive cloud stats
!
! Apply Tz retrieval
!
@@ -2407,7 +2565,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
cenlatx=abs(cenlat)*r0_04
if (cenlatx < one) then
- if(luse)aivals(6,is) = aivals(6,is) + one
+ if(luse) aivals(6,is) = aivals(6,is) + one
efact = half*(cenlatx+one)
do i=1,nchanl
if(varinv(i) > tiny_r_kind) errf(i)=efact*errf(i)
@@ -2419,7 +2577,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
if(varinv(i) > tiny_r_kind)then
dtbf = demisf*abs(emissivity_k(i))+dtempf*abs(ts(i))
term = dtbf*dtbf
- if(term > tiny_r_kind)varinv(i)=varinv(i)/(one+varinv(i)*term)
+ if(term > tiny_r_kind) varinv(i) = varinv(i)/(one+varinv(i)*term)
end if
end do
@@ -2435,90 +2593,186 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, &
if(hirs) then
do i=1,nchanl
m=ich(i)
- if (iomg_det(m) > 0 .and. i < 4 .and. abs(tbcnob(8)) > 40.0_r_kind) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
- if(iomg_det(m) > 0 .and. i == 12 .and. abs(tbcnob(8)) > 10.0_r_kind) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
-!90S-60S
- if(cenlat >= -90.0_r_kind .and. cenlat < -60.0_r_kind) then
- if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 12.0_r_kind) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
- if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 6.0_r_kind) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
- if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 4.0_r_kind) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
-!60S-30S
- else if(cenlat >= -60.0_r_kind .and. cenlat < -30.0_r_kind) then
- if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 10.0_r_kind) then
+ if(iomg_det(m) > 0 .and. i >= 4 .and. i <= 12)then
+ if (i < 4 .and. abs(tbcnob(8)) > 40.0_r_kind) then
varinv(i) = zero
if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
- if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
- if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 1.5_r_kind) then
+ else if(i == 12 .and. abs(tbcnob(8)) > 10.0_r_kind) then
varinv(i) = zero
if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
endif
+!90S-60S
+ if(cenlat >= -90.0_r_kind .and. cenlat < -60.0_r_kind) then
+ if(i == 4 .and. abs(tbcnob(8)) > 12.0_r_kind) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ else if(i == 5 .and. abs(tbcnob(8)) > 6.0_r_kind) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ else if(i == 6 .and. abs(tbcnob(8)) > 4.0_r_kind) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ endif
+!60S-30S
+ else if(cenlat >= -60.0_r_kind .and. cenlat < -30.0_r_kind) then
+ if(i == 4 .and. abs(tbcnob(8)) > 10.0_r_kind) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ else if( i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ else if(i == 6 .and. abs(tbcnob(8)) > 1.5_r_kind) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ endif
!30S-30N
- else if(cenlat >= -30.0_r_kind .and. cenlat < 30.0_r_kind) then
- if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 5.0_r_kind) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
- if(iomg_det(m) > 0 .and. i == 5 .and. (tbcnob(8) < -2.0_r_kind .or. tbcnob(8) > 3.0_r_kind)) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
- if(iomg_det(m) > 0 .and. i == 6 .and. (tbcnob(8) < -1.5_r_kind .or. tbcnob(8) > 3.0_r_kind)) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
+ else if(cenlat >= -30.0_r_kind .and. cenlat < 30.0_r_kind ) then
+ if(i == 4 .and. abs(tbcnob(8)) > 5.0_r_kind) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ else if(i == 5 .and. (tbcnob(8) < -2.0_r_kind .or. tbcnob(8) > 3.0_r_kind)) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ else if(i == 6 .and. (tbcnob(8) < -1.5_r_kind .or. tbcnob(8) > 3.0_r_kind)) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ endif
!30N-60N
- else if(cenlat >= 30.0_r_kind .and. cenlat < 60.0_r_kind) then
- if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 8.0_r_kind) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
- if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
- if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 1.0_r_kind) then
- varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
- endif
- endif !cenlat
+ else if(cenlat >= 30.0_r_kind .and. cenlat < 60.0_r_kind) then
+ if(i == 4 .and. abs(tbcnob(8)) > 8.0_r_kind) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ else if(i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ else if(i == 6 .and. abs(tbcnob(8)) > 1.0_r_kind) then
+ varinv(i) = zero
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det
+ endif
+ endif !cenlat
+ end if
if (itopo_det(m) > 0 .and. zsges > 1500.0_r_kind) then
varinv(i) = zero
- if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_itopo_det
+ if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_itopo_det
endif
end do
endif !! if (hirs)
!---mkim
+ return
+end subroutine qc_irsnd
+subroutine emc_legacy_cloud_detect(nchanl,nsig,tsavg5,trop5,prsltmp,tvp,ts,tbc,temp,varinv_use,lcloud,cld,cldp)
+
+!$$$ subprogram documentation block
+! . . .
+! subprogram: emc_legacy_cloud_detect determine clear/cloudy profiles from hirs,goessndr,airs,iasi,cris instruments
+!
+! prgmmr: derber ??? org: np23 date: ???
+!
+! abstract: determine if a profile is clear/cloudy. If cloudy, determine model layer of the lcoud.
+! This subroutine is designed for infrared sounders.
+!
+! program history log:
+! 2022-06-20 jung moved into a subroutine
+!
+! input argument list:
+! nchanl - number of channels per obs
+! nsig - number of model layers
+! tsavg5 - surface skin temperature
+! trop5 - tropopause pressure
+! prsltmp - array of layer pressure in vertical (surface to toa)
+! tvp - array of temperatures in vertical (surface to toa)
+! ts - skin temperature sensitivity
+! tbc - simulated - observed BT with bias correction
+! temp - temperature sensitivity array
+! varinv_use - observation weight used (modified obs var error inverse)
+!
+! output argument list:
+! lcloud - model layer of cloud
+! cld - derived cloud amount
+! cldp - model layer pressure (hPa) of cloud
+!
+! attributes:
+! language: f90
+! machine: ibm RS/6000 SP
+!
+!$$$ end documentation block
+
+use kinds, only: i_kind, r_kind
+use constants, only: tiny_r_kind, zero, r10
+implicit none
+
+integer(i_kind), intent(in ) :: nchanl, nsig
+integer(i_kind), intent( out) :: lcloud
+real(r_kind), intent(in ) :: tsavg5, trop5
+real(r_kind), intent( out) :: cld, cldp
+real(r_kind), dimension(nchanl), intent(in ) :: tbc, ts, varinv_use
+real(r_kind), dimension(nsig,nchanl), intent(in ) :: temp
+real(r_kind), dimension(nsig), intent(in ) :: tvp, prsltmp
+
+integer(i_kind) :: i, k, kk
+
+real(r_kind) :: sum,sum2,sum3,cloudp,tmp
+real(r_kind),dimension(nchanl) :: dtb
+
+ sum3=zero
+ do i=1,nchanl
+ sum3=sum3+tbc(i)*tbc(i)*varinv_use(i)
+ end do
+ sum3=0.75_r_kind*sum3
+ lcloud=0
+ cld=zero
+ cldp=r10*prsltmp(1)
+
+ do k=1,nsig
+ if(prsltmp(k) > trop5)then
+ do i=1,nchanl
+ dtb(i)=(tvp(k)-tsavg5)*ts(i)
+ end do
+ do kk=1,k-1
+ do i=1,nchanl
+ dtb(i)=dtb(i)+(tvp(k)-tvp(kk))*temp(kk,i)
+ end do
+ end do
+ sum=zero
+ sum2=zero
+ do i=1,nchanl
+ if(varinv_use(i) > tiny_r_kind)then
+ sum=sum+tbc(i)*dtb(i)*varinv_use(i)
+ sum2=sum2+dtb(i)*dtb(i)*varinv_use(i)
+ end if
+ end do
+ if (abs(sum2) < tiny_r_kind) sum2 = sign(tiny_r_kind,sum2)
+ cloudp=min(max(sum/sum2,zero),one)
+ sum=zero
+ do i=1,nchanl
+ if(varinv_use(i) > tiny_r_kind)then
+ tmp=tbc(i)-cloudp*dtb(i)
+ sum=sum+tmp*tmp*varinv_use(i)
+ end if
+ end do
+ if(sum < sum3)then
+ sum3=sum
+ lcloud=k
+ cld=cloudp
+ cldp=r10*prsltmp(k)
+ end if
+ end if
+
+ end do
+
+end subroutine emc_legacy_cloud_detect
- return
-end subroutine qc_irsnd
subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
zsges,cenlat,frac_sea,pangs,trop5,tzbgr,tsavg5,tbc,tb_obs,tnoise, &
wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, &
+ varinv_after_wavenum,varinv_after_rangechk,varinv_after_topo,varinv_after_transmittop, & !emily
+ varinv_after_clddet, varinv_after_nsstret, varinv_after_jsfcchk, & !emily
id_qc,aivals,errf,varinv,varinv_use,cld,cldp)
! id_qc,aivals,errf,varinv,varinv_use,cld,cldp,radmod) ! all-sky
@@ -2600,12 +2854,13 @@ subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
real(r_kind),dimension(nsig,nchanl),intent(in ) :: ptau5,temp,wmix
real(r_kind),dimension(nsig), intent(in ) :: prsltmp,tvp
real(r_kind),dimension(nchanl), intent(inout) :: errf,varinv,varinv_use
+ real(r_kind),dimension(nchanl), intent( out) :: varinv_after_wavenum, varinv_after_rangechk, varinv_after_topo, varinv_after_transmittop !emily
+ real(r_kind),dimension(nchanl), intent( out) :: varinv_after_clddet, varinv_after_nsstret, varinv_after_jsfcchk !emily
! Declare local parameters
real(r_kind),parameter:: oneover400=1.0_r_kind/400.0_r_kind
-
real(r_kind) :: demisf,dtempf,efact,dtbf,term,cenlatx,sfchgtfact
real(r_kind) :: sum1,sum2,sum3,cloudp,tmp,dts
real(r_kind),dimension(nchanl,nsig) :: dtb
@@ -2639,6 +2894,13 @@ subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
end do
endif
+!>>emily
+ do i=1,nchanl
+ varinv_after_wavenum(i) = varinv(i)
+ enddo
+!< r1000 .or. tb_obs(i) <= zero) then
varinv(i)=zero
varinv_use(i)=zero
+ if(id_qc(i) == igood_qc)id_qc(i)=ifail_range_qc !emily_bugfix
end if
+ varinv_after_rangechk(i) = varinv(i) !emily
varinv(i) = varinv(i)*(one-(one-sfchgtfact)*ptau5(1,i))
varinv_use(i) = varinv_use(i)*(one-(one-sfchgtfact)*ptau5(1,i))
+ varinv_after_topo(i) = varinv(i) !emily
! Modify error based on transmittance at top of model
varinv(i)=varinv(i)*ptau5(nsig,i)
varinv_use(i)=varinv_use(i)*ptau5(nsig,i)
errf(i)=errf(i)*ptau5(nsig,i)
+ varinv_after_transmittop(i) = varinv(i) !emily
! QC based on presence/absence of cloud
sum3=sum3+tbc(i)*tbc(i)*varinv_use(i)
@@ -2686,6 +2952,7 @@ subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
lcloud=0
cld=zero
cldp=r10*prsltmp(1)
+
!
! Zeroing dtb since it used outside the loop in which is defined
!
@@ -2764,6 +3031,10 @@ subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
end do
end if
+ do i=1,nchanl
+ varinv_after_clddet(i) = varinv(i) !emily
+ enddo
+
!
! Apply Tz retrieval
!
@@ -2791,6 +3062,10 @@ subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
endif
end if
+ do i=1,nchanl
+ varinv_after_nsstret(i) = varinv(i) !emily
+ enddo
+
cenlatx=abs(cenlat)*r0_04
if (cenlatx < one) then
if(luse)aivals(6,is) = aivals(6,is) + one
@@ -2809,12 +3084,17 @@ subroutine qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
end if
end do
+ do i=1,nchanl
+ varinv_after_jsfcchk(i) = varinv(i) !emily
+ end do
+
return
end subroutine qc_avhrr
subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, &
zsges,cenlat,tb_obsbc1,cosza,clw,tbc,ptau5,emissivity_k,ts, &
- pred,predchan,id_qc,aivals,errf,errf0,clwp_amsua,varinv,cldeff_obs,cldeff_fg,factch6, &
+ pred,predchan,id_qc,aivals,errf,errf0,clwp_amsua,varinv,varinv_sdoei,varinv_grosschk,varinv_after_jsfcchk,varinv_after_sdoei,cldeff_obs,cldeff_fg,factch6,factch4,qc4emiss_out, & !emily
+ ! pred,predchan,id_qc,aivals,errf,errf0,clwp_amsua,varinv,cldeff_obs,cldeff_fg,factch6, & !orig
cld_rbc_idx,sfc_speed,error0,clw_guess_retrieval,scatp,radmod)
!$$$ subprogram documentation block
@@ -2901,11 +3181,17 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, &
real(r_kind), intent(in ) :: cosza,clw,clwp_amsua,clw_guess_retrieval
real(r_kind), intent(in ) :: sfc_speed,scatp
real(r_kind), intent(inout) :: factch6
+ real(r_kind), intent(inout) :: factch4 !emily
+ real(r_kind), intent(inout) :: qc4emiss_out !emily
real(r_kind),dimension(40,ndat), intent(inout) :: aivals
real(r_kind),dimension(nchanl), intent(in ) :: tbc,emissivity_k,ts
real(r_kind),dimension(nsig,nchanl), intent(in ) :: ptau5
real(r_kind),dimension(npred,nchanl),intent(in ) :: pred,predchan
real(r_kind),dimension(nchanl), intent(inout) :: errf,errf0,varinv
+ real(r_kind),dimension(nchanl), intent( out) :: varinv_after_jsfcchk !emily
+ real(r_kind),dimension(nchanl), intent( out) :: varinv_after_sdoei !emily
+ real(r_kind),dimension(nchanl), intent( out) :: varinv_sdoei, varinv_grosschk !emily
+
real(r_kind),dimension(nchanl), intent(in ) :: error0
real(r_kind),dimension(nchanl), intent(in ) :: cld_rbc_idx
type(rad_obs_type), intent(in ) :: radmod
@@ -2922,7 +3208,7 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, &
real(r_kind) :: efactmc,vfactmc,dtde1,dtde2,dtde3,dtde15,dsval,clwx
real(r_kind) :: de1,de2,de3,de15
real(r_kind) :: thrd1,thrd2,thrd3,thrd15
- real(r_kind) :: factch4
+! real(r_kind) :: factch4 !emily
real(r_kind) :: ework,clwtmp
real(r_kind) :: icol
integer(i_kind) :: i
@@ -3021,17 +3307,20 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, &
errf(1:ich544)=zero
varinv(1:ich544)=zero
do i=1,ich544
- if(id_qc(i) == igood_qc)id_qc(i) = ifail_interchan_qc
+ ! if(id_qc(i) == igood_qc)id_qc(i) = ifail_interchan_qc !orig
+ if(id_qc(i) == igood_qc)id_qc(i) = ifail_range_qc !emily
end do
errf(ich890)=zero
varinv(ich890)=zero
- if(id_qc(ich890) == igood_qc) id_qc(ich890) = ifail_interchan_qc
+ ! if(id_qc(ich890) == igood_qc) id_qc(ich890) = ifail_interchan_qc !orig
+ if(id_qc(ich890) == igood_qc) id_qc(ich890) = ifail_range_qc !emily
if (latms) then
errf(16:22)=zero
varinv(16:22)=zero
do i=16,22
- if(id_qc(i) == igood_qc)id_qc(i) = ifail_interchan_qc
+ ! if(id_qc(i) == igood_qc)id_qc(i) = ifail_interchan_qc !orig
+ if(id_qc(i) == igood_qc)id_qc(i) = ifail_range_qc !emily
end do
end if
@@ -3366,6 +3655,11 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, &
end if
endif ! all-sky chk
+!>>emily
+ qc4emiss_out = zero
+ if (qc4emiss) qc4emiss_out = one
+!<>emily
+ do i = 1, nchanl
+ varinv_grosschk(i) = varinv(i)
+ enddo
+!< r2000) then
@@ -3437,6 +3737,12 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, &
end if
end do
+!>>emily
+ do i=1,nchanl
+ varinv_after_jsfcchk(i) = varinv(i) !emily
+ end do
+!<>emily
+ do i=1,nchanl
+ varinv_sdoei(i) = varinv(i) !emily
+ enddo
+!<>emily
+ do i=1,nchanl
+ varinv_after_sdoei(i) = varinv(i) !emily
+ end do
+!<>emily
+ id_qc,aivals,errf,varinv,varinv_use, &
+ varinv_after_sfcterrianchk, &
+ varinv_after_rangechk, &
+ varinv_after_topo, &
+ varinv_after_transmittop, &
+ varinv_after_clddet, &
+ varinv_after_stdchk, &
+ varinv_after_grossroutinechk, &
+ varinv_after_stdadj, &
+ varinv_after_nsstret, &
+ varinv_after_jsfcchk, &
+ cld,cldp,kmax,abi,ahi,seviri)
+!< r1000 .or. tb_obs(i) <= zero) then
varinv(i)=zero
varinv_use(i)=zero
+ if(id_qc(i) == igood_qc)id_qc(i)=ifail_range_qc !emily_bugfix
end if
+ varinv_after_rangechk(i) = varinv(i) !emily
+
tmp=one-(one-sfchgtfact)*ptau5(1,i)
varinv(i) = varinv(i)*tmp
varinv_use(i) = varinv_use(i)*tmp
+ varinv_after_topo(i) = varinv(i) !emily
! Modify error based on transmittance at top of model
varinv(i)=varinv(i)*ptau5(nsig,i)
varinv_use(i)=varinv_use(i)*ptau5(nsig,i)
errf(i)=errf(i)*ptau5(nsig,i)
+ varinv_after_transmittop(i) = varinv(i) !emily
! QC based on presence/absence of cloud
sum3=sum3+tbc(i)*tbc(i)*varinv_use(i)
@@ -4496,7 +4852,6 @@ subroutine qc_geocsr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc
end if
end do
-
! If no clouds check surface temperature/emissivity
else ! If no cloud was detected, do surface temp/emiss checks
sum=zero
@@ -4525,7 +4880,19 @@ subroutine qc_geocsr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
end do
end if
endif
+!>>emily
+ do i = 1, nchanl
+ varinv_after_clddet(i) = varinv(i) !emily
+ end do
+!<>emily
+ do i = 1, nchanl
+ varinv_after_stdchk(i) = varinv(i) !emily
+ varinv_after_grossroutinechk(i) = varinv(i) !emily
+ varinv_after_stdadj(i) = varinv(i) !emily
+ enddo
+!<= 0.5 for chn10.3
@@ -4546,6 +4913,7 @@ subroutine qc_geocsr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
varinv(i)=zero
end if
end if
+ varinv_after_stdchk(i) = varinv(i) !emily
! QC_o-g: If abs(o-g) > 2.0 do not use
if ( i/=2 .and. abs(tbc(i)) > two ) then
varinv(i) = zero
@@ -4553,6 +4921,7 @@ subroutine qc_geocsr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
! QC1 in statsrad
if(luse)aivals(8,is)= aivals(8,is) + one !hliu check
end if
+ varinv_after_grossroutinechk(i) = varinv(i) !emily
end if
! adjust varinv according to the BT standard deviation
@@ -4571,7 +4940,7 @@ subroutine qc_geocsr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
if(seviri .or. ahi) then
varinv(i)=varinv(i)
end if
-
+ varinv_after_stdadj(i) = varinv(i) !emily
end do
!
! Apply Tz retrieval
@@ -4600,6 +4969,12 @@ subroutine qc_geocsr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
endif
end if
+!>>emily
+ do i=1,nchanl
+ varinv_after_nsstret(i) = varinv(i) !emily
+ enddo
+!>>emily
+
! Generate q.c. bounds and modified variances.
do i=1,nchanl
if(varinv(i) > tiny_r_kind)then
@@ -4607,8 +4982,8 @@ subroutine qc_geocsr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse, &
term = dtbf*dtbf
if(term > tiny_r_kind)varinv(i)=varinv(i)/(one+varinv(i)*term)
end if
+ varinv_after_jsfcchk(i) = varinv(i) !emily
end do
-
return
@@ -4616,3 +4991,4 @@ end subroutine qc_geocsr
end module qcmod
+
diff --git a/src/gsi/radiance_mod.f90 b/src/gsi/radiance_mod.f90
index 60aa0bc3cd..aae7794957 100644
--- a/src/gsi/radiance_mod.f90
+++ b/src/gsi/radiance_mod.f90
@@ -1326,11 +1326,7 @@ subroutine radiance_ex_biascor_gmi(radmod,clw_obs,clw_guess_retrieval,nchanl,cld
do i=1,nchanl
if (radmod%lcloud4crtm(i)<0) cycle
- if (clw_obs <= cclr(i) .and. clw_guess_retrieval <= cclr(i) .and. abs(clw_obs-clw_guess_retrieval) < 0.001_r_kind) then
- cld_rbc_idx(i)=one !clear/clear
- else
- cld_rbc_idx(i)=zero
- endif
+ if ((clw_obs-cclr(i))*(clw_guess_retrieval-cclr(i))=0.005_r_kind) cld_rbc_idx(i)=zero
end do
return
diff --git a/src/gsi/radinfo.f90 b/src/gsi/radinfo.f90
index 76a08c39a5..4ad17626e6 100644
--- a/src/gsi/radinfo.f90
+++ b/src/gsi/radinfo.f90
@@ -615,7 +615,7 @@ subroutine radinfo_read
! !USES:
use obsmod, only: iout_rad
- use constants, only: zero,one,zero_quad
+ use constants, only: zero,one,zero_quad, r10
use mpimod, only: mype
use mpeu_util, only: perr,die
implicit none
@@ -855,7 +855,8 @@ subroutine radinfo_read
varA(i,j)=varx(i)
end do
ostats(j)=ostatsx
- if ((any(varx/=zero) .and. iuse_rad(j)>-2) .or. iuse_rad(j)==4) &
+ if ((all(varx==zero) .and. iuse_rad(j)>-2) .or. iuse_rad(j)==4) cycle read3
+ if ((any(varx/=r10) .and. iuse_rad(j)>-2) .or. iuse_rad(j)==4) &
inew_rad(j)=.false.
cycle read3
end if
@@ -896,7 +897,7 @@ subroutine radinfo_read
! Allocate arrays to receive angle dependent bias information.
! Open file to bias file (satang=satbias_angle). Read data.
- maxscan=250
+ maxscan=252
if (.not.adp_anglebc) maxscan = 90 ! default value for old files
if (adp_anglebc) then
@@ -1453,7 +1454,7 @@ real(r_kind) function rnad_pos(isis,iscan,jch)
piece=-0.625_r_kind
if (mod(iscan,2) == 1) piece = 0.625_r_kind
- rnad_pos=radstart(jch)+radstep(jch)*float((iscan-1)/2)+piece
+ rnad_pos=radstart(jch)+radstep(jch)*real((iscan-1)/2,r_kind)+piece
else
@@ -1465,7 +1466,7 @@ real(r_kind) function rnad_pos(isis,iscan,jch)
else
ifov=iscan
end if
- rnad_pos=radstart(jch)+radstep(jch)*float(ifov-1)
+ rnad_pos=radstart(jch)+radstep(jch)*real(ifov-1,r_kind)
end if
@@ -1740,7 +1741,7 @@ subroutine init_predx
if (.not. (any(inew_rad) .or. any(update_tlapmean))) return
if (ndat==0) return
- if (mype==0) write(6,*) 'INIT_PREDX: enter routine'
+! if (mype==0) write(6,*) 'INIT_PREDX: enter routine'
! Allocate and initialize data arrays
if (any(update_tlapmean)) then
@@ -1867,6 +1868,7 @@ subroutine init_predx
end do
end do loop_a
+ write(6,*) 'INIT_PREDX: inst_sat new_chan = ', trim(fdiag_rad), new_chan
if (.not. update .and. new_chan==0) then
call close_radiag(fdiag_rad,lndiag)
cycle loopf
@@ -2032,7 +2034,7 @@ subroutine init_predx
tlap2(jj) = tlap0(jj) + tlap1(jj)/tsum(jj)
count_tlapmean(jj)=count_tlapmean(jj)+one
elseif (tcnt(jj)>0) then
- ratio = max(zero,min(tcnt(jj)/float(nthreshold),one))
+ ratio = max(zero,min(tcnt(jj)/real(nthreshold,r_kind),one))
tsum(jj)=ratio*tsum(jj)+tsum0(jj)
! tlap2(jj) = tlap0(jj) + ratio*wgtlap*tlap1(jj)/tsum(jj)
tlap2(jj) = tlap0(jj) + ratio*tlap1(jj)/tsum(jj)
diff --git a/src/gsi/raflib.f90 b/src/gsi/raflib.f90
index 227bda3cb1..eb6d399d21 100644
--- a/src/gsi/raflib.f90
+++ b/src/gsi/raflib.f90
@@ -4488,14 +4488,14 @@ SUBROUTINE EIGEN(A,R,N,MV)
end do
if(anorm>zero) then
ANORM=1.414_r_kind*SQRT(ANORM)
- ANRMX=ANORM*RANGE/FLOAT(N)
+ ANRMX=ANORM*RANGE/real(N,r_kind)
!
! INITIALIZE INDICATORS AND COMPUTE THRESHOLD, THR
!
IND=0
THR=ANORM
loop1: do
- THR=THR/FLOAT(N)
+ THR=THR/real(N,r_kind)
loop2: do
L=1
loop3: do
diff --git a/src/gsi/rapidrefresh_cldsurf_mod.f90 b/src/gsi/rapidrefresh_cldsurf_mod.f90
index 1ee35fffba..475f44a9d3 100644
--- a/src/gsi/rapidrefresh_cldsurf_mod.f90
+++ b/src/gsi/rapidrefresh_cldsurf_mod.f90
@@ -28,7 +28,11 @@ module rapidrefresh_cldsurf_mod
! option for checking and adjusting the profile of Qr/Qs/Qg/Qnr
! retrieved through cloud analysis to reduce the background
! reflectivity ghost in analysis. (default is 0)
-!
+! 2023-07-30 Zhao added options for analysis of significant wave height
+! (SWH, aka howv in GSI code):
+! corp_howv: to set the static background error of howv
+! hwllp_howv: to set the de-correlation length scale
+! i_howv_3dda: control the analysis of howv in 3D analysis (if howv is in anavinfo)
!
! Subroutines Included:
! sub init_rapidrefresh_cldsurf - initialize RR related variables to default values
@@ -181,6 +185,42 @@ module rapidrefresh_cldsurf_mod
! = 2(clean Qg as in 1, and adjustment to the retrieved Qr/Qs/Qnr throughout the whole profile)
! = 3(similar to 2, but adjustment to Qr/Qs/Qnr only below maximum reflectivity level
! and where the dbz_obs is missing);
+! corp_howv - namelist real, static BE of howv (standard error deviation)
+! hwllp_howv - namelist real, static BE de-correlation length scale of howv
+! i_howv_3dda - integer, control the analysis of howv in 3D analysis (either var or hybrid)
+! = 0 (howv-off: default) : no analysis of howv in 3D analysis.
+! = 1 (howv-on) : if variable name "howv" is found in anavinfo,
+! set it to be 1 to turn on analysis of howv;
+! note: in hybrid envar run, the static BE is redueced by beta_s (<1.0),
+! since there is no ensemble of howv currently yet, then no ensemble
+! contribution to the total BE of howv, so the total BE of howv is actually
+! just the reduced static BE of howv. If to make the analysis of howv
+! in hyrbid run is as similar as the analysis of howv in pure 3dvar run,
+! the static BE of howv used in hybrid run needs to be tuned (inflated actually).
+! corp_gust - namelist real, static BE of gust (standard error deviation)
+! note: 1. initialised to be an arbitary negative value, in order to skip this
+! negative value, instead to use value (3.0 m/s) set in subroutine
+! berror_read_wgt_reg as default.
+! 2. (3drtma only) if a user-specified value (e.g., 2.0 m/s) is preferred
+! for corp_gust, in GSI namelist session "rapidrefresh_cldsurf",
+! set "corp_gust=2.0,"
+! hwllp_gust - namelist real, static BE de-correlation length scale of gust
+! note: 1. initialised to be an arbitary negative value, in order to skip this
+! negative value, instead to use value (same value for q) set in
+! subroutine berror_read_wgt_reg as default
+! 2. (3drtma only) if a user-specified value (e.g., 100 km) is preferred
+! for hwllp_gust, in GSI namelist session "rapidrefresh_cldsurf",
+! set "hwllp_gust=100000.0,"
+! oerr_gust - namelist real, observation error of gust
+! note: 1. initialised to be an arbitary negative value, in order to skip this
+! negative value, instead to use value (1.0 m/s) set in read_prepbufr.f90
+! 2. (3drtma only) if a user-specified value (e.g., 1.5 m/s ) is preferred
+! for oerr_gust, in GSI namelist session "rapidrefresh_cldsurf",
+! set "oerr_gust=1.5,"
+! i_gust_3dda - integer, control the analysis of gust in 3D analysis (either var or hybrid)
+! = 0 (gust-off: default) : no analysis of gust in 3D analysis.
+! = 1 (gust-on) : if variable name "gust" is found in anavinfo,
+! set it to be 1 to turn on analysis of gust;
!
! attributes:
! language: f90
@@ -252,6 +292,10 @@ module rapidrefresh_cldsurf_mod
public :: l_saturate_bkCloud
public :: l_rtma3d
public :: i_precip_vertical_check
+ public :: corp_howv, hwllp_howv
+ public :: i_howv_3dda
+ public :: corp_gust, hwllp_gust, oerr_gust
+ public :: i_gust_3dda
logical l_hydrometeor_bkio
real(r_kind) dfi_radar_latent_heat_time_period
@@ -310,6 +354,10 @@ module rapidrefresh_cldsurf_mod
logical l_saturate_bkCloud
logical l_rtma3d
integer(i_kind) i_precip_vertical_check
+ real(r_kind) :: corp_howv, hwllp_howv
+ integer(i_kind) :: i_howv_3dda
+ real(r_kind) :: corp_gust, hwllp_gust, oerr_gust
+ integer(i_kind) :: i_gust_3dda
contains
@@ -325,6 +373,8 @@ subroutine init_rapidrefresh_cldsurf
! 2008-06-03 Hu initial build for cloud analysis
! 2010-03-29 Hu change names to init_rapidrefresh_cldsurf
! 2011--5-04 Todling inquire MetGuess for presence of hyrometeors & set default
+! 2023-07-30 Zhao added code for initialization of some variables used
+! in analysis of significant wave height
!
! input argument list:
!
@@ -337,8 +387,12 @@ subroutine init_rapidrefresh_cldsurf
!$$$
use kinds, only: i_kind
use gsi_metguess_mod, only: gsi_metguess_get
+ use mpimod, only: mype
+ use state_vectors, only: ns2d,svars2d
+
implicit none
integer(i_kind) ivar,i,ier
+ integer(i_kind) i2
logical have_hmeteor(5)
character(len=2),parameter :: hydrometeors(5) = (/ 'qi', &
'ql', &
@@ -418,6 +472,41 @@ subroutine init_rapidrefresh_cldsurf
l_saturate_bkCloud= .true.
l_rtma3d = .false. ! turn configuration for rtma3d off
i_precip_vertical_check = 0 ! No check and adjustment to retrieved Qr/Qs/Qg (default)
+ corp_howv = 0.42_r_kind ! 0.42 meters (default)
+ hwllp_howv = 170000.0_r_kind ! 170,000.0 meters (170km as default for 3DRTMA, 50km is used in 2DRTMA)
+ i_howv_3dda = 0 ! no analysis of significant wave height (howv) in 3D analysis (default)
+ corp_gust = -1.50_r_kind ! initialised as negative & void to be skipped, in order to use
+ ! the value (3.0 m/s) set in sub berror_read_wgt_reg (as default).
+ ! If user-specified value is preferred, set it in session
+ ! "rapidrefresh_cldsurf" of GSI namelist file
+
+ hwllp_gust = -90000.0_r_kind ! initialised as a value, in order to skip this negative value
+ ! and to use the value (used for q) set in sub berror_read_wgt_reg.
+ ! If user-specified value is preferred, set it in session
+ ! "rapidrefresh_cldsurf" of GSI namelist file
+
+ oerr_gust = -2.5_r_kind ! initialised as a negative value, in order to skip this negative value
+ ! and to use the value (1.0 m/s) set in read_prepbufr.f90
+ ! If user-specified value is preferred, set it in session
+ ! "rapidrefresh_cldsurf" of GSI namelist file
+
+ i_gust_3dda = 0 ! no analysis of wind gust (gust) in 3D analysis (default)
+
+!-- searching for specific variable in state variable list (reading from anavinfo)
+ do i2=1,ns2d
+ if ( trim(svars2d(i2))=='howv' .or. trim(svars2d(i2))=='HOWV' ) then
+ i_howv_3dda = 1
+ if ( mype == 0 ) then
+ write(6,'(1x,A,1x,A8,1x,A,1x,I4)')"init_rapidrefresh_cldsurf: anavinfo svars2d (state variable): ",trim(adjustl(svars2d(i2))), " is found in anavinfo, set i_howv_3dda = ", i_howv_3dda
+ end if
+ end if
+ if ( trim(svars2d(i2))=='gust' .or. trim(svars2d(i2))=='GUST' ) then
+ i_gust_3dda = 1
+ if ( mype == 0 ) then
+ write(6,'(1x,A,1x,A8,1x,A,1x,I4)')"init_rapidrefresh_cldsurf: anavinfo svars2d (state variable): ",trim(adjustl(svars2d(i2))), " is found in anavinfo, set i_gust_3dda = ", i_gust_3dda
+ end if
+ end if
+ end do ! i2 : looping over 2-D anasv
return
end subroutine init_rapidrefresh_cldsurf
diff --git a/src/gsi/rdgrbsst.f90 b/src/gsi/rdgrbsst.f90
index 8be85ad608..29e5346eae 100644
--- a/src/gsi/rdgrbsst.f90
+++ b/src/gsi/rdgrbsst.f90
@@ -132,14 +132,14 @@ subroutine rdgrbsst(file_sst,mlat_sst,mlon_sst,&
! Get lat_sst & lon_sst
do i = 2, nlat_sst - 1
- rlats_sst(i) = (xsst0 + float(i-2)*dres)*deg2rad
+ rlats_sst(i) = (xsst0 + real(i-2,r_kind)*dres)*deg2rad
enddo
rlats_sst(1) = -90.0_r_kind*deg2rad
rlats_sst(nlat_sst) = 90.0_r_kind*deg2rad
do j = 2, nlon_sst - 1
- rlons_sst(j) = (ysst0 + float(j-2)*dres)*deg2rad
+ rlons_sst(j) = (ysst0 + real(j-2,r_kind)*dres)*deg2rad
enddo
rlons_sst(1) = -half*dres*deg2rad ! 1
@@ -184,8 +184,8 @@ subroutine rdgrbsst(file_sst,mlat_sst,mlon_sst,&
sums = sums + sst(j,2)
sumn = sumn + sst(j,nlat_sst-1)
end do
- sums = sums / float(i)
- sumn = sumn / float(i)
+ sums = sums / real(i,r_kind)
+ sumn = sumn / real(i,r_kind)
do j = 2,nlon_sst-1
sst(j,1) = sums
sst(j,nlat_sst) = sumn
diff --git a/src/gsi/read_NASA_LaRC_cloud.f90 b/src/gsi/read_NASA_LaRC_cloud.f90
index ec3f29e3fa..05889e2d6b 100644
--- a/src/gsi/read_NASA_LaRC_cloud.f90
+++ b/src/gsi/read_NASA_LaRC_cloud.f90
@@ -172,6 +172,13 @@ subroutine read_NASA_LaRC_cloud(nread,ndata,nouse,infile,obstype,lunout,sis,nob
write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,numobs)
write(6,*)'NASA larcglb::',nreal,numobs
+ deallocate(cdata_all)
+ deallocate(lat_l)
+ deallocate(lon_l)
+ deallocate(ptop_l)
+ deallocate(teff_l)
+ deallocate(phase_l)
+ deallocate(lwp_l)
return
end subroutine read_NASA_LaRC_cloud
diff --git a/src/gsi/read_aerosol.f90 b/src/gsi/read_aerosol.f90
index 0d07a6c904..a58b2d4358 100644
--- a/src/gsi/read_aerosol.f90
+++ b/src/gsi/read_aerosol.f90
@@ -367,7 +367,7 @@ subroutine read_aerosol(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
end if
! Deallocate local arrays
- deallocate(aeroout)
+ deallocate(aeroout,nrec)
deallocate(dataaod)
! End of MODIS bufr block
@@ -596,7 +596,8 @@ subroutine read_aerosol(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
end if
! Deallocate local arrays
- deallocate(aeroout)
+ deallocate(aeroout,nrec)
+ deallocate(dataaod)
! End of VIIRS AOD bufr block
diff --git a/src/gsi/read_airs.f90 b/src/gsi/read_airs.f90
index 16e890abd1..c5392dad14 100644
--- a/src/gsi/read_airs.f90
+++ b/src/gsi/read_airs.f90
@@ -622,7 +622,6 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,&
end do bufr_chans
end if
-
! Channel based quality control
if(amsua)then
@@ -790,7 +789,7 @@ subroutine read_airs(mype,val_airs,ithin,isfcalc,rmesh,jsatid,gstime,&
endif
sol_aziang = aquaspot(2)
- lza = (start + float(ifov-1)*step)*deg2rad
+ lza = (start + real(ifov-1,r_kind)*step)*deg2rad
!
! interpolate NSST variables to Obs. location and get dtw, dtc, tz_tr
!
diff --git a/src/gsi/read_amsr2.f90 b/src/gsi/read_amsr2.f90
index a7b27abccc..9d8d4944d9 100644
--- a/src/gsi/read_amsr2.f90
+++ b/src/gsi/read_amsr2.f90
@@ -566,7 +566,7 @@ subroutine read_amsr2(mype,val_amsr2,ithin,rmesh,jsatid,gstime,&
if(.not. regional .and. dist1 > 0.75_r_kind) cycle obsloop
endif
- crit1 = crit1 + 10._r_kind * float(iskip)
+ crit1 = crit1 + 10._r_kind * real(iskip,r_kind)
call checkob(dist1,crit1,itx,iuse)
if(.not. iuse) then
cycle obsloop
diff --git a/src/gsi/read_anowbufr.f90 b/src/gsi/read_anowbufr.f90
index e2b744eb6a..449ce5cdf8 100644
--- a/src/gsi/read_anowbufr.f90
+++ b/src/gsi/read_anowbufr.f90
@@ -50,7 +50,9 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,&
iconc,ierror,ilat,ilon,itime,iid,ielev,isite,iikx,ilate,ilone,&
elev_missing,site_scale,tunable_error,&
code_pm25_ncbufr,code_pm25_anowbufr,&
- code_pm10_ncbufr,code_pm10_anowbufr
+ code_pm10_ncbufr,code_pm10_anowbufr,&
+ anowbufr_ext,pm2_5_teom_max,pm10_teom_max
+
use mpimod, only: npe
implicit none
@@ -71,10 +73,12 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,&
nyob=3,ndhr=4,ntyp=5,ncopopm=6
!see headr input format below
integer(i_kind), parameter :: nfields=6
+ integer(i_kind), parameter :: nfields_b=12
!output format parameters
integer(i_kind), parameter:: nchanl=0,nreal=ilone
real(r_kind),parameter :: r360 = 360.0_r_kind
+ real(r_kind),parameter :: r90 = 90.0_r_kind
real(r_kind),parameter :: percent=1.e-2_r_kind
real(r_kind), parameter :: anow_missing=1.0e11_r_kind,&
@@ -96,8 +100,10 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,&
real(r_kind), dimension(5) :: rinc
character(len=8) :: subset
character(len=80) :: headr
+ character(len=80) :: obstr
real(r_double), dimension(nfields) :: indata
+ real(r_double), dimension(nfields_b) :: indata_a,indata_b
real(r_kind) :: tdiff,obstime,t4dv
real(r_kind) :: dlat,dlon,error_1,error_2,obserror,dlat_earth,dlon_earth
@@ -141,7 +147,6 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,&
! reading each report from bufr
do while (ireadmg(lunin,subset,idate) == 0)
-
if (trim(obstype)=='pm2_5') then
if ( (subset == 'NC008031') .or. (subset == 'NC008032' ) ) then
@@ -149,9 +154,16 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,&
ncbufr=.true.
write(6,*)'READ_PM2_5: AIRNOW data type, subset=',subset
else if (subset == 'ANOWPM') then
- headr='SID XOB YOB DHR TYP COPOPM'
- anowbufr=.true.
- write(6,*)'READ_PM2_5: AIRNOW data type, subset=',subset
+ if (anowbufr_ext) then
+ headr='SID XOB YOB DHR TYP T29 SQN PROCN RPT CAT TYPO TSIG'
+ obstr='TPHR QCIND COPOPM ELV COPOPM10 COPOCO'
+ anowbufr=.true.
+ write(6,*)'READ_PM2_5_BUFR_EXT: AIRNOW data type, subset=',subset
+ else ! default ANOWBUFR Table
+ headr='SID XOB YOB DHR TYP COPOPM'
+ anowbufr=.true.
+ write(6,*)'READ_PM2_5: AIRNOW data type, subset=',subset
+ end if
else
cycle
endif
@@ -162,6 +174,17 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,&
headr='PTID CLONH CLATH TPHR TYPO COPOPM'
ncbufr=.true.
write(6,*)'READ_PM10: AIRNOW data type, subset=',subset
+ else if (subset == 'ANOWPM') then
+ if (anowbufr_ext) then
+ headr='SID XOB YOB DHR TYP T29 SQN PROCN RPT CAT TYPO TSIG'
+ obstr='TPHR QCIND COPOPM ELV COPOPM10 COPOCO'
+ anowbufr=.true.
+ write(6,*)'READ_PM10_BUFR_EXT: AIRNOW data type, subset=',subset
+ else
+ headr='SID XOB YOB DHR TYP COPOPM'
+ anowbufr=.true.
+ write(6,*)'READ_PM10: AIRNOW data type, subset=',subset
+ end if
else
cycle
endif
@@ -176,8 +199,17 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,&
imin=0
do while (ireadsb(lunin) == 0)
- call ufbint(lunin,indata,nfields,1,iret,headr)
-
+ if (anowbufr_ext) then
+ call ufbint(lunin,indata_a,nfields_b,1,iret,headr)
+ indata(1:5) = indata_a(1:5)
+ call ufbint(lunin,indata_b,nfields_b,1,iret,obstr)
+ if (trim(obstype)=='pm2_5') indata(ncopopm)=indata_b(3)
+ if (trim(obstype)=='pm10') indata(ncopopm)=indata_b(5)
+ site_elev = indata_b(4)
+ else
+ call ufbint(lunin,indata,nfields,1,iret,headr)
+ end if
+
if (anowbufr) then
kx=indata(ntyp)
read(sid,'(Z8)')site_id
@@ -198,13 +230,15 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,&
nread = nread + 1
conc=indata(ncopopm)
-
if ( iret > 0 .and. (conc < conc_missing ) .and. &
(conc >= zero)) then
if(indata(nxob) >= r360) indata(nxob) = indata(nxob) - r360
if(indata(nxob) < zero) indata(nxob) = indata(nxob) + r360
+ if(indata(nxob) > r360)cycle
+ if(indata(nyob) > r90)cycle
+
dlon_earth_deg=indata(nxob)
dlat_earth_deg=indata(nyob)
@@ -307,6 +341,7 @@ subroutine read_anowbufr(nread,ndata,nodata,gstime,&
ndata=ndata+1
nodata=nodata+1
+ if(ndata>maxobs) exit
cdata_all(iconc,ndata) = conc ! pm2_5 obs
cdata_all(ierror,ndata) = obserror ! pm2_5 obs error
diff --git a/src/gsi/read_atms.f90 b/src/gsi/read_atms.f90
index 9f5efb5301..3ecebd32e8 100644
--- a/src/gsi/read_atms.f90
+++ b/src/gsi/read_atms.f90
@@ -177,6 +177,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
real(r_kind), ALLOCATABLE, TARGET :: dlat_earth_save(:)
real(r_kind), ALLOCATABLE, TARGET :: crit1_save(:)
real(r_kind), ALLOCATABLE, TARGET :: lza_save(:)
+ real(r_kind), ALLOCATABLE, TARGET :: satheight_save(:)
real(r_kind), ALLOCATABLE, TARGET :: satazi_save(:)
real(r_kind), ALLOCATABLE, TARGET :: solzen_save(:)
real(r_kind), ALLOCATABLE, TARGET :: solazi_save(:)
@@ -352,6 +353,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
ALLOCATE(crit1_save(maxobs))
ALLOCATE(it_mesh_save(maxobs))
ALLOCATE(lza_save(maxobs))
+ ALLOCATE(satheight_save(maxobs))
ALLOCATE(satazi_save(maxobs))
ALLOCATE(solzen_save(maxobs))
ALLOCATE(solazi_save(maxobs))
@@ -401,7 +403,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
! inflate selection value for ears_db data
crit0 = 0.01_r_kind
- if ( llll > 1 ) crit0 = crit0 + r100 * float(llll)
+ if ( llll > 1 ) crit0 = crit0 + r100 * real(llll,r_kind)
call ufbint(lnbufr,bfr1bhdr,n1bhdr,1,iret,hdr1b)
@@ -455,9 +457,9 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
lza = bfr2bhdr(1)*deg2rad ! local zenith angle
if(ifov <= 48) lza=-lza
- panglr=(start+float(ifov-1)*step)*deg2rad
+ panglr=(start+real(ifov-1,r_kind)*step)*deg2rad
satellite_height=bfr1bhdr(13)
-! Ensure orbit height is reasonable
+ satheight_save(iob)=satellite_height
if (satellite_height < 780000.0_r_kind .OR. &
satellite_height > 900000.0_r_kind) satellite_height = 824000.0_r_kind
rato = one + satellite_height/rearth_equator
@@ -511,10 +513,10 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
ALLOCATE(Relative_Time_In_Seconds(Num_Obs))
ALLOCATE(IScan(Num_Obs))
Relative_Time_In_Seconds = 3600.0_r_kind*T4DV_Save(1:Num_Obs)
- write(6,*) 'Calling ATMS_Spatial_Average'
+! write(6,*) 'Calling ATMS_Spatial_Average'
CALL ATMS_Spatial_Average(Num_Obs, NChanl, IFOV_Save(1:Num_Obs), &
Relative_Time_In_Seconds, BT_Save(1:nchanl,1:Num_Obs), IScan, IRet)
- write(6,*) 'ATMS_Spatial_Average Called with IRet=',IRet
+! write(6,*) 'ATMS_Spatial_Average Called with IRet=',IRet
DEALLOCATE(Relative_Time_In_Seconds)
IF (IRet /= 0) THEN
@@ -534,6 +536,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
it_mesh => it_mesh_save(iob)
ifov => ifov_save(iob)
lza => lza_save(iob)
+ satellite_height = satheight_save(iob)
satazi => satazi_save(iob)
solzen => solzen_save(iob)
solazi => solazi_save(iob)
@@ -544,11 +547,6 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
dlat_earth = dlat_earth*deg2rad
dlon_earth = dlon_earth*deg2rad
-! Just use every fifth scan position and scanline (and make sure that we have
-! position 48 as we need it for scan bias)
- if (5*NINT(REAL(IScan(Iob))/5_r_kind) /= IScan(IOb) .OR. &
- 5*NINT(REAL(IFov-3)/5_r_kind) /= IFOV -3 ) CYCLE ObsLoop
-
! Regional case
if(regional)then
call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)
@@ -648,7 +646,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
idomsfc(1),sfcpct,ts,tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10,sfcr)
endif
- crit1 = crit1 + rlndsea(isflg) + 10._r_kind*float(iskip) + 0.01_r_kind * abs(zz)
+ crit1 = crit1 + rlndsea(isflg) + 10._r_kind*real(iskip,r_kind) + 0.01_r_kind * abs(zz)
call checkob(dist1,crit1,itx,iuse)
if(.not. iuse)cycle ObsLoop
@@ -726,7 +724,7 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
endif
! Re-calculate look angle
- panglr=(start+float(ifov-1)*step)*deg2rad
+ panglr=(start+real(ifov-1,r_kind)*step)*deg2rad
! Load selected observation into data array
@@ -736,7 +734,8 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,&
data_all(3 ,itx)= dlon ! grid relative longitude
data_all(4 ,itx)= dlat ! grid relative latitude
data_all(5 ,itx)= lza ! local zenith angle
- data_all(6 ,itx)= satazi ! local azimuth angle
+ !data_all(6 ,itx)= satazi ! local azimuth angle
+ data_all(6 ,itx)= satellite_height ! temporary output
data_all(7 ,itx)= panglr ! look angle
data_all(8 ,itx)= ifovmod ! scan position
data_all(9 ,itx)= solzen ! solar zenith angle
diff --git a/src/gsi/read_avhrr.f90 b/src/gsi/read_avhrr.f90
index 48c6200c44..c1509828ad 100755
--- a/src/gsi/read_avhrr.f90
+++ b/src/gsi/read_avhrr.f90
@@ -585,6 +585,7 @@ subroutine read_avhrr(mype,val_avhrr,ithin,rmesh,jsatid,&
deallocate(data_mesh,nrec)
enddo ! do imesh = 1, nmesh
+ deallocate(amesh,hsst_thd)
! Allow single task to check for bad obs, update superobs sum,
! and write out data to scratch file for further processing.
diff --git a/src/gsi/read_bufrtovs.f90 b/src/gsi/read_bufrtovs.f90
index 0aed801ee5..d07933c133 100644
--- a/src/gsi/read_bufrtovs.f90
+++ b/src/gsi/read_bufrtovs.f90
@@ -228,7 +228,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
real(r_kind),allocatable,dimension(:,:):: data_all
real(crtm_kind),allocatable,dimension(:):: data1b4
- real(r_double),allocatable,dimension(:):: data1b8,data1b8x
+ real(r_double),allocatable,dimension(:):: data1b8
real(r_double),dimension(n1bhdr):: bfr1bhdr
real(r_double),dimension(n2bhdr):: bfr2bhdr
@@ -519,7 +519,6 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
! support multiple spc coefficient files for any given sensor
if(amsua .or. amsub .or. mhs)then
quiet=.not.verbose
- allocate(data1b8x(nchanl))
spc_coeff_versions = 0
spc_coeff_found = .true.
do while (spc_coeff_found)
@@ -674,7 +673,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
terrain = 50._r_kind
if(llll == 1)terrain = 0.01_r_kind*abs(bfr1bhdr(13))
crit0 = 0.01_r_kind + terrain
- if (llll > 1 ) crit0 = crit0 + r100 * float(llll)
+ if (llll > 1 ) crit0 = crit0 + r100 * real(llll,r_kind)
timeinflat=two
call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh)
call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh)
@@ -684,7 +683,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
if (llll > 1) then
sacv = nint(bfr1bhdr(14))
if (sacv > spc_coeff_versions) then
- write(6,*) 'READ_BUFRTOVS WARNING sacv greater than spc_coeff_versions'
+ write(6,*) 'READ_BUFRTOVS WARNING sacv greater than spc_coeff_versions',' ',jsatid,' ',obstype
end if
else ! normal feed doesn't have antenna correction, so set sacv to 0
sacv = 0
@@ -700,7 +699,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
if(hirs .and. ((jsatid == 'n16') .or. (jsatid == 'n17'))) &
ifovmod=ifovmod+1
- panglr=(start+float(ifovmod-1)*step)*deg2rad
+ panglr=(start+real(ifovmod-1,r_kind)*step)*deg2rad
lzaest = asin(rato*sin(panglr))
if( msu .or. hirs2 .or. ssu)then
lza = lzaest
@@ -748,13 +747,15 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
! unless the satellite is n15 or n16, because tranamsua
! does this conversion because the coefficient files exist
! for it to use
- data1b8x=data1b8
data1b4=data1b8
!call apply_antcorr(accoeff_sets(spc_coeff_versions),ifov,data1b4)
call apply_antcorr(accoeff_sets(1),ifov,data1b4)
- data1b8=data1b4
do j=1,nchanl
- if(data1b8x(j) > r1000) data1b8(j) = 1000000._r_kind
+ if(data1b8(j) > r1000)then
+ data1b8(j) = 1000000._r_kind
+ else
+ data1b8(j) = data1b4(j)
+ end if
end do
end if
else ! EARS / DB
@@ -766,14 +767,16 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
! data originator,
! then convert back to brightness temperature using the version
! of parameters used by the CRTM
- data1b8x=data1b8
data1b4=data1b8
call remove_antcorr(accoeff_sets(sacv),ifov,data1b4)
!call apply_antcorr(accoeff_sets(spc_coeff_versions),ifov,data1b4)
call apply_antcorr(accoeff_sets(1),ifov,data1b4)
- data1b8=data1b4
do j=1,nchanl
- if(data1b8x(j) > r1000) data1b8(j) = 1000000._r_kind
+ if(data1b8(j) > r1000) then
+ data1b8(j) = 1000000._r_kind
+ else
+ data1b8(j)=data1b4(j)
+ end if
end do
end if
end if
@@ -785,12 +788,14 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
else ! EARS / DB
call ufbrep(lnbufr,data1b8,1,nchanl,iret,'TMBRST')
if ( amsua .or. amsub .or. mhs )then
- data1b8x=data1b8
data1b4=data1b8
call remove_antcorr(accoeff_sets(1),ifov,data1b4)
- data1b8=data1b4
do j=1,nchanl
- if(data1b8x(j) > r1000)data1b8(j) = 1000000._r_kind
+ if(data1b8(j) > r1000)then
+ data1b8(j) = 1000000._r_kind
+ else
+ data1b8(j) = data1b4(j)
+ end if
end do
end if
end if
@@ -816,7 +821,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
end do
if (iskip >= nchanl) cycle read_loop
! Map obs to thinning grid
- crit1 = crit1 + 10._r_kind*float(iskip)
+ crit1 = crit1 + 10._r_kind*real(iskip,r_kind)
call checkob(dist1,crit1,itx,iuse)
if(.not. iuse)cycle read_loop
@@ -1053,8 +1058,6 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
call closbf(lnbufr)
close(lnbufr)
- if (allocated(data1b8x)) deallocate(data1b8x)
-
end do ears_db_loop
deallocate(data1b8,data1b4)
@@ -1080,6 +1083,11 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,&
call count_obs(ndata,nele,ilat,ilon,data_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
write(lunout) ((data_all(k,n),k=1,nele),n=1,ndata)
+! write(6,*)'emily checking jsatid = ', jsatid
+! write(6,*)'emily checking nread = ', nread
+! write(6,*)'emily checking ndata = ', ndata
+! write(6,*)'emily checking ndata*nchanl = ', ndata*nchanl
+! write(6,*)'emily checking nodata = ', nodata
end if
! Deallocate local arrays
diff --git a/src/gsi/read_cris.f90 b/src/gsi/read_cris.f90
index a257480c9a..d5668f8864 100644
--- a/src/gsi/read_cris.f90
+++ b/src/gsi/read_cris.f90
@@ -93,6 +93,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth,gsi_nstcoupler_deter
use mpimod, only: npe
use gsi_io, only: verbose
+ use qcmod, only: cris_cads
! use radiance_mod, only: rad_obs_type
implicit none
@@ -145,7 +146,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
character(len=40) :: infile2
integer(i_kind) :: kidsat, ksatid
integer(i_kind) :: iret,ireadsb,ireadmg,irec,next, nrec_startx
- integer(i_kind) :: bufr_nchan,maxinfo
+ integer(i_kind) :: bufr_nchan,maxinfo,dval_info
integer(i_kind),allocatable,dimension(:)::nrec
@@ -178,8 +179,8 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
logical :: outside,iuse,assim,valid,clear
logical :: cris,quiet
- integer(i_kind) :: ifov, ifor, iscn, instr, ioff, ilat, ilon, sensorindex
- integer(i_kind) :: i, l, iskip, bad_line, llll
+ integer(i_kind) :: ifov, ifor, iscn, instr, ioff, ilat, ilon, sensorindex_cris
+ integer(i_kind) :: i, j, l, iskip, bad_line, llll
integer(i_kind) :: nreal, isflg
integer(i_kind) :: itx, k, nele, itt, n
integer(i_kind):: idomsfc(1)
@@ -187,7 +188,23 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
integer(i_kind):: error_status, irecx,ierr
integer(i_kind):: radedge_min, radedge_max
integer(i_kind):: bufr_size
- character(len=20),dimension(1):: sensorlist
+ character(len=20),allocatable,dimension(:) :: sensorlist
+
+! Imager cluster information for CADS
+ integer(i_kind) :: iexponent, sensorindex_imager, cads_info
+ integer(i_kind),dimension(7) :: imager_cluster_index
+ logical :: imager_coeff
+ logical,dimension(7) :: imager_cluster_flag
+ character(len=80) :: spc_filename
+ character(len=20) :: sensorlist_imager
+ real(r_kind),dimension(83,7) :: imager_info
+ real(r_kind),dimension(7) :: imager_cluster_size
+ real(r_kind),dimension(2) :: imager_mean, imager_std_dev, imager_conversion
+ real(r_kind) :: imager_cluster_tot
+
+! bufr error codes
+! real(r_kind),dimension(7,3) :: error_codes
+
! scan angle calculation geometry based on:
! C. Root 2014: JPSS Ground Project Code 474-00032
@@ -209,6 +226,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
! Set standard parameters
character(8),parameter:: fov_flag="crosstrk"
integer(i_kind),parameter:: sfc_channel=501 !used in thinning routine if cloud informatino is not available
+ integer(i_kind),parameter:: band_2_start=714 !for CADS, if any of band 1 (chans 1 - 713) are missing, reject profile
integer(i_kind),parameter:: ichan=-999 ! fov-based surface code is not channel specific for cris
real(r_kind),parameter:: expansion=one ! exansion factor for fov-based surface code.
! use one for ir sensors.
@@ -227,8 +245,12 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
maxinfo = 31
disterrmax=zero
ntest=0
- if(dval_use) maxinfo = maxinfo + 2
- nreal = maxinfo + nstinfo
+ dval_info = 0
+ if(dval_use) dval_info = 2
+ cads_info = 0
+ if(cris_cads) cads_info = 23
+ nreal = maxinfo + cads_info + dval_info + nstinfo
+
ndata = 0
nodata = 0
cris= obstype == 'cris' .or. obstype == 'cris-fsr'
@@ -301,46 +323,93 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
'SAID YEAR MNTH DAYS HOUR MINU SECO CLATH CLONH SAZA BEARAZ SOZA SOLAZI'
! Load spectral coefficient structure
- sensorlist(1)=sis
quiet=.not. verbose
+
+ imager_coeff = .false.
+!TODO spc_filename = trim(crtm_coeffs_path)//'viirs-m_'//trim(jsatid)//'.SpcCoeff.bin' ! when viirs naming convention becomes standarized
+ if ( trim(jsatid) == 'npp' ) then
+ spc_filename = trim(crtm_coeffs_path)//'viirs-m_npp.SpcCoeff.bin'
+ sensorlist_imager = 'viirs-m_npp'
+ elseif ( trim(jsatid) == 'n20' ) then
+ spc_filename = trim(crtm_coeffs_path)//'viirs-m_n20.SpcCoeff.bin'
+ sensorlist_imager = 'viirs-m_n20'
+ inquire(file=trim(spc_filename), exist=imager_coeff)
+ if ( .not. imager_coeff ) then
+ spc_filename = trim(crtm_coeffs_path)//'viirs-m_j1.SpcCoeff.bin'
+ sensorlist_imager = 'viirs-m_j1'
+ endif
+ elseif ( trim(jsatid) == 'n21' ) then
+ spc_filename = trim(crtm_coeffs_path)//'viirs-m_n21.SpcCoeff.bin'
+ sensorlist_imager = 'viirs-m_n21'
+ inquire(file=trim(spc_filename), exist=imager_coeff)
+ if ( .not. imager_coeff ) then
+ spc_filename = trim(crtm_coeffs_path)//'viirs-m_j2.SpcCoeff.bin'
+ sensorlist_imager = 'viirs-m_j2'
+ endif
+ endif
+ inquire(file=trim(spc_filename), exist=imager_coeff)
+ if ( imager_coeff ) then
+ allocate( sensorlist(2))
+ sensorlist(1) = sis
+!TODO sensorlist(2) = 'viirs-m_'//trim(jsatid) !when viirs naming conventions becomes standardized
+ sensorlist(2) = trim(sensorlist_imager)
+ else
+ allocate( sensorlist(1))
+ sensorlist(1) = sis
+ endif
+
if( crtm_coeffs_path /= "" ) then
if(mype_sub==mype_root .and. print_verbose) write(6,*)'READ_CRIS: crtm_spccoeff_load() on path "'//trim(crtm_coeffs_path)//'"'
error_status = crtm_spccoeff_load(sensorlist,&
- File_Path = crtm_coeffs_path,quiet=quiet )
+ File_Path = crtm_coeffs_path,quiet=quiet)
else
error_status = crtm_spccoeff_load(sensorlist,quiet=quiet)
endif
if (error_status /= success) then
write(6,*)'READ_CRIS: ***ERROR*** crtm_spccoeff_load error_status=',error_status,&
- ' TERMINATE PROGRAM EXECUTION'
+ ' TERMINATE PROGRAM EXECUTION'
call stop2(71)
endif
+! find CRIS sensorindex.
+ sensorindex_cris = 0
+ if ( sc(1)%sensor_id(1:4) == 'cris' )then
+ sensorindex_cris = 1
+ else
+ write(6,*)'READ_CRIS: ***ERROR*** sensorindex_cris not set NO CRIS DATA USED'
+ write(6,*)'READ_CRIS: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION'
+ call stop2(71)
+ end if
+
+! find imager sensorindex.
+ sensorindex_imager = 0
+ if ( cris_cads .and. imager_coeff ) then
+ if ( sc(2)%sensor_id(1:4) == 'viir' )then
+ sensorindex_imager = 2
+ else
+ write(6,*)'READ_CRIS: ***ERROR*** sensorindex_viirs not set NO VIIRS CLUSTER INFO USED BY CADS'
+ write(6,*)'READ_CRIS: We are looking for ', sc(2)%sensor_id, ' TERMINATE PROGRAM EXECUTION'
+ imager_coeff = .false.
+ end if
+ else
+ imager_coeff = .false.
+ end if
+
! Find the channels being used (from satinfo file) in the spectral coef. structure.
do i=subset_start,subset_end
channel_number(i -subset_start +1) = nuchan(i)
end do
sc_index(:) = 0
satinfo_chan: do i=1,satinfo_nchan
- spec_coef: do l=1,sc(1)%n_channels
- if ( channel_number(i) == sc(1)%sensor_channel(l) ) then
+ spec_coef: do l=1,sc(sensorindex_cris)%n_channels
+ if ( channel_number(i) == sc(sensorindex_cris)%sensor_channel(l) ) then
sc_index(i) = l
exit spec_coef
endif
end do spec_coef
end do satinfo_chan
-! find CRIS sensorindex.
- sensorindex = 0
- if ( sc(1)%sensor_id(1:4) == 'cris' )then
- sensorindex = 1
- else
- write(6,*)'READ_CRIS: ***ERROR*** sensorindex not set NO CRIS DATA USED'
- write(6,*)'READ_CRIS: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION'
- call stop2(71)
- end if
-
! Calculate parameters needed for FOV-based surface calculation.
if (isfcalc==1)then
instr=17 ! CrIS is similar to AIRS for this purpose.
@@ -582,7 +651,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
! Increment nread counter by bufr_nchan (should be changed to number of channels in satinfo file? (satinfo_nchan))
nread = nread + satinfo_nchan
crit0 = 0.01_r_kind
- if( llll > 1 ) crit0 = crit0 + r100 * float(llll)
+ if( llll > 1 ) crit0 = crit0 + r100 * real(llll,r_kind)
timeinflat=6.0_r_kind
call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh)
call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh)
@@ -600,8 +669,8 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
if( ifor <= 15 ) sat_zenang = -sat_zenang
! Compute scan angle including sensor twist.
- look_angle_est = (start + float((ifor-1))*step) * deg2rad + &
- fov_dist(ifov) * sin(fov_ang(ifov) - float(ifor-1)*step*deg2rad)
+ look_angle_est = (start + real((ifor-1),r_kind)*step) * deg2rad + &
+ fov_dist(ifov) * sin(fov_ang(ifov) - real(ifor-1,r_kind)*step*deg2rad)
sat_look_angle=asin(rato*sin(sat_zenang*deg2rad))
if(abs(sat_look_angle)*rad2deg > MAX_SENSOR_ZENITH_ANGLE) then
@@ -687,7 +756,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
clear = .false.
pred = zero
-! Cloud information may be missing depending on how the VIIRS granules align
+! Cloud information may be missing depending on how the imager granules align
! with the CrIS granules.
! Cloud Amount, TOCC is total cloud cover [%], HOCT is cloud height [m]
call ufbint(lnbufr,cloud_properties,2,1,iret,'TOCC HOCT')
@@ -699,7 +768,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
else
pred1 = cloud_properties(2) *7.0_r_kind / r1000 ! Assume a lapse rate to convert hgt to delta TB.
radiance = allchan(2,sfc_channel_index) * r1000 ! Conversion from W to mW
- call crtm_planck_temperature(sensorindex,sfc_channel,radiance,temperature(sfc_channel_index)) ! radiance to BT calculation
+ call crtm_planck_temperature(sensorindex_cris,sfc_channel,radiance,temperature(sfc_channel_index)) ! radiance to BT calculation
pred2 = tsavg *0.98_r_kind - temperature(sfc_channel_index)
pred = max(pred1,pred2) ! use the largest of lapse rate (pred1) or sfc channel-surface difference (pred2)
endif
@@ -709,7 +778,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
! the surface channel is fixed and set earlier in the code (501).
radiance = allchan(2,sfc_channel_index) * r1000 ! Conversion from W to mW
- call crtm_planck_temperature(sensorindex,sfc_channel,radiance,temperature(sfc_channel_index)) ! radiance to BT calculation
+ call crtm_planck_temperature(sensorindex_cris,sfc_channel,radiance,temperature(sfc_channel_index)) ! radiance to BT calculation
if (temperature(sfc_channel_index) > tbmin .and. temperature(sfc_channel_index) < tbmax ) then
if ( tsavg*0.98_r_kind <= temperature(sfc_channel_index)) then ! 0.98 is a crude estimate of the surface emissivity
clear = .true.
@@ -743,7 +812,7 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
! now such spectra are rejected.
if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds
radiance = allchan(2,bufr_chan) * r1000 ! Conversion from W to mW
- call crtm_planck_temperature(sensorindex,sc_chan,radiance,temperature(bufr_chan)) ! radiance to BT calculation
+ call crtm_planck_temperature(sensorindex_cris,sc_chan,radiance,temperature(bufr_chan)) ! radiance to BT calculation
else ! error with channel number or radiance
temperature(bufr_chan) = tbmin
endif
@@ -756,14 +825,14 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
bufr_chan = bufr_index(i)
if(temperature(bufr_chan) <= tbmin .or. temperature(bufr_chan) >= tbmax ) then
temperature(bufr_chan) = tbmin
- if(iuse_rad(ioff+i) >= 0) iskip = iskip + 1
+ if(iuse_rad(ioff+i) >= 0 .or. (cris_cads .and. sc_index(i) < band_2_start)) iskip = iskip + 1
endif
end do skip_loop
if(iskip > 0 .and. print_verbose)write(6,*) ' READ_CRIS : iskip > 0 ',iskip
-! if( iskip >= 10 )cycle read_loop
+ if( iskip >= 10 .and. cris_cads ) cycle read_loop
- crit1=crit1 + ten*float(iskip)
+ crit1=crit1 + ten*real(iskip,r_kind)
! Final map obs to grids
if ( clear ) then
@@ -772,9 +841,86 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
call finalcheck(one,crit1,itx,iuse)
endif
if(.not. iuse)cycle read_loop
-!
+
+! Read the imager cluster information for the Cloud and Aerosol Detection Software.
+! Only channels 15 and 16 are used.
+
+ if ( cris_cads ) then
+ call ufbseq(lnbufr,imager_info,83,7,iret,'CRISCS')
+ if ( iret == 7 .and. imager_info(3,1) <= 100.0_r_kind .and. &
+ imager_info(3,1) >= zero .and. imager_coeff ) then ! if imager cluster info exists
+ imager_mean = zero
+ imager_std_dev = zero
+ imager_cluster_tot = zero
+ imager_cluster_flag = .TRUE.
+ imager_cluster_size = imager_info(3,1:7)
+ imager_cluster_size(:) = imager_cluster_size(:) / sum(imager_cluster_size(:))
+ imager_conversion(1) = one / (sc(sensorindex_imager)%wavenumber(4) **2)
+ imager_conversion(2) = one / (sc(sensorindex_imager)%wavenumber(5) **2)
+
+! Order clusters from largest (1) to smallest (7)
+ imager_cluster_sort: do i=1,7
+ j = maxloc(imager_cluster_size,dim=1,mask=imager_cluster_flag)
+ imager_cluster_index(i) = j
+ imager_cluster_flag(j) = .FALSE.
+ end do imager_cluster_sort
+
+! Convert from radiance to brightness temperature for mean and standard devation used by CADS
+! Imager cluster info added to data_all array.
+
+ imager_cluster_info: do j=1,7
+ i = imager_cluster_index(j)
+
+ data_all(maxinfo+j,itx) = imager_cluster_size(i) ! Imager cluster fraction
+ imager_cluster_tot = imager_cluster_tot + imager_info(3,i)
+
+ iexponent = -(nint(imager_info(75,i)) -11) ! channel 15 radiance for each cluster
+ imager_info(76,i) = imager_info(76,i) * imager_conversion(1) * (ten ** iexponent)
+
+ iexponent = -(nint(imager_info(77,i)) -11) ! channel 15 radiance std dev for each cluster.
+ imager_info(78,i) = imager_info(78,i) * imager_conversion(1) * (ten ** iexponent)
+
+ call crtm_planck_temperature(sensorindex_imager,4,imager_info(76,i),data_all(maxinfo+7+j,itx))
+ data_all(maxinfo+7+j,itx) = max(data_all(maxinfo+7+j,itx),zero)
+
+ iexponent = -(nint(imager_info(80,i)) -11) ! channel 16 radiance for each cluster
+ imager_info(81,i) = imager_info(81,i) * imager_conversion(2) * (ten ** iexponent)
+
+ iexponent = -(nint(imager_info(82,i))-5 ) ! channel 16 radiance std dev for each cluster.
+ iexponent = -(nint(imager_info(82,i)) -11) ! channel 16 radiance std dev for each cluster.
+ imager_info(83,i) = imager_info(83,i) * imager_conversion(2) * (ten ** iexponent)
+
+ call crtm_planck_temperature(sensorindex_imager,5,imager_info(81,i),data_all(maxinfo+14+j,itx))
+ data_all(maxinfo+14+j,itx) = max(data_all(maxinfo+14+j,itx),zero)
+
+
+ end do imager_cluster_info
+
+! Compute cluster averages for each channel
+
+ imager_mean(1) = sum(imager_cluster_size(:) * imager_info(76,:)) ! Channel 15 radiance cluster average
+ imager_std_dev(1) = sum(imager_cluster_size(:) * (imager_info(76,:)**2 + imager_info(78,:)**2)) - imager_mean(1)**2
+ imager_std_dev(1) = sqrt(max(imager_std_dev(1),zero)) ! Channel 15 radiance RMSE
+ call crtm_planck_temperature(sensorindex_imager,4,(imager_std_dev(1) + imager_mean(1)),imager_std_dev(1))
+ call crtm_planck_temperature(sensorindex_imager,4,imager_mean(1),imager_mean(1)) ! Channel 15 average BT
+ imager_std_dev(1) = imager_std_dev(1) - imager_mean(1) ! Channel 15 BT std dev
+ data_all(maxinfo+22,itx) = imager_std_dev(1)
+
+ imager_mean(2) = sum(imager_cluster_size(:) * imager_info(81,:)) ! Channel 16 radiance cluster average
+ imager_std_dev(2) = sum(imager_cluster_size(:) * (imager_info(81,:)**2 + imager_info(83,:)**2)) - imager_mean(1)**2
+ imager_std_dev(2) = sqrt(max(imager_std_dev(1),zero)) ! Channel 16 radiance RMSE
+ call crtm_planck_temperature(sensorindex_imager,5,(imager_std_dev(2) + imager_mean(2)),imager_std_dev(2))
+ call crtm_planck_temperature(sensorindex_imager,5,imager_mean(2),imager_mean(2)) ! Channel 16 average BT
+ imager_std_dev(2) = imager_std_dev(2) - imager_mean(2) ! Channel 16 BT std dev
+ data_all(maxinfo+23,itx) = imager_std_dev(2)
+
+ else ! Imager cluster information is missing. Set everything to zero
+ data_all(maxinfo+1 : maxinfo+25,itx) = zero
+ endif
+ endif ! cris_cads
+
! interpolate NSST variables to Obs. location and get dtw, dtc, tz_tr
-!
+
if ( nst_gsi > 0 ) then
tref = ts(0)
dtw = zero
@@ -818,15 +964,17 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
data_all(31,itx)= dlat_earth_deg ! earth relative latitude (degrees)
if(dval_use) then
- data_all(32,itx)= val_cris
- data_all(33,itx)= itt
+ data_all(maxinfo+cads_info+1,itx)= val_cris
+ data_all(maxinfo+cads_info+2,itx)= itt
+! data_all(32+cads_info,itx)= val_cris
+! data_all(33+cads_info,itx)= itt
end if
if ( nst_gsi > 0 ) then
- data_all(maxinfo+1,itx) = tref ! foundation temperature
- data_all(maxinfo+2,itx) = dtw ! dt_warm at zob
- data_all(maxinfo+3,itx) = dtc ! dt_cool at zob
- data_all(maxinfo+4,itx) = tz_tr ! d(Tz)/d(Tr)
+ data_all(maxinfo+cads_info+dval_info+1,itx) = tref ! foundation temperature
+ data_all(maxinfo+cads_info+dval_info+2,itx) = dtw ! dt_warm at zob
+ data_all(maxinfo+cads_info+dval_info+3,itx) = dtc ! dt_cool at zob
+ data_all(maxinfo+cads_info+dval_info+4,itx) = tz_tr ! d(Tz)/d(Tr)
endif
! Put satinfo defined channel temperatures into data array
diff --git a/src/gsi/read_dbz_nc.f90 b/src/gsi/read_dbz_nc.f90
index 89eebde8b6..f06545afa1 100644
--- a/src/gsi/read_dbz_nc.f90
+++ b/src/gsi/read_dbz_nc.f90
@@ -69,15 +69,16 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
use kinds, only: r_kind,r_double,i_kind,r_single
use constants, only: zero,half,one,two,deg2rad,rad2deg, &
one_tenth,r1000,r60,r60inv,r100,r400,grav_equator, &
- eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening
+ eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening,r_missing
use gridmod, only: tll2xy,nsig,nlat,nlon
- use obsmod, only: iadate,doradaroneob, &
+ use obsmod, only: iadate,doradaroneob,oneoblat,oneoblon,oneobheight, &
mintiltdbz,maxtiltdbz,minobrangedbz,maxobrangedbz,&
- static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz
+ static_gsi_nopcp_dbz,rmesh_dbz,zmesh_dbz,pmot_dbz,reduce_diag
+ use gsi_4dvar, only: iwinbgn
use hybrid_ensemble_parameters,only : l_hyb_ens
use obsmod,only: radar_no_thinning,missing_to_nopcp
use convinfo, only: nconvtype,ctwind,icuse,ioctype
- use convthin, only: make3grids,map3grids,del3grids,use_all
+ use convthin, only: make3grids,map3grids_m,del3grids,use_all
use jfunc, only: miter
use mpimod, only: npe
implicit none
@@ -133,27 +134,28 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
real(r_kind), allocatable, dimension(:) :: zl_thin
real(r_kind),dimension(nsig):: hges,zges
real(r_kind) sin2,termg,termr,termrg,zobs,hgt
- integer(i_kind) ntmp,iout,iiout,ntdrvr_thin2
+ integer(i_kind) iout,ntdrvr_thin2
real(r_kind) crit1,timedif
real(r_kind),parameter:: r16000 = 16000.0_r_kind
logical :: luse
- integer(i_kind) maxout,maxdata
- integer(i_kind),allocatable,dimension(:):: isort
!--General declarations
- integer(i_kind) :: ierror,i,j,k,nvol, &
- ikx,mins_an
+ integer(i_kind) :: ierror,i,j,k,ikx,mins_an
integer(i_kind) :: maxobs,nchanl,ilat,ilon,scount
real(r_kind) :: thistiltr,thisrange,this_stahgt,thishgt
- real(r_kind) :: thisazimuthr,t4dv, &
+ real(r_kind) :: thisazimuthr, &
dlat,dlon,thiserr,thislon,thislat, &
timeb
real(r_kind) :: radartwindow
- real(r_kind) :: rmins_an
+ real(r_kind) :: rmins_an,usage
real(r_kind),allocatable,dimension(:,:):: cdata_all
real(r_double) rstation_id
+ logical, allocatable,dimension(:) :: rusage,rthin
+ logical save_all
+! integer(i_kind) numthin,numqc,numrem,numall
+ integer(i_kind) nxdata,pmot
character(8) cstaid
character(4) this_staid
@@ -217,19 +219,15 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
maxobs=50000000 !value taken from read_radar.f90
!--Allocate cdata_all array
- allocate(cdata_all(maxdat,maxobs),isort(maxobs))
- rmesh=rmesh_dbz
- zmesh=zmesh_dbz
+ allocate(cdata_all(maxdat,maxobs),rthin(maxobs),rusage(maxobs))
+ rmesh=rmesh_dbz
+ zmesh=zmesh_dbz
+ ntdrvr_thin2=0
+ icntpnt=0
+ zflag=0
- maxout=0
- maxdata=0
- isort=0
- ntdrvr_thin2=0
- icntpnt=0
- zflag=0
-
- use_all=.true.
+ use_all=.true.
if (ithin > 0) then
write(6,*)'READ_RADAR_DBZ: ithin,rmesh :',ithin,rmesh
use_all=.false.
@@ -240,7 +238,6 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
endif
xmesh=rmesh
call make3grids(xmesh,nlevz)
-! call make3grids2(xmesh,nlevz)
allocate(zl_thin(nlevz))
if (zflag == 1) then
@@ -303,6 +300,8 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
dbzQC = data_r_3d
+ deallocate(data_r_3d)
+
else if( ivar == 2 )then
allocate( data_r_1d(dims(ivar,1)) )
@@ -337,14 +336,22 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
call w3fs21(iadate,mins_an) !mins_an -integer number of mins snce 01/01/1978
rmins_an=mins_an !convert to real number
+ timeb=real(mins_an-iwinbgn,r_kind) !assume all observations are at the analysis time
ivar = 1
-
+ pmot=pmot_dbz
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
+ rusage = .true.
+ rthin = .false.
+
ILOOP : &
do i = 1, dims(ivar,1)
do j = 1, dims(ivar,2)
do k = 1, dims(ivar,3)
+
imissing2nopcp = 0
! Missing data in the input file have the value -999.0
if( dbzQC(i,j,k) <= -900.0_r_kind ) then
@@ -380,6 +387,12 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
thislon = lon(i,j)
thislat = lat(i,j)
+
+ if(doradaroneob) then
+ thislat=oneoblat
+ thislon=oneoblon
+ thishgt=oneobheight
+ endif
!-Check format of longitude and correct if necessary
@@ -404,13 +417,23 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
! changed to hard-coded value for now; dbznoise used for two different purposes in this subroutine:
! (1) threshold for lowest reflectivity value considered to be an observation and
! (2) ob error
- thiserr = 5.0_r_kind
-
-
+
+! Specify a larger error standard deviation for reflectivity observations in precipitation
+! than for reflectivity observations that indicate a lack of preciptation.
+ if( dbzQC(i,j,k) < 5.0_r_kind ) then
+ thiserr = 5.0_r_kind
+ else
+ thiserr = 10.0_r_kind
+ end if
+
nread = nread + 1
+ usage=zero
+ if(icuse(ikx) < zero)usage=r100
!#################### Data thinning ###################
icntpnt=icntpnt+1
+ if(icntpnt>maxobs) exit
+
if(ithin > 0)then
@@ -445,36 +468,28 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
zobs = hgt
- ntmp=ndata ! counting moved to map3gridS
- timedif=abs(t4dv) !don't know about this
+ timedif=zero ! assume all observations are at the analysis time
crit1 = timedif/r6+half
- call map3grids(1,zflag,zl_thin,nlevz,thislat,thislon,&
- zobs,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.)
-
-
- maxout=max(maxout,iout)
- maxdata=max(maxdata,ndata)
-
+ call map3grids_m(1,save_all,zflag,zl_thin,nlevz, &
+ thislat,thislon,zobs,crit1,ndata,&
+ luse,maxobs,rthin,.false.,.false.)
+
if (.not. luse) then
ntdrvr_thin2=ntdrvr_thin2+1
cycle
endif
- if(iiout > 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+1
- endif
- isort(icntpnt)=iout
else
ndata =ndata+1
- nodata=nodata+1
- iout=ndata
- isort(icntpnt)=iout
endif
+ iout=ndata
!!end modified for thinning
- thisazimuthr=0.0_r_kind
+ thisazimuthr=r_missing
+ thistiltr=r_missing
+ this_stahgt=r_missing
+ thisrange=r_missing
this_staid=radid !Via equivalence in declaration, value is propagated
! to rstation_id used below.
cdata_all(1,iout) = thiserr ! reflectivity obs error (dB) - inflated/adjusted
@@ -484,7 +499,7 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
cdata_all(5,iout) = dbzQC(i,j,k) ! radar reflectivity factor
cdata_all(6,iout) = thisazimuthr ! 90deg-azimuth angle (radians)
- cdata_all(7,iout) = timeb*r60inv ! obs time (analyis relative hour)
+ cdata_all(7,iout) = timeb*r60inv ! obs time (relative hour from beginning of the DA window)
cdata_all(8,iout) = ikx ! type
cdata_all(9,iout) = thistiltr ! tilt angle (radians)
cdata_all(10,iout)= this_stahgt ! station elevation (m)
@@ -500,13 +515,57 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
cdata_all(17,iout)= dbznoise ! noise threshold for reflectivity (dBZ)
cdata_all(18,iout)= imissing2nopcp !=0, normal
!=1, !values !converted !from !missing !values
-
+ if(usage >= r100)rusage(ndata)=.false.
+
if(doradaroneob .and. (cdata_all(5,iout) > -99.0_r_kind) ) exit ILOOP
end do ! k
end do ! j
end do ILOOP ! i
+ nxdata=ndata
+ ndata=0
+ if(nxdata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,ndata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' dbz ',numall,numrem,numqc,numthin
+
+! If flag to not save thinned data is set - compress data
+ if(pmot /= 1)then
+ do i=1,nxdata
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ ndata=ndata+1
+ if(i > ndata)then
+ do k=1,maxdat
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
+ end if
+ end do
+ end if
+ end if
+
+ nodata=nodata+nxdata
+
+ deallocate(dbzQC,lat,lon)
+
if (.not. use_all) then
deallocate(zl_thin)
call del3grids
@@ -514,7 +573,6 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
!---all looping done now print diagnostic output
write(6,*)'READ_dBZ: Reached eof on radar reflectivity file'
- write(6,*)'READ_dBZ: # volumes in input file =',nvol
write(6,*)'READ_dBZ: # read in obs. number =',nread
write(6,*)'READ_dBZ: # elevations outside time window =',numbadtime
write(6,*)'READ_dBZ: # of noise obs to no precip obs =',num_nopcp
@@ -533,10 +591,10 @@ subroutine read_dbz_nc(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,no
!---------------DEALLOCATE ARRAYS-------------!
- deallocate(cdata_all)
else !fileopen
write(6,*) 'READ_dBZ: ERROR OPENING RADAR REFLECTIVITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...'
end if fileopen
+deallocate(cdata_all,rusage,rthin)
end subroutine read_dbz_nc
diff --git a/src/gsi/read_dbz_netcdf.f90 b/src/gsi/read_dbz_netcdf.f90
index 6ea03afaff..193449b460 100644
--- a/src/gsi/read_dbz_netcdf.f90
+++ b/src/gsi/read_dbz_netcdf.f90
@@ -170,9 +170,9 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob
integer(i_kind) :: num_missing=0,num_nopcp=0, & !counts
numbadtime=0,num_badtilt=0, &
num_badrange=0,num_m2nopcp=0, &
- num_noise=0,num_limmax=0 ,num_limmin=0
-
-
+ num_noise=0,num_limmax=0 ,num_limmin=0
+
+
!--General declarations
integer(i_kind) :: ierror,lunrad,i,j,k,v,na,nb,nelv,nvol, &
@@ -185,7 +185,7 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob
real(r_kind) :: thistiltr,selev0,celev0,thisrange,this_stahgt,thishgt
real(r_kind) :: celev,selev,gamma,thisazimuthr,rlon0, &
clat0,slat0,dlat,dlon,thiserr,thislon,thislat, &
- rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter
+ rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter
real(r_kind) :: radartwindow
real(r_kind) :: dbzerr,rmins_an,rmins_ob
real(r_kind),allocatable,dimension(:,:):: cdata_all
@@ -203,7 +203,7 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob
!---------SETTINGS FOR FUTURE NAMELIST---------!
integer(i_kind) :: maxobrange=999000 ! Range (m) *within* which to use observations - obs *outside* this range are not used
integer(i_kind) :: minobrange=-999 ! Range (m) *outside* of which to use observatons - obs *inside* this range are not used
- real(r_kind) :: mintilt=0.0_r_kind ! Only use tilt(elevation) angles (deg) >= this number
+ real(r_kind) :: mintilt=0.0_r_kind ! Only use tilt(elevation) angles (deg) >= this number
real(r_kind) :: maxtilt=20.0_r_kind ! Do no use tilt(elevation) angles (deg) >= this number
logical :: missing_to_nopcp=.false. ! Set missing observations to 'no precipitation' observations -> dbznoise (See Aksoy et al. 2009, MWR)
real(r_kind) :: dbznoise=2.0_r_kind ! dBZ obs must be >= dbznoise for assimilation
@@ -223,9 +223,7 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob
real(r_single), allocatable :: azimuth_nc(:),beamwidth_nc(:),azimspacing_nc(:),gatewidth_nc(:)
-real(r_single), allocatable :: nyquist_nc(:),obdata_nc(:,:)
-real(r_single) nyquist_default_nc
-parameter(nyquist_default_nc=50.0_r_kind)
+real(r_single), allocatable :: obdata_nc(:,:)
!clg
! ! due to representativeness error associated with the model
!----------------------------------------------!
@@ -241,13 +239,13 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob
if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then
ikx=i
radartwindow=ctwind(ikx)*r60 !Time window units converted to minutes
- ! (default setting for dbz within convinfo is 0.05 hours)
- dbzerr=5_r_kind !Ob error (dB) to use for radar reflectivity factor
- exit !Exit loop when finished with initial convinfo fields
+ ! (default setting for dbz within convinfo is 0.05 hours)
+ dbzerr=5_r_kind !Ob error (dB) to use for radar reflectivity factor
+ exit !Exit loop when finished with initial convinfo fields
else if ( i==nconvtype ) then
write(6,*) 'READ_dBZ: ERROR - OBSERVATION TYPE IS NOT PRESENT IN CONVINFO OR USE FLAG IS ZERO'
- write(6,*) 'READ_dBZ: ABORTTING read_dbz.f90 - NO REFLECTIVITY OBS READ!'
- return
+ write(6,*) 'READ_dBZ: ABORTTING read_dbz.f90 - NO REFLECTIVITY OBS READ!'
+ return
endif
end do
@@ -327,7 +325,7 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob
!reverse order of dimensions as stated in ncdump:
allocate(azimuth_nc(numazim_nc),beamwidth_nc(numazim_nc),azimspacing_nc(numazim_nc),gatewidth_nc(numazim_nc))
-allocate(nyquist_nc(numazim_nc),obdata_nc(numgate_nc,numazim_nc))
+allocate(obdata_nc(numgate_nc,numazim_nc))
ierr = NF90_GET_VAR(ncid,varid1,azimuth_nc)
if (ierr /= nf90_noerr) call handle_err(ierr,"azimuth data")
@@ -420,12 +418,12 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob
obdate(1)=strct_in_dbz(v,k)%year
obdate(2)=strct_in_dbz(v,k)%month
- obdate(3)=strct_in_dbz(v,k)%day
+ obdate(3)=strct_in_dbz(v,k)%day
obdate(4)=strct_in_dbz(v,k)%hour
obdate(5)=strct_in_dbz(v,k)%minute
call w3fs21(obdate,mins_ob) !mins_ob -integer number of mins snce 01/01/1978
- rmins_ob=mins_ob !convert to real number
- rmins_ob=rmins_ob+(strct_in_dbz(v,k)%second*r60inv) !convert seconds to minutes and add to ob time
+ rmins_ob=mins_ob !convert to real number
+ rmins_ob=rmins_ob+(strct_in_dbz(v,k)%second*r60inv) !convert seconds to minutes and add to ob time
!-Comparison is done in units of minutes
@@ -439,139 +437,140 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob
if (thistilt <= maxtilt .and. thistilt >= mintilt) then
gates: do i=1,strct_in_dbz(v,k)%num_gate
-
- thisrange=strct_in_dbz(v,k)%fstgatdis + float(i-1)*strct_in_dbz(v,k)%gateWidth
+
+ thisrange=strct_in_dbz(v,k)%fstgatdis + real(i-1,r_kind)*strct_in_dbz(v,k)%gateWidth
!-Check to make sure observations are within specified range
- if (thisrange <= maxobrange .and. thisrange >= minobrange) then
- azms: do j=1,strct_in_dbz(v,k)%num_beam
-
- !-Check to see if this is a missing observation
-
- nread=nread+1
-
+ if (thisrange <= maxobrange .and. thisrange >= minobrange) then
+ azms: do j=1,strct_in_dbz(v,k)%num_beam
+
+ !-Check to see if this is a missing observation
+
+ nread=nread+1
+
if ( abs(strct_in_dbz(v,k)%field(i,j)) >= 99.0_r_kind ) then
-
- !--Extend no precip observations to missing data fields?
+
+ !--Extend no precip observations to missing data fields?
! May help suppress spurious convection if a problem.
-
+
if (missing_to_nopcp) then
- strct_in_dbz(v,k)%field(i,j) = dbznoise
- num_m2nopcp = num_m2nopcp+1
- else
- num_missing=num_missing+1
- cycle azms !No reason to process the ob if it is missing
+ strct_in_dbz(v,k)%field(i,j) = dbznoise
+ num_m2nopcp = num_m2nopcp+1
+ else
+ num_missing=num_missing+1
+ cycle azms !No reason to process the ob if it is missing
end if
-
+
+ end if
+
+
+ if (l_limmax) then
+ if ( strct_in_dbz(v,k)%field(i,j) > 60_r_kind ) then
+ strct_in_dbz(v,k)%field(i,j) = 60_r_kind
+ num_limmax=num_limmax+1
+ end if
end if
-
-
- if (l_limmax) then
- if ( strct_in_dbz(v,k)%field(i,j) > 60_r_kind ) then
- strct_in_dbz(v,k)%field(i,j) = 60_r_kind
- num_limmax=num_limmax+1
- end if
- end if
- if (l_limmin) then
- if ( strct_in_dbz(v,k)%field(i,j) < 0_r_kind ) then
- strct_in_dbz(v,k)%field(i,j) = 0_r_kind
- num_limmin=num_limmin+1
- end if
- end if
-
- !--Find observation height using method from read_l2bufr_mod.f90
-
- this_stahgt=strct_in_dbz(v,k)%radhgt
+ if (l_limmin) then
+ if ( strct_in_dbz(v,k)%field(i,j) < 0_r_kind ) then
+ strct_in_dbz(v,k)%field(i,j) = 0_r_kind
+ num_limmin=num_limmin+1
+ end if
+ end if
+
+ !--Find observation height using method from read_l2bufr_mod.f90
+
+ this_stahgt=strct_in_dbz(v,k)%radhgt
aactual=rearth+this_stahgt
a43=four_thirds*aactual
thistiltr=thistilt*deg2rad
selev0=sin(thistiltr)
- celev0=cos(thistiltr)
- b=thisrange*(thisrange+two*aactual*selev0)
+ celev0=cos(thistiltr)
+ b=thisrange*(thisrange+two*aactual*selev0)
c=sqrt(aactual*aactual+b)
ha=b/(aactual+c)
epsh=(thisrange*thisrange-ha*ha)/(r8*aactual)
h=ha-epsh
- thishgt=this_stahgt+h
-
- !--Find observation location using method from read_l2bufr_mod.f90
-
- !-Get corrected tilt angle
- celev=celev0
- selev=selev0
- celev=a43*celev0/(a43+h)
- selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h))
-
- gamma=half*thisrange*(celev0+celev)
-
+ thishgt=this_stahgt+h
+
+ !--Find observation location using method from read_l2bufr_mod.f90
+
+ !-Get corrected tilt angle
+ celev=celev0
+ selev=selev0
+ celev=a43*celev0/(a43+h)
+ selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h))
+
+ gamma=half*thisrange*(celev0+celev)
+
!-Get earth lat lon of observation
-
+
rlon0=deg2rad*strct_in_dbz(v,k)%radlon
- clat0=cos(deg2rad*strct_in_dbz(v,k)%radlat)
- slat0=sin(deg2rad*strct_in_dbz(v,k)%radlat)
- thisazimuthr=(90.0_r_kind-strct_in_dbz(v,k)%azim(j))*deg2rad !Storing as 90-azm to
- ! be consistent with
- ! read_l2bufr_mod.f90
- rad_per_meter=one/rearth
- rlonloc=rad_per_meter*gamma*cos(thisazimuthr)
+ clat0=cos(deg2rad*strct_in_dbz(v,k)%radlat)
+ slat0=sin(deg2rad*strct_in_dbz(v,k)%radlat)
+ thisazimuthr=(90.0_r_kind-strct_in_dbz(v,k)%azim(j))*deg2rad !Storing as 90-azm to
+ ! be consistent with
+ ! read_l2bufr_mod.f90
+ rad_per_meter=one/rearth
+ rlonloc=rad_per_meter*gamma*cos(thisazimuthr)
rlatloc=rad_per_meter*gamma*sin(thisazimuthr)
-
- call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob)
+
+ call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob)
- thislat=rlatglob*rad2deg
+ thislat=rlatglob*rad2deg
thislon=rlonglob*rad2deg
!-Check format of longitude and correct if necessary
- if(thislon>=r360) thislon=thislon-r360
+ if(thislon>=r360) thislon=thislon-r360
if(thislon=r360 .or. thislat >90.0_r_kind) cycle
+
+ !-Convert back to radians
+
+ thislat = thislat*deg2rad
thislon = thislon*deg2rad
-
- !find grid relative lat lon locations of earth lat lon
+
+ !find grid relative lat lon locations of earth lat lon
- call tll2xy(thislon,thislat,dlon,dlat,outside)
+ call tll2xy(thislon,thislat,dlon,dlat,outside)
if (outside) cycle azms !If observation is outside the domain
- ! then cycle, but don't increase range right away.
- ! Domain could be rectangular, so ob may be out of
- ! range at one end, but not the other.
- thiserr=dbzerr
+ ! then cycle, but don't increase range right away.
+ ! Domain could be rectangular, so ob may be out of
+ ! range at one end, but not the other.
+ thiserr=dbzerr
-
- ndata = min(ndata+1,maxobs)
- nodata = min(nodata+1,maxobs) !number of obs not used (no meaning here)
-
- this_staid=strct_in_dbz(v,k)%radid !Via equivalence in declaration, value is propagated
- ! to rstation_id used below.
-
- cdata_all(1,ndata) = thiserr ! reflectivity obs error (dB) - inflated/adjusted
- cdata_all(2,ndata) = dlon ! grid relative longitude
- cdata_all(3,ndata) = dlat ! grid relative latitude
- cdata_all(4,ndata) = thishgt ! obs absolute height (m)
- cdata_all(5,ndata) = strct_in_dbz(v,k)%field(i,j) ! radar reflectivity factor
- cdata_all(6,ndata) = thisazimuthr ! 90deg-azimuth angle (radians)
- cdata_all(7,ndata) = timeb*r60inv ! obs time (analyis relative hour)
- cdata_all(8,ndata) = ikx ! type double check with the convinfo txt
- cdata_all(9,ndata) = thistiltr ! tilt angle (radians)
- cdata_all(10,ndata)= this_stahgt ! station elevation (m)
- cdata_all(11,ndata)= rstation_id ! station id
- cdata_all(12,ndata)= icuse(ikx) ! usage parameter
- cdata_all(13,ndata)= thislon*rad2deg ! earth relative longitude (degrees)
- cdata_all(14,ndata)= thislat*rad2deg ! earth relative latitude (degrees)
- cdata_all(15,ndata)= thisrange ! range from radar in m
- cdata_all(16,ndata)= dbzerr ! orginal error from convinfo file
- cdata_all(17,ndata)= dbznoise ! noise threshold for reflectivity (dBZ)
+
+ ndata = min(ndata+1,maxobs)
+ nodata = min(nodata+1,maxobs) !number of obs not used (no meaning here)
+
+ this_staid=strct_in_dbz(v,k)%radid !Via equivalence in declaration, value is propagated
+ ! to rstation_id used below.
+
+ cdata_all(1,ndata) = thiserr ! reflectivity obs error (dB) - inflated/adjusted
+ cdata_all(2,ndata) = dlon ! grid relative longitude
+ cdata_all(3,ndata) = dlat ! grid relative latitude
+ cdata_all(4,ndata) = thishgt ! obs absolute height (m)
+ cdata_all(5,ndata) = strct_in_dbz(v,k)%field(i,j) ! radar reflectivity factor
+ cdata_all(6,ndata) = thisazimuthr ! 90deg-azimuth angle (radians)
+ cdata_all(7,ndata) = timeb*r60inv ! obs time (analyis relative hour)
+ cdata_all(8,ndata) = ikx ! type double check with the convinfo txt
+ cdata_all(9,ndata) = thistiltr ! tilt angle (radians)
+ cdata_all(10,ndata)= this_stahgt ! station elevation (m)
+ cdata_all(11,ndata)= rstation_id ! station id
+ cdata_all(12,ndata)= icuse(ikx) ! usage parameter
+ cdata_all(13,ndata)= thislon*rad2deg ! earth relative longitude (degrees)
+ cdata_all(14,ndata)= thislat*rad2deg ! earth relative latitude (degrees)
+ cdata_all(15,ndata)= thisrange ! range from radar in m
+ cdata_all(16,ndata)= dbzerr ! orginal error from convinfo file
+ cdata_all(17,ndata)= dbznoise ! noise threshold for reflectivity (dBZ)
end do azms !j
else
- num_badrange=num_badrange+1 !If outside acceptable range, increment
- end if !Range check
-
- end do gates !i
+ num_badrange=num_badrange+1 !If outside acceptable range, increment
+ end if !Range check
+
+ end do gates !i
else
num_badtilt=num_badtilt+1 !If outside acceptable tilts, increment
@@ -606,18 +605,20 @@ subroutine read_dbz_mrms_netcdf(nread,ndata,nodata,infile,obstype,lunout,sis,nob
!---------------DEALLOCATE ARRAYS-------------!
- deallocate(cdata_all)
- do v=1,nvol
- do k=1,nelv
- deallocate(strct_in_dbz(v,k)%azim)
- deallocate(strct_in_dbz(v,k)%field)
- end do
- end do
- deallocate(strct_in_dbz)
else !fileopen
write(6,*) 'READ_dBZ: ERROR OPENING RADAR REFLECTIVITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...'
end if fileopen
+ deallocate(cdata_all)
+ do v=1,nvol
+ do k=1,nelv
+ deallocate(strct_in_dbz(v,k)%azim)
+ deallocate(strct_in_dbz(v,k)%field)
+ end do
+ end do
+ deallocate(strct_in_dbz)
+ deallocate(obdata_nc,azimuth_nc)
+ deallocate(beamwidth_nc,azimspacing_nc,gatewidth_nc)
end subroutine read_dbz_mrms_netcdf
@@ -794,9 +795,9 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout,
integer(i_kind) :: num_missing=0,num_nopcp=0, & !counts
numbadtime=0,num_badtilt=0, &
num_badrange=0,num_m2nopcp=0, &
- num_noise=0,num_limmax=0 ,num_limmin=0
-
-
+ num_noise=0,num_limmax=0 ,num_limmin=0
+
+
!--General declarations
integer(i_kind) :: ierror,lunrad,i,j,k,v,na,nb,nelv,nvol, &
@@ -809,7 +810,7 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout,
real(r_kind) :: thistiltr,selev0,celev0,thisrange,this_stahgt,thishgt
real(r_kind) :: celev,selev,gamma,thisazimuthr,rlon0, &
clat0,slat0,dlat,dlon,thiserr,thislon,thislat, &
- rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter
+ rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter
real(r_kind) :: radartwindow
real(r_kind) :: dbzerr,rmins_an,rmins_ob
real(r_kind),allocatable,dimension(:,:):: cdata_all
@@ -827,7 +828,7 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout,
!---------SETTINGS FOR FUTURE NAMELIST---------!
integer(i_kind) :: maxobrange=99900000 ! Range (m) *within* which to use observations - obs *outside* this range are not used
integer(i_kind) :: minobrange=-999 ! Range (m) *outside* of which to use observatons - obs *inside* this range are not used
- real(r_kind) :: mintilt=0.0_r_kind ! Only use tilt(elevation) angles (deg) >= this number
+ real(r_kind) :: mintilt=0.0_r_kind ! Only use tilt(elevation) angles (deg) >= this number
real(r_kind) :: maxtilt=20.0_r_kind ! Do no use tilt(elevation) angles (deg) >= this number
logical :: missing_to_nopcp=.false. ! Set missing observations to 'no precipitation' observations -> dbznoise (See Aksoy et al. 2009, MWR)
real(r_kind) :: dbznoise=2_r_kind ! dBZ obs must be >= dbznoise for assimilation
@@ -849,9 +850,7 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout,
real(r_single), allocatable :: azimuth_nc(:),beamwidth_nc(:),azimspacing_nc(:),gatewidth_nc(:)
-real(r_single), allocatable :: nyquist_nc(:),obdata_nc(:,:),obdata_pixel_nc(:)
-real(r_single) nyquist_default_nc
-parameter(nyquist_default_nc=50.0_r_kind)
+real(r_single), allocatable :: obdata_pixel_nc(:)
logical l_pixel_unlimited
integer(i_kind):: ipix
integer(i_kind)::real_numpixel,start_nc(1),count_nc(1)
@@ -863,13 +862,13 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout,
if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then
ikx=i
radartwindow=ctwind(ikx)*r60 !Time window units converted to minutes
- ! (default setting for dbz within convinfo is 0.05 hours)
- dbzerr=5_r_kind !Ob error (dB) to use for radar reflectivity factor
- exit !Exit loop when finished with initial convinfo fields
+ ! (default setting for dbz within convinfo is 0.05 hours)
+ dbzerr=5_r_kind !Ob error (dB) to use for radar reflectivity factor
+ exit !Exit loop when finished with initial convinfo fields
else if ( i==nconvtype ) then
write(6,*) 'READ_dBZ: ERROR - OBSERVATION TYPE IS NOT PRESENT IN CONVINFO OR USE FLAG IS ZERO'
- write(6,*) 'READ_dBZ: ABORTTING read_dbz.f90 - NO REFLECTIVITY OBS READ!'
- return
+ write(6,*) 'READ_dBZ: ABORTTING read_dbz.f90 - NO REFLECTIVITY OBS READ!'
+ return
endif
end do
@@ -960,7 +959,6 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout,
!reverse order of dimensions as stated in ncdump:
allocate(azimuth_nc(numazim_nc),beamwidth_nc(numazim_nc),azimspacing_nc(numazim_nc),gatewidth_nc(numazim_nc))
-allocate(nyquist_nc(numazim_nc),obdata_nc(numgate_nc,numazim_nc))
allocate(obdata_pixel_nc(num_pixel_nc))
allocate(pixel_x_nc(num_pixel_nc))
allocate(pixel_y_nc(num_pixel_nc))
@@ -1017,20 +1015,20 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout,
! transform the read-in ob to the intermidate obs variables( radar obs to be used in GSI
- strct_in_dbz(v,k)%radid=radarsite_nc
- strct_in_dbz(v,k)%vcpnum=vcp_nc
- strct_in_dbz(v,k)%year=iyear ! to be defind from infile name
+ strct_in_dbz(v,k)%radid=radarsite_nc
+ strct_in_dbz(v,k)%vcpnum=vcp_nc
+ strct_in_dbz(v,k)%year=iyear ! to be defind from infile name
strct_in_dbz(v,k)%month=imon
strct_in_dbz(v,k)%day=iday
strct_in_dbz(v,k)%hour=ihour
strct_in_dbz(v,k)%minute=imin
strct_in_dbz(v,k)%second=isec
- strct_in_dbz(v,k)%radlat=lat_nc
+ strct_in_dbz(v,k)%radlat=lat_nc
strct_in_dbz(v,k)%radlon=lon_nc
strct_in_dbz(v,k)%radhgt=height_nc
- strct_in_dbz(v,k)%fstgatdis =firstgate_nc
+ strct_in_dbz(v,k)%fstgatdis =firstgate_nc
strct_in_dbz(v,k)%gateWidth=gatewidth_nc(1) ! always the same ??)
- strct_in_dbz(v,k)%elev_angle=elev_nc
+ strct_in_dbz(v,k)%elev_angle=elev_nc
strct_in_dbz(v,k)%num_beam=numazim_nc
strct_in_dbz(v,k)%num_gate=numgate_nc
na=strct_in_dbz(v,k)%num_beam
@@ -1065,8 +1063,8 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout,
obdate(5)=strct_in_dbz(v,k)%minute
call w3fs21(obdate,mins_ob) !mins_ob -integer number of mins snce 01/01/1978
- rmins_ob=mins_ob !convert to real number
- rmins_ob=rmins_ob+(strct_in_dbz(v,k)%second*r60inv) !convert seconds to minutes and add to ob time
+ rmins_ob=mins_ob !convert to real number
+ rmins_ob=rmins_ob+(strct_in_dbz(v,k)%second*r60inv) !convert seconds to minutes and add to ob time
!-Comparison is done in units of minutes
@@ -1088,139 +1086,139 @@ subroutine read_dbz_mrms_sparse_netcdf(nread,ndata,nodata,infile,obstype,lunout,
pixel: do ipix=1,real_numpixel
j=pixel_x_nc(ipix)+1
i=pixel_y_nc(ipix)+1
-
- thisrange=strct_in_dbz(v,k)%fstgatdis + float(i-1)*strct_in_dbz(v,k)%gateWidth
+
+ thisrange=strct_in_dbz(v,k)%fstgatdis + real(i-1,r_kind)*strct_in_dbz(v,k)%gateWidth
!-Check to make sure observations are within specified range
- if (thisrange <= maxobrange .and. thisrange >= minobrange) then
-
-
- nread=nread+1
+ if (thisrange <= maxobrange .and. thisrange >= minobrange) then
+
+
+ nread=nread+1
if ( abs(obdata_pixel_nc(ipix)) >= 999.0_r_kind ) then
-
- !--Extend no precip observations to missing data fields?
+
+ !--Extend no precip observations to missing data fields?
! May help suppress spurious convection if a problem.
-
+
if (missing_to_nopcp) then
- obdata_pixel_nc(ipix) = dbznoise
- num_m2nopcp = num_m2nopcp+1
- else
- num_missing=num_missing+1
- cycle pixel !No reason to process the ob if it is missing
+ obdata_pixel_nc(ipix) = dbznoise
+ num_m2nopcp = num_m2nopcp+1
+ else
+ num_missing=num_missing+1
+ cycle pixel !No reason to process the ob if it is missing
end if
-
+
+ end if
+
+
+ if (l_limmax) then
+ if ( obdata_pixel_nc(ipix) > 60_r_kind ) then
+ obdata_pixel_nc(ipix) = 60_r_kind
+ num_limmax=num_limmax+1
+ end if
end if
-
-
- if (l_limmax) then
- if ( obdata_pixel_nc(ipix) > 60_r_kind ) then
- obdata_pixel_nc(ipix) = 60_r_kind
- num_limmax=num_limmax+1
- end if
- end if
- if (l_limmin) then
- if ( obdata_pixel_nc(ipix) < 0_r_kind ) then
- obdata_pixel_nc(ipix) = 0_r_kind
- num_limmin=num_limmin+1
- end if
- end if
-
- !-Special treatment for no-precip obs?
-
-
- !--Find observation height using method from read_l2bufr_mod.f90
-
- this_stahgt=strct_in_dbz(v,k)%radhgt
+ if (l_limmin) then
+ if ( obdata_pixel_nc(ipix) < 0_r_kind ) then
+ obdata_pixel_nc(ipix) = 0_r_kind
+ num_limmin=num_limmin+1
+ end if
+ end if
+
+ !-Special treatment for no-precip obs?
+
+
+ !--Find observation height using method from read_l2bufr_mod.f90
+
+ this_stahgt=strct_in_dbz(v,k)%radhgt
aactual=rearth+this_stahgt
a43=four_thirds*aactual
thistiltr=thistilt*deg2rad
selev0=sin(thistiltr)
- celev0=cos(thistiltr)
- b=thisrange*(thisrange+two*aactual*selev0)
+ celev0=cos(thistiltr)
+ b=thisrange*(thisrange+two*aactual*selev0)
c=sqrt(aactual*aactual+b)
ha=b/(aactual+c)
epsh=(thisrange*thisrange-ha*ha)/(r8*aactual)
h=ha-epsh
- thishgt=this_stahgt+h
-
- !--Find observation location using method from read_l2bufr_mod.f90
-
- !-Get corrected tilt angle
- celev=celev0
- selev=selev0
- celev=a43*celev0/(a43+h)
- selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h))
-
- gamma=half*thisrange*(celev0+celev)
-
+ thishgt=this_stahgt+h
+
+ !--Find observation location using method from read_l2bufr_mod.f90
+
+ !-Get corrected tilt angle
+ celev=celev0
+ selev=selev0
+ celev=a43*celev0/(a43+h)
+ selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h))
+
+ gamma=half*thisrange*(celev0+celev)
+
!-Get earth lat lon of observation
-
+
rlon0=deg2rad*strct_in_dbz(v,k)%radlon
- clat0=cos(deg2rad*strct_in_dbz(v,k)%radlat)
- slat0=sin(deg2rad*strct_in_dbz(v,k)%radlat)
- thisazimuthr=(90.0_r_kind-strct_in_dbz(v,k)%azim(j))*deg2rad !Storing as 90-azm to
- ! be consistent with
- ! read_l2bufr_mod.f90
- rad_per_meter=one/rearth
- rlonloc=rad_per_meter*gamma*cos(thisazimuthr)
+ clat0=cos(deg2rad*strct_in_dbz(v,k)%radlat)
+ slat0=sin(deg2rad*strct_in_dbz(v,k)%radlat)
+ thisazimuthr=(90.0_r_kind-strct_in_dbz(v,k)%azim(j))*deg2rad !Storing as 90-azm to
+ ! be consistent with
+ ! read_l2bufr_mod.f90
+ rad_per_meter=one/rearth
+ rlonloc=rad_per_meter*gamma*cos(thisazimuthr)
rlatloc=rad_per_meter*gamma*sin(thisazimuthr)
-
- call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob)
+
+ call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob)
- thislat=rlatglob*rad2deg
+ thislat=rlatglob*rad2deg
thislon=rlonglob*rad2deg
!-Check format of longitude and correct if necessary
- if(thislon>=r360) thislon=thislon-r360
+ if(thislon>=r360) thislon=thislon-r360
if(thislon 0) then
+ data_extra(:,:) = diag_status%all_data_extra(diag_status%cur_ob_idx,:,:)
+ endif
diag_status%cur_ob_idx = diag_status%cur_ob_idx + 1
diff --git a/src/gsi/read_fed.f90 b/src/gsi/read_fed.f90
new file mode 100644
index 0000000000..9ba799e341
--- /dev/null
+++ b/src/gsi/read_fed.f90
@@ -0,0 +1,403 @@
+subroutine read_fed(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs)
+!$$$ subprogram documentation block
+! . . . .
+! ABSTRACT:
+! This routine reads in netcdf or prepbufr flash-extent density (FED) data.
+!
+! PROGRAM HISTORY LOG:
+! 2018-07-25 Rong Kong (CAPS/OU) - modified based on read_radarref_mosaic.f90
+! 2019-09-20 Yaping Wang (CIMMS/OU)
+! 2021-07-01 David Dowell (DCD; NOAA GSL) - added maximum flashes/min for observed FED
+!
+! 2023-10-18 Hongli Wang (NOAA GSL)
+! - cleanup code, removed hardcoded obs height (6500m)
+! - use height fron obs file if they are avaiable, otherwise
+! use default value or value from namelist variable r_hgt_fed
+! - return if NetCDF file open status /= nf90_noerror
+!
+! input argument list:
+! infile - unit from which to read observation information file
+! obstype - observation type to process
+! lunout - unit to which to write data for further processing
+! twind - input group time window (hours)
+! sis - observation variable name
+!
+! output argument list:
+! nread - number of type "obstype" observations read
+! ndata - number of type "obstype" observations retained for further processing
+! nobs - array of observations on each subdomain for each processor
+!
+! ATTRIBUTES:
+! LANGUAGE: FORTRAN 90
+!
+!$$$
+!
+!_____________________________________________________________________
+!
+ use kinds, only: r_kind,r_double,i_kind
+ use constants, only: zero,one,deg2rad,r60inv
+ use convinfo, only: nconvtype,icuse,ioctype
+ use gsi_4dvar, only: iwinbgn
+ use gridmod, only: tll2xy
+ use mod_wrfmass_to_a, only: wrfmass_obs_to_a8
+ use mpimod, only: npe
+ use obsmod, only: perturb_obs,iadatemn,dofedoneob,oneoblat,oneoblon,r_hgt_fed
+
+ use netcdf
+ implicit none
+
+ include 'netcdf.inc'
+!
+ character(len=*), intent(in) :: infile,obstype
+ integer(i_kind), intent(in) :: lunout
+ integer(i_kind), intent(inout) :: nread,ndata
+ integer(i_kind), intent(inout) :: nodata
+ integer(i_kind), dimension(npe) ,intent(inout) :: nobs
+ real(r_kind), intent(in ) :: twind
+ character(len=*), intent(in) :: sis
+
+! Declare local parameters
+ real(r_kind),parameter:: r90 = 90.0_r_kind
+ real(r_kind),parameter:: r360 = 360.0_r_kind
+ real(r_kind),parameter:: oe_fed = 1.0_r_kind
+ real(r_kind),parameter:: fed_lowbnd = 0.1_r_kind ! use fed == fed_lowbnd
+ real(r_kind),parameter:: fed_lowbnd2 = 0.1_r_kind ! use fed >= fed_lowbnd2
+! real(r_kind),parameter:: fed_highbnd = 18.0_r_kind ! 18 flashes/min from Sebok and Back (2021, unpublished)
+ real(r_kind),parameter:: fed_highbnd = 8.0_r_kind ! 8 flashes/min from Back (2023) for regional FV3 tests
+
+!
+! For fed observations
+!
+ integer(i_kind) nreal,nchanl
+
+ integer(i_kind) ifn,i
+
+ integer(i_kind) :: ilon,ilat
+
+ logical :: fedobs, fedob
+ real(r_kind),allocatable,dimension(:,:):: cdata_out
+ real(r_kind) :: federr, thiserr
+ real(r_kind) :: hgt_fed(1)
+
+ real(r_kind) :: i_maxloc,j_maxloc,k_maxloc
+ integer(i_kind) :: kint_maxloc
+ real(r_kind) :: fed_max
+ integer(i_kind) :: ndata2
+
+ character(8) station_id
+ real(r_double) :: rstation_id
+ equivalence(rstation_id,station_id)
+
+ integer(i_kind) :: maxlvl
+ integer(i_kind) :: numfed,maxobs
+ integer(i_kind) :: k
+
+ real(r_kind),allocatable,dimension(:,:) :: fed3d_column ! 3D fed in column
+ real(r_kind),allocatable,dimension(:) :: fed3d_hgt ! fed height
+ real(r_kind),allocatable,dimension(:) :: utime ! time
+
+ integer(i_kind) :: ikx
+
+ character*128 :: myname='read_fed'
+
+ real(r_kind) :: dlat, dlon ! rotated corrdinate
+ real(r_kind) :: dlat_earth, dlon_earth ! in unit of degree
+ real(r_kind) :: rlat00, rlon00 ! in unit of rad
+
+ logical :: l_psot_fed
+ logical :: l_latlon_fedobs
+ logical :: outside
+
+! for read netcdf
+ integer(i_kind) :: sec70,mins_an
+ integer(i_kind) :: varID, ncdfID, status
+ real(r_kind) :: timeb,twindm,rmins_an,rmins_ob
+
+
+ hgt_fed = r_hgt_fed
+
+ write(6,*) "r_kind=",r_kind
+ l_psot_fed = .FALSE.
+ l_latlon_fedobs = .TRUE.
+
+ fedob = obstype == 'fed'
+ if (fedob) then
+ nreal=25
+ else
+ write(6,*) ' illegal obs type in read_fed : obstype=',obstype
+ call stop2(94)
+ end if
+ if(perturb_obs .and. fedob)nreal=nreal+1
+ write(6,*)'read_fed: nreal=',nreal
+
+ fedobs = .false.
+ ikx=0
+ do i=1,nconvtype
+ if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then
+ fedobs=.true.
+ ikx=i
+ federr = oe_fed ! Obs error (flashes per minute)
+ thiserr = federr
+ exit ! Exit loop when finished with initial convinfo fields
+ else if (i == nconvtype ) then
+ write(6,*) 'read_fed: Obs Type for fed is not in CONVINFO !'
+ write(6,*) 'read_fed: PLEASE modify the CONVINFO file !'
+ write(6,*) 'read_fed: abort read_fed !'
+ return
+ endif
+ end do
+ write(6,'(1x,A,A30,I4,A15,F7.3,A7)') &
+ trim(myname),': fed in convinfo-->ikx=',ikx,' fed ob err:',thiserr," (fed)"
+
+ nread=0
+ ndata=0
+ nchanl=0
+ ifn = 15
+
+ if (fedobs) then
+ maxlvl= 1 ! fed only has one level
+
+!!!! Start reading fed observations from NETCDF format data file
+ ! CHECK IF DATA FILE EXISTS
+ ! OPEN NETCDF FILE
+ status = nf90_open(TRIM(infile), NF90_NOWRITE, ncdfID)
+ print*, '*** OPENING GOES FED OBS NETCDF FILE: ', infile, status
+ if(status/=nf90_noerr)return
+
+ !------------------------
+ ! Get Dimension Info (1-D)
+ !-------------------------
+ status = nf90_inq_varid( ncdfID, 'numobs', varID )
+ status = nf90_get_var( ncdfID, varID, maxobs )
+
+ !------------------------
+ ! Allocate data arrays
+ !-------------------------
+ ALLOCATE( fed3d_column( 5, maxobs ) )
+ allocate( fed3d_hgt(maxobs) )
+ ALLOCATE( utime( 1 ) ) ! seconds since from 2000-01-01 12:00
+ fed3d_hgt = -999.0_r_kind
+
+ !------------------------
+ ! Get useful data arrays
+ !-------------------------
+ ! LON
+ status = nf90_inq_varid( ncdfID, 'lon', varID )
+ status = nf90_get_var( ncdfID, varID, fed3d_column(1, :) )
+ ! LAT
+ status = nf90_inq_varid( ncdfID, 'lat', varID )
+ status = nf90_get_var( ncdfID, varID, fed3d_column(2, :) )
+ ! FED value
+ status = nf90_inq_varid( ncdfID, 'value', varID )
+ status = nf90_get_var( ncdfID, varID, fed3d_column(3, :) )
+ ! TIME
+ status = nf90_inq_varid( ncdfID, 'time', varID )
+ status = nf90_get_var( ncdfID, varID, utime )
+
+ ! FED height, optional variable
+ status = nf90_inq_varid( ncdfID, 'height', varID )
+ if(status==nf90_noerr)&
+ status = nf90_get_var( ncdfID, varID, fed3d_hgt )
+
+ ! CLOSE NETCDF FILE
+ status = nf90_close( ncdfID )
+
+
+ !-Obtain analysis time in minutes since reference date
+ sec70 = 694267200.0 ! seconds since from 1978-01-01 00:00 to 2000-01-01 12:00
+ ! because the official GOES prescribed epoch time for GLM data is 2000-01-01 12:00:00
+
+ call w3fs21(iadatemn,mins_an) !mins_an -integer number of mins snce 01/01/1978
+ rmins_an=mins_an !convert to real number
+
+ ! SINCE ALL OBS WILL HAVE THE SAME TIME, CHECK TIME HERE:
+ rmins_ob = ( utime(1) + sec70 )/60 !Convert to Minutes from seconds
+ twindm = twind*60. !Convert to Minutes from hours
+ timeb = rmins_ob-rmins_an
+
+ if(abs(timeb) > abs(twindm)) then
+ print*, 'WARNING: ALL FED OBSERVATIONS OUTSIDE ASSIMILATION TIME WINDOW: ', timeb, twindm
+ endif
+
+ !time relative to the beginning of the da time window
+ timeb=real(rmins_ob-iwinbgn,r_kind)
+
+ numfed = maxobs
+ do i=1,numfed
+ if (fed3d_column( 3, i ) >= fed_lowbnd2 .or. fed3d_column( 3, i ) == fed_lowbnd ) then
+ ndata = ndata + 1
+ end if
+ end do
+
+ write(6,*)'read_fed: total no. of obs = ',ndata
+ nread=ndata
+ nodata=ndata
+!!! - Finished reading fed observations from NETCDF format data file
+
+ allocate(cdata_out(nreal,ndata))
+!
+ do i=1,numfed
+ do k=1,maxlvl
+ if (fed3d_column(k+2,i) .gt. fed_highbnd) fed3d_column(k+2,i) = fed_highbnd
+ end do
+ end do
+
+ write(6,*) ' ------- check max and min value of OBS: bufr fed -------'
+ write(6,*) ' level maxval(fed) minval(fed)'
+ do k=1,maxlvl
+ write(6,*) k,maxval(fed3d_column(k+2,:)),minval(fed3d_column(k+2,:))
+ end do
+
+ i_maxloc=-1.0
+ j_maxloc=-1.0
+ k_maxloc=-1.0
+ kint_maxloc=-1
+ fed_max=-999.99
+ ndata2=0
+
+ ILOOP : &
+ do i=1,numfed
+ if(fed3d_hgt(i) > 0.0_r_kind)then
+ hgt_fed=fed3d_hgt(i)
+ else
+ hgt_fed = r_hgt_fed
+ end if
+ do k=1,maxlvl
+ if( fed3d_column(k+2,i) >= fed_lowbnd2 .or. fed3d_column(k+2,i) == fed_lowbnd .or. dofedoneob) then !Rong Kong
+ dlon_earth = fed3d_column(1,i) ! longitude (degrees) of observation
+ ! ilone=18 ! index of longitude (degrees)
+ dlat_earth = fed3d_column(2,i) ! latitude (degrees) of observation
+ ! ilate=19 ! index of latitude (degrees)
+
+ if (dofedoneob) then
+ dlat_earth=oneoblat
+ dlon_earth=oneoblon
+ endif
+
+ !-Check format of longitude and correct if necessary
+ if(dlon_earth>=r360) dlon_earth=dlon_earth-r360
+ if(dlon_earth=r360 .or. dlat_earth >90.0_r_kind) cycle
+
+ !-Convert back to radians
+ rlon00 = dlon_earth*deg2rad
+ rlat00 = dlat_earth*deg2rad
+ call tll2xy(rlon00,rlat00,dlon,dlat,outside)
+ if (dofedoneob) then
+ if (outside) then
+ write(6,*)'READ_FED: ONE OB OUTSIDE; STOP2(61) ',dlat_earth,dlon_earth
+ call stop2(61)
+ end if
+ end if
+ if (outside) cycle
+
+ !If observation is outside the domain
+ ! then cycle, but don't increase
+ ! range right away.
+ ! Domain could be rectangular, so ob
+ ! may be out of
+ ! range at one end, but not the
+ ! other.
+
+ ndata2=ndata2+1
+ cdata_out( 1,ndata2) = thiserr ! obs error (flashes/min) - inflated/adjusted
+
+ cdata_out( 2,ndata2) = dlon !
+
+ cdata_out( 3,ndata2) = dlat
+
+ cdata_out( 4,ndata2) = hgt_fed(k) ! obs absolute height (m) above MSL
+ ! ipres=4 ! index of pressure
+ cdata_out( 5,ndata2) = fed3d_column(k+2,i) ! FED value
+
+ cdata_out( 6,ndata2) = rstation_id ! station id (charstring equivalent to real double)
+ ! id=6 ! index of station id
+
+ cdata_out( 7,ndata2) = timeb*r60inv ! observation time in data array
+ ! itime=7 ! index of observation time in data array
+ cdata_out( 8,ndata2) = ikx ! ob type
+ ! ikxx=8 ! index of ob type
+ cdata_out( 9,ndata2) = thiserr*2.0_r_kind ! max error
+ ! iqmax=9 ! index of max error
+ cdata_out(10,ndata2) = 273.0_r_kind ! dry temperature
+ ! itemp=10 ! index of dry temperature
+ cdata_out(11,ndata2) = 1.0_r_kind ! quality mark
+ ! iqc=11 ! index of quality mark
+ cdata_out(12,ndata2) = thiserr ! original-original obs error ratio
+ ! ier2=12 ! index of original-original obs error ratio
+ cdata_out(13,ndata2) = icuse(ikx) ! index of use parameter
+ ! iuse=13 ! index of use parameter
+ cdata_out(14,ndata2) = icuse(ikx) ! dominant surface type
+ ! idomsfc=14 ! index of dominant surface type
+ cdata_out(15,ndata2) = 273.0_r_kind ! index of surface skin temperature
+ ! iskint=15 ! index of surface skin temperature
+ cdata_out(16,ndata2) = 0.5_r_kind ! 10 meter wind factor
+ ! iff10=16 ! index of 10 meter wind factor
+ cdata_out(17,ndata2) = 0.5_r_kind ! surface roughness
+ ! isfcr=17 ! index of surface roughness
+
+ cdata_out(18,ndata2) = dlon_earth ! longitude (degrees)
+
+ cdata_out(19,ndata2) = dlat_earth ! latitude (degrees)
+
+ cdata_out(20,ndata2) = hgt_fed(k) ! station elevation (m)
+ ! istnelv=20 ! index of station elevation (m)
+ cdata_out(21,ndata2) = hgt_fed(k) ! observation height (m)
+ ! iobshgt=21 ! index of observation height (m)
+ cdata_out(22,ndata2) = hgt_fed(k) ! surface height
+ ! izz=22 ! index of surface height
+ cdata_out(23,ndata2) = fed3d_column(4,i) ! i index of obs grid for bufr resolution (i.e.,8km)
+
+ cdata_out(24,ndata2) = fed3d_column(5,i) ! j index of obs grid for bufr resolution
+
+ cdata_out(25,ndata2) = hgt_fed(k) ! data level category
+ ! icat =25 ! index of data level category
+ if(perturb_obs .and. fedob)then
+ cdata_out(26,ndata2) = 1.0_r_kind ! obs perturbation
+ ! iptrb=26 ! index of q perturbation
+ end if
+
+ if( dofedoneob ) exit ILOOP
+
+ if(fed3d_column(k+2,i) > fed_max)then
+ kint_maxloc=k
+ k_maxloc=real(k,r_kind)
+ j_maxloc=fed3d_column(2,i)
+ i_maxloc=fed3d_column(1,i)
+ fed_max =fed3d_column(k+2,i)
+ end if
+
+ endif
+ enddo ! k
+ enddo ILOOP ! i
+
+!---all looping done now print diagnostic output
+ write(6,*)'READ_FED: Reached eof on FED file'
+ write(6,*)'READ_FED: # read in obs. number =',nread
+ write(6,*)'READ_FED: # read in obs. number for further processing =',ndata2
+! write(6,*)'READ_FED: dlon_earth', cdata_out(18,10:15)
+
+ ilon=2 ! array index for longitude
+ ilat=3 ! array index for latitude in obs information array
+ ndata=ndata2
+ nodata=ndata2
+
+!---Write observations to scratch file---!
+
+ call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs)
+ write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata
+ write(lunout) ((cdata_out(k,i),k=1,nreal),i=1,ndata)
+
+ deallocate(cdata_out)
+ if (allocated(fed3d_column)) deallocate(fed3d_column)
+
+ write(6,'(1x,A,F12.5,1x,A,3(1x,F8.3),1x,I4)') &
+ 'read_fed: max fed =',fed_max, '@ i j k =', &
+ i_maxloc,j_maxloc,k_maxloc,kint_maxloc
+
+ end if
+ return
+
+end subroutine read_fed
+!
+!
diff --git a/src/gsi/read_files.f90 b/src/gsi/read_files.f90
index 93ddd17bf7..60282bfbc6 100644
--- a/src/gsi/read_files.f90
+++ b/src/gsi/read_files.f90
@@ -69,7 +69,8 @@ subroutine read_files(mype)
! nfsecondn FCST Secs (i_kind) numerator
! nfsecondd FCST Secs (i_kind) denominator
!
-! %fhour = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+! %fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+! real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
! attributes:
! language: f90
@@ -264,7 +265,7 @@ subroutine read_files(mype)
write(6,*)'READ_FILES: ***WARNING*** problem reading atm file ',trim(filename),iret
idate6 = get_idate_from_time_units(atmges)
call read_vardata(atmges, 'time', fhour)
- hourg4 = float(nint(fhour(1))) ! going to make this nearest integer for now
+ hourg4 = real(nint(fhour(1)),r_kind) ! going to make this nearest integer for now
idateg(1) = idate6(4)
idateg(2) = idate6(2)
idateg(3) = idate6(3)
@@ -288,7 +289,8 @@ subroutine read_files(mype)
call stop2(80)
endif
- hourg4 = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ hourg4 = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
idateg(1) = idate(4) !hour
idateg(2) = idate(2) !month
idateg(3) = idate(3) !day
@@ -342,7 +344,7 @@ subroutine read_files(mype)
ncdim = get_dim(sfcges, 'grid_yt'); sfc_head%latb = ncdim%len
idate6 = get_idate_from_time_units(sfcges)
call read_vardata(sfcges, 'time', fhour)
- hourg4 = float(nint(fhour(1))) ! going to make this nearest integer for now
+ hourg4 = real(nint(fhour(1)),r_kind) ! going to make this nearest integer for now
idateg(1) = idate6(4)
idateg(2) = idate6(2)
idateg(3) = idate6(3)
@@ -381,7 +383,8 @@ subroutine read_files(mype)
nfhour, nfminute, nfsecondn, nfsecondd
call stop2(80)
endif
- hourg4 = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ hourg4 = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
idateg(1) = idate(4) !hour
idateg(2) = idate(2) !month
idateg(3) = idate(3) !day
@@ -478,7 +481,8 @@ subroutine read_files(mype)
nfhour, nfminute, nfsecondn, nfsecondd
call stop2(80)
endif
- hourg4 = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ hourg4 = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
idateg(1) = idate(4) !hour
idateg(2) = idate(2) !month
idateg(3) = idate(3) !day
@@ -540,7 +544,8 @@ subroutine read_files(mype)
nfhour, nfminute, nfsecondn, nfsecondd
call stop2(80)
endif
- hourg4 = float(nfhour) + float(nfminute)/r60 + float(nfsecondn)/float(nfsecondd)/r3600
+ hourg4 = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
idateg(1) = idate(4) !hour
idateg(2) = idate(2) !month
idateg(3) = idate(3) !day
@@ -585,7 +590,7 @@ subroutine read_files(mype)
if (nst_gsi > 0 ) call mpi_bcast(time_nst,2*nfldnst,mpi_rtype,npem1,mpi_comm_world,ierror)
! for external aerosol files
- if(.not.allocated(time_aer)) allocate(time_aer(nfldaer,2))
+ if(lread_ext_aerosol .and. (.not.allocated(time_aer))) allocate(time_aer(nfldaer,2))
if (lread_ext_aerosol) call mpi_bcast(time_aer,2*nfldaer,mpi_rtype,npem1,mpi_comm_world,ierror)
call mpi_bcast(iamana,3,mpi_rtype,npem1,mpi_comm_world,ierror)
@@ -620,7 +625,7 @@ subroutine read_files(mype)
endif
if (l4densvar .and. nfldsig/=ntlevs_ens) then
if (mype==0) then
- write(6,*)'READ_FILES: ***ERROR*** insufficient atm fcst for 4densvar: PROGRAM STOPS'
+ write(6,*)'READ_FILES: ***FATAL ERROR*** insufficient atm fcst for 4densvar: PROGRAM STOPS'
do i=1,ntlevs_ens
ihr=nhr_obsbin*(i-1)+nhr_half
present=.false.
@@ -629,7 +634,7 @@ subroutine read_files(mype)
end do
if (.not.present) then
write(filename,'(''sigf'',i2.2)')ihr
- write(6,*)'READ_FILES: ***ERROR*** file ',trim(filename),' missing: PROGRAM STOPS'
+ write(6,*)'READ_FILES: ***FATAL ERROR*** file ',trim(filename),' missing: PROGRAM STOPS'
endif
end do
endif
@@ -652,7 +657,7 @@ subroutine read_files(mype)
endif
if (l4densvar .and. nfldsfc/=ntlevs_ens) then
if (mype==0) then
- write(6,*)'READ_FILES: ***ERROR*** insufficient sfc fcst for 4densvar: PROGRAM STOPS'
+ write(6,*)'READ_FILES: ***FATAL ERROR*** insufficient sfc fcst for 4densvar: PROGRAM STOPS'
do i=1,ntlevs_ens
ihr=nhr_obsbin*(i-1)+nhr_half
present=.false.
@@ -661,7 +666,7 @@ subroutine read_files(mype)
end do
if (.not.present) then
write(filename,'(''sfcf'',i2.2)')ihr
- write(6,*)'READ_FILES: ***ERROR*** file ',trim(filename),' missing: PROGRAM STOPS'
+ write(6,*)'READ_FILES: ***FATAL ERROR*** file ',trim(filename),' missing: PROGRAM STOPS'
endif
end do
endif
diff --git a/src/gsi/read_fl_hdob.f90 b/src/gsi/read_fl_hdob.f90
index c7dc95f612..4041740d52 100644
--- a/src/gsi/read_fl_hdob.f90
+++ b/src/gsi/read_fl_hdob.f90
@@ -48,15 +48,15 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
use kinds, only: r_single,r_kind,r_double,i_kind
use constants, only: zero,one_tenth,one,two,ten,deg2rad,t0c,half,&
three,four,rad2deg,tiny_r_kind,huge_r_kind,r0_01,&
- r60inv,r10,r100,r2000,hvap,eps,omeps,rv,grav
+ r60inv,r10,r100,r2000,hvap,eps,omeps,rv,grav,r_missing
use gridmod, only: diagnostic_reg,regional,nlon,nlat,nsig,&
tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,&
rlats,rlons,twodvar_regional,fv3_regional
use convinfo, only: nconvtype, &
icuse,ictype,icsubtype,ioctype, &
- ithin_conv,rmesh_conv,pmesh_conv
+ ithin_conv,rmesh_conv,pmesh_conv,pmot_conv
use obsmod, only: perturb_obs,perturb_fact,ran01dom
- use obsmod, only: bmiss
+ use obsmod, only: bmiss,reduce_diag
use aircraftinfo, only: aircraft_t_bc,aircraft_t_bc_pof,aircraft_t_bc_ext
use converr,only: etabl
use converr_ps,only: etabl_ps,isuble_ps,maxsub_ps
@@ -69,7 +69,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
use convb_uv,only: btabl_uv
use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,time_4dvar,winlen,thin4d
use qcmod, only: errormod,njqc
- use convthin, only: make3grids,map3grids,del3grids,use_all
+ use convthin, only: make3grids,map3grids_m,del3grids,use_all
use ndfdgrids,only: init_ndfdgrid,destroy_ndfdgrid,relocsfcob,adjust_error
use deter_sfc_mod, only: deter_sfc_type,deter_sfc2
use mpimod, only: npe
@@ -128,7 +128,6 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
! integer(i_kind) :: m,itypex,lcount,iflag
integer(i_kind) :: nlevp ! vertical level for thinning
integer(i_kind) :: pflag
- integer(i_kind) :: ntmp,iiout,igood
integer(i_kind) :: kk,klon1,klat1,klonp1,klatp1
integer(i_kind) :: iuse
integer(i_kind) :: nmind
@@ -137,7 +136,11 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
integer(i_kind) :: ibit(mxib)
integer(i_kind) :: idate5(5)
- integer(i_kind), allocatable,dimension(:) :: isort
+ logical, allocatable,dimension(:) :: rusage,rthin
+ logical save_all
+! integer(i_kind) numthin,numqc,numrem,numall
+ integer(i_kind) pmot,iqm
+ integer(i_kind) nxdata
! Real variables
real(r_kind), parameter :: r0_001 = 0.001_r_kind
@@ -171,7 +174,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
real(r_kind) :: es,qsat,rhob_calc,tdob_calc,tdry
real(r_kind) :: dummy
real(r_kind) :: del,ediff,errmin,jbmin
- real(r_kind) :: tvflg
+ real(r_kind) :: tvflg,log100
real(r_kind) :: presl(nsig)
real(r_kind) :: obstime(6,1)
@@ -188,7 +191,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
real(r_double) :: rstation_id
real(r_double) :: r_prvstg(1,1),r_sprvstg(1,1)
- real(r_kind), allocatable,dimension(:,:) :: cdata_all,cdata_out
+ real(r_kind), allocatable,dimension(:,:) :: cdata_all
real(r_kind), allocatable,dimension(:) :: presl_thin
! Equivalence to handle character names
@@ -234,6 +237,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
ierr_uv = 0
var_jb=zero
jbmin=zero
+ log100=log(100._r_kind)
lim_qm = 4
@@ -258,7 +262,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
else if (lpsob) then
nreal = 23
iecol = 5
- errmin = one_tenth ! set lower bound of ob error for moisture (RH)
+ errmin = one_tenth ! set lower bound of ob error for surface pressure
else
write(6,*) ' illegal obs type in read_fl_hdob '
call stop2(94)
@@ -352,6 +356,11 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
write(6,*)'READ_FL_HDOB: ictype(nc),rmesh,pflag,nlevp,pmesh,nc ',&
ioctype(nc),ictype(nc),rmesh,pflag,nlevp,pmesh,nc
endif
+ pmot=nint(pmot_conv(nc))
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
+
!------------------------------------------------------------------------------------------------
@@ -377,25 +386,25 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
!---------------------------------------------------------------------------------------------------
! Allocate array to hold data
- allocate(cdata_all(nreal,maxobs))
- allocate(isort(maxobs))
+ allocate(cdata_all(nreal,maxobs),rusage(maxobs),rthin(maxobs))
! Initialize
cdata_all = zero
- isort = 0
nread = 0
nchanl = 0
ntest = 0
nvtest = 0
ilon = 2
ilat = 3
+ rusage = .true.
+ rthin = .false.
+ use_all=.true.
! Open bufr file again for reading
open(lunin,file=trim(infile),form='unformatted')
call openbf(lunin,'IN',lunin)
call datelen(10)
ntb = 0
- igood = 0
! Loop through BUFR file
loop_msg2: do while(ireadmg(lunin,subset,idate) >= 0)
loop_readsb2: do while(ireadsb(lunin) == 0)
@@ -603,6 +612,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
obserr = max(obserr,errmin)
endif
! Read extrapolated surface pressure [pa] and convert to [cb]
+ dlnpsob = log100 ! default (1000mb)
if (lpsob) then
call ufbint(lunin,obspsf,1,1,nlv,psfstr)
if (obspsf(1,1) >= missing .or. &
@@ -632,7 +642,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
endif
enddo
if (ncount_ps ==1) then
- write(6,*) 'READ_FL_HDOB,WARNING!!psob: cannot find subtyep in the error,&
+ write(6,*) 'READ_FL_HDOB,WARNING!!psob: cannot find subtype in the error,&
table,itype,iosub=',itypey,icsubtype(nc)
write(6,*) 'read error table at colomn subtype as 0, error table column= ',ierr_ps
endif
@@ -896,9 +906,6 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
! Get information from surface file necessary for conventional data
call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,tsavg,ff10,sfcr,zz)
-! Process data passed quality control
- igood = igood+1
-
! Process data thinning procedure on good data
if (ithin > 0) then
if (pflag == 0) then
@@ -922,8 +929,6 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
end do
endif ! pflag
- ntmp = ndata ! counting moved into map3grids
-
! Set data quality index for thinning
if (thin4d) then
timedif = zero
@@ -937,26 +942,18 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
end do
endif
- call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
- pob_cb,crit1,ndata,iout,igood,iiout,luse,.false.,.false.)
+ call map3grids_m(-1,save_all,pflag,presl_thin,nlevp, &
+ dlat_earth,dlon_earth,pob_cb,crit1,ndata,&
+ luse,maxobs,rthin,.false.,.false.)
+
if (.not. luse) cycle loop_readsb2
- if(iiout > 0) isort(iiout) = 0
- if (ndata > ntmp) then
- nodata = nodata+2
- if (luvob) &
- nodata = nodata+2
- endif
- isort(igood) = iout
+ if(rthin(ndata))usage=101._r_kind
else
ndata = ndata+1
- nodata = nodata+2
- if (luvob) &
- nodata = nodata+2
- iout = ndata
- isort(igood) = iout
endif ! ithin
+ iout = ndata
!-------------------------------------------------------------------------------------------------
! Write data into output arrays
@@ -966,8 +963,11 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
if (lpsob) then
qcm = ps_qm
psoe = obserr*one_tenth ! convert from mb to cb
+ iqm=10
if (inflate_error) psoe = psoe*r1_2
- if (qcm > lim_qm ) psoe = psoe*1.0e6_r_kind
+ if (qcm > lim_qm ) then
+ psoe = psoe*1.0e6_r_kind
+ end if
cdata_all( 1,iout)=psoe ! surface pressure error (cb)
cdata_all( 2,iout)=dlon ! grid relative longitude
cdata_all( 3,iout)=dlat ! grid relative latitude
@@ -997,9 +997,12 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
! Winds --- u, v components
if (luvob) then
woe = obserr
+ iqm = 12
if (pob_mb < r50) woe = woe*r1_2
if (inflate_error) woe = woe*r1_2
- if (qcm > lim_qm ) woe = woe*1.0e6_r_kind
+ if (qcm > lim_qm ) then
+ woe = woe*1.0e6_r_kind
+ end if
if(regional .and. .not. fv3_regional)then
u0 = uob
v0 = vob
@@ -1046,9 +1049,12 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
! Temperature
if(ltob) then
toe = obserr
+ iqm = 10
if (pob_mb < r100) toe = toe*r1_2
if (inflate_error) toe = toe*r1_2
- if (qcm > lim_qm ) toe = toe*1.0e6_r_kind
+ if (qcm > lim_qm ) then
+ toe = toe*1.0e6_r_kind
+ end if
cdata_all( 1,iout)=toe ! temperature error
cdata_all( 2,iout)=dlon ! grid relative longitude
cdata_all( 3,iout)=dlat ! grid relative latitude
@@ -1081,11 +1087,14 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
if(lqob) then
qoe = obserr*one_tenth ! RH (e.g. 0.98)
qmaxerr = emerr
+ iqm = 11
if (inflate_error) then
qmaxerr = emerr*r0_7
qoe = qoe*r1_2
end if
- if (qcm > lim_qm ) qoe = qoe*1.0e6_r_kind
+ if (qcm > lim_qm ) then
+ qoe = qoe*1.0e6_r_kind
+ end if
cdata_all( 1,iout)=qoe ! q error (RH e.g. 0.98)
cdata_all( 2,iout)=dlon ! grid relative longitude
cdata_all( 3,iout)=dlat ! grid relative latitude
@@ -1116,12 +1125,15 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
! Winds --- surface wind speed
if (lspdob) then
woe = obserr
+ iqm = 11
if (inflate_error) woe = woe*r1_2
- if (qcm > lim_qm ) woe = woe*1.0e6_r_kind
+ if (qcm > lim_qm ) then
+ woe = woe*1.0e6_r_kind
+ end if
cdata_all( 1,iout)=woe ! wind error
cdata_all( 2,iout)=dlon ! grid relative longitude
cdata_all( 3,iout)=dlat ! grid relative latitude
- cdata_all( 4,iout)=dlnpsob ! ln(surface pressure in cb)
+ cdata_all( 4,iout)=r_missing ! ln(surface pressure in cb) !Since dlnpsob is not provided by SFMR, force it to be r_missing. Not used in setupspd.f90
cdata_all( 5,iout)=spdob*sqrt(two)*half ! u obs
cdata_all( 6,iout)=spdob*sqrt(two)*half ! v obs
cdata_all( 7,iout)=rstation_id ! station id
@@ -1142,6 +1154,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
cdata_all(22,iout)=r_prvstg(1,1) ! provider name
cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name
endif
+ if(usage >= r100)rusage(ndata)=.false.
end do loop_readsb2
end do loop_msg2
@@ -1154,31 +1167,76 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
deallocate(presl_thin)
call del3grids
endif
-
+
+ nxdata=ndata
+ ndata=0
+ if(nxdata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,ndata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' fl ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,&
+! numrem,numqc,numthin
+! If thinned data set quality mark to 14
+ if (ithin > 0 .and. ithin <5) then
+ do i=1,nxdata
+ if(rthin(i))cdata_all(iqm,i)=14
+ end do
+ end if
+
+! If flag to not save thinned data is set - compress data
+ if(pmot /= 1)then
+ do i=1,nxdata
+
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ ndata=ndata+1
+ if(i > ndata)then
+ do k=1,nreal
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
+ end if
+ end do
+ end if
+ end if
+ if(luvob)then
+ nodata=nodata+2*ndata
+ else
+ nodata=nodata+nxdata
+ end if
+
! Write header record and data to output file for further processing
- allocate(cdata_out(nreal,ndata))
- do i=1,ndata
- do k=1,nreal
- cdata_out(k,i)=cdata_all(k,i)
- end do
- end do
- deallocate(cdata_all)
! deallocate(etabl)
- call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs)
+ call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
- write(lunout) cdata_out
- deallocate(cdata_out)
-900 continue
+ write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata)
+ deallocate(cdata_all,rusage,rthin)
+
if(diagnostic_reg .and. ntest>0) write(6,*)'READ_FL_HDOB: ',&
'ntest, disterrmax=', ntest,disterrmax
if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_FL_HDOB: ',&
'nvtest,vdisterrmax=',ntest,vdisterrmax
if (ndata == 0) then
- write(6,*)'READ_FL_HDOB: no data to process'
+ write(6,*)'READ_FL_HDOB: no data to process',obstype
endif
- write(6,*)'READ_FL_HDOB: nreal=',nreal
+ write(6,*)'READ_FL_HDOB: nreal=',nreal,obstype
write(6,*)'READ_FL_HDOB: ntb,nread,ndata,nodata=',ntb,nread,ndata,nodata
diff --git a/src/gsi/read_gfs_ozone_for_regional.f90 b/src/gsi/read_gfs_ozone_for_regional.f90
index 5b6acce30b..52e07087c0 100644
--- a/src/gsi/read_gfs_ozone_for_regional.f90
+++ b/src/gsi/read_gfs_ozone_for_regional.f90
@@ -291,8 +291,8 @@ subroutine read_gfs_ozone_for_regional
if (nframe /= 0) call error_msg(trim(my_name),trim(filename),'nframe', &
'getfilehead',istop,nframe)
- fhour = float(nfhour) + float(nfminute)/r60 + &
- float(nfsecondn)/float(nfsecondd)/r3600
+ fhour = real(nfhour,r_kind) + real(nfminute,r_kind)/r60 + &
+ real(nfsecondn,r_kind)/real(nfsecondd,r_kind)/r3600
nsig_gfs=levs
jcap_org=njcap
@@ -319,9 +319,6 @@ subroutine read_gfs_ozone_for_regional
call stop2(85)
endif
- allocate(vcoord(levs+1,nvcoord))
- vcoord(:,1:nvcoord) = nems_vcoord(:,1:nvcoord,1)
- deallocate(nems_vcoord)
call nemsio_close(gfile,iret=iret)
if ( iret /= 0 ) call error_msg(trim(my_name),trim(filename),' ', &
@@ -416,7 +413,7 @@ subroutine read_gfs_ozone_for_regional
write(6,*)'READ_GFS_OZONE_FOR_REGIONAL: ***ERROR*** INVALID value for nvcoord=',sighead%nvcoord,filename
call stop2(85)
endif
- else if ( use_gfs_ncio ) then
+ else if ( use_gfs_ncio ) then
if (gfshead%nvcoord == 1) then
do k=1,nsig_gfs+1
bk5(k) = gfsheadv%vcoord(k,1)
@@ -437,6 +434,8 @@ subroutine read_gfs_ozone_for_regional
call stop2(85)
endif
else
+ allocate(vcoord(levs+1,nvcoord))
+ vcoord(:,1:nvcoord) = nems_vcoord(:,1:nvcoord,1)
if (nvcoord == 1) then
do k=1,nsig_gfs+1
bk5(k) = vcoord(k,1)
@@ -456,6 +455,7 @@ subroutine read_gfs_ozone_for_regional
write(6,*)'GET_GEFS_FOR_REGIONAL: ***ERROR*** INVALID value for nvcoord=',nvcoord
call stop2(85)
endif
+ deallocate(vcoord,nems_vcoord)
end if
! Load reference temperature array (used by general coordinate)
@@ -497,7 +497,6 @@ subroutine read_gfs_ozone_for_regional
vector=.false.
call general_sub2grid_create_info(grd_gfs,inner_vars,nlat_gfs,nlon_gfs,nsig_gfs,num_fields, &
.not.regional,vector)
- deallocate(vector)
jcap_gfs_test=jcap_gfs
call general_init_spec_vars(sp_gfs,jcap_gfs,jcap_gfs_test,grd_gfs%nlat,grd_gfs%nlon)
if (hires .and. .not. use_gfs_nemsio .and. .not. use_gfs_ncio) then
@@ -507,9 +506,6 @@ subroutine read_gfs_ozone_for_regional
! also want to set up regional grid structure variable grd_mix, which still has number of
! vertical levels set to nsig_gfs, but horizontal dimensions set to regional domain.
- num_fields=2*nsig_gfs
- allocate(vector(num_fields))
- vector=.false.
call general_sub2grid_create_info(grd_mix,inner_vars,nlat,nlon,nsig_gfs,num_fields,regional,vector)
deallocate(vector)
diff --git a/src/gsi/read_gmi.f90 b/src/gsi/read_gmi.f90
index 0f45aa7e28..6ad4d829a3 100644
--- a/src/gsi/read_gmi.f90
+++ b/src/gsi/read_gmi.f90
@@ -184,7 +184,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,&
integer(i_kind) :: jc,bufsat,n
integer(i_kind),dimension(5):: iobsdate
integer(i_kind):: method,iobs,num_obs
- integer(i_kind),parameter :: maxobs=4000000
+ integer(i_kind),parameter :: maxobs=6000000
!-- integer(i_kind),parameter :: nscan=74 ! after binning ifov, 221/3 + 1
integer(i_kind),parameter :: nscan=221
@@ -414,7 +414,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,&
call ufbrep(lnbufr,var_check1,1,nchanl,iret,'GMICHQ')
!call ufbrep(lnbufr,gmirfi,1,nchanl,iret,'GMIRFI')
call ufbrep(lnbufr,pixelsaza,1,ngs,iret,'SAZA')
- call ufbrep(lnbufr,val_angls,n_angls,ngs,iret,'SAMA SZA SMA SGA')
+ call ufbrep(lnbufr,val_angls,n_angls,ngs,iret,'BEARAZ SOZA SOLAZI SSGA')
call ufbint(lnbufr,pixelloc,2, 1,iret,'CLATH CLONH')
if (any(var_check1 < 99999999999_r_double)) then ! 100000000000 seems to be the missing value
@@ -528,6 +528,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,&
flgch = 0
iobs=iobs+1
+ if(iobs>maxobs) exit
end do read_loop
end do read_subset
690 continue
@@ -677,7 +678,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,&
if(.not. regional .and. dist1 > 0.75_r_kind) cycle obsloop
endif
- crit1 = crit1 + 10._r_kind * float(iskip)
+ crit1 = crit1 + 10._r_kind * real(iskip,r_kind)
call checkob(dist1,crit1,itx,iuse)
if(.not. iuse) then
cycle obsloop
@@ -695,7 +696,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,&
call deter_sfc(dlat,dlon,dlat_earth,dlon_earth,t4dv,isflg,idomsfc,sfcpct, &
ts,tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10,sfcr)
- call deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct)
+ call deter_sfc_gmi(dlat_earth,dlon_earth,isflg)
! Only keep obs over ocean - ej
@@ -818,7 +819,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,&
if(pos_max==0) then
j2=1
else
- j2=nint(float(pos_statis(i))/pos_max)
+ j2=nint(real(pos_statis(i),r_kind)/pos_max)
j2=max(1,j2)
endif
do j=1,pos_statis(i),j2
@@ -834,7 +835,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,&
if(pos_max==0) then
j2=1
else
- j2=nint(float(pos_statis(i))/pos_max)
+ j2=nint(real(pos_statis(i),r_kind)/pos_max)
j2=max(1,j2)
endif
do j=1,pos_statis(i),j2
diff --git a/src/gsi/read_goesglm.f90 b/src/gsi/read_goesglm.f90
index e0124abbf2..8746fa27dd 100644
--- a/src/gsi/read_goesglm.f90
+++ b/src/gsi/read_goesglm.f90
@@ -76,9 +76,8 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
character(8) subset
character(1) sidchr(8)
- integer(i_kind) ireadmg,ireadsb,icntpnt,icount
+ integer(i_kind) ireadmg,ireadsb,icntpnt
integer(i_kind) lunin,i
- integer(i_kind) itx
integer(i_kind) ihh,idd,idate,iret,im,iy,k
integer(i_kind) nchanl,nreal,ilat,ilon
integer(i_kind) lqm
@@ -89,7 +88,6 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
integer(i_kind) nmsg ! message index
integer(i_kind),parameter :: maxobs=2000000
integer(i_kind),dimension(5):: idate5
- integer(i_kind),allocatable,dimension(:):: isort,iloc
real(r_kind) time
real(r_kind) usage
@@ -99,7 +97,7 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
real(r_kind) cdist,disterr,disterrmax,rlon00,rlat00
real(r_kind) vdisterrmax
real(r_kind) timex,timeobs,toff,t4dv,zeps
- real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out
+ real(r_kind),allocatable,dimension(:,:):: cdata_all
!--- flash rate
real(r_kind),allocatable,dimension(:,:):: cdata_flash,cdata_flash_h
integer(i_kind) :: ndata_flash,ndata_flash_h
@@ -122,6 +120,10 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
nreal=13
lob = obstype == 'goes_glm'
+ if(.not.lob) then
+ write(6,*) 'mix-up reading goes_glm ',obstype
+ return
+ end if
! . . . .
@@ -139,8 +141,7 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
nmsg = 0
disterrmax=-9999.0_r_kind
- allocate(cdata_all(nreal,maxobs),isort(maxobs))
- isort = 0
+ allocate(cdata_all(nreal,maxobs))
cdata_all=zero
nread=0
ntest=0
@@ -224,7 +225,7 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
call w3fs21(idate5,minan) ! analysis ref time in seconds relative to historic date
! Add obs reference time, then subtract analysis time to get obs time relative to analysis
- time_correction=float(minobs-minan)*r60inv
+ time_correction=real(minobs-minan,r_kind)*r60inv
else
time_correction=zero
end if
@@ -276,9 +277,9 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
icntpnt=icntpnt+1
ndata=ndata+1
+ if(ndata>maxobs) exit
nodata=nodata+1
iout=ndata
- isort(icntpnt)=iout
if (ndata > maxobs) then
write(6,*)'READ_GOESGLM: ***WARNING*** ndata > maxobs for ',obstype
@@ -290,21 +291,19 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
usage = zero
if (iuse_light(nlighttype) <= 0)usage=100._r_kind
- if (lob) then
- cdata_all(1,iout) =loe ! lightning observation error
- cdata_all(2,iout) =dlon ! grid relative longitude
- cdata_all(3,iout) =dlat ! grid relative latitude
- cdata_all(4,iout) =iout ! lightning obs
- cdata_all(5,iout) =rstation_id ! station id
- cdata_all(6,iout) =t4dv ! analysis time
- cdata_all(7,iout) =nlighttype ! type
- cdata_all(8,iout) =lmerr ! lightning max error
- cdata_all(9,iout) =lqm ! quality mark
- cdata_all(10,iout)=loe ! original lightning obs error loe
- cdata_all(11,iout)=usage ! usage parameter
- cdata_all(12,iout)=dlon_earth*rad2deg ! earth relative lon (degrees)
- cdata_all(13,iout)=dlat_earth*rad2deg ! earth relative lat (degrees)
- end if
+ cdata_all(1,iout) =loe ! lightning observation error
+ cdata_all(2,iout) =dlon ! grid relative longitude
+ cdata_all(3,iout) =dlat ! grid relative latitude
+ cdata_all(4,iout) =iout ! lightning obs
+ cdata_all(5,iout) =rstation_id ! station id
+ cdata_all(6,iout) =t4dv ! analysis time
+ cdata_all(7,iout) =nlighttype ! type
+ cdata_all(8,iout) =lmerr ! lightning max error
+ cdata_all(9,iout) =lqm ! quality mark
+ cdata_all(10,iout)=loe ! original lightning obs error loe
+ cdata_all(11,iout)=usage ! usage parameter
+ cdata_all(12,iout)=dlon_earth*rad2deg ! earth relative lon (degrees)
+ cdata_all(13,iout)=dlat_earth*rad2deg ! earth relative lat (degrees)
! end loop on read line BUFR
@@ -322,30 +321,7 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
call closbf(lunin)
! Write header record and data to output file for further processing
- allocate(iloc(ndata))
- icount=0.
- do i=1,maxobs
- if(isort(i) > 0)then
- icount=icount+1
- iloc(icount)=isort(i)
- end if
- end do
- if(ndata /= icount)then
- write(6,*) ' READ_GOESGLM: mix up in read_goesglm ,ndata,icount ',ndata,icount
- call stop2(50)
- end if
- allocate(cdata_out(nreal,ndata))
- do i=1,ndata
- itx=iloc(i)
- do k=1,nreal
- cdata_out(k,i)=cdata_all(k,itx)
- end do
- end do
-
- deallocate(iloc,isort,cdata_all)
-
-! . . . .
! Call to the subroutine that transforms lightning strikes into lightning flash rate
@@ -360,9 +336,9 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
allocate(cdata_flash_h(nreal,ndata_flash_h))
call convert_to_flash_rate &
- (nreal,ndata,cdata_out,ndata_flash_h,cdata_flash_h,ndata_flash)
+ (nreal,ndata,cdata_all,ndata_flash_h,cdata_flash_h,ndata_flash)
- deallocate(cdata_out)
+ deallocate(cdata_all)
ndata=ndata_flash
allocate(cdata_flash(nreal,ndata))
@@ -387,8 +363,8 @@ subroutine read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twindin,sis)
else ! ndata=0
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
- write(lunout) cdata_out
- deallocate(cdata_out)
+ write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata)
+ deallocate(cdata_all)
end if !! if(ndata =/ 0) then
@@ -511,13 +487,13 @@ subroutine convert_to_flash_rate &
end do !! do iobs=2,ndata_strike
- darea=darea_sum/float(ndata_strike)
+ darea=darea_sum/real(ndata_strike,r_kind)
else !! ndata_strike=0
darea=zero
end if !! if(ndata_strike>0) then
- dtime=float(nhr_assimilation)
+ dtime=real(nhr_assimilation,r_kind)
! Regional
@@ -573,8 +549,8 @@ subroutine convert_to_flash_rate &
!! find lightning strikes near the (ii0,jj0) point
- xbound=float(ii0)
- ybound=float(jj0)
+ xbound=real(ii0,r_kind)
+ ybound=real(jj0,r_kind)
xflag=(xx>xbound) .AND. (xxybound) .AND. (yy0) then
- glon_central(index)=glon_central(index)/float(lcount(index))
- glat_central(index)=glat_central(index)/float(lcount(index))
- lon_central(index)= lon_central(index)/float(lcount(index))
- lat_central(index)= lat_central(index)/float(lcount(index))
+ glon_central(index)=glon_central(index)/real(lcount(index),r_kind)
+ glat_central(index)=glat_central(index)/real(lcount(index),r_kind)
+ lon_central(index)= lon_central(index)/real(lcount(index),r_kind)
+ lat_central(index)= lat_central(index)/real(lcount(index),r_kind)
endif !! if(lcount(index)>0) then
enddo !! do index=1,ngridh
@@ -652,7 +628,7 @@ subroutine convert_to_flash_rate &
cdata_flash_h( 3,icount)=glat_central(index)
if (darea>0._r_kind) then
- cdata_flash_h( 4,icount)=float(lcount(index))/(darea*dtime)
+ cdata_flash_h( 4,icount)=real(lcount(index),r_kind)/(darea*dtime)
else
cdata_flash_h( 4,icount)=0.
end if
@@ -726,22 +702,22 @@ subroutine convert_time (date_old,date_new,nmax)
jdd=INT(0.0001_r_kind*xdate(i))
idd=INT(xdate(i))-jdd*10000
- ysumidd=float(idd)
- dd=float(INT(0.01_r_kind*ysumidd))
+ ysumidd=real(idd,r_kind)
+ dd=real(INT(0.01_r_kind*ysumidd),r_kind)
hh=ysumidd-dd*100._r_kind
sumidd=sumidd+dd*24._r_kind+hh
enddo !! do i=1,nmax
- xsumidd=float(sumidd)/nmax
- ysumidd=float(INT(xsumidd))
+ xsumidd=real(sumidd,r_kind)/nmax
+ ysumidd=real(INT(xsumidd),r_kind)
kdd=INT(xsumidd/24._r_kind)
- xdd=float(kdd)
- xhh=ysumidd-float(kdd)*24._r_kind
+ xdd=real(kdd,r_kind)
+ xhh=ysumidd-real(kdd,r_kind)*24._r_kind
- ydate=float(jdd)*10000._r_kind+xdd*100._r_kind+xhh+xccyy
+ ydate=real(jdd,r_kind)*10000._r_kind+xdd*100._r_kind+xhh+xccyy
date_old=ydate
diff --git a/src/gsi/read_goesimgr_skycover.f90 b/src/gsi/read_goesimgr_skycover.f90
index dda9aad6f4..97eeb5e695 100644
--- a/src/gsi/read_goesimgr_skycover.f90
+++ b/src/gsi/read_goesimgr_skycover.f90
@@ -50,14 +50,14 @@ subroutine read_goesimgr_skycover(nread,ndata,nodata,infile,obstype,lunout,gsti
use constants, only: zero,one_tenth,one,deg2rad,half,&
three,four, r60inv,r10,r100,r2000
- use convinfo, only: nconvtype, &
- icuse,ictype,ioctype,&
- ithin_conv,rmesh_conv,pmesh_conv,ctwind
- use convthin, only: make3grids,map3grids,del3grids,use_all
+ use convinfo, only: nconvtype,icuse,ictype,ioctype,&
+ ithin_conv,rmesh_conv,pmesh_conv,ctwind,pmot_conv
+! use convinfo, only: icsubtype
+ use convthin, only: make3grids,map3grids_m,del3grids,use_all
use gridmod, only: regional,nlon,nlat,nsig,tll2xy,txy2ll,&
rlats,rlons
use deter_sfc_mod, only: deter_sfc2
- use obsmod, only: bmiss,ran01dom
+ use obsmod, only: bmiss,ran01dom,reduce_diag
use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,time_4dvar,thin4d
use adjust_cloudobs_mod, only: adjust_goescldobs
use mpimod, only: npe
@@ -95,9 +95,8 @@ subroutine read_goesimgr_skycover(nread,ndata,nodata,infile,obstype,lunout,gsti
integer(i_kind) :: iret,kx,pflag,nlevp,nmind,levs,idomsfc
integer(i_kind) :: low_cldamt_qc,mid_cldamt_qc,hig_cldamt_qc,tcamt_qc
integer(i_kind) :: ithin,klat1,klon1,klonp1,klatp1,kk,k,ilat,ilon,nchanl
- integer(i_kind) :: iout,ntmp,iiout,maxobs,icount,itx,iuse,idate,ierr
+ integer(i_kind) :: iout,maxobs,iuse,idate,ierr
integer(i_kind),dimension(5) :: idate5
- integer(i_kind),allocatable,dimension(:):: isort,iloc
real(r_kind) :: dlat,dlon,dlat_earth,dlon_earth,toff,t4dv
real(r_kind) :: dlat_earth_deg,dlon_earth_deg
real(r_kind) :: dx,dx1,dy,dy1,w00,w10,w01,w11,crit1,timedif,tdiff
@@ -106,10 +105,13 @@ subroutine read_goesimgr_skycover(nread,ndata,nodata,infile,obstype,lunout,gsti
real(r_kind) :: low_cldamt,mid_cldamt,hig_cldamt,usage,zz,sfcr,rstation_id
real(r_kind),allocatable,dimension(:):: presl_thin
real(r_kind),dimension(nsig):: presl
- real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out
+ real(r_kind),allocatable,dimension(:,:):: cdata_all
real(r_double),dimension(9):: hdr
real(r_double),dimension(3):: goescld
-
+ logical,allocatable,dimension(:)::rthin,rusage
+ logical save_all
+! integer(i_kind) numthin,numqc,numrem,numall
+ integer(i_kind) nxdata,pmot
logical :: outside,ithinp,luse
@@ -196,8 +198,7 @@ subroutine read_goesimgr_skycover(nread,ndata,nodata,infile,obstype,lunout,gsti
end do
maxobs=ntb
- allocate(cdata_all(nreal,maxobs),isort(maxobs))
- isort = 0
+ allocate(cdata_all(nreal,maxobs),rusage(maxobs),rthin(maxobs))
cdata_all=zero
nread=0
nchanl=0
@@ -211,211 +212,240 @@ subroutine read_goesimgr_skycover(nread,ndata,nodata,infile,obstype,lunout,gsti
call openbf(lunin,'IN',lunin)
call datelen(10)
- loop_msg: do while (ireadmg(lunin,subset,idate) == 0)
- loop_readsb: do while (ireadsb(lunin) == 0)
- ntb=ntb+1
- ! - Extract type, date, and location information
- call ufbint(lunin,hdr,9,1,iret,hdrstr)
-
- ! - Compare relative obs time with window. If obs
- ! - falls outside of window, don't use this obs
- idate5(1) = hdr(2) ! year
- idate5(2) = hdr(3) ! month
- idate5(3) = hdr(4) ! day
- idate5(4) = hdr(5) ! hours
- idate5(5) = hdr(6) ! minutes
- call w3fs21(idate5,nmind)
- rminobs=real(nmind,8)+(real(hdr(7),8)*r60inv)!convert the seconds of the ob to minutes and store to rminobs
- t4dv = (rminobs-real(iwinbgn,r_kind))*r60inv
- tdiff=(rminobs-gstime)*r60inv !GS time is the analysis time in minutes from w3fs21
-
- if (l4dvar.or.l4densvar) then
- if (t4dvwinlen) cycle loop_readsb
- else
- ! - Check to make sure ob is within convinfo time window (ctwind) and
- ! - is within overwall time window twind (usually +-3)
- if( (abs(tdiff) > ctwind(nc)) .or. (abs(tdiff) > twind) )cycle loop_readsb
- endif
-
-
- kx=999_i_kind !hardwire typ to 999
- if(abs(hdr(8))>r90 .or. abs(hdr(9))>r360) cycle loop_readsb
- if(hdr(9)== r360)hdr(9)=hdr(9)-r360
- if(hdr(9) < zero)hdr(9)=hdr(9)+r360
- dlon_earth_deg = hdr(9)
- dlat_earth_deg = hdr(8)
- dlon_earth=hdr(9)*deg2rad
- dlat_earth=hdr(8)*deg2rad
- nread=nread+1
- if(regional)then
- call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) ! convert to rotated coordinate
- if(outside) cycle loop_readsb ! check to see if outside regional domain
- else
- dlat = dlat_earth
- dlon = dlon_earth
- call grdcrd1(dlat,rlats,nlat,1)
- call grdcrd1(dlon,rlons,nlon,1)
- endif
+ pmot=nint(pmot_conv(nc))
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
+ rusage = .true.
+ rthin = .false.
+ use_all=.true.
+
+ loop_msg: do while (ireadmg(lunin,subset,idate) == 0)
+ loop_readsb: do while (ireadsb(lunin) == 0)
+ ntb=ntb+1
+ ! - Extract type, date, and location information
+ call ufbint(lunin,hdr,9,1,iret,hdrstr)
+
+ ! - Compare relative obs time with window. If obs
+ ! - falls outside of window, don't use this obs
+ idate5(1) = hdr(2) ! year
+ idate5(2) = hdr(3) ! month
+ idate5(3) = hdr(4) ! day
+ idate5(4) = hdr(5) ! hours
+ idate5(5) = hdr(6) ! minutes
+ call w3fs21(idate5,nmind)
+ rminobs=real(nmind,8)+(real(hdr(7),8)*r60inv)!convert the seconds of the ob to minutes and store to rminobs
+ t4dv = (rminobs-real(iwinbgn,r_kind))*r60inv
+ tdiff=(rminobs-gstime)*r60inv !GS time is the analysis time in minutes from w3fs21
+
+ if (l4dvar.or.l4densvar) then
+ if (t4dvwinlen) cycle loop_readsb
+ else
+ ! - Check to make sure ob is within convinfo time window (ctwind) and
+ ! - is within overwall time window twind (usually +-3)
+ if( (abs(tdiff) > ctwind(nc)) .or. (abs(tdiff) > twind) )cycle loop_readsb
+ endif
- ! Read in the obs
- goescld=bmiss
- call ufbint(lunin,goescld,3,1,levs,goescldstr_new)
- if (goescld(3) > r0_01_bmiss) then
+
+ kx=999_i_kind !hardwire typ to 999
+ if(abs(hdr(8))>r90 .or. abs(hdr(9))>r360) cycle loop_readsb
+ if(hdr(9)== r360)hdr(9)=hdr(9)-r360
+ if(hdr(9) < zero)hdr(9)=hdr(9)+r360
+ dlon_earth_deg = hdr(9)
+ dlat_earth_deg = hdr(8)
+ dlon_earth=hdr(9)*deg2rad
+ dlat_earth=hdr(8)*deg2rad
+ nread=nread+1
+ if(regional)then
+ call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) ! convert to rotated coordinate
+ if(outside) cycle loop_readsb ! check to see if outside regional domain
+ else
+ dlat = dlat_earth
+ dlon = dlon_earth
+ call grdcrd1(dlat,rlats,nlat,1)
+ call grdcrd1(dlon,rlons,nlon,1)
+ endif
+
+ ! Read in the obs
+ goescld=bmiss
+ call ufbint(lunin,goescld,3,1,levs,goescldstr_new)
+ if (goescld(3) > r0_01_bmiss) then
! if ob is missing, look for it in old BUFR mnemonic sequence
- goescld=bmiss
- call ufbint(lunin,goescld,3,1,levs,goescldstr)
- if (goescld(3) > r0_01_bmiss) cycle loop_readsb !If obs are missing, cycle
- endif
- c_prvstg=cspval
- c_sprvstg=cspval
-
- ! - Set station ID
- rstation_id=goescld(1)
+ goescld=bmiss
+ call ufbint(lunin,goescld,3,1,levs,goescldstr)
+ if (goescld(3) > r0_01_bmiss) cycle loop_readsb !If obs are missing, cycle
+ endif
+ c_prvstg=cspval
+ c_sprvstg=cspval
+
+ ! - Set station ID
+ rstation_id=goescld(1)
- ithin=ithin_conv(nc)
- ithinp = ithin > 0 .and. pflag /= 0
-
- ! - Thin in vertical - note we can only thin in the horizontal
- ! - since sky cover is a 2D field. So this branch should never run
- ! - unless we get info about the vertical location of the clouds in the
- ! - future. Leaving here as a 'just-in-case' measure.
- if(ithinp )then
-! Interpolate guess pressure profile to observation location
- klon1= int(dlon); klat1= int(dlat)
- dx = dlon-klon1; dy = dlat-klat1
- dx1 = one-dx; dy1 = one-dy
- w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy
-
- klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon)
- if (klon1==0) klon1=nlon
- klatp1=min(nlat,klat1+1); klonp1=klon1+1
- if (klonp1==nlon+1) klonp1=1
+ ithin=ithin_conv(nc)
+ ithinp = ithin > 0 .and. pflag /= 0
+
+ ! - Thin in vertical - note we can only thin in the horizontal
+ ! - since sky cover is a 2D field. So this branch should never run
+ ! - unless we get info about the vertical location of the clouds in the
+ ! - future. Leaving here as a 'just-in-case' measure.
+ if(ithinp )then
+! Interpolate guess pressure profile to observation location
+ klon1= int(dlon); klat1= int(dlat)
+ dx = dlon-klon1; dy = dlat-klat1
+ dx1 = one-dx; dy1 = one-dy
+ w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy
+
+ klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon)
+ if (klon1==0) klon1=nlon
+ klatp1=min(nlat,klat1+1); klonp1=klon1+1
+ if (klonp1==nlon+1) klonp1=1
+ do kk=1,nsig
+ presl(kk)=w00*prsl_full(klat1 ,klon1 ,kk) + &
+ w10*prsl_full(klatp1,klon1 ,kk) + &
+ w01*prsl_full(klat1 ,klonp1,kk) + &
+ w11*prsl_full(klatp1,klonp1,kk)
+ end do
+ end if
+
+ iuse=icuse(nc)
+
+ ! General block for data thinning - if requested
+ if (ithin > 0 .and. iuse >=0) then
+ ! - Set data quality index for thinning
+ if (thin4d) then
+ timedif = zero
+ else
+ timedif=abs(t4dv-toff)
+ endif
+
+ crit1 = timedif/r6+half
+
+ ! - simple 1-to-1 mapping of vertical levels when no thinning in the vertical
+ if (pflag==0) then
do kk=1,nsig
- presl(kk)=w00*prsl_full(klat1 ,klon1 ,kk) + &
- w10*prsl_full(klatp1,klon1 ,kk) + &
- w01*prsl_full(klat1 ,klonp1,kk) + &
- w11*prsl_full(klatp1,klonp1,kk)
+ presl_thin(kk)=presl(kk)
end do
- end if
-
- iuse=icuse(nc)
-
- ! General block for data thinning - if requested
- if (ithin > 0 .and. iuse >=0) then
- ntmp=ndata ! counting moved to map3gridS
- ! - Set data quality index for thinning
- if (thin4d) then
- timedif = zero
- else
- timedif=abs(t4dv-toff)
- endif
-
- crit1 = timedif/r6+half
-
- ! - simple 1-to-1 mapping of vertical levels when no thinning in the vertical
- if (pflag==0) then
- do kk=1,nsig
- presl_thin(kk)=presl(kk)
- end do
- endif
- ppb=one_tenth*1013.25_r_kind !number is irrelevant for 2D - set to standard SLP -> 1013.25 and convert from mb to cb
- call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
- ppb,crit1,ndata,iout,ntb,iiout,luse,.false.,.false.)
-
- if (.not. luse) cycle loop_readsb
- if(iiout > 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+1
- endif
- isort(ntb)=iout
- else ! - no thinnning
- ndata=ndata+1
- nodata=nodata+1
- iout=ndata
- isort(ntb)=iout
- endif
-
- !- Set usage variable
- usage = 0
- if(iuse <= 0)usage=r100
-
- ! Get information from surface file necessary for conventional data here
- call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,tsavg,ff10,sfcr,zz)
-
- ! - Obtain the ob and tune the QC marks for ob error tuning a bit later
-
- call adjust_goescldobs(goescld(3),tdiff,dlat_earth,dlon_earth, &
- low_cldamt,low_cldamt_qc,mid_cldamt,mid_cldamt_qc, &
- hig_cldamt,hig_cldamt_qc,tcamt,tcamt_qc)
-
-
- if(tcamt_qc==15 .or. tcamt_qc==12 .or. tcamt_qc==9 .or. tcamt_qc==8) usage=r100
- tcamt_oe=20.0_r_kind
- if(tcamt_qc==1) tcamt_oe=tcamt_oe*1.25_r_kind
- if(tcamt_qc==2) tcamt_oe=tcamt_oe*1.50_r_kind
- if(tcamt_qc==3) tcamt_oe=tcamt_oe*1.75_r_kind
-
- cdata_all( 1,iout)=tcamt_oe ! obs error
- cdata_all( 2,iout)=dlon ! grid relative longitude
- cdata_all( 3,iout)=dlat ! grid relative latitude
- cdata_all( 4,iout)=tcamt ! total cloud amount (%)
- cdata_all( 5,iout)=rstation_id ! station ID
- cdata_all( 6,iout)=t4dv ! time
- cdata_all( 7,iout)=nc ! type
- cdata_all( 8,iout)=tcamt_qc ! quality mark
- cdata_all( 9,iout)=usage ! usage parameter
- cdata_all(10,iout)=idomsfc ! dominate surface type
- cdata_all(11,iout)=tsavg ! skin temperature
- cdata_all(12,iout)=ff10 ! 10 meter wind factor
- cdata_all(13,iout)=sfcr ! surface roughness
- cdata_all(14,iout)=dlon_earth_deg ! earth relative longitude (degrees)
- cdata_all(15,iout)=dlat_earth_deg ! earth relative latitude (degrees)
- cdata_all(16,iout)=bmiss ! station elevation (m)
- cdata_all(17,iout)=bmiss ! observation height (m)
- cdata_all(18,iout)=zz ! terrain height at ob location
- cdata_all(19,iout)=r_prvstg(1,1) ! provider name
- cdata_all(20,iout)=r_sprvstg(1,1) ! subprovider name
-
- enddo loop_readsb
-
- enddo loop_msg
-
-! Close unit to bufr file
- call closbf(lunin)
-! Deallocate arrays used for thinning data
- if (.not.use_all) then
- deallocate(presl_thin)
- call del3grids
- endif
+ endif
+ ppb=one_tenth*1013.25_r_kind !number is irrelevant for 2D - set to standard SLP -> 1013.25 and convert from mb to cb
+ call map3grids_m(-1,save_all,pflag,presl_thin,nlevp, &
+ dlat_earth,dlon_earth,ppb,crit1,ndata,&
+ luse,maxobs,rthin,.false.,.false.)
+
+ if (.not. luse) cycle loop_readsb
+ else ! - no thinnning
+ ndata=ndata+1
+ endif
+ iout=ndata
+
+ !- Set usage variable
+ usage = 0
+ if(iuse <= 0)usage=r100
+
+ ! Get information from surface file necessary for conventional data here
+ call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,tsavg,ff10,sfcr,zz)
+
+ ! - Obtain the ob and tune the QC marks for ob error tuning a bit later
+
+ call adjust_goescldobs(goescld(3),tdiff,dlat_earth,dlon_earth, &
+ low_cldamt,low_cldamt_qc,mid_cldamt,mid_cldamt_qc, &
+ hig_cldamt,hig_cldamt_qc,tcamt,tcamt_qc)
+
+
+ if(tcamt_qc==15 .or. tcamt_qc==12 .or. tcamt_qc==9 .or. tcamt_qc==8) usage=r100
+ tcamt_oe=20.0_r_kind
+ if(tcamt_qc==1) tcamt_oe=tcamt_oe*1.25_r_kind
+ if(tcamt_qc==2) tcamt_oe=tcamt_oe*1.50_r_kind
+ if(tcamt_qc==3) tcamt_oe=tcamt_oe*1.75_r_kind
+
+ cdata_all( 1,iout)=tcamt_oe ! obs error
+ cdata_all( 2,iout)=dlon ! grid relative longitude
+ cdata_all( 3,iout)=dlat ! grid relative latitude
+ cdata_all( 4,iout)=tcamt ! total cloud amount (%)
+ cdata_all( 5,iout)=rstation_id ! station ID
+ cdata_all( 6,iout)=t4dv ! time
+ cdata_all( 7,iout)=nc ! type
+ cdata_all( 8,iout)=tcamt_qc ! quality mark
+ cdata_all( 9,iout)=usage ! usage parameter
+ cdata_all(10,iout)=idomsfc ! dominate surface type
+ cdata_all(11,iout)=tsavg ! skin temperature
+ cdata_all(12,iout)=ff10 ! 10 meter wind factor
+ cdata_all(13,iout)=sfcr ! surface roughness
+ cdata_all(14,iout)=dlon_earth_deg ! earth relative longitude (degrees)
+ cdata_all(15,iout)=dlat_earth_deg ! earth relative latitude (degrees)
+ cdata_all(16,iout)=bmiss ! station elevation (m)
+ cdata_all(17,iout)=bmiss ! observation height (m)
+ cdata_all(18,iout)=zz ! terrain height at ob location
+ cdata_all(19,iout)=r_prvstg(1,1) ! provider name
+ cdata_all(20,iout)=r_sprvstg(1,1) ! subprovider name
+ if(usage >=r100)rusage(ndata)=.false.
+
+ enddo loop_readsb
+
+ enddo loop_msg
+
+! Close unit to bufr file
+ call closbf(lunin)
+! Deallocate arrays used for thinning data
+ if (.not.use_all) then
+ deallocate(presl_thin)
+ call del3grids
+ endif
! Normal exit
-
-! Write header record and data to output file for further processing
- allocate(iloc(ndata))
- icount=0
- do i=1,maxobs
- if(isort(i) > 0)then
- icount=icount+1
- iloc(icount)=isort(i)
+ nxdata=ndata
+ ndata=0
+ if(nxdata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,nxdata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' sky ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin
+! If thinned data set usage
+ if (ithin > 0 .and. ithin <5) then
+ do i=1,nxdata
+ if(rthin(i))then
+ cdata_all(9,i)=100._r_kind
+ cdata_all(8,i)=14
+ end if
+ end do
end if
- end do
- if(ndata /= icount)then
- write(6,*) myname,': ndata and icount do not match STOPPING...ndata,icount ',ndata,icount
- call stop2(50)
+! If flag to not save thinned data is set - compress data
+ if(pmot /= 1)then
+ do i=1,nxdata
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ ndata=ndata+1
+ if(i > ndata)then
+ do k=1,nreal
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
+ end if
+ end do
+ end if
+ nodata=nodata+ndata
end if
- allocate(cdata_out(nreal,ndata))
- do i=1,ndata
- itx=iloc(i)
- do k=1,nreal
- cdata_out(k,i)=cdata_all(k,itx)
- end do
- end do
- deallocate(iloc,isort,cdata_all)
+
+! Write header record and data to output file for further processing
- call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs)
+ call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata
- write(lunout) cdata_out
+ write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata)
- deallocate(cdata_out)
+ deallocate(cdata_all,rusage,rthin)
if (ndata == 0) then
write(6,*)myname,'no read_goesimgr_skycover data'
diff --git a/src/gsi/read_goesndr.f90 b/src/gsi/read_goesndr.f90
index 86fc1f0a5c..7c55b6ab4c 100644
--- a/src/gsi/read_goesndr.f90
+++ b/src/gsi/read_goesndr.f90
@@ -382,7 +382,7 @@ subroutine read_goesndr(mype,val_goes,ithin,rmesh,jsatid,infile,&
nread=nread+nchanl
crit0=0.01_r_kind
- if(ifov < mfov .and. ifov > 0) crit0 = crit0+two*float(mfov-ifov)
+ if(ifov < mfov .and. ifov > 0) crit0 = crit0+two*real(mfov-ifov,r_kind)
timeinflat=6.0_r_kind
call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh)
call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh)
diff --git a/src/gsi/read_gps.f90 b/src/gsi/read_gps.f90
index 3d8379ee3b..02012cb5f6 100644
--- a/src/gsi/read_gps.f90
+++ b/src/gsi/read_gps.f90
@@ -137,21 +137,32 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, &
bend_error,ref_error,bend_pccf,ref_pccf
real(r_kind),allocatable,dimension(:,:):: cdata_all
-
- integer(i_kind),parameter:: n1ahdr=10
+
+!> xuanli
+! integer(i_kind),parameter:: n1ahdr=10
+ integer(i_kind),parameter:: n1ahdr=13
+!< xuanli
real(r_double),dimension(n1ahdr):: bfr1ahdr
real(r_double),dimension(50,maxlevs):: data1b
real(r_double),dimension(50,maxlevs):: data2a
real(r_double),dimension(maxlevs):: nreps_this_ROSEQ2
+
+!> xuanli
+ real(r_kind):: azm_ang, sat_ascd, sat_constid, siid, ogce
+!< xuanli
data lnbufr/10/
- data hdr1a / 'YEAR MNTH DAYS HOUR MINU PCCF ELRC SAID PTID GEODU' /
+! data hdr1a / 'YEAR MNTH DAYS HOUR MINU PCCF ELRC SAID PTID GEODU' /
+ data hdr1a / 'YEAR MNTH DAYS HOUR MINU PCCF ELRC SAID PTID GEODU SCLF SIID OGCE' /
data nemo /'QFRO'/
!***********************************************************************************
maxobs=2e6
- nreal=maxinfo
+!> xuanli
+! nreal=maxinfo
+ nreal=24
+!< xuanli
nchanl=0
ilon=2
ilat=3
@@ -170,7 +181,6 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, &
write(6,*)'READ GPS: CONVINFO DOES NOT INCLUDE ANY ',trim(sis),' DATA'
return
end if
-
! Open file for input, then read bufr data
open(lnbufr,file=trim(infile),form='unformatted')
call openbf(lnbufr,'IN',lnbufr)
@@ -214,16 +224,19 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, &
call ufbint(lnbufr,qfro,1,1,iret,nemo)
! observation time in minutes
- idate5(1) = bfr1ahdr(1) ! year
- idate5(2) = bfr1ahdr(2) ! month
- idate5(3) = bfr1ahdr(3) ! day
- idate5(4) = bfr1ahdr(4) ! hour
- idate5(5) = bfr1ahdr(5) ! minute
- pcc=bfr1ahdr(6) ! profile per cent confidence
- roc=bfr1ahdr(7) ! Earth local radius of curvature
- said=bfr1ahdr(8) ! Satellite identifier
- ptid=bfr1ahdr(9) ! Platform transmitter ID number
- geoid=bfr1ahdr(10) ! Geoid undulation
+ idate5(1) = bfr1ahdr(1) ! year
+ idate5(2) = bfr1ahdr(2) ! month
+ idate5(3) = bfr1ahdr(3) ! day
+ idate5(4) = bfr1ahdr(4) ! hour
+ idate5(5) = bfr1ahdr(5) ! minute
+ pcc=bfr1ahdr(6) ! profile per cent confidence
+ roc=bfr1ahdr(7) ! Earth local radius of curvature
+ said=bfr1ahdr(8) ! Satellite identifier
+ ptid=bfr1ahdr(9) ! Platform transmitter ID number
+ geoid=bfr1ahdr(10) ! Geoid undulation
+ sat_constid=bfr1ahdr(11) ! Satellite classification
+ siid=bfr1ahdr(12) ! Satellite instrument
+ ogce = bfr1ahdr(13) ! Identification of originating/generating centre
call w3fs21(idate5,minobs)
! Locate satellite id in convinfo file
@@ -235,7 +248,7 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, &
exit find_loop
endif
end do find_loop
- if (ikx==0) then
+ if (ikx==0) then
cycle read_loop
endif
@@ -296,6 +309,16 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, &
endif
endif
+!> xuanli ascending flag: when qfro bit3 is set, occultation is ascending
+! bit3 is clear, occultation is descending
+ sat_ascd = 0.0
+ call upftbv(lnbufr,nemo,qfro,mxib,ibit,nib)
+ if(nib > 0) then
+ do i=1,nib
+ if(ibit(i) .eq. 3) sat_ascd=1.0
+ enddo
+ endif
+!< xuanli
! Read bending angle information
! Get the number of occurences of sequence ROSEQ2 in this subset
@@ -345,6 +368,7 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, &
nread=nread+1 ! count observations
rlat=data1b(1,k) ! earth relative latitude (degrees)
rlon=data1b(2,k) ! earth relative longitude (degrees)
+ azm_ang=data1b(3,k) ! azimuth angle !xuanli
height=data2a(1,k)
ref=data2a(2,k)
ref_error=data2a(4,k)
@@ -368,8 +392,7 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, &
good=.true.
if((abs(rlat)>90._r_kind).or.(abs(rlon)>r360).or.(height<=zero)) then
good=.false.
- endif
- if (ref_obs) then
+ else if (ref_obs) then
if ((ref>=1.e+9_r_kind).or.(ref<=zero).or.(height>=1.e+9_r_kind)) then
good=.false.
endif
@@ -440,7 +463,16 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, &
cdata_all(14,ndata)= dlon_earth_deg ! earth relative longitude (degrees)
cdata_all(15,ndata)= dlat_earth_deg ! earth relative latitude (degrees)
cdata_all(16,ndata)= geoid ! geoid undulation (m)
-
+!> xuanli
+ cdata_all(17,ndata)= qfro ! qfro
+ cdata_all(18,ndata)= sat_ascd ! ascending flag
+ cdata_all(19,ndata)= azm_ang ! azimuth angle
+ cdata_all(20,ndata)= sat_constid ! satellite classification
+ cdata_all(21,ndata)= siid ! occulting satellite
+ cdata_all(22,ndata)= ogce ! Identification of originating/generating centre
+ cdata_all(23,ndata)= ref ! refractivity obs (units of N)
+ cdata_all(24,ndata)= height ! geometric height above geoid (m)
+!< xuanli
else
notgood = notgood + 1
end if
@@ -466,8 +498,9 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, &
write(6,*)'READ_GPS: # bad or missing data=', notgood
do i=1,ngpsro_type
if (nmrecs_id(i)>0) &
- write(6,1020)'READ_GPS: LEO_id,nprof_gps = ',gpsro_itype(i),nmrecs_id(i)
+ write(6,1021)'READ_GPS: LEO_id,nprof_gps = ',gpsro_itype(i),nmrecs_id(i)
end do
+1021 format(a31,i6,i6)
write(6,1020)'READ_GPS: ref_obs,nprof_gps= ',ref_obs,nprof_gps
1020 format(a31,L,i6)
diff --git a/src/gsi/read_iasi.f90 b/src/gsi/read_iasi.f90
index 367c224508..362d7257a4 100644
--- a/src/gsi/read_iasi.f90
+++ b/src/gsi/read_iasi.f90
@@ -118,7 +118,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
use crtm_spccoeff, only: sc,crtm_spccoeff_load,crtm_spccoeff_destroy
use gridmod, only: diagnostic_reg,regional,nlat,nlon,&
tll2xy,txy2ll,rlats,rlons
- use constants, only: zero,deg2rad,rad2deg,r60inv,one,ten,r100
+ use constants, only: zero,deg2rad,rad2deg,r60inv,one,ten,r100,r_missing
use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen
use calc_fov_crosstrk, only: instrument_init, fov_check, fov_cleanup
use deter_sfc_mod, only: deter_sfc,deter_sfc_fov
@@ -127,6 +127,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
use gsi_nstcouplermod, only: gsi_nstcoupler_skindepth, gsi_nstcoupler_deter
use mpimod, only: npe
use gsi_io, only: verbose
+ use qcmod, only: iasi_cads
! use radiance_mod, only: rad_obs_type
implicit none
@@ -175,7 +176,6 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
character(len=4) :: senname
character(len=80) :: allspotlist
character(len=40) :: infile2
- integer(i_kind) :: jstart
integer(i_kind) :: iret,ireadsb,ireadmg,irec,next, nrec_startx
integer(i_kind),allocatable,dimension(:) :: nrec
@@ -202,17 +202,18 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
real(r_kind),dimension(0:3) :: ts
real(r_kind),dimension(10) :: sscale
real(crtm_kind),allocatable,dimension(:) :: temperature
+ real(r_kind),allocatable,dimension(:) :: scalef
real(r_kind),allocatable,dimension(:,:):: data_all
real(r_kind) cdist,disterr,disterrmax,dlon00,dlat00
logical :: outside,iuse,assim,valid
logical :: iasi,quiet,cloud_info
- integer(i_kind) :: ifov, instr, iscn, ioff, sensorindex
+ integer(i_kind) :: ifov, instr, iscn, ioff, sensorindex_iasi
integer(i_kind) :: i, j, l, iskip, ifovn, bad_line, ksatid, kidsat, llll
integer(i_kind) :: nreal, isflg
integer(i_kind) :: itx, k, nele, itt, n
- integer(i_kind):: iexponent,maxinfo, bufr_nchan
+ integer(i_kind):: iexponent,maxinfo, bufr_nchan, dval_info
integer(i_kind):: idomsfc(1)
integer(i_kind):: ntest
integer(i_kind):: error_status, irecx,ierr
@@ -221,8 +222,18 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
integer(i_kind) :: sfc_channel_index
integer(i_kind),allocatable, dimension(:) :: channel_number, sc_index, bufr_index
integer(i_kind),allocatable, dimension(:) :: bufr_chan_test
- character(len=20),dimension(1):: sensorlist
-
+ character(len=20),allocatable, dimension(:):: sensorlist
+
+! Imager clouser information for CADS
+ integer(i_kind) :: sensorindex_imager, cads_info
+ integer(i_kind),dimension(7) :: imager_cluster_index
+ logical :: imager_coeff
+ logical,dimension(7) :: imager_cluster_flag
+ character(len=80) :: spc_filename
+ real(r_kind),dimension(33,7) :: imager_info
+ real(r_kind),dimension(7) :: imager_cluster_size
+ real(r_kind),dimension(2) :: imager_mean, imager_std_dev
+ real(r_kind) :: imager_cluster_tot
! Set standard parameters
character(8),parameter:: fov_flag="crosstrk"
@@ -238,7 +249,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
integer(i_kind),parameter :: ilon = 3
integer(i_kind),parameter :: ilat = 4
real(r_kind) :: ptime,timeinflat,crit0
- integer(i_kind) :: ithin_time,n_tbin,it_mesh
+ integer(i_kind) :: ithin_time,n_tbin,it_mesh,jstart
logical print_verbose
print_verbose=.false.
@@ -248,8 +259,11 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
maxinfo = 31
disterrmax=zero
ntest=0
- if(dval_use) maxinfo=maxinfo+2
- nreal = maxinfo + nstinfo
+ dval_info = 0
+ if(dval_use) dval_info = 2
+ cads_info = 0
+ if(iasi_cads) cads_info = 23
+ nreal = maxinfo + cads_info + dval_info + nstinfo
ndata = 0
nodata = 0
@@ -315,7 +329,19 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
! load spectral coefficient structure
quiet=.not. verbose
- sensorlist(1)=sis
+
+ imager_coeff = .false.
+ spc_filename =trim(crtm_coeffs_path)//'avhrr3_'//trim(jsatid)//'.SpcCoeff.bin'
+ inquire(file=trim(spc_filename), exist=imager_coeff)
+ if ( imager_coeff ) then
+ allocate( sensorlist(2))
+ sensorlist(1) = sis
+ sensorlist(2) = 'avhrr3_'//trim(jsatid)
+ else
+ allocate( sensorlist(1))
+ sensorlist(1) = sis
+ endif
+
if( crtm_coeffs_path /= "" ) then
if(mype_sub==mype_root .and. print_verbose) write(6,*)'READ_IASI: crtm_spccoeff_load() on path "'//trim(crtm_coeffs_path)//'"'
error_status = crtm_spccoeff_load(sensorlist,&
@@ -330,6 +356,31 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
call stop2(71)
endif
+! find IASI sensorindex
+ sensorindex_iasi = 0
+ if ( sc(1)%sensor_id(1:4) == 'iasi' ) then
+ sensorindex_iasi = 1
+ else
+ write(6,*)'READ_IASI: ***ERROR*** sensorindex_iasi not set NO IASI DATA USED'
+ write(6,*)'READ_IASI: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION'
+ call stop2(71)
+ end if
+
+! find imager sensorindex
+ sensorindex_imager = 0
+ if ( iasi_cads .and. imager_coeff ) then
+ if ( sc(2)%sensor_id(1:4) == 'avhr' ) then
+ sensorindex_imager = 2
+ imager_coeff = .true.
+ else
+ write(6,*)'READ_IASI: ***ERROR*** sensorindex_imager is not set NO IASI DATA USED'
+ write(6,*)'READ_IASI: We are looking for ', sc(2)%sensor_id
+ imager_coeff = .false.
+ end if
+ else
+ imager_coeff = .false.
+ end if
+
! Find the channels being used (from satinfo file) in the spectral coef. structure.
do i=subset_start,subset_end
channel_number(i -subset_start +1) = nuchan(i)
@@ -337,23 +388,13 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
sc_index(:) = 0
satinfo_chan: do i=1,satinfo_nchan
spec_coef: do l=1,sc(1)%n_channels
- if ( channel_number(i) == sc(1)%sensor_channel(l) ) then
+ if ( channel_number(i) == sc(sensorindex_iasi)%sensor_channel(l) ) then
sc_index(i) = l
exit spec_coef
endif
end do spec_coef
end do satinfo_chan
-! find IASI sensorindex
- sensorindex = 0
- if ( sc(1)%sensor_id(1:4) == 'iasi' ) then
- sensorindex = 1
- else
- write(6,*)'READ_IASI: sensorindex not set NO IASI DATA USED'
- write(6,*)'READ_IASI: We are looking for ', sc(1)%sensor_id, ' TERMINATE PROGRAM EXECUTION'
- call stop2(71)
- end if
-
! Calculate parameters needed for FOV-based surface calculation.
if (isfcalc==1)then
instr=18
@@ -396,6 +437,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
allocate(temperature(1)) ! dependent on # of channels in the bufr file
allocate(allchan(2,1)) ! actual values set after ireadsb
allocate(bufr_chan_test(1))! actual values set after ireadsb
+ allocate(scalef(1))
! Big loop to read data file
next=0
@@ -442,10 +484,11 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
bufr_size = size(temperature,1)
if ( bufr_size /= bufr_nchan ) then ! Re-allocation if number of channels has changed
! Allocate the arrays needed for the channel and radiance array
- deallocate(temperature,allchan,bufr_chan_test)
+ deallocate(temperature,allchan,bufr_chan_test,scalef)
allocate(temperature(bufr_nchan)) ! dependent on # of channels in the bufr file
allocate(allchan(2,bufr_nchan))
allocate(bufr_chan_test(bufr_nchan))
+ allocate(scalef(bufr_nchan))
bufr_chan_test(:)=0
endif ! allocation if
@@ -575,7 +618,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
nread = nread + satinfo_nchan
crit0 = 0.01_r_kind
- if( llll > 1 ) crit0 = crit0 + r100 * float(llll)
+ if( llll > 1 ) crit0 = crit0 + r100 * real(llll,r_kind)
timeinflat=6.0_r_kind
call tdiff2crit(tdiff,ptime,ithin_time,timeinflat,crit0,crit1,it_mesh)
call map2tgrid(dlat_earth,dlon_earth,dist1,crit1,itx,ithin,itt,iuse,sis,it_mesh=it_mesh)
@@ -596,7 +639,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
! Compare IASI satellite scan angle and zenith angle
piece = -step_adjust
if ( mod(ifovn,2) == 1) piece = step_adjust
- lza = ((start + float((ifov-1)/4)*step) + piece)*deg2rad
+ lza = ((start + real((ifov-1)/4,r_kind)*step) + piece)*deg2rad
sat_height_ratio = (earth_radius + linele(4))/earth_radius
lzaest = asin(sat_height_ratio*sin(lza))*rad2deg
if (abs(sat_zenang - lzaest) > one) then
@@ -647,6 +690,9 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
if (iret == 7 .and. cloud_frac(1) <= r100 .and. cloud_frac(1) >= zero) then
pred = r100 - cloud_frac(1)
cloud_info = .true.
+ cloud_frac = cloud_frac/r100
+ else
+ cloud_frac = r_missing
endif
crit1 = crit1 + pred
@@ -675,6 +721,18 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
! Read IASI channel number(CHNM) and radiance (SCRA)
call ufbseq(lnbufr,allchan,2,bufr_nchan,iret,'IASICHN')
+ jstart=1
+ scalef=one
+ do i=1,bufr_nchan
+ scaleloop: do j=jstart,10
+ if(allchan(1,i) >= cscale(1,j) .and. allchan(1,i) <= cscale(2,j))then
+ scalef(i) = sscale(j)
+ jstart=j
+ exit scaleloop
+ end if
+ end do scaleloop
+ end do
+
if (iret /= bufr_nchan) then
write(6,*)'READ_IASI: ### ERROR IN READING ', senname, ' BUFR DATA:', &
iret, ' CH DATA IS READ INSTEAD OF ',bufr_nchan
@@ -703,52 +761,47 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
cycle read_loop
endif
- iskip = 0
- jstart=1
+!$omp parallel do schedule(dynamic,1) private(i,sc_chan,bufr_chan,radiance)
channel_loop: do i=1,satinfo_nchan
- sc_chan = sc_index(i)
- if ( bufr_index(i) == 0 ) cycle channel_loop
bufr_chan = bufr_index(i)
+ if (bufr_chan > 0 ) then
! check that channel number is within reason
- if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds
- radiance = allchan(2,bufr_chan)
- scaleloop: do j=jstart,10
- if(allchan(1,bufr_chan) >= cscale(1,j) .and. allchan(1,bufr_chan) <= cscale(2,j))then
- radiance = allchan(2,bufr_chan)*sscale(j)
- jstart=j
- exit scaleloop
- end if
- end do scaleloop
- call crtm_planck_temperature(sensorindex,sc_chan,radiance,temperature(bufr_chan))
- else
- temperature(bufr_chan) = tbmin
- endif
+ if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds
+ radiance = allchan(2,bufr_chan)*scalef(bufr_chan)
+ sc_chan = sc_index(i)
+ call crtm_planck_temperature(sensorindex_iasi,sc_chan,radiance,temperature(bufr_chan))
+ else
+ temperature(bufr_chan) = tbmin
+ endif
+ end if
end do channel_loop
! Check for reasonable temperature values
+ iskip = 0
skip_loop: do i=1,satinfo_nchan
if ( bufr_index(i) == 0 ) cycle skip_loop
bufr_chan = bufr_index(i)
if(temperature(bufr_chan) <= tbmin .or. temperature(bufr_chan) > tbmax ) then
- temperature(bufr_chan) = min(tbmax,max(zero,temperature(bufr_chan)))
+ temperature(bufr_chan) = min(tbmax,max(tbmin,temperature(bufr_chan)))
if(iuse_rad(ioff+i) >= 0)iskip = iskip + 1
endif
end do skip_loop
- if(iskip > 0 .and. print_verbose)write(6,*) ' READ_IASI : iskip > 0 ',iskip
- if( iskip > 0 )cycle read_loop
+ if(iskip > 0)then
+ if(print_verbose)write(6,*) ' READ_IASI : iskip > 0 ',iskip
+ cycle read_loop
+ end if
- crit1=crit1 + ten*float(iskip)
+! crit1=crit1 + ten*real(iskip,r_kind)
-! If the surface channel exists (~960.0 cm-1) and the AVHRR cloud information is missing, use an
+! If the surface channel exists (~960.0 cm-1) and the imager cloud information is missing, use an
! estimate of the surface temperature to determine if the profile may be clear.
if (.not. cloud_info) then
pred = tsavg*0.98_r_kind - temperature(sfc_channel_index)
pred = max(pred,zero)
+ crit1=crit1 + pred
endif
- crit1=crit1 + pred
-
! Map obs to grids
if (pred == zero) then
call finalcheck(dist1,crit1,itx,iuse)
@@ -757,6 +810,78 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
endif
if(.not. iuse)cycle read_loop
+! Read the imager cluster information for the Cloud and Aerosol Detection Software.
+! Only channels 4 and 5 are used.
+
+ if ( iasi_cads ) then
+ call ufbseq(lnbufr,imager_info,33,7,iret,'IASIL1CS')
+ if (iret == 7 .and. imager_info(3,1) <= 100.0_r_kind .and. &
+ imager_info(3,1) >= zero .and. imager_coeff ) then ! if imager cluster info exists
+ imager_mean = zero
+ imager_std_dev = zero
+ imager_cluster_tot = zero
+ imager_cluster_flag = .TRUE.
+ imager_cluster_size = imager_info(3,1:7)
+ imager_cluster_size(:) = imager_cluster_size(:) / sum(imager_cluster_size(:))
+
+! Order clusters from largest (1) to smallest (7)
+ imager_cluster_sort: do i=1,7
+ j = maxloc(imager_cluster_size,dim=1,mask=imager_cluster_flag)
+ imager_cluster_index(i) = j
+ imager_cluster_flag(j) = .FALSE.
+ end do imager_cluster_sort
+
+! Convert from radiance to brightness temperature for mean and standard deviation used by CADS.
+! Imager cluster info added to data_all array
+
+ imager_cluster_info: do j=1,7
+ i = imager_cluster_index(j)
+
+ data_all(maxinfo+j,itx) = imager_cluster_size(i) ! Imager cluster fraction
+ imager_cluster_tot = imager_cluster_tot + imager_info(3,i)
+
+ iexponent = -(nint(imager_info(25,i))-5 ) ! channel 4 radiance for each cluster.
+ imager_info(26,i) = imager_info(26,i) * (ten ** iexponent)
+
+ iexponent = -(nint(imager_info(27,i))-5 ) ! channel 4 radiance std dev for each cluster.
+ imager_info(28,i) = imager_info(28,i) * (ten ** iexponent)
+
+ call crtm_planck_temperature(sensorindex_imager,2,imager_info(26,i),data_all(maxinfo+7+j,itx))
+ data_all(maxinfo+7+j,itx) = max(data_all(maxinfo+7+j,itx),zero)
+
+ iexponent = -(nint(imager_info(30,i))-5 ) ! channel 5 radiance for each cluster
+ imager_info(31,i) = imager_info(31,i) * (ten ** iexponent)
+
+ iexponent = -(nint(imager_info(32,i))-5 ) ! channel 5 radiance std dev for each cluser.
+ imager_info(33,i) = imager_info(33,i) * (ten ** iexponent)
+
+ call crtm_planck_temperature(sensorindex_imager,3,imager_info(31,i),data_all(maxinfo+14+j,itx))
+ data_all(maxinfo+14+j,itx) = max(data_all(maxinfo+14+j,itx),zero)
+
+ end do imager_cluster_info
+
+! Compute cluster averages for each channel
+
+ imager_mean(1) = sum(imager_cluster_size(:) * imager_info(26,:)) ! Channel 4 radiance cluster average
+ imager_std_dev(1) = sum(imager_cluster_size(:) * (imager_info(26,:)**2 + imager_info(28,:)**2)) - imager_mean(1)**2
+ imager_std_dev(1) = sqrt(max(imager_std_dev(1),zero)) ! Channel 4 radiance RMSE
+ call crtm_planck_temperature(sensorindex_imager,2,(imager_std_dev(1) + imager_mean(1)),imager_std_dev(1))
+ call crtm_planck_temperature(sensorindex_imager,2,imager_mean(1),imager_mean(1)) ! Channel 4 average BT
+ imager_std_dev(1) = imager_std_dev(1) - imager_mean(1) ! Channel 4 BT std dev
+ data_all(maxinfo+22,itx) = imager_std_dev(1)
+
+ imager_mean(2) = sum(imager_cluster_size(:) * imager_info(31,:)) ! Channel 5 radiance cluster average
+ imager_std_dev(2) = sum(imager_cluster_size(:) * (imager_info(31,:)**2 + imager_info(33,:)**2)) - imager_mean(1)**2
+ imager_std_dev(2) = sqrt(max(imager_std_dev(1),zero)) ! Channel 5 radiance RMSE
+ call crtm_planck_temperature(sensorindex_imager,3,(imager_std_dev(2) + imager_mean(2)),imager_std_dev(2))
+ call crtm_planck_temperature(sensorindex_imager,3,imager_mean(2),imager_mean(2)) ! Channel 5 average BT
+ imager_std_dev(2) = imager_std_dev(2) - imager_mean(2) ! Channel 5 BT std dev
+ data_all(maxinfo+23,itx) = imager_std_dev(2)
+
+ else ! Imager cluster information is missing. Set everything to zero
+ data_all(maxinfo+1 : maxinfo+25,itx) = zero
+ endif
+ endif ! iasi_cads = .true.
!
! interpolate NSST variables to Obs. location and get dtw, dtc, tz_tr
!
@@ -791,7 +916,8 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
data_all(18,itx)= ts(3) ! snow skin temperature
data_all(19,itx)= tsavg ! average skin temperature
data_all(20,itx)= vty ! vegetation type
- data_all(21,itx)= vfr ! vegetation fraction
+ !data_all(21,itx)= vfr ! vegetation fraction
+ data_all(21,itx)= cloud_frac(1) ! temporary place for cloud fraction
data_all(22,itx)= sty ! soil type
data_all(23,itx)= stp ! soil temperature
data_all(24,itx)= sm ! soil moisture
@@ -804,25 +930,27 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
data_all(31,itx)= dlat_earth_deg ! earth relative latitude (degrees)
if(dval_use)then
- data_all(32,itx)= val_iasi
- data_all(33,itx)= itt
+ data_all(maxinfo+cads_info+1,itx)= val_iasi
+ data_all(maxinfo+cads_info+2,itx)= itt
end if
if ( nst_gsi > 0 ) then
- data_all(maxinfo+1,itx) = tref ! foundation temperature
- data_all(maxinfo+2,itx) = dtw ! dt_warm at zob
- data_all(maxinfo+3,itx) = dtc ! dt_cool at zob
- data_all(maxinfo+4,itx) = tz_tr ! d(Tz)/d(Tr)
+ data_all(maxinfo+cads_info+dval_info+1,itx) = tref ! foundation temperature
+ data_all(maxinfo+cads_info+dval_info+2,itx) = dtw ! dt_warm at zob
+ data_all(maxinfo+cads_info+dval_info+3,itx) = dtc ! dt_cool at zob
+ data_all(maxinfo+cads_info+dval_info+4,itx) = tz_tr ! d(Tz)/d(Tr)
endif
! Put satinfo defined channel temperatures into data array
do l=1,satinfo_nchan
+ ! Prevent out of bounds reference from temperature
+ if ( bufr_index(l) == 0 ) cycle
i = bufr_index(l)
- if ( bufr_index(l) /= 0 ) then
+ if(i /= 0)then
data_all(l+nreal,itx) = temperature(i) ! brightness temerature
else
data_all(l+nreal,itx) = tbmin
- endif
+ end if
end do
nrec(itx)=irec
@@ -835,7 +963,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,&
end do ears_db_loop
- deallocate(temperature, allchan, bufr_chan_test)
+ deallocate(temperature, allchan, bufr_chan_test,scalef)
deallocate(channel_number,sc_index)
deallocate(bufr_index)
! deallocate crtm info
diff --git a/src/gsi/read_l2bufr_mod.f90 b/src/gsi/read_l2bufr_mod.f90
index e0619ed1a8..9c9ad73afe 100644
--- a/src/gsi/read_l2bufr_mod.f90
+++ b/src/gsi/read_l2bufr_mod.f90
@@ -56,9 +56,9 @@ module read_l2bufr_mod
public :: range_max,del_time,l2superob_only,elev_angle_max,del_azimuth
public :: minnum,del_range,del_elev
- public :: invtllv,radar_sites,radar_box,radar_rmesh,radar_zmesh
+ public :: invtllv,radar_sites,radar_box,radar_rmesh,radar_zmesh,radar_pmot
- integer(i_kind) minnum
+ integer(i_kind) minnum,radar_pmot
real(r_kind) del_azimuth,del_elev,del_range,del_time,elev_angle_max,range_max,radar_rmesh,radar_zmesh
logical l2superob_only,radar_sites,radar_box
@@ -100,6 +100,14 @@ subroutine initialize_superob_radar
radar_box=.false.
radar_rmesh=10._r_kind
radar_zmesh=500._r_kind
+
+! radar_pmot of 0,1,2,3 will save different sets of obs output
+! radar_pmot - all obs - thin obs
+! radar_pmot - all obs
+! radar_pmot - use obs
+! radar_pmot - use obs + thin obs
+
+ radar_pmot = 2
end subroutine initialize_superob_radar
subroutine radar_bufr_read_all(npe,mype)
@@ -749,6 +757,7 @@ subroutine radar_bufr_read_all(npe,mype)
write(6,*)' nobs_hrbin=',nobs_hrbin1
write(6,*)' nrange_max=',nrange_max1
end if
+ deallocate(icount)
! Prepare to create superobs and write out.
open(inbufr,file='radar_supobs_from_level2',form='unformatted',iostat=iret)
@@ -946,6 +955,7 @@ subroutine radar_bufr_read_all(npe,mype)
close(inbufr)
close(inbufr)
end if
+ deallocate(indx)
deallocate(bins_work,bins,ibins2)
if(l2superob_only) then
call mpi_finalize(ierror)
diff --git a/src/gsi/read_lidar.f90 b/src/gsi/read_lidar.f90
index 6d74de0802..ad5b27b784 100644
--- a/src/gsi/read_lidar.f90
+++ b/src/gsi/read_lidar.f90
@@ -172,7 +172,7 @@ subroutine read_lidar(nread,ndata,nodata,infile,obstype,lunout,twind,sis,nobs)
! add obs reference time, then subtract analysis time to get obs time relative to analysis
- time_correction=float(minobs-minan)*r60inv
+ time_correction=real(minobs-minan,r_kind)*r60inv
else
time_correction=zero
diff --git a/src/gsi/read_mitm_mxtm.f90 b/src/gsi/read_mitm_mxtm.f90
index fbfe310bd4..393e997e32 100644
--- a/src/gsi/read_mitm_mxtm.f90
+++ b/src/gsi/read_mitm_mxtm.f90
@@ -84,7 +84,7 @@ subroutine read_mitm_mxtm(nread,ndata,nodata,infile,obstype,lunout,gstime,sis,no
real(r_kind) :: stnelev
real(r_kind) :: usage,tsavg,ff10,sfcr,zz
real(r_kind) :: mxtmoe,mitmoe,oberr,qtflg
- real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out
+ real(r_kind),allocatable,dimension(:,:):: cdata_all
integer(i_kind) :: ikx(100:199) !order number of report type in convinfo file
integer(i_kind) :: kxall(100:199)
@@ -407,19 +407,11 @@ subroutine read_mitm_mxtm(nread,ndata,nodata,infile,obstype,lunout,gstime,sis,no
ndata=iout
nodata=iout
- allocate(cdata_out(nreal,ndata))
- do i=1,ndata
- do k=1,nreal
- cdata_out(k,i)=cdata_all(k,i)
- end do
- end do
-
call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata
- write(lunout) cdata_out
+ write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata)
deallocate(cdata_all)
- deallocate(cdata_out)
call destroy_rjlists
if (lhilbert) call destroy_hilbertcurve
diff --git a/src/gsi/read_nsstbufr.f90 b/src/gsi/read_nsstbufr.f90
index adfdee4f13..97096f3760 100644
--- a/src/gsi/read_nsstbufr.f90
+++ b/src/gsi/read_nsstbufr.f90
@@ -367,7 +367,7 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, &
if ( rsc > 60.0_r_kind .or. rsc < zero ) rsc = zero !second in real
call w3fs21(idate5,nmind)
- sstime=float(nmind)
+ sstime=real(nmind,r_kind)
tdiff=(sstime-gstime)*r60inv
@@ -542,9 +542,9 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, &
kx = 197
sstoe = one
elseif ( trim(subset) == 'NC031002' ) then ! TESAC
- if ( tpf(1,1) >= one .and. tpf(1,1) < 20.0_r_kind ) then
- zob = tpf(1,1)
- elseif ( tpf(1,1) >= zero .and. tpf(1,1) < one ) then
+ if ( tpf2(1,1) >= one .and. tpf2(1,1) < 20.0_r_kind ) then
+ zob = tpf2(1,1)
+ elseif ( tpf2(1,1) >= zero .and. tpf2(1,1) < one ) then
zob = one
endif
kx = 198
@@ -553,9 +553,9 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, &
kx = 199 ! classify argo & glider to be bathy type
sstoe = r0_6
elseif ( trim(subset) == 'NC031001' ) then ! BATHY
- if ( tpf(1,1) >= one .and. tpf(1,1) <= 20.0_r_kind ) then
- zob = tpf(1,1)
- elseif ( tpf(1,1) >= zero .and. tpf(1,1) < one ) then
+ if ( tpf2(1,1) >= one .and. tpf2(1,1) <= 20.0_r_kind ) then
+ zob = tpf2(1,1)
+ elseif ( tpf2(1,1) >= zero .and. tpf2(1,1) < one ) then
zob = one
endif
kx = 199
@@ -667,6 +667,7 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, &
! Close unit to bufr file
1020 continue
+ deallocate(data_all)
if (oberrflg) deallocate(etabl)
call closbf(lunin)
close(lunin)
diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90
index 53b0723953..f89b42e155 100644
--- a/src/gsi/read_obs.F90
+++ b/src/gsi/read_obs.F90
@@ -192,6 +192,7 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread)
if ( .not. l_use_dbz_directDA) then
if(trim(dtype) == 'dbz' )return
end if
+ if(trim(dtype) == 'fed' )return
! Use routine as usual
@@ -202,7 +203,6 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread)
call datelen(10)
call readmg(lnbufr,subset,idate,iret)
if(iret == 0)then
-
! Extract date and check for consistency with analysis date
if (idateiadateend) then
if(offtime_data) then
@@ -221,9 +221,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread)
lexist=.false.
end if
if(lexist)then
- if(jsatid == '')then
- kidsat=0
- else if(jsatid == 'metop-a')then
+ kidsat=0
+ if(jsatid == 'metop-a')then
kidsat=4
else if(jsatid == 'metop-b')then
kidsat=3
@@ -346,8 +345,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread)
call datelen(10)
if(kidsat /= 0)then
- lexist = .false.
- satloop: do while(ireadmg(lnbufr,subset,idate2) >= 0)
+ lexist = .false.
+ satloop: do while(ireadmg(lnbufr,subset,idate2) >= 0)
if(ireadsb(lnbufr)==0)then
call ufbint(lnbufr,satid,1,1,iret,'SAID')
end if
@@ -356,8 +355,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread)
exit satloop
end if
nread = nread + 1
- end do satloop
- else if(trim(filename) == 'prepbufr')then ! RTod: wired-in filename is not a good idea
+ end do satloop
+ else if(trim(filename) == 'prepbufr')then
lexist = .false.
fileloop: do while(ireadmg(lnbufr,subset,idate2) >= 0)
do while(ireadsb(lnbufr)>=0)
@@ -402,7 +401,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread)
(said == 44) .or. (said == 5) .or. (said == 41) .or. &
(said == 42) .or. (said == 43) .or. (said == 722) .or. &
(said == 723).or. (said == 265).or. (said == 266) .or. &
- (said == 267).or. (said == 268).or. (said == 269)) then
+ (said == 267).or. (said == 268).or. (said == 269) .or. &
+ (said == 803)) then
lexist=.true.
exit gpsloop
end if
@@ -438,10 +438,10 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread)
end do
nread = nread + 1
end do airploop
- else if(trim(filename) == 'satwndbufr')then
+ else if(index(filename,'satwnd') /=0 .or. index(filename,'satwhr') /=0) then
lexist = .false.
loop: do while(ireadmg(lnbufr,subset,idate2) >= 0)
-! 5 GOES-R AMVs (NC005030, NC005031, NC005032, NC005034 and NC005039)
+! 5 GOES-R AMVs (NC005030, NC005031, NC005032, NC005034, NC005039, NC005099)
! are added as the GOES-R bufr file provide do not contain other winds.
! May not be necessary with the operational satwnd BUFR
if(trim(subset) == 'NC005010' .or. trim(subset) == 'NC005011' .or.&
@@ -452,6 +452,7 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread)
trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or.&
trim(subset) == 'NC005032' .or. trim(subset) == 'NC005034' .or.&
trim(subset) == 'NC005039' .or. &
+ trim(subset) == 'NC005099' .or. &
trim(subset) == 'NC005090' .or. trim(subset) == 'NC005091' .or.&
trim(subset) == 'NC005067' .or. trim(subset) == 'NC005068' .or. trim(subset) == 'NC005069' .or.&
trim(subset) == 'NC005047' .or. trim(subset) == 'NC005048' .or. trim(subset) == 'NC005049' .or.&
@@ -894,6 +895,7 @@ subroutine read_obs(ndata,mype)
if(obstype == 'mls20' ) nmls_type=nmls_type+1
if(obstype == 'mls22' ) nmls_type=nmls_type+1
if(obstype == 'mls30' ) nmls_type=nmls_type+1
+ if(obstype == 'mls55' ) nmls_type=nmls_type+1
if(nmls_type>1) then
write(6,*) '******ERROR***********: there is more than one MLS data type, not allowed, please check'
call stop2(339)
@@ -913,7 +915,8 @@ subroutine read_obs(ndata,mype)
obstype == 'mitm' .or. obstype=='pmsl' .or. &
obstype == 'howv' .or. obstype=='tcamt' .or. &
obstype=='lcbas' .or. obstype=='cldch' .or. obstype == 'larcglb' .or. &
- obstype=='uwnd10m' .or. obstype=='vwnd10m' .or. obstype=='dbz' ) then
+ obstype=='uwnd10m' .or. obstype=='vwnd10m' .or. obstype=='dbz' .or. &
+ obstype=='fed') then
ditype(i) = 'conv'
else if (obstype == 'swcp' .or. obstype == 'lwcp') then
ditype(i) = 'wcp'
@@ -937,6 +940,7 @@ subroutine read_obs(ndata,mype)
.or. obstype == 'ompsnp' &
.or. obstype == 'gome' &
.or. index(obstype, 'omps') /= 0 &
+ .or. index(obstype, 'omi' ) /= 0 &
.or. mls &
) then
ditype(i) = 'ozone'
@@ -1063,7 +1067,7 @@ subroutine read_obs(ndata,mype)
obstype == 'iasi' .or. obstype == 'atms') .and. &
(dplat(i) == 'n17' .or. dplat(i) == 'n18' .or. &
dplat(i) == 'n19' .or. dplat(i) == 'npp' .or. &
- dplat(i) == 'n20' .or. &
+ dplat(i) == 'n20' .or. dplat(i) == 'n21' .or. &
dplat(i) == 'metop-a' .or. dplat(i) == 'metop-b' .or. &
dplat(i) == 'metop-c')
! direct broadcast from NESDIS/UW
@@ -1074,7 +1078,7 @@ subroutine read_obs(ndata,mype)
obstype == 'iasi') .and. &
(dplat(i) == 'n17' .or. dplat(i) == 'n18' .or. &
dplat(i) == 'n19' .or. dplat(i) == 'npp' .or. &
- dplat(i) == 'n20' .or. &
+ dplat(i) == 'n20' .or. dplat(i) == 'n21' .or. &
dplat(i) == 'metop-a' .or. dplat(i) == 'metop-b' .or. &
dplat(i) == 'metop-c')
@@ -1083,7 +1087,12 @@ subroutine read_obs(ndata,mype)
if (ii>npem1) ii=0
if(mype==ii)then
call gsi_inquire(lenbytes,lexist,trim(dfile(i)),mype)
- call read_obs_check (lexist,trim(dfile(i)),dplat(i),dtype(i),minuse,read_rec1(i))
+
+ if (is_extOzone(dfile(i),obstype,dplat(i))) then
+ print*,'reading ',trim(dfile(i)),' ',obstype,' ',trim(dplat(i)),lexist,lenbytes
+ else
+ call read_obs_check (lexist,trim(dfile(i)),dplat(i),dtype(i),minuse,read_rec1(i))
+ endif
! If no data set starting record to be 999999. Note if this is not large
! enough code should still work - just does a bit more work.
@@ -1298,6 +1307,10 @@ subroutine read_obs(ndata,mype)
use_hgtl_full=.true.
if(belong(i))use_hgtl_full_proc=.true.
end if
+ if(obstype == 'fed')then
+ use_hgtl_full=.true.
+ if(belong(i))use_hgtl_full_proc=.true.
+ end if
if(obstype == 'sst')then
if(belong(i))use_sfc=.true.
endif
@@ -1493,7 +1506,7 @@ subroutine read_obs(ndata,mype)
else if(obstype == 'uv' .or. obstype == 'wspd10m' .or. &
obstype == 'uwnd10m' .or. obstype == 'vwnd10m') then
! Process satellite winds which seperate from prepbufr
- if ( index(infile,'satwnd') /=0 ) then
+ if ( index(infile,'satwnd') /=0 .or. index(infile,'satwhr') /=0 ) then
call read_satwnd(nread,npuse,nouse,infile,obstype,lunout,gstime,twind,sis,&
prsl_full,nobs_sub1(1,i))
string='READ_SATWND'
@@ -1516,10 +1529,6 @@ subroutine read_obs(ndata,mype)
call read_fl_hdob(nread,npuse,nouse,infile,obstype,lunout,gstime,twind,sis,&
prsl_full,nobs_sub1(1,i))
string='READ_FL_HDOB'
- else if (index(infile,'uprair') /=0)then
- call read_hdraob(nread,npuse,nouse,infile,obstype,lunout,twind,sis,&
- prsl_full,hgtl_full,nobs_sub1(1,i),read_rec(i))
- string='READ_UPRAIR'
else
call read_prepbufr(nread,npuse,nouse,infile,obstype,lunout,twind,sis,&
prsl_full,nobs_sub1(1,i),read_rec(i))
@@ -1593,6 +1602,7 @@ subroutine read_obs(ndata,mype)
string='READ_RADAR'
else if (sis == 'l2rw') then
if (l2rwthin)then
+ write(6,*)'READ_OBS: radial wind,read_radar_l2rw,dsis=',sis
call read_radar_l2rw(npuse,nouse,lunout,obstype,sis,nobs_sub1(1,i),hgtl_full)
string='READ_RADAR_L2RW_NOVADQC'
else
@@ -1635,6 +1645,12 @@ subroutine read_obs(ndata,mype)
endif
end if
+! Process flash extent density
+ else if (obstype == 'fed' ) then
+ print *, "calling read_fed"
+ call read_fed(nread,npuse,nouse,infile,obstype,lunout,twind,sis,nobs_sub1(1,i))
+ string='READ_FED'
+
! Process lagrangian data
else if (obstype == 'lag') then
call read_lag(nread,npuse,nouse,infile,lunout,obstype,&
@@ -1897,7 +1913,7 @@ subroutine read_obs(ndata,mype)
! Process satellite lightning observations (e.g. GOES/GLM)
else if(ditype(i) == 'light')then
if (obstype == 'goes_glm' ) then
- call read_goesglm(nread,ndata,nodata,infile,obstype,lunout,twind,sis)
+ call read_goesglm(nread,npuse,nodata,infile,obstype,lunout,twind,sis)
string='READ_GOESGLM'
endif
@@ -1942,6 +1958,7 @@ subroutine read_obs(ndata,mype)
! Deallocate arrays containing full horizontal surface fields
call destroy_sfc
! Sum and distribute number of obs read and used for each input ob group
+
call mpi_allreduce(ndata1,ndata,ndat*3,mpi_integer,mpi_sum,mpi_comm_world,&
ierror)
diff --git a/src/gsi/read_ozone.f90 b/src/gsi/read_ozone.f90
index 43dd16d5c8..8e9788d1cf 100644
--- a/src/gsi/read_ozone.f90
+++ b/src/gsi/read_ozone.f90
@@ -138,7 +138,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
character(8) subset,subset6,subset8,subset8_ompsnp
character(49) ozstr,ozostr
character(63) lozstr
- character(51) ozgstr
+ character(51) ozgstr_v1,ozgstr_v2
character(27) ozgstr2
character(42) ozostr2
character(64) mlstr
@@ -165,11 +165,12 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
! maximum number of observations set to
real(r_kind),allocatable,dimension(:,:):: ozout
- real(r_double) toq,poq
+ real(r_double) toq,poq,orbn
real(r_double),dimension(nloz_v6):: ozone_v6
real(r_double),dimension(29,nloz_v8):: ozone_v8
real(r_double),dimension(10):: hdroz
- real(r_double),dimension(10):: hdrozg
+ integer(i_kind):: nhdrozg
+ real(r_double),allocatable,dimension(:):: hdrozg
real(r_double),dimension(5):: hdrozg2
real(r_double),dimension(10):: hdrozo
real(r_double),dimension(8) :: hdrozo2
@@ -195,8 +196,10 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
data lozstr &
/ 'OSP12 OSP11 OSP10 OSP9 OSP8 OSP7 OSP6 OSP5 OSP4 OSP3 OSP2 OSP1 ' /
- data ozgstr &
- / 'SAID CLAT CLON YEAR DOYR HOUR MINU SECO SOZA SOLAZI' /
+ data ozgstr_v1 &
+ / 'SAID CLAT CLON SOZA SOLAZI YEAR DOYR HOUR MINU SECO' /
+ data ozgstr_v2 &
+ / 'SAID CLAT CLON SOZA SOLAZI YEAR MNTH DAYS HOUR MINU SECO' /
data ozgstr2 &
/ 'CLDMNT SNOC ACIDX STKO FOVN' /
data ozostr &
@@ -482,8 +485,19 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
cycle obsloop
endif
-! extract header information
- call ufbint(lunin,hdrozg,10,1,iret,ozgstr)
+! Test for BUFR version using ORBN mnemonic
+ call ufbint(lunin,orbn,1,1,iret,'ORBN')
+ if (orbn > 100000000.0_r_kind) then
+ nhdrozg = 11
+ else
+ nhdrozg = 10
+ endif
+ if (.not.allocated(hdrozg)) allocate(hdrozg(nhdrozg))
+ if (nhdrozg == 11) then
+ call ufbint(lunin,hdrozg,nhdrozg,1,iret,ozgstr_v2)
+ else
+ call ufbint(lunin,hdrozg,nhdrozg,1,iret,ozgstr_v1)
+ endif
call ufbint(lunin,hdrozg2,5,1,iret,ozgstr2)
rsat = hdrozg(1); ksatid=rsat
@@ -494,7 +508,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
if (ksatid /= kidsat) cycle obsloop
! NESDIS does not put a flag for high SZA gome-2 data (SZA > 84 degree)
- if ( hdrozg(9) > r84 ) cycle obsloop
+ if ( hdrozg(4) > r84 ) cycle obsloop
nmrecs=nmrecs+nloz+1
@@ -520,15 +534,24 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
endif
! Convert observation time to relative time
- idate5(1) = hdrozg(4) !year
- IDAYYR = hdrozg(5) ! Day of year
- JULIAN = -31739 + 1461 * (idate5(1) + 4799) /4 &
- -3 * ((idate5(1) + 4899) / 100) / 4 + IDAYYR
- call w3fs26(JULIAN,idate5(1),idate5(2),idate5(3),IDAYWK,IDAYYR)
-! idate5(2) month
-! idate5(3) day
- idate5(4) = hdrozg(6) !hour
- idate5(5) = hdrozg(7) !minute
+ if (nhdrozg == 11) then
+ idate5(1) = hdrozg(6) !year
+ idate5(2) = hdrozg(7) !month
+ idate5(3) = hdrozg(8) !day
+ idate5(4) = hdrozg(9) !hour
+ idate5(5) = hdrozg(10) !minute
+ else
+ idate5(1) = hdrozg(6) !year
+ IDAYYR = hdrozg(7) ! Day of year
+ JULIAN = -31739 + 1461 * (idate5(1) + 4799) /4 &
+ -3 * ((idate5(1) + 4899) / 100) / 4 + IDAYYR
+ call w3fs26(JULIAN,idate5(1),idate5(2),idate5(3),IDAYWK,IDAYYR)
+! idate5(2) month
+! idate5(3) day
+ idate5(4) = hdrozg(8) !hour
+ idate5(5) = hdrozg(9) !minute
+ endif
+
call w3fs21(idate5,nmind)
t4dv=real((nmind-iwinbgn),r_kind)*r60inv
sstime=real(nmind,r_kind)
@@ -574,8 +597,8 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
ozout(5,itx)=dlon_earth_deg ! earth relative longitude (degrees)
ozout(6,itx)=dlat_earth_deg ! earth relative latitude (degrees)
ozout(7,itx)=toq ! total ozone error flag
- ozout(8,itx)=hdrozg(9) ! solar zenith angle
- ozout(9,itx)=hdrozg(10) ! solar azimuth angle
+ ozout(8,itx)=hdrozg(4) ! solar zenith angle
+ ozout(9,itx)=hdrozg(5) ! solar azimuth angle
ozout(10,itx)=hdrozg2(1) ! CLOUD AMOUNT IN SEGMENT
ozout(11,itx)=hdrozg2(2) ! SNOW COVER
ozout(12,itx)=hdrozg2(3) ! AEROSOL CONTAMINATION INDEX
@@ -624,7 +647,8 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
call makegrids(rmesh,ithin,n_tbin=n_tbin)
! Set dependent variables and allocate arrays
- nreal=14
+! nreal=14 !orig
+ nreal=15 !emily (add AFBO)
nloz=0
nchanl=1
nozdat=nreal+nchanl
@@ -753,7 +777,9 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
ozout(12,itx)=hdrozo2(2) ! aerosol index
ozout(13,itx)=hdrozo2(3) ! ascending/descending
ozout(14,itx)=hdrozo2(7) ! scan position
- ozout(15,itx)=totoz
+ ozout(15,itx)=hdrozo2(8) ! AFBO !emily
+ ozout(16,itx)=totoz !emily
+!orig ozout(15,itx)=totoz
! End of loop over observations
end do read_loop2
@@ -1056,7 +1082,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
ozout(8,ndata)=usage1(k) !
ozout(9,ndata)=mlspres(k) ! mls pressure in log(cb)
ozout(10,ndata)=mlsozpc(k) ! ozone mixing ratio precision in ppmv
- ozout(11,ndata)=float(ipos(k)) ! pointer of obs level index in ozinfo.txt
+ ozout(11,ndata)=real(ipos(k),r_kind) ! pointer of obs level index in ozinfo.txt
ozout(12,ndata)=nloz ! # of mls vertical levels
ozout(nreal+1,ndata)=mlsoz(k) ! ozone mixing ratio in ppmv
end do
@@ -1220,7 +1246,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, &
ozout(8,ndata)=usage1(k) !
ozout(9,ndata)=log(press(k)) ! ompslp pressure in log(cb)
ozout(10,ndata)=omrstd(k)*ompslp_mult_fact ! ozone mixing ratio precision in ppmv
- ozout(11,ndata)=float(ipos(k)) ! pointer of obs level index in
+ ozout(11,ndata)=real(ipos(k),r_kind) ! pointer of obs level index in
! ozinfo.txt
ozout(12,ndata)=j !nloz ! # of ompslp vertical levels
ozout(13,ndata)=omr(k) ! ozone mixing ratio in ppmv
diff --git a/src/gsi/read_pblh.f90 b/src/gsi/read_pblh.f90
index a7b7c066a2..1ff2cd2c23 100644
--- a/src/gsi/read_pblh.f90
+++ b/src/gsi/read_pblh.f90
@@ -343,7 +343,7 @@ subroutine read_pblh(nread,ndata,nodata,infile,obstype,lunout,twindin,&
! Add obs reference time, then subtract analysis time to get obs time relative to analysis
- time_correction=float(minobs-minan)/60._r_kind
+ time_correction=real(minobs-minan,r_kind)/60._r_kind
else
time_correction=zero
diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90
index d2cb503926..7dc1c463bf 100644
--- a/src/gsi/read_prepbufr.f90
+++ b/src/gsi/read_prepbufr.f90
@@ -148,6 +148,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
!
! 2020-05-04 wu - no rotate_wind for fv3_regional
! 2020-09-05 CAPS(C. Tong) - add flag for new vadwind obs to assimilate around the analysis time only
+! 2023-03-23 draper - add code for processing T2m and q2m for global system
+! 2023-07-30 zhao - added code to extract obs of significant wave height (howvob) from bufr record
+! in prepbufr file for 3D analysis
+! 2024-01-11 zhao - added code to extract sensible temp (tdry) and tv flag
+! for moisture obs(qob) when running (2D/3D)RTMA
! input argument list:
! infile - unit from which to read BUFR data
@@ -185,6 +190,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
use obsmod, only: iadate,oberrflg,perturb_obs,perturb_fact,ran01dom,hilbert_curve
use obsmod, only: blacklst,offtime_data,bmiss,ext_sonde,time_offset, vad_near_analtime
+ use obsmod, only: reduce_diag
use aircraftinfo, only: aircraft_t_bc,aircraft_t_bc_pof,ntail,taillist,idx_tail,npredt,predt, &
aircraft_t_bc_ext,ntail_update,max_tail,nsort,itail_sort,idx_sort,timelist
use converr,only: etabl
@@ -198,8 +204,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
use convb_t,only: btabl_t
use convb_uv,only: btabl_uv
use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,winlen,thin4d
- use convthin, only: make3grids,map3grids,map3grids_m,del3grids,use_all
- use convthin_time, only: make3grids_tm,map3grids_tm,map3grids_m_tm,del3grids_tm,use_all_tm
+ use convthin, only: make3grids,map3grids_m,del3grids,use_all
+ use convthin_time, only: make3grids_tm,map3grids_m_tm,del3grids_tm,use_all_tm
use qcmod, only: errormod,errormod_aircraft,noiqc,newvad,njqc
use qcmod, only: pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres
use qcmod, only: nrand
@@ -212,7 +218,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
use hilbertcurve,only: init_hilbertcurve, accum_hilbertcurve, &
apply_hilbertcurve,destroy_hilbertcurve
use ndfdgrids,only: init_ndfdgrid,destroy_ndfdgrid,relocsfcob,adjust_error
- use jfunc, only: tsensible
+ use jfunc, only: tsensible, hofx_2m_sfcfile
use deter_sfc_mod, only: deter_sfc_type,deter_sfc2
use gsi_nstcouplermod, only: nst_gsi,nstinfo
use gsi_nstcouplermod, only: gsi_nstcoupler_deter
@@ -221,6 +227,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
use adjust_cloudobs_mod, only: adjust_convcldobs,adjust_goescldobs
use mpimod, only: npe
use rapidrefresh_cldsurf_mod, only: i_gsdsfc_uselist,i_gsdqc,i_ens_mean
+ use rapidrefresh_cldsurf_mod, only: l_rtma3d, oerr_gust
use gsi_io, only: verbose
use phil2, only: denest ! hilbert curve
@@ -263,9 +270,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
logical tob,qob,uvob,spdob,sstob,pwob,psob,gustob,visob,tdob,mxtmob,mitmob,pmob,howvob,cldchob
logical metarcldobs,goesctpobs,tcamtob,lcbasob
logical outside,driftl,convobs,inflate_error
- logical sfctype
+ logical sfctype, global_2m_land
logical luse,ithinp,windcorr
- logical patch_fog
+ logical patch_fog,save_all
logical aircraftset,aircraftobs,aircraftobst,aircrafttype
logical acft_profl_file
logical,allocatable,dimension(:,:):: lmsg ! set true when convinfo entry id found in a message
@@ -287,17 +294,17 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
character(1) cdummy
logical lhilbert
- integer(i_kind) ireadmg,ireadsb,icntpnt,icntpnt2,icount,iiout
- integer(i_kind) lunin,i,maxobs,j,idomsfc,it29,nmsgmax,mxtb
+ integer(i_kind) ireadmg,ireadsb,iqm,iuse,pmot
+ integer(i_kind) lunin,i,maxobs,j,idomsfc,it29,nmsgmax,mxtb,maxall
integer(i_kind) kk,klon1,klat1,klonp1,klatp1
- integer(i_kind) nc,nx,isflg,ntread,itx,ii,ncsave
+ integer(i_kind) nc,isflg,ntread,ii,ncsave,nxdata,nx
integer(i_kind) ihh,idd,idate,iret,im,iy,k,levs
integer(i_kind) metarcldlevs,metarwthlevs,cldseqlevs,cld2seqlevs
integer(i_kind) kx,kx0,nreal,nchanl,ilat,ilon,ithin
integer(i_kind) cat,zqm,pwq,sstq,qm,lim_qm,lim_zqm,gustqm,visqm,tdqm,mxtmqm,mitmqm,howvqm,cldchqm
integer(i_kind) lim_tqm,lim_qqm
integer(i_kind) nlevp ! vertical level for thinning
- integer(i_kind) ntmp,iout
+ integer(i_kind) iout
integer(i_kind) pflag,irec,zflag
integer(i_kind) ntest,nvtest,iosub,ixsub,isubsub,iobsub
integer(i_kind) kl,k1,k2,k1_ps,k1_q,k1_t,k1_uv,k1_pw,k2_q,k2_t,k2_uv,k2_pw,k2_ps
@@ -314,7 +321,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
integer(i_kind),dimension(255):: pqm,qqm,tqm,wqm,pmq
integer(i_kind),dimension(nconvtype)::ntxall
integer(i_kind),dimension(nconvtype+1)::ntx
- integer(i_kind),allocatable,dimension(:):: isort,iloc,nrep
+ integer(i_kind),allocatable,dimension(:):: nrep
integer(i_kind),allocatable,dimension(:,:):: tab
integer(i_kind) ibfms,thisobtype_usage
integer(i_kind) iwmo,ios
@@ -334,7 +341,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
real(r_kind) del,terrmin,werrmin,perrmin,qerrmin,pwerrmin,del_ps,del_q,del_t,del_uv,del_pw
real(r_kind) pjbmin,qjbmin,tjbmin,wjbmin
real(r_kind) tsavg,ff10,sfcr,zz
- real(r_kind) crit1,timedif,xmesh,pmesh,pmot,ptime ! thinning parameter
+ real(r_kind) crit1,timedif,xmesh,pmesh,ptime ! thinning parameter
real(r_kind) time_correction
real(r_kind) tcamt,lcbas,ceiling
real(r_kind) tcamt_oe,lcbas_oe
@@ -378,12 +385,18 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
integer(i_kind) indexx
real(r_kind) dentrip,dentrip_tmp,vmin,vmax,rmesh_tmp,pmesh_tmp,prest
integer(i_kind) ntime_max,ntime_tmp,itype,ikx
+! integer(i_kind) numthin,numqc,numrem,numall
integer(i_kind),dimension(24) :: ntype_arr
integer(i_kind),allocatable,dimension(:,:) :: index_arr
real(r_kind),allocatable,dimension(:,:,:) :: data_hilb
real(r_kind),allocatable,dimension(:) :: rlat_hil,rlon_hil,height,wtob,wght_hilb
+ logical, allocatable,dimension(:) :: rusage,rthin
! end of block
+! for extracting sensible-vs-virtual temp obs
+ integer(i_kind),dimension(1,255):: tqm4q
+ real(r_kind),dimension(1,255):: tvflg4q
+ real(r_double),dimension(1,255):: tobs4q
! equivalence to handle character names
equivalence(r_prvstg(1,1),c_prvstg)
@@ -431,8 +444,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! character(len=8) :: cval
! equivalence (rval,cval)
! character(7) flnm
- integer:: icase,klev,ikkk,tkk
- real:: diffhgt,diffuu,diffvv
+
+ integer:: icase,klev,ikkk,tkk
+ real:: diffhgt,diffuu,diffvv
+ integer,dimension(3)::kcount
real(r_double),dimension(3,1500):: fcstdat
logical print_verbose
@@ -444,12 +459,14 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! Initialize variables
+ kcount=0
vdisterrmax=zero
zflag=0
nreal=0
satqc=zero
tob = obstype == 't'
- uvob = obstype == 'uv' ; if (twodvar_regional) uvob = uvob .or. obstype == 'wspd10m' .or. obstype == 'uwnd10m' .or. obstype == 'vwnd10m'
+ uvob = obstype == 'uv'
+ if (twodvar_regional) uvob = uvob .or. obstype == 'wspd10m' .or. obstype == 'uwnd10m' .or. obstype == 'vwnd10m'
spdob = obstype == 'spd'
psob = obstype == 'ps'
qob = obstype == 'q'
@@ -472,52 +489,96 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
tdob .or. mxtmob .or. mitmob .or. pmob .or. howvob .or. &
tcamtob .or. lcbasob .or. cldchob
aircraftobst=.false.
+ iqm = 0
+ iuse = 0
if(tob)then
nreal=25
+ iqm = 10
+ iuse = 12
else if(uvob) then
- nreal=27
+ nreal=26
+ iqm = 12
+ iuse = 14
else if(spdob) then
nreal=24
+ iqm = 11
+ iuse = 13
else if(psob) then
nreal=20
+ iqm=10
+ iuse = 12
else if(qob) then
nreal=26
+ iqm = 11
+ iuse = 13
else if(pwob) then
nreal=20
+ iqm = 9
+ iuse = 11
else if(sstob) then
if (nst_gsi > 0) then
nreal=18 + nstinfo
else
nreal=18
end if
+ iqm = 11
+ iuse = 13
else if(gustob) then
nreal=21
+ iqm = 11
+ iuse = 12
else if(visob) then
nreal=18
+ iqm = 9
+ iuse = 10
else if(tdob) then
nreal=25
+ iqm = 11
+ iuse = 13
else if(mxtmob) then
nreal=24
+ iqm = 10
+ iuse = 12
else if(mitmob) then
nreal=24
+ iqm = 10
+ iuse = 12
else if(pmob) then
nreal=24
+ iqm = 11
+ iuse = 13
else if(howvob) then
nreal=23
+ iqm = 9
+ iuse = 11
else if(metarcldobs) then
nreal=27
+ iqm = 0
+ iuse = 22
else if(goesctpobs) then
nreal=8
+ iqm = 0
+ iuse = 8
else if(tcamtob) then
nreal=20
+ iqm = 8
+ iuse = 9
else if(lcbasob) then
nreal=23
+ iqm = 8
+ iuse = 9
else if(cldchob) then
nreal=18
+ iqm = 9
+ iuse = 10
else
write(6,*) ' illegal obs type in READ_PREPBUFR ',obstype
call stop2(94)
end if
+ if(iuse < 1) then
+ write(6,*) ' mix up in read_prepbufr iuse '
+ call stop2(49)
+ end if
! Set qc limits based on noiqc flag
if (noiqc) then
@@ -603,10 +664,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
!! get message and subset counts
call getcount_bufr(infile,nmsgmax,mxtb)
- allocate(lmsg(nmsgmax,ntread),tab(mxtb,3),nrep(nmsgmax))
+ allocate(lmsg(nmsgmax,ntread),tab(mxtb,2),nrep(nmsgmax))
lmsg = .false.
maxobs=0
+ maxall=0
tab=0
nmsg=0
nrep=0
@@ -689,7 +751,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! identify drifting buoys - TYP=180/280 T29=562 and last three digits of SID between 500 and 999
! (see https://www.wmo.int/pages/prog/amp/mmop/wmo-number-rules.html) Set kx to 199/299
- if (id_drifter .and. (kx==180 .or. kx==280) .and. nint(hdr(3))==562) then
+ if (id_drifter .and. (kx==180 .or. kx==280) .and. nint(hdr(3),r_double)==562) then
rstation_id=hdr(4)
read(c_station_id,*,iostat=ios) iwmo
if (ios == 0 .and. iwmo > 0) then
@@ -699,7 +761,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
end if
end if
- if (id_ship .and. (kx==180) .and. (nint(hdr(3))==522 .or. nint(hdr(3))==523)) then
+ if (id_ship .and. (kx==180) .and. (nint(hdr(3),r_double)==522 .or. nint(hdr(3),r_double)==523)) then
rstation_id=hdr(4)
kx = kx + 18
end if
@@ -774,11 +836,12 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
end if
end if
end do matchloop
+ call ufbint(lunin,levdat,1,255,levs,levstr)
+ maxall=maxall+max(1,levs)
! Save information for next read
if(ncsave /= 0) then
- call ufbint(lunin,levdat,1,255,levs,levstr)
maxobs=maxobs+max(1,levs)
nx=1
if(ithin_conv(ncsave) > 0 .and. ithin_conv(ncsave) <5)then
@@ -788,7 +851,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
end if
tab(ntb,1)=ncsave
tab(ntb,2)=nx
- tab(ntb,3)=levs
lmsg(nmsg,nx) = .true.
end if
@@ -821,6 +883,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
glcd=-999._r_double
endif
+ if(print_verbose) write(6,'(1x,A,A,A,2(A,1x,F8.3))') 'read_prepbufr:', &
+ trim(adjustl(obstype)),':', ' vtcd= ',vtcd,' glcd= ',glcd
+
call init_rjlists
call init_aircraft_rjlists
if(i_gsdsfc_uselist==1) call init_gsd_sfcuselist
@@ -834,9 +899,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! loop over convinfo file entries; operate on matches
- allocate(cdata_all(nreal,maxobs),isort(maxobs))
- isort = 0
- cdata_all=zero
+ allocate(cdata_all(nreal,maxall),rusage(maxall),rthin(maxall))
nread=0
ntest=0
nvtest=0
@@ -844,22 +907,27 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
ilon=2
ilat=3
rmesh=zero
- pmot=zero
pmesh=zero
ptime=zero
xmesh=zero
pflag=0
+ save_all=.true.
+ rusage = .true.
+ rthin = .false.
+ ndata = 0
loop_convinfo: do nx=1, ntread
- use_all_tm = .true.
+ use_all_tm = .true.
use_all = .true.
ithin=0
+ pmot=0
if(nx > 1) then
nc=ntx(nx)
ithin=ithin_conv(nc)
+ pmot=nint(pmot_conv(nc))
if (ithin > 0 .and. ithin <5) then
rmesh=rmesh_conv(nc)
pmesh=pmesh_conv(nc)
- pmot=pmot_conv(nc)
+
ptime=ptime_conv(nc)
if(pmesh > zero .and. ithin ==1) then
pflag=1
@@ -903,10 +971,13 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
enddo
endif
endif
- if(print_verbose) write(6,*)'READ_PREPBUFR: at line 779: obstype,ictype(nc),rmesh,pflag,nlevp,pmesh,pmot,ptime=',&
- trim(ioctype(nc)),ictype(nc),rmesh,pflag,nlevp,pmesh,pmot,ptime,ithin
+ if(print_verbose) write(6,*)'READ_PREPBUFR: obstype,ictype(nc),rmesh,pflag,nlevp,pmesh,pmot,ptime=',&
+ trim(ioctype(nc)),ictype(nc),rmesh,pflag,nlevp,pmesh,pmot,ptime,ithin,ndata,nc
endif
endif
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all = .false.
+ if(pmot /= 2 .and. pmot /= 0)save_all=.true.
call closbf(lunin)
@@ -919,8 +990,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
ntb = 0
nmsg = 0
- icntpnt=0
- icntpnt2=0
disterrmax=-9999.0_r_kind
irec = 0
loop_msg: do while (ireadmg(lunin,subset,idate)== 0)
@@ -935,9 +1004,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
nmsg = nmsg+1
if(.not.lmsg(nmsg,nx)) then
- do i=ntb+1,ntb+nrep(nmsg)
- icntpnt2=icntpnt2+tab(i,3)
- end do
ntb=ntb+nrep(nmsg)
cycle loop_msg ! no useable reports this mesage, skip ahead report count
end if
@@ -946,10 +1012,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! use msg lookup table to decide which messages to skip
! use report id lookup table to only process matching reports
ntb = ntb+1
- if(icntpnt < icntpnt2)icntpnt=icntpnt2
- icntpnt2=icntpnt2+tab(ntb,3)
- nc=tab(ntb,1)
- if(nc <= 0 .or. tab(ntb,2) /= nx) cycle loop_readsb
+ if(tab(ntb,1) <= 0 .or. tab(ntb,2) /= nx) cycle loop_readsb
! Extract type, date, and location information
call ufbint(lunin,hdr,8,1,iret,hdstr)
@@ -968,7 +1031,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
!
! identify drifting buoys - TYP=180/280 T29=562 and last three digits of SID between 500 and 999
! (see https://www.wmo.int/pages/prog/amp/mmop/wmo-number-rules.html) Set kx to 199/299
- if (id_drifter .and. (kx==180 .or. kx==280) .and. nint(hdr(8))==562 ) then
+ if (id_drifter .and. (kx==180 .or. kx==280) .and. nint(hdr(8),r_double)==562) then
rstation_id=hdr(1)
read(c_station_id,*,iostat=ios) iwmo
if (ios == 0 .and. iwmo > 0) then
@@ -978,7 +1041,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
end if
end if
- if (id_ship .and. (kx==180) .and. (nint(hdr(8))==522 .or. nint(hdr(8))==523) ) then
+ if (id_ship .and. (kx==180) .and. (nint(hdr(8),r_double)==522 .or. nint(hdr(8),r_double)==523) ) then
rstation_id=hdr(1)
kx = kx + 18
end if
@@ -1067,7 +1130,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! Add obs reference time, then subtract analysis time to get obs time relative to analysis
- time_correction=float(minobs-minan)*r60inv
+ time_correction=real(minobs-minan,r_kind)*r60inv
else
time_correction=zero
@@ -1088,12 +1151,16 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! Balloon drift information available for these data
driftl=kx==120.or.kx==220.or.kx==221
+ nc=tab(ntb,1)
if (.not. (aircraft_t_bc .and. acft_profl_file)) then
if (l4dvar.or.l4densvar) then
if ((t4dvwinlen) .and. .not.driftl) cycle loop_readsb ! outside time window
else
- if((real(abs(time)) > real(ctwind(nc)) .or. real(abs(time)) > real(twindin)) &
- .and. .not. driftl)cycle loop_readsb ! outside time window
+ ! Fix to ensure end of time window is NOT included
+ if ((real(abs(time)) > real(ctwind(nc)) .or. real(time)==real(three) .or. &
+ real(abs(time)) > real(twindin)) .and. .not. driftl)cycle loop_readsb ! outside time window
+! if((real(abs(time)) > real(ctwind(nc)) .or. real(abs(time)) > real(twindin)) &
+! .and. .not. driftl)cycle loop_readsb ! outside time window
endif
timex=time
@@ -1131,6 +1198,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
if (howvob) call ufbint(lunin,owave,1,255,levs,owavestr)
if (cldchob) call ufbint(lunin,cldceilh,1,255,levs,cldceilhstr)
endif
+! Extract obs of howv in 3D Analysis
+! (if-block is to avoid potential issue if decoding the bufr record twice in 2DRTMA run)
+ if ( .not. twodvar_regional ) then
+ if (howvob) call ufbint(lunin,owave,1,255,levs,owavestr)
+ endif
if(kx==224 .and. newvad) then
call ufbint(lunin,fcstdat,3,255,levs,'UFC VFC TFC ')
end if
@@ -1178,7 +1250,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
enddo
do k=1,levs
ppb=obsdat(1,k)
- cat=nint(min(obsdat(10,k),qcmark_huge))
+ cat=nint(min(obsdat(10,k),qcmark_huge))
if ( cat /=0 ) cycle
ppb=max(zero,min(ppb,r2000))
if(ppb>=etabl_ps(itypex,1,1)) k1_ps=1
@@ -1201,12 +1273,11 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
obserr(1,k)=max(obserr(1,k),perrmin)
endif
! Surface pressure b
- var_jb(1,k)=(one-del_ps)*btabl_ps(itypex,k1_ps,ierr_ps)+del_ps*btabl_ps(itypex,k2_ps,ierr_ps)
+ var_jb(1,k)=(one-del_ps)*btabl_ps(itypex,k1_ps,ierr_ps)+del_ps*btabl_ps(itypex,k2_ps,ierr_ps)
var_jb(1,k)=max(var_jb(1,k),pjbmin)
if (var_jb(1,k) >=10.0_r_kind) var_jb(1,k)=zero
enddo
- endif
- if (tob) then
+ else if (tob) then
itypex=itypey
ierr_t=0
do i =1,maxsub_t
@@ -1256,8 +1327,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
var_jb(3,k)=max(var_jb(3,k),tjbmin)
if (var_jb(3,k) >=10.0_r_kind) var_jb(3,k)=zero
enddo
- endif
- if (qob) then
+ else if (qob) then
itypex=itypey
ierr_q=0
do i =1,maxsub_q
@@ -1310,8 +1380,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! write(6,*) 'READ_PREPBUFR:120_q,obserr,var_jb=',obserr(2,k),var_jb(2,k),ppb
! endif
enddo
- endif
- if (uvob) then
+ else if (uvob) then
itypex=itypey
ierr_uv=0
do i =1,maxsub_uv
@@ -1347,13 +1416,13 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
if (abs(ediff_uv) > tiny_r_kind) then
del_uv = (ppb-etabl_uv(itypex,k1_uv,1))/ediff_uv
else
- del_uv = huge_r_kind
+ del_uv = huge_r_kind
endif
del_uv=max(zero,min(del_uv,one))
! Wind error
! write(6,*) 'READ_PREPBUFR_UV:',itypex,k1_uv,itypey,k2_uv,ierr_uv,nc,kx,ppb
- obserr(5,k)=(one-del_uv)*etabl_uv(itypex,k1_uv,ierr_uv)+del_uv*etabl_uv(itypex,k2_uv,ierr_uv)
- obserr(5,k)=max(obserr(5,k),werrmin)
+ obserr(5,k)=(one-del_uv)*etabl_uv(itypex,k1_uv,ierr_uv)+del_uv*etabl_uv(itypex,k2_uv,ierr_uv)
+ obserr(5,k)=max(obserr(5,k),werrmin)
!Wind b
var_jb(5,k)=(one-del_uv)*btabl_uv(itypex,k1_uv,ierr_uv)+del_uv*btabl_uv(itypex,k2_uv,ierr_uv)
var_jb(5,k)=max(var_jb(5,k),wjbmin)
@@ -1362,8 +1431,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! write(6,*) 'READ_PREPBUFR:220_uv,obserr,var_jb=',obserr(5,k),var_jb(5,k),ppb,k2_uv,del_uv
! endif
enddo
- endif
- if (pwob) then
+ else if (pwob) then
itypex=itypey
ierr_pw=0
do i =1,maxsub_pw
@@ -1448,6 +1516,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
if(driftl)call ufbint(lunin,drfdat,8,255,iret,drift)
! raob level enhancement on temp and q obs
+! (note: levs is increased by sonde_ext, and not same as original value read from prepbufr)
if(ext_sonde .and. kx==120) call sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levs,kx,vtcd)
nread=nread+levs
@@ -1614,10 +1683,17 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
pmq(k)=nint(qcmark(8,k))
end do
+! 187, 181, and 183 are the screen-level obs over land
+! note: don't need the hofx_2m_sfcfile if set usage in convinfo, and qm updated in the input file
+ global_2m_land = ( (kx==187 .or. kx==181 .or. kx==183) .and. hofx_2m_sfcfile )
+
! If temperature ob, extract information regarding virtual
! versus sensible temperature
if(tob) then
- if (.not. twodvar_regional .or. .not.tsensible) then
+ ! use tvirtual if tsensible flag not set, and not in either 2Dregional or global_2m DA mode
+ ! for now, keeping 2m obs as sensible, for global system.
+ if ( (.not. tsensible) .and. .not. (twodvar_regional .or. global_2m_land) ) then
+
do k=1,levs
tvflg(k)=one ! initialize as sensible
do j=1,20
@@ -1638,8 +1714,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
qcmark(3,k)=min(tobaux(2,k,j),qcmark_huge)
tqm(k)=nint(qcmark(3,k))
exit
- endif
- endif
+ end if
+ end if
if (tpc(k,j)==vtcd) then
obsdat(3,k)=tobaux(1,k,j+1)
qcmark(3,k)=min(tobaux(2,k,j+1),qcmark_huge)
@@ -1651,6 +1727,25 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
end if
end if
+! If moisture ob (qob) and (2D/3D)RTMA, set tv flag information (based on tpc)
+! regarding virtual vs. sensible temperaure, to get tdry (if virtual temp
+! then compute tdry; if sensible temp, then tdry= tsen), then save tdry
+! in q-obsdaig file for RTMA offline Auto-QC.
+ if (qob .and. (l_rtma3d .or. twodvar_regional)) then
+ tobs4q(1,:) = bmiss
+ tqm4q(1,:) = bmiss
+ tvflg4q(1,:)= -one
+ do k=1,levs
+ tvflg4q(1,k)=one ! initialize as sensible
+ tobs4q(1,k)=obsdat(3,k) ! temp obs read in prepbufr
+ tqm4q(1,k)=tqm(k)
+ do j=1,20
+ if (tpc(k,j)==vtcd) tvflg4q(1,k)=zero ! reset flag if virtual
+ if (tpc(k,j)>=bmiss) exit ! end of stack
+ end do
+ end do
+ end if ! if qob & rtma
+
if(i_gsdqc==2) then
! AMV acceptance for all obs (E. James)
if (kx >= 240 .and. kx <= 260) then
@@ -1701,16 +1796,14 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
endif
end if
LOOP_K_LEVS: do k=1,levs
- if( zflag ==-1) then
- ppb=obsdat(1,k)*one_tenth
- else if(zflag ==1) then
- ppb=obsdat(4,k)
- endif
- if(kx==224 .and. newvad)then
- if(mod(k,6)/=0) cycle LOOP_K_LEVS
- end if
-
- icntpnt=icntpnt+1
+ if( zflag ==-1) then
+ ppb=obsdat(1,k)*one_tenth
+ else if(zflag ==1) then
+ ppb=obsdat(4,k)
+ endif
+ if(kx==224 .and. newvad)then
+ if(mod(k,6)/=0) cycle LOOP_K_LEVS
+ end if
! Extract quality marks
if(tob)then
@@ -1735,6 +1828,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
gustqm=0
if (kx==188 .or. kx==288 .or. kx==195 .or. kx==295 ) &
call get_gustqm(kx,c_station_id,c_prvstg,c_sprvstg,gustqm)
+ if ( l_rtma3d ) gustqm = 0 ! skipping get_gustqm for 3drtma run (missing list file)
qm=gustqm
else if(visob) then
visqm=0 ! need to fix this later
@@ -1827,7 +1921,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
if (l4dvar.or.l4densvar) then
if (t4dvwinlen) cycle LOOP_K_LEVS
else
- if (real(abs(time))>real(ctwind(nc)) .or. real(abs(time))>real(twindin)) cycle LOOP_K_LEVS
+ ! Fix to ensure end of time window is NOT included
+ if (real(abs(time)) > real(ctwind(nc)) .or. real(time)==real(three) .or. &
+ real(abs(time)) > real(twindin)) cycle LOOP_K_LEVS ! outside time window
+! if (real(abs(time))>real(ctwind(nc)) .or. real(abs(time))>real(twindin)) cycle LOOP_K_LEVS
endif
end if
@@ -1914,21 +2011,44 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! Missing Values ==> Cycling! In this case for howv only. #ww3
if (howvob .and. owave(1,k) > r0_1_bmiss) cycle LOOP_K_LEVS
+! Over-ride QM=9 and hard-wire errors for land obs and hofx_sfc_file option
+! Can be deleted once prepbufr processing updated.
+ if ( global_2m_land ) then
+ if (tob .and. qm==9 ) then
+ pqm(k)=2 ! otherwise, type 183 will be discarded.
+ qm=2
+ tqm(k)=2
+ if (kx==187) obserr(3,k)=2.0_r_double
+ if (kx==181) obserr(3,k)=2.0_r_double
+ if (kx==183) obserr(3,k)=2.0_r_double
+ endif
+ if (qob .and. qm == 9 ) then
+ qm = 2
+ ! qob err specified as fraction of qsat, multiplied by 10.
+ if (kx==187) obserr(2,k)=1.0_r_double
+ if (kx==181) obserr(2,k)=1.0_r_double
+ if (kx==183) obserr(2,k)=1.0_r_double
+ endif
+ endif
! Set usage variable
usage = zero
- if(icuse(nc) <= 0)usage=100._r_kind
- if(qm == 15 .or. qm == 12 .or. qm == 9)usage=100._r_kind
- if(qm >=lim_qm )usage=101._r_kind
- if(convobs .and. pqm(k) >=lim_qm )usage=102._r_kind
- if((kx>=192.and.kx<=195) .and. psob )usage=r100
- if (gustob .and. obsdat(8,k) > r0_1_bmiss) usage=103._r_kind
- if (visob .and. obsdat(9,k) > r0_1_bmiss) usage=103._r_kind
- if (tdob .and. obsdat(12,k) > r0_1_bmiss) usage=103._r_kind
- if (pmob .and. obsdat(13,k) > r0_1_bmiss) usage=103._r_kind
- if (mxtmob .and. maxtmint(1,k) > r0_1_bmiss) usage=103._r_kind
- if (mitmob .and. maxtmint(2,k) > r0_1_bmiss) usage=103._r_kind
- if (howvob .and. owave(1,k) > r0_1_bmiss) usage=103._r_kind
- if (cldchob .and. cldceilh(1,k) > r0_1_bmiss) usage=103._r_kind
+ if((gustob .and. obsdat(8,k) > r0_1_bmiss) .or. &
+ (visob .and. obsdat(9,k) > r0_1_bmiss) .or. &
+ (tdob .and. obsdat(12,k) > r0_1_bmiss) .or. &
+ (pmob .and. obsdat(13,k) > r0_1_bmiss) .or. &
+ (mxtmob .and. maxtmint(1,k) > r0_1_bmiss) .or. &
+ (mitmob .and. maxtmint(2,k) > r0_1_bmiss) .or. &
+ (howvob .and. owave(1,k) > r0_1_bmiss) .or. &
+ (cldchob .and. cldceilh(1,k) > r0_1_bmiss))then
+ usage=103._r_kind
+ else if(convobs .and. pqm(k) >=lim_qm )then
+ usage=102._r_kind
+ else if(qm >=min(lim_qm,8) )then
+ usage=101._r_kind
+ else if(icuse(nc) <= 0 .or. &
+ (kx>=192 .and. kx<=195 .and. psob))then
+ usage=100._r_kind
+ end if
if (sfctype) then
if (i_gsdsfc_uselist==1 ) then
@@ -1943,20 +2063,21 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
!retrieve wind sensor height
if (twodvar_regional) then
if ( kx==288.or.kx==295 .or. (gustob .and. (kx==188.or.kx==195)) ) then
- call find_wind_height(c_prvstg,c_sprvstg,windsensht)
+ call find_wind_height(c_prvstg,c_sprvstg,windsensht,kcount)
endif
endif
- endif
- if (sfctype .and. i_gsdqc==2) then ! filter bad 2-m dew point and 0 mesonet wind obs
- if (kx==288.or.kx==295) then ! for mesonet wind
- if(abs(obsdat(5,k))<0.01_r_kind .and. abs(obsdat(6,k))<0.01_r_kind) usage=115._r_kind
- endif
- if (qob .and. (kx >=180 .and. kx<=189) .and. obsdat(2,k) < 1.0e10_r_kind) then ! for 2-m dew point
- if(obsdat(12,k) < min(-40.0_r_kind,obsdat(3,k)-10.0_r_kind)) usage=116._r_kind ! < min(-40C or T-Td)
- if((obsdat(3,k)-obsdat(12,k)) > 70.0_r_kind) usage=117._r_kind ! <70C
- if(obsdat(12,k) > 32.2_r_kind) usage=118._r_kind ! > 90F
+ if(i_gsdqc==2) then ! filter bad 2-m dew point and 0 mesonet wind obs
+ if (kx==288.or.kx==295) then ! for mesonet wind
+ if(abs(obsdat(5,k))<0.01_r_kind .and. abs(obsdat(6,k))<0.01_r_kind) usage=115._r_kind
+ endif
+ if (qob .and. (kx >=180 .and. kx<=189) .and. obsdat(2,k) < 1.0e10_r_kind) then ! for 2-m dew point
+ if(obsdat(12,k) < min(-40.0_r_kind,obsdat(3,k)-10.0_r_kind)) usage=116._r_kind ! < min(-40C or T-Td)
+ if((obsdat(3,k)-obsdat(12,k)) > 70.0_r_kind) usage=117._r_kind ! <70C
+ if(obsdat(12,k) > 32.2_r_kind) usage=118._r_kind ! > 90F
+ endif
endif
endif
+ ! to-do: should we add qob checks from above for landsfctype too?
if ((kx>129.and.kx<140).or.(kx>229.and.kx<240) ) then
call get_aircraft_usagerj(kx,obstype,c_station_id,usage)
@@ -1976,13 +2097,92 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! don't use MESONET psfc obs if 8th character of station id is "x")
if( kx==188 .and. psob .and. sidchr(8)=='x' ) usage=r100
+! Set inflate_error logical based on qm flag
+ inflate_error=.false.
+ if (qm==3 .or. qm==7) inflate_error=.true.
+
+ if(uvob) then
+ selev=stnelev
+ oelev=obsdat(4,k)
+ if(kx >= 280 .and. kx < 300 )then
+ if (twodvar_regional.and.(kx==288.or.kx==295)) then
+ oelev=windsensht+selev !windsensht: read in from prepbufr
+ else
+ oelev=r10+selev
+ endif
+ if (kx == 280 )then
+ it29=nint(hdr(8))
+ if(it29 == 522 .or. it29 == 523 .or. it29 == 531)then
+! oelev=r20+selev
+ oelev=r20
+ end if
+ end if
+
+ if (kx == 282) oelev=r20+selev
+ if (kx == 285 .or. kx == 289 .or. kx == 290) then
+ oelev=selev
+ selev=zero
+ endif
+ else
+ if((kx >= 221 .and. kx <= 229) &
+ .and. selev >= oelev) oelev=r10+selev
+ end if
+
+! Rotate winds to rotated coordinate
+ uob=obsdat(5,k)
+ vob=obsdat(6,k)
+ !* thin new VAD wind and generate VAD superob
+ if(kx==224.and.newvad)then
+ klev=k+5 !*average over 6 points
+ ! klev=k !* no average
+ if(klev>levs) cycle loop_readsb
+ diffuu=obsdat(5,k)-fcstdat(1,k)
+ diffvv=obsdat(6,k)-fcstdat(2,k)
+ if(sqrt(diffuu**2+diffvv**2)>10.0_r_kind) cycle loop_k_levs
+ if(abs(diffvv)>8.0_r_kind) cycle loop_k_levs
+ !if(abs(diffvv)>5.0.and.oelev<5000.0.and.fcstdat(3,k)>276.3) cycle loop_k_levs
+ if(oelev>7000.0_r_kind) cycle loop_k_levs
+ if(abs(diffvv)>5.0_r_kind.and.oelev<5000.0_r_kind) cycle loop_k_levs
+ ! write(6,*)'sliu diffuu,vv::',diffuu, diffvv
+ uob=zero
+ vob=zero
+ oelev=zero
+ tkk=0
+ do ikkk=k,klev
+ diffhgt=obsdat(4,ikkk)-obsdat(4,k)
+ if(diffhgt<301.0_r_kind)then
+ uob=uob+obsdat(5,ikkk)
+ vob=vob+obsdat(6,ikkk)
+ oelev=oelev+obsdat(4,ikkk)
+ tkk=tkk+1
+ end if
+ end do
+ uob=uob/tkk
+ vob=vob/tkk
+ oelev=oelev/tkk
+
+ diffuu=5.0_r_kind;diffvv=5.0_r_kind
+ diffhgt=0.0_r_kind
+ do ikkk=k,klev
+ diffuu=abs(obsdat(5,ikkk)-uob)
+ if(diffhgt5.0_r_kind)cycle LOOP_K_LEVS !* if u-u_avg>5.0, reject
+ if(tkk<3) cycle LOOP_K_LEVS !* obs numb<3, reject
+ !* unreasonable observation, will fix this in QC package
+ if(sqrt(uob**2+vob**2)>60.0_r_kind)cycle LOOP_readsb
+ end if
+ end if
! Get information from surface file necessary for conventional data here
+ if(icuse(nc) < 0)qm = 9
! Special block for data thinning - if requested
if (ithin > 0 .and. ithin <5 .and. usage <100.0_r_kind) then
! if (ithin > 0 .and. ithin <5) then
- ntmp=ndata ! counting moved to map3gridS
! Set data quality index for thinning
if (thin4d) then
@@ -2005,46 +2205,27 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
if (ptime >zero ) then
itime=int((abs(timedif)+three)/ptime)+1
- if(itime >ntime) itime=ntime
- call map3grids_tm(zflag,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
- ppb,itime,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.)
- if (.not. luse) then
- if(k==levs) then
- cycle loop_readsb
- else
- cycle LOOP_K_LEVS
- endif
- endif
- if(iiout > 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+1
- if(uvob)nodata=nodata+1
- endif
- isort(icntpnt)=iout
+ if(itime >ntime) itime=ntime
+ call map3grids_m_tm(zflag,save_all,pflag,presl_thin,nlevp, &
+ dlat_earth,dlon_earth,ppb,itime,crit1,ndata,&
+ luse,maxobs,rthin,.false.,.false.)
else
- call map3grids(zflag,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
- ppb,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.)
- if (.not. luse) then
- if(k==levs) then
- cycle loop_readsb
- else
- cycle LOOP_K_LEVS
- endif
- endif
- if(iiout > 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+1
- if(uvob)nodata=nodata+1
+ call map3grids_m(zflag,save_all,pflag,presl_thin,nlevp, &
+ dlat_earth,dlon_earth,ppb,crit1,ndata,&
+ luse,maxobs,rthin,.false.,.false.)
+ endif
+ if (.not. luse) then
+ if(k==levs) then
+ cycle loop_readsb
+ else
+ cycle LOOP_K_LEVS
endif
- isort(icntpnt)=iout
endif
+ if(rthin(ndata))usage=101._r_kind
else
ndata=ndata+1
- nodata=nodata+1
- if(uvob)nodata=nodata+1
- iout=ndata
- isort(icntpnt)=iout
endif
+ iout=ndata
if(ndata > maxobs) then
write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype
@@ -2061,10 +2242,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! Extract pressure level and quality marks
dlnpob=log(plevs(k)) ! ln(pressure in cb)
-! Set inflate_error logical based on qm flag
- inflate_error=.false.
- if (qm==3 .or. qm==7) inflate_error=.true.
+ if(qm >= 8 .or. usage >= 100.0_r_kind)then
+ rusage(iout)=.false.
+ end if
! Temperature
if(tob) then
ppb=obsdat(1,k)
@@ -2116,6 +2297,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! Winds
else if(uvob) then
+
if (aircraftobs .and. aircraft_t_bc .and. acft_profl_file) then
call errormod_aircraft(pqm,wqm,levs,plevs,errout,k,presl,dpres,nsig,lim_qm,hdr3)
else
@@ -2124,80 +2306,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
woe=obserr(5,k)*errout
if (inflate_error) woe=woe*r1_2
if(obsdat(1,k) < r50)woe=woe*r1_2
- selev=stnelev
- oelev=obsdat(4,k)
- if(kx >= 280 .and. kx < 300 )then
- if (twodvar_regional.and.(kx==288.or.kx==295)) then
- oelev=windsensht+selev !windsensht: read in from prepbufr
- else
- oelev=r10+selev
- endif
- if (kx == 280 )then
- it29=nint(hdr(8))
- if(it29 == 522 .or. it29 == 523 .or. it29 == 531)then
-! oelev=r20+selev
- oelev=r20
- end if
- end if
-
- if (kx == 282) oelev=r20+selev
- if (kx == 285 .or. kx == 289 .or. kx == 290) then
- oelev=selev
- selev=zero
- endif
- else
- if((kx >= 221 .and. kx <= 229) &
- .and. selev >= oelev) oelev=r10+selev
- end if
-
-! Rotate winds to rotated coordinate
- uob=obsdat(5,k)
- vob=obsdat(6,k)
- !* thin new VAD wind and generate VAD superob
- if(kx==224.and.newvad)then
- klev=k+5 !*average over 6 points
- ! klev=k !* no average
- if(klev>levs) cycle loop_readsb
- diffuu=obsdat(5,k)-fcstdat(1,k)
- diffvv=obsdat(6,k)-fcstdat(2,k)
- if(sqrt(diffuu**2+diffvv**2)>10.0_r_kind) cycle loop_k_levs
- if(abs(diffvv)>8.0_r_kind) cycle loop_k_levs
- !if(abs(diffvv)>5.0.and.oelev<5000.0.and.fcstdat(3,k)>276.3) cycle loop_k_levs
- if(oelev>7000.0_r_kind) cycle loop_k_levs
- if(abs(diffvv)>5.0_r_kind.and.oelev<5000.0_r_kind) cycle loop_k_levs
- ! write(6,*)'sliu diffuu,vv::',diffuu, diffvv
- uob=0.0
- vob=0.0
- oelev=0.0
- tkk=0
- do ikkk=k,klev
- diffhgt=obsdat(4,ikkk)-obsdat(4,k)
- if(diffhgt<301.0_r_kind)then
- uob=uob+obsdat(5,ikkk)
- vob=vob+obsdat(6,ikkk)
- oelev=oelev+obsdat(4,ikkk)
- tkk=tkk+1
- end if
- end do
- uob=uob/tkk
- vob=vob/tkk
- oelev=oelev/tkk
-
- diffuu=5.0_r_kind;diffvv=5.0_r_kind
- diffhgt=0.0_r_kind
- do ikkk=k,klev
- diffuu=abs(obsdat(5,ikkk)-uob)
- if(diffhgt5.0_r_kind)cycle LOOP_K_LEVS !* if u-u_avg>5.0, reject
- if(tkk<3) cycle LOOP_K_LEVS !* obs numb<3, reject
- !* unreasonable observation, will fix this in QC package
- if(sqrt(uob**2+vob**2)>60.0_r_kind)cycle LOOP_readsb
- end if
-
if(regional .and. .not. fv3_regional)then
u0=uob
v0=vob
@@ -2210,6 +2318,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
end if
endif
+
cdata_all(1,iout)=woe ! wind error
cdata_all(2,iout)=dlon ! grid relative longitude
cdata_all(3,iout)=dlat ! grid relative latitude
@@ -2239,8 +2348,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
cdata_all(25,iout)=var_jb(5,k) ! non linear qc parameter
cdata_all(26,iout)=one ! hilbert curve weight, modified later
if(perturb_obs)then
- cdata_all(28,iout)=ran01dom()*perturb_fact ! u perturbation
- cdata_all(29,iout)=ran01dom()*perturb_fact ! v perturbation
+ cdata_all(27,iout)=ran01dom()*perturb_fact ! u perturbation
+ cdata_all(28,iout)=ran01dom()*perturb_fact ! v perturbation
endif
else if(spdob) then
@@ -2326,7 +2435,15 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
end if
qobcon=obsdat(2,k)*convert
tdry=r999
- if (tqm(k) 0.0_r_kind ) gustoe = oerr_gust
selev=stnelev
oelev=obsdat(4,k)
if(selev == oelev)oelev=r10+selev
@@ -2465,6 +2585,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
if ((kx==188).or.(kx==288) .or.(kx==195) .or.(kx==295)) then
! gustoe=2.5
gustoe=1.0
+ if ( l_rtma3d .and. oerr_gust > 0.0_r_kind ) gustoe = oerr_gust
windcorr=abs(obsdat(5,k))<1.0 .and. abs(obsdat(6,k))<1.0 .and. obsdat(8,k)>10.0
if (windcorr) gustoe=gustoe*1.5_r_kind
@@ -2781,7 +2902,6 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
hig_cldamt,hig_cldamt_qc,tcamt,lcbas,tcamt_qc,lcbas_qc,ceiling,stnelev)
end if
- if(tcamt_qc==15 .or. tcamt_qc==12 .or. tcamt_qc==9) usage=100._r_kind
tcamt_oe=20.0_r_kind
if(tcamt_qc==1) tcamt_oe=tcamt_oe*1.25_r_kind
if(tcamt_qc==2) tcamt_oe=tcamt_oe*1.50_r_kind
@@ -2818,7 +2938,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
low_cldamt,low_cldamt_qc,mid_cldamt,mid_cldamt_qc, &
hig_cldamt,hig_cldamt_qc,tcamt,lcbas,tcamt_qc,lcbas_qc,ceiling,stnelev)
- if(lcbas_qc==15 .or. lcbas_qc==12 .or. lcbas_qc==9) usage=100._r_kind
+ if(lcbas_qc >= 8) usage=100._r_kind
+ if(usage >= 100.0_r_kind)rusage(iout)=.false.
lcbas_oe=4500.0_r_kind
if(lcbas_qc==3) lcbas_oe=lcbas_oe*1.25_r_kind
if(lcbas_qc==4) lcbas_oe=lcbas_oe*1.5_r_kind
@@ -2925,51 +3046,82 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
deallocate(presl_thin)
call del3grids
endif
- if (.not.use_all_tm) then
- deallocate(presl_thin)
+ if(.not.use_all_tm) then
+ deallocate(presl_thin)
call del3grids_tm
endif
-
! Normal exit
enddo loop_convinfo! loops over convinfo entry matches
deallocate(lmsg,tab,nrep)
+
! Close unit to bufr file
call closbf(lunin)
close(lunin)
! Apply hilbert curve for cross validation if requested
- if(lhilbert) &
- call apply_hilbertcurve(maxobs,obstype,cdata_all(thisobtype_usage,1:maxobs))
+ if(lhilbert) then
+ call apply_hilbertcurve(ndata,obstype,cdata_all(thisobtype_usage,1:ndata))
-! Write header record and data to output file for further processing
- allocate(iloc(ndata))
- icount=0
- do i=1,maxobs
- if(isort(i) > 0)then
- icount=icount+1
- iloc(icount)=isort(i)
- end if
- end do
- if(ndata /= icount)then
- write(6,*) ' PREPBUFR: mix up in read_prepbufr ,ndata,icount ',ndata,icount
- call stop2(50)
+ do i=1,ndata
+ if(cdata_all(thisobtype_usage,i) >= 100._r_kind) rusage(i) = .false.
+ end do
end if
- allocate(cdata_out(nreal,ndata))
- do i=1,ndata
- itx=iloc(i)
- do k=1,nreal
- cdata_out(k,i)=cdata_all(k,itx)
+
+ nxdata=ndata
+ ndata=0
+ if(nxdata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,maxobs
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' prep ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin
+! If thinned data set quality mark to 14
+ ! If flag to not save thinned data is set - compress data
+ do i=1,nxdata
+ ! pmot=0 - all obs - thin obs
+ ! pmot=1 - all obs
+ ! pmot=2 - use obs
+ ! pmot=3 - use obs + thin obs
+
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 1) .or. &
+ (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ if(rthin(i) .and. iqm > 0)cdata_all(iqm,i)=14
+ if(.not. rusage(i))cdata_all(iuse,i) = max(cdata_all(iuse,i),101.0_r_kind)
+ ndata=ndata+1
+ if(i > ndata)then
+ do k=1,nreal
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
+ end if
end do
- end do
- deallocate(iloc,isort,cdata_all)
+ if(uvob)then
+ nodata=nodata+2*ndata
+ else
+ nodata=nodata+ndata
+ end if
+ end if
+ deallocate(rusage,rthin)
+
! the following is gettin the types which will be applied hilbert curve to
! estimate the density
- if(obstype == 'uv') then
+ if(obstype == 'uv' .and. ndata > 0) then
vmin=-10.00_r_kind
vmax=18000.00_r_kind
nor=0
@@ -3046,7 +3198,8 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
endif
enddo
- write(6,*),'READ_PREPBUFR:dentrip,pmesh,rmesh,ndata=',dentrip,pmesh,rmesh,ntime_max,ndata
+ write(6,*),'READ_PREPBUFR: itype,dentrip,pmesh,rmesh,ndata=',&
+ itype,dentrip,pmesh,rmesh,ntime_max,ndata
if(dentrip >= one .and. pmesh >zero .and. rmesh >zero) then
allocate(data_hilb(3,ndata,6),index_arr(ndata,ntime_max))
@@ -3056,21 +3209,25 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
index_arr=0
do k=1,ndata
- ikx=nint(cdata_out(10,k))
- itype=ictype(ikx)
+ ikx=nint(cdata_all(10,k))
+ if (ikx>0) then
+ itype=ictype(ikx)
+ else
+ itype=0
+ endif
if( itype ==230 .or. itype ==231 .or. itype ==233) then
- prest=r10*exp(cdata_out(4,k))
+ prest=r10*exp(cdata_all(4,k))
if (prest <100.0_r_kind) cycle
if(ithin_conv(ikx) >=5) then
if(ptime_conv(ikx) >zero) then
- ntime=int(((cdata_out(9,k)-time_offset)+three)/ptime_conv(ikx))+1
+ ntime=int(((cdata_all(9,k)-time_offset)+three)/ptime_conv(ikx))+1
endif
if(ntime >ntime_max) ntime=ntime_max
if(ntime <0) ntime=1
ntype_arr(ntime)=ntype_arr(ntime)+1
ndata_hil=ntype_arr(ntime)
- data_hilb(1,ndata_hil,ntime)=cdata_out(20,k)
- data_hilb(2,ndata_hil,ntime)=cdata_out(19,k)
+ data_hilb(1,ndata_hil,ntime)=cdata_all(20,k)
+ data_hilb(2,ndata_hil,ntime)=cdata_all(19,k)
prest=prest*100.0_r_kind
if(prest >stndrd_atmos_ps) then
prest=zero
@@ -3088,7 +3245,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
write(6,*),'READ_PREPBUFR :something is wrong,lat,lon,prest=',&
data_hilb(1,ndata_hil,ntime),&
data_hilb(2,ndata_hil,ntime),&
- cdata_out(4,k),data_hilb(3,ndata_hil,ntime)
+ cdata_all(4,k),data_hilb(3,ndata_hil,ntime)
endif
endif
endif
@@ -3110,12 +3267,12 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
ndata_hil=0
deallocate(rlat_hil,rlon_hil,height,wtob)
endif
- enddo
+ enddo
deallocate(data_hilb,index_arr)
endif
do i=1,ndata
- cdata_out(26,i)=wght_hilb(i)
+ cdata_all(26,i)=wght_hilb(i)
enddo
deallocate(wght_hilb)
@@ -3130,26 +3287,24 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
if(metarcldobs .and. ndata > 0) then
if(i_ens_mean /= 1) then
maxobs=2000000
- allocate(cdata_all(nreal,maxobs))
- call reorg_metar_cloud(cdata_out,nreal,ndata,cdata_all,maxobs,iout)
+ allocate(cdata_out(nreal,maxobs))
+ call reorg_metar_cloud(cdata_all,nreal,ndata,cdata_out,maxobs,iout)
ndata=iout
- deallocate(cdata_out)
- allocate(cdata_out(nreal,ndata))
+ deallocate(cdata_all)
+ allocate(cdata_all(nreal,ndata))
do i=1,nreal
do j=1,ndata
- cdata_out(i,j)=cdata_all(i,j)
+ cdata_all(i,j)=cdata_out(i,j)
end do
end do
- deallocate(cdata_all)
+ deallocate(cdata_out)
endif
endif
- call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs)
+ call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata
- write(lunout) cdata_out
+ write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata)
-
-
- deallocate(cdata_out)
+ deallocate(cdata_all)
call destroy_rjlists
call destroy_aircraft_rjlists
if(i_gsdsfc_uselist==1) call destroy_gsd_sfcuselist
@@ -3165,6 +3320,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
'nvtest,vdisterrmax=',ntest,vdisterrmax
if(print_verbose)write(6,*)'READ_PREPBUFR: closbf(',lunin,')'
+ if (twodvar_regional .and. (uvob .or. gustob .or. spdob)) then
+ write(6,*) 'kcount values from find wind height = ',kcount
+ end if
+
! End of routine
@@ -3283,8 +3442,8 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd)
write(6,*)'error in SONDE_EXT levs > 255'
return
endif
- obsdat(1,ll)=dpmdl(k)
- qcmark(1,ll) =max (qcmark(1,i),qcmark(1,im)) !PQM
+ obsdat(1,ll) = dpmdl(k)
+ qcmark(1,ll) = max (qcmark(1,i),qcmark(1,im)) !PQM
qcmark(2,ll) = bmiss
qcmark(3,ll) = bmiss
qcmark(4,ll) = bmiss
@@ -3297,21 +3456,21 @@ subroutine sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levsio,kx,vtcd)
wi=(dpobs(im)-prsltmp(k))/(dpobs(im)-dpobs(i))
!!! find tob, only bogus if both good obs and of the same type (sensible/virtual)
if( tqm(i)<4 .and. tqm(im)<4 .and. tvflg(i)==tvflg(im) ) then
- obsdat(3,ll)=obsdat(3,im)*wim + obsdat(3,i)*wi
- drfdat(1,ll) = drfdat(1,im)*wim + drfdat(1,i)*wi
- drfdat(2,ll) = drfdat(2,im)*wim + drfdat(2,i)*wi
- drfdat(3,ll) = drfdat(3,im)*wim + drfdat(3,i)*wi
- qcmark(3,ll) =max (qcmark(3,i),qcmark(3,im)) !TQM
- obserr(3,ll) =max (obserr(3,i),obserr(3,im)) ! TOE
+ obsdat(3,ll) = obsdat(3,im)*wim + obsdat(3,i)*wi
+ drfdat(1,ll) = drfdat(1,im)*wim + drfdat(1,i)*wi
+ drfdat(2,ll) = drfdat(2,im)*wim + drfdat(2,i)*wi
+ drfdat(3,ll) = drfdat(3,im)*wim + drfdat(3,i)*wi
+ qcmark(3,ll) = max (qcmark(3,i),qcmark(3,im)) !TQM
+ obserr(3,ll) = max (obserr(3,i),obserr(3,im)) ! TOE
endif
!!! find qob
if( qqm(i)<4 .and. qqm(im)<4 ) then
- obsdat(2,ll)=obsdat(2,im)*wim + obsdat(2,i)*wi
- drfdat(1,ll) = drfdat(1,im)*wim + drfdat(1,i)*wi
- drfdat(2,ll) = drfdat(2,im)*wim + drfdat(2,i)*wi
- drfdat(3,ll) = drfdat(3,im)*wim + drfdat(3,i)*wi
- qcmark(2,ll) =max (qcmark(2,i),qcmark(2,im)) !QQM
- obserr(2,ll) =max (obserr(2,i),obserr(2,im)) ! QOE
+ obsdat(2,ll) = obsdat(2,im)*wim + obsdat(2,i)*wi
+ drfdat(1,ll) = drfdat(1,im)*wim + drfdat(1,i)*wi
+ drfdat(2,ll) = drfdat(2,im)*wim + drfdat(2,i)*wi
+ drfdat(3,ll) = drfdat(3,im)*wim + drfdat(3,i)*wi
+ qcmark(2,ll) = max (qcmark(2,i),qcmark(2,im)) !QQM
+ obserr(2,ll) = max (obserr(2,i),obserr(2,im)) ! QOE
endif
!!! define zob
if( zqm(i)<4 .and. zqm(im)<4 ) then
diff --git a/src/gsi/read_radar.f90 b/src/gsi/read_radar.f90
index 8e5de5aff9..84a4f4fbcf 100644
--- a/src/gsi/read_radar.f90
+++ b/src/gsi/read_radar.f90
@@ -90,16 +90,15 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
eccentricity,somigliana,grav_ratio,grav, &
semi_major_axis,flattening,two
use qcmod, only: erradar_inflate,vadfile,newvad
- use obsmod, only: iadate,ianldate,l_foreaft_thin
+ use obsmod, only: iadate,ianldate,l_foreaft_thin,reduce_diag
use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,time_4dvar,thin4d
use gridmod, only: regional,nlat,nlon,tll2xy,rlats,rlons,rotate_wind_ll2xy,nsig,&
fv3_regional
use gridmod, only: wrf_nmm_regional,nems_nmmb_regional,cmaq_regional,wrf_mass_regional
use gridmod, only: fv3_regional
use convinfo, only: nconvtype,ctwind, &
- ncmiter,ncgroup,ncnumgrp,icuse,ictype,ioctype,ithin_conv,rmesh_conv,pmesh_conv
- use convthin, only: make3grids,map3grids,del3grids,use_all
- use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model
+ ncmiter,ncgroup,ncnumgrp,icuse,ictype,ioctype,ithin_conv,rmesh_conv,pmesh_conv,pmot_conv
+ use convthin, only: make3grids,map3grids_m,del3grids,use_all
use mpimod, only: npe
use gsi_io, only: verbose
use mpimod, only: mype
@@ -107,6 +106,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
use directDA_radaruse_mod, only: l_correct_azmu, l_correct_tilt, i_correct_tilt, &
l_azm_east1st, l_plt_diag_rw
use directDA_radaruse_mod, only: l_use_rw_columntilt
+ use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model
implicit none
@@ -154,7 +154,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
character(30) outmessage
character(255) filename
- integer(i_kind) lnbufr,i,j,k,maxobs,icntpnt,iiout,n,istop
+ integer(i_kind) lnbufr,i,j,k,maxobs,n,istop
integer(i_kind) nmrecs,ibadazm,ibadtilt,ibadrange,ibadwnd,ibaddist,ibadheight,ibadvad,kthin
integer(i_kind) iyr,imo,idy,ihr,imn,isc,ithin
integer(i_kind) ibadstaheight,ibaderror,notgood,idate,iheightbelowsta,ibadfit
@@ -269,9 +269,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
integer(i_kind) :: ii,jjj,nmissing,nirrr,noutside,ntimeout,nsubzero,iimax
integer(i_kind) ntdrvr_in,ntdrvr_kept,ntdrvr_thin1,ntdrvr_thin2
integer(i_kind) ntdrvr_thin2_foreswp,ntdrvr_thin2_aftswp
- integer(i_kind) maxout,maxdata
integer(i_kind) kk,klon1,klat1,klonp1,klatp1
- integer(i_kind),allocatable,dimension(:):: isort
real(r_single) elevmax,elevmin
real(r_single) thisrange,thisazimuth,thistilt
@@ -286,7 +284,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
real(r_kind),dimension(nsig):: zges,hges
real(r_kind) dx,dy,dx1,dy1,w00,w10,w01,w11
logical luse
- integer(i_kind) ntmp,iout
+ integer(i_kind) iout
integer(i_kind):: zflag
integer(i_kind) nlevz ! vertical level for thinning
real(r_kind) crit1,timedif
@@ -298,6 +296,11 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
real(r_kind) tdrele1,tdrele2,tdrele3
integer(i_kind) nswp,firstbeam,nforeswp,naftswp,nfore,naft,nswptype,irec
logical foreswp,aftswp
+
+ logical, allocatable,dimension(:) :: rusage,rthin
+ logical save_all
+! integer(i_kind) numthin,numqc,numrem
+ integer(i_kind) nxdata,pmot,numall
data lnbufr/10/
data hdrstr(1) / 'CLAT CLON SELV ANEL YEAR MNTH DAYS HOUR MINU MGPT' /
@@ -341,7 +344,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
if (.not.lexist1 .and. .not.lexist2 .and. .not.lexist3) return
eradkm=rearth*0.001_r_kind
- maxobs=2e8
+ maxobs=4e6
nreal=maxdat
nchanl=0
ilon=2
@@ -357,10 +360,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
hdrstr(2)='PTID YEAR MNTH DAYS HOUR MINU SECO CLAT CLON FLVLST ANAZ ANEL'
end if
- allocate(cdata_all(maxdat,maxobs),isort(maxobs))
+ allocate(cdata_all(maxdat,maxobs),rusage(maxobs),rthin(maxobs))
- isort = 0
- cdata_all=zero
+ rusage=.true.
+ rthin=.false.
if (trim(infile) /= 'tldplrbufr' .and. trim(infile) /= 'tldplrso') then
@@ -633,17 +636,25 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
nsuper2_kept=0
! LEVEL_TWO_READ: if(loop==0 .and. sis=='l2rw') then
- if(loop==0) outmessage='level 2 superobs:'
+ if(loop==0) outmessage='level 2 superobs:'
! Open sequential file containing superobs
open(lnbufr,file='radar_supobs_from_level2',form='unformatted')
rewind lnbufr
+ pmot=0
+ if(ikx /= 0)then
+ pmot=pmot_conv(ikx)
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all = .false.
+ if(pmot /= 2 .and. pmot /= 0)save_all=.true.
+ end if
! dist2max=-huge(dist2max)
! dist2min=huge(dist2min)
! Loop to read superobs data file
- do
+ superobs:do
+ if(ikx == 0) exit superobs
read(lnbufr,iostat=iret)this_staid,this_stalat,this_stalon,this_stahgt, &
thistime,thislat,thislon,thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt
if(iret/=0) exit
@@ -845,13 +856,14 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
level2(ivad)=level2(ivad)+1
nobs_box(irrr,iaaa,ivadz,ivad)=nobs_box(irrr,iaaa,ivadz,ivad)+1
ndata =min(ndata+1,maxobs)
- nodata =min(nodata+1,maxobs) !number of obs not used (no meaning here)
+ nodata =min(nodata+1,maxobs)
usage = zero
if(icuse(ikx) < 0)usage=r100
if(ncnumgrp(ikx) > 0 )then ! cross validation on
if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx)
end if
-
+ if(usage >= 100._r_kind) rusage(ndata)=.false.
+
call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr)
LEVEL_TWO_READ: if(loop==0 .and. sis=='l2rw') then
@@ -892,9 +904,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
notgood = notgood + 1
end if
- end do
+ end do superobs
close(lnbufr) ! A simple unformatted fortran file should not be mixed with a bufr I/O
+ nread=nsuper2_kept
LEVEL_TWO_READ_2: if(loop==0 .and. sis=='l2rw') then
write(6,*)'READ_RADAR: ',trim(outmessage),' reached eof on 2/2.5/3 superob radar file'
@@ -1087,6 +1100,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
if(trim(ioctype(i)) == trim(obstype))ikx = i
end do
if(ikx==0) cycle loop2
+ pmot=pmot_conv(ikx)
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all = .false.
+ if(pmot /= 2 .and. pmot /= 0)save_all=.true.
call w3fs21(idate5,minobs)
t4dv=real(minobs-iwinbgn,r_kind)*r60inv
if (l4dvar.or.l4densvar) then
@@ -1275,12 +1292,13 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
end if
nobs_box(irrr,iaaa,ivadz,ivad)=nobs_box(irrr,iaaa,ivadz,ivad)+1
ndata = min(ndata+1,maxobs)
- nodata = min(nodata+1,maxobs) !number of obs not used (no meaning here)
+ nodata = min(nodata+1,maxobs)
usage = zero
if(icuse(ikx) < 0)usage=r100
if(ncnumgrp(ikx) > 0 )then ! cross validation on
if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx)
end if
+ if(usage >= 100._r_kind) rusage(ndata)=.false.
call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr)
@@ -1325,7 +1343,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
! End of bufr read loop
end do loop2
end if
-
+
! Normal exit
! Close unit to bufr file
@@ -1335,8 +1353,8 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
write(6,*)'READ_RADAR: ',trim(outmessage),' reached eof on 2.5/3 superob radar file.'
- if(loop==1) write(6,*)'READ_RADAR: nsuper2_5_in,nsuper2_5_kept=',nsuper2_5_in,nsuper2_5_kept
- if(loop==2) write(6,*)'READ_RADAR: nsuper3_in,nsuper3_kept=',nsuper3_in,nsuper3_kept
+ if(loop==1)write(6,*)'READ_RADAR: nsuper2_5_in,nsuper2_5_kept=',nsuper2_5_in,nsuper2_5_kept
+ if(loop==2)write(6,*)'READ_RADAR: nsuper3_in,nsuper3_kept=',nsuper3_in,nsuper3_kept
write(6,*)'READ_RADAR: # no vad match =',novadmatch
write(6,*)'READ_RADAR: # out of vadrange=',ioutofvadrange
write(6,*)'READ_RADAR: # bad azimuths=',ibadazm
@@ -1586,6 +1604,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
if(trim(ioctype(i)) == trim(obstype))ikx = i
end do
if(ikx==0) cycle sb_report
+ pmot=pmot_conv(ikx)
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all = .false.
+ if(pmot /= 2 .and. pmot /= 0)save_all=.true.
! time window check
call w3fs21(idate5,minobs)
@@ -1957,9 +1979,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
re-compile GSI, re-run !!! <-- WARNING*** ***'
end if
ndata = min(ndata+1,maxobs)
- nodata = min(nodata+1,maxobs) !number of obs not used (no meaning here)
+ nodata = min(nodata+1,maxobs)
usage = zero
if(icuse(ikx) < 0)usage=r100
+ if(usage >= 100._r_kind) rusage(ndata)=.false.
call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr)
@@ -2154,18 +2177,14 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
ibadstaheight=0
notgood=0
notgood0=0
- nread=0
ntdrvr_in=0
ntdrvr_kept=0
ntdrvr_thin1=0
ntdrvr_thin2=0
ntdrvr_thin2_foreswp=0
ntdrvr_thin2_aftswp=0
- maxout=0
- maxdata=0
nmissing=0
subset_check(3)='NC006070'
- icntpnt=0
nswp=0
nforeswp=0
naftswp=0
@@ -2195,6 +2214,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
zflag=0
nlevz=nsig
endif
+
xmesh=rmesh
call make3grids(xmesh,nlevz)
allocate(zl_thin(nlevz))
@@ -2219,6 +2239,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
if(trim(ioctype(i)) == trim(obstype))ikx = i
end do
if(ikx == 0) return
+ pmot=pmot_conv(ikx)
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all = .false.
+ if(pmot /= 2 .and. pmot /= 0)save_all=.true.
call w3fs21(iadate,mincy) ! analysis time in minutes
@@ -2390,8 +2414,6 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
ntdrvr_kept=ntdrvr_kept+1
!#################### Data thinning ###################
- icntpnt=icntpnt+1
-
if(ithin > 0)then
if(zflag == 0)then
klon1= int(dlon); klat1= int(dlat)
@@ -2423,7 +2445,6 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
zobs = height
- ntmp=ndata ! counting moved to map3gridS
if (thin4d) then
timedif = zero
else
@@ -2431,27 +2452,19 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
endif
crit1 = timedif/r6+half
- call map3grids(1,zflag,zl_thin,nlevz,dlat_earth,dlon_earth,&
- zobs,crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.)
- maxout=max(maxout,iout)
- maxdata=max(maxdata,ndata)
+ call map3grids_m(1,save_all,zflag,zl_thin,nlevz, &
+ dlat_earth,dlon_earth,zobs,crit1,ndata,&
+ luse,maxobs,rthin,.false.,.false.)
if (.not. luse) then
ntdrvr_thin2=ntdrvr_thin2+1
cycle
endif
- if(iiout > 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+1
- endif
- isort(icntpnt)=iout
else
ndata =ndata+1
- nodata=nodata+1
- iout=ndata
- isort(icntpnt)=iout
endif
+ iout=ndata
if(ndata > maxobs) then
write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype
@@ -2465,9 +2478,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
if(ncnumgrp(ikx) > 0 )then ! cross validation on
if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx)
end if
+ if(usage >= 100._r_kind) rusage(ndata)=.false.
call deter_zsfc_model(dlat,dlon,zsges)
-
+
! Get information from surface file necessary for conventional data here
call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr)
@@ -2508,7 +2522,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
end do ! end of loop, reading TDR so data files
close(lnbufr)
- else
+ else if (trim(infile) == 'tldplrbufr' ) then
nswptype=0
nmrecs=0
@@ -2659,6 +2673,10 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
if(trim(ioctype(i)) == trim(obstype) .and. kx == ictype(i))ikx = i
end do
if(ikx == 0) cycle loop4
+ pmot=pmot_conv(ikx)
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
call w3fs21(idate5,minobs)
t4dv=real(minobs-iwinbgn,r_kind)*r60inv
@@ -2784,8 +2802,9 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
nread=nread+1
! Select data every 3 km along each beam
if(MOD(INT(tdr_obs(1,k)-tdr_obs(1,1)),3000) < 100)then
- if(tdr_obs(3,k) >= 800.) nmissing=nmissing+1 !xx
- if(tdr_obs(3,k) < 800.) then
+ if(tdr_obs(3,k) >= 800.) then
+ nmissing=nmissing+1 !xx
+ else
ii=ii+1
dopbin(ii)=tdr_obs(3,k)
thisrange=tdr_obs(1,k)
@@ -2902,6 +2921,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
good=.true.
if(.not.good0) then
notgood0=notgood0+1
+ good=.false.
cycle
end if
! if data is good, load into output array
@@ -2910,7 +2930,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
ntdrvr_kept=ntdrvr_kept+1
!#################### Data thinning ###################
- icntpnt=icntpnt+1
+ if(ndata>maxobs) exit
if(ithin > 0)then
if(zflag == 0)then
@@ -2943,7 +2963,6 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
zobs = height
- ntmp=ndata ! counting moved to map3gridS
if (thin4d) then
timedif = zero
else
@@ -2951,10 +2970,9 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
endif
crit1 = timedif/r6+half
- call map3grids(1,zflag,zl_thin,nlevz,dlat_earth,dlon_earth,&
- zobs,crit1,ndata,iout,icntpnt,iiout,luse,foreswp,aftswp)
- maxout=max(maxout,iout)
- maxdata=max(maxdata,ndata)
+ call map3grids_m(1,save_all,zflag,zl_thin,nlevz, &
+ dlat_earth,dlon_earth,zobs,crit1,ndata,&
+ luse,maxobs,rthin,foreswp,aftswp)
if (.not. luse) then
if (foreswp) then
@@ -2965,18 +2983,11 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
ntdrvr_thin2=ntdrvr_thin2+1
cycle
endif
- if(iiout > 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+1
- endif
- isort(icntpnt)=iout
else
ndata =ndata+1
- nodata=nodata+1
- iout=ndata
- isort(icntpnt)=iout
endif
+ iout=ndata
if(ndata > maxobs) then
write(6,*)'READ_PREPBUFR: ***WARNING*** ndata > maxobs for ',obstype
@@ -2990,7 +3001,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
if(ncnumgrp(ikx) > 0 )then ! cross validation on
if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx)
end if
-
+ if(usage >= 100._r_kind) rusage(ndata)=.false.
call deter_zsfc_model(dlat,dlon,zsges)
! Get information from surface file necessary for conventional data here
@@ -3013,12 +3024,12 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
cdata(14)= skint ! skin temperature
cdata(15)= ff10 ! 10 meter wind factor
cdata(16)= sfcr ! surface roughness
- cdata(17)=dlon_earth_deg ! earth relative longitude (degrees)
- cdata(18)=dlat_earth_deg ! earth relative latitude (degrees)
- cdata(19)=dist ! range from radar in km (used to estimate beam spread)
- cdata(20)=zsges ! model elevation at radar site
- cdata(21)=thiserr
- cdata(22)=hdr(1)+three+one ! tail Doppler radar
+ cdata(17)= dlon_earth_deg ! earth relative longitude (degrees)
+ cdata(18)= dlat_earth_deg ! earth relative latitude (degrees)
+ cdata(19)= dist ! range from radar in km (used to estimate beam spread)
+ cdata(20)= zsges ! model elevation at radar site
+ cdata(21)= thiserr
+ cdata(22)= hdr(1)+three+one ! tail Doppler radar
do j=1,maxdat
cdata_all(j,iout)=cdata(j)
end do
@@ -3053,6 +3064,50 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
call del3grids
endif
+
+ nxdata=ndata
+ ndata=0
+ if(nxdata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,nxdata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' radar1 ',trim(ioctype(ikx)),ikx,numall,&
+! numrem,numqc,numthin,pmot
+
+! If flag to not save thinned data is set - compress data
+ do i=1,nxdata
+
+
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 1) .or. &
+ (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ if(rthin(i))cdata_all(12,i)=101._r_kind
+ ndata=ndata+1
+ do k=1,maxdat
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
+ end do
+ end if
+ nodata=nodata+ndata
+ deallocate(rusage,rthin)
+
+ write(6,*)'READ_RADAR: # records saved in radar1 = ', ndata
write(6,*)'READ_RADAR: # records(beams) read in nmrecs=', nmrecs
write(6,*)'READ_RADAR: # records out of time window =', ntimeout
write(6,*)'READ_RADAR: # records with bad tilt=',ibadtilt
@@ -3224,9 +3279,10 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
use gsi_4dvar, only: l4dvar,l4densvar,winlen,time_4dvar
use gridmod, only: regional,nlat,nlon,tll2xy,rlats,rlons,rotate_wind_ll2xy,&
fv3_regional
- use convinfo, only: nconvtype,ncmiter,ncgroup,ncnumgrp,icuse,ioctype
- use deter_sfc_mod, only: deter_sfc2
+ use convinfo, only: nconvtype,ncmiter,ncgroup,ncnumgrp,icuse,ioctype,pmot_conv
+ use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model
use mpimod, only: npe
+ use obsmod, only: reduce_diag,time_offset
implicit none
@@ -3267,7 +3323,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
integer(i_kind) iret,kx0
integer(i_kind) nreal,nchanl,ilat,ilon,ikx
integer(i_kind) idomsfc
- real(r_kind) usage,ff10,sfcr,skint,t4dv,t4dvo,toff
+ real(r_kind) usage,ff10,sfcr,skint,t4dvo
real(r_kind) eradkm,dlat_earth,dlon_earth
real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat
real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist
@@ -3295,8 +3351,11 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
real(r_kind) thishgt,thisvr,corrected_azimuth,thiserr,corrected_tilt
integer(i_kind) nsuper2_in,nsuper2_kept
real(r_kind) errzmax
+ logical, allocatable,dimension(:) :: rusage
+ integer(i_kind) numqc,numrem
+ integer(i_kind) nxdata,pmot,numall
+ logical save_all
- integer(i_kind),allocatable,dimension(:):: isort
! following variables are for fore/aft separation
integer(i_kind) irec
@@ -3318,11 +3377,9 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
dlatmin=huge(dlatmin)
dlonmin=huge(dlonmin)
- allocate(cdata_all(maxdat,maxobs),isort(maxobs))
-
- isort = 0
- cdata_all=zero
+ allocate(cdata_all(maxdat,maxobs),rusage(maxobs))
+ rusage=.true.
! Initialize variables
xscale=1000._r_kind
xscalei=one/xscale
@@ -3336,13 +3393,17 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
errzmax=zero
-
! First process any level 2 superobs.
! Initialize variables.
ikx=0
do i=1,nconvtype
if(trim(ioctype(i)) == trim(obstype))ikx = i
end do
+ if(ikx == 0) return
+ pmot=pmot_conv(ikx)
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
timemax=-huge(timemax)
timemin=huge(timemin)
@@ -3406,7 +3467,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
staheight=this_stahgt !station elevation
tiltangle=corrected_tilt*deg2rad
- t4dvo=toff+thistime
+ t4dvo=thistime+time_offset
timemax=max(timemax,t4dvo)
timemin=min(timemin,t4dvo)
@@ -3508,24 +3569,25 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
end if
good=.true.
if(.not.good0) then
+ good=.false.
notgood0=notgood0+1
cycle
- else
-
end if
! If data is good, load into output array
if(good) then
nsuper2_kept=nsuper2_kept+1
ndata =min(ndata+1,maxobs)
- nodata =min(nodata+1,maxobs) !number of obs not used (no meaninghere)
+ nodata =min(nodata+1,maxobs)
usage = zero
if(icuse(ikx) < 0)usage=r100
if(ncnumgrp(ikx) > 0 )then ! cross validation on
if(mod(ndata,ncnumgrp(ikx))== ncgroup(ikx)-1)usage=ncmiter(ikx)
end if
+ if(usage >= 100._r_kind)rusage(ndata)=.true.
- call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr)
+ call deter_sfc2(dlat_earth,dlon_earth,t4dvo,idomsfc,skint,ff10,sfcr)
+ call deter_zsfc_model(dlat,dlon,zsges)
cdata(1) = error ! wind obs error (m/s)
cdata(2) = dlon ! grid relative longitude
@@ -3533,7 +3595,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
cdata(4) = height ! obs absolute height (m)
cdata(5) = rwnd ! wind obs (m/s)
cdata(6) = azm*deg2rad ! azimuth angle (radians)
- cdata(7) = t4dv ! obs time (hour)
+ cdata(7) = t4dvo ! obs time (hour)
cdata(8) = ikx ! type
cdata(9) = tiltangle ! tilt angle (radians)
cdata(10)= staheight ! station elevation (m)
@@ -3559,8 +3621,46 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
end if
end do
+ nxdata=ndata
+ ndata=0
+ if(nxdata > 0)then
+! numqc=0
+! numrem=0
+! do i=1,nxdata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' radar3 ',numall,numrem,numqc
+! If flag to not save thinned data is set - compress data
+ if(pmot /= 1)then
+ do i=1,nxdata
+
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if( pmot == 0 .or. &
+ (pmot == 2 .and. rusage(i)) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ ndata=ndata+1
+ if(i > ndata)then
+ do k=1,maxdat
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
+ end if
+ end do
+ end if
+ end if
+ nodata=nodata+ndata
+
close(lnbufr) ! A simple unformatted fortran file should not be mixed with bufr I/O
+
write(6,*)'READ_RADAR_L2RW_NOVADQC: ',trim(outmessage),' reached eof on 2 superob radar file'
write(6,*)'READ_RADAR_L2RW_NOVADQC: nsuper2_in,nsuper2_kept=',nsuper2_in,nsuper2_kept
write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad azimuths=',ibadazm
@@ -3583,7 +3683,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata)
- deallocate(cdata_all)
+ deallocate(cdata_all,rusage)
return
@@ -3597,15 +3697,16 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
use oneobmod, only: oneobtest,learthrel_rw
use gsi_4dvar, only: l4dvar,l4densvar,winlen,time_4dvar
use gridmod, only: regional,nlat,nlon,tll2xy,rlats,rlons,rotate_wind_ll2xy,nsig
- use obsmod, only: doradaroneob,oneobradid,time_offset
+ use obsmod, only: doradaroneob,oneobradid,time_offset,reduce_diag
use mpeu_util, only: gettablesize,gettable
use convinfo, only: nconvtype,icuse,ioctype
- use deter_sfc_mod, only: deter_sfc2
+ use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model
use mpimod, only: npe
- use read_l2bufr_mod, only: radar_sites,radar_rmesh,radar_zmesh,elev_angle_max,del_time,range_max
+ use read_l2bufr_mod, only: radar_sites,radar_rmesh,radar_zmesh,elev_angle_max,del_time,range_max,radar_pmot
use constants, only: eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening,grav_equator
use obsmod,only: radar_no_thinning,iadate
- use convthin, only: make3grids,map3grids
+ use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model
+ use convthin, only: make3grids,map3grids_m
implicit none
@@ -3645,7 +3746,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
integer(i_kind) iret,kx0
integer(i_kind) nreal,nchanl,ilat,ilon,ikx
integer(i_kind) idomsfc
- real(r_kind) usage,ff10,sfcr,skint,t4dvo,toff
+ real(r_kind) usage,ff10,sfcr,skint,t4dvo
real(r_kind) eradkm,dlat_earth,dlon_earth
real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat
real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist
@@ -3686,7 +3787,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
character(4),allocatable,dimension(:):: rsite
integer(i_kind),allocatable,dimension(:):: ruse
character(8) chdr2,subset
- real(r_double) rdisttest(n_gates_max),hdr(10),hdr2(12),rwnd0(3,n_gates_max)
+ real(r_double) rdisttest(n_gates_max),hdr(3),hdr2(12),rwnd0(3,n_gates_max)
character(4) stn_id
equivalence (chdr2,hdr2(1))
real(r_kind) stn_lat,stn_lon,stn_hgt,stn_az,stn_el,t,range,vrmax,vrmin,aactual,a43,b,c,selev0,celev0,thistiltr,epsh,h,ha,rlonloc,rlatloc
@@ -3695,16 +3796,17 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
real(r_kind):: relm,srlm,crlm,sph,cph,cc,anum,denom
real(r_kind) :: rmesh,xmesh,zmesh,dx,dy,dx1,dy1,w00,w01,w10,w11
real(r_kind), allocatable, dimension(:) :: zl_thin
- integer(i_kind) :: ithin,zflag,nlevz,icntpnt,klon1,klat1,kk,klatp1,klonp1
+ integer(i_kind) :: ithin,zflag,nlevz,klon1,klat1,kk,klatp1,klonp1
real(r_kind),dimension(nsig):: hges,zges
real(r_kind) sin2,termg,termr,termrg,zobs
- integer(i_kind) ntmp,iout,iiout,ntdrvr_thin2
+ integer(i_kind) iout,ntdrvr_thin2
real(r_kind) crit1,timedif
- integer(i_kind) maxout,maxdata
logical :: luse
- integer(i_kind) iyref,imref,idref,ihref,nout
-
- integer(i_kind),allocatable,dimension(:):: isort
+ integer(i_kind) iyref,imref,idref,ihref,nout
+ logical, allocatable,dimension(:) :: rusage,rthin
+ logical save_all
+! integer(i_kind) numthin,numqc,numrem
+ integer(i_kind) nxdata,pmot,numall
! following variables are for fore/aft separation
integer(i_kind) irec
@@ -3731,7 +3833,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
ilat=3
ikx=0
do j=1,nconvtype
- if(trim(ioctype(j)) == trim(obstype))ikx = j
+ if(trim(ioctype(j)) == trim(obstype))ikx = j
end do
iaaamax=-huge(iaaamax)
iaaamin=huge(iaaamin)
@@ -3739,10 +3841,10 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
dlonmax=-huge(dlonmax)
dlatmin=huge(dlatmin)
dlonmin=huge(dlonmin)
- allocate(cdata_all(maxdat,maxobs),isort(maxobs))
+ allocate(cdata_all(maxdat,maxobs),rusage(maxobs),rthin(maxobs))
- isort = 0
- cdata_all=zero
+ rthin=.false.
+ rusage=.true.
xscale=1000._r_kind
xscalei=one/xscale
max_rrr=nint(1000000.0_r_kind*xscalei)
@@ -3751,7 +3853,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
nmrecs=0
irec=0
errzmax=zero
-
+
timemax=-huge(timemax)
timemin=huge(timemin)
errmax=-huge(errmax)
@@ -3773,16 +3875,16 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
nsuper2_in=0
nsuper2_kept=0
ntdrvr_thin2=0
- maxout=0
- maxdata=0
- isort=0
- icntpnt=0
nout=0
if(loop==0) outmessage='level 2 superobs:'
rmesh=radar_rmesh
zmesh=radar_zmesh
nlevz=nint(16000._r_kind/zmesh)
xmesh=rmesh
+ pmot=radar_pmot
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
call make3grids(xmesh,nlevz)
allocate(zl_thin(nlevz))
zflag=1
@@ -3860,11 +3962,10 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
stn_lat=hdr2(2)
stn_lon=hdr2(3)
stn_hgt=hdr2(4)+hdr2(5)
- call ufbint(inbufr,hdr,10,1,levs, &
- 'SSTN YEAR MNTH DAYS HOUR MINU SECO ANAZ ANEL QCRW')
+ call ufbint(inbufr,hdr,3,1,levs,'ANAZ ANEL QCRW')
nradials_in=nradials_in+1
- stn_az=r90-hdr(8)
- stn_el=hdr(9)
+ stn_az=r90-hdr(1)
+ stn_el=hdr(2)
call ufbint(inbufr,rwnd0,3,n_gates_max,n_gates,'DIST125M DMVR DVSW')
do i=1,n_gates
range=distfact*rwnd0(1,i)
@@ -3972,7 +4073,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
slat=sin(dlat_earth)
staheight=this_stahgt !station elevation
tiltangle=corrected_tilt*deg2rad
- t4dvo=toff+thistime
+ t4dvo=time_offset+thistime
timemax=max(timemax,t4dvo)
timemin=min(timemin,t4dvo)
! Exclude data if it does not fall within time window
@@ -4030,7 +4131,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
azm=azm_earth
end if
!#################### Data thinning ###################
- icntpnt=icntpnt+1
+ if(ndata>maxobs) exit
ithin=1 !number of obs to keep per grid box
if(radar_no_thinning) then
ithin=-1
@@ -4064,32 +4165,23 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
end do
endif
zobs = height
- ntmp=ndata ! counting moved to map3gridS
if (l4dvar) then
timedif = zero
else
- timedif=abs(t4dvo-toff)
+ timedif=abs(t4dvo-time_offset)
endif
crit1 = timedif/r6+half
- call map3grids(1,zflag,zl_thin,nlevz,dlat_earth,dlon_earth,&
- zobs,crit1,ndata,iout,icntpnt,iiout,luse, .false., .false.)
- maxout=max(maxout,iout)
- maxdata=max(maxdata,ndata)
+ call map3grids_m(1,save_all,zflag,zl_thin,nlevz, &
+ dlat_earth,dlon_earth,zobs,crit1,ndata,&
+ luse,maxobs,rthin,.false.,.false.)
if (.not. luse) then
ntdrvr_thin2=ntdrvr_thin2+1
cycle
endif
- if(iiout > 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+1
- endif
- isort(icntpnt)=iout
else
ndata =ndata+1
- nodata=nodata+1
- iout=ndata
- isort(icntpnt)=iout
endif
+ iout=ndata
!#################### Data thinning ###################
if(.not. oneobtest) then
iaaa=azm/(r360/(r8*irrr))
@@ -4137,7 +4229,14 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
if(good) then
usage = zero
- if(icuse(ikx) < 0)usage=r100
+ if(icuse(ikx) < 0)then
+ rusage(ndata)=.false.
+ usage=r100
+ end if
+
+! Get information from surface file necessary for conventional data here
+ call deter_zsfc_model(dlat,dlon,zsges)
+ call deter_sfc2(dlat_earth,dlon_earth,t4dvo,idomsfc,skint,ff10,sfcr)
nsuper2_kept=nsuper2_kept+1
cdata(1) = error ! wind obs error (m/s)
@@ -4146,7 +4245,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
cdata(4) = height ! obs absolute height (m)
cdata(5) = rwnd ! wind obs (m/s)
cdata(6) = azm*deg2rad ! azimuth angle (radians)
- cdata(7) = t4dvo+time_offset ! obs time (hour)
+ cdata(7) = t4dvo ! obs time (hour)
cdata(8) = ikx ! type
cdata(9) = tiltangle ! tilt angle (radians)
cdata(10)= staheight ! station elevation (m)
@@ -4172,23 +4271,68 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
end do
end do
close(lnbufr) ! A simple unformatted fortran file should not be mixed with bufr I/O
- write(6,*)'READ_RADAR_L2RW_NOVADQC: ',trim(outmessage),' reached eof on 2 superob radar file'
- write(6,*)'READ_RADAR_L2RW_NOVADQC: nsuper2_in,nsuper2_kept=',nsuper2_in,nsuper2_kept
- write(6,*)'READ_RADAR_L2RW_NOVADQC: # bad winds =',ibadwnd,nobs_badvr,nobs_badsr
- write(6,*)'READ_RADAR_L2RW_NOVADQC: # num thinned =',kthin,ntdrvr_thin2
- write(6,*)'READ_RADAR_L2RW_NOVADQC: timemin,max =',timemin,timemax
- write(6,*)'READ_RADAR_L2RW_NOVADQC: errmin,max =',errmin,errmax
- write(6,*)'READ_RADAR_L2RW_NOVADQC: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax
+ nxdata=ndata
+ ndata=0
+ if(nxdata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,nxdata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' radar2 ',numall,numrem,numqc,numthin
+! If thinned data set quality mark to 14
+ if (ithin == 1 ) then
+ do i=1,nxdata
+ if(rthin(i))cdata_all(12,i)=101._r_kind
+ end do
+ end if
+
+! If flag to not save thinned data is set - compress data
+ if(pmot /= 1)then
+ do i=1,nxdata
+
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ ndata=ndata+1
+ if(i > ndata)then
+ do k=1,maxdat
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
+ end if
+ end do
+ end if
+ end if
+ nodata=nodata+ndata
+ write(6,*)'READ_RADAR_L2RW: ',trim(outmessage),' reached eof on 2 superob radar file'
+ write(6,*)'READ_RADAR_L2RW: nsuper2_in,nsuper2_kept=',nsuper2_in,nsuper2_kept
+ write(6,*)'READ_RADAR_L2RW: # bad winds =',ibadwnd,nobs_badvr,nobs_badsr
+ write(6,*)'READ_RADAR_L2RW: # num thinned =',kthin,ntdrvr_thin2
+ write(6,*)'READ_RADAR_L2RW: timemin,max =',timemin,timemax
+ write(6,*)'READ_RADAR_L2RW: errmin,max =',errmin,errmax
+ write(6,*)'READ_RADAR_L2RW: dlatmin,max,dlonmin,max=',dlatmin,dlatmax,dlonmin,dlonmax
! Write observation to scratch file
+ deallocate(rusage,rthin)
call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
- write(6,*) shape(cdata_all)
write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata)
deallocate(cdata_all)
if (radar_sites) deallocate(rtable,rsite,ruse)
deallocate(zl_thin)
- deallocate(isort)
return
end subroutine read_radar_l2rw
diff --git a/src/gsi/read_radar_wind_ascii.f90 b/src/gsi/read_radar_wind_ascii.f90
index 2e1b06a50c..b79904273e 100644
--- a/src/gsi/read_radar_wind_ascii.f90
+++ b/src/gsi/read_radar_wind_ascii.f90
@@ -120,12 +120,12 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg
use gridmod, only: regional,tll2xy,rotate_wind_ll2xy,nsig,nlat,nlon,&
fv3_regional
use obsmod, only: iadate, &
- mintiltvr,maxtiltvr,minobrangevr,maxobrangevr, rmesh_vr,zmesh_vr,&
+ mintiltvr,maxtiltvr,minobrangevr,maxobrangevr,rmesh_vr,zmesh_vr,pmot_vr,&
doradaroneob,oneoblat,oneoblon,oneobheight,oneobradid
- use obsmod,only: radar_no_thinning
+ use obsmod,only: radar_no_thinning,reduce_diag
use gsi_4dvar, only: l4dvar,time_4dvar
use convinfo, only: nconvtype,ctwind,icuse,ioctype
- use convthin, only: make3grids,map3grids,del3grids,use_all
+ use convthin, only: make3grids,map3grids_m,del3grids,use_all
use read_l2bufr_mod, only: invtllv
use qcmod, only: erradar_inflate
use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model
@@ -173,21 +173,19 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg
end type radar
!--Counters for diagnostics
- integer(i_kind) :: num_missing=0,numbadtime=0, & !counts
- num_badtilt=0,num_badrange=0, &
- ibadazm=0
+ integer(i_kind) :: num_missing=0,numbadtime=0, & !counts
+ num_badtilt=0,num_badrange=0, &
+ ibadazm=0
-integer(i_kind) :: ithin,zflag,nlevz,icntpnt,klon1,klat1,kk,klatp1,klonp1
-real(r_kind) :: rmesh,xmesh,zmesh,dx,dy,dx1,dy1,w00,w01,w10,w11
-real(r_kind), allocatable, dimension(:) :: zl_thin
+ integer(i_kind) :: ithin,zflag,nlevz,icntpnt,klon1,klat1,kk,klatp1,klonp1
+ real(r_kind) :: rmesh,xmesh,zmesh,dx,dy,dx1,dy1,w00,w01,w10,w11
+ real(r_kind), allocatable, dimension(:) :: zl_thin
real(r_kind),dimension(nsig):: hges,zges
real(r_kind) sin2,termg,termr,termrg,zobs,height
- integer(i_kind) ntmp,iout,iiout,ntdrvr_thin2
+ integer(i_kind) iout,ntdrvr_thin2
real(r_kind) crit1,timedif
real(r_kind),parameter:: r16000 = 16000.0_r_kind
-logical :: luse
- integer(i_kind) maxout,maxdata
- integer(i_kind),allocatable,dimension(:):: isort
+ logical :: luse
!--General declarations
integer(i_kind) :: ierror,lunrad,i,j,k,v,na,nb,nelv,nvol, &
@@ -201,12 +199,16 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg
real(r_kind) :: thistiltr,selev0,celev0,thisrange,this_stahgt,thishgt
real(r_kind) :: celev,selev,gamma,thisazimuthr,rlon0,t4dv, &
clat0,slat0,dlat,dlon,thiserr,thislon,thislat, &
- rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter
+ rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter
real(r_kind) :: azm,cosazm_earth,sinazm_earth,cosazm,sinazm
- real(r_kind) :: radartwindow
+ real(r_kind) :: radartwindow,usage
real(r_kind) :: rmins_an,rmins_ob
real(r_kind),allocatable,dimension(:,:):: cdata_all
real(r_double) rstation_id
+ logical, allocatable,dimension(:) :: rusage,rthin
+ logical save_all
+! integer(i_kind) numthin,numqc,numrem,numall
+ integer(i_kind) nxdata,pmot
character(8) cstaid
character(4) this_staid
@@ -217,7 +219,7 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg
type(radar),allocatable :: strct_in_vel(:,:)
-real(r_kind) :: mintilt,maxtilt,maxobrange,minobrange
+ real(r_kind) :: mintilt,maxtilt,maxobrange,minobrange
integer(i_kind) :: thin_freq=1
@@ -228,10 +230,10 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg
!-Check if radial velocity is in the convinfo file and extract necessary attributes
- ithin=1 !number of obs to keep per grid box
- if(radar_no_thinning) then
- ithin=-1
- endif
+ ithin=1 !number of obs to keep per grid box
+ if(radar_no_thinning) then
+ ithin=-1
+ endif
errmax=-huge(errmax)
errmin=huge(errmin)
@@ -241,13 +243,13 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg
if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then
ikx=i
radartwindow=ctwind(ikx)*r60 !Time window units converted to minutes
- ! (default setting for dbz within convinfo is 0.05 hours)
- thiserr= 2_r_kind !1.75_r_kind !2_r_kind !Ob error (m/s) to use for radial velocity
- exit !Exit loop when finished with initial convinfo fields
+ ! (default setting for dbz within convinfo is 0.05 hours)
+ thiserr= 2_r_kind !1.75_r_kind !2_r_kind !Ob error (m/s) to use for radial velocity
+ exit !Exit loop when finished with initial convinfo fields
else if ( i==nconvtype ) then
write(6,*) 'READ_RADAR_WIND_ASCII: ERROR - OBSERVATION TYPE IS NOT PRESENT IN CONVINFO OR USE FLAG IS ZERO'
- write(6,*) 'READ_RADAR_WIND_ASCII: ABORTING read_radar_wind_ascii.f90 - NO VELOCITY OBS READ!'
- return
+ write(6,*) 'READ_RADAR_WIND_ASCII: ABORTING read_radar_wind_ascii.f90 - NO VELOCITY OBS READ!'
+ return
endif
end do
@@ -266,22 +268,19 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg
!--Allocate cdata_all array
- allocate(cdata_all(maxdat,maxobs),isort(maxobs))
+ allocate(cdata_all(maxdat,maxobs),rusage(maxobs),rthin(maxobs))
rmesh=rmesh_vr
zmesh=zmesh_vr
- maxout=0
- maxdata=0
- isort=0
ntdrvr_thin2=0
icntpnt=0
zflag=0
use_all=.true.
- if (ithin > 0) then
- write(6,*)'READ_RADAR: ithin,rmesh :',ithin,rmesh
+ if (ithin == 1) then
+ write(6,*)'READ_RADAR: rmesh :',rmesh
use_all=.false.
if(zflag == 0)then
nlevz=nsig
@@ -306,8 +305,8 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg
iostat=ierror,form='formatted')
- fileopen: if (ierror == 0) then
- read(lunrad,'(2i8)') nelv,nvol !read number of elevations and number of volumes
+ fileopen: if (ierror == 0) then
+ read(lunrad,'(2i8)') nelv,nvol !read number of elevations and number of volumes
!*************************IMPORTANT***************************!
@@ -319,302 +318,304 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg
!------Begin processing--------------------------!
+ rusage = .true.
+ rthin = .false.
+ use_all=.true.
- !-Obtain analysis time in minutes since reference date
- call w3fs21(iadate,mins_an) !mins_an -integer number of mins snce 01/01/1978
- rmins_an=mins_an !convert to real number
-
- volumes: do v=1,nvol
-
- read(lunrad,'(i8)') nelv
- allocate(strct_in_vel(1,nelv))
- tilts: do k=1,nelv
-
- read(lunrad,'(a4)') strct_in_vel(1,k)%radid
- read(lunrad,'(i8)') strct_in_vel(1,k)%vcpnum
- read(lunrad,'(6i8)') strct_in_vel(1,k)%year &
- ,strct_in_vel(1,k)%month &
- ,strct_in_vel(1,k)%day &
- ,strct_in_vel(1,k)%hour &
- ,strct_in_vel(1,k)%minute &
- ,strct_in_vel(1,k)%second
- read(lunrad,'(2f10.3,f10.1)') strct_in_vel(1,k)%radlat &
- ,strct_in_vel(1,k)%radlon &
- ,strct_in_vel(1,k)%radhgt
- read(lunrad,'(2f8.1)') strct_in_vel(1,k)%fstgatdis &
- ,strct_in_vel(1,k)%gateWidth
- read(lunrad,'(f8.3)') strct_in_vel(1,k)%elev_angle
- read(lunrad,'(2i8)') strct_in_vel(1,k)%num_beam &
- ,strct_in_vel(1,k)%num_gate
- na=strct_in_vel(1,k)%num_beam
- nb=strct_in_vel(1,k)%num_gate
-
- !******allocate arrays within radar data type**********!
- allocate(strct_in_vel(1,k)%azim(na))
- allocate(strct_in_vel(1,k)%field(nb,na))
- !******************************************************!
+ !-Obtain analysis time in minutes since reference date
+
+ call w3fs21(iadate,mins_an) !mins_an -integer number of mins snce 01/01/1978
+ rmins_an=mins_an !convert to real number
- read(lunrad,'(f8.3)') strct_in_vel(1,k)%nyq_vel
- read(lunrad,'(15f6.1)') (strct_in_vel(1,k)%azim(j),j=1,na)
- read(lunrad,'(20f6.1)') ((strct_in_vel(1,k)%field(i,j),i=1,nb),j=1,na)
-
-
- obdate(1)=strct_in_vel(1,k)%year
- obdate(2)=strct_in_vel(1,k)%month
- obdate(3)=strct_in_vel(1,k)%day
- obdate(4)=strct_in_vel(1,k)%hour
- obdate(5)=strct_in_vel(1,k)%minute
- call w3fs21(obdate,mins_ob) !mins_ob -integer number of mins snce 01/01/1978
- rmins_ob=mins_ob !convert to real number
- rmins_ob=rmins_ob+(strct_in_vel(1,k)%second*r60inv) !convert seconds to minutes and add to ob time
-
- !-Comparison is done in units of minutes
-
- timeb = rmins_ob-rmins_an
+ volumes: do v=1,nvol
+
+ read(lunrad,'(i8)') nelv
+ allocate(strct_in_vel(1,nelv))
+ tilts: do k=1,nelv
+
+ read(lunrad,'(a4)') strct_in_vel(1,k)%radid
+ read(lunrad,'(i8)') strct_in_vel(1,k)%vcpnum
+ read(lunrad,'(6i8)') strct_in_vel(1,k)%year &
+ ,strct_in_vel(1,k)%month &
+ ,strct_in_vel(1,k)%day &
+ ,strct_in_vel(1,k)%hour &
+ ,strct_in_vel(1,k)%minute &
+ ,strct_in_vel(1,k)%second
+ read(lunrad,'(2f10.3,f10.1)') strct_in_vel(1,k)%radlat &
+ ,strct_in_vel(1,k)%radlon &
+ ,strct_in_vel(1,k)%radhgt
+ read(lunrad,'(2f8.1)') strct_in_vel(1,k)%fstgatdis &
+ ,strct_in_vel(1,k)%gateWidth
+ read(lunrad,'(f8.3)') strct_in_vel(1,k)%elev_angle
+ read(lunrad,'(2i8)') strct_in_vel(1,k)%num_beam &
+ ,strct_in_vel(1,k)%num_gate
+ na=strct_in_vel(1,k)%num_beam
+ nb=strct_in_vel(1,k)%num_gate
+
+ !******allocate arrays within radar data type**********!
+ allocate(strct_in_vel(1,k)%azim(na))
+ allocate(strct_in_vel(1,k)%field(nb,na))
+ !******************************************************!
+
+ read(lunrad,'(f8.3)') strct_in_vel(1,k)%nyq_vel
+ read(lunrad,'(15f6.1)') (strct_in_vel(1,k)%azim(j),j=1,na)
+ read(lunrad,'(20f6.1)') ((strct_in_vel(1,k)%field(i,j),i=1,nb),j=1,na)
+
+
+ obdate(1)=strct_in_vel(1,k)%year
+ obdate(2)=strct_in_vel(1,k)%month
+ obdate(3)=strct_in_vel(1,k)%day
+ obdate(4)=strct_in_vel(1,k)%hour
+ obdate(5)=strct_in_vel(1,k)%minute
+ call w3fs21(obdate,mins_ob) !mins_ob -integer number of mins snce 01/01/1978
+ rmins_ob=mins_ob !convert to real number
+ rmins_ob=rmins_ob+(strct_in_vel(1,k)%second*r60inv) !convert seconds to minutes and add to ob time
+
+ !-Comparison is done in units of minutes
+
+ timeb = rmins_ob-rmins_an
- if(doradaroneob .and. (oneobradid /= strct_in_vel(1,k)%radid)) cycle tilts
+ if(doradaroneob .and. (oneobradid /= strct_in_vel(1,k)%radid)) cycle tilts
- if(abs(timeb) > abs(radartwindow)) then
- numbadtime=numbadtime+1
- cycle tilts !If not in time window, cycle the loop
- end if
- !--Time window check complete--!
+ if(abs(timeb) > abs(radartwindow)) then
+ numbadtime=numbadtime+1
+ cycle tilts !If not in time window, cycle the loop
+ end if
+ !--Time window check complete--!
- thistilt=strct_in_vel(1,k)%elev_angle
- if (thistilt <= maxtilt .and. thistilt >= mintilt) then
-
- gates: do i=1,strct_in_vel(1,k)%num_gate,thin_freq
- thisrange=strct_in_vel(1,k)%fstgatdis + float(i-1)*strct_in_vel(1,k)%gateWidth
-
- !-Check to make sure observations are within specified range
-
- if (thisrange <= maxobrange .and. thisrange >= minobrange) then
-
- azms: do j=1,strct_in_vel(1,k)%num_beam
-
- !-Check to see if this is a missing observation)
- nread=nread+1
- if ( strct_in_vel(1,k)%field(i,j) >= 999.0_r_kind ) then
- num_missing=num_missing+1
- cycle azms !No reason to process the ob if it is missing
- end if
-
- !--Find observation height using method from read_l2bufr_mod.f90
-
- this_stahgt=strct_in_vel(1,k)%radhgt
- aactual=rearth+this_stahgt
- a43=four_thirds*aactual
+ thistilt=strct_in_vel(1,k)%elev_angle
+ if (thistilt <= maxtilt .and. thistilt >= mintilt) then
+
+ gates: do i=1,strct_in_vel(1,k)%num_gate,thin_freq
+ thisrange=strct_in_vel(1,k)%fstgatdis + real(i-1,r_kind)*strct_in_vel(1,k)%gateWidth
+
+ !-Check to make sure observations are within specified range
+
+ if (thisrange <= maxobrange .and. thisrange >= minobrange) then
+
+ azms: do j=1,strct_in_vel(1,k)%num_beam
+
+ !-Check to see if this is a missing observation)
+ nread=nread+1
+ if ( strct_in_vel(1,k)%field(i,j) >= 999.0_r_kind ) then
+ num_missing=num_missing+1
+ cycle azms !No reason to process the ob if it is missing
+ end if
+
+ !--Find observation height using method from read_l2bufr_mod.f90
+
+ this_stahgt=strct_in_vel(1,k)%radhgt
+ aactual=rearth+this_stahgt
+ a43=four_thirds*aactual
thistiltr=thistilt*deg2rad
selev0=sin(thistiltr)
- celev0=cos(thistiltr)
- b=thisrange*(thisrange+two*aactual*selev0)
+ celev0=cos(thistiltr)
+ b=thisrange*(thisrange+two*aactual*selev0)
c=sqrt(aactual*aactual+b)
ha=b/(aactual+c)
epsh=(thisrange*thisrange-ha*ha)/(r8*aactual)
h=ha-epsh
- thishgt=this_stahgt+h
+ thishgt=this_stahgt+h
height=thishgt
- !--Find observation location using method from read_l2bufr_mod.f90
-
- !-Get corrected tilt angle
- celev=celev0
- selev=selev0
- celev=a43*celev0/(a43+h)
- selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h))
-
- gamma=half*thisrange*(celev0+celev)
-
+ !--Find observation location using method from read_l2bufr_mod.f90
+
+ !-Get corrected tilt angle
+ celev=celev0
+ selev=selev0
+ celev=a43*celev0/(a43+h)
+ selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h))
+
+ gamma=half*thisrange*(celev0+celev)
+
!-Get earth lat lon of observation
-
+
rlon0=deg2rad*strct_in_vel(1,k)%radlon
- clat0=cos(deg2rad*strct_in_vel(1,k)%radlat)
- slat0=sin(deg2rad*strct_in_vel(1,k)%radlat)
- thisazimuthr=(90.0_r_kind-strct_in_vel(1,k)%azim(j))*deg2rad !Storing as 90-azm to
- ! be consistent with
- ! read_l2bufr_mod.f90
- rad_per_meter=one/rearth
- rlonloc=rad_per_meter*gamma*cos(thisazimuthr)
+ clat0=cos(deg2rad*strct_in_vel(1,k)%radlat)
+ slat0=sin(deg2rad*strct_in_vel(1,k)%radlat)
+ thisazimuthr=(90.0_r_kind-strct_in_vel(1,k)%azim(j))*deg2rad !Storing as 90-azm to
+ ! be consistent with
+ ! read_l2bufr_mod.f90
+ rad_per_meter=one/rearth
+ rlonloc=rad_per_meter*gamma*cos(thisazimuthr)
rlatloc=rad_per_meter*gamma*sin(thisazimuthr)
-
- call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob)
+
+ call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob)
- thislat=rlatglob*rad2deg
+ thislat=rlatglob*rad2deg
thislon=rlonglob*rad2deg
- if(doradaroneob) then
- thislat=oneoblat
- thislon=oneoblon
- thishgt=oneobheight
- endif
+ if(doradaroneob) then
+ thislat=oneoblat
+ thislon=oneoblon
+ thishgt=oneobheight
+ endif
- if(thislon>=r360) thislon=thislon-r360
- if(thislon=r360) thislon=thislon-r360
+ if(thislonzero) errmin=min(error,errmin)
- if(abs(azm)>r400) then
- ibadazm=ibadazm+1
- cycle azms
- end if
-
- this_staid=strct_in_vel(1,k)%radid !Via equivalence in declaration, value is propagated
- ! to rstation_id used below.
-
- ! Get model terrain at radar station location
- ! If radar station is outside of grid, does not mean the
- ! radar obs are outside the grid - therefore no need to
- ! cycle azms.
-
- radar_lon=deg2rad*strct_in_vel(1,k)%radlon
- radar_lat=deg2rad*strct_in_vel(1,k)%radlat
- call tll2xy(radar_lon,radar_lat,dlon_radar,dlat_radar,outside)
- call deter_zsfc_model(dlat_radar,dlon_radar,zsges)
-
- ! Determines land surface type based on surrounding land
- ! surface types
+ if(regional .and. .not. fv3_regional) then
+ cosazm_earth=cos(thisazimuthr)
+ sinazm_earth=sin(thisazimuthr)
+ call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,thislon,dlon,dlat)
+ azm=atan2(sinazm,cosazm)
+ else
+ azm=thisazimuthr
+ end if
+
+ !--Do limited QC from read_radar.f90--!
+ error = erradar_inflate*thiserr
+ errmax=max(error,errmax)
+ if(thiserr>zero) errmin=min(error,errmin)
+ if(abs(azm)>r400) then
+ ibadazm=ibadazm+1
+ cycle azms
+ end if
+
+ this_staid=strct_in_vel(1,k)%radid !Via equivalence in declaration, value is propagated
+ ! to rstation_id used below.
+
+ ! Get model terrain at radar station location
+ ! If radar station is outside of grid, does not mean the
+ ! radar obs are outside the grid - therefore no need to
+ ! cycle azms.
+
+ radar_lon=deg2rad*strct_in_vel(1,k)%radlon
+ radar_lat=deg2rad*strct_in_vel(1,k)%radlat
+ call tll2xy(radar_lon,radar_lat,dlon_radar,dlat_radar,outside)
+ call deter_zsfc_model(dlat_radar,dlon_radar,zsges)
+
+ ! Determines land surface type based on surrounding land
+ ! surface types
- t4dv=timeb*r60inv
-
- call deter_sfc2(thislat,thislon,t4dv,idomsfc,skint,ff10,sfcr)
-
-
+ t4dv=timeb*r60inv
+
+ call deter_sfc2(thislat,thislon,t4dv,idomsfc,skint,ff10,sfcr)
!#################### Data thinning ###################
- icntpnt=icntpnt+1
-
- if(ithin > 0)then
- if(zflag == 0)then
- klon1= int(dlon); klat1= int(dlat)
- dx = dlon-klon1; dy = dlat-klat1
- dx1 = one-dx; dy1 = one-dy
- w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy
+ icntpnt=icntpnt+1
+ if(icntpnt>maxobs) exit
+ pmot=pmot_vr
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
+
+ usage = zero
+ if(abs(icuse(ikx)) /= 1)usage=r100
- klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon)
- if (klon1==0) klon1=nlon
- klatp1=min(nlat,klat1+1); klonp1=klon1+1
- if (klonp1==nlon+1) klonp1=1
- do kk=1,nsig
- hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) + &
- w10*hgtl_full(klatp1,klon1 ,kk) + &
- w01*hgtl_full(klat1 ,klonp1,kk) + &
- w11*hgtl_full(klatp1,klonp1,kk)
- end do
- sin2 = sin(thislat)*sin(thislat)
- termg = grav_equator * &
- ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2))
- termr = semi_major_axis /(one + flattening + grav_ratio - &
- two*flattening*sin2)
- termrg = (termg/grav)*termr
- do kk=1,nsig
- zges(kk) = (termr*hges(kk)) / (termrg-hges(kk))
- zl_thin(kk)=zges(kk)
- end do
- endif
-
- zobs = height
-
- ntmp=ndata ! counting moved to map3gridS
- if (l4dvar) then
- timedif = zero
- else
+ if(ithin == 1)then
+ if(zflag == 0)then
+ klon1= int(dlon); klat1= int(dlat)
+ dx = dlon-klon1; dy = dlat-klat1
+ dx1 = one-dx; dy1 = one-dy
+ w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy
+
+ klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon)
+ if (klon1==0) klon1=nlon
+ klatp1=min(nlat,klat1+1); klonp1=klon1+1
+ if (klonp1==nlon+1) klonp1=1
+ do kk=1,nsig
+ hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) + &
+ w10*hgtl_full(klatp1,klon1 ,kk) + &
+ w01*hgtl_full(klat1 ,klonp1,kk) + &
+ w11*hgtl_full(klatp1,klonp1,kk)
+ end do
+ sin2 = sin(thislat)*sin(thislat)
+ termg = grav_equator * &
+ ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2))
+ termr = semi_major_axis /(one + flattening + grav_ratio - &
+ two*flattening*sin2)
+ termrg = (termg/grav)*termr
+ do kk=1,nsig
+ zges(kk) = (termr*hges(kk)) / (termrg-hges(kk))
+ zl_thin(kk)=zges(kk)
+ end do
+ endif
+
+ zobs = height
+
+ if (l4dvar) then
+ timedif = zero
+ else
! timedif=abs(t4dv-toff)
- timedif=abs(t4dv) !don't know about this
- endif
- crit1 = timedif/r6+half
+ timedif=abs(t4dv) !don't know about this
+ endif
+ crit1 = timedif/r6+half
- call map3grids(1,zflag,zl_thin,nlevz,thislat,thislon,&
- zobs,crit1,ndata,iout,icntpnt,iiout,luse, .false., .false.)
- maxout=max(maxout,iout)
- maxdata=max(maxdata,ndata)
-
- if (.not. luse) then
- ntdrvr_thin2=ntdrvr_thin2+1
- cycle
- endif
- if(iiout > 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+1
- endif
- isort(icntpnt)=iout
-
- else
- ndata =ndata+1
- nodata=nodata+1
- iout=ndata
- isort(icntpnt)=iout
- endif
-
- cdata_all(1,iout) = error ! wind obs error (m/s)
- cdata_all(2,iout) = dlon ! grid relative longitude
- cdata_all(3,iout) = dlat ! grid relative latitude
- cdata_all(4,iout) = thishgt ! obs absolute height (m)
- cdata_all(5,iout) = strct_in_vel(1,k)%field(i,j) ! wind obs (m/s)
- cdata_all(6,iout) = azm ! azimuth angle (radians)
- cdata_all(7,iout) = t4dv ! obs time (hour) - analysis relative
- cdata_all(8,iout) = ikx ! type
- cdata_all(9,iout) = thistiltr ! tilt angle (radians)
- cdata_all(10,iout)= this_stahgt ! station elevation (m)
- cdata_all(11,iout)= rstation_id ! station id
- cdata_all(12,iout)= icuse(ikx) ! usage parameter
- cdata_all(13,iout)= idomsfc ! dominate surface type
- cdata_all(14,iout)= skint ! skin temperature
- cdata_all(15,iout)= ff10 ! 10 meter wind factor
- cdata_all(16,iout)= sfcr ! surface roughness
- cdata_all(17,iout)=thislon*rad2deg ! earth relative longitude (degrees)
- cdata_all(18,iout)=thislat*rad2deg ! earth relative latitude (degrees)
- cdata_all(19,iout)=thisrange/1000_r_kind ! range from radar in km (used to estimate beam spread)
- cdata_all(20,iout)=zsges ! model elevation at radar site
- cdata_all(21,iout)=thiserr
- cdata_all(22,iout)=two ! Level 2 data
-
- if(doradaroneob .and. (cdata_all(5,iout) > -99_r_kind) ) exit volumes
-
- end do azms !j
- else
- num_badrange=num_badrange+1 !If outside acceptable range, increment
- end if !Range check
-
- end do gates !i
+ call map3grids_m(1,save_all,zflag,zl_thin,nlevz, &
+ thislat,thislon,zobs,crit1,ndata,&
+ luse,maxobs,rthin,.false.,.false.)
+
+ if (.not. luse) then
+ ntdrvr_thin2=ntdrvr_thin2+1
+ cycle
+ endif
+
+ else
+ ndata =ndata+1
+ endif
+ iout=ndata
+
+ cdata_all(1,iout) = error ! wind obs error (m/s)
+ cdata_all(2,iout) = dlon ! grid relative longitude
+ cdata_all(3,iout) = dlat ! grid relative latitude
+ cdata_all(4,iout) = thishgt ! obs absolute height (m)
+ cdata_all(5,iout) = strct_in_vel(1,k)%field(i,j) ! wind obs (m/s)
+ cdata_all(6,iout) = azm ! azimuth angle (radians)
+ cdata_all(7,iout) = t4dv ! obs time (hour) - analysis relative
+ cdata_all(8,iout) = ikx ! type
+ cdata_all(9,iout) = thistiltr ! tilt angle (radians)
+ cdata_all(10,iout)= this_stahgt ! station elevation (m)
+ cdata_all(11,iout)= rstation_id ! station id
+ cdata_all(12,iout)= icuse(ikx) ! usage parameter
+ cdata_all(13,iout)= idomsfc ! dominate surface type
+ cdata_all(14,iout)= skint ! skin temperature
+ cdata_all(15,iout)= ff10 ! 10 meter wind factor
+ cdata_all(16,iout)= sfcr ! surface roughness
+ cdata_all(17,iout)=thislon*rad2deg ! earth relative longitude (degrees)
+ cdata_all(18,iout)=thislat*rad2deg ! earth relative latitude (degrees)
+ cdata_all(19,iout)=thisrange/1000._r_kind ! range from radar in km (used to estimate beam spread)
+ cdata_all(20,iout)=zsges ! model elevation at radar site
+ cdata_all(21,iout)=thiserr
+ cdata_all(22,iout)=two ! Level 2 data
+
+ if(doradaroneob .and. (cdata_all(5,iout) > -99_r_kind) ) exit volumes
+ if(usage >= r100)rusage(iout)=.false.
+
+ end do azms !j
+ else
+ num_badrange=num_badrange+1 !If outside acceptable range, increment
+ end if !Range check
+
+ end do gates !i
- else
- num_badtilt=num_badtilt+1 !If outside acceptable tilts, increment
- end if !Tilt check
+ else
+ num_badtilt=num_badtilt+1 !If outside acceptable tilts, increment
+ end if !Tilt check
- end do tilts !k
+ end do tilts !k
- do k=1,nelv
- deallocate(strct_in_vel(1,k)%azim)
- deallocate(strct_in_vel(1,k)%field)
- enddo
- deallocate(strct_in_vel)
+ do k=1,nelv
+ deallocate(strct_in_vel(1,k)%azim)
+ deallocate(strct_in_vel(1,k)%field)
+ enddo
+ deallocate(strct_in_vel)
end do volumes !v
close(lunrad) !modified to do one scan at a time
@@ -625,6 +626,55 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg
endif
!end modified for thinning
+
+ nxdata=ndata
+ ndata=0
+ if(nxdata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,nxdata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' asciiradar ',trim(ioctype(ikx)),ikx,numall,&
+! numrem,numqc,numthin
+! If thinned data set quality mark to 14
+ if (ithin == 1 ) then
+ do i=1,nxdata
+ if(rthin(i))cdata_all(12,i)=101._r_kind
+ end do
+ end if
+
+! If flag to not save thinned data is set - compress data
+ if(pmot /= 1)then
+ do i=1,nxdata
+
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ ndata=ndata+1
+ if(i > ndata)then
+ do k=1,maxdat
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
+ end if
+ end do
+ end if
+ end if
+ nodata=nodata+ndata
+
!---all looping done now print diagnostic output
write(6,*)'READ_RADAR_WIND_ASCII: Reached eof on radar wind ascii file'
@@ -644,12 +694,13 @@ subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hg
!---------------DEALLOCATE ARRAYS-------------!
- deallocate(cdata_all)
else !fileopen
- write(6,*) 'READ_RADAR_WIND_ASCII: ERROR OPENING RADIAL VELOCITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...'
+ write(6,*) 'READ_RADAR_WIND_ASCII: ERROR OPENING RADIAL VELOCITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...'
end if fileopen
+ deallocate(cdata_all,rusage,rthin)
+
end subroutine read_radar_wind_ascii
diff --git a/src/gsi/read_rapidscat.f90 b/src/gsi/read_rapidscat.f90
index c952383df0..f1fffd43a8 100644
--- a/src/gsi/read_rapidscat.f90
+++ b/src/gsi/read_rapidscat.f90
@@ -43,16 +43,16 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
use gridmod, only: diagnostic_reg,regional,nlon,nlat,nsig,&
tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,&
rlats,rlons,fv3_regional
- use qcmod, only: errormod,noiqc
- use convthin, only: make3grids,map3grids,del3grids,use_all
+ use qcmod, only: errormod
+ use convthin, only: make3grids,map3grids_m,del3grids,use_all
use constants, only: deg2rad,zero,rad2deg,one_tenth,&
tiny_r_kind,huge_r_kind,r60inv,one_tenth,&
one,two,three,four,five,half,quarter,r60inv,r10,r100,r2000
! use converr,only: etabl
- use obsmod, only: ran01dom,bmiss
+ use obsmod, only: ran01dom,bmiss,reduce_diag
use convinfo, only: nconvtype, &
icuse,ictype,icsubtype,ioctype, &
- ithin_conv,rmesh_conv,pmesh_conv
+ ithin_conv,rmesh_conv,pmesh_conv,pmot_conv
use gsi_4dvar, only: l4dvar,iwinbgn,winlen,time_4dvar,l4densvar,thin4d
use deter_sfc_mod, only: deter_sfc_type,deter_sfc2
use mpimod, only: npe
@@ -107,13 +107,12 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
integer(i_kind) ireadmg,ireadsb,iuse,mxtb,nmsgmax
integer(i_kind) i,maxobs,idomsfc,nsattype
- integer(i_kind) nc,nx,isflg,itx,nchanl
+ integer(i_kind) nc,nx,isflg,nchanl
integer(i_kind) ntb,ntmatch,ncx,ncsave,ntread
integer(i_kind) kk,klon1,klat1,klonp1,klatp1
integer(i_kind) nmind,lunin,idate,ilat,ilon,iret,k
- integer(i_kind) nreal,ithin,iout,ntmp,icount,iiout,ii
+ integer(i_kind) nreal,ithin,iout,ii
integer(i_kind) itype,iosub,ixsub,isubsub,iobsub
- integer(i_kind) lim_qm
integer(i_kind) nlevp ! vertical level for thinning
integer(i_kind) pflag
integer(i_kind) ntest,nvtest
@@ -127,7 +126,7 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
integer(i_kind),dimension(nconvtype+1) :: ntx
integer(i_kind),dimension(5):: idate5
- integer(i_kind),allocatable,dimension(:):: isort,iloc,nrep
+ integer(i_kind),allocatable,dimension(:):: nrep
integer(i_kind),allocatable,dimension(:,:)::tab
integer(i_kind) ietabl,itypex,lcount,iflag,m
@@ -135,14 +134,14 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
real(r_single),allocatable,dimension(:,:,:) :: etabl
real(r_kind) toff,t4dv
- real(r_kind) rmesh,ediff,usage,tdiff
+ real(r_kind) rmesh,ediff,tdiff
real(r_kind) u0,v0,uob,vob,dx,dy,dx1,dy1,w00,w10,w01,w11
real(r_kind) dlnpob,ppb,ppb2,qifn,qify,ee
real(r_kind) woe,dlat,dlon,dlat_earth,dlon_earth,oelev
real(r_kind) dlat_earth_deg,dlon_earth_deg
real(r_kind) cdist,disterr,disterrmax,rlon00,rlat00
real(r_kind) vdisterrmax,u00,v00,uob1,vob1
- real(r_kind) del,werrmin,obserr,ppb1
+ real(r_kind) del,werrmin,obserr,ppb1,usage
real(r_kind) tsavg,ff10,sfcr,sstime,gstime,zz
real(r_kind) crit1,timedif,xmesh,pmesh
real(r_kind),dimension(nsig):: presl
@@ -156,7 +155,11 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
real(r_double),dimension(1,1):: r_prvstg,r_sprvstg
real(r_kind),allocatable,dimension(:):: presl_thin
real(r_kind),allocatable,dimension(:,:):: cdata_all
- real(r_kind),allocatable,dimension(:,:):: cdata_out
+
+ logical,allocatable,dimension(:)::rthin,rusage
+ logical save_all
+! integer(i_kind) numthin,numqc,numrem,numall
+ integer(i_kind) nxdata,pmot
! equivalence to handle character names
equivalence(r_prvstg(1,1),c_prvstg)
@@ -213,11 +216,6 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
werrmin=one
nsattype=0
nreal=23
- if (noiqc) then
- lim_qm=8
- else
- lim_qm=4
- endif
! ** read convtype from convinfo file
! ** only read in rapidsat 296 for now **
@@ -252,7 +250,7 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
call getcount_bufr(infile,nmsgmax,mxtb)
- allocate(lmsg(nmsgmax,ntread),tab(mxtb,3),nrep(nmsgmax))
+ allocate(lmsg(nmsgmax,ntread),tab(mxtb,2),nrep(nmsgmax))
lmsg = .false.
maxobs=0
@@ -332,16 +330,13 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
end if
tab(ntb,1)=ncsave
tab(ntb,2)=nx
- tab(ntb,3)=1
lmsg(nmsg,nx) = .true.
end if
enddo loop_report
enddo msg_report
! Loop over convinfo file entries; operate on matches
- allocate(cdata_all(nreal,maxobs),isort(maxobs))
- isort = 0
- cdata_all=zero
+ allocate(cdata_all(nreal,maxobs),rusage(maxobs),rthin(maxobs))
nread=0
ntest=0
nvtest=0
@@ -352,6 +347,8 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
!! read satellite winds one type a time
! same as in the read_prepbufr.f90 file
+ rusage = .true.
+ rthin = .false.
loop_convinfo: do nx=1,ntread
use_all = .true.
ithin=0
@@ -397,6 +394,17 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
ntb = 0
nmsg = 0
+ if(nx == 1)then
+ pmot=0
+ else
+ nc=ntx(nx)
+ pmot=nint(pmot_conv(nc))
+ end if
+ if(pmot < 2 .and. reduce_diag)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
+ use_all=.true.
+
loop_msg: do while(ireadmg(lunin,subset,idate) == 0)
nmsg = nmsg+1
if(.not.lmsg(nmsg,nx)) then
@@ -547,7 +555,7 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
obserr=(one-del)*etabl(itype,k1,4)+del*etabl(itype,k2,4)
obserr=max(obserr,werrmin)
! Set usage variable
- usage = 0
+ usage = zero
iuse=icuse(nc)
if(iuse <= 0)usage=r100
@@ -584,7 +592,6 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
! Special block for data thinning - if requested
if (ithin > 0 .and. iuse >=0) then
- ntmp=ndata ! counting moved to map3gridS
! Set data quality index for thinning
if (thin4d) then
@@ -601,22 +608,16 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
end do
endif
- call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
- ppb,crit1,ndata,iout,ntb,iiout,luse,.false.,.false.)
+ call map3grids_m(-1,save_all,pflag,presl_thin,nlevp, &
+ dlat_earth,dlon_earth,ppb,crit1,ndata,&
+ luse,maxobs,rthin,.false.,.false.)
if (.not. luse) cycle loop_readsb
- if(iiout > 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+2
- endif
- isort(ntb)=iout
else
ndata=ndata+1
- nodata=nodata+2
- iout=ndata
- isort(ntb)=iout
endif
+ iout=ndata
woe=obserr
oelev=r10
@@ -659,6 +660,7 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
cdata_all(21,iout)=zz ! terrain height at ob location
cdata_all(22,iout)=r_prvstg(1,1) ! provider name
cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name
+ if(usage >= r100)rusage(ndata)=.false.
enddo loop_readsb
@@ -675,35 +677,57 @@ subroutine read_rapidscat(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,
call closbf(lunin)
! Write header record and data to output file for further processing
- allocate(iloc(ndata))
- icount=0
- do i=1,maxobs
- if(isort(i) > 0)then
- icount=icount+1
- iloc(icount)=isort(i)
- end if
- end do
- if(ndata /= icount)then
- write(6,*) ' READ_RAPIDSCAT: mix up in read_satwnd ,ndata,icount ',ndata,icount
- call stop2(49)
- end if
- allocate(cdata_out(nreal,ndata))
- do i=1,ndata
- itx=iloc(i)
- do k=1,nreal
- cdata_out(k,i)=cdata_all(k,itx)
- end do
- end do
- deallocate(iloc,isort,cdata_all)
deallocate(etabl)
-
+ nxdata=ndata
+ ndata=0
+ if(nxdata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,nxdata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' rapid ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin
+! If thinned data set usage
+ do i=1,nxdata
+ if(rthin(i))then
+ cdata_all(14,i)=100._r_kind
+ cdata_all(12,i)=14
+ end if
+ end do
+! If flag to not save thinned data is set - compress data
+ do i=1,nxdata
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 1) .or. &
+ (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ ndata=ndata+1
+ do k=1,nreal
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
+ end do
+ end if
+ nodata=nodata+ndata
+ deallocate(rusage,rthin)
- call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs)
+ call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
- write(lunout) cdata_out
+ write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata)
+
+ deallocate(cdata_all)
- deallocate(cdata_out)
-900 continue
if(diagnostic_reg .and. ntest>0) write(6,*)'READ_RAPIDSCAT: ',&
'ntest,disterrmax=',ntest,disterrmax
if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_RAPIDSCAT: ',&
diff --git a/src/gsi/read_saphir.f90 b/src/gsi/read_saphir.f90
index 3547f2cf5c..06e992b03d 100644
--- a/src/gsi/read_saphir.f90
+++ b/src/gsi/read_saphir.f90
@@ -360,10 +360,10 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,&
! compute look angle (panglr) and check against max angle
-! panglr=(start+float(ifov-1)*step)*deg2rad
+! panglr=(start+real(ifov-1,r_kind)*step)*deg2rad
! Use this calculation for now:
step = .6660465
- panglr = (42.96 - float(ifov-1)*step)*deg2rad
+ panglr = (42.96 - real(ifov-1,r_kind)*step)*deg2rad
if(abs(lza)*rad2deg > MAX_SENSOR_ZENITH_ANGLE) then
write(6,*)'READ_SAPHIR WARNING lza error ',lza,panglr
@@ -508,7 +508,7 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,&
- crit1 = crit1 + rlndsea(isflg) + 10._r_kind*float(iskip) + 0.01_r_kind * abs(zz)
+ crit1 = crit1 + rlndsea(isflg) + 10._r_kind*real(iskip,r_kind) + 0.01_r_kind * abs(zz)
call checkob(dist1,crit1,itx,iuse)
if(.not. iuse)cycle ObsLoop
@@ -529,10 +529,10 @@ subroutine read_saphir(mype,val_tovs,ithin,isfcalc,&
endif
! Re-calculate look angle
-! panglr=(start+float(ifov-1)*step)*deg2rad
+! panglr=(start+real(ifov-1,r_kind)*step)*deg2rad
! Use this calculation for now:
step = .6660465
- panglr = (42.96 - float(ifov-1)*step)*deg2rad
+ panglr = (42.96 - real(ifov-1,r_kind)*step)*deg2rad
! Load selected observation into data array
diff --git a/src/gsi/read_satmar.f90 b/src/gsi/read_satmar.f90
index 673872e308..e9062a65f6 100644
--- a/src/gsi/read_satmar.f90
+++ b/src/gsi/read_satmar.f90
@@ -70,9 +70,11 @@ subroutine read_satmar (nread, ndata, nodata, &
use gridmod, only: regional, rlats,rlons,nlat,nlon,txy2ll,tll2xy, &
twodvar_regional
use satthin, only: map2tgrid,destroygrids,makegrids
- use convinfo, only: ithin_conv,rmesh_conv,nconvtype,icuse,ictype,ioctype,ctwind
- use convthin, only: make3grids,use_all,map3grids,del3grids
- use obsmod, only: bmiss,hilbert_curve
+ use convinfo, only: ithin_conv,rmesh_conv,nconvtype,icuse,ictype,ioctype,ctwind, &
+ pmot_conv
+! use convinfo, only: icsubtype
+ use convthin, only: make3grids,use_all,map3grids_m,del3grids
+ use obsmod, only: bmiss,hilbert_curve,reduce_diag
use mpimod, only: npe
implicit none
@@ -98,15 +100,14 @@ subroutine read_satmar (nread, ndata, nodata, &
real (r_kind),parameter :: r6 = 6.0_r_kind
real (r_kind),parameter :: dflt_err = 0.2_r_kind
!
- integer(i_kind) :: tot,cnt,cnt1,k,ntmp,iout,iiout
+ integer(i_kind) :: tot,cnt,cnt1,k,iout,i
integer(i_kind) :: ireadmg,ireadsb,idate
integer(i_kind) :: iRec,ierr,nc,i1,ilat,ilon,nchanl,nlevp,indsat
integer(i_kind) :: nmind, nrec
integer(i_kind) :: thisobtype_usage, iuse
! real
- real(r_kind),allocatable,dimension(:, :) :: data_all,data_out
+ real(r_kind),allocatable,dimension(:, :) :: data_all
real(r_kind),allocatable,dimension(:):: DumForThin
- integer(i_kind),allocatable,dimension(:):: isort,iloc
! real(r_kind),allocatable,dimension(: ) :: data_1d
real(r_kind) :: dlon,dlat
real(r_kind) :: tdiff,crit1,timedif,toff
@@ -171,6 +172,11 @@ subroutine read_satmar (nread, ndata, nodata, &
integer(i_kind),parameter :: howvRatMiuSigma = 3
integer(i_kind),parameter :: howvRathowvDpth = 2
real(r_kind),parameter :: howvDistm = 10000.0_r_kind
+ logical,allocatable,dimension(:)::rthin,rusage
+ logical save_all
+! integer(i_kind) numthin,numqc,numrem,numall
+ integer(i_kind) nxdata,pmot
+
!
! call init_constants_derived
lhilbert = twodvar_regional .and. hilbert_curve
@@ -203,9 +209,9 @@ subroutine read_satmar (nread, ndata, nodata, &
end if
!
! *#* Thinning *#*!
- use_all = .true.
- ithin=ithin_conv(nc)
- if (ithin > 0 ) then
+ use_all = .true.
+ ithin=ithin_conv(nc)
+ if (ithin > 0 ) then
rmesh=rmesh_conv(nc)
use_all = .false.
nlevp=1 !Dummy for using make3grids
@@ -214,7 +220,7 @@ subroutine read_satmar (nread, ndata, nodata, &
call make3grids(xmesh,nlevp)
write(6,'(A,1x,A,1x,A,I4,1x,f8.2,1x,I3,1x,I3)')myname,': ioctype(nc),ictype(nc),rmesh,nlevp,nc ',&
trim(ioctype(nc)),ictype(nc),rmesh,nlevp,nc
- endif
+ endif
!
! *#* Main - Start *#*!
open(lun11,file=trim(infile),action='read',form='unformatted', iostat=ierr)
@@ -236,13 +242,19 @@ subroutine read_satmar (nread, ndata, nodata, &
close(lun11)
!
! Allocate Arrays for all the data
- allocate (data_all (nreal, cnt),isort(cnt))
- isort = 0
+ allocate (data_all (nreal, cnt),rusage(cnt),rthin(cnt))
!
! Loop over file
open(lun11,file=trim(infile),action='read',form='unformatted')
call openbf(lun11,'IN',lun11)
call datelen(dtLen)
+ pmot=nint(pmot_conv(nc))
+ if(pmot < 2 .and. reduce_diag)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
+ rusage = .true.
+ rthin = .false.
+ use_all=.true.
!
read_msg: do while(ireadmg(lun11,subset,idate) == 0)
do i1 = 1,nosat
@@ -394,7 +406,6 @@ subroutine read_satmar (nread, ndata, nodata, &
cnt = 0
iuse=icuse(nc)
if (ithin > 0 .and. iuse >=0) then
- ntmp=ndata
if (thin4d) then
timedif = zero ! crit1=0.01_r_kind
else
@@ -402,20 +413,15 @@ subroutine read_satmar (nread, ndata, nodata, &
end if
crit1 = timedif/r6+half
!
- call map3grids(-1,0,DumForThin,nlevp,dlat_earth,dlon_earth &
- ,one ,crit1,ndata,iout,nrec,iiout,luse,.false.,.false.)
+ call map3grids_m(-1,save_all,0,DumForThin,nlevp, &
+ dlat_earth,dlon_earth,one,crit1,ndata,&
+ luse,cnt,rthin,.false.,.false.)
+
if (.not. luse) cycle
- if(iiout > 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+1
- endif
- isort(nrec)=iout
else ! - no thinnning
ndata=ndata+1
- nodata=nodata+1
- iout=ndata
- isort(nrec)=iout
endif
+ iout=ndata
!
usage = zero !- Set usage variable :: practically useless
if (howv_1d(2)<=tiny_r_kind) howv_1d(2)=dflt_err
@@ -462,44 +468,67 @@ subroutine read_satmar (nread, ndata, nodata, &
enddo read_msg
call closbf(lun11)
! Write header record and data to output file for further processing
- allocate(iloc(ndata))
- cnt1 = 0
- do i1=1,size(data_all,2)
- if(isort(i1) > 0)then
- cnt1=cnt1 + 1
- iloc(cnt1)=isort(i1)
- end if
- end do
- if(ndata /= cnt1)then
- write(6,*) myname,': ndata and icount do not match STOPPING...ndata,cnt1,cnt ',ndata,cnt1,cnt
- call stop2(50)
- end if
-!
- allocate(data_out(nreal,ndata))
- do i1=1,ndata
- iout=iloc(i1)
- do k=1,nreal
- data_out(k,i1)=data_all(k,iout)
- end do
- end do
- deallocate(iloc,isort,data_all)
-
- call count_obs(ndata,nreal,ilat,ilon,data_out,nobs)
-
- write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata
- write(lunout) data_out
- deallocate(data_out)
-
- if (ndata == 0) then
- write(6,*)myname,': closbf(',lun11,') no data'
- endif
- close(lun11)
!
+ nxdata=ndata
+ ndata=0
+ if(nxdata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,nxdata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' smar ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin
+! If thinned data set usage
+ do i=1,nxdata
+ if(rthin(i))data_all(11,i)=100._r_kind
+ end do
+! If flag to not save thinned data is set - compress data
+ if(pmot /= 1)then
+ do i=1,nxdata
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ ndata=ndata+1
+ if(i > ndata)then
+ do k=1,nreal
+ data_all(k,ndata)=data_all(k,i)
+ end do
+ end if
+ end if
+ end do
+ end if
+ nodata=nodata+ndata
+ end if
+
! Deallocate local arrays
if (ithin > 0 ) then
deallocate(DumForThin)
call del3grids
end if
+
+ call count_obs(ndata,nreal,ilat,ilon,data_all,nobs)
+
+ write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata
+ write(lunout) ((data_all(k,i1),k=1,nreal),i1=1,ndata)
+ deallocate(data_all,rusage,rthin)
+
+ if (ndata == 0) then
+ write(6,*)myname,': closbf(',lun11,') no data'
+ endif
+ close(lun11)
+!
!
end subroutine read_satmar
!
diff --git a/src/gsi/read_satwnd.f90 b/src/gsi/read_satwnd.f90
index 874483c86e..0fb9680116 100644
--- a/src/gsi/read_satwnd.f90
+++ b/src/gsi/read_satwnd.f90
@@ -18,6 +18,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
! 253: EUMETSAT IR winds, 254: EUMETSAT WV deep layer winds
! 257,258,259: MODIS IR,WV cloud top, WV deep layer winds
! 260: VIIR IR winds
+! 241: CIMSS enhanced AMV winds
! respectively
! For satellite subtype: 50-80 from EUMETSAT geostationary satellites(METEOSAT)
! 100-199 from JMA geostationary satellites(MTSAT)
@@ -74,11 +75,10 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
! or hilber curve downweighting
!
! 2020-05-04 wu - no rotate_wind for fv3_regional
-! 2021-07-25 Genkova - read GOES-17 AMVQ flag:8-mitigated height
-! 16-mit.target, 24-mit.target & height; write in diag
! 2021-07-25 Genkova - added code for Metop-B/C winds in new BUFR,NC005081 !
! 2022-01-20 Genkova - added missing station_id for polar winds
! 2022-01-20 Genkova - added code for Meteosat and Himawari AMVs in new BUFR
+! 2022-12-10 Bi - added code for CIMSS enhanced AMVs in new BUFR
!
!
! input argument list:
@@ -107,15 +107,15 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,&
rlats,rlons,twodvar_regional,wrf_nmm_regional,fv3_regional
use qcmod, only: errormod,njqc
- use convthin, only: make3grids,map3grids,map3grids_m,del3grids,use_all
- use convthin_time, only: make3grids_tm,map3grids_tm,map3grids_m_tm,del3grids_tm,use_all_tm
+ use convthin, only: make3grids,map3grids_m,del3grids,use_all
+ use convthin_time, only: make3grids_tm,map3grids_m_tm,del3grids_tm,use_all_tm
use constants, only: deg2rad,zero,rad2deg,one_tenth,&
tiny_r_kind,huge_r_kind,r60inv,one_tenth,&
one,two,three,four,five,half,quarter,r60inv,r100,r2000
use converr,only: etabl
use converr_uv,only: etabl_uv,isuble_uv,maxsub_uv
use convb_uv,only: btabl_uv
- use obsmod, only: perturb_obs,perturb_fact,ran01dom,bmiss
+ use obsmod, only: perturb_obs,perturb_fact,ran01dom,bmiss,reduce_diag
use convinfo, only: nconvtype, &
icuse,ictype,icsubtype,ioctype, &
ithin_conv,rmesh_conv,pmesh_conv,pmot_conv,ptime_conv, &
@@ -157,12 +157,11 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
real(r_kind),parameter:: r799=799.0_r_kind
real(r_kind),parameter:: r1200= 1200.0_r_kind
real(r_kind),parameter:: r10000= 10000.0_r_kind
-
-
+ real(r_double),parameter:: rmiss=10d7
! Declare local variables
logical outside,inflate_error
- logical luse,ithinp
+ logical luse,ithinp,do_qc
logical,allocatable,dimension(:,:):: lmsg ! set true when convinfo entry id found in a message
character(70) obstr_v1, obstr_v2,hdrtr_v1,hdrtr_v2
@@ -172,15 +171,15 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
character(8) c_prvstg,c_sprvstg
character(8) c_station_id,stationid
- integer(i_kind) mxtb,nmsgmax
+ integer(i_kind) mxtb,nmsgmax,qcret
integer(i_kind) ireadmg,ireadsb,iuse
integer(i_kind) i,maxobs,idomsfc,nsattype,ncount
- integer(i_kind) nc,nx,isflg,itx,j,nchanl
+ integer(i_kind) nc,nx,isflg,j,nchanl
integer(i_kind) ntb,ntmatch,ncx,ncsave,ntread
integer(i_kind) kk,klon1,klat1,klonp1,klatp1
integer(i_kind) nmind,lunin,idate,ilat,ilon,iret,k
- integer(i_kind) nreal,ithin,iout,ntmp,icount,iiout,ii
- integer(i_kind) itype,iosub,ixsub,isubsub,iobsub,itypey,ierr
+ integer(i_kind) nreal,ithin,iout,ii
+ integer(i_kind) itype,iosub,ixsub,isubsub,iobsub,itypey,ierr,ihdr9
integer(i_kind) qm
integer(i_kind) nlevp ! vertical level for thinning
integer(i_kind) pflag
@@ -192,35 +191,42 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
integer(i_kind),dimension(nconvtype+1) :: ntx
integer(i_kind),dimension(5):: idate5
- integer(i_kind),allocatable,dimension(:):: nrep,isort,iloc
+ integer(i_kind),allocatable,dimension(:):: nrep,istab
integer(i_kind),allocatable,dimension(:,:):: tab
+ integer(i_kind) :: icnt(1000)
- integer(i_kind) ntime,itime
+ integer(i_kind) ntime,itime,istype
real(r_kind) toff,t4dv
- real(r_kind) rmesh,ediff,usage,tdiff
+ real(r_kind) rmesh,ediff,tdiff
real(r_kind) u0,v0,uob,vob,dx,dy,dx1,dy1,w00,w10,w01,w11
- real(r_kind) dlnpob,ppb,ppb2,qifn,qify,ee,ree,pct1,experr_norm
+ real(r_kind) dlnpob,ppb,qifn,qify,ee,ree,pct1,experr_norm
real(r_kind) woe,dlat,dlon,dlat_earth,dlon_earth
real(r_kind) dlat_earth_deg,dlon_earth_deg
real(r_kind) cdist,disterr,disterrmax,rlon00,rlat00
- real(r_kind) vdisterrmax,u00,v00,uob1,vob1
- real(r_kind) del,werrmin,obserr,ppb1,var_jb,wjbmin,wjbmax
+ real(r_kind) vdisterrmax,u00,v00
+ real(r_kind) del,werrmin,obserr,var_jb,wjbmin,wjbmax
+! real(r_kind) ppb1,ppb2,uob1,vob1
real(r_kind) tsavg,ff10,sfcr,sstime,gstime,zz
- real(r_kind) crit1,timedif,xmesh,pmesh,pmot,ptime
+ real(r_kind) crit1,timedif,xmesh,pmesh,ptime
real(r_kind),dimension(nsig):: presl
real(r_double),dimension(13):: hdrdat
- real(r_double),dimension(5):: obsdat
- real(r_double),dimension(2) :: hdrdat_test
- real(r_double),dimension(3,5) :: heightdat
- real(r_double),dimension(6,4) :: derdwdat
+ real(r_double),dimension(4):: obsdat
+ real(r_double),dimension(2) :: hdrdat_test,hdrdat_005099
+! real(r_double),dimension(3,5) :: heightdat
+! real(r_double),dimension(6,4) :: derdwdat
real(r_double),dimension(3,12) :: qcdat
real(r_double),dimension(1,1):: r_prvstg,r_sprvstg
real(r_kind),allocatable,dimension(:):: presl_thin
- real(r_kind),allocatable,dimension(:):: rusage
- real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out
+ real(r_kind),allocatable,dimension(:,:):: cdata_all
+
+ logical,allocatable,dimension(:)::rthin,rusage
+ logical save_all
+ !integer(i_kind) numthin,numqc,numrem,numall
+ integer(i_kind) nxdata,pmot
+
! GOES-16 new BUFR related variables
real(r_double) :: rep_array
@@ -242,8 +248,8 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
data hdrtr_v2 /'SAID CLATH CLONH YEAR MNTH DAYS HOUR MINU SWCM SAZA OGCE SCCF SWQM'/ ! OGCE replaces GCLONG, OGCE exists in old and new BUFR
! SWQM doesn't exist in the new BUFR, so qm is initialized to '2' manually
- data obstr_v1 /'HAMD PRLC WDIR WSPD AMVQ'/
- data obstr_v2 /'EHAM PRLC WDIR WSPD AMVQ'/
+ data obstr_v1 /'HAMD PRLC WDIR WSPD'/
+ data obstr_v2 /'EHAM PRLC WDIR WSPD'/
! data heightr/'MDPT '/
! data derdwtr/'TWIND'/
data qcstr /' OGCE GNAP PCCF'/
@@ -265,21 +271,22 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
wjbmax=5.0_r_kind
pflag=0
var_jb=zero
+ icnt=0
! allocate(etabl(302,33,6)) ! add 2 ObsErr profiles for GOES-R IR(itype=301) and WV(itype=300) (not used yet, 2015-07-08, Genkova)
! Set lower limits for observation errors
werrmin=one
nsattype=0
- nreal=27
+ nreal=34
if(perturb_obs ) nreal=nreal+2
ntread=1
ntmatch=0
ntx(ntread)=0
ntxall=0
do nc=1,nconvtype
- if( (trim(ioctype(nc)) == 'uv' .or. trim(ioctype(nc)) == 'wspd10m' .or. trim(ioctype(nc)) == 'uwnd10m' .or. trim(ioctype(nc)) == 'vwnd10m') .and. ictype(nc) >=240 &
- .and. ictype(nc) <=265) then
+ if((trim(ioctype(nc)) == 'uv' .or. trim(ioctype(nc)) == 'wspd10m' .or. trim(ioctype(nc)) == 'uwnd10m' .or. &
+ trim(ioctype(nc)) == 'vwnd10m') .and. ictype(nc) >=240 .and. ictype(nc) <=265) then
ntmatch=ntmatch+1
ntxall(ntmatch)=nc
ithin=ithin_conv(nc)
@@ -289,6 +296,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
end if
end if
end do
+
if(ntmatch == 0)then
write(6,*) ' READ_SATWND: no matching obstype found in obsinfo ',obstype
return
@@ -300,12 +308,12 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
call getcount_bufr(infile,nmsgmax,mxtb)
- allocate(lmsg(nmsgmax,ntread),tab(mxtb,3),nrep(nmsgmax))
-
+ allocate(lmsg(nmsgmax,ntread),istab(nmsgmax),tab(mxtb,3),nrep(nmsgmax))
lmsg = .false.
maxobs=0
tab=0
+ istab=0
nmsg=0
nrep=0
ntb =0
@@ -316,6 +324,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
msg_report: do while (ireadmg(lunin,subset,idate) == 0)
! if(trim(subset) == 'NC005012') cycle msg_report
+ istype=0
! Time offset
if(nmsg == 0) call time_4dvar(idate,toff)
nmsg=nmsg+1
@@ -323,15 +332,85 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
write(6,*)'READ_SATWND: messages exceed maximum ',nmsgmax
call stop2(49)
endif
+ if(trim(subset) == 'NC005064' .or. trim(subset) == 'NC005065' .or. &
+ trim(subset) == 'NC005066') then
+! EUMETSAT satellite IDS
+ istype=1
+ else if(trim(subset) == 'NC005067' .or. trim(subset) == 'NC005068' .or.&
+ trim(subset) == 'NC005069') then ! read new EUM BURF
+! EUMETSAT new BUFR satellite IDS
+ istype=2
+ else if(trim(subset) == 'NC005041' .or. trim(subset) == 'NC005042' .or. &
+ trim(subset) == 'NC005043') then
+! JMA satellite IDS
+ istype=3
+ else if(trim(subset) == 'NC005044' .or. trim(subset) == 'NC005045' .or. &
+ trim(subset) == 'NC005046') then
+! JMA satellite IDS
+ istype=4
+
+ else if(trim(subset) == 'NC005047' .or. trim(subset) == 'NC005048' .or.&
+ trim(subset) == 'NC005049') then ! read new Him-8 BURF
+! new HIM-8 BUFR
+ istype=5
+ else if(trim(subset) == 'NC005001' .or. trim(subset) == 'NC005002' .or. &
+ trim(subset) == 'NC005003' ) then
+! NESDIS BUFR
+ istype=6
+ else if(trim(subset) == 'NC005010' .or. trim(subset) == 'NC005011' .or. &
+ trim(subset) == 'NC005012' ) then
+! NESDIS BUFR
+ istype=7
+ else if(trim(subset) == 'NC005070' .or. trim(subset) == 'NC005071' ) then
+! NASA AQUA and Terra winds
+ istype=8
+ else if( trim(subset) == 'NC005080') then
+! EUMETSAT and NOAA polar winds
+ istype=9
+ else if( trim(subset) == 'NC005081') then
+! EUMETSAT polar winds
+ istype=10
+ else if( trim(subset) == 'NC005019') then
+! GOES shortwave winds
+ istype=11
+ else if( trim(subset) == 'NC005072') then
+! LEOGEO (LeoGeo) winds
+ istype=12
+ else if( trim(subset) == 'NC005090') then
+! VIIRS winds
+ istype=13
+ else if(trim(subset) == 'NC005091') then
+! VIIRS N-20 with new sequence
+ istype=14
+ else if(trim(subset) == 'NC005030') then
+! GOES-R IR LW winds
+ istype=15
+ else if(trim(subset) == 'NC005039') then
+! GOES-R IR SW winds
+ istype=16
+ else if(trim(subset) == 'NC005032') then
+! GOES-R VIS winds
+ istype=17
+ else if(trim(subset) == 'NC005034') then
+! GOES-R WV cloud top
+ istype=18
+ else if(trim(subset) == 'NC005031') then
+! GOES-R WV clear sky/deep layer
+ istype=19
+ else if(trim(subset) == 'NC005099') then
+ istype=20
+ else
+! write(6,*) ' subset not found ',trim(subset),nmsg
+ end if
+ istab(nmsg)=istype
loop_report: do while (ireadsb(lunin) == 0)
ntb = ntb+1
- maxobs=maxobs+1
nrep(nmsg)=nrep(nmsg)+1
+ maxobs=maxobs+1
if (ntb>mxtb) then
write(6,*)'READ_SATWND: reports exceed maximum ',mxtb
call stop2(49)
endif
-
call ufbint(lunin,hdrdat,13,1,iret,hdrtr_v1)
! SWQM doesn't exist for GOES-R/new BUFR/ hence hdrdat(13)=MISSING.
@@ -340,165 +419,195 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
iobsub=0
itype=-1
iobsub=int(hdrdat(1))
- if(trim(subset) == 'NC005064' .or. trim(subset) == 'NC005065' .or. &
- trim(subset) == 'NC005066') then
+ ihdr9=nint(hdrdat(9))
+
+ if(istype == 1) then
if( hdrdat(1) = r50) then !the range of EUMETSAT satellite IDS
- if(hdrdat(9) == one) then ! IR winds
+ if(ihdr9 == 1) then ! IR winds
itype=253
- else if(hdrdat(9) == two) then ! visible winds
+ else if(ihdr9 == 2) then ! visible winds
itype=243
- else if(hdrdat(9) == three) then ! WV cloud top
+ else if(ihdr9 == 3) then ! WV cloud top
itype=254
- else if(hdrdat(9) >= four) then ! WV deep layer, monitored
+ else if(ihdr9 >= 4) then ! WV deep layer, monitored
itype=254
endif
endif
- else if(trim(subset) == 'NC005067' .or. trim(subset) == 'NC005068' .or.&
- trim(subset) == 'NC005069') then ! read new EUM BURF
+
+ else if(istype == 2) then ! read new EUM BURF
if( hdrdat(1) = r50) then !the range of EUMETSAT satellite IDS
- if(hdrdat(9) == one) then ! IR winds
+ if(ihdr9 == 1) then ! IR winds
itype=253
- else if(hdrdat(9) == two) then ! visible winds
+ else if(ihdr9 == 2) then ! visible winds
itype=243
- else if(hdrdat(9) == three) then ! WV cloud top
+ else if(ihdr9 == 3) then ! WV cloud top
itype=254
- else if(hdrdat(9) >= four) then ! WV deep layer, monitored
+ else if(ihdr9 >= 4) then ! WV deep layer, monitored
itype=254
endif
endif
- else if(trim(subset) == 'NC005044' .or. trim(subset) == 'NC005045' .or. &
- trim(subset) == 'NC005046') then
+
+ else if(istype == 3) then
if( hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! the range of JMA satellite IDS
- if(hdrdat(9) == one) then ! IR winds
+ if(ihdr9 == 1) then ! IR winds
itype=252
- else if(hdrdat(9) == two) then ! visible winds
+ else if(ihdr9 == 2) then ! visible winds
itype=242
- else if(hdrdat(9) == three) then ! WV cloud top
+ else if(ihdr9 == 3) then ! WV cloud top
itype=250
- else if(hdrdat(9) >= four) then ! WV deep layer,monitored
+ else if(ihdr9 >= 4) then ! WV deep layer,monitored
itype=250
endif
endif
- else if(trim(subset) == 'NC005047' .or. trim(subset) == 'NC005048' .or.&
- trim(subset) == 'NC005049') then ! read new Him-8 BURF
+
+ else if(istype == 4) then
if( hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! the range of JMA satellite IDS
- if(hdrdat(9) == one) then ! IR winds
+ if(ihdr9 == 1) then ! IR winds
itype=252
- else if(hdrdat(9) == two) then ! visible winds
+ else if(ihdr9 == 2) then ! visible winds
itype=242
- else if(hdrdat(9) == three) then ! WV cloud top
+ else if(ihdr9 == 3) then ! WV cloud top
itype=250
- else if(hdrdat(9) >= four) then ! WV deep layer, monitored
+ else if(ihdr9 >= 4) then ! WV deep layer,monitored
itype=250
endif
endif
- else if(trim(subset) == 'NC005010' .or. trim(subset) == 'NC005011' .or. &
- trim(subset) == 'NC005012' ) then
+
+ else if(istype == 5) then ! read new Him-8 BURF
+ if( hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! the range of JMA satellite IDS
+ if(ihdr9 == 1) then ! IR winds
+ itype=252
+ else if(ihdr9 == 2) then ! visible winds
+ itype=242
+ else if(ihdr9 == 3) then ! WV cloud top
+ itype=250
+ else if(ihdr9 >= 4) then ! WV deep layer, monitored
+ itype=250
+ endif
+ endif
+
+ else if(istype == 6) then
+ if( hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! the range of NESDIS satellite IDS
+ if(ihdr9 == 1) then ! IR winds
+ if(hdrdat(12) <50000000000000.0_r_kind) then
+ itype=245
+ else
+ itype=240 ! short wave IR winds
+ endif
+ else if(ihdr9 == 2 ) then ! visible winds
+ itype=251
+ else if(ihdr9 == 3 ) then ! WV cloud top
+ itype=246
+ else if(ihdr9 >= 4 ) then ! WV deep layer,monitored
+ itype=247
+ endif
+ endif
+
+ else if(istype == 7) then
if( hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! the range of NESDIS satellite IDS
- if(hdrdat(9) == one) then ! IR winds
+ if(ihdr9 == 1) then ! IR winds
if(hdrdat(12) <50000000000000.0_r_kind) then
itype=245
else
- itype=240 ! short wave IR winds
+ itype=240 ! short wave IR winds
endif
- else if(hdrdat(9) == two ) then ! visible winds
+ else if(ihdr9 == 2 ) then ! visible winds
itype=251
- else if(hdrdat(9) == three ) then ! WV cloud top
+ else if(ihdr9 == 3 ) then ! WV cloud top
itype=246
- else if(hdrdat(9) >= four ) then ! WV deep layer,monitored
+ else if(ihdr9 >= 4 ) then ! WV deep layer,monitored
itype=247
endif
endif
- else if(trim(subset) == 'NC005070' .or. trim(subset) == 'NC005071' ) then
+
+ else if(istype == 8) then
if( hdrdat(1) >=r700 .and. hdrdat(1) <= r799 ) then ! the range of NASA Terra and Aqua satellite IDs
- if(hdrdat(9) == one) then ! IR winds
+ if(ihdr9 == 1) then ! IR winds
itype=257
- else if(hdrdat(9) == three) then ! WV cloud top
+ else if(ihdr9 == 3) then ! WV cloud top
itype=258
- else if(hdrdat(9) >= four) then ! WV deep layer
+ else if(ihdr9 >= 4) then ! WV deep layer
itype=259
endif
endif
- else if( trim(subset) == 'NC005080') then
+ else if(istype == 9) then
if( hdrdat(1) <10.0_r_kind .or. (hdrdat(1) >= 200.0_r_kind .and. &
hdrdat(1) <=223.0_r_kind) ) then ! the range of EUMETSAT and NOAA polar orbit satellite IDs
- if(hdrdat(9) == one) then ! IR winds
+ if(ihdr9 == 1) then ! IR winds
itype=244
else
write(6,*) 'READ_SATWND: wrong derived method value'
endif
endif
- else if( trim(subset) == 'NC005081') then
+ else if(istype == 10) then
if( hdrdat(1) <10.0_r_kind ) then ! the range of EUMETSAT polar orbit satellite IDs new BUFR
- if(hdrdat(9) == one) then ! IR winds
+ if(ihdr9 == 1) then ! IR winds
itype=244
else
write(6,*) 'READ_SATWND: wrong derived method value'
endif
endif
- else if( trim(subset) == 'NC005019') then ! GOES shortwave winds
+
+ else if(istype == 11) then ! GOES shortwave winds
if(hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! The range of NESDIS satellite IDS
- if(hdrdat(9) == one) then ! short wave IR winds
+ if(ihdr9 == 1) then ! short wave IR winds
itype=240
endif
endif
- else if( trim(subset) == 'NC005072') then ! LEOGEO (LeoGeo) winds
+ else if(istype == 12) then ! LEOGEO (LeoGeo) winds
if(hdrdat(1) == 854 ) then ! LeoGeo satellite ID
- if(hdrdat(9) == one) then ! LEOGEO IRwinds
+ if(ihdr9 == 1) then ! LEOGEO IRwinds
itype=255
endif
endif
- else if( trim(subset) == 'NC005090') then ! VIIRS winds
+ else if(istype == 13) then ! VIIRS winds
if(hdrdat(1) >=r200 .and. hdrdat(1) <=r250 ) then ! The range of satellite IDS
- if(hdrdat(9) == one) then ! VIIRS IR winds
+ if(ihdr9 == 1) then ! VIIRS IR winds
itype=260
endif
endif
- else if(trim(subset) == 'NC005091') then ! VIIRS N-20 with new sequence
-! Commented out, because we need clarification for SWCM/hdrdat(9) from Yi Song
+ else if(istype == 14) then ! VIIRS N-20 with new sequence
+! Commented out, because we need clarification for SWCM/ihdr9 from Yi Song
! NOTE: Once it is confirmed that SWCM values are sensible, apply this logic and
! replace lines 685-702
- ! if(hdrdat(9) == one) then ! VIIRS IR
+ ! if(ihdr9 == 1) then ! VIIRS IR
! winds
! itype=260
! endif
!Temporary solution replacing the commented code above
- if(trim(subset) == 'NC005091') then ! IR LW winds
- itype=260
- endif
+ itype=260
!GOES-R section of the 'if' statement over 'subsets'
- else if(trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or. trim(subset) == 'NC005032' .or. &
- trim(subset) == 'NC005034' .or. trim(subset) == 'NC005039') then
-! Commented out, because we need clarification for SWCM/hdrdat(9) from Yi Song
+! Commented out, because we need clarification for SWCM/ihdr9 from Yi Song
! NOTE: Once it is confirmed that SWCM values are sensible, apply this logic and replace lines 685-702
-! if(hdrdat(9) == one) then
+! if(ihdr9 == 1) then
! if(hdrdat(12) <50000000000000.0_r_kind) then
! itype=245 ! GOES-R IR(LW) winds
! else
! itype=240 ! GOES-R IR(SW) winds
! endif
-! else if(hdrdat(9) == two ) then
+! else if(ihdr9 == 2 ) then
! itype=251 ! GOES-R VIS winds
-! else if(hdrdat(9) == three ) then
+! else if(ihdr9 == 3 ) then
! itype=246 ! GOES-R CT WV winds
-! else if(hdrdat(9) >= four ) then
+! else if(ihdr9 >= 4 ) then
! itype=247 ! GOES-R CS WV winds
! endif
!Temporary solution replacing the commented code above
- if(trim(subset) == 'NC005030') then ! IR LW winds
- itype=245
- else if(trim(subset) == 'NC005039') then ! IR SW winds
- itype=240
- else if(trim(subset) == 'NC005032') then ! VIS winds
- itype=251
- else if(trim(subset) == 'NC005034') then ! WV cloud top
- itype=246
- else if(trim(subset) == 'NC005031') then ! WV clear sky/deep layer
- itype=247
- endif
+ else if(istype == 15) then ! IR LW winds
+ itype=245
+ else if(istype == 16) then ! IR SW winds
+ itype=240
+ else if(istype == 17) then ! VIS winds
+ itype=251
+ else if(istype == 18) then ! WV cloud top
+ itype=246
+ else if(istype == 19) then ! WV clear sky/deep layer
+ itype=247
+ else if(istype == 20) then
+ itype=241
else ! wind is not recognised and itype is not assigned
cycle loop_report
endif
@@ -532,7 +641,6 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
! Save information for next read
if(ncsave /= 0) then
- maxobs=maxobs+1
nx=1
if(ithin_conv(ncsave) > 0 .and. ithin_conv(ncsave) <5)then
do ii=2,ntread
@@ -541,38 +649,38 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
end if
tab(ntb,1)=ncsave
tab(ntb,2)=nx
- tab(ntb,3)=1
+ tab(ntb,3)=itype
lmsg(nmsg,nx) = .true.
end if
enddo loop_report
enddo msg_report
-
- allocate(cdata_all(nreal,maxobs),isort(maxobs),rusage(maxobs))
- isort = 0
- cdata_all=zero
nread=0
ntest=0
nvtest=0
nchanl=0
ilon=2
ilat=3
- rusage=101.0_r_kind
-
-! Open, then read date from bufr data
-!! read satellite winds one type a time
+ allocate(cdata_all(nreal,maxobs),rthin(maxobs),rusage(maxobs))
+ rusage = .true.
+ rthin = .false.
loop_convinfo: do nx=1,ntread
+
+ ! set parameters for processing the next satwind type
use_all = .true.
use_all_tm = .true.
ithin=0
+! Default for non thinned data is save all
+ pmot=0
+
if(nx >1) then
nc=ntx(nx)
ithin=ithin_conv(nc)
+ pmot = pmot_conv(nc)
if (ithin > 0 .and. ithin <5) then
rmesh=rmesh_conv(nc)
pmesh=pmesh_conv(nc)
- pmot=pmot_conv(nc)
ptime=ptime_conv(nc)
if(pmesh > zero) then
pflag=1
@@ -598,14 +706,18 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
enddo
endif
endif
- write(6,'(a52,a16,I5,f10.2,2i5,f10.2,i5,2f10.2)') &
+ write(6,'(a52,a16,I5,f10.2,2i5,f10.2,i5,i5,f10.2)') &
' READ_SATWND: ictype(nc),rmesh,pflag,nlevp,pmesh,nc ', &
ioctype(nc),ictype(nc),rmesh,pflag,nlevp,pmesh,nc,pmot,ptime
endif
endif
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
+
+ ! Open and read the file once for each satwnd type
call closbf(lunin)
- close(lunin)
open(lunin,file=trim(infile),form='unformatted')
call openbf(lunin,'IN',lunin)
call datelen(10)
@@ -614,54 +726,59 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
ncount=0
loop_msg: do while(IREADMG(lunin,subset,idate) == 0)
nmsg = nmsg+1
- if(.not.lmsg(nmsg,nx)) then
+ istype = istab(nmsg)
+ if(.not.lmsg(nmsg,nx) .or. istype == 3 .or. istype == 6) then
+! currently istypes 3 and 6 not used. If adding needs to be deleted from above line
+! as well as below.
ntb=ntb+nrep(nmsg)
cycle loop_msg ! no useable reports this mesage, skip ahead report count
end if
loop_readsb: do while(ireadsb(lunin) == 0)
ntb = ntb+1
- nc=tab(ntb,1)
+ nc = tab(ntb,1)
if(nc <= 0 .or. tab(ntb,2) /= nx) cycle loop_readsb
+ itype = tab(ntb,3)
+ if(itype <= 0) cycle loop_readsb
hdrdat=bmiss
obsdat=bmiss
- heightdat=bmiss
- derdwdat=bmiss
+! heightdat=bmiss
+! derdwdat=bmiss
qcdat=bmiss
- iobsub=0
- itype=-1
uob=bmiss
vob=bmiss
ppb=bmiss
- ppb1=bmiss
- ppb2=bmiss
- uob1=bmiss
- vob1=bmiss
+! ppb1=bmiss
+! ppb2=bmiss
+! uob1=bmiss
+! vob1=bmiss
ee=r110
qifn=r110
qify=r110
-! Test for BUFR version using lat/lon mnemonics
+ ! test for BUFR version using lat/lon mnemonics
call ufbint(lunin,hdrdat_test,2,1,iret, 'CLAT CLON')
if ( hdrdat_test(1) > 100000000.0_r_kind .and. hdrdat_test(2) > 100000000.0_r_kind ) then
call ufbint(lunin,hdrdat,13,1,iret,hdrtr_v2)
- call ufbint(lunin,obsdat,5,1,iret,obstr_v2)
+ call ufbint(lunin,obsdat,4,1,iret,obstr_v2)
else
call ufbint(lunin,hdrdat,13,1,iret,hdrtr_v1)
- call ufbint(lunin,obsdat,5,1,iret,obstr_v1)
+ call ufbint(lunin,obsdat,4,1,iret,obstr_v1)
endif
+ ! reject data with missing pressure or wind
ppb=obsdat(2)
- if (ppb > 100000000.0_r_kind .or. &
- hdrdat(3) >100000000.0_r_kind .or. &
- obsdat(4) > 100000000.0_r_kind) cycle loop_readsb
- if(ppb >r10000) ppb=ppb/r100
- if (ppb rmiss .or. hdrdat(3)>rmiss .or. obsdat(4)>rmiss) cycle loop_readsb
+ if(ppb>r10000) ppb=ppb/r100 ! ppb<10000 may indicate data reported in daPa or hPa
+
+ ! reject date above 125mb (or 850 for regional)
+ if ((twodvar_regional .and. ppb twind) cycle loop_readsb
endif
- iosub=0
+ ! reject data with bad lat/lon
if(abs(hdrdat(2)) >r90 ) cycle loop_readsb
if( hdrdat(3) r360) cycle loop_readsb
qm=2
iobsub=int(hdrdat(1))
+ ihdr9=nint(hdrdat(9))
write(stationid,'(i3)') iobsub
- ! assign types and get quality info : start
- if(trim(subset) == 'NC005064' .or. trim(subset) == 'NC005065' .or. &
- trim(subset) == 'NC005066') then
- if( hdrdat(1) = r50) then ! the range of EUMETSAT satellite IDs
- c_prvstg='EUMETSAT'
- if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
- if(hdrdat(9) == one) then ! IR winds
- itype=253
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- else if(hdrdat(9) == two) then ! visible winds
- itype=243
- c_station_id='VI'//stationid
- c_sprvstg='VI'
- else if(hdrdat(9) == three) then ! WV cloud top, try to assimilate
- itype=254
- c_station_id='WV'//stationid
- c_sprvstg='WV'
- else if(hdrdat(9) >= four) then ! WV deep layer,monitoring
- itype=254
- qm=9 ! quality mark as 9, means the observation error needed to be set
- c_station_id='WV'//stationid
- c_sprvstg='WV'
- endif
+ ! counter for satwnd types
+ !if(itype>=240.and.itype<=279) icnt(itype)=icnt(itype)+1
+
+ ! test for QCSTR or MANDATORY QC - if not skip over the extra blocks
+ call ufbrep(lunin,qcdat,3,12,qcret,qcstr)
+ do_qc = subset(1:7)=='NC00503'.and.nint(hdrdat(1))>=270
+ do_qc = do_qc.or.subset(1:7)=='NC00501'
+ do_qc = do_qc.or.subset=='NC005081'.or.subset=='NC005091'
+ do_qc = do_qc.or.qcret>0
+
+ ! assign types and get quality info: start
+
+ if(.not.do_qc) then
+ continue
+ else if(istype == 1) then
+ if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
+ c_prvstg='EUMETSAT'
+ if(ihdr9 == 1) then ! IR winds
+! itype=253
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ else if(ihdr9 == 2) then ! visible winds
+! itype=243
+ c_station_id='VI'//stationid
+ c_sprvstg='VI'
+ else if(ihdr9 == 3) then ! WV cloud top, try to assimilate
+! itype=254
+ c_station_id='WV'//stationid
+ c_sprvstg='WV'
+ else if(ihdr9 >= 4) then ! WV deep layer,monitoring
+! itype=254
+ qm=9 ! quality mark as 9, means the observation error needed to be set
+ c_station_id='WV'//stationid
+ c_sprvstg='WV'
+ endif
! get quality information
- call ufbrep(lunin,qcdat,3,12,iret,qcstr)
- do j=4,9
- if( qify r105) then
- qify=qcdat(3,j)
- else if(qcdat(2,j) == two .and. qifn >r105) then
- qifn=qcdat(3,j)
- else if(qcdat(2,j) == three .and. ee >r105) then
- ee=qcdat(3,j)
- endif
+ do j=4,9
+ if( qify r105) then
+ qify=qcdat(3,j)
+ else if(qcdat(2,j) == two .and. qifn >r105) then
+ qifn=qcdat(3,j)
+ else if(qcdat(2,j) == three .and. ee >r105) then
+ ee=qcdat(3,j)
endif
- enddo
- if(qifn <85.0_r_kind ) then ! qifn, QI without forecast
- qm=15
endif
+ enddo
+ if(qifn <85.0_r_kind ) then ! qifn, QI without forecast
+ qm=15
+ endif
+! Extra block for new EUMETSAT BUFR: Start
+ else if(istype == 2)then ! new EUM BUFR
+ if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
+ c_prvstg='EUMETSAT'
+ if(ihdr9 == 1) then ! IR winds
+! itype=253
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ else if(ihdr9 == 2) then ! visible winds
+! itype=243
+ c_station_id='VI'//stationid
+ c_sprvstg='VI'
+ else if(ihdr9 == 3) then ! WV cloud top, try to assimilate
+! itype=254
+ c_station_id='WV'//stationid
+ c_sprvstg='WV'
+ else if(ihdr9 >= 4) then ! WV deep layer,monitoring
+! itype=254
+ qm=9 ! quality mark as 9, means the observation error needed to be set
+ c_station_id='WV'//stationid
+ c_sprvstg='WV'
+ endif
+! get quality information THIS SECTION NEEDS TO BE TESTED!!!
+ call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}')
+ irep_array = max(1,int(rep_array))
+ allocate( amvivr(2,irep_array))
+ call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD')
+ pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova
+ deallocate( amvivr )
+ call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF
+ qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR
+ ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s]
+ if(qifn <85.0_r_kind ) then ! qifn, QI without forecast
+ qm=15
+ endif
+! Extra block for new EUMETSAT BUFR: End
+ else if(istype == 4) then ! JMA
+ if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
+ c_prvstg='JMA'
+ if(ihdr9 == 1) then ! IR winds
+! itype=252
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ else if(ihdr9 == 2) then ! visible winds
+! itype=242
+ c_station_id='VI'//stationid
+ c_sprvstg='VI'
+ else if(ihdr9 == 3) then ! WV cloud top
+! itype=250
+ c_station_id='WV'//stationid
+ c_sprvstg='WV'
+ else if(ihdr9 >= 4) then ! WV deep layer,as monitoring
+! itype=250
+ qm=9
+ c_station_id='WV'//stationid
+ c_sprvstg='WV'
endif
- else if(trim(subset) == 'NC005044' .or. trim(subset) == 'NC005045' .or. & ! JMA
- trim(subset) == 'NC005046') then
- if(hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! the range of JMA satellite IDS
- c_prvstg='JMA'
- if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
- if(hdrdat(9) == one) then ! IR winds
- itype=252
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- else if(hdrdat(9) == two) then ! visible winds
- itype=242
- c_station_id='VI'//stationid
- c_sprvstg='VI'
- else if(hdrdat(9) == three) then ! WV cloud top
- itype=250
- c_station_id='WV'//stationid
- c_sprvstg='WV'
- else if(hdrdat(9) >=four) then ! WV deep layer,as monitoring
- itype=250
- qm=9
- c_station_id='WV'//stationid
- c_sprvstg='WV'
- endif
! get quality information
- call ufbrep(lunin,qcdat,3,12,iret,qcstr)
- do j=4,9
- if( qify <=r105 .and. qifn r105 ) then
- qify=qcdat(3,j)
- else if(qcdat(2,j) == 102.0_r_kind .and. qifn >r105 ) then
- qifn=qcdat(3,j)
- else if(qcdat(2,j) == 103.0_r_kind .and. ee >r105) then
- ee=qcdat(3,j)
- endif
+ do j=4,9
+ if( qify <=r105 .and. qifn r105 ) then
+ qify=qcdat(3,j)
+ else if(qcdat(2,j) == 102.0_r_kind .and. qifn >r105 ) then
+ qifn=qcdat(3,j)
+ else if(qcdat(2,j) == 103.0_r_kind .and. ee >r105) then
+ ee=qcdat(3,j)
endif
- enddo
-
- if(qifn <85.0_r_kind ) then ! qifn: QI value without forecast
- qm=15
endif
+ enddo
+
+ if(qifn <85.0_r_kind ) then ! qifn: QI value without forecast
+ qm=15
endif
- else if(trim(subset) == 'NC005010' .or. trim(subset) == 'NC005011' .or. & ! NESDIS GOES
- trim(subset) == 'NC005012' ) then
- if(hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! the range of NESDIS satellite IDS
- c_prvstg='NESDIS'
- if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
- if(hdrdat(9) == one) then ! IR winds
- if(hdrdat(12) <50000000000000.0_r_kind) then ! for channel 4
- itype=245
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- else
- itype=240 ! short wave winds
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- endif
- else if(hdrdat(9) == two ) then ! visible winds
- itype=251
- c_station_id='VI'//stationid
- c_sprvstg='VI'
- else if(hdrdat(9) == three) then ! WV cloud top
- itype=246
- c_station_id='WV'//stationid
- c_sprvstg='WV'
- else if(hdrdat(9) >= four) then ! WV deep layer.mornitored set in convinfo file
- itype=247
- c_station_id='WV'//stationid
- c_sprvstg='WV'
+! Extra block for new JMA BUFR: Start
+ else if(istype == 5)then ! new JMA BUFR
+ if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
+ c_prvstg='JMA'
+ if(ihdr9 == 1) then ! IR winds
+! itype=252
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ else if(ihdr9 == 2) then ! visible winds
+! itype=242
+ c_station_id='VI'//stationid
+ c_sprvstg='VI'
+ else if(ihdr9 == 3) then ! WV cloud top
+! itype=250
+ c_station_id='WV'//stationid
+ c_sprvstg='WV'
+ else if(ihdr9 >= 4) then ! WV deep layer,monitoring
+! itype=250
+ qm=9 ! quality mark as 9, means the observation error needed to be set
+ c_station_id='WV'//stationid
+ c_sprvstg='WV'
+ endif
+! get quality information THIS SECTION NEEDS TO BE TESTED!!!
+ call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}')
+ irep_array = max(1,int(rep_array))
+ allocate( amvivr(2,irep_array))
+ call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD')
+ pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova
+ deallocate( amvivr )
+ call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF
+ qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR
+ ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s]
+ if(qifn <85.0_r_kind ) then ! qifn, QI without forecast
+ qm=15
+ endif
+! Extra block for new JMA BUFR: End
+ else if(istype == 7)then ! NESDIS GOES
+ if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
+ c_prvstg='NESDIS'
+ if(ihdr9 == 1) then ! IR winds
+ if(hdrdat(12) <50000000000000.0_r_kind) then ! for channel 4
+! itype=245
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ else
+! itype=240 ! short wave winds
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
endif
- call ufbrep(lunin,qcdat,3,8,iret,qcstr)
+ else if(ihdr9 == 2) then ! visible winds
+! itype=251
+ c_station_id='VI'//stationid
+ c_sprvstg='VI'
+ else if(ihdr9 == 3) then ! WV cloud top
+! itype=246
+ c_station_id='WV'//stationid
+ c_sprvstg='WV'
+ else if(ihdr9 >= 4) then ! WV deep layer.mornitored set in convinfo file
+! itype=247
+ c_station_id='WV'//stationid
+ c_sprvstg='WV'
+ endif
! get quality information
- do j=1,8
- if( qify <=r105 .and. qifn r105 ) then
- qifn=qcdat(3,j)
- else if(qcdat(2,j) == three .and. qify >r105) then
- qify=qcdat(3,j)
- else if( qcdat(2,j) == four .and. ee >r105) then
- ee=qcdat(3,j)
- endif
+ do j=1,8
+ if( qify <=r105 .and. qifn r105 ) then
+ qifn=qcdat(3,j)
+ else if(qcdat(2,j) == three .and. qify >r105) then
+ qify=qcdat(3,j)
+ else if( qcdat(2,j) == four .and. ee >r105) then
+ ee=qcdat(3,j)
endif
- enddo
-!QI not applied to CAWV for now - may in the future
- if(qifn <85.0_r_kind .and. itype /= 247) then
- qm=15
endif
- if(wrf_nmm_regional) then
+ enddo
+!QI not applied to CAWV for now - may in the future
+ if(qifn <85.0_r_kind .and. itype /= 247) then
+ qm=15
+ endif
+ if(wrf_nmm_regional) then
! Minimum speed requirement for CAWV of 8m/s for HWRF.
! Tighten QC for 247 winds by removing winds below 450hPa
- if(itype == 247 .and. obsdat(4) < 8.0_r_kind .and. ppb > 450.0_r_kind) then
- qm=15
+ if(itype == 247 .and. obsdat(4) < 8.0_r_kind .and. ppb > 450.0_r_kind) then
+ qm=15
! Tighten QC for 240 winds by remove winds above 700hPa
- elseif(itype == 240 .and. ppb < 700.0_r_kind) then
- qm=15
+ elseif(itype == 240 .and. ppb < 700.0_r_kind) then
+ qm=15
! Tighten QC for 251 winds by remove winds above 750hPa
- elseif(itype == 251 .and. ppb < 750.0_r_kind) then
- qm=15
- endif
- else
+ elseif(itype == 251 .and. ppb < 750.0_r_kind) then
+ qm=15
+ endif
+ else
! Minimum speed requirement for CAWV of 10m/s
- if(itype == 247 .and. obsdat(4) < 10.0_r_kind) then
- qm=15
- endif
+ if(itype == 247 .and. obsdat(4) < 10.0_r_kind) then
+ qm=15
endif
endif
- else if(trim(subset) == 'NC005070' .or. trim(subset) == 'NC005071') then ! MODIS
- if(hdrdat(1) >=r700 .and. hdrdat(1) <= r799 ) then
- c_prvstg='MODIS'
- if(hdrdat(9) == one) then ! IR winds
- itype=257
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- else if(hdrdat(9) == three) then ! WV cloud top
- itype=258
- c_station_id='WV'//stationid
- c_sprvstg='WVCLOP'
- else if(hdrdat(9) >= four) then ! WV deep layer
- itype=259
- c_station_id='WV'//stationid
- c_sprvstg='WVDLAYER'
- endif
+ else if(istype == 8) then ! MODIS
+ c_prvstg='MODIS'
+ if(ihdr9 == 1) then ! IR winds
+! itype=257
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ else if(ihdr9 == 3) then ! WV cloud top
+! itype=258
+ c_station_id='WV'//stationid
+ c_sprvstg='WVCLOP'
+ else if(ihdr9 >= 4) then ! WV deep layer
+! itype=259
+ c_station_id='WV'//stationid
+ c_sprvstg='WVDLAYER'
+ endif
! get quality information
- call ufbrep(lunin,qcdat,3,8,iret,qcstr)
- do j=1,8
- if( qify <=r105 .and. qifn r105) then
- qifn=qcdat(3,j)
- else if(qcdat(2,j) == three .and. qify >r105) then
- qify=qcdat(3,j)
- else if( qcdat(2,j) == four .and. ee >r105 ) then
- ee=qcdat(3,j)
- endif
+ do j=1,8
+ if( qify <=r105 .and. qifn r105) then
+ qifn=qcdat(3,j)
+ else if(qcdat(2,j) == three .and. qify >r105) then
+ qify=qcdat(3,j)
+ else if( qcdat(2,j) == four .and. ee >r105 ) then
+ ee=qcdat(3,j)
endif
- enddo
- endif
- else if( trim(subset) == 'NC005080') then ! AVHRR
- if(hdrdat(1) <10.0_r_kind .or. (hdrdat(1) >= 200.0_r_kind .and. &
- hdrdat(1) <=223.0_r_kind) ) then
- c_prvstg='AVHRR'
- if(hdrdat(9) == one) then ! IR winds
- itype=244
- else
- write(6,*) 'READ_SATWND: wrong derived method value'
endif
+ enddo
+ else if(istype == 9) then ! AVHRR
+ c_prvstg='AVHRR'
+! itype=244
! get quality information
- call ufbrep(lunin,qcdat,3,8,iret,qcstr)
- do j=1,6
- if( qify <=r105 .and. qifn r105) then
- qifn=qcdat(3,j)
- else if(qcdat(2,j) == three .and. qify >r105) then
- qify=qcdat(3,j)
- else if( qcdat(2,j) == four .and. ee >r105) then
- ee=qcdat(3,j)
- endif
+ do j=1,6
+ if( qify <=r105 .and. qifn r105) then
+ qifn=qcdat(3,j)
+ else if(qcdat(2,j) == three .and. qify >r105) then
+ qify=qcdat(3,j)
+ else if( qcdat(2,j) == four .and. ee >r105) then
+ ee=qcdat(3,j)
endif
- enddo
- endif
- else if( trim(subset) == 'NC005019') then ! GOES shortwave winds
- if(hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! The range of NESDIS satellite IDS
- c_prvstg='NESDIS'
- if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
- if(hdrdat(9) == one) then ! short wave IR winds
- itype=240
- c_station_id='IR'//stationid
- c_sprvstg='IR'
endif
+ enddo
+! Extra block for new Metop/AVHRR BUFR: Start
+ else if(istype == 10) then ! Metop-B/C from EUMETSAT
+ c_prvstg='METOP'
+ if(ihdr9 == 1) then ! IRwinds
+! itype=244
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ else
+ write(6,*) 'READ_SATWND: wrong derived method value'
+ endif
+ call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}')
+ irep_array = int(rep_array)
+ allocate( amvivr(2,irep_array))
+ call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD')
+ pct1 = amvivr(2,1) ! use of pct1 is limited to GOES-16/17) as introduced by Nebuda/Genkova
+ deallocate( amvivr )
+ call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF
+ qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR
+ ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s]
+! Extra block for new Metop/AVHRR BUFR: End
+ else if(istype == 11) then ! GOES shortwave winds
+ if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
+ c_prvstg='NESDIS'
+ if(ihdr9 == 1) then ! short wave IR winds
+! itype=240
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ endif
! get quality information
- call ufbrep(lunin,qcdat,3,8,iret,qcstr)
- do j=1,6
- if( qify <=r105 .and. qifn r105) then
- qifn=qcdat(3,j)
- else if(qcdat(2,j) == three .and. qify >r105) then
- qify=qcdat(3,j)
- else if( qcdat(2,j) == four .and. ee >r105) then
- ee=qcdat(3,j)
- endif
+ do j=1,6
+ if( qify <=r105 .and. qifn r105) then
+ qifn=qcdat(3,j)
+ else if(qcdat(2,j) == three .and. qify >r105) then
+ qify=qcdat(3,j)
+ else if( qcdat(2,j) == four .and. ee >r105) then
+ ee=qcdat(3,j)
endif
- enddo
-! Tighten QC for 240 winds by removing winds above 700hPa
- if(wrf_nmm_regional) then
- if(itype == 240 .and. ppb < 700.0_r_kind) qm=15
endif
+ enddo
+! Tighten QC for 240 winds by removing winds above 700hPa
+ if(wrf_nmm_regional) then
+ if(itype == 240 .and. ppb < 700.0_r_kind) qm=15
endif
- else if( trim(subset) == 'NC005072') then ! LEOGEO (LeoGeo) winds
+ else if(istype == 12) then ! LEOGEO (LeoGeo) winds
if(hdrdat(1) ==854 ) then ! LEOGEO satellite ID
c_prvstg='LEOGEO'
- if(hdrdat(9) == one) then !LEOGEO IR winds
- itype=255
+ if(ihdr9 == 1) then !LEOGEO IR winds
+! itype=255
c_station_id='IR'//stationid
c_sprvstg='IR'
endif
! get quality information
- call ufbrep(lunin,qcdat,3,8,iret,qcstr)
!!! Rethink this strategy!!!
qifn=qcdat(3,1)
qify=qcdat(3,2)
@@ -945,303 +1141,206 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
!endif
!enddo
endif
- else if( trim(subset) == 'NC005090') then ! VIIRS IR winds
- if(hdrdat(1) >=r200 .and. hdrdat(1) <=r250 ) then ! The range of satellite IDS
- c_prvstg='VIIRS'
- if(hdrdat(9) == one) then ! VIIRS IR winds
- itype=260
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- endif
+ else if(istype == 13) then ! VIIRS IR winds
+ c_prvstg='VIIRS'
+ if(ihdr9 == 1) then ! VIIRS IR winds
+! itype=260
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ endif
! get quality information
- call ufbrep(lunin,qcdat,3,8,iret,qcstr)
- do j=1,6
- if( qify <=r105 .and. qifn r105) then
- qifn=qcdat(3,j)
- else if(qcdat(2,j) == three .and. qify >r105) then
- qify=qcdat(3,j)
- else if( qcdat(2,j) == four .and. ee >r105) then
- ee=qcdat(3,j)
- endif
+ do j=1,6
+ if( qify <=r105 .and. qifn r105) then
+ qifn=qcdat(3,j)
+ else if(qcdat(2,j) == three .and. qify >r105) then
+ qify=qcdat(3,j)
+ else if( qcdat(2,j) == four .and. ee >r105) then
+ ee=qcdat(3,j)
endif
- enddo
- endif
+ endif
+ enddo
if(qifn <85.0_r_kind ) then ! qifn, QI without forecast
qm=15
endif
-! Extra block for new JMA BUFR: Start
- else if(trim(subset) == 'NC005047' .or. trim(subset) == 'NC005048' .or. &
- trim(subset) == 'NC005049') then ! read new JMA BURF
- if( hdrdat(1) >=r100 .and. hdrdat(1) <=r199 ) then ! The range of satellite IDs
- c_prvstg='JMA'
- if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
- if(hdrdat(9) == one) then ! IR winds
- itype=252
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- else if(hdrdat(9) == two) then ! visible winds
- itype=242
- c_station_id='VI'//stationid
- c_sprvstg='VI'
- else if(hdrdat(9) == three) then ! WV cloud top
- itype=250
- c_station_id='WV'//stationid
- c_sprvstg='WV'
- else if(hdrdat(9) >= four) then ! WV deep layer,monitoring
- itype=250
- qm=9 ! quality mark as 9, means the observation error needed to be set
- c_station_id='WV'//stationid
- c_sprvstg='WV'
- endif
-! get quality information THIS SECTION NEEDS TO BE TESTED!!!
- call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}')
- irep_array = int(rep_array)
- allocate( amvivr(2,irep_array))
- call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD')
- pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova
- deallocate( amvivr )
- call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF
- qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR
- ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s]
- if(qifn <85.0_r_kind ) then ! qifn, QI without forecast
- qm=15
- endif
- endif
-! Extra block for new JMA BUFR: End
-! Extra block for new EUMETSAT BUFR: Start
- else if(trim(subset) == 'NC005067' .or. trim(subset) == 'NC005068' .or. &
- trim(subset) == 'NC005069') then ! read new EUM BURF
- if( hdrdat(1) = r50 ) then ! The range of satellite IDs
- c_prvstg='EUMETSAT'
- if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
- if(hdrdat(9) == one) then ! IR winds
- itype=253
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- else if(hdrdat(9) == two) then ! visible winds
- itype=243
- c_station_id='VI'//stationid
- c_sprvstg='VI'
- else if(hdrdat(9) == three) then ! WV cloud top, try to assimilate
- itype=254
- c_station_id='WV'//stationid
- c_sprvstg='WV'
- else if(hdrdat(9) >= four) then ! WV deep layer,monitoring
- itype=254
- qm=9 ! quality mark as 9, means the observation error needed to be set
- c_station_id='WV'//stationid
- c_sprvstg='WV'
- endif
-! get quality information THIS SECTION NEEDS TO BE TESTED!!!
- call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}')
- irep_array = int(rep_array)
- allocate( amvivr(2,irep_array))
- call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD')
- pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova
- deallocate( amvivr )
- call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF
- qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR
- ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s]
- if(qifn <85.0_r_kind ) then ! qifn, QI without forecast
- qm=15
- endif
- endif
-! Extra block for new EUMETSAT BUFR: End
-! Extra block for new Metop/AVHRR BUFR: Start
- else if(trim(subset) == 'NC005081') then ! Metop-B/C from NESDIS
- if( hdrdat(1) <10.0_r_kind ) then ! The range of satellite IDs
- c_prvstg='METOP'
- if(hdrdat(9) == one) then ! IRwinds
- itype=244
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- else
- write(6,*) 'READ_SATWND: wrong derived method value'
- endif
- call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}')
- irep_array = int(rep_array)
- allocate( amvivr(2,irep_array))
- call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD')
- pct1 = amvivr(2,1) ! use of pct1 is limited to GOES-16/17) as introduced by Nebuda/Genkova
- deallocate( amvivr )
- call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF
- qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR
- ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s]
- endif
-! Extra block for new Metop/AVHRR BUFR: End
! Extra block for VIIRS NOAA-20: Start
- else if(trim(subset) == 'NC005091') then
- if( hdrdat(1) >=r200 .and. hdrdat(1) <=r250 ) then ! Use this range in v16.*
- c_prvstg='VIIRS'
- if(trim(subset) == 'NC005091') then ! IR LW winds
- itype=260
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- !write(6,*)'itype= ',itype
- endif
-
-! call ufbint(lunin,rep_array,1,1,iret, '{AMVAHA}')
-! irep_array = int(rep_array)
-! allocate( amvaha(4,irep_array))
-! call ufbint(lunin,amvaha,4,irep_array,iret, 'EHAM PRLC TMDBST
-! HOCT')
-! deallocate( amvaha )
+ else if(istype == 14) then
+ c_prvstg='VIIRS' ! IR LW winds
+! itype=260
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ !write(6,*)'itype= ',itype
+
+! call ufbint(lunin,rep_array,1,1,iret, '{AMVAHA}')
+! irep_array = int(rep_array)
+! allocate( amvaha(4,irep_array))
+! call ufbint(lunin,amvaha,4,irep_array,iret, 'EHAM PRLC TMDBST
+! HOCT')
+! deallocate( amvaha )
!
-! call ufbint(lunin,rep_array,1,1,iret, '{AMVIII}')
-! irep_array = int(rep_array)
-! allocate( amviii(12,irep_array))
-! call ufbrep(lunin,amviii,12,irep_array,iret, 'LTDS SCLF SAID
-! SIID CHNM SCCF ORBN SAZA BEARAZ EHAM PRLC TMDBST')
-! deallocate( amviii )
-
- call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}')
- irep_array = int(rep_array)
- allocate( amvivr(2,irep_array))
- call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD')
- pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova
- deallocate( amvivr )
-
-! call ufbrep(lunin,rep_array,1,1,iret, '{AMVCLD}')
-! irep_array = int(rep_array)
-! allocate( amvcld(12,irep_array))
-! ! MUCE --> MUNCEX within the new GOES16/17 and NOAA-20 VIIRS
-! sequence (I.Genkova, J.Whiting)
-! ! THIS CHANGE HAS NOT BEEN TESTED !!!
-! !call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUCE
-! VSAT TMDBST VSAT CDTP MUCE OECS CDTP HOCT COPT')
-! call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUNCEX
-! VSAT TMDBST VSAT CDTP MUNCEX OECS CDTP HOCT COPT')
-! deallocate( amvcld )
-
- call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF
- qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR
- ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s]
- endif
+! call ufbint(lunin,rep_array,1,1,iret, '{AMVIII}')
+! irep_array = int(rep_array)
+! allocate( amviii(12,irep_array))
+! call ufbrep(lunin,amviii,12,irep_array,iret, 'LTDS SCLF SAID
+! SIID CHNM SCCF ORBN SAZA BEARAZ EHAM PRLC TMDBST')
+! deallocate( amviii )
+
+ call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}')
+ irep_array = int(rep_array)
+ allocate( amvivr(2,irep_array))
+ call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD')
+ pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova
+ deallocate( amvivr )
+
+! call ufbrep(lunin,rep_array,1,1,iret, '{AMVCLD}')
+! irep_array = int(rep_array)
+! allocate( amvcld(12,irep_array))
+! ! MUCE --> MUNCEX within the new GOES16/17 and NOAA-20 VIIRS
+! sequence (I.Genkova, J.Whiting)
+! ! THIS CHANGE HAS NOT BEEN TESTED !!!
+! !call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUCE
+! VSAT TMDBST VSAT CDTP MUCE OECS CDTP HOCT COPT')
+! call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUNCEX
+! VSAT TMDBST VSAT CDTP MUNCEX OECS CDTP HOCT COPT')
+! deallocate( amvcld )
+
+ call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC') ! AMVQIC:: GNAPS PCCF
+ qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR
+ ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s]
! Extra block for VIIRS NOAA20: End
! Extra block for GOES-R winds: Start
- else if(trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or. trim(subset) == 'NC005032' .or. & !IR(LW) / CS WV / VIS GOES-R like winds
- trim(subset) == 'NC005034' .or. trim(subset) == 'NC005039' ) then !CT WV / IR(SW) GOES-R like winds
-
- if(hdrdat(1) >=r250 .and. hdrdat(1) <=r299 ) then ! the range of NESDIS satellite IDs
- ! The sample newBUFR has SAID=259 (GOES-15)
- ! When GOES-R SAID is assigned, pls check
- ! if this range is still valid (Genkova))
- c_prvstg='NESDIS'
+ else if (istype >= 15 .and. istype <=20)then
+
+ c_prvstg='GOESR'
+ if(istype == 15) then ! IR LW winds
if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
- if(trim(subset) == 'NC005030') then ! IR LW winds
- itype=245
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- !write(6,*)'itype= ',itype
- else if(trim(subset) == 'NC005039') then ! IR SW winds
- itype=240
- c_station_id='IR'//stationid
- c_sprvstg='IR'
- !write(6,*)'itype= ',itype
- else if(trim(subset) == 'NC005032') then ! VIS winds
- itype=251
- c_station_id='VI'//stationid
- c_sprvstg='VI'
- !write(6,*)'itype= ',itype
- else if(trim(subset) == 'NC005034') then ! WV cloud top
- itype=246
- c_station_id='WV'//stationid
- c_sprvstg='WV'
- !write(6,*)'itype= ',itype
- else if(trim(subset) == 'NC005031') then ! WV clear sky/deep layer
- itype=247
- c_station_id='WV'//stationid
- c_sprvstg='WV'
+! itype=245
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ !write(6,*)'itype= ',itype
+ else if(istype == 16) then ! IR SW winds
+ if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
+! itype=240
+ c_station_id='IR'//stationid
+ c_sprvstg='IRSW'
+ !write(6,*)'itype= ',itype
+ else if(istype == 17) then ! VIS winds
+ if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
+! itype=251
+ c_station_id='VI'//stationid
+ c_sprvstg='VIS'
!write(6,*)'itype= ',itype
- endif
+ else if(istype == 18) then ! WV cloud top
+ if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
+! itype=246
+ c_station_id='WV'//stationid
+ c_sprvstg='WVCT'
+ !write(6,*)'itype= ',itype
+ else if(istype == 19) then ! WV clear sky/deep layer
+ if(hdrdat(10) >68.0_r_kind) cycle loop_readsb ! reject data zenith angle >68.0 degree
+! itype=247
+ c_station_id='WV'//stationid
+ c_sprvstg='WVCS'
+ !write(6,*)'itype= ',itype
+ else if(istype == 20) then ! WV clear sky/deep layer
+ hdrdat(10)=61.23 ! set zenith angle for CIMSS AMVs to 67 to pass QC, no value in origional data
+! itype=241
+ c_station_id='IR'//stationid
+ c_sprvstg='IR'
+ endif
-! call ufbint(lunin,rep_array,1,1,iret, '{AMVAHA}')
-! irep_array = int(rep_array)
-! allocate( amvaha(4,irep_array))
-! call ufbint(lunin,amvaha,4,irep_array,iret, 'EHAM PRLC TMDBST HOCT')
-! deallocate( amvaha )
-!
-! call ufbint(lunin,rep_array,1,1,iret, '{AMVIII}')
-! irep_array = int(rep_array)
-! allocate( amviii(12,irep_array))
-! call ufbrep(lunin,amviii,12,irep_array,iret, 'LTDS SCLF SAID SIID CHNM SCCF ORBN SAZA BEARAZ EHAM PRLC TMDBST')
-! deallocate( amviii )
-
- call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}')
- irep_array = int(rep_array)
- allocate( amvivr(2,irep_array))
- call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD')
- pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova
- deallocate( amvivr )
-
-! call ufbrep(lunin,rep_array,1,1,iret, '{AMVCLD}')
-! irep_array = int(rep_array)
-! allocate( amvcld(12,irep_array))
-! call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUCE VSAT TMDBST VSAT CDTP MUCE OECS CDTP HOCT COPT')
-! deallocate( amvcld )
-
- call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC')
- qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR
- ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s]
+! call ufbint(lunin,rep_array,1,1,iret, '{AMVAHA}')
+! irep_array = int(rep_array)
+! allocate( amvaha(4,irep_array))
+! call ufbint(lunin,amvaha,4,irep_array,iret, 'EHAM PRLC TMDBST HOCT')
+! deallocate( amvaha )
+
+! call ufbint(lunin,rep_array,1,1,iret, '{AMVIII}')
+! irep_array = int(rep_array)
+! allocate( amviii(12,irep_array))
+! call ufbrep(lunin,amviii,12,irep_array,iret, 'LTDS SCLF SAID SIID CHNM SCCF ORBN SAZA BEARAZ EHAM PRLC TMDBST')
+! deallocate( amviii )
+
+ if (itype /= 241) then
+
+ call ufbint(lunin,rep_array,1,1,iret, '{AMVIVR}')
+ irep_array = int(rep_array)
+ allocate( amvivr(2,irep_array))
+ call ufbrep(lunin,amvivr,2,irep_array,iret, 'TCOV CVWD')
+ pct1 = amvivr(2,1) ! use of pct1 (a new variable in the BUFR) is introduced by Nebuda/Genkova
+ deallocate( amvivr )
+
+! call ufbrep(lunin,rep_array,1,1,iret, '{AMVCLD}')
+! irep_array = int(rep_array)
+! allocate( amvcld(12,irep_array))
+! call ufbrep(lunin,amvcld,12,irep_array,iret, 'FOST CDTP MUCE VSAT TMDBST VSAT CDTP MUCE OECS CDTP HOCT COPT')
+! deallocate( amvcld )
+
+ call ufbseq(lunin,amvqic,2,4,iret, 'AMVQIC')
+ qifn = amvqic(2,2) ! QI w/ fcst does not exist in this BUFR
+ ee = amvqic(2,4) ! NOTE: GOES-R's ee is in [m/s]
! Additional QC introduced by Sharon Nebuda (for GOES-R winds from MSG proxy images)
- if (qifn < 80_r_kind .or. qifn > r100 ) qm=15 !reject data with low QI
- if (ppb < 125.0_r_kind) qm=15 !reject data above 125hPa: Trop check in setup.f90
- experr_norm = 10.0_r_kind - 0.1_r_kind * ee ! introduced by Santek/Nebuda
- if (obsdat(4) > 0.1_r_kind) then ! obsdat(4) is the AMV speed
- experr_norm = experr_norm/obsdat(4)
- else
- experr_norm = 100.0_r_kind
- end if
- if (experr_norm > 0.9_r_kind) qm=15 ! reject data with EE/SPD>0.9
-
- if(wrf_nmm_regional) then
- ! type 251 has been determine not suitable to be subjected to pct1 range check
- if(itype==240 .or. itype==245 .or. itype==246) then
- if (pct1 < 0.04_r_kind) qm=15
- if (pct1 > 0.50_r_kind) qm=15
- elseif (itype==251) then
- if (pct1 > 0.50_r_kind) qm=15
- endif
- else
- if(itype==240 .or. itype==245 .or. itype==246 .or. itype==251) then
- ! types 245 and 246 have been used to determine the acceptable pct1 range, but that pct1 range is applied to all GOES-R winds
- if (pct1 < 0.04_r_kind) qm=15
- if (pct1 > 0.50_r_kind) qm=15
- endif
- endif
+ if (qifn < 80_r_kind .or. qifn > r100 )then
+ qm=15 !reject data with low QI
+ else if (ppb < 125.0_r_kind) then
+ qm=15 !reject data above 125hPa: Trop check in setup.f90
+ else if (obsdat(4) > 0.1_r_kind) then ! obsdat(4) is the AMV speed
+ experr_norm = (10.0_r_kind - 0.1_r_kind * ee)/obsdat(4) ! introduced by Santek/Nebuda
+ if (experr_norm > 0.9_r_kind) qm=15 ! reject data with EE/SPD>0.9
+ else
+ qm=15
+ end if
+
+ if(wrf_nmm_regional) then
+ ! type 251 has been determine not suitable to be subjected to pct1 range check
+ if(itype==240 .or. itype==245 .or. itype==246 .or. itype==241) then
+ if (pct1 < 0.04_r_kind .or. pct1 > 0.50_r_kind) qm=15
+ elseif (itype==251) then
+ if (pct1 > 0.50_r_kind) qm=15
+ endif
+ else
+ if(itype==240 .or. itype==245 .or. itype==246 .or. itype==251) then
+ ! types 245 and 246 have been used to determine the acceptable pct1 range, but that pct1 range is applied to all GOES-R winds
+ if (pct1 < 0.04_r_kind .or. pct1 > 0.50_r_kind) qm=15
+ endif
+ endif
! GOES-16 additional QC addopting ECMWF's approach(Katie Lean,14IWW)-start
- if (EC_AMV_QC) then
- if (qifn < 90_r_kind .or. qifn > r100 ) qm=15 ! stricter QI
- if (ppb < 150.0_r_kind) qm=15 ! all high level
- if (itype==251 .and. ppb < 700.0_r_kind) qm=15 ! VIS
- if (itype==246 .and. ppb > 300.0_r_kind) qm=15 ! WVCA
- dlon_earth=hdrdat(3)*deg2rad
- dlat_earth=hdrdat(2)*deg2rad
- call deter_sfc_type(dlat_earth,dlon_earth,t4dv,isflg,tsavg)
- if (isflg == 1 .and. ppb > 850.0_r_kind) qm=15 ! low over land
- endif
+ if (EC_AMV_QC) then
+ if (qifn < 90_r_kind .or. qifn > r100 ) qm=15 ! stricter QI
+ if (ppb < 150.0_r_kind) qm=15 ! all high level
+ if (itype==251 .and. ppb < 700.0_r_kind) qm=15 ! VIS
+ if (itype==246 .and. ppb > 300.0_r_kind) qm=15 ! WVCA
+ if (qm < 15)then
+ dlon_earth=hdrdat(3)*deg2rad
+ dlat_earth=hdrdat(2)*deg2rad
+ call deter_sfc_type(dlat_earth,dlon_earth,t4dv,isflg,tsavg)
+ if (isflg == 1 .and. ppb > 850.0_r_kind) qm=15 ! low over land
+ end if
+ endif
+
+ else ! Assign values for the mnemonics/variables missing in original datafile for type 241
+
+ call ufbint(lunin,hdrdat_005099,2,1,iret, 'GNAPS PCCF');
+ qifn=hdrdat_005099(2);
+ qm=2 ! do not reject the wind
+ pct1=0.4_r_kind ! do not reject the wind
+ ee=1.0_r_kind ! do not reject the wind
+
+ endif
! winds rejected by qc dont get used
- if (qm == 15) usage=r100
- if (qm == 3 .or. qm ==7) woe=woe*r1_2
+ if (qm == 3 .or. qm ==7) woe=woe*r1_2
! set strings for diagnostic output
- if(itype==240 ) then; c_prvstg='GOESR' ; c_sprvstg='IRSW' ; endif
- if(itype==245 ) then; c_prvstg='GOESR' ; c_sprvstg='IR' ; endif
- if(itype==246 ) then; c_prvstg='GOESR' ; c_sprvstg='WVCT' ; endif
- if(itype==247 ) then; c_prvstg='GOESR' ; c_sprvstg='WVCS' ; endif
- if(itype==251 ) then; c_prvstg='GOESR' ; c_sprvstg='VIS' ; endif
- endif
+
! Extra block for GOES-R winds: End
else ! wind is not recognised and itype is not assigned
+ write(6,*) 'read_satwnd: WIND IS NOT RECOGNIZED ',istype,itype
cycle loop_readsb
endif
- if ( itype == -1 ) cycle loop_readsb ! unassigned itype
-
! assign types and get quality info : end
if ( qify == zero) qify=r110
@@ -1274,8 +1373,6 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
call grdcrd1(dlon,rlons,nlon,1)
endif
-
-
!! detect surface type for IR winds monitoring over land for lat greter than 20N
! isflg - surface flag
! 0 sea
@@ -1284,7 +1381,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
! 3 snow
! 4 mixed
if( .not. twodvar_regional) then
- if(itype ==245 .or. itype ==252 .or. itype ==253 .or. itype ==240) then
+ if(itype ==245 .or. itype ==252 .or. itype ==253 .or. itype ==240 .or. itype ==241) then
if(hdrdat(2) >20.0_r_kind) then
call deter_sfc_type(dlat_earth,dlon_earth,t4dv,isflg,tsavg)
if(isflg /= 0) cycle loop_readsb
@@ -1386,7 +1483,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
endif ! end of njqc
if((itype==245 .or. itype==246) &
- .and. (trim(subset) == 'NC005010' .or. trim(subset) == 'NC005011' .or. trim(subset) == 'NC005012' )) then !only applies to AMVs from legacy algorithm (pre GOES-R)
+ .and. istype == 7) then !only applies to AMVs from legacy algorithm (pre GOES-R)
! using Santek quality control method,calculate the original ee value:
! NOTE: Up until GOES-R winds algorithm, EE (expected error, ee) is reported as percent 0-100% (the higher the ee, the better the wind quality)
! NOTE: In the new GOES-R BUFR, EE (expected error, ee) is reported in m/s (the smaller the ee, the better the wind quality)
@@ -1410,16 +1507,10 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
! Reduce OE for the GOES-R winds by half following Sharon Nebuda's work
! GOES-R wind are identified/recognised here by subset, but it could be done by itype or SAID
! After completing the evaluation of GOES-R winds, REVISE this section!!!
- if(trim(subset) == 'NC005030' .or. trim(subset) == 'NC005031' .or. trim(subset) == 'NC005032' .or. &
- trim(subset) == 'NC005034' .or. trim(subset) == 'NC005039' ) then
+ if(istype >= 15 .and. istype <=20)then
obserr=obserr/two
endif
-! Set usage variable
- usage = 0
- iuse=icuse(nc)
- if(iuse <= 0)usage=r100
- if(qm == 15 .or. qm == 12 .or. qm == 9)usage=r100
! if(itype==240) then; c_prvstg='NESDIS' ; c_sprvstg='IR' ; endif
! if(itype==242) then; c_prvstg='JMA' ; c_sprvstg='VI' ; endif
! if(itype==243) then; c_prvstg='EUMETSAT' ; c_sprvstg='VI' ; endif
@@ -1444,9 +1535,9 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
!! process the thining procedure
ithin=ithin_conv(nc)
- ithinp = ithin > 0 .and. ithin <5 .and. pflag /= 0
+ ithinp = ithin > 0 .and. ithin <5 .and. qm < 4
! if(ithinp .and. iuse >=0 )then
- if(ithinp )then
+ if(ithinp .and. pflag /= 0 )then
! Interpolate guess pressure profile to observation location
klon1= int(dlon); klat1= int(dlat)
dx = dlon-klon1; dy = dlat-klat1
@@ -1465,31 +1556,23 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
! Compute depth of guess pressure layersat observation location
end if
+
dlnpob=log(one_tenth*ppb) ! ln(pressure in cb)
ppb=one_tenth*ppb ! from mb to cb
! Special block for data thinning - if requested
- if (ithin > 0 .and. ithin <5 .and. iuse >=0 .and. qm <4) then
- ntmp=ndata ! counting moved to map3gridS
+ if (ithinp) then
! Set data quality index for thinning
if (thin4d) then
timedif = zero
else
timedif=abs(t4dv-toff)
endif
+ crit1 = timedif/r6+half
if(itype == 243 .or. itype == 253 .or. itype == 254) then
- if(qifn zero ) then
itime=int((tdiff+three)/ptime)+1
if (itime >ntime) itime=ntime
- if(pmot 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+2
- endif
- rusage(iout)=usage
- isort(ntb)=iout
- else
-! call map3grids_m_tm(-1,pflag,presl_thin,nlevp,ntime,dlat_earth,dlon_earth,&
- call map3grids_m_tm(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
- ppb,itime,crit1,ndata,iout,ntb,iiout,luse,maxobs,usage,rusage,.false.,.false.)
- if (ndata > ntmp) then
- nodata=nodata+2
- endif
- isort(ntb)=iout
- endif
- else
- if(pmot 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+2
- endif
- isort(ntb)=iout
- rusage(iout)=usage
- else
- call map3grids_m(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
- ppb,crit1,ndata,iout,ntb,iiout,luse,maxobs,usage,rusage,.false.,.false.)
- if (ndata > ntmp) then
- nodata=nodata+2
- endif
- isort(ntb)=iout
- endif
+ call map3grids_m_tm(-1,save_all,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
+ ppb,itime,crit1,ndata,luse,maxobs,rthin,.false.,.false.)
+ else
+ call map3grids_m(-1,save_all,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
+ ppb,crit1,ndata,luse,maxobs,rthin,.false.,.false.)
endif
+ if(.not. luse) cycle loop_readsb
else
ndata=ndata+1
- nodata=nodata+2
- iout=ndata
- isort(ntb)=iout
- rusage(iout)=usage
endif
+ iout=ndata
+ iuse=icuse(nc)
+ if(iuse < 0)qm = 9
+ if(qm > 7 .or. iuse < 0 )rusage(iout)=.false.
inflate_error=.false.
if (qm==3 .or. qm==7) inflate_error=.true.
woe=obserr
@@ -1574,7 +1624,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
cdata_all(11,iout)=qifn +1000.0_r_kind*qify ! quality indicator
cdata_all(12,iout)=qm ! quality mark
cdata_all(13,iout)=obserr ! original obs error
- cdata_all(14,iout)=usage ! usage parameter
+ cdata_all(14,iout)=0 ! usage parameter
cdata_all(15,iout)=idomsfc ! dominate surface type
cdata_all(16,iout)=tsavg ! skin temperature
cdata_all(17,iout)=ff10 ! 10 meter wind factor
@@ -1587,12 +1637,21 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
cdata_all(25,iout)=var_jb ! non linear qc parameter
cdata_all(26,iout)=one ! hilbert curve weight
cdata_all(27,iout)=obsdat(5) ! AMVQ for GOES-17 mitig.AMVs
+ ! extra variables for satwind qc for brett
+ cdata_all(28,iout)=hdrdat(9) ! wind computation method
+ cdata_all(29,iout)=hdrdat(10) ! satellite zenith angle
+ cdata_all(30,iout)=hdrdat(1) ! satellite identifier
+ cdata_all(31,iout)=qifn ! QI without forecast
+ cdata_all(32,iout)=qify ! QI with forecast
+ cdata_all(33,iout)=ee ! expected error
+ cdata_all(34,iout)=pct1
if(perturb_obs)then
- cdata_all(28,iout)=ran01dom()*perturb_fact ! u perturbation
- cdata_all(29,iout)=ran01dom()*perturb_fact ! v perturbation
+ cdata_all(35,iout)=ran01dom()*perturb_fact ! u perturbation
+ cdata_all(36,iout)=ran01dom()*perturb_fact ! v perturbation
endif
+
enddo loop_readsb
! End of bufr read loop
enddo loop_msg
@@ -1605,52 +1664,72 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
deallocate(presl_thin)
call del3grids_tm
endif
-
! Normal exit
-
enddo loop_convinfo! loops over convinfo entry matches
deallocate(lmsg,tab,nrep)
! Close unit to bufr file
call closbf(lunin)
-
-
- ! Write header record and data to output file for further processing
- allocate(iloc(ndata))
- icount=0
- do i=1,maxobs
- if(isort(i) > 0)then
- icount=icount+1
- iloc(icount)=isort(i)
- end if
- end do
- if(ndata /= icount)then
- write(6,*) ' READ_SATWND: mix up in read_satwnd ,ndata,icount ',ndata,icount
- call stop2(49)
- end if
-
- allocate(cdata_out(nreal,ndata))
- do i=1,ndata
- itx=iloc(i)
- do k=1,13
- cdata_out(k,i)=cdata_all(k,itx)
+!
+ if(ndata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,ndata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' smar ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin
+! If thinned data set usage
+ do i=1,ndata
+ if(rthin(i))then
+ cdata_all(12,i)=14
+ cdata_all(14,i)=101.0_r_kind
+ end if
+ if(.not. rusage(i))cdata_all(14,i) = 100.0_r_kind
end do
- cdata_out(14,i)=rusage(itx)
- do k=15,nreal
- cdata_out(k,i)=cdata_all(k,itx)
+ nxdata=ndata
+! If flag to not save thinned data is set - compress data
+ ndata=0
+ do i=1,nxdata
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 1) .or. &
+ (pmot == 2 .and. rusage(i) .and. .not. rthin(i)) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ ndata=ndata+1
+ do k=1,nreal
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
end do
- end do
- deallocate(iloc,isort,cdata_all,rusage)
+ nodata=nodata+2*ndata
+ end if
+ deallocate(rusage,rthin)
+
+
+ ! Write header record and data to output file for further processing
- call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs)
+ call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
- write(lunout) cdata_out
+ write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata)
+
+ deallocate(cdata_all)
- deallocate(cdata_out)
-900 continue
- if(diagnostic_reg .and. ntest>0) write(6,*)'READ_SATWND: ',&
+ if(diagnostic_reg)then
+ if(ntest>0) write(6,*)'READ_SATWND: ',&
'ntest,disterrmax=',ntest,disterrmax
- if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_SATWND: ',&
+ if(nvtest>0) write(6,*)'READ_SATWND: ',&
'nvtest,vdisterrmax=',ntest,vdisterrmax
+ end if
if (ndata == 0) then
write(6,*)'READ_SATWND: closbf(',lunin,')'
diff --git a/src/gsi/read_sfcwnd.f90 b/src/gsi/read_sfcwnd.f90
index 05c96b21fc..07fed808c7 100644
--- a/src/gsi/read_sfcwnd.f90
+++ b/src/gsi/read_sfcwnd.f90
@@ -48,19 +48,19 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
use gridmod, only: diagnostic_reg,regional,nlon,nlat,nsig,&
tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,&
rlats,rlons,fv3_regional
- use qcmod, only: errormod,noiqc,njqc
+ use qcmod, only: errormod,njqc
- use convthin, only: make3grids,map3grids,del3grids,use_all
+ use convthin, only: make3grids,map3grids_m,del3grids,use_all
use constants, only: deg2rad,zero,rad2deg,one_tenth,&
tiny_r_kind,huge_r_kind,r60inv,one_tenth,&
one,two,three,four,five,half,quarter,r60inv,r10,r100,r2000
use converr,only: etabl
use converr_uv,only: etabl_uv,isuble_uv,maxsub_uv
use convb_uv,only: btabl_uv
- use obsmod, only: ran01dom,bmiss
+ use obsmod, only: ran01dom,bmiss,reduce_diag
use convinfo, only: nconvtype, &
icuse,ictype,icsubtype,ioctype, &
- ithin_conv,rmesh_conv,pmesh_conv
+ ithin_conv,rmesh_conv,pmesh_conv,pmot_conv
use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,winlen,time_4dvar,thin4d
use deter_sfc_mod, only: deter_sfc_type,deter_sfc2
use mpimod, only: npe
@@ -97,13 +97,12 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
integer(i_kind) ireadmg,ireadsb,iuse,mxtb,nmsgmax
integer(i_kind) i,maxobs,idomsfc,nsattype,j,ncount
- integer(i_kind) nc,nx,isflg,itx,nchanl
+ integer(i_kind) nc,nx,isflg,nchanl
integer(i_kind) ntb,ntmatch,ncx,ncsave,ntread
integer(i_kind) kk,klon1,klat1,klonp1,klatp1
integer(i_kind) nmind,lunin,idate,ilat,ilon,iret,k
- integer(i_kind) nreal,ithin,iout,ntmp,icount,iiout,ii
+ integer(i_kind) nreal,ithin,iout,ii
integer(i_kind) itype,iosub,ixsub,isubsub,iobsub
- integer(i_kind) lim_qm
integer(i_kind) nlevp ! vertical level for thinning
integer(i_kind) pflag
integer(i_kind) ntest,nvtest
@@ -117,7 +116,7 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
integer(i_kind),dimension(nconvtype+1) :: ntx
integer(i_kind),dimension(5):: idate5
- integer(i_kind),allocatable,dimension(:):: isort,iloc,nrep
+ integer(i_kind),allocatable,dimension(:):: nrep
integer(i_kind),allocatable,dimension(:,:)::tab
! integer(i_kind) itypex,lcount,iflag,m
@@ -143,7 +142,13 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
real(r_double),dimension(5,4):: wnddat
real(r_double),dimension(1,1):: r_prvstg,r_sprvstg
real(r_kind),allocatable,dimension(:):: presl_thin
- real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out
+ real(r_kind),allocatable,dimension(:,:):: cdata_all
+
+ logical,allocatable,dimension(:)::rthin,rusage
+ logical save_all
+! integer(i_kind) numthin,numqc,numrem,numall
+ integer(i_kind) nxdata,pmot
+
! equivalence to handle character names
equivalence(r_prvstg(1,1),c_prvstg)
@@ -200,11 +205,6 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
werrmin=one
nsattype=0
nreal=24
- if (noiqc) then
- lim_qm=8
- else
- lim_qm=4
- endif
! ** read convtype from convinfo file
! ** only read in OSCAT 291 for now **
@@ -239,7 +239,7 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
call getcount_bufr(infile,nmsgmax,mxtb)
- allocate(lmsg(nmsgmax,ntread),tab(mxtb,3),nrep(nmsgmax))
+ allocate(lmsg(nmsgmax,ntread),tab(mxtb,2),nrep(nmsgmax))
lmsg = .false.
maxobs=0
@@ -321,7 +321,6 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
end if
tab(ntb,1)=ncsave
tab(ntb,2)=nx
- tab(ntb,3)=1
lmsg(nmsg,nx) = .true.
end if
enddo loop_report
@@ -329,9 +328,7 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
! Loop over convinfo file entries; operate on matches
- allocate(cdata_all(nreal,maxobs),isort(maxobs))
- isort = 0
- cdata_all=zero
+ allocate(cdata_all(nreal,maxobs),rusage(maxobs),rthin(maxobs))
nread=0
ntest=0
nvtest=0
@@ -342,15 +339,19 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
!! read satellite winds one type a time
! same as in the read_prepbufr.f90 file
+ rusage = .true.
+ rthin = .false.
loop_convinfo: do nx=1,ntread
use_all = .true.
ithin=0
+ pmot=0
if(nx >1) then
nc=ntx(nx)
ithin=ithin_conv(nc)
if (ithin > 0 ) then
rmesh=rmesh_conv(nc)
pmesh=pmesh_conv(nc)
+ pmot = pmot_conv(nc)
use_all = .false.
if(pmesh > zero) then
pflag=1
@@ -376,6 +377,9 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
ioctype(nc),ictype(nc),rmesh,pflag,nlevp,pmesh,nc
endif
endif
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
call closbf(lunin)
close(lunin)
@@ -473,9 +477,7 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
if(obsdat(3) >=1) cycle loop_readsb
if(trim(subset) == 'NC012255') then ! OSCAT KNMI wind
- if( hdrdat(1) == r421) then
- itype=291
- endif
+ if( hdrdat(1) == r421) itype=291
endif
@@ -642,7 +644,6 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
! Special block for data thinning - if requested
if (ithin > 0 .and. iuse >=0) then
- ntmp=ndata ! counting moved to map3gridS
! Set data quality index for thinning
if (thin4d) then
@@ -659,22 +660,16 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
end do
endif
- call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
- ppb,crit1,ndata,iout,ntb,iiout,luse,.false.,.false.)
+ call map3grids_m(-1,save_all,pflag,presl_thin,nlevp, &
+ dlat_earth,dlon_earth,ppb,crit1,ndata,&
+ luse,maxobs,rthin,.false.,.false.)
if (.not. luse) cycle loop_readsb
- if(iiout > 0) isort(iiout)=0
- if (ndata > ntmp) then
- nodata=nodata+2
- endif
- isort(ntb)=iout
else
ndata=ndata+1
- nodata=nodata+2
- iout=ndata
- isort(ntb)=iout
endif
+ iout=ndata
woe=obserr
oelev=r10
@@ -718,6 +713,7 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
cdata_all(22,iout)=r_prvstg(1,1) ! provider name
cdata_all(23,iout)=r_sprvstg(1,1) ! subprovider name
cdata_all(24,iout)=var_jb ! non linear qc parameter
+ if(usage >= r100)rusage(ndata)=.false.
enddo loop_readsb
@@ -729,43 +725,69 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
deallocate(presl_thin)
call del3grids
endif
+
! Normal exit
enddo loop_convinfo! loops over convinfo entry matches
call closbf(lunin)
deallocate(lmsg,nrep,tab)
-
- ! Write header record and data to output file for further processing
- allocate(iloc(ndata))
- icount=0
- do i=1,maxobs
- if(isort(i) > 0)then
- icount=icount+1
- iloc(icount)=isort(i)
- end if
- end do
- if(ndata /= icount)then
- write(6,*) ' READ_SFCWND: mix up in read_satwnd ,ndata,icount ',ndata,icount
- call stop2(49)
+ nxdata=ndata
+ ndata=0
+ if(nxdata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,nxdata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' sfc ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin
+! If thinned data set usage
+ do i=1,nxdata
+ if(rthin(i))then
+ cdata_all(14,i)=101._r_kind
+ cdata_all(12,i)=14
+ end if
+ end do
+! If flag to not save thinned data is set - compress data
+ do i=1,nxdata
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 1) .or. &
+ (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ ndata=ndata+1
+ if(i > ndata)then
+ do k=1,nreal
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
+ end if
+ end do
+ nodata=nodata+ndata
end if
+ ! Write header record and data to output file for further processing
+ deallocate(rusage,rthin)
- allocate(cdata_out(nreal,ndata))
- do i=1,ndata
- itx=iloc(i)
- do k=1,nreal
- cdata_out(k,i)=cdata_all(k,itx)
- end do
- end do
- deallocate(iloc,isort,cdata_all)
! deallocate(etabl)
+ close(lunin)
- call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs)
+ call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
- write(lunout) cdata_out
+ write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata)
- deallocate(cdata_out)
-900 continue
+ deallocate(cdata_all)
+
if(diagnostic_reg .and. ntest>0) write(6,*)'READ_SFCWND: ',&
'ntest,disterrmax=',ntest,disterrmax
if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_SFCWND: ',&
@@ -777,7 +799,6 @@ subroutine read_sfcwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis
write(6,*) 'READ_SFCWND,nread,ndata,nreal,nodata=',nread,ndata,nreal,nodata
- close(lunin)
! End of routine
return
diff --git a/src/gsi/read_ssmi.f90 b/src/gsi/read_ssmi.f90
index 3e47ee79b5..cece78ac03 100755
--- a/src/gsi/read_ssmi.f90
+++ b/src/gsi/read_ssmi.f90
@@ -132,7 +132,8 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,&
real(r_kind),parameter:: tbmin=70.0_r_kind
real(r_kind),parameter:: tbmax=320.0_r_kind
character(80),parameter:: hdr1b='SAID YEAR MNTH DAYS HOUR MINU SECO ORBN' !use for ufbint()
- character(40),parameter:: str1='CLAT CLON SFTG POSN SAZA' !use for ufbint()
+ character(40),parameter:: str1='CLATH CLONH SFTG POSN SAZA' !use for ufbint() new
+ character(40),parameter:: strx='CLAT CLON SFTG POSN SAZA' !use for ufbint() old
character(40),parameter:: str2='TMBR' !use for ufbrep()
! Declare local variables
@@ -302,6 +303,7 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,&
! SSM/I data are stored in groups of nscan, hence the loop.
call ufbint(lnbufr,midat,nloc,nscan,iret,str1)
+ if(midat(1,1)>10e8) call ufbint(lnbufr,midat,nloc,nscan,iret,strx)
!--- Extract brightness temperature data. Apply gross check to data.
@@ -309,7 +311,6 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,&
call ufbrep(lnbufr,mirad,1,nchanl*nscan,iret,str2)
-
ij=0
scan_loop: do js=1,nscan
@@ -511,7 +512,6 @@ subroutine read_ssmi(mype,val_ssmi,ithin,rmesh,jsatid,gstime,&
end do read_loop
end do read_subset
call closbf(lnbufr)
- close(lnbufr)
! If multiple tasks read input bufr file, allow each tasks to write out
! information it retained and then let single task merge files together
diff --git a/src/gsi/read_viirs.f90 b/src/gsi/read_viirs.f90
index 66923c9896..ab80642f29 100644
--- a/src/gsi/read_viirs.f90
+++ b/src/gsi/read_viirs.f90
@@ -198,6 +198,7 @@ subroutine read_sst_viirs(mype,val_viirs,ithin,rmesh,jsatid,&
bufsat = 226
else
write(*,*) 'READ_SST_VIIRS: Unrecognized value for jsatid '//jsatid//':RETURNING'
+ deallocate(amesh,hsst_thd)
return
end if
@@ -516,7 +517,7 @@ subroutine read_sst_viirs(mype,val_viirs,ithin,rmesh,jsatid,&
endif
! Deallocate local arrays
- deallocate(data_all)
+ deallocate(data_all,amesh,hsst_thd)
if(diagnostic_reg.and.ntest>0 .and. mype_sub==mype_root) &
write(6,*)'READ_VIIRS-M: ',&
diff --git a/src/gsi/read_wcpbufr.f90 b/src/gsi/read_wcpbufr.f90
index 41dc36f3f6..65e70f4be8 100644
--- a/src/gsi/read_wcpbufr.f90
+++ b/src/gsi/read_wcpbufr.f90
@@ -47,11 +47,11 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
tll2xy,txy2ll, rlats,rlons
use convinfo, only: nconvtype,ctwind, &
ncmiter,ncgroup,ncnumgrp,icuse,ictype,icsubtype,ioctype, &
- ithin_conv,rmesh_conv,pmesh_conv
+ ithin_conv,rmesh_conv,pmesh_conv,pmot_conv
use converr,only: etabl
- use obsmod, only: iadate, offtime_data, oberrflg
+ use obsmod, only: iadate, offtime_data, oberrflg,reduce_diag
use gsi_4dvar, only: l4dvar,l4densvar,time_4dvar,winlen,thin4d
- use convthin, only: make3grids,map3grids,del3grids,use_all
+ use convthin, only: make3grids,map3grids_m,del3grids,use_all
use mpimod, only: npe
implicit none
@@ -85,15 +85,15 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
character(8) c_station_id
character(1) sidchr(8)
- integer(i_kind) ireadmg,ireadsb,icntpnt,icntpnt2,icount,iiout
+ integer(i_kind) ireadmg,ireadsb,icntpnt,icntpnt2
integer(i_kind) lunin,i,maxobs,nmsgmax,mxtb
integer(i_kind) kk,klon1,klat1,klonp1,klatp1
- integer(i_kind) nc,nx,ntread,itx,ii,ncsave
+ integer(i_kind) nc,nx,ntread,ii,ncsave
integer(i_kind) ihh,idd,idate,iret,im,iy,k,levs
integer(i_kind) kx,nreal,nchanl,ilat,ilon,ithin
integer(i_kind) qm, swcpq, lwcpq
integer(i_kind) nlevp ! vertical level for thinning
- integer(i_kind) ntmp,iout
+ integer(i_kind) iout
integer(i_kind) pflag,irec
integer(i_kind) ntest,nvtest,iosub,ixsub,isubsub,iobsub
integer(i_kind) kl,k1,k2
@@ -105,7 +105,7 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
integer(i_kind),dimension(255):: pqm
integer(i_kind),dimension(nconvtype)::ntxall
integer(i_kind),dimension(nconvtype+1)::ntx
- integer(i_kind),allocatable,dimension(:):: isort,iloc,nrep
+ integer(i_kind),allocatable,dimension(:):: nrep
integer(i_kind),allocatable,dimension(:,:):: tab
real(r_kind) time,timex,timeobs,toff,t4dv,zeps
real(r_kind) rmesh,ediff,usage
@@ -125,7 +125,12 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
real(r_kind),dimension(nsig-1):: dpres
real(r_kind),dimension(255)::plevs
real(r_kind),allocatable,dimension(:):: presl_thin
- real(r_kind),allocatable,dimension(:,:):: cdata_all,cdata_out
+ real(r_kind),allocatable,dimension(:,:):: cdata_all
+ logical,allocatable,dimension(:)::rthin,rusage
+ logical save_all
+! integer(i_kind) numthin,numqc,numrem
+ integer(i_kind) nxdata,pmot,numall
+
real(r_double) rstation_id,qcmark_huge
real(r_double),dimension(8):: hdr
@@ -294,25 +299,28 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! loop over convinfo file entries; operate on matches
- allocate(cdata_all(nreal,maxobs),isort(maxobs))
- isort = 0
- cdata_all=zero
+ allocate(cdata_all(nreal,maxobs),rusage(maxobs),rthin(maxobs))
nread=0
ntest=0
nvtest=0
nchanl=0
ilon=2
ilat=3
+ rusage = .true.
+ rthin = .false.
loop_convinfo: do nx=1, ntread
use_all = .true.
ithin=0
+ pmot=0
+
if(nx > 1) then
nc=ntx(nx)
ithin=ithin_conv(nc)
if (ithin > 0 ) then
rmesh=rmesh_conv(nc)
pmesh=pmesh_conv(nc)
+ pmot=nint(pmot_conv(nc))
use_all = .false.
if(pmesh > zero) then
pflag=1
@@ -338,6 +346,9 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
trim(ioctype(nc)),ictype(nc),rmesh,pflag,nlevp,pmesh
endif
endif
+ if(reduce_diag .and. pmot < 2)pmot=pmot+2
+ save_all=.false.
+ if(pmot /= 2 .and. pmot /= 0) save_all=.true.
call closbf(lunin)
@@ -380,32 +391,32 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
call ufbint(lunin,hdr,8,1,iret,hdstr)
kx=hdr(5)
- if(abs(hdr(3))>r90 .or. abs(hdr(2))>r360) cycle loop_readsb
- if(hdr(2)== r360)hdr(2)=hdr(2)-r360
- if(hdr(2) < zero)hdr(2)=hdr(2)+r360
- dlon_earth_deg=hdr(2)
- dlat_earth_deg=hdr(3)
- dlon_earth=hdr(2)*deg2rad
- dlat_earth=hdr(3)*deg2rad
-
- if(regional)then
- call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) ! convert to rotated coordinate
- if(diagnostic_reg) then
- call txy2ll(dlon,dlat,rlon00,rlat00)
- ntest=ntest+1
- cdist=sin(dlat_earth)*sin(rlat00)+cos(dlat_earth)*cos(rlat00)* &
- (sin(dlon_earth)*sin(rlon00)+cos(dlon_earth)*cos(rlon00))
- cdist=max(-one,min(cdist,one))
- disterr=acos(cdist)*rad2deg
- disterrmax=max(disterrmax,disterr)
- end if
- if(outside) cycle loop_readsb ! check to see if outside regional domain
- else
- dlat = dlat_earth
- dlon = dlon_earth
- call grdcrd1(dlat,rlats,nlat,1)
- call grdcrd1(dlon,rlons,nlon,1)
- endif
+ if(abs(hdr(3))>r90 .or. abs(hdr(2))>r360) cycle loop_readsb
+ if(hdr(2)== r360)hdr(2)=hdr(2)-r360
+ if(hdr(2) < zero)hdr(2)=hdr(2)+r360
+ dlon_earth_deg=hdr(2)
+ dlat_earth_deg=hdr(3)
+ dlon_earth=hdr(2)*deg2rad
+ dlat_earth=hdr(3)*deg2rad
+
+ if(regional)then
+ call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) ! convert to rotated coordinate
+ if(diagnostic_reg) then
+ call txy2ll(dlon,dlat,rlon00,rlat00)
+ ntest=ntest+1
+ cdist=sin(dlat_earth)*sin(rlat00)+cos(dlat_earth)*cos(rlat00)* &
+ (sin(dlon_earth)*sin(rlon00)+cos(dlon_earth)*cos(rlon00))
+ cdist=max(-one,min(cdist,one))
+ disterr=acos(cdist)*rad2deg
+ disterrmax=max(disterrmax,disterr)
+ end if
+ if(outside) cycle loop_readsb ! check to see if outside regional domain
+ else
+ dlat = dlat_earth
+ dlon = dlon_earth
+ call grdcrd1(dlat,rlats,nlat,1)
+ call grdcrd1(dlon,rlons,nlon,1)
+ endif
!------------------------------------------------------------------------
@@ -430,28 +441,28 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
! Add obs reference time, then subtract analysis time to get obs time relative to analysis
- time_correction=float(minobs-minan)*r60inv
+ time_correction=real(minobs-minan,r_kind)*r60inv
else
time_correction=zero
end if
- timeobs=real(real(hdr(4),r_single),r_double)
- t4dv=timeobs + toff
- zeps=1.0e-8_r_kind
- if (t4dv -zeps) t4dv=zero
- if (t4dv>winlen.and.t4dv -zeps) t4dv=zero
+ if (t4dv>winlen.and.t4dvwinlen) cycle loop_readsb ! outside time window
- else
- if((real(abs(time)) > real(ctwind(nc)) .or. real(abs(time)) > real(twindin)))cycle loop_readsb ! outside time window
- endif
+ if (l4dvar.or.l4densvar) then
+ if (t4dvwinlen) cycle loop_readsb ! outside time window
+ else
+ if((real(abs(time)) > real(ctwind(nc)) .or. real(abs(time)) > real(twindin)))cycle loop_readsb ! outside time window
+ endif
- timex=time
+ timex=time
! Extract data information on levels
call ufbint(lunin,obsdat,5,255,levs,obstr)
@@ -550,9 +561,11 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
if(qm > 15 .or. qm < 0) cycle loop_k_levs
+! Set usage variable
+ usage = zero
+
! Special block for data thinning - if requested
if (ithin > 0) then
- ntmp=ndata ! counting moved to map3gridS
! Set data quality index for thinning
if (thin4d) then
@@ -568,9 +581,12 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
end do
endif
- call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
- plevs(k),crit1,ndata,iout,icntpnt,iiout,luse,.false.,.false.)
+ call map3grids_m(-1,save_all,pflag,presl_thin,nlevp, &
+ dlat_earth,dlon_earth,plevs(k),crit1,ndata,&
+ luse,maxobs,rthin,.false.,.false.)
+
+ if(rthin(ndata))usage=101._r_kind
if (.not. luse) then
if(k==levs) then
cycle loop_readsb
@@ -578,26 +594,17 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
cycle LOOP_K_LEVS
endif
endif
- if(iiout > 0) isort(iiout)=0
- if(ndata > ntmp)then
- nodata=nodata+1
- end if
- isort(icntpnt)=iout
else
ndata=ndata+1
- nodata=nodata+1
- iout=ndata
- isort(icntpnt)=iout
endif
+ iout=ndata
if(ndata > maxobs) then
write(6,*)'READ_WCPBUFR: ***WARNING*** ndata > maxobs for ',obstype
ndata = maxobs
end if
-! Set usage variable
- usage = zero
if(icuse(nc) <= 0)usage=100._r_kind
@@ -610,6 +617,7 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
if(ncnumgrp(nc)>0 )then ! default cross validation on
if(mod(ndata+1,ncnumgrp(nc))== ncgroup(nc)-1)usage=ncmiter(nc)
end if
+ if(icuse(nc) <= 0 .or. qm >= 8) rusage(iout) = .false.
! Extract pressure level and quality marks
dlnpob=log(plevs(k)) ! ln(pressure in cb)
@@ -670,7 +678,6 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
deallocate(presl_thin)
call del3grids
endif
-
! Normal exit
enddo loop_convinfo! loops over convinfo entry matches
@@ -679,35 +686,56 @@ subroutine read_wcpbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
close(lunin)
deallocate(lmsg,tab,nrep)
-! Write header record and data to output file for further processing
- allocate(iloc(ndata))
- icount=0
- do i=1,maxobs
- if(isort(i) > 0)then
- icount=icount+1
- iloc(icount)=isort(i)
- end if
- end do
- if(ndata /= icount)then
- write(6,*) ' WCPBUFR: mix up in read_wcpbufr ,ndata,icount ',ndata,icount
- call stop2(50)
- end if
- allocate(cdata_out(nreal,ndata))
- do i=1,ndata
- itx=iloc(i)
- do k=1,nreal
- cdata_out(k,i)=cdata_all(k,itx)
+ nxdata=ndata
+ nodata=0
+ if(nxdata > 0)then
+! numthin=0
+! numqc=0
+! numrem=0
+! do i=1,nxdata
+! if(.not. rusage(i))then
+! numqc=numqc+1
+! else if(rthin(i))then
+! numthin=numthin+1
+! else
+! numrem=numrem+1
+! end if
+! end do
+! write(6,*) ' wcp ',trim(ioctype(nc)),ictype(nc),icsubtype(nc),numall,numrem,numqc,numthin
+! If thinned data set usage
+ do i=1,nxdata
+ if(rthin(i))cdata_all(11,i)=100._r_kind
end do
- end do
- deallocate(iloc,isort,cdata_all)
+! If flag to not save thinned data is set - compress data
+ do i=1,nxdata
+! pmot=0 - all obs - thin obs
+! pmot=1 - all obs
+! pmot=2 - use obs
+! pmot=3 - use obs + thin obs
+ if((pmot == 0 .and. .not. rthin(i)) .or. &
+ (pmot == 1) .or. &
+ (pmot == 2 .and. (rusage(i) .and. .not. rthin(i))) .or. &
+ (pmot == 3 .and. rusage(i))) then
+
+ ndata=ndata+1
+ do k=1,nreal
+ cdata_all(k,ndata)=cdata_all(k,i)
+ end do
+ end if
+ end do
+ nodata=nodata+ndata
+ end if
+
+ deallocate(rusage,rthin)
+
+! Write header record and data to output file for further processing
- call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs)
+ call count_obs(ndata,nreal,ilat,ilon,cdata_all,nobs)
write(lunout) obstype,sis,nreal,nchanl,ilat,ilon,ndata
- write(lunout) cdata_out
+ write(lunout) ((cdata_all(k,i),k=1,nreal),i=1,ndata)
- deallocate(cdata_out)
+ deallocate(cdata_all)
-900 continue
if(diagnostic_reg .and. ntest>0) write(6,*)'READ_WCPBUFR: ',&
'ntest,disterrmax=',ntest,disterrmax
if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_WCPBUFR: ',&
diff --git a/src/gsi/reorg_metar_cloud.f90 b/src/gsi/reorg_metar_cloud.f90
index 2d947f2ef3..478d1ab363 100644
--- a/src/gsi/reorg_metar_cloud.f90
+++ b/src/gsi/reorg_metar_cloud.f90
@@ -264,9 +264,9 @@ subroutine reorg_metar_cloud(cdata,nreal,ndata,cdata_all,maxobs,ngrid)
min_dist = 1.e10_r_kind
do ic= 1,nsta_cld
ista = sta_cld(ic)
- dist = (float(i1)-cdata(2,ista))*(float(i1)-cdata(2,ista)) &
- +(float(j1)-cdata(3,ista))*(float(j1)-cdata(3,ista))
- if (dist < min_dist .and. dist < float(isprd2)) then
+ dist = (real(i1,r_kind)-cdata(2,ista))*(real(i1,r_kind)-cdata(2,ista)) &
+ +(real(j1,r_kind)-cdata(3,ista))*(real(j1,r_kind)-cdata(3,ista))
+ if (dist < min_dist .and. dist < real(isprd2,r_kind)) then
min_dist = dist
ista_min = ista
end if
@@ -318,8 +318,8 @@ subroutine reorg_metar_cloud(cdata,nreal,ndata,cdata_all,maxobs,ngrid)
enddo
cdata_all(24,iout) = cdata_all(2,iout) ! save observaion station i
cdata_all(25,iout) = cdata_all(3,iout) ! save observaion station j
- cdata_all(2,iout) = float(i1) ! grid index i
- cdata_all(3,iout) = float(j1) ! grid index j
+ cdata_all(2,iout) = real(i1,r_kind) ! grid index i
+ cdata_all(3,iout) = real(j1,r_kind) ! grid index j
cdata_all(23,iout)= min_dist ! distance from station
endif
endif
diff --git a/src/gsi/rfdpar.f90 b/src/gsi/rfdpar.f90
index 79fa959bcb..b679ed6448 100644
--- a/src/gsi/rfdpar.f90
+++ b/src/gsi/rfdpar.f90
@@ -71,7 +71,7 @@ subroutine rfdpar1(be,rate,m)
cof=zero
cof(0)=one
do i=1,m
- cof(i)=half*cof(i-1)/float(i)
+ cof(i)=half*cof(i-1)/real(i,r_kind)
enddo
! Locate the m roots of this polynomial:
call zroots(cof,m,croot,polish)
diff --git a/src/gsi/satthin.F90 b/src/gsi/satthin.F90
index 02d19b198c..c093c4b1d5 100644
--- a/src/gsi/satthin.F90
+++ b/src/gsi/satthin.F90
@@ -134,6 +134,8 @@ module satthin
use obsmod, only: time_window_max
use constants, only: deg2rad,rearth_equator,zero,two,pi,half,one,&
rad2deg,r1000
+ use chemmod, only: laeroana_fv3smoke
+
implicit none
! set default to private
@@ -348,7 +350,7 @@ subroutine makegvals
end subroutine makegvals
- subroutine makegrids(rmesh,ithin,n_tbin)
+ subroutine makegrids(rmesh,ithin,n_tbin,itxmax_in)
!$$$ subprogram documentation block
! . . . .
! subprogram: makegrids
@@ -384,7 +386,8 @@ subroutine makegrids(rmesh,ithin,n_tbin)
real(r_kind) ,intent(in ) :: rmesh
integer(i_kind),intent(in ) :: ithin
- integer(i_kind),intent(in ), optional :: n_tbin
+ integer(i_kind),intent(in ), optional :: n_tbin
+ integer(i_kind),intent(in ), optional :: itxmax_in
real(r_kind),parameter:: r360 = 360.0_r_kind
integer(i_kind) i,j
integer(i_kind) mlonx,mlonj
@@ -400,7 +403,11 @@ subroutine makegrids(rmesh,ithin,n_tbin)
itx_all=0
if(abs(rmesh) <= one .or. ithin <= 0)then
use_all=.true.
- itxmax=1e9
+ if (present(itxmax_in)) then
+ itxmax = itxmax_in
+ else
+ itxmax = 1e7
+ endif
allocate(icount(itxmax))
allocate(score_crit(itxmax))
do j=1,itxmax
@@ -612,9 +619,9 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any)
jmax=nlat_sfc-2
allocate(slatx(jmax),wlatx(jmax))
call splat(idrt,jmax,slatx,wlatx)
- dlon=two*pi/float(nlon_sfc)
+ dlon=two*pi/real(nlon_sfc,r_kind)
do i=1,nlon_sfc
- rlons_sfc(i)=float(i-1)*dlon
+ rlons_sfc(i)=real(i-1,r_kind)*dlon
end do
do i=1,(nlat_sfc-1)/2
rlats_sfc(i+1)=-asin(slatx(i))
@@ -961,7 +968,10 @@ subroutine getsfc(mype,mype_io,use_sfc,use_sfc_any)
end if
if (.not.lobserver) then
if(allocated(veg_frac)) deallocate(veg_frac)
- if(allocated(veg_type)) deallocate(veg_type)
+! veg_type will be used in setuppm2_5.f90 for rrfs_sd PM2.5 DA
+ if(.not. laeroana_fv3smoke )then
+ if(allocated(veg_type)) deallocate(veg_type)
+ endif
if(allocated(soil_type)) deallocate(soil_type)
if(allocated(soil_moi)) deallocate(soil_moi)
if(allocated(sfc_rough)) deallocate(sfc_rough)
diff --git a/src/gsi/setupaod.f90 b/src/gsi/setupaod.f90
index a1e4656e76..e0964ee972 100644
--- a/src/gsi/setupaod.f90
+++ b/src/gsi/setupaod.f90
@@ -61,7 +61,8 @@ subroutine setupaod(obsLL,odiagLL,lunin,mype,nchanl,nreal,nobs,&
dplat,lobsdiagsave,lobsdiag_allocated,&
dirname,time_offset,luse_obsdiag
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d, nc_diag_chaninfo_dim_set, nc_diag_chaninfo
+ nc_diag_write, nc_diag_data2d, nc_diag_chaninfo_dim_set, nc_diag_chaninfo, &
+ nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
use gsi_4dvar, only: nobs_bins,hr_obsbin
use gridmod, only: nsig,get_ij
@@ -179,6 +180,7 @@ subroutine setupaod(obsLL,odiagLL,lunin,mype,nchanl,nreal,nobs,&
real(r_kind) :: qcall, smask
real(r_kind) :: styp, dbcf
+ real(r_kind),dimension(nchanl):: chan_level
real(r_kind),dimension(nchanl):: emissivity,ts,emissivity_k
real(r_kind),dimension(nchanl):: tsim
real(r_kind),dimension(nsig,nchanl):: wmix,temp,ptau5
@@ -408,7 +410,7 @@ subroutine setupaod(obsLL,odiagLL,lunin,mype,nchanl,nreal,nobs,&
call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, &
tvp,qvp,qsat,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, &
trop5,tzbgr,dtsavg,sfc_speed, &
- tsim,emissivity,ptau5,ts,emissivity_k, &
+ tsim,emissivity,chan_level,ptau5,ts,emissivity_k, &
temp,wmix,jacobian,error_status,layer_od=layer_od,jacobian_aero=jacobian_aero)
! interpolate aerosols at observation locations for diag files here
if (aero_diagsave) then
@@ -841,16 +843,16 @@ subroutine contents_netcdf_diag_
if ( iuse_aero(l) < 0 ) cycle
call nc_diag_metadata("Channel_Index", i)
call nc_diag_metadata("Observation_Class", obsclass)
- call nc_diag_metadata("Latitude", sngl(cenlat)) ! observation latitude (degrees)
- call nc_diag_metadata("Longitude", sngl(cenlon)) ! observation longitude (degrees)
- call nc_diag_metadata("Obs_Time", sngl(dtime))!-time_offset)) ! observation time (hours relative to analysis time)
- call nc_diag_metadata("Sol_Zenith_Angle", sngl(pangs)) ! solar zenith angle (degrees)
- call nc_diag_metadata("Sol_Azimuth_Angle", sngl(data_s(isazi_ang,n))) ! solar azimuth angle (degrees)
+ call nc_diag_metadata_to_single("Latitude",(cenlat)) ! observation latitude (degrees)
+ call nc_diag_metadata_to_single("Longitude",(cenlon)) ! observation longitude (degrees)
+ call nc_diag_metadata_to_single("Time",(dtime))!-time_offset)) ! observation time (hours relative to analysis time)
+ call nc_diag_metadata_to_single("Sol_Zenith_Angle",(pangs)) ! solar zenith angle (degrees)
+ call nc_diag_metadata_to_single("Sol_Azimuth_Angle",(data_s(isazi_ang,n))) ! solar azimuth angle (degrees)
call nc_diag_metadata("Surface_type", nint(data_s(istyp,n)))
call nc_diag_metadata("MODIS_deep_blue_flag", nint(dbcf) )
- call nc_diag_metadata("Observation", sngl(diagbufchan(1,i)) ) ! observed aod
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted",sngl(diagbufchan(2,i)))
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",sngl(diagbufchan(2,i)))! obs - sim aod with no bias correction
+ call nc_diag_metadata("Observation",(diagbufchan(1,i)) ) ! observed aod
+ call nc_diag_metadata("Obs_Minus_Forecast_adjusted",(diagbufchan(2,i)))
+ call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",(diagbufchan(2,i)))! obs - sim aod with no bias correction
if (diagbufchan(3,i) > tiny_r_kind) then
tmp(1)=one/diagbufchan(3,i)
@@ -859,7 +861,7 @@ subroutine contents_netcdf_diag_
end if
call nc_diag_metadata("Observation_Error",tmp(1))
- call nc_diag_metadata("QC_Flag", sngl(diagbufchan(4,i))) !quality control mark or event indicator
+ call nc_diag_metadata("QC_Flag",(diagbufchan(4,i))) !quality control mark or event indicator
tmp(1)=get_zsfc()
call nc_diag_metadata("sfc_height",tmp(1)) ! height in meters
diff --git a/src/gsi/setupbend.f90 b/src/gsi/setupbend.f90
index 9bc856d67a..074bc7e002 100644
--- a/src/gsi/setupbend.f90
+++ b/src/gsi/setupbend.f90
@@ -147,13 +147,17 @@ subroutine setupbend(obsLL,odiagLL, &
use gsi_4dvar, only: nobs_bins,hr_obsbin
use guess_grids, only: ges_lnprsi,hrdifsig,geop_hgti,nfldsig
+ use guess_grids, only: ges_lnprsl,ges_prsi,geop_hgtl
use guess_grids, only: nsig_ext,gpstop,commgpstop,commgpserrinf
+!> xuanli
+ use guess_grids, only: ges_tsen
+!< xuanli
use gridmod, only: nsig
use gridmod, only: get_ij,latlon11
use constants, only: fv,n_a,n_b,n_c,deg2rad,tiny_r_kind,r0_01,r18,r61,r63,r10000
use constants, only: zero,half,one,two,eccentricity,semi_major_axis,&
grav_equator,somigliana,flattening,grav_ratio,grav,rd,eps,three,four,five,&
- r100,r400
+ r100,r400,r1000
use lagmod, only: setq, setq_TL
use lagmod, only: slagdw, slagdw_TL
use jfunc, only: jiter,miter,jiterstart
@@ -225,10 +229,14 @@ subroutine setupbend(obsLL,odiagLL, &
real(r_kind),dimension(nele,nobs):: data
real(r_kind),dimension(nsig):: dbenddn,dbenddxi
real(r_kind) pressure,hob_s,d_ref_rad,d_ref_rad_TL,hob_s_top
+ real(r_kind) hobb
real(r_kind),dimension(4) :: w4,dw4,dw4_TL
-
+
+!> xuanli
integer(i_kind) ier,ilon,ilat,ihgt,igps,itime,ikx,iuse, &
- iprof,ipctc,iroc,isatid,iptid,ilate,ilone,ioff,igeoid
+ iprof,ipctc,iroc,isatid,iptid,ilate,ilone,ioff,igeoid,iqfro
+ integer(i_kind) iascd, iazm, iconstid, isiid, iogce, iref, ihggt
+!< xuanli
integer(i_kind) i,j,k,kk,mreal,nreal,jj,ikxx,ibin
integer(i_kind) mm1,nsig_up,ihob,istatus,nsigstart
integer(i_kind) kprof,istat,k1,k2,nobs_out,top_layer_SR,bot_layer_SR,count_SR
@@ -264,6 +272,11 @@ subroutine setupbend(obsLL,odiagLL, &
real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv
real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q
+!> xuanli
+ real(r_kind),dimension(nsig, nobs) :: Tsen,Tvir,sphm,hgtl,prslnl
+ real(r_kind),dimension(nsig+1,nobs) :: hgti,prslni
+!< xuanli
+
type(obsLList),pointer,dimension(:):: gpshead
logical:: commdat
gpshead => obsLL(:)
@@ -301,7 +314,6 @@ subroutine setupbend(obsLL,odiagLL, &
!268 => PlanetiQ GNOMES-B
!269 => Spire Lemur 3U CubeSat
!66 => Sentinel-6
-
! Check to see if required guess fields are available
call check_vars_(proceed)
if(.not.proceed) return ! not all vars available, simply return
@@ -328,12 +340,22 @@ subroutine setupbend(obsLL,odiagLL, &
ilone=14 ! index of earth relative longitude (degrees)
ilate=15 ! index of earth relative latitude (degrees)
igeoid=16 ! index of geoid undulation (a value per profile, m)
+!> xuanli
+ iqfro=17 ! index of qfro (integer)
+ iascd=18 ! index of ascending flag (integer)
+ iazm=19 ! index of azimuth angle
+ iconstid=20 ! index of classification ID (integer)
+ isiid=21 ! index of occulting sat (integer)
+ iogce=22 ! index of identification of originating (integer)
+ iref=23 ! index of refractivity
+ ihggt=24 ! index of height
+!< xuanli
! Intialize variables
nsig_up=nsig+nsig_ext ! extend nsig_ext levels above interface level nsig
- rsig=float(nsig)
+ rsig=real(nsig,r_kind)
rdog=rd/grav
- rsig_up=float(nsig_up)
+ rsig_up=real(nsig_up,r_kind)
nobs_out=0
hob_s_top=one
mm1=mype+1
@@ -345,7 +367,8 @@ subroutine setupbend(obsLL,odiagLL, &
allocate(ddnj(grids_dim),grid_s(grids_dim),ref_rad_s(grids_dim))
! Allocate arrays for output to diagnostic file
- mreal=22
+! mreal=22 ! xuanli
+ mreal=35 ! xuanli
nreal=mreal
if (lobsdiagsave) nreal=nreal+4*miter+1
if (save_jacobian) then
@@ -453,6 +476,19 @@ subroutine setupbend(obsLL,odiagLL, &
prsltmp_o(1:nsig,i)=prsltmp(1:nsig) ! needed in minimization
+ call tintrp2a1(ges_tsen, Tsen(1:nsig,i), dlat,dlon,dtime,hrdifsig, &
+ nsig, mype,nfldsig)
+ call tintrp2a1(geop_hgtl, hgtl(1:nsig,i), dlat,dlon,dtime,hrdifsig, &
+ nsig, mype,nfldsig)
+ call tintrp2a1(ges_lnprsl,prslnl(1:nsig,i),dlat,dlon,dtime,hrdifsig, &
+ nsig, mype,nfldsig)
+
+ Tvir(1:nsig,i) = tges(1:nsig) ! virtual temperature
+ sphm(1:nsig,i) = qges(1:nsig) ! specific humidity
+ hgtl(1:nsig,i) = hgtl(1:nsig,i) + zsges ! mid level geopotential height
+ hgti(1:nsig+1,i) = hges(1:nsig+1) + zsges ! interface level geopotential height
+ prslni(1:nsig+1,i) = prsltmp(1:nsig+1) ! interface level log(pressure)
+
! Compute refractivity index-radius product at interface
!
! Convert geopotential height at layer midpoints to geometric height using
@@ -573,7 +609,11 @@ subroutine setupbend(obsLL,odiagLL, &
rdiagbuf(2,i) = data(iprof,i) ! profile identifier
rdiagbuf(3,i) = data(ilate,i) ! lat in degrees
rdiagbuf(4,i) = data(ilone,i) ! lon in degrees
- rdiagbuf(7,i) = tpdpres(i)-rocprof ! impact height in meters
+!> xuanli: modified imph in the diag file. In jedi: imph=impp-roc-geoid
+! rdiagbuf(7,i) = tpdpres(i)-rocprof ! impact height in meters
+ rdiagbuf(7,i) = tpdpres(i)-rocprof-unprof ! impact height in meters
+!< xuanli
+
! rdiagbuf(7,i) = tpdpres(i) ! impact parameter in meters
rdiagbuf(8,i) = dtime-time_offset ! obs time (hours relative to analysis time)
! rdiagbuf(9,i) = data(ipctc,i) ! input bufr qc - index of per cent confidence
@@ -582,6 +622,21 @@ subroutine setupbend(obsLL,odiagLL, &
rdiagbuf(17,i) = data(igps,i) ! bending angle observation (radians)
rdiagbuf(19,i) = hob ! model vertical grid (interface) if monotone grid
rdiagbuf(22,i) = 1.e+10_r_kind ! spread (filled in by EnKF)
+!> xuanli
+ rdiagbuf(23,i) = tpdpres(i) ! impact parameter in meters
+ rdiagbuf(24,i) = data(ipctc,i) ! input bufr qc - index of per cent confidence
+ rdiagbuf(25,i) = data(iptid,i) ! transmitter occ id
+ rdiagbuf(26,i) = rocprof ! local radius of curvature (m)
+ rdiagbuf(27,i) = unprof ! geoid undulation (m)
+ rdiagbuf(28,i) = data(iqfro,i) ! qfro
+ rdiagbuf(29,i) = data(iascd,i) ! ascending flag
+ rdiagbuf(30,i) = data(iazm,i) ! azimuth angle
+ rdiagbuf(31,i) = data(iconstid,i) ! satellite classification
+ rdiagbuf(32,i) = data(isiid,i) ! occulting satellite
+ rdiagbuf(33,i) = data(iogce,i) ! Identification of processing center
+ rdiagbuf(34,i) = data(iref,i) ! refractivity
+ rdiagbuf(35,i) = data(ihggt,i) ! geometric height
+!< xuanli -
if(ratio_errors(i) > tiny_r_kind) then ! obs inside model grid
@@ -618,14 +673,16 @@ subroutine setupbend(obsLL,odiagLL, &
ihob=hob
k1=min(max(1,ihob),nsig)
k2=max(1,min(ihob+1,nsig))
- delz=hob-float(k1)
+ delz=hob-real(k1,r_kind)
delz=max(zero,min(delz,one))
trefges=tges_o(k1,i)*(one-delz)+tges_o(k2,i)*delz
qrefges=qges_o(k1)*(one-delz)+qges_o(k2)*delz !Lidia
rdiagbuf( 6,i) = ten*exp(dpressure) ! pressure at obs location (hPa) if monotone grid
+ ! atmosphere_pressure_coordinate
rdiagbuf(18,i) = trefges ! temperature at obs location (Kelvin) if monotone grid
rdiagbuf(21,i) = qrefges ! specific humidity at obs location (kg/kg) if monotone grid
+
commdat=.false.
if (data(isatid,i)>=265 .and. data(isatid,i)<=269) commdat=.true.
if (.not. qcfail(i)) then ! not SR
@@ -715,7 +772,7 @@ subroutine setupbend(obsLL,odiagLL, &
call setq(q_w(:,k),ref_rad(k-1:k+1),3)
enddo
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter
! Get refractivity index-radius and [d(ln(n))/dx] in new grid.
intloop: do j=1,grids_dim
@@ -1027,6 +1084,28 @@ subroutine setupbend(obsLL,odiagLL, &
gps_alltail(ibin)%head%elat= data(ilate,i)
gps_alltail(ibin)%head%elon= data(ilone,i)
+! 2 dimensional geovals for JEDI
+ allocate(gps_alltail(ibin)%head%tvirges(nsig),stat=istatus)
+ allocate(gps_alltail(ibin)%head%tsenges(nsig),stat=istatus)
+ allocate(gps_alltail(ibin)%head%sphmges(nsig),stat=istatus)
+ allocate(gps_alltail(ibin)%head%hgtlges(nsig),stat=istatus)
+ allocate(gps_alltail(ibin)%head%hgtiges(nsig+1),stat=istatus)
+ allocate(gps_alltail(ibin)%head%prsiges(nsig+1),stat=istatus)
+ allocate(gps_alltail(ibin)%head%prslges(nsig),stat=istatus)
+
+ do j= 1, nsig
+ gps_alltail(ibin)%head%tvirges(j) = Tvir(j,i)
+ gps_alltail(ibin)%head%tsenges(j) = Tsen(j,i)
+ gps_alltail(ibin)%head%sphmges(j) = sphm(j,i)
+ gps_alltail(ibin)%head%hgtlges(j) = hgtl(j,i)
+ gps_alltail(ibin)%head%prslges(j) = 1000.0*exp(prslnl(j,i))
+ end do
+
+ do j= 1, nsig + 1
+ gps_alltail(ibin)%head%hgtiges(j) = hgti(j,i)
+ gps_alltail(ibin)%head%prsiges(j) = 1000.0*exp(prslni(j,i))
+ end do
+
allocate(gps_alltail(ibin)%head%rdiag(nreal),stat=istatus)
if (istatus/=0) write(6,*)'SETUPBEND: allocate error for gps_alldiag, istatus=',istatus
diff --git a/src/gsi/setupcldch.f90 b/src/gsi/setupcldch.f90
index cd3790016d..0cfda9a279 100644
--- a/src/gsi/setupcldch.f90
+++ b/src/gsi/setupcldch.f90
@@ -196,7 +196,7 @@ subroutine setupcldch(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_dia
isprvd=18 ! index of subprovider
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! Check for missing data !need obs value and error
diff --git a/src/gsi/setupcldtot.F90 b/src/gsi/setupcldtot.F90
index 3d899d1a82..694c8f1df3 100755
--- a/src/gsi/setupcldtot.F90
+++ b/src/gsi/setupcldtot.F90
@@ -45,13 +45,22 @@ subroutine setupcldtot(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_di
use mpeu_util, only: die,perr
use kinds, only: r_kind,r_single,r_double,i_kind
+ use constants, only: zero,one,r1000,r10,r100
+ use constants, only: huge_single,wgtlim,three
+ use constants, only: tiny_r_kind,five,half,two,r0_01
+ use constants, only: zero,one, h1000
+
use obsmod, only: rmiss_single,time_offset
+ use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate
+ use obsmod, only: luse_obsdiag
+ use m_obsLList, only: obsLList
+ use m_obsdiagNode, only: obs_diags
use m_obsNode, only: obsNode
use m_qNode, only: qNode
use m_qNode, only: qNode_appendto
+ use m_dtime, only: dtime_setup, dtime_check, dtime_show
use gsi_4dvar, only: nobs_bins,hr_obsbin
- use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate
use nc_diag_write_mod,only: nc_diag_init, nc_diag_header,nc_diag_metadata, &
nc_diag_write, nc_diag_data2d
use nc_diag_read_mod, only: nc_diag_read_init,nc_diag_read_get_dim, &
@@ -60,26 +69,18 @@ subroutine setupcldtot(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_di
use guess_grids, only: geop_hgtl,hrdifsig,nfldsig,ges_tsen,ges_prsl
use gridmod, only: nsig,get_ijk
- use constants, only: zero,one,r1000,r10,r100
- use constants, only: huge_single,wgtlim,three
- use constants, only: tiny_r_kind,five,half,two,r0_01
use qcmod, only: npres_print
use jfunc, only: jiter
use convinfo, only: nconvtype
use convinfo, only: icsubtype
- use m_dtime, only: dtime_setup, dtime_check, dtime_show
use rapidrefresh_cldsurf_mod, only: i_cloud_q_innovation, &
cld_bld_hgt,i_ens_mean
use gsi_bundlemod, only : gsi_bundlegetpointer
use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle
use mpimod, only: mpi_comm_world
- use constants, only: zero,one, h1000
use gsdcloudlib_pseudoq_mod, only: cloudLWC_pseudo,cloudCover_Surface_col
- use m_obsLList, only: obsLList
- use m_obsdiagNode, only: obs_diags
- use obsmod, only: luse_obsdiag
implicit none
@@ -90,7 +91,7 @@ subroutine setupcldtot(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_di
integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs
real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork
real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork
- integer(i_kind) ,intent(in ) :: is ! ndat index
+ integer(i_kind) ,intent(in ) :: is ! ndat index
logical ,intent(in ) :: conv_diagsave
#ifdef RR_CLOUDANALYSIS
diff --git a/src/gsi/setupdbz.f90 b/src/gsi/setupdbz.f90
index 9bbf5ed34b..4f25256c98 100644
--- a/src/gsi/setupdbz.f90
+++ b/src/gsi/setupdbz.f90
@@ -131,7 +131,7 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d
use obsmod, only: luse_obsdiag, netcdf_diag, binary_diag, dirname, ianldate
use obsmod, only: doradaroneob,oneobddiff,oneobvalue
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim,nc_diag_read_close
use oneobmod, only: oneobtest
use oneobmod, only: maginnov
@@ -150,7 +150,7 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d
use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype
use convinfo, only: icsubtype
use m_dtime, only: dtime_setup, dtime_check
- use obsmod, only : if_model_dbz, inflate_obserr
+ use obsmod, only : if_model_dbz, inflate_dbz_obserr
use setupdbz_lib, only:hx_dart,jqr_dart,jqs_dart,jqg_dart
use gridmod, only: wrf_mass_regional,nems_nmmb_regional, fv3_regional
use sparsearr, only: sparr2, new, size, writearray, fullarray
@@ -364,7 +364,7 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d
iptrb=26 ! index of dbz perturbation
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
if ( .not. luse(i) ) then
icnt_nouse = icnt_nouse + 1
@@ -426,6 +426,7 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d
if (lobsdiagsave) nreal=nreal+4*miter+1
if (.not.allocated(cdiagbuf)) allocate(cdiagbuf(nobs))
if (.not.allocated(rdiagbuf)) allocate(rdiagbuf(nreal,nobs))
+ if(netcdf_diag) call init_netcdf_diag_
end if
mm1=mype+1
scale=one
@@ -589,14 +590,17 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d
! Compute observation pressure (only used for diagnostics)
dz = zges(k2)-zges(k1)
dlnp = prsltmp(k2)-prsltmp(k1)
- pobl = prsltmp(k1) + (dlnp/dz)*(zob-zges(k1))
-
- presw = ten*exp(pobl)
-
if ( l_use_dbz_directDA ) then
- presq = presw
+ pobl = prsltmp(k1) + (dlnp/dz)*(zob-zges(k1))
+ presw = ten*exp(pobl)
+ presq = presw
else
- if( (k1 == k2) .and. (k1 == 1) ) presw=ten*exp(prsltmp(k1))
+ if( (k1 == k2) .and. (k1 == 1) ) then
+ presw = ten*exp(prsltmp(k1))
+ else
+ pobl = prsltmp(k1) + (dlnp/dz)*(zob-zges(k1))
+ presw = ten*exp(pobl)
+ end if
end if
! solution to Nan in some members only for EnKF which causes problem?
@@ -1256,8 +1260,11 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d
end if
else
- if (ratio > cgross(ikx) .or. ratio_errors < tiny_r_kind) then
- if ( inflate_obserr .and. (ratio-cgross(ikx)) <= cgross(ikx) .and. ratio_errors >= tiny_r_kind) then
+
+! Apply gross error check only to reflectivity observations in precipitation (>= 5 dBZ).
+ if ( ( (data(idbzob,i) >= 5_r_kind) .and. (ratio > cgross(ikx)) ) .or. (ratio_errors < tiny_r_kind) ) then
+
+ if ( inflate_dbz_obserr .and. (ratio-cgross(ikx)) <= cgross(ikx) .and. ratio_errors >= tiny_r_kind) then
! Since radar reflectivity can be very different from the model background
! good observations may be rejected during this QC step. However, if these observations
! are allowed through, they can yield problems with convergence. Therefore the error
@@ -1447,35 +1454,42 @@ subroutine setupdbz(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,radardbz_d
! Release memory of local guess arrays
call final_vars_
-
! Write information to diagnostic file
- if(radardbz_diagsave .and. ii>0 )then
+ if(radardbz_diagsave .and. netcdf_diag) call nc_diag_write
+ if(radardbz_diagsave .and. binary_diag .and. ii>0 )then
- write(string,600) jiter
-600 format('radardbz_',i2.2)
- diag_file=trim(dirname) // trim(string)
- if(init_pass) then
- open(newunit=lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind')
+ if( .not. l_use_dbz_directDA .and. .not. if_model_dbz )then
+ write(7)'dbz',nchar,nreal,ii,mype,ioff0
+ write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii)
+ deallocate(cdiagbuf,rdiagbuf)
else
- inquire(file=trim(diag_file),exist=diagexist)
- if (diagexist) then
- open(lu_diag,file=trim(diag_file),form='unformatted',status='old',position='append')
+
+ write(string,600) jiter
+600 format('radardbz_',i2.2)
+ diag_file=trim(dirname) // trim(string)
+ if(init_pass) then
+ open(newunit=lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind')
else
- open(lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind')
+ inquire(file=trim(diag_file),exist=diagexist)
+ if (diagexist) then
+ open(lu_diag,file=trim(diag_file),form='unformatted',status='old',position='append')
+ else
+ open(lu_diag,file=trim(diag_file),form='unformatted',status='unknown',position='rewind')
+ endif
+ endif
+ if(init_pass .and. mype == 0) then
+ if ( .not. l_use_dbz_directDA ) then ! EnKF uses these diagnostics and EnKF uses single OBS file for now.
+ write(lu_diag) ianldate ! So do not write analysis date for binary in case of using direct reflectivity DA.
+ end if
+ write(6,*)'SETUPDBZ: write time record to file ',&
+ trim(diag_file), ' ',ianldate
endif
- endif
- if(init_pass .and. mype == 0) then
- if ( .not. l_use_dbz_directDA ) then ! EnKF uses these diagnostics and EnKF uses single OBS file for now.
- write(lu_diag) ianldate ! So do not write analysis date for binary in case of using direct reflectivity DA.
- end if
- write(6,*)'SETUPDBZ: write time record to file ',&
- trim(diag_file), ' ',ianldate
- endif
- write(lu_diag)'dbz',nchar,nreal,ii,mype,ioff0
- write(lu_diag)cdiagbuf(1:ii),rdiagbuf(:,1:ii)
- deallocate(cdiagbuf,rdiagbuf)
- close(lu_diag)
+ write(lu_diag)'dbz',nchar,nreal,ii,mype,ioff0
+ write(lu_diag)cdiagbuf(1:ii),rdiagbuf(:,1:ii)
+ deallocate(cdiagbuf,rdiagbuf)
+ close(lu_diag)
+ end if
end if
write(6,*)'mype, irefsmlobs,irejrefsmlobs are ',mype,' ',irefsmlobs, ' ',irejrefsmlobs
! close(52) !simulated obs
@@ -1773,7 +1787,7 @@ subroutine init_netcdf_diag_
end if
call nc_diag_init(diag_conv_file, append=append_diag)
-
+
if (.not. append_diag) then ! don't write headers on append - the module will break?
call nc_diag_header("date_time",ianldate )
call nc_diag_header("Number_of_state_vars", nsdim )
@@ -1920,29 +1934,29 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_metadata("Observation_Class", obsclass )
call nc_diag_metadata("Observation_Type", ictype(ikx) )
call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
- call nc_diag_metadata("Station_Elevation", sngl(data(ielev,i)) )
- call nc_diag_metadata("Pressure", sngl(presw) )
- call nc_diag_metadata("Height", sngl(data(ihgt,i)) )
- call nc_diag_metadata("Time", sngl(dtime-time_offset))
- call nc_diag_metadata("Prep_QC_Mark", sngl(zero) )
- call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) )
+ call nc_diag_metadata_to_single("Latitude", data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude", data(ilone,i) )
+ call nc_diag_metadata_to_single("Station_Elevation",data(ielev,i) )
+ call nc_diag_metadata_to_single("Pressure", presw )
+ call nc_diag_metadata_to_single("Height", data(ihgt,i) )
+ call nc_diag_metadata_to_single("Time", dtime, time_offset, "-")
+ call nc_diag_metadata_to_single("Prep_QC_Mark", zero )
+ call nc_diag_metadata_to_single("Prep_Use_Flag", data(iuse,i) )
! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ! )
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt )
if(muse(i)) then
- call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
+ call nc_diag_metadata_to_single("Analysis_Use_Flag",one )
else
- call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
+ call nc_diag_metadata_to_single("Analysis_Use_Flag",-one )
endif
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
+ call nc_diag_metadata_to_single("Errinv_Input", errinv_input )
+ call nc_diag_metadata_to_single("Errinv_Adjust", errinv_adjst )
+ call nc_diag_metadata_to_single("Errinv_Final", errinv_final )
- call nc_diag_metadata("Observation", sngl(data(idbzob,i)) )
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(idbzob,i)-rdBZ) )
+ call nc_diag_metadata_to_single("Observation", data(idbzob,i) )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", data(idbzob,i), rdBZ, "-")
if (lobsdiagsave) then
do jj=1,miter
diff --git a/src/gsi/setupdw.f90 b/src/gsi/setupdw.f90
index 93749b2ad9..6ca68e4cae 100644
--- a/src/gsi/setupdw.f90
+++ b/src/gsi/setupdw.f90
@@ -37,7 +37,7 @@ subroutine setupdw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa
use obsmod, only: rmiss_single,lobsdiag_forenkf
use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
use m_obsdiagNode, only: obs_diag
use m_obsdiagNode, only: obs_diags
@@ -298,7 +298,7 @@ subroutine setupdw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa
end if
scale=one
- rsig=float(nsig)
+ rsig=real(nsig,r_kind)
mm1=mype+1
call dtime_setup()
@@ -496,7 +496,7 @@ subroutine setupdw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa
dwwind=(ugesindw*sinazm+vgesindw*cosazm)*factw
iz = max(1, min( int(dpres), nsig))
- delz = max(zero, min(dpres - float(iz), one))
+ delz = max(zero, min(dpres - real(iz,r_kind), one))
if (save_jacobian) then
u_ind = getindex(svars3d, 'u')
@@ -904,29 +904,29 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_metadata("Observation_Class", obsclass )
call nc_diag_metadata("Observation_Type", ictype(ikx) )
call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
+ call nc_diag_metadata_to_single("Latitude", data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude", data(ilone,i) )
call nc_diag_metadata("Station_Elevation", missing )
- call nc_diag_metadata("Pressure", sngl(presw) )
- call nc_diag_metadata("Height", sngl(data(ihgt,i)) )
- call nc_diag_metadata("Time", sngl(dtime-time_offset))
+ call nc_diag_metadata_to_single("Pressure", presw )
+ call nc_diag_metadata_to_single("Height", data(ihgt,i) )
+ call nc_diag_metadata_to_single("Time", dtime,time_offset,"-" )
call nc_diag_metadata("Prep_QC_Mark", missing )
- call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) )
+ call nc_diag_metadata_to_single("Prep_Use_Flag", data(iuse,i) )
! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb )
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt )
if(muse(i)) then
- call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
+ call nc_diag_metadata_to_single("Analysis_Use_Flag",one )
else
- call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
+ call nc_diag_metadata_to_single("Analysis_Use_Flag",-one )
endif
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
+ call nc_diag_metadata_to_single("Errinv_Input",errinv_input )
+ call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst )
+ call nc_diag_metadata_to_single("Errinv_Final",errinv_final )
- call nc_diag_metadata("Observation", sngl(data(ilob,i)))
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(ilob,i)-dwwind))
+ call nc_diag_metadata_to_single("Observation",data(ilob,i) )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", data(ilob,i), dwwind, '-')
!_RT_NC4_TODO
!_RT rdiagbuf(20,ii) = factw ! 10m wind reduction factor
diff --git a/src/gsi/setupfed.f90 b/src/gsi/setupfed.f90
new file mode 100644
index 0000000000..682c056adf
--- /dev/null
+++ b/src/gsi/setupfed.f90
@@ -0,0 +1,1129 @@
+module fed_setup
+ implicit none
+ private
+ public:: setup
+ interface setup; module procedure setupfed; end interface
+
+contains
+subroutine setupfed(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,fed_diagsave,init_pass)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: setupfed compute rhs of flash extent density
+! orig. prgmmr:
+! Rong Kong CAPS/OU 2018-01-21 (modified based on setupdbz.f90)
+! modified:
+! Yaping Wang CIMMS/OU 2019-11-11
+! David Dowell (DCD) NOAA GSL 2021-07-01
+! - added a second option (tanh) for observation operator, based on the
+! work of Sebok and Back (2021, unpublished)
+! - capped maximum model FED
+! Hongli Wang NOAA GSL 2023-09-14
+! - Add option to use fed from background file to calculate fed innov
+! - cleanup code, removed hardcoded obs height (6500m)
+!
+ use mpeu_util, only: die,perr
+ use kinds, only: r_kind,r_single,r_double,i_kind
+ use m_obsdiagNode, only: obs_diag
+ use m_obsdiagNode, only: obs_diags
+ use m_obsdiagNode, only: obsdiagLList_nextNode
+ use m_obsdiagNode, only: obsdiagNode_set
+ use m_obsdiagNode, only: obsdiagNode_get
+ use m_obsdiagNode, only: obsdiagNode_assert
+ use obsmod, only: rmiss_single,&
+ lobsdiagsave,nobskeep,lobsdiag_allocated,time_offset
+ use obsmod, only: oberror_tune
+ use obsmod, only: if_model_fed,innov_use_model_fed,dofedoneob,oneobddiff,oneobvalue
+ use m_obsNode, only: obsNode
+ use m_fedNode, only: fedNode
+ use m_fedNode, only: fedNode_appendto
+ use obsmod, only: luse_obsdiag, netcdf_diag, binary_diag, dirname, ianldate
+ use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
+ nc_diag_write, nc_diag_data2d
+ use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim,nc_diag_read_close
+ use m_obsLList, only: obsLList
+ use gsi_4dvar, only: nobs_bins,hr_obsbin
+ use oneobmod, only: magoberr
+ use guess_grids, only: hrdifsig,nfldsig,ges_prsi
+ use guess_grids, only: ges_lnprsl, geop_hgtl
+ use gridmod, only: lat2, lon2
+ use gridmod, only: nsig, get_ij,get_ijk,tll2xy
+ use constants, only: flattening,semi_major_axis,grav_ratio,zero,grav,wgtlim
+ use constants, only: half,one,two,grav_equator,eccentricity,somigliana
+ use constants, only: deg2rad,r60,tiny_r_kind,cg_term,huge_single
+ use constants, only: r10,r100,r1000
+ use constants, only: grav,tpwcon
+ use qcmod, only: npres_print,ptopq,pbotq
+ use jfunc, only: jiter,last,miter
+ use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype
+ use convinfo, only: icsubtype
+ use converr, only: ptabl
+ use m_dtime, only: dtime_setup, dtime_check, dtime_show
+ use state_vectors, only: nsdim
+
+ use gsi_bundlemod, only: GSI_BundleGetPointer
+ use gsi_metguess_mod, only: gsi_metguess_get, GSI_MetGuess_Bundle
+
+ use netcdf
+
+
+ implicit none
+! Declare passed variables
+ type(obsLList ),target,dimension(:),intent(in):: obsLL
+ type(obs_diags),target,dimension(:),intent(in):: odiagLL
+
+ logical ,intent(in ) :: fed_diagsave
+ integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs
+ real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork
+ real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork
+ integer(i_kind) ,intent(in ) :: is ! ndat index
+ logical ,intent(in ) :: init_pass ! state of "setup" parameters
+
+
+! Declare local parameters
+ integer(i_kind),parameter:: fed_obs_ob_shape = 2 ! 1 = linear (Allen et al.)
+ ! 2 = tanh (Sebok and Back)
+! coefficients for tanh operator, from Sebok and Back (2021)
+! real(r_kind),parameter:: a_coeff = 8.4_r_kind ! a (flashes/min) in tanh operator
+! real(r_kind),parameter:: b_coeff = 12.248_r_kind ! b (flashes/min) in tanh operator
+! real(r_kind),parameter:: c_coeff = 5.0e-10_r_kind ! c (radians/kg) in tanh operator
+! real(r_kind),parameter:: d_coeff = 1.68e9_r_kind ! d (kg) in tanh operator
+! real(r_kind),parameter:: fed_highbnd = 18.0_r_kind ! DCD: Sebok and Back (2021, unpublished)
+
+! coefficients for tanh operator, from work by A. Back with regional FV3 (2023)
+ real(r_kind),parameter:: a_coeff = -3.645_r_kind ! a (flashes/min) in tanh operator
+ real(r_kind),parameter:: b_coeff = 15.75_r_kind ! b (flashes/min) in tanh operator
+ real(r_kind),parameter:: c_coeff = 1.939e-10_r_kind ! c (radians/kg) in tanh operator
+ real(r_kind),parameter:: d_coeff = -1.215e9_r_kind ! d (kg) in tanh operator
+ real(r_kind),parameter:: fed_highbnd = 8.0_r_kind ! DCD: Back (2023, unpublished) for FV3
+
+ real(r_kind),parameter:: r0_001 = 0.001_r_kind
+ real(r_kind),parameter:: r8 = 8.0_r_kind
+ real(r_kind),parameter:: ten = 10.0_r_kind
+ real(r_kind),parameter:: D608=0.608_r_kind
+ character(len=*),parameter:: myname='setupfed'
+
+! Declare external calls for code analysis
+ external:: tintrp2a1
+ external:: tintrp2a11
+ external:: tintrp2a1116
+ external:: tintrp31
+ external:: grdcrd1
+ external:: stop2
+
+! Declare local variables
+ real(r_kind) rlow,rhgh,rsig
+ real(r_kind) dz
+ real(r_kind) jqg_num,jqg
+ real(r_kind) dlnp,pobl,zob
+ real(r_kind) sin2,termg,termr,termrg
+ real(r_kind) psges,zsges
+ real(r_kind),dimension(nsig):: zges,hges
+ real(r_kind) prsltmp(nsig)
+ real(r_kind) sfcchk
+ real(r_kind) residual,obserrlm,obserror,ratio,scale,val2
+ real(r_kind) ress,ressw
+ real(r_kind) val,valqc,rwgt
+ real(r_kind) cg_w,wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2
+ real(r_double) rstation_id
+ real(r_kind) dlat,dlon,dtime,dpres,ddiff,error,slat,dlat8km,dlon8km
+ real(r_kind) ratio_errors
+ real(r_kind) presw
+ real(r_kind) errinv_input,errinv_adjst,errinv_final
+ real(r_kind) err_input,err_adjst,err_final
+ real(r_kind),dimension(nele,nobs):: data
+ real(r_kind),dimension(lat2,lon2,nfldsig)::rp
+ real(r_single),allocatable,dimension(:,:)::rdiagbuf
+ real(r_kind),allocatable,dimension(:,:,: ) :: ges_z
+ real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps
+ real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q
+ real(r_kind),allocatable,dimension(:,:,:,:) :: ges_qg,ges_qg_mask
+ real(r_kind),allocatable,dimension(:,:,:,:) :: ges_fed
+ real(r_kind) :: presq
+ real(r_kind) :: T1D,RHO
+ real(r_kind) :: glmcoeff = 2.088_r_kind*10.0**(-8.0) ! Allen et al. (2016,MWR)
+ real(r_kind) :: CM = 0.5_r_kind ! tuning factor in eq. 14 of Kong et al. 2020
+
+ integer(i_kind) i,nchar,nreal,k,j,k1,ii,jj
+ integer(i_kind) mm1,k2
+ integer(i_kind) jsig,ikxx,nn,ibin,ioff,ioff0
+ integer(i_kind) ier,ilat,ilon,ifedob,ikx,itime,iuse
+ integer(i_kind) id,ilone,ilate
+ integer(i_kind) ier2
+
+ integer(i_kind) nlat_ll,nlon_ll,nsig_ll,nfld_ll
+
+ integer(i_kind) ipres,iqmax,iqc,icat,itemp
+ integer(i_kind) istnelv,iobshgt,izz,iprvd,isprvd,iptrb
+ integer(i_kind) idomsfc,iskint,isfcr,iff10
+
+ character(8) station_id
+ character(8),allocatable,dimension(:):: cdiagbuf
+ character(80):: string
+ character(128):: diag_file
+ logical :: diagexist
+ logical,dimension(nobs):: luse,muse
+ integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID
+ logical proceed
+
+ equivalence(rstation_id,station_id)
+ integer(i_kind) numequal,numnotequal
+
+ type(fedNode),pointer:: my_head
+ type(obs_diag),pointer:: my_diag
+ type(obs_diags),pointer:: my_diagLL
+
+ real(r_kind),dimension(nsig+1):: prsitmp
+
+
+!------------------------------------------------!
+
+ integer(i_kind) :: itmp,jtmp
+
+ integer(i_kind), parameter :: ntimesfed=1
+ integer(i_kind),parameter :: nxfed=99, nyfed=99, nzfed=1, nfldfed=3
+ real(r_kind),dimension(nobs) :: FEDMdiag,FEDMdiagTL
+ integer(i_kind) :: npt
+ real(r_kind) :: dlat_earth,dlon_earth
+
+! YPW added the next lines
+ logical :: l_set_oerr_ratio_fed=.False.
+ logical :: l_gpht2gmht = .True.
+ real(r_kind),dimension(nobs) :: dlatobs,dlonobs
+ integer(i_kind):: ngx,ngy,igx,jgy
+ real(r_kind):: dx_m, dy_m
+
+ type(obsLList),pointer,dimension(:):: fedhead
+ fedhead => obsLL(:)
+
+!============================================================================================
+! Read and reformat observations in work arrays.
+ read(lunin)data,luse,ioid
+
+ write(6,*)myname,'(pe=',mype,') nele nobs =',nele,nobs, &
+ 'luse_obsdiag=',luse_obsdiag,'lat2,lon2=',lat2,lon2
+
+ ier=1 ! index of obs error
+ ilon=2 ! index of grid relative obs location (x)
+ ilat=3 ! index of grid relative obs location (y)
+ ipres=4 ! index of pressure
+ ifedob=5 ! index of fed observation
+ id=6 ! index of station id
+ itime=7 ! index of observation time in data array
+ ikxx=8 ! index of ob type
+ iqmax=9 ! index of max error
+ itemp=10 ! index of dry temperature
+ iqc=11 ! index of quality mark
+ ier2=12 ! index of original-original obs error ratio
+ iuse=13 ! index of use parameter
+ idomsfc=14 ! index of dominant surface type
+ iskint=15 ! index of surface skin temperature
+ iff10=16 ! index of 10 meter wind factor
+ isfcr=17 ! index of surface roughness
+ ilone=18 ! index of longitude (degrees)
+ ilate=19 ! index of latitude (degrees)
+ istnelv=20 ! index of station elevation (m)
+ iobshgt=21 ! index of observation height (m)
+ izz=22 ! index of surface height
+ iprvd=23 ! index of observation provider
+ isprvd=24 ! index of observation subprovider
+ icat =25 ! index of data level category
+ iptrb=26 ! index of fed perturbation
+ do i=1,nobs
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
+ end do
+
+ if (dofedoneob) then
+ muse=.true.
+ end if
+
+ numequal=0
+ numnotequal=0
+
+!
+! If requested, save select data for output to diagnostic file
+ if(fed_diagsave)then
+ ii=0
+ nchar=1_i_kind
+ ioff0=26_i_kind ! 21 + 5 (22->Zr; 23->Zs; 24->Zg; 25->tsenges;26->RHO;)
+ nreal=ioff0
+ if (lobsdiagsave) nreal=nreal+4*miter+1
+ allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs))
+ rdiagbuf=zero
+ if(netcdf_diag) call init_netcdf_diag_
+ end if
+ mm1=mype+1
+ scale=one
+ rsig=nsig
+
+
+
+ !============================================================================================
+!
+! Check to see if required guess fields are available
+! vars. list: ps, z, q
+! vars. list: qr, qs, qg
+ !============================================================================================
+
+ call check_vars_(proceed)
+ if(.not.proceed) then
+ write(6,*) myname,': some or all necessary variables are not available for fed obs operator. Quit!'
+ return ! not all vars available, simply return
+ end if
+
+! If require guess vars available, extract from bundle ...
+ call init_vars_
+! qscalar=zero
+
+ !============================================================================================
+ ! 1) Calculate the graupel-mass and graupel-volume based flash extent density
+ ! (FED) on model space, added by R. Kong, 07/05/2018
+ !============================================================================================
+ ges_qg_mask=ges_qg
+ where(ges_qg>0.0005) !Count the volume where qg > 0.5/kg
+ ges_qg_mask=1.0
+ elsewhere
+ ges_qg_mask=0.0
+ endwhere
+
+ ! Operator start here
+ ! set ngx and ngy =2, so the integrated domain is 15kmx15km
+ ngx = 2
+ ngy = 2
+ dx_m = 3000.
+ dy_m = 3000.
+ print*,'FED Operator start here!,ngx=',ngx,'ngy=',ngy
+ rp=zero
+
+ print*, 'mype = ', mype
+ print*, 'nfldsig = ', nfldsig
+ print*, 'nsig = ', nsig
+ print*, 'lon2 = ', lon2
+ print*, 'lat2 = ', lat2
+ if (.not. innov_use_model_fed .or. .not. if_model_fed) then
+! compute graupel mass, in kg per 15 km x 15 km column
+ do jj=1,nfldsig
+ do k=1,nsig
+ do i=1,lon2
+ do j=1,lat2 !How to handle MPI????
+ do igx=1,2*ngx+1 !horizontal integration of qg around point to calculate FED
+ do jgy=1,2*ngy+1
+ itmp = i-ngx+igx-1
+ jtmp = j-ngy+jgy-1
+ itmp = min(max(1,itmp),lon2)
+ jtmp = min(max(1,jtmp),lat2)
+ rp(j,i,jj)=rp(j,i,jj) + ges_qg(jtmp,itmp,k,jj)* &
+ dx_m*dy_m*(ges_prsi(jtmp,itmp,k,jj)-ges_prsi(jtmp,itmp,k+1,jj))*&
+ tpwcon * r10
+ end do !igx
+ end do !jgy
+ end do !j
+ end do !i
+ end do !k
+ end do !jj
+
+! compute FED, in flashes/min
+ do jj=1,nfldsig
+ do i=1,lon2
+ do j=1,lat2
+ if (fed_obs_ob_shape .eq. 1) then
+ rp(j,i,jj) = CM * glmcoeff * rp(j,i,jj)
+ else if (fed_obs_ob_shape .eq. 2) then
+ rp(j,i,jj) = a_coeff + b_coeff &
+ * tanh(c_coeff * (rp(j,i,jj) - d_coeff))
+ else
+ write(6,*) ' unknown fed_obs_ob_shape: ', fed_obs_ob_shape
+ write(6,*) ' aborting setupfed'
+ call stop2(999)
+ end if
+ if (rp(j,i,jj) .gt. fed_highbnd) rp(j,i,jj) = fed_highbnd
+ end do !j
+ end do !i
+ end do !jj
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ write(6,*) 'fed_obs_ob_shape=',fed_obs_ob_shape
+ if (fed_obs_ob_shape .eq. 2) then
+ write(6,*) 'a_coeff=',a_coeff
+ write(6,*) 'b_coeff=',b_coeff
+ write(6,*) 'c_coeff=',c_coeff
+ write(6,*) 'd_coeff=',d_coeff
+ end if
+ write(6,*) 'fed_highbnd=',fed_highbnd
+ write(6,*) 'maxval(ges_qg)=',maxval(ges_qg),'pe=',mype
+ end if ! .not. innov_use_model_fed .or. .not. if_model_fed
+
+ !============================================================================================
+
+ nlat_ll=size(ges_qg,1)
+ nlon_ll=size(ges_qg,2)
+ nsig_ll=size(ges_qg,3)
+ nfld_ll=size(ges_qg,4)
+
+ do i=1,nobs
+ dtime=data(itime,i)
+ dlat=data(ilat,i)
+ dlon=data(ilon,i)
+
+ dlon8km=data(iprvd,i) !iprvd=23
+ dlat8km=data(isprvd,i) !isprvd=24
+
+ dpres=data(ipres,i) ! from rdararef_mosaic2: this height abv MSL
+ ikx = nint(data(ikxx,i))
+ error=data(ier2,i)
+ slat=data(ilate,i)*deg2rad ! needed when converting geophgt to
+ dlon_earth = data(ilone,i) !the lontitude and latitude on the obs pts.
+ dlat_earth = data(ilate,i)
+ ! geometric hgh (hges --> zges below)
+
+ if (nobs_bins>1) then
+ ibin = NINT( dtime/hr_obsbin ) + 1
+ else
+ ibin = 1
+ end if
+
+ if (ibin<1.or.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin
+
+ if (luse_obsdiag) my_diagLL => odiagLL(ibin)
+
+! Link obs to diagnostics structure
+ if(luse_obsdiag)then
+ my_diag => obsdiagLList_nextNode(my_diagLL ,&
+ create = .not.lobsdiag_allocated ,&
+ idv = is ,&
+ iob = ioid(i) ,&
+ ich = 1 ,&
+ elat = data(ilate,i) ,&
+ elon = data(ilone,i) ,&
+ luse = luse(i) ,&
+ miter = miter )
+ if(.not.associated(my_diag)) call die(myname, &
+ 'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated)
+ end if
+
+! Interpolate terrain height(model elevation) to obs location.
+ call tintrp2a11(ges_z,zsges,dlat,dlon,dtime,hrdifsig,&
+ mype,nfldsig)
+! print*,'i,after tintrp2all',i,mype,dlat,zsges
+! 1. dpres (MRMS obs height is height above MSL) is adjusted by zsges, so it
+! is changed to height relative to model elevation (terrain).
+! because in GSI, geop_hgtl is the height relative to terrain (ges_z)
+! (subroutine guess_grids)
+ dpres=dpres-zsges
+ if (dpres rsig)ratio_errors = zero
+
+!----------------------------------------------------------------------------!
+! !
+! Implementation of forward operator for flash extend densit ----------------!
+! !
+!----------------------------------------------------------------------------!
+
+ !============================================================================================
+ ! 3) H(x), interpolate the FED from model space on the local domain to obs space (FEDMdiag)
+ !============================================================================================
+
+ npt = 0
+ FEDMdiag(i) = 0.
+ if (if_model_fed .and. innov_use_model_fed) then
+ !use fed from background file
+ call tintrp31(ges_fed,FEDMdiag(i), dlat,dlon,dpres,dtime,hrdifsig,mype,nfldsig)
+ else
+ call tintrp2a11(rp,FEDMdiag(i),dlat,dlon,dtime,hrdifsig,mype,nfldsig)
+ end if
+ dlonobs(i) = dlon_earth
+ dlatobs(i) = dlat_earth
+
+ ! also Jacobian used for TLM and ADM
+ !FEDMdiagTL, used for gsi-3dvar,will be implemented in future......
+ FEDMdiagTL(i) = 0.
+ jqg_num = FEDMdiagTL(i) !=dFED/Dqg
+ jqg = jqg_num
+
+
+ if(FEDMdiag(i)==data(ifedob,i)) then
+ numequal=numequal+1
+ else
+ numnotequal=numnotequal+1
+ end if
+
+!!!!!!!!!!!!!!!!!END H(x)!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ! Compute innovations
+ !--------------Calculate departure from observation----------------!
+
+ ddiff = data(ifedob,i) - FEDMdiag(i)
+ if (dofedoneob) then
+ !use magoberr to define obs error, but oneobtest=.false.
+ if(magoberr <= zero) magoberr=1.0_r_kind
+ error=one/(magoberr)
+ ratio_errors=one
+ if (jiter==1) then
+ if (oneobvalue > 0_r_kind) then
+ data(ifedob,i) = oneobvalue
+ ddiff = data(ifedob,i) - FEDMdiag(i)
+ else
+ ddiff = oneobddiff
+ data(ifedob,i) = FEDMdiag(i)+ddiff
+ oneobvalue = data(ifedob,i)
+ endif
+ write(6,*)"FED_ONEOB: O_Val,B_Val= ",data(ifedob,i),FEDMdiag(i)
+ write(6,*)"FED_ONEOB: Innov,Error= ",ddiff,magoberr
+ else
+ data(ifedob,i) = oneobvalue
+ ddiff = data(ifedob,i) - FEDMdiag(i)
+ end if
+ end if !oneob
+
+! Gross error checks
+ obserror = one/max(ratio_errors*error,tiny_r_kind)
+ obserrlm = max(cermin(ikx),min(cermax(ikx),obserror))
+ residual = abs(ddiff) != y-H(xb)
+ ratio = residual/obserrlm != y-H(xb)/sqrt(R)
+
+ if (l_set_oerr_ratio_fed) then
+ if (ratio > cgross(ikx) .or. ratio_errors < tiny_r_kind) then
+ if (luse(i)) awork(4) = awork(4)+one
+ error = zero
+ ratio_errors = zero
+ end if
+ else
+ ratio_errors = one
+ end if
+
+ if (ratio_errors*error <=tiny_r_kind) muse(i)=.false.
+! if (nobskeep>0 .and. luse_obsdiag) muse(i)=obsdiags(i_fed_ob_type,ibin)%tail%muse(nobskeep)
+ if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i))
+
+ val = error*ddiff !=y-H(xb)/sqrt(R)
+
+! Compute penalty terms (linear & nonlinear qc).
+ if(luse(i))then
+ exp_arg = -half*val**2
+ rat_err2 = ratio_errors**2
+ val2=val*val !(o-g)**2/R, would be saved in awork
+ if (cvar_pg(ikx) > tiny_r_kind .and. error > tiny_r_kind) then
+ arg = exp(exp_arg)
+ wnotgross= one-cvar_pg(ikx)
+ cg_w=cvar_b(ikx)
+ wgross = cg_term*cvar_pg(ikx)/(cg_w*wnotgross)
+ term = log((arg+wgross)/(one+wgross))
+ wgt = one-wgross/(arg+wgross)
+ rwgt = wgt/wgtlim
+ else
+ term = exp_arg
+ wgt = wgtlim
+ rwgt = wgt/wgtlim
+ end if
+ valqc = -two*rat_err2*term
+
+! print*,'Compute penalty terms'
+! Accumulate statistics for obs belonging to this task
+ if (muse(i)) then
+ if(rwgt < one) awork(21) = awork(21)+one
+ jsig = dpres
+ jsig=max(1,min(jsig,nsig))
+ awork(6*nsig+jsig+100)=awork(6*nsig+jsig+100)+val2*rat_err2
+ awork(5*nsig+jsig+100)=awork(5*nsig+jsig+100)+one
+ awork(3*nsig+jsig+100)=awork(3*nsig+jsig+100)+valqc
+ end if
+! Loop over pressure level groupings and obs to accumulate
+! statistics as a function of observation type.
+ ress = scale*ddiff
+ ressw = ress*ress
+ nn=1
+ if (.not. muse(i)) then
+ nn=2
+ if(ratio_errors*error >=tiny_r_kind)nn=3
+ end if
+ do k = 1,npres_print
+! if(presw >=ptop(k) .and. presw<=pbot(k))then
+ if(presq >=ptopq(k) .and. presq<=pbotq(k))then
+ bwork(k,ikx,1,nn) = bwork(k,ikx,1,nn)+one ! count
+ bwork(k,ikx,2,nn) = bwork(k,ikx,2,nn)+ddiff ! bias
+ bwork(k,ikx,3,nn) = bwork(k,ikx,3,nn)+ressw ! (o-g)**2
+ bwork(k,ikx,4,nn) = bwork(k,ikx,4,nn)+val2*rat_err2 ! penalty
+ bwork(k,ikx,5,nn) = bwork(k,ikx,5,nn)+valqc ! nonlin qc penalty
+
+ end if
+ end do
+ end if
+
+ if(luse_obsdiag)then
+ call obsdiagNode_set(my_diag, luse=luse(i), wgtjo=(error*ratio_errors)**2, &
+ jiter=jiter, muse=muse(i), nldepart=ddiff)
+ end if
+
+! If obs is "acceptable", load array with obs info for use
+! in inner loop minimization (int* and stp* routines)
+ if ( .not. last .and. muse(i)) then
+
+ allocate(my_head) ! YPW added
+ call fedNode_appendto(my_head,fedhead(ibin))
+
+ my_head%idv=is
+ my_head%iob=i
+ my_head%elat= data(ilate,i)
+ my_head%elon= data(ilone,i)
+
+ my_head%dlev= dpres
+ call get_ijk(mm1,dlat,dlon,dpres,my_head%ij,my_head%wij)
+ my_head%res = ddiff ! Observation - ges
+ my_head%err2 = error**2
+ my_head%raterr2 = ratio_errors**2
+ my_head%time = dtime
+ my_head%b = cvar_b(ikx)
+ my_head%pg = cvar_pg(ikx)
+ my_head%luse = luse(i)
+
+ if(oberror_tune) then
+ ! my_head%fedpertb=data(iptrb,i)/error/ratio_errors
+ my_head%kx=ikx
+ if(presq > ptabl(2))then
+ my_head%k1=1
+ else if( presq <= ptabl(33)) then
+ my_head%k1=33
+ else
+ k_loop: do k=2,32
+ if(presq > ptabl(k+1) .and. presq <= ptabl(k)) then
+ my_head%k1=k
+ exit k_loop
+ end if
+ end do k_loop
+ end if
+ end if
+!-------------------------------------------------
+
+ if(luse_obsdiag)then
+ call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head')
+ my_head%diags => my_diag
+ end if
+
+ my_head => null()
+ end if
+
+! Save select output for diagnostic file
+ if(.not.luse(i))write(6,*)' luse, mype',luse(i),mype
+ if(fed_diagsave .and. luse(i))then
+ ii=ii+1
+ rstation_id = data(id,i)
+ err_input = data(ier2,i)
+ err_adjst = data(ier,i)
+ if (ratio_errors*error>tiny_r_kind) then
+ err_final = one/(ratio_errors*error)
+ else
+ err_final = huge_single
+ end if
+ errinv_input = huge_single
+ errinv_adjst = huge_single
+ errinv_final = huge_single
+ if (err_input>tiny_r_kind) errinv_input = one/err_input
+ if (err_adjst>tiny_r_kind) errinv_adjst = one/err_adjst
+ if (err_final>tiny_r_kind) errinv_final = one/err_final
+
+ if(binary_diag) call contents_binary_diag_(my_diag)
+ if(netcdf_diag) call contents_netcdf_diag_(my_diag)
+
+ end if
+ end do
+
+! Release memory of local guess arrays
+ call final_vars_
+
+! Write information to diagnostic file
+ if(fed_diagsave .and. netcdf_diag) call nc_diag_write
+ if(fed_diagsave .and. binary_diag .and. ii>0)then
+
+ write(string,600) jiter
+600 format('fed_',i2.2)
+ diag_file=trim(dirname) // trim(string)
+ if(init_pass) then
+ open(66,file=trim(diag_file),form='unformatted',status='unknown',position='rewind')
+ else
+ inquire(file=trim(diag_file),exist=diagexist)
+ if (diagexist) then
+ open(66,file=trim(diag_file),form='unformatted',status='old',position='append')
+ else
+ open(66,file=trim(diag_file),form='unformatted',status='unknown',position='rewind')
+ end if
+ end if
+ if(init_pass .and. mype == 0) then
+ write(66) ianldate
+ write(6,*)'SETUPFED: write time record to file ',&
+ trim(diag_file), ' ',ianldate
+ end if
+
+! call dtime_show(myname,'diagsave:fed',i_fed_ob_type)
+ write(66)'fed',nchar,nreal,ii,mype,ioff0
+ write(66)cdiagbuf(1:ii),rdiagbuf(:,1:ii)
+ ! write(6,*)'fed,nchar,nreal,ii,mype',nchar,nreal,ii,mype
+ deallocate(cdiagbuf,rdiagbuf)
+ close(66)
+ end if
+
+! End of routine
+
+
+! return
+
+ contains
+
+ subroutine check_vars_ (proceed)
+
+
+ logical,intent(inout) :: proceed
+ integer(i_kind) ivar, istatus
+! Check to see if required guess fields are available
+ call gsi_metguess_get ('var::ps', ivar, istatus )
+ proceed=ivar>0
+ call gsi_metguess_get ('var::z' , ivar, istatus )
+ proceed=proceed.and.ivar>0
+ call gsi_metguess_get ('var::q' , ivar, istatus )
+ proceed=proceed.and.ivar>0
+! call gsi_metguess_get ('var::tv' , ivar, istatus )
+! proceed=proceed.and.ivar>0
+ call gsi_metguess_get ('var::qs', ivar, istatus )
+ proceed=proceed.and.ivar>0
+ call gsi_metguess_get ('var::qg', ivar, istatus )
+ proceed=proceed.and.ivar>0
+ call gsi_metguess_get ('var::qr', ivar, istatus )
+ proceed=proceed.and.ivar>0
+ end subroutine check_vars_
+
+
+ subroutine init_vars_
+
+! use radaremul_cst, only: mphyopt
+ use obsmod, only: if_model_fed
+ real(r_kind),dimension(:,: ),pointer:: rank2=>NULL()
+ real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL()
+ character(len=5) :: varname
+ integer(i_kind) ifld, istatus
+
+! If require guess vars available, extract from bundle ...
+ if(size(gsi_metguess_bundle)==nfldsig) then
+! get ps ...
+ varname='ps'
+ call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus)
+ if (istatus==0) then
+ if(allocated(ges_ps))then
+ write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
+ call stop2(999)
+ end if
+ allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig))
+ ges_ps(:,:,1)=rank2
+ do ifld=2,nfldsig
+ call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus)
+ ges_ps(:,:,ifld)=rank2
+ end do
+ else
+ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
+ call stop2(999)
+ end if
+! get z ...
+ varname='z'
+ call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus)
+ if (istatus==0) then
+ if(allocated(ges_z))then
+ write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
+ call stop2(999)
+ end if
+ allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig))
+ ges_z(:,:,1)=rank2
+ do ifld=2,nfldsig
+ call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus)
+ ges_z(:,:,ifld)=rank2
+ end do
+
+ if(if_model_fed)then
+ ! get fed ....
+ varname='fed'
+ call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus)
+ if (istatus==0) then
+ if(allocated(ges_fed))then
+ write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
+ call stop2(999)
+ endif
+ allocate(ges_fed(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig))
+ ges_fed(:,:,:,1)=rank3
+ do ifld=2,nfldsig
+ call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus)
+ ges_fed(:,:,:,ifld)=rank3
+ enddo
+ else
+ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
+ call stop2(999)
+ endif
+ endif
+
+ else
+ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
+ call stop2(999)
+ end if
+! get q ...
+ varname='q'
+ call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus)
+ if (istatus==0) then
+ if(allocated(ges_q))then
+ write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
+ call stop2(999)
+ end if
+ allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig))
+ ges_q(:,:,:,1)=rank3
+ do ifld=2,nfldsig
+ call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus)
+ ges_q(:,:,:,ifld)=rank3
+ end do
+ else
+ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
+ call stop2(999)
+ end if
+! get tv ...
+! varname='tv'
+! call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus)
+! if (istatus==0) then
+! if(allocated(ges_tv))then
+! write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
+! call stop2(999)
+! end if
+! allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig))
+! ges_tv(:,:,:,1)=rank3
+! do ifld=2,nfldsig
+! call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus)
+! ges_tv(:,:,:,ifld)=rank3
+! ges_tv(:,:,:,ifld)=rank3
+! end do
+! else
+! write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
+! call stop2(999)
+! end if
+! get qr ...
+! get qg ...
+ varname='qg'
+ call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus)
+ if (istatus==0) then
+ if(allocated(ges_qg))then
+ write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
+ call stop2(999)
+ end if
+ allocate(ges_qg(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig))
+ if(.not. allocated(ges_qg_mask))then
+ allocate(ges_qg_mask(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig))
+ end if
+
+ ges_qg(:,:,:,1)=rank3
+ do ifld=2,nfldsig
+ call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus)
+ ges_qg(:,:,:,ifld)=rank3
+ end do
+ else
+ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
+ call stop2(999)
+ end if
+ else
+ write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',&
+ nfldsig,size(gsi_metguess_bundle)
+ call stop2(999)
+ end if
+ end subroutine init_vars_
+
+ subroutine init_netcdf_diag_
+ character(len=80) string
+ character(len=128) diag_conv_file
+ integer(i_kind) ncd_fileid,ncd_nobs
+ logical append_diag
+ logical,parameter::verbose=.false.
+ write(string,900) jiter
+900 format('conv_fed_',i2.2,'.nc4')
+ diag_conv_file=trim(dirname) // trim(string)
+
+ inquire(file=diag_conv_file, exist=append_diag)
+
+ if (append_diag) then
+ call nc_diag_read_init(diag_conv_file,ncd_fileid)
+ ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs')
+ call nc_diag_read_close(diag_conv_file)
+
+ if (ncd_nobs > 0) then
+ if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists. Appending. nobs,mype=',ncd_nobs,mype
+ else
+ if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs. Not appending. nobs,mype=',ncd_nobs,mype
+ append_diag = .false. ! if there are no obs in existing file, then do not try to append
+ end if
+ end if
+
+ call nc_diag_init(diag_conv_file, append=append_diag)
+
+ if (.not. append_diag) then ! don't write headers on append - the module will break?
+ call nc_diag_header("date_time",ianldate )
+ call nc_diag_header("Number_of_state_vars", nsdim )
+ end if
+ end subroutine init_netcdf_diag_
+ subroutine contents_binary_diag_(odiag)
+ type(obs_diag),pointer,intent(in):: odiag
+
+ cdiagbuf(ii) = station_id ! station id
+
+ rdiagbuf(1,ii) = ictype(ikx) ! observation type
+ rdiagbuf(2,ii) = icsubtype(ikx) ! observation subtype
+
+ rdiagbuf(3,ii) = data(ilate,i) ! observation latitude (degrees)
+ rdiagbuf(4,ii) = data(ilone,i) ! observation longitude (degrees)
+
+ rdiagbuf(5,ii) = data(istnelv,i) ! station elevation (meters)
+ rdiagbuf(6,ii) = presq ! observation pressure (hPa)
+ rdiagbuf(7,ii) = data(iobshgt,i) ! observation height (meters)
+ rdiagbuf(8,ii) = (dtime*r60)-time_offset ! obs time (sec relative to analysis time)
+ rdiagbuf(9,ii) = data(iqc,i) ! input prepbufr qc or event mark
+ rdiagbuf(10,ii) = rmiss_single ! setup qc or event mark
+ rdiagbuf(11,ii) = data(iuse,i) ! read_prepbufr data usage flag
+ if(muse(i)) then
+ rdiagbuf(12,ii) = one ! analysis usage flag (1=use, -1=not used)
+ else
+ rdiagbuf(12,ii) = -one
+ end if
+
+ rdiagbuf(13,ii) = rwgt ! nonlinear qc relative weight
+ rdiagbuf(14,ii) = errinv_input ! prepbufr inverse obs error (dBZ)**-1
+ rdiagbuf(15,ii) = errinv_adjst ! read_prepbufr inverse obs error (dBZ)**-1
+ rdiagbuf(16,ii) = errinv_final ! final inverse observation error (dBZ)**-1
+ rdiagbuf(17,ii) = data(ifedob,i) ! radar reflectivity observation (dBZ)
+ rdiagbuf(18,ii) = ddiff ! obs-ges (dBZ)
+ rdiagbuf(19,ii) = data(ifedob,i)-FEDMdiag(i) ! obs-ges w/o bias correction (dBZ) (future slot)
+ rdiagbuf(20,ii) = dlat8km ! j-index on 8km bufr obs grid
+ rdiagbuf(21,ii) = dlon8km ! i-index on 8km bufr obs grid
+
+! print*,'data(ilat,i)=',data(ilat,i),'data(ilon,i)=',data(ilon,i)
+
+ rdiagbuf(22,ii) = FEDMdiag(i) ! dBZ from rain water
+
+ rdiagbuf(23,ii) = T1D ! temperature (sensible, K)
+ rdiagbuf(24,ii) = RHO ! air density (kg/m**3)
+
+ if (lobsdiagsave) then
+ write(6,*)'wrong here, stop in setupfed.f90 '
+ stop
+ ioff=nreal
+ do jj=1,miter
+ ioff=ioff+1
+ if (odiag%muse(jj)) then
+ rdiagbuf(ioff,ii) = one
+ else
+ rdiagbuf(ioff,ii) = -one
+ end if
+ end do
+ do jj=1,miter+1
+ ioff=ioff+1
+ rdiagbuf(ioff,ii) = odiag%nldepart(jj)
+ end do
+ do jj=1,miter
+ ioff=ioff+1
+ rdiagbuf(ioff,ii) = odiag%tldepart(jj)
+ end do
+ do jj=1,miter
+ ioff=ioff+1
+ rdiagbuf(ioff,ii) = odiag%obssen(jj)
+ end do
+ end if
+
+ end subroutine contents_binary_diag_
+ subroutine contents_netcdf_diag_(odiag)
+ type(obs_diag),pointer,intent(in):: odiag
+! Observation class
+ character(7),parameter :: obsclass = ' fed'
+ real(r_kind),dimension(miter) :: obsdiag_iuse
+ call nc_diag_metadata("Station_ID", station_id )
+ call nc_diag_metadata("Observation_Class", obsclass )
+ call nc_diag_metadata("Observation_Type", ictype(ikx) )
+ call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
+ call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
+ call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
+ call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) )
+ call nc_diag_metadata("Pressure", sngl(presq) )
+ call nc_diag_metadata("Height", sngl(data(iobshgt,i)) )
+ call nc_diag_metadata("Time", sngl(dtime*r60-time_offset))
+ call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) )
+ call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) )
+! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb ! )
+ call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
+ if(muse(i)) then
+ call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
+ else
+ call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
+ end if
+
+ call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
+ call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
+ call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
+
+ call nc_diag_metadata("Observation", sngl(data(ifedob,i)) )
+ call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) )
+ call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(ifedob,i)-FEDMdiag(i)) )
+ if (lobsdiagsave) then
+ do jj=1,miter
+ if (odiag%muse(jj)) then
+ obsdiag_iuse(jj) = one
+ else
+ obsdiag_iuse(jj) = -one
+ end if
+ end do
+
+ call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse )
+ call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart )
+ call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart )
+ call nc_diag_data2d("ObsDiagSave_obssen" , odiag%obssen )
+ end if
+
+ end subroutine contents_netcdf_diag_
+
+ subroutine final_vars_
+ if(allocated(ges_z )) deallocate(ges_z )
+ if(allocated(ges_q )) deallocate(ges_q )
+! if(allocated(ges_tv)) deallocate(ges_tv)
+ if(allocated(ges_ps)) deallocate(ges_ps)
+ if(allocated(ges_qg)) deallocate(ges_qg)
+ if(allocated(ges_fed)) deallocate(ges_fed)
+ end subroutine final_vars_
+
+ subroutine init_qcld(t_cld, qxmin_cld, icat_cld, t_dpnd)
+ use kinds, only: r_kind,r_single,r_double,i_kind
+ implicit none
+ real(r_kind), intent(in ) :: t_cld
+ real(r_kind), intent(inout) :: qxmin_cld
+ integer, intent(in ) :: icat_cld
+ logical, intent(in ) :: t_dpnd
+!
+! local variables
+ real :: tr_ll, qrmin_ll, tr_hl, qrmin_hl
+ real :: ts_ll, qsmin_ll, ts_hl, qsmin_hl
+ real :: tg_ll, qgmin_ll, tg_hl, qgmin_hl
+ real :: qr_min, qs_min, qg_min
+!------------------------------------------------------
+
+ qr_min = 5.0E-6_r_kind
+ qs_min = 5.0E-6_r_kind
+ qg_min = 5.0E-6_r_kind
+ tr_ll = 275.65; qrmin_ll = 5.0E-6_r_kind;
+ tr_hl = 270.65; qrmin_hl = 1.0E-8_r_kind;
+ ts_ll = 275.65; qsmin_ll = 1.0E-8_r_kind;
+ ts_hl = 270.65; qsmin_hl = 5.0E-6_r_kind;
+ tg_ll = 275.65; qgmin_ll = 1.0E-6_r_kind;
+ tg_hl = 270.65; qgmin_hl = 5.0E-6_r_kind;
+
+ select case (icat_cld)
+ case (1)
+ if ( t_dpnd ) then
+ if (t_cld <= tr_hl) then
+ qxmin_cld = qrmin_hl
+ else if (t_cld >= tr_ll) then
+ qxmin_cld = qrmin_ll
+ else
+ qxmin_cld = (qrmin_hl + qrmin_ll) * 0.5
+ end if
+ else
+ qxmin_cld = qr_min
+ end if
+ case default
+ write(6,*) 'wrong cloud hydrometer category ID',icat_cld
+ end select
+
+ return
+
+ end subroutine init_qcld
+
+end subroutine setupfed
+end module fed_setup
diff --git a/src/gsi/setupgust.f90 b/src/gsi/setupgust.f90
index 65f4c3caba..c6b4aa260f 100644
--- a/src/gsi/setupgust.f90
+++ b/src/gsi/setupgust.f90
@@ -224,7 +224,7 @@ subroutine setupgust(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag
goverrd=grav/rd
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! Check for missing data
diff --git a/src/gsi/setuphowv.f90 b/src/gsi/setuphowv.f90
index c2b1dfe3e9..3ecb05c8ff 100644
--- a/src/gsi/setuphowv.f90
+++ b/src/gsi/setuphowv.f90
@@ -195,7 +195,7 @@ subroutine setuphowv(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
hr_offset=min_offset/60.0_r_kind
diff --git a/src/gsi/setuplag.f90 b/src/gsi/setuplag.f90
index 0bad754a0c..01692d8164 100644
--- a/src/gsi/setuplag.f90
+++ b/src/gsi/setuplag.f90
@@ -171,7 +171,7 @@ subroutine setuplag(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags
allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs))
end if
scale=one
- rsig=float(nsig)
+ rsig=real(nsig,r_kind)
mm1=mype+1
call dtime_setup()
diff --git a/src/gsi/setuplcbas.f90 b/src/gsi/setuplcbas.f90
index 962abbecaa..508236ec26 100644
--- a/src/gsi/setuplcbas.f90
+++ b/src/gsi/setuplcbas.f90
@@ -191,7 +191,7 @@ subroutine setuplcbas(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_dia
scale=one
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! Check for missing data
diff --git a/src/gsi/setuplight.f90 b/src/gsi/setuplight.f90
index e9ed19d3c3..505008b4e9 100644
--- a/src/gsi/setuplight.f90
+++ b/src/gsi/setuplight.f90
@@ -90,7 +90,7 @@ subroutine setuplight(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,light_di
nobskeep,lobsdiag_allocated
use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
use obsmod, only: luse_obsdiag
use m_obsNode, only: obsNode
@@ -421,7 +421,7 @@ subroutine setuplight(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,light_di
nobs_loc=zero
do i=1,nobs
- muse(i)=nint(data(11,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
enddo
dup=one
@@ -534,7 +534,7 @@ subroutine setuplight(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,light_di
! eps0 - guess value of lightning flash rate
if(nobs_gbl > 0) then
- eps=eps0*exp( (one/ float(nobs_gbl))*sum_gbl/(one+r0/w0) )
+ eps=eps0*exp( (one/ real(nobs_gbl,r_kind))*sum_gbl/(one+r0/w0) )
else
eps=eps0
endif !! if(nobs_gbl .gt. 0) then
@@ -1619,25 +1619,25 @@ subroutine contents_netcdf_diag_(odiag)
real(r_single),parameter:: missing = -9.99e9_r_single
real(r_kind),dimension(miter) :: obsdiag_iuse
- call nc_diag_metadata("GLM_Detect_Err", sngl(data(ier,i)) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
- call nc_diag_metadata("Lightning_FR_Obs", sngl(dlight ) )
- call nc_diag_metadata("Time", sngl(dtime) )
- call nc_diag_metadata("GLM_QC_Mark", sngl(data(iqc,i)) )
- call nc_diag_metadata("GLM_Orig_Detect_Err", sngl(data(ier2,i)) )
- call nc_diag_metadata("GLM_Use_Flag", sngl(data(iuse,i)) )
+ call nc_diag_metadata_to_single("GLM_Detect_Err", data(ier,i) )
+ call nc_diag_metadata_to_single("Latitude", data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude", data(ilone,i) )
+ call nc_diag_metadata_to_single("Lightning_FR_Obs", dlight )
+ call nc_diag_metadata_to_single("Time", dtime )
+ call nc_diag_metadata_to_single("GLM_QC_Mark", data(iqc,i) )
+ call nc_diag_metadata_to_single("GLM_Orig_Detect_Err", data(ier2,i) )
+ call nc_diag_metadata_to_single("GLM_Use_Flag", data(iuse,i) )
if(muse(i)) then
call nc_diag_metadata("Analysis_Use_Flag", 1._r_single )
else
call nc_diag_metadata("Analysis_Use_Flag", -1._r_single )
endif
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
- call nc_diag_metadata("Obs_Minus_Forecast_VarBC", sngl(ddiff) )
- call nc_diag_metadata("Obs_Minus_Forecast_NoVarBC", sngl(dlight-lightges0) )
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt )
+ call nc_diag_metadata_to_single("Errinv_Input", errinv_input )
+ call nc_diag_metadata_to_single("Errinv_Adjust", errinv_adjst )
+ call nc_diag_metadata_to_single("Errinv_Final", errinv_final )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_VarBC",ddiff )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_NoVarBC",dlight,lightges0,'-')
if (lobsdiagsave) then
do jj=1,miter
if (odiag%muse(jj)) then
@@ -1650,7 +1650,7 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse )
call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart )
call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart )
- call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen )
+ call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen )
endif
end subroutine contents_netcdf_diag_
diff --git a/src/gsi/setuplwcp.f90 b/src/gsi/setuplwcp.f90
index 7e06144f68..d020cbbc90 100644
--- a/src/gsi/setuplwcp.f90
+++ b/src/gsi/setuplwcp.f90
@@ -68,7 +68,7 @@ subroutine setuplwcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag
use obsmod, only: netcdf_diag, binary_diag, dirname
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header,nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim,nc_diag_read_close
use state_vectors, only: svars3d, levels
@@ -274,7 +274,7 @@ subroutine setuplwcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag
iobshgt=16 ! index of observation height (m)
do i=1,nobs
- muse(i)=nint(data(11,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
dup=one
@@ -848,28 +848,28 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_metadata("Observation_Class", obsclass )
call nc_diag_metadata("Observation_Type", ictype(ikx) )
call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
- call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) )
- call nc_diag_metadata("Pressure", sngl(data(iobsprs,i)) )
- call nc_diag_metadata("Height", sngl(data(iobshgt,i)) )
- call nc_diag_metadata("Time", sngl(dtime-time_offset))
- call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) )
- call nc_diag_metadata("Setup_QC_Mark", sngl(rmiss_single) )
- call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) )
+ call nc_diag_metadata_to_single("Latitude", data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude", data(ilone,i) )
+ call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) )
+ call nc_diag_metadata_to_single("Pressure", data(iobsprs,i) )
+ call nc_diag_metadata_to_single("Height", data(iobshgt,i) )
+ call nc_diag_metadata_to_single("Time", dtime,time_offset,'-' )
+ call nc_diag_metadata_to_single("Prep_QC_Mark", data(iqc,i) )
+ call nc_diag_metadata("Setup_QC_Mark", rmiss_single )
+ call nc_diag_metadata_to_single("Prep_Use_Flag", data(iuse,i) )
if(muse(i)) then
- call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
+ call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single )
else
- call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
+ call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single )
endif
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
- call nc_diag_metadata("Observation", sngl(dlwcp) )
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(dlwcp-lwcpges))
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt )
+ call nc_diag_metadata_to_single("Errinv_Input", errinv_input )
+ call nc_diag_metadata_to_single("Errinv_Adjust", errinv_adjst )
+ call nc_diag_metadata_to_single("Errinv_Final", errinv_final )
+ call nc_diag_metadata_to_single("Observation", dlwcp )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",dlwcp,lwcpges,'-')
if (lobsdiagsave) then
do jj=1,miter
diff --git a/src/gsi/setupmitm.f90 b/src/gsi/setupmitm.f90
index 89b01acbec..cc5b16fde3 100644
--- a/src/gsi/setupmitm.f90
+++ b/src/gsi/setupmitm.f90
@@ -195,7 +195,7 @@ subroutine setupmitm(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! Check for duplicate observations at same location
diff --git a/src/gsi/setupmxtm.f90 b/src/gsi/setupmxtm.f90
index 0c71415f80..5f332c4de5 100644
--- a/src/gsi/setupmxtm.f90
+++ b/src/gsi/setupmxtm.f90
@@ -195,7 +195,7 @@ subroutine setupmxtm(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! Check for duplicate observations at same location
diff --git a/src/gsi/setupoz.f90 b/src/gsi/setupoz.f90
index 24381df447..9e52bf4bf2 100644
--- a/src/gsi/setupoz.f90
+++ b/src/gsi/setupoz.f90
@@ -83,6 +83,9 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
! 2017-02-09 guo - Remove m_alloc, n_alloc.
! . Remove my_node with corrected typecast().
! 2017-10-27 todling - revised netcdf output for lay case; obs-sens needs attention
+! 2020-02-26 todling - reset obsbin from hr to min
+! 2022-08-10 karpowicz - fixes to ncdiag air_pressure_levels, change mass output to
+! ppmv/mole fraction, fix ompsnm scan positoin and solar zenith angle.
!
! input argument list:
! lunin - unit from which to read observations
@@ -110,10 +113,10 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
use mpeu_util, only: die,perr,getindex
use kinds, only: r_kind,r_single,i_kind
- use state_vectors, only: svars3d, levels
+ use state_vectors, only: svars3d, levels, nsdim
- use constants, only : zero,half,one,two,tiny_r_kind
- use constants, only : rozcon,cg_term,wgtlim,h300,r10
+ use constants, only : zero,half,one,two,tiny_r_kind,s_missing
+ use constants, only : constoz,rozcon,cg_term,wgtlim,h300,r10,r100,r1000
use m_obsdiagNode, only : obs_diag
use m_obsdiagNode, only : obs_diags
@@ -131,10 +134,11 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
use m_obsLList, only : obsLList
use obsmod, only : nloz_omi
use obsmod, only : luse_obsdiag
+! use obsmod, only : wrtgeovals
use obsmod, only: netcdf_diag, binary_diag, dirname
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
use gsi_4dvar, only: nobs_bins,hr_obsbin
@@ -155,8 +159,8 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
implicit none
! !INPUT PARAMETERS:
- type(obsLList ),target,dimension(:),intent(in):: obsLL
- type(obs_diags),target,dimension(:),intent(in):: odiagLL
+ type(obsLList ),target,dimension(:),intent(inout):: obsLL
+ type(obs_diags),target,dimension(:),intent(inout):: odiagLL
integer(i_kind) , intent(in ) :: lunin ! unit from which to read observations
integer(i_kind) , intent(in ) :: mype ! mpi task id
@@ -191,9 +195,9 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
! Declare local variables
- real(r_kind) omg,rat_err2,dlat,dtime,dlon,rat_err4diag
+ real(r_kind) omg,rat_err2,dlat,dtime,dlon
real(r_kind) cg_oz,wgross,wnotgross,wgt,arg,exp_arg,term
- real(r_kind) psi,errorinv
+ real(r_kind) psi,errorinv,rat_err4diag
real(r_kind),dimension(nlevs):: ozges,varinv3,ozone_inv,ozobs,varinv4diag
real(r_kind),dimension(nlevs):: ratio_errors,error
real(r_kind),dimension(nlevs-1):: ozp
@@ -201,6 +205,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
real(r_kind),dimension(nlevs):: pobs,gross,tnoise
real(r_kind),dimension(nreal+nlevs,nobs):: data
real(r_kind),dimension(nsig+1)::prsitmp
+ real(r_kind),dimension(nsig)::ozgestmp ! GeoVaLs for JEDI/UFO
real(r_single),dimension(nlevs):: pob4,grs4,err4
real(r_single),dimension(ireal,nobs):: diagbuf
real(r_single),allocatable,dimension(:,:,:)::rdiagbuf
@@ -214,10 +219,10 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
type(sparr2) :: dhx_dx
integer(i_kind) i,nlev,ii,jj,iextra,ibin, kk, nperobs
- integer(i_kind) k,j,nz,jc,idia,irdim1,istatus,ioff0
+ integer(i_kind) k1,k2,k,j,nz,jc,idia,irdim1,istatus,ioff0,ioff1
integer(i_kind) ioff,itoss,ikeep,ierror_toq,ierror_poq
integer(i_kind) isolz,ifovn,itoqf
- integer(i_kind) mm1,itime,ilat,ilon,ilate,ilone,itoq,ipoq
+ integer(i_kind) mm1,itime,ilat,ilon,ilate,ilone,itoq,ipoq,iafbo !emily
integer(i_kind),dimension(iint,nobs):: idiagbuf
integer(i_kind),dimension(nlevs):: ipos,iouse,ikeepk
@@ -252,6 +257,9 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
call init_vars_
mm1=mype+1
+
+ write(6,*)'emily checking: you are here ...', myname, obstype
+
!
!*********************************************************************************
! Initialize arrays
@@ -280,7 +288,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
iouse(jc)=iuse_oz(j)
tnoise(jc)=error_oz(j)
gross(jc)=min(r10*gross_oz(j),h300)
- if (obstype == 'sbuv2' .or. obstype == 'ompsnp') then
+ if (obstype == 'sbuv2' .or. obstype == 'ompsnp' .or. obstype == 'ompsnpnc') then
pobs(jc)=pob_oz(j) * 1.01325_r_kind
else
pobs(jc)=pob_oz(j)
@@ -319,6 +327,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
irdim1=7
ioff0=irdim1
if(lobsdiagsave) irdim1=irdim1+4*miter+1
+ ioff1=irdim1
if (save_jacobian) then
nnz = nsig ! number of non-zero elements in dH(x)/dx profile
nind = 1
@@ -345,7 +354,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
isolz=8 ! index of solar zenith angle (gome and omi only)
itoqf=9 ! index of row anomaly (omi only)
ifovn=14 ! index of scan position (gome and omi only)
-
+ iafbo=15 ! index of algorithm flag for best ozone (for omi, ompsnm, and ompstc8) !emily
! If requested, save data for diagnostic ouput
if(ozone_diagsave)ii=0
@@ -363,7 +372,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
dlon=data(ilon,i)
dtime=data(itime,i)
- if (obstype == 'sbuv2' .or. obstype == 'ompsnp') then
+ if (obstype == 'sbuv2' .or. obstype == 'ompsnp' .or. obstype == 'ompsnpnc') then
if (nobskeep>0) then
! write(6,*)'setupozlay: nobskeep',nobskeep
call stop2(259)
@@ -388,7 +397,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
enddo
end if
- if (obstype == 'omieff' .or. obstype == 'tomseff') then
+ if (obstype == 'omieff' .or. obstype == 'tomseff' .or. obstype == 'ompsnmeff') then
pob_oz_omi(nloz_omi) = 1000.0_r_kind* 1.01325_r_kind
do j=nloz_omi-1, 1, -1
pob_oz_omi(j) = pob_oz_omi(j+1)/2.0
@@ -409,8 +418,18 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
ozp_omi(nloz_omi) = prsitmp(1)
call grdcrd1(ozp_omi(nloz_omi),prsitmp,nsig+1,-1)
end if
-
- if (obstype /= 'omieff' .and. obstype /= 'tomseff') then
+
+ ! GeoVaLs for JEDI/UFO
+ call tintrp2a1(ges_oz,ozgestmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+
+ ! need call to get pressures for pressure level output in ncdiags
+ call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime,hrdifsig,&
+ nsig+1,mype,nfldsig)
+
+
+ if (obstype /= 'omieff' .and. obstype /= 'tomseff' .and. &
+ obstype /= 'ompsnmeff' ) then
call intrp3oz1(ges_oz,ozges,dlat,dlon,ozp,dtime,&
nlevs,mype,doz_dz)
endif
@@ -441,7 +460,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
! For OMI/GOME, nlev=1
do k=1,nlev
j=ipos(k)
- if (obstype == 'omieff' .or. obstype == 'tomseff' ) then
+ if (obstype == 'omieff' .or. obstype == 'tomseff' .or. obstype == 'ompsnmeff') then
ioff=ifovn+1 !
else
ioff=nreal+k ! SBUV and OMI w/o efficiency factors
@@ -449,7 +468,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
! Compute innovation and load obs error into local array
! KW OMI and TOMS have averaging kernels
- if (obstype == 'omieff' .or. obstype == 'tomseff' ) then
+ if (obstype == 'omieff' .or. obstype == 'tomseff' .or. obstype == 'ompsnmeff') then
! everything in data is from top to bottom
nlayers = nloz_omi + 1
apriori(1:nloz_omi) = data(ioff:ioff+nloz_omi -1, i)
@@ -542,7 +561,8 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
rdiagbuf(3,k,ii) = errorinv ! inverse observation error
if (obstype == 'gome' .or. obstype == 'omieff' .or. &
obstype == 'omi' .or. obstype == 'tomseff' .or. &
- obstype == 'ompstc8') then
+ obstype == 'ompsnmeff' .or. obstype == 'ompstc8' .or. &
+ obstype == 'ompsnm') then
rdiagbuf(4,k,ii) = data(isolz,i) ! solar zenith angle
rdiagbuf(5,k,ii) = data(ifovn,i) ! field of view number
else
@@ -556,7 +576,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
endif
rdiagbuf(7,k,ii) = 1.e+10_r_single ! spread (filled in by EnKF)
- idia = ioff0
+ idia = ioff1
if (save_jacobian) then
oz_ind = getindex(svars3d, 'oz')
if (oz_ind < 0) then
@@ -574,34 +594,76 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
endif
if (netcdf_diag) then
+ k1 = k
+ k2 = k - 1
+ if(k2 == 0)k2 = 1
+ if(k == nlevs)then
+ k1=nlevs-1
+ k2=1
+ endif
+ if (obstype == 'sbuv2' .or. obstype == 'ompsnp' .or. obstype == 'ompsnpnc' ) then
+ call nc_diag_metadata_to_single("TopLevelPressure",pobs(k2)*r100)
+ call nc_diag_metadata_to_single("BottomLevelPressure", &
+ (pobs(k1)*r100))
+ else
+ call &
+ nc_diag_metadata_to_single("TopLevelPressure",prsitmp(nsig+1)*r1000)
+ call nc_diag_metadata_to_single("BottomLevelPressure", &
+ prsitmp(1)*r1000)
+ endif
+ call nc_diag_metadata("MPI_Task_Number", mype )
+ call nc_diag_metadata_to_single("Latitude",(data(ilate,i)) )
+ call nc_diag_metadata_to_single("Longitude",(data(ilone,i)) )
+ if(isnan(dtime) .or. isnan(time_offset)) then
+ call nc_diag_metadata("Time",s_missing)
+ else
+ call nc_diag_metadata_to_single("Time",dtime-time_offset)
+ endif
+ call nc_diag_data2d("mole_fraction_of_ozone_in_air", sngl(ozgestmp*constoz))
+ call nc_diag_data2d("air_pressure_levels",sngl(prsitmp*r1000))
call nc_diag_metadata("MPI_Task_Number", mype )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
- call nc_diag_metadata("Time", sngl(data(itime,i)-time_offset) )
- call nc_diag_metadata("Reference_Pressure", sngl(pobs(k)) )
- call nc_diag_metadata("Analysis_Use_Flag", iouse(k) )
- call nc_diag_metadata("Observation", sngl(ozobs(k)))
- call nc_diag_metadata("Inverse_Observation_Error", sngl(errorinv))
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ozone_inv(k)))
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",sngl(ozone_inv(k)))
+ call nc_diag_metadata_to_single("Latitude", data(ilate,i))
+ call nc_diag_metadata_to_single("Longitude", data(ilone,i))
+ call nc_diag_metadata_to_single("Time", data(itime,i)-time_offset)
+ call nc_diag_metadata("Total_Ozone_Error_Flag", float(ierror_toq) )
+ call nc_diag_metadata("Profile_Ozone_Error_Flag", float(ierror_poq) )
+ call nc_diag_metadata_to_single("Reference_Pressure",(pobs(k)*r100))
+ call nc_diag_metadata("Analysis_Use_Flag", float(iouse(k)) )
+ call nc_diag_metadata_to_single("Observation",(ozobs(k)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error",(errorinv))
+ call nc_diag_metadata_to_single("Input_Observation_Error", (error(k)))
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",(ozone_inv(k)))
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",(ozone_inv(k)))
+ call nc_diag_metadata_to_single("Forecast_unadjusted", (ozges(k)))
+ call nc_diag_metadata_to_single("Forecast_adjusted", (ozges(k)))
if (obstype == 'gome' .or. obstype == 'omieff' .or. &
- obstype == 'omi' .or. obstype == 'tomseff' ) then
- call nc_diag_metadata("Solar_Zenith_Angle", sngl(data(isolz,i)) )
- call nc_diag_metadata("Scan_Position", sngl(data(ifovn,i)) )
+ obstype == 'omi' .or. obstype == 'tomseff' .or. &
+ obstype == 'ompsnmeff' .or. obstype == 'ompsnm') then
+ call nc_diag_metadata_to_single("Solar_Zenith_Angle",(data(isolz,i)) )
+ call nc_diag_metadata_to_single("Scan_Position",(data(ifovn,i)) )
else
- call nc_diag_metadata("Solar_Zenith_Angle", sngl(rmiss) )
- call nc_diag_metadata("Scan_Position", sngl(rmiss) )
+ call nc_diag_metadata_to_single("Solar_Zenith_Angle",(rmiss) )
+ call nc_diag_metadata_to_single("Scan_Position",(rmiss) )
endif
if (obstype == 'omieff' .or. obstype == 'omi' ) then
- call nc_diag_metadata("Row_Anomaly_Index", sngl(data(itoqf,i)) )
+ call nc_diag_metadata_to_single("Row_Anomaly_Index",(data(itoqf,i)) )
else
- call nc_diag_metadata("Row_Anomaly_Index", sngl(rmiss) )
+ call nc_diag_metadata_to_single("Row_Anomaly_Index",(rmiss) )
endif
+!>>emily
+ if (obstype == 'omi' .or. obstype == 'ompstc8' .or. obstype == 'ompsnm') then
+ call nc_diag_metadata_to_single("Algorithm_Flag_For_Best_Ozone", data(iafbo,i))
+ endif
+!< my_diag)
- idia=6
+ idia=ioff0
do jj=1,miter
idia=idia+1
if (odiag%muse(jj)) then
@@ -785,7 +849,7 @@ subroutine setupozlay(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
if(in_curbin) then
if (ozone_diagsave.and.lobsdiagsave.and.luse(i)) then
- rdiagbuf(7:irdim1,1:nlevs,ii) = zero
+ rdiagbuf(ioff0+1:irdim1,1:nlevs,ii) = zero
endif
endif ! (in_curbin)
@@ -932,6 +996,7 @@ subroutine init_netcdf_diag_
call nc_diag_header("Satellite_Sensor", isis)
call nc_diag_header("Satellite", dplat(is))
call nc_diag_header("Observation_type", obstype)
+ call nc_diag_header("Number_of_state_vars", nsdim )
call nc_diag_header("pobs", pobs)
call nc_diag_header("gross",gross)
call nc_diag_header("tnoise",tnoise)
@@ -995,7 +1060,9 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
! 2016-12-09 mccarty - add netcdf_diag capability
! 2017-02-09 guo - Remove m_alloc, n_alloc.
! . Remove my_node with corrected typecast().
-!
+! 2020-02-26 todling - reset obsbin from hr to min
+! 2022-08-10 karpowicz/todling - replace ncdiag analysis use flag with +/-1 instead of zero
+!
! input argument list:
! lunin - unit from which to read observations
! mype - mpi task id
@@ -1036,8 +1103,9 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
use obsmod, only : mype_diaghdr,dirname,time_offset,ianldate
use obsmod, only : lobsdiag_allocated,lobsdiagsave,lobsdiag_forenkf
use obsmod, only: netcdf_diag, binary_diag, dirname
+! use obsmod, only: wrtgeovals
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
use m_obsNode, only: obsNode
use m_o3lNode, only : o3lNode
@@ -1046,9 +1114,10 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
use obsmod, only : luse_obsdiag
use guess_grids, only : nfldsig,ges_lnprsl,hrdifsig
+ use guess_grids, only : ges_prsi,ntguessig
use constants, only : zero,half,one,two,tiny_r_kind,four
- use constants, only : cg_term,wgtlim,r10,constoz
+ use constants, only : cg_term,wgtlim,r10,r100,r1000,constoz
use gsi_4dvar, only: nobs_bins,hr_obsbin
@@ -1066,8 +1135,8 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
implicit none
! !INPUT PARAMETERS:
- type(obsLList ),target,dimension(:),intent(in):: obsLL
- type(obs_diags),target,dimension(:),intent(in):: odiagLL
+ type(obsLList ),target,dimension(:),intent(inout):: obsLL
+ type(obs_diags),target,dimension(:),intent(inout):: odiagLL
integer(i_kind) , intent(in ) :: lunin ! unit from which to read observations
integer(i_kind) , intent(in ) :: mype ! mpi task id
@@ -1106,26 +1175,30 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
real(r_kind) o3ges, o3ppmv
real(r_kind) rlow,rhgh,sfcchk
- real(r_kind) omg,rat_err2,dlat,dtime,dlon,rat_err4diag
+ real(r_kind) omg,rat_err2,dlat,dtime,dlon
real(r_kind) cg_oz,wgross,wnotgross,wgt,arg,exp_arg,term
real(r_kind) errorinv
- real(r_kind) psges,ozlv,airnd,uvnd,visnd
+ real(r_kind) psges,ozlv, airnd, uvnd, visnd
- real(r_kind) varinv3,ratio_errors,varinv4diag
+ real(r_kind) varinv3,ratio_errors
+ real(r_kind) varinv4diag,rat_err4diag
real(r_kind) dpres,obserror,ozone_inv,preso3l
real(r_kind),dimension(nreal+nlevs,nobs):: data
real(r_kind),dimension(nsig):: prsltmp
+ real(r_kind),dimension(nsig+1)::prsitmp
+ real(r_kind),dimension(nsig)::ozgestmp ! GeoVaLs for JEDI/UFO
real(r_single),dimension(ireal,nobs):: diagbuf
real(r_single),allocatable,dimension(:,:,:)::rdiagbuf
integer(i_kind) i,ii,jj,iextra,ibin
- integer(i_kind) k,j,idia,irdim1,ioff0
+ integer(i_kind) k1,k2,k,j,idia,irdim1,ioff0,ioff1
integer(i_kind) isolz,iuse
integer(i_kind) mm1,itime,ilat,ilon,ilate,ilone,iozmr,ilev,ipres,iprcs,imls_levs
+ integer(i_kind) iairnd, iuvnd, ivisnd
integer(i_kind),dimension(iint,nobs):: idiagbuf
- integer(i_kind) iairnd,iuvnd,ivisnd
real(r_kind) gross,tnoise,pobs
+
character(12) string
character(10) filex
character(128) diag_ozone_file
@@ -1158,6 +1231,7 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
mm1=mype+1
+ write(6,*)'emily checking: you are here ...', myname, obstype
!
!*********************************************************************************
@@ -1178,6 +1252,7 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
irdim1=10
ioff0 = irdim1
if(lobsdiagsave) irdim1=irdim1+4*miter+1
+ ioff1 = irdim1
if (save_jacobian) then
nnz = 2 ! number of non-zero elements in dH(x)/dx profile
nind = 1
@@ -1273,6 +1348,12 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig, &
nsig,mype,nfldsig)
+ ! GeoVaLs for JEDI/UFO
+ call tintrp2a1(ges_oz,ozgestmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(ges_prsi, prsitmp,dlat,dlon,dtime,hrdifsig,&
+ nsig+1,mype,nfldsig)
+
! Get approximate k value of surface by using surface pressure
! for surface check.
sfcchk=log(psges)
@@ -1304,22 +1385,25 @@ subroutine setupozlev(obsLL,odiagLL,lunin,mype,stats_oz,nlevs,nreal,nobs,&
! Check if observation above model top or below model surface
rlow=max(sfcchk-dpres,zero)
- rhgh=max(dpres-0.001_r_kind-float(nsig),zero)
+ rhgh=max(dpres-0.001_r_kind-real(nsig,r_kind),zero)
! calculate factor for error adjustment if too (high,low)
ratio_errors=obserror/(obserror+1.0e6_r_kind*rhgh+four*rlow)
! Check to see if observations is above the top of the model
- if (dpres > float(nsig)) then
+ if (dpres > real(nsig,r_kind)) then
ratio_errors=zero
obserror=1.0e6_r_kind
end if
+ call tintrp2a1(ges_oz,ozgestmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+
! Interpolate guess ozone to observation location and time
call tintrp31(ges_oz,o3ges,dlat,dlon,dpres,dtime, &
hrdifsig,mype,nfldsig)
iz = max(1, min( int(dpres), nsig))
- delz = max(zero, min(dpres - float(iz), one))
+ delz = max(zero, min(dpres - real(iz,r_kind), one))
if (save_jacobian) then
oz_ind = getindex(svars3d, 'oz')
if (oz_ind < 0) then
@@ -1627,7 +1711,7 @@ subroutine contents_binary_diag_(odiag)
rdiagbuf(10,1,ii) = visnd ! log10 ozone number density vis
if (lobsdiagsave) then
- idia=6
+ idia=ioff0
do jj=1,miter
idia=idia+1
if (odiag%muse(jj)) then
@@ -1649,6 +1733,7 @@ subroutine contents_binary_diag_(odiag)
rdiagbuf(idia,1,ii) = odiag%obssen(jj)
enddo
endif
+ idia = ioff1
if (save_jacobian) then
call writearray(dhx_dx, rdiagbuf(idia+1:irdim1,1,ii))
idia = idia + size(dhx_dx)
@@ -1659,34 +1744,52 @@ subroutine contents_netcdf_diag_(odiag)
type(obs_diag),pointer,intent(in):: odiag
! Observation class
character(7),parameter :: obsclass = ' ozlev'
+ integer(i_kind),parameter :: ione = 1
real(r_kind),dimension(miter) :: obsdiag_iuse
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
+ call nc_diag_metadata_to_single("Latitude", data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude", data(ilone,i) )
call nc_diag_metadata("MPI_Task_Number", mype )
- call nc_diag_metadata("Time", sngl(data(itime,i)-time_offset))
- call nc_diag_metadata("Inverse_Observation_Error", sngl(errorinv) )
- call nc_diag_metadata("Observation", sngl(ozlv) )
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ozone_inv) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted",sngl(ozone_inv) )
- call nc_diag_metadata("Reference_Pressure", sngl(preso3l) )
- call nc_diag_metadata("Input_Observation_Error", sngl(obserror) )
- if(obstype =="omps_lp")then
- call nc_diag_metadata("Log10 Air Number Density", sngl(airnd))
- call nc_diag_metadata("Log10 Ozone Number Density UV", sngl(uvnd))
- call nc_diag_metadata("Log10 Ozone Number Density VIS",sngl(visnd))
- endif
-
+ call nc_diag_metadata_to_single("Time", dtime,time_offset,'-' )
+ call nc_diag_metadata_to_single("Inverse_Observation_Error",errorinv )
+ call nc_diag_metadata_to_single("Observation", ozlv )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ozone_inv )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",ozone_inv )
+ call nc_diag_metadata_to_single("Reference_Pressure", preso3l*r100 ) ! Pa
if(luse(i)) then
- call nc_diag_metadata("Analysis_Use_Flag", 1 )
+ call nc_diag_metadata("Analysis_Use_Flag", ione )
else
- call nc_diag_metadata("Analysis_Use_Flag", -1 )
+ call nc_diag_metadata("Analysis_Use_Flag", -ione )
endif
+
+ call nc_diag_metadata_to_single("Input_Observation_Error",obserror )
+ if(obstype =="ompslp")then
+ call nc_diag_metadata_to_single("Log10 Air Number Density",airnd )
+ call nc_diag_metadata_to_single("Log10 Ozone Number Density UV",uvnd )
+ call nc_diag_metadata_to_single("Log10 Ozone Number Density VIS",visnd )
+ endif
+ call nc_diag_metadata_to_single("Forecast_adjusted", o3ppmv)
+ call nc_diag_metadata_to_single("Forecast_unadjusted", o3ppmv)
+ !if (wrtgeovals) then
+ ! ozgestmp = ozgestmp *constoz
+ ! call nc_diag_data2d("mole_fraction_of_ozone_in_air", ozgestmp)
+ ! call nc_diag_data2d("air_pressure",exp(prsltmp)*r1000) ! Pa
+ !endif
+ k1 = k
+ k2 = k - 1
+ if(k2 == 0)k2 = 1
+ if(k == nlevs)then
+ k1=nlevs-1
+ k2=1
+ endif
+
if (save_jacobian) then
call nc_diag_data2d("Observation_Operator_Jacobian_stind", dhx_dx%st_ind)
call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind)
call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val,r_single))
- endif
-
+ endif
+ ! GeoVaLs for JEDI/UFO
+ call nc_diag_data2d("mole_fraction_of_ozone_in_air", sngl(ozgestmp*constoz))
+ call nc_diag_data2d("air_pressure_levels",sngl(prsitmp*r1000))
if (lobsdiagsave) then
do jj=1,miter
if (odiag%muse(jj)) then
diff --git a/src/gsi/setuppblh.f90 b/src/gsi/setuppblh.f90
index 6d2a56b9fd..5a92494756 100644
--- a/src/gsi/setuppblh.f90
+++ b/src/gsi/setuppblh.f90
@@ -177,7 +177,7 @@ subroutine setuppblh(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag
istnelv=14 ! index of station elevation (m)
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! Check for missing data !need obs value and error
diff --git a/src/gsi/setuppcp.f90 b/src/gsi/setuppcp.f90
index 970bc5b9af..7a89ccb6ca 100644
--- a/src/gsi/setuppcp.f90
+++ b/src/gsi/setuppcp.f90
@@ -223,7 +223,7 @@ subroutine setuppcp(obsLL,odiagLL,lunin,mype,aivals,nele,nobs,&
character(12) string
character(128) diag_pcp_file
- integer(i_kind) km1,mm1,iiflg,iextra,ireal
+ integer(i_kind) km1,mm1,iextra,ireal
integer(i_kind) ii,i,j,k,m,n,ibin,ioff,ioff0
integer(i_kind) ipt
integer(i_kind) nsphys,ixp,iyp,ixx,iyy
@@ -325,7 +325,6 @@ subroutine setuppcp(obsLL,odiagLL,lunin,mype,aivals,nele,nobs,&
! ONE TIME, INITIAL SETUP PRIOR TO PROCESSING SATELLITE DATA
!
! Initialize variables
- iiflg = 1
ncloud = ncld
nsphys = max(int(two*deltim/dtphys+0.9999_r_kind),1)
dtp = two*deltim/nsphys
@@ -417,8 +416,8 @@ subroutine setuppcp(obsLL,odiagLL,lunin,mype,aivals,nele,nobs,&
elseif (amsu) then
itype = 8
endif
- rterm1=one/float(nsig)
- rterm2=one/float(nsig*(nsig-1))
+ rterm1=one/real(nsig,r_kind)
+ rterm2=one/real(nsig*(nsig-1),r_kind)
call dtime_setup()
do n = 1,nobs
diff --git a/src/gsi/setuppm2_5.f90 b/src/gsi/setuppm2_5.f90
index 79e6129cd8..ad940cce78 100644
--- a/src/gsi/setuppm2_5.f90
+++ b/src/gsi/setuppm2_5.f90
@@ -94,8 +94,8 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave)
use gsi_4dvar, only: nobs_bins,hr_obsbin
use gridmod, only : get_ij,get_ijk
-
use guess_grids, only : nfldsig,hrdifsig
+ use guess_grids, only : veg_type
use gsi_bundlemod, only : gsi_bundlegetpointer,GSI_BundlePrint
use gsi_chemguess_mod, only : gsi_chemguess_get,gsi_chemguess_bundle
use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle
@@ -115,7 +115,8 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave)
use chemmod, only: naero_gocart_wrf,aeronames_gocart_wrf,&
upper2lower,lower2upper,laeroana_gocart,wrf_pm2_5
use chemmod, only: naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,laeroana_fv3cmaq
- use chemmod, only: naero_smoke_fv3,aeronames_smoke_fv3,laeroana_fv3smoke,pm2_5_innov_threshold
+ use chemmod, only: naero_smoke_fv3,aeronames_smoke_fv3,laeroana_fv3smoke
+ use chemmod, only: pm2_5_innov_threshold,pm2_5_urban_innov_threshold,pm2_5_bg_threshold
use gridmod, only : cmaq_regional,wrf_mass_regional,fv3_cmaq_regional
implicit none
@@ -146,7 +147,7 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave)
real(r_kind) :: pm2_5ges
real(r_kind) :: ratio_errors,error
real(r_kind) :: innov,innov_error2,rwgt,valqc,tfact,innov_error,elevges,&
- elevdiff,conc,elevobs,ps_ges,site_id,tv_ges
+ elevdiff,conc,elevobs,ps_ges,site_id,tv_ges,veg_type_ges
real(r_kind) errinv_input,errinv_adjst,errinv_final
real(r_kind) err_input,err_adjst,err_final
@@ -278,7 +279,7 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave)
call stop2(453)
endif
- do i=2,naero_smoke_fv3
+ do i=2,naero_smoke_fv3-1 ! remove contribution from coarsepm
aeroname=trim(aeronames_smoke_fv3(i))
call gsi_bundlegetpointer(gsi_chemguess_bundle(1),trim(aeroname),&
rank3,ier)
@@ -705,13 +706,18 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave)
if (wrf_mass_regional .or. fv3_cmaq_regional .or. laeroana_fv3smoke) then
call tintrp2a11(ges_ps,ps_ges,dlat,dlon,dtime,hrdifsig,&
mype,nfldsig)
-
call tintrp2a11(ges_tv(:,:,1,nfldsig),tv_ges,dlat,dlon,dtime,hrdifsig,&
mype,nfldsig)
conc=conc/(ps_ges*r1000/(rd*tv_ges))
endif
-
-
+!
+ if (laeroana_fv3smoke) then
+ if (.not. allocated(veg_type)) then
+ print*,"VEG_TYPE NOT ALLOCATED, WILL NOT BE USED IN PM2.5 DA FOR RRFS_SD",mype
+ else
+ call intrp2a11(veg_type(:,:,1),veg_type_ges,dlat,dlon,mype)
+ endif
+ endif
!if elevobs is known than calculate difference otherwise
!assume that difference is acceptable
@@ -740,17 +746,20 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave)
mype,nfldsig)
innov = conc - pm2_5ges
if (laeroana_fv3smoke) then
- if ( -1.0*innov >= pm2_5_innov_threshold .or. &
- (innov > pm2_5_innov_threshold .and. pm2_5ges >=1.0_r_kind).or. &
- (conc >= 40.0_r_kind .and. pm2_5ges >=1.0_r_kind).or. &
- conc >= 100.0_r_kind ) then
- innov = innov
+ if ( veg_type_ges == 13.0_r_kind ) then
+ if (abs(innov) < pm2_5_urban_innov_threshold) then
+ muse(i)=.false.
+ end if
else
- innov = 0.0_r_kind
+ if (abs(innov) < pm2_5_innov_threshold) then
+ muse(i)=.false.
+ end if
+ end if
+
+ if (pm2_5ges < pm2_5_bg_threshold) then
muse(i)=.false.
end if
if (tv_ges-273.15_r_kind < 5.0_r_kind) then
- innov = 0.0_r_kind
muse(i)=.false.
end if
@@ -770,21 +779,28 @@ subroutine setuppm2_5(obsLL,odiagLL,lunin,mype,nreal,nobs,isis,is,conv_diagsave)
mype,nfldsig)
call tintrp2a11(pm25wc(:,:,:,2,nfldsig),pm25wc_ges(2),dlat,dlon,dtime,hrdifsig,&
mype,nfldsig)
-
- if (pm25wc_ges(1) >= 1.0_r_kind) then
+ if (pm25wc_ges(1) >= pm2_5_bg_threshold) then
pm25wc_ges(1)=1.0_r_kind
else
- pm25wc_ges(2)=0.0_r_kind
+ pm25wc_ges(1)=0.0_r_kind
end if
- if (pm25wc_ges(2) >= 1.0_r_kind) then
+ if (pm25wc_ges(2) >= pm2_5_bg_threshold) then
pm25wc_ges(2)=1.0_r_kind
else
pm25wc_ges(2)=0.0_r_kind
end if
+ if ( (pm25wc_ges(1)+pm25wc_ges(2)) < 1.0_r_kind ) then
+ muse(i) = .false.
+ end if
else
pm25wc_ges = 0.0_r_kind
end if
+ if (oneobtest_chem) then
+ pm25wc_ges=1.0_r_kind
+ muse(i) = .true.
+ end if
+
error=one/data(ierror,i)
ratio_errors=one/sqrt(real(dup(i)))
innov_error = error*innov
@@ -1115,6 +1131,7 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_metadata("Latitude", data(ilate,i) )
call nc_diag_metadata("Longitude", data(ilone,i) )
call nc_diag_metadata("Station_Elevation", data(ielev,i) )
+ call nc_diag_metadata("Station_Veg_Type", veg_type_ges )
call nc_diag_metadata("Pressure", ps_ges )
call nc_diag_metadata("Height", data(ielev,i) )
call nc_diag_metadata("Time", dtime-time_offset )
diff --git a/src/gsi/setuppmsl.f90 b/src/gsi/setuppmsl.f90
index d66a6f827e..b830d26b97 100644
--- a/src/gsi/setuppmsl.f90
+++ b/src/gsi/setuppmsl.f90
@@ -191,7 +191,7 @@ subroutine setuppmsl(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
dup=one
diff --git a/src/gsi/setupps.f90 b/src/gsi/setupps.f90
index 6a0fdd4fb2..fde1f540ba 100644
--- a/src/gsi/setupps.f90
+++ b/src/gsi/setupps.f90
@@ -125,15 +125,16 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa
use obsmod, only: netcdf_diag, binary_diag, dirname
use obsmod, only: l_obsprvdiag
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
use gridmod, only: nsig,get_ij,twodvar_regional
use constants, only: zero,one_tenth,one,half,pi,g_over_rd, &
huge_r_kind,tiny_r_kind,two,huge_single, &
- r1000,wgtlim,tiny_single,r10,three
+ r1000,r100,wgtlim,tiny_single,r10,three
use jfunc, only: jiter,last,jiterstart,miter
use qcmod, only: dfact,dfact1,npres_print,vqc,nvqc
use guess_grids, only: hrdifsig,ges_lnprsl,nfldsig,ntguessig
+ use guess_grids, only: geop_hgtl, ges_prsi, ges_tsen
use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype,icsubtype
use convinfo, only: ibeta,ikapa
@@ -181,15 +182,26 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa
real(r_kind) cg_t,cvar,wgt,rat_err2,qcgross
real(r_kind),dimension(nobs):: dup
real(r_kind),dimension(nsig):: prsltmp
+ real(r_kind),dimension(nsig):: zges, prsltmp2, tvgestmp, tsentmp, qtmp, utmp, vtmp
+ real(r_kind) :: tgges,roges
+ real(r_kind),dimension(nsig+1):: prsitmp
real(r_kind),dimension(nele,nobs):: data
real(r_single),allocatable,dimension(:,:)::rdiagbuf
+ ! GSI profiles are stored with bottom up index; output the profiles
+ ! with top down index
+ real(r_kind),dimension(nsig):: ttmp_reverse,tvtmp_reverse,qtmp_reverse,utmp_reverse,vtmp_reverse
+ real(r_kind),dimension(nsig):: zges_reverse,prsltmp2_reverse
+ real(r_kind),dimension(nsig):: zges_read_reverse, zges_geometric_reverse
+ real(r_kind),dimension(nsig+1):: prsitmp_reverse
+ !<< JEDI
integer(i_kind) ier,ilon,ilat,ipres,ihgt,itemp,id,itime,ikx,iqc,iptrb,ijb
integer(i_kind) ier2,iuse,ilate,ilone,istnelv,idomsfc,izz,iprvd,isprvd
integer(i_kind) ikxx,nn,ibin,ioff,ioff0
- integer(i_kind) i,j,nchar,nreal,ii,jj,k,l,mm1
+ integer(i_kind) i,j,nchar,nreal,ii,jj,k,kk,l,mm1
integer(i_kind) itype,isubtype
integer(i_kind) ibb,ikk,idddd
+ integer(i_kind) msges
logical,dimension(nobs):: luse,muse
integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID
@@ -214,6 +226,8 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa
real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps
real(r_kind),allocatable,dimension(:,:,: ) :: ges_z
real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv
+ real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q
+ real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u, ges_v
type(sparr2) :: dhx_dx
integer(i_kind) :: ps_ind, nnz, nind
@@ -273,7 +287,7 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa
! muse = true then used
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! If HD raobs available move prepbufr version to monitor
if(nhdps > 0)then
@@ -298,26 +312,26 @@ subroutine setupps(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa
hr_offset=min_offset/60.0_r_kind
! Check for duplicate observations at same location
dup=one
- do k=1,nobs
- do l=k+1,nobs
- if(data(ilat,k) == data(ilat,l) .and. &
- data(ilon,k) == data(ilon,l) .and. &
- data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. &
- muse(k) .and. muse(l))then
- if(l_closeobs) then
- if(abs(data(itime,k)-hr_offset)>emily
+ do k = 1, nsig
+ kk = nsig-k+1
+ utmp_reverse(kk) = utmp(k)
+ vtmp_reverse(kk) = vtmp(k)
+ ttmp_reverse(kk) = tsentmp(k)
+ tvtmp_reverse(kk) = tvgestmp(k) !emily
+ qtmp_reverse(kk) = qtmp(k)
+ !hsges_reverse(kk) = hsges(k)
+ !zges_read_reverse(kk)= zges_read(k)
+ !zges_geometric_reverse(kk)= zges_geometric(k)
+ zges_read_reverse(kk)= zsges+zges(k)
+ !zges_geometric_reverse(kk)= zges_geometric(k)
+ zges_reverse(kk) = zges(k)
+ prsltmp2_reverse(kk) = prsltmp2(k)
+ enddo
+ do k = 1, nsig+1
+ kk = (nsig+1)-k+1
+ prsitmp_reverse(kk) = prsitmp(k)
+ enddo
+ call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(prsltmp2_reverse*r1000))
+ call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(prsitmp_reverse*r1000))
+ call nc_diag_data2d("air_temperature", sngl(ttmp_reverse))
+ call nc_diag_data2d("virtual_temperature", sngl(tvtmp_reverse)) !emily
+ call nc_diag_data2d("specific_humidity", sngl(qtmp_reverse))
+ call nc_diag_data2d("eastward_wind", sngl(utmp_reverse))
+ call nc_diag_data2d("northward_wind", sngl(vtmp_reverse))
+! call nc_diag_data2d("geopotential_height", sngl(hsges_reverse) ) !orig
+ call nc_diag_data2d("geopotential_height", sngl(zges_read_reverse) ) !emily
+ !call nc_diag_data2d("geometric_height", sngl(zges_geometric_reverse) )
+ !!emily
+ !< obsLL(:)
save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf
@@ -320,9 +352,12 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
icat =22 ! index of data level category
ijb =23 ! index of non linear qc parameter
iptrb=24 ! index of q perturbation
+ if (l_rtma3d .or. twodvar_regional) then
+ iqt =25 ! index of flag indicating if virtual temp is associated to this moisture obs
+ end if
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! If HD raobs available move prepbufr version to monitor
if(nhdq > 0)then
@@ -359,8 +394,11 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
hr_offset=min_offset/60.0_r_kind
dup=one
do k=1,nobs
+ ikx=nint(data(ikxx,k))
+ itype=ictype(ikx)
+ landsfctype =( itype==181 .or. itype==183 .or. itype==187 )
do l=k+1,nobs
- if (twodvar_regional) then
+ if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then
duplogic=data(ilat,k) == data(ilat,l) .and. &
data(ilon,k) == data(ilon,l) .and. &
data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. &
@@ -398,6 +436,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
iip=0
nchar=1
ioff0=21
+ if (l_rtma3d .or. twodvar_regional) ioff0 = ioff0 + 2 ! 22:tdry; 23:tvflag (in binary obsdiag for 2D/3DRTMA)
nreal=ioff0
if (lobsdiagsave) nreal=nreal+4*miter+1
if (twodvar_regional .or. l_obsprvdiag) then
@@ -425,9 +464,15 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
ice=.false. ! get larger (in rh) q obs error for mixed and ice phases
iderivative=0
+
+ ! calculate qsat and 2m qsat
do jj=1,nfldsig
- call genqsat(qg(1,1,1,jj),ges_tsen(1,1,1,jj),ges_prsl(1,1,1,jj),lat2,lon2,nsig,ice,iderivative)
- qg2m(:,:,jj)=qg(:,:,1,jj)
+ call genqsat(qg(:,:,:,jj),ges_tsen(:,:,:,jj),ges_prsl(:,:,:,jj),lat2,lon2,nsig,ice,iderivative)
+ if (i_use_2mq4b > 0) then ! use lowest model level
+ qg2m(:,:,jj)=qg(:,:,1,jj)
+ elseif ( hofx_2m_sfcfile ) then ! calculate from 2m model output
+ call genqsat(qg2m(:,:,jj),ges_t2m(:,:,jj),ges_ps(:,:,jj),lat2,lon2,1,ice,iderivative)
+ endif
end do
@@ -440,10 +485,10 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
call dtime_check(dtime, in_curbin, in_anybin)
if(.not.in_anybin) cycle
+ landsfctype =( itype==181 .or. itype==183 .or. itype==187 )
! Flag static conditions to create PBL_pseudo_surfobsq obs.
- l_pbl_pseudo_itype = l_pbl_pseudo_surfobsq .and. &
- ( itype==181 .or. itype==183 .or.itype==187 )
+ l_pbl_pseudo_itype = l_pbl_pseudo_surfobsq .and. landsfctype
if(in_curbin) then
! Convert obs lats and lons to grid coordinates
@@ -506,27 +551,50 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,&
nsig,mype,nfldsig)
+
+
+! GEOVALS for UFO eval
+ psges2 = psges ! keep in cb
+ prsltmp2 = exp(prsltmp)
+ call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime,hrdifsig,&
+ nsig+1,mype,nfldsig)
+ call tintrp2a1(ges_tsen,ttmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(ges_q,qtmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(ges_u,utmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(ges_v,vtmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(geop_hgtl,hsges,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+
+! END GEOVALS
presq=r10*exp(dpres)
itype=ictype(ikx)
dprpx=zero
- if(((itype > 179 .and. itype < 190) .or. itype == 199) &
+
+ if ( hofx_2m_sfcfile .and. landsfctype) then
+ dpres = one ! put obs on surface
+ else
+ if(((itype > 179 .and. itype < 190) .or. itype == 199) &
.and. .not.twodvar_regional)then
- dprpx=abs(one-exp(dpres-log(psges)))*r10
- end if
+ dprpx=abs(one-exp(dpres-log(psges)))*r10
+ endif
! Put obs pressure in correct units to get grid coord. number
- call grdcrd1(dpres,prsltmp(1),nsig,-1)
+ call grdcrd1(dpres,prsltmp(1),nsig,-1)
! Get approximate k value of surface by using surface pressure
- sfcchk=log(psges)
- call grdcrd1(sfcchk,prsltmp(1),nsig,-1)
+ sfcchk=log(psges)
+ call grdcrd1(sfcchk,prsltmp(1),nsig,-1)
! Check to see if observations is above the top of the model (regional mode)
- if( dpres>=nsig+1)dprpx=1.e6_r_kind
- if((itype > 179 .and. itype < 186) .or. itype == 199) dpres=one
+ if( dpres>=nsig+1)dprpx=1.e6_r_kind
+ if((itype > 179 .and. itype < 186) .or. itype == 199) dpres=one
+
+ endif
-! Scale errors by guess saturation q
-
qob = data(iqob,i)
if(limitqobs) then
call tintrp31(ges_qsat,qsges,dlat,dlon,dpres,dtime,hrdifsig,&
@@ -534,11 +602,13 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
qob=min(qob,superfact*qsges)
end if
+! get qsges, to be used to scale the obs error
call tintrp31(qg,qsges,dlat,dlon,dpres,dtime,hrdifsig,&
mype,nfldsig)
-! Interpolate 2-m qs to obs locations/times
- if((i_use_2mq4b > 0) .and. ((itype > 179 .and. itype < 190) .or. itype == 199) &
- .and. .not.twodvar_regional)then
+
+! overwrite qsges with 2-m qs if sfc obs scheme
+ if( ( (i_use_2mq4b > 0) .and. ((itype > 179 .and. itype < 190) .or. itype == 199) &
+ .and. .not.twodvar_regional) .or. (hofx_2m_sfcfile .and. landsfctype) )then
call tintrp2a11(qg2m,qsges,dlat,dlon,dtime,hrdifsig,mype,nfldsig)
endif
@@ -549,10 +619,36 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
rmaxerr=max(small2,rmaxerr)
errorx =(data(ier,i)+dprpx)*qsges
-! Interpolate guess moisture to observation location and time
- call tintrp31(ges_q,qges,dlat,dlon,dpres,dtime, &
- hrdifsig,mype,nfldsig)
-
+! qges: Interpolate guess moisture to observation location and time
+
+ if (.not. ( hofx_2m_sfcfile .and. landsfctype) ) then
+ call tintrp31(ges_q,qges,dlat,dlon,dpres,dtime, &
+ hrdifsig,mype,nfldsig)
+ else
+ ! only use land locations
+ if (int(data(idomsfc,i)) .NE. 1 ) muse(i) = .false.
+
+ call tintrp2a11(ges_q2m,qges,dlat,dlon,dtime,hrdifsig,mype,nfldsig)
+
+ ! terrain correction: assume RH_zo = RH_zm, and correct T with
+ ! same lapse rate as used for T2m terrain correction
+
+ delta_z = data(istnelv,i) - data(izz,i) ! obs -model
+
+ do jj=1,nfldsig
+ ! qsat in model at height of obs
+ call genqsat(qg2m_o(:,:,jj),ges_t2m(:,:,jj)+delta_z*T_lapse,ges_ps(:,:,jj),lat2,lon2,1,ice,iderivative)
+ enddo
+
+ call tintrp2a11(qg2m_o,qsges_o,dlat,dlon,dtime,hrdifsig,mype,nfldsig)
+ q_delta_terrain = (qsges/qsges_o - 1)*qob
+ qob = qob * ( qsges/qsges_o)
+
+ !update the station elevation
+ data(istnelv,i) = data(izz,i)
+
+ endif
+
ddiff=qob-qges
! Setup dynamic ob error specification for aircraft recon in hurricanes
@@ -572,18 +668,22 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
endif
errorx =max(small1,errorx)
-
! Adjust observation error to reflect the size of the residual.
! If extrapolation occurred, then further adjust error according to
! amount of extrapolation.
- rlow=max(sfcchk-dpres,zero)
+ if (.not. (hofx_2m_sfcfile .and. landsfctype) ) then
+ rlow=max(sfcchk-dpres,zero)
! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface]
- if(l_sfcobserror_ramp_q) then
- ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind)*0.001_r_kind
+ if(l_sfcobserror_ramp_q) then
+ ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind)*0.001_r_kind
+ else
+ ramp=rlow
+ endif
else
- ramp=rlow
+ rlow = zero
+ ramp = zero
endif
rhgh=max(dpres-r0_001-rsig,zero)
@@ -594,14 +694,27 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
if(rhgh/=zero) awork(3) = awork(3) + one
end if
- ratio_errors=error*qsges/(errorx+1.0e6_r_kind*rhgh+r8*ramp)
+! inflate error for uncertainty in the terrain adjustment
+ lapse_error = 0.
+ if ( hofx_2m_sfcfile .and. landsfctype) then
+ if (abs(delta_z)max_delta_z do not assim.
+ ! inflate obs error to account for error in lapse_rate
+ ! also include some representativity error here (assuming
+ ! delta_z ~ heterogeneity)
+ lapse_error = abs(lapse_error_frac*q_delta_terrain)
+ else
+ muse(i)=.false.
+ endif
+ endif
+
+ ratio_errors=error*qsges/(errorx+1.0e6_r_kind*rhgh+r8*ramp + lapse_error)
! Check to see if observations is above the top of the model (regional mode)
if (dpres > rsig) ratio_errors=zero
error=one/(error*qsges)
iz = max(1, min( int(dpres), nsig))
- delz = max(zero, min(dpres - float(iz), one))
+ delz = max(zero, min(dpres - real(iz,r_kind), one))
if (save_jacobian) then
@@ -618,7 +731,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
dhx_dx%val(2) = delz ! weight for iz+1's level
endif
-! Interpolate 2-m q to obs locations/times
+! i_use_2mq4b: Interpolate 2-m q to obs locations/times
if(i_use_2mq4b>0 .and. itype > 179 .and. itype < 190 .and. .not.twodvar_regional)then
if(i_coastline==2 .or. i_coastline==3) then
@@ -643,7 +756,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
call stop2(100)
endif
ddiff=qob-qges
- endif
+ endif ! i_use_2mq4b
! If requested, setup for single obs test.
@@ -943,7 +1056,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
my_head => null()
ENDDO
- endif ! 181,183,187
+ endif ! l_pbl_pseudo_itype
!!!!!!!!!!!!!!!!!! PBL pseudo surface obs !!!!!!!!!!!!!!!!!!!!!!!
! End of loop over observations
@@ -1025,7 +1138,7 @@ subroutine init_vars_
call stop2(999)
endif
! get q2m ...
- if (i_use_2mq4b>0) then
+ if (i_use_2mq4b>0 .or. hofx_2m_sfcfile) then
varname='q2m'
call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus)
if (istatus==0) then
@@ -1044,6 +1157,61 @@ subroutine init_vars_
call stop2(999)
endif
endif ! i_use_2mq4b
+ if (hofx_2m_sfcfile) then
+ varname='t2m'
+ call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus)
+ if (istatus==0) then
+ if(allocated(ges_t2m))then
+ write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
+ call stop2(999)
+ endif
+ allocate(ges_t2m(size(rank2,1),size(rank2,2),nfldsig))
+ ges_t2m(:,:,1)=rank2
+ do ifld=2,nfldsig
+ call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus)
+ ges_t2m(:,:,ifld)=rank2
+ enddo
+ else
+ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
+ call stop2(999)
+ endif
+ endif ! hofx_2m_sfcfile
+! get u ...
+ varname='u'
+ call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus)
+ if (istatus==0) then
+ if(allocated(ges_u))then
+ write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
+ call stop2(999)
+ endif
+ allocate(ges_u(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig))
+ ges_u(:,:,:,1)=rank3
+ do ifld=2,nfldsig
+ call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus)
+ ges_u(:,:,:,ifld)=rank3
+ enddo
+ else
+ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
+ call stop2(999)
+ endif
+! get v ...
+ varname='v'
+ call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus)
+ if (istatus==0) then
+ if(allocated(ges_v))then
+ write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
+ call stop2(999)
+ endif
+ allocate(ges_v(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig))
+ ges_v(:,:,:,1)=rank3
+ do ifld=2,nfldsig
+ call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus)
+ ges_v(:,:,:,ifld)=rank3
+ enddo
+ else
+ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
+ call stop2(999)
+ endif
! get q ...
varname='q'
call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus)
@@ -1140,6 +1308,11 @@ subroutine contents_binary_diag_(odiag)
rdiagbuf(20,ii) = qsges ! guess saturation specific humidity
rdiagbuf(21,ii) = 1e+10_r_single ! spread (filled in by EnKF)
+ if (l_rtma3d .or. twodvar_regional) then ! in binary obsdiag for 2D/3DRTMA
+ rdiagbuf(22,ii) = data(itemp,i) ! dry temperature associated to qob
+ rdiagbuf(23,ii) = data(iqt, i) ! tv flag (0: virtual temp; 1: sensible temp)
+ end if
+
ioff=ioff0
if (lobsdiagsave) then
do jj=1,miter
@@ -1217,6 +1390,11 @@ subroutine contents_binary_diagp_(odiag)
rdiagbufp(20,iip) = qsges ! guess saturation specific humidity
rdiagbufp(21,iip) = 1e+10_r_single ! spread (filled in by EnKF)
+ if (l_rtma3d .or. twodvar_regional) then ! in binary obsdiag for 2D/3DRTMA
+ rdiagbufp(22,ii) = data(itemp,i) ! dry temperature associated to qob
+ rdiagbufp(23,ii) = data(iqt, i) ! tv flag (0: virtual temp; 1: sensible temp)
+ end if
+
ioff=ioff0
!----
if (lobsdiagsave) then
@@ -1270,29 +1448,36 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_metadata("Observation_Class", obsclass )
call nc_diag_metadata("Observation_Type", ictype(ikx) )
call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
- call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) )
- call nc_diag_metadata("Pressure", sngl(presq) )
- call nc_diag_metadata("Height", sngl(data(iobshgt,i)) )
- call nc_diag_metadata("Time", sngl(dtime-time_offset))
- call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) )
- call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) )
- call nc_diag_metadata("Nonlinear_QC_Var_Jb", sngl(var_jb) )
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
+ call nc_diag_metadata_to_single("Latitude", data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude", data(ilone,i) )
+! this is the obs height after being interpolated to the model (=model height)
+ call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) )
+ call nc_diag_metadata_to_single("Pressure", presq )
+! this is the original obs height (= stn elevation, before being interpolated)
+ call nc_diag_metadata_to_single("Height", data(iobshgt,i) )
+ call nc_diag_metadata_to_single("Time", dtime,time_offset,'-' )
+ call nc_diag_metadata_to_single("Prep_QC_Mark", data(iqc,i) )
+ call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) )
+ call nc_diag_metadata_to_single("Nonlinear_QC_Var_Jb",var_jb )
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt )
if(muse(i)) then
- call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
+ call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single )
else
- call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
+ call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single )
endif
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
-
- call nc_diag_metadata("Observation", sngl(data(iqob,i)))
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(qob-qges) )
- call nc_diag_metadata("Forecast_Saturation_Spec_Hum", sngl(qsges) )
+ call nc_diag_metadata_to_single("Errinv_Input", errinv_input )
+ call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst )
+ call nc_diag_metadata_to_single("Errinv_Final", errinv_final )
+
+ call nc_diag_metadata_to_single("Observation", data(iqob,i) )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",qob,qges,'-')
+ call nc_diag_metadata_to_single("Forecast_Saturation_Spec_Hum",qsges )
+ if (l_rtma3d .or. twodvar_regional) then
+ call nc_diag_metadata_to_single("Observation_Tdry", data(itemp,i) )
+ call nc_diag_metadata_to_single("Setup_QC_Mark", data(iqt, i) )
+ endif
+
if (lobsdiagsave) then
do jj=1,miter
if (odiag%muse(jj)) then
@@ -1305,14 +1490,14 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse )
call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart )
call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart )
- call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen )
+ call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen )
endif
if (twodvar_regional .or. l_obsprvdiag) then
call nc_diag_metadata("Dominant_Sfc_Type", data(idomsfc,i) )
call nc_diag_metadata("Model_Terrain", data(izz,i) )
r_prvstg = data(iprvd,i)
- call nc_diag_metadata("Provider_Name", c_prvstg )
+ call nc_diag_metadata("Provider_Name", c_prvstg )
r_sprvstg = data(isprvd,i)
call nc_diag_metadata("Subprovider_Name", c_sprvstg )
endif
@@ -1322,6 +1507,40 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val,r_single))
endif
+ ! GEOVALS
+ !>>emily
+ do k = 1, nsig
+ kk = nsig-k+1
+ utmp_reverse(kk) = utmp(k)
+ vtmp_reverse(kk) = vtmp(k)
+ ttmp_reverse(kk) = ttmp(k)
+ !tvtmp_reverse(kk) = tges(k) !emily
+ qtmp_reverse(kk) = qtmp(k)
+ hsges_reverse(kk) = hsges(k)
+! zges_read_reverse(kk)= zges_read(k)
+! zges_geometric_reverse(kk)= zges_geometric(k)
+ !zges_reverse(kk) = zges(k)
+ prsltmp2_reverse(kk) = prsltmp2(k)
+ enddo
+ do k = 1, nsig+1
+ kk = (nsig+1)-k+1
+ prsitmp_reverse(kk) = prsitmp(k)
+ enddo
+ call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(prsltmp2_reverse*r1000))
+ call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(prsitmp_reverse*r1000))
+ call nc_diag_data2d("air_temperature", sngl(ttmp_reverse))
+ call nc_diag_data2d("virtual_temperature", sngl(tvtmp_reverse)) !emily
+ call nc_diag_data2d("specific_humidity", sngl(qtmp_reverse))
+ call nc_diag_data2d("eastward_wind", sngl(utmp_reverse))
+ call nc_diag_data2d("northward_wind", sngl(vtmp_reverse))
+ call nc_diag_data2d("geopotential_height", sngl(hsges_reverse)) !orig
+! call nc_diag_data2d("geopotential_height", sngl(zges_read_reverse)) !emily
+! call nc_diag_data2d("geometric_height", sngl(zges_geometric_reverse)) !emily
+ !< nchanl)then
@@ -551,19 +581,20 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
end if
! Load channel numbers into local array based on satellite type
+ if (iuse_rad(j)==4) then
+ predx(:,j)=zero
+ endif
ich(jc)=j
do i=1,npred
- if (iuse_rad(j)==4) predx(i,j)=zero
predchan(i,jc)=predx(i,j)
end do
!
! Set error instrument channels
tnoise(jc)=varch(j)
- channel_passive=iuse_rad(j)==-1 .or. iuse_rad(j)==0
- if (iuse_rad(j)< -1 .or. (channel_passive .and. &
+ if (iuse_rad(j)< -1 .or. (channel_passive(j) .and. &
.not.rad_diagsave)) tnoise(jc)=r1e10
- if (passive_bc .and. channel_passive) tnoise(jc)=varch(j)
+ if (passive_bc .and. channel_passive(j)) tnoise(jc)=varch(j)
if (iuse_rad(j)>0) l_may_be_passive=.true.
if (tnoise(jc) < 1.e4_r_kind) toss = .false.
@@ -589,6 +620,26 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
return
endif
+! Load data array for current satellite
+ read(lunin) data_s,luse,ioid
+
+ if (nobskeep>0) then
+! write(6,*)'setuprad: nobskeep',nobskeep
+ call stop2(275)
+ end if
+
+ call dtime_setup()
+! If using CADS setup arrays and calculate imager BTs
+ imager_cluster_fraction=zero
+ imager_cluster_bt=zero
+ imager_chan_stdev=zero
+ imager_model_bt=zero
+ if ((iasi_cads .and. iasi) .or. (cris_cads .and. cris)) then
+
+ call cads_imager_calc(obstype,isis,nobs,nreal,nchanl,nsig,data_s,init_pass,mype, &
+ imager_cluster_fraction,imager_cluster_bt,imager_chan_stdev, imager_model_bt)
+ endif ! using cads
+
if ( mype == 0 .and. .not.l_may_be_passive) write(6,*)mype,'setuprad: passive obs',is,isis
! Logic to turn off print of reading coefficients if not first interation or not mype_diaghdr or not init_pass
@@ -695,8 +746,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
endif
endif
-
-
! Find number of channels written to diag file
if(reduce_diag)then
nchanl_diag=0
@@ -766,14 +815,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
if (netcdf_diag) call init_netcdf_diag_
endif
-! Load data array for current satellite
- read(lunin) data_s,luse,ioid
-
- if (nobskeep>0) then
-! write(6,*)'setuprad: nobskeep',nobskeep
- call stop2(275)
- end if
-
! PROCESSING OF SATELLITE DATA
! Loop over data in this block
@@ -800,6 +841,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
zsges=data_s(izz,n)
nadir = nint(data_s(iscan_pos,n))
pangs = data_s(iszen_ang,n)
+ if (iasi) then
+ cloud_frac = data_s(21,n)
+ else
+ cloud_frac = r_missing
+ end if
! Extract warm load temperatures
! wltm1 = data_s(isty,n)
! wltm2 = data_s(istp,n)
@@ -815,7 +861,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
if(seviri .and. abs(data_s(iszen_ang,n)) > 180.0_r_kind) data_s(iszen_ang,n)=r100
-! Set land/sea, snow, ice percentages and flags (no time interpolation)
+! Set land/sea, snow, i e percentages and flags (no time interpolation)
sea = data_s(ifrac_sea,n) >= 0.99_r_kind
land = data_s(ifrac_lnd,n) >= 0.99_r_kind
@@ -847,25 +893,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
iinstr=getindex(idnames,trim(covtype))
endif
endif
- do jc=1,nchanl
- j=ich(jc)
-
- tnoise(jc)=varch(j)
-
- if(sea .and. (varch_sea(j)>zero)) tnoise(jc)=varch_sea(j)
- if(land .and. (varch_land(j)>zero)) tnoise(jc)=varch_land(j)
- if(ice .and. (varch_ice(j)>zero)) tnoise(jc)=varch_ice(j)
- if(snow .and. (varch_snow(j)>zero)) tnoise(jc)=varch_snow(j)
- if(mixed .and. (varch_mixed(j)>zero)) tnoise(jc)=varch_mixed(j)
- tnoise_save = tnoise(jc)
-
- channel_passive=iuse_rad(j)==-1 .or. iuse_rad(j)==0
- if (iuse_rad(j)< -1 .or. (channel_passive .and. &
- .not.rad_diagsave)) tnoise(jc)=r1e10
- if (passive_bc .and. channel_passive) tnoise(jc)=tnoise_save
- if (tnoise(jc) < 1.e4_r_kind) toss = .false.
- end do
-
! Count data of different surface types
if(luse(n))then
if (mixed) then
@@ -886,9 +913,30 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
endif
endif
+ do jc=1,nchanl
+ j=ich(jc)
+
+ tnoise(jc)=varch(j)
+
+ if(mixed .and. (varch_mixed(j)>zero)) then
+ tnoise(jc)=varch_mixed(j)
+ else if(snow .and. (varch_snow(j)>zero)) then
+ tnoise(jc)=varch_snow(j)
+ else if(ice .and. (varch_ice(j)>zero)) then
+ tnoise(jc)=varch_ice(j)
+ else if(land .and. (varch_land(j)>zero)) then
+ tnoise(jc)=varch_land(j)
+ else if(sea .and. (varch_sea(j)>zero)) then
+ tnoise(jc)=varch_sea(j)
+ end if
+
+ if (.not. (passive_bc .and. channel_passive(j))) then
+ if (iuse_rad(j)< -1 .or. (channel_passive(j) .and. &
+ .not.rad_diagsave)) tnoise(jc)=r1e10
+ end if
+
! Load channel data into work array.
- do i = 1,nchanl
- tb_obs(i) = data_s(i+nreal,n)
+ tb_obs(jc) = data_s(jc+nreal,n)
end do
@@ -901,7 +949,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, &
tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, &
trop5,tzbgr,dtsavg,sfc_speed, &
- tsim,emissivity,ptau5,ts,emissivity_k, &
+ tsim,emissivity,chan_level,ptau5,ts,emissivity_k, &
temp,wmix,jacobian,error_status,tsim_clr=tsim_clr,tcc=tcc, &
tcwv=tcwv,hwp_ratio=hwp_ratio,stability=stability)
if(gmi) then
@@ -912,7 +960,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, &
tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, &
trop5,tzbgr,dtsavg,sfc_speed, &
- tsim2,emissivity2,ptau52,ts2,emissivity_k2, &
+ tsim2,emissivity2,chan_level,ptau52,ts2,emissivity_k2, &
temp2,wmix2,jacobian2,error_status,tsim_clr=tsim_clr2,tcc=tcc,&
tcwv=tcwv,hwp_ratio=hwp_ratio,stability=stability)
! merge
@@ -936,7 +984,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, &
tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, &
trop5,tzbgr,dtsavg,sfc_speed, &
- tsim,emissivity,ptau5,ts,emissivity_k, &
+ tsim,emissivity,chan_level,ptau5,ts,emissivity_k, &
temp,wmix,jacobian,error_status)
if(gmi) then
gmi_low_angles(1:3)=data_s(ilzen_ang:iscan_ang,n)
@@ -946,7 +994,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
call call_crtm(obstype,dtime,data_s(:,n),nchanl,nreal,ich, &
tvp,qvp,qs,clw_guess,ciw_guess,rain_guess,snow_guess,prsltmp,prsitmp, &
trop5,tzbgr,dtsavg,sfc_speed, &
- tsim2,emissivity2,ptau52,ts2,emissivity_k2, &
+ tsim2,emissivity2,chan_level,ptau52,ts2,emissivity_k2, &
temp2,wmix2,jacobian2,error_status)
! merge
emissivity(10:13) = emissivity2(10:13)
@@ -996,10 +1044,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
tsavg5=tsavg5+dtsavg
endif
+! Compute microwave cloud liquid water or graupel water path for bias correction and QC.
+ if (adp_anglebc) then
! If using adaptive angle dependent bias correction, update the predicctors
! for this part of bias correction. The AMSUA cloud liquid water algorithm
! uses total angle dependent bias correction for channels 1 and 2
- if (adp_anglebc) then
do i=1,nchanl
mm=ich(i)
if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then
@@ -1018,8 +1067,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
end if
end do
end if
-
-! Compute microwave cloud liquid water or graupel water path for bias correction and QC.
+!*****
clw_obs=zero
clw_guess_retrieval=zero
gwp=zero
@@ -1056,10 +1104,8 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
id_qc(1:nchanl) = ifail_cloud_qc
endif
endif
- endif
! Screening for cold-air outbreak area (only applied to MW for now)
- if (cao_check .and. radmod%lprecip) then
- if(microwave .and. sea) then
+ if (cao_check .and. radmod%lprecip) then
if(radmod%lcloud_fwd) then
cao_flag = (stability < 12.0_r_kind) .and. (hwp_ratio < half) .and. (tcwv < 8.0_r_kind)
if (cao_flag) then ! remove all tropospheric channels
@@ -1082,12 +1128,14 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
endif
endif
+! totbc = total bias correction !emily
+ totbc=zero !emily
predbias=zero
- cld_rbc_idx2=zero
+
+!$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias)
do i=1,nchanl
mm=ich(i)
-
!*****
! COMPUTE AND APPLY BIAS CORRECTION TO SIMULATED VALUES
!*****
@@ -1113,30 +1161,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
else
pred(3,i) = clw_obs*cosza*cosza
end if
+
if(radmod%lcloud_fwd .and. sea) pred(3,i ) = zero
-
-
-
! Apply bias correction
-
- kmax(i) = 0
- if (lwrite_peakwt .or. passive_bc) then
- ptau5derivmax = -9.9e31_r_kind
-! maximum of weighting function is level at which transmittance
-! (ptau5) is changing the fastest. This is used for the level
-! assignment (needed for vertical localization).
- weightmax(i) = zero
- do k=2,nsig
- ptau5deriv = abs( (ptau5(k-1,i)-ptau5(k,i))/ &
- (log(prsltmp(k-1))-log(prsltmp(k))) )
- if (ptau5deriv > ptau5derivmax) then
- ptau5derivmax = ptau5deriv
- kmax(i) = k
- weightmax(i) = r10*prsitmp(k) ! cb to mb.
- end if
- enddo
- end if
tlapchn(i)= (ptau5(2,i)-ptau5(1,i))*(tsavg5-tvp(2))
do k=2,nsig-1
@@ -1182,22 +1210,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
end do
end if
- if (abi2km .and. regional) then
- abi2km_bc = zero
- abi2km_bc(2) = 233.5_r_kind
- abi2km_bc(3) = 241.7_r_kind
- abi2km_bc(4) = 250.5_r_kind
- pred(:,i) = zero
- if (i>=2 .and. i<=4) then
- if (tb_obs(i) > 190.0_r_kind .and. tb_obs(i) < 300.0_r_kind) then
- pred(1,i)=1.0_r_kind
- pred(2,i)=tb_obs(i)-abi2km_bc(i)
- pred(3,i)=(tb_obs(i)-abi2km_bc(i))**2
- pred(4,i)=(tb_obs(i)-abi2km_bc(i))**3
- end if
- end if
- end if
-
do j = 1,npred
predbias(j,i) = predchan(j,i)*pred(j,i)
end do
@@ -1214,12 +1226,14 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
! tbcnob = obs - guess before bias correction
tbcnob(i) = tb_obs(i) - tsim(i)
tbc(i) = tbcnob(i)
-
+
do j=1, npred-angord
tbc(i)=tbc(i) - predbias(j,i) !obs-ges with bias correction
+ totbc(i) = totbc(i) + predbias(j,i)
end do
tbc(i)=tbc(i) - predbias(npred+1,i)
tbc(i)=tbc(i) - predbias(npred+2,i)
+ totbc(i) = totbc(i) + predbias(npred+1,i)+predbias(npred+2,i)
! Calculate cloud effect for QC
if (radmod%cld_effect .and. eff_area) then
@@ -1234,15 +1248,37 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
bias = bias+predbias(npred+2,i)
cldeff_obs(i)=cldeff_obs(i) - bias ! observed cloud delta (bias corrected)
endif
+ end do
+ kmax = 0
+ if (lwrite_peakwt .or. passive_bc) then
+!$omp parallel do schedule(dynamic,1) private(i,k,ptau5derivmax,ptau5deriv)
+ do i=1,nchanl
+ ptau5derivmax = -9.9e31_r_kind
+! maximum of weighting function is level at which transmittance
+! (ptau5) is changing the fastest. This is used for the level
+! assignment (needed for vertical localization).
+ weightmax(i) = zero
+ do k=2,nsig
+ ptau5deriv = abs( (ptau5(k-1,i)-ptau5(k,i))/ &
+ (log(prsltmp(k-1))-log(prsltmp(k))) )
+ if (ptau5deriv > ptau5derivmax) then
+ ptau5derivmax = ptau5deriv
+ kmax(i) = k
+ weightmax(i) = r10*prsitmp(k) ! cb to mb.
+ end if
+ enddo
! End of loop over channels
- end do
+ end do
+ end if
! Compute retrieved microwave cloud liquid water and
! assign cld_rbc_idx for bias correction in allsky conditions
cld_rbc_idx=one
+ cld_rbc_idx2=zero
if (radmod%lcloud_fwd .and. radmod%ex_biascor .and. eff_area) then
ierrret=0
+!$omp parallel do schedule(dynamic,1) private(i,mm,j)
do i=1,nchanl
mm=ich(i)
tsim_bc(i)=tsim(i)
@@ -1258,19 +1294,19 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
tsim_clr_bc(i)=tsim_clr_bc(i)+predbias(npred+2,i)
end do
- if(amsua.or.atms) call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret)
- if(gmi) then
- call gmi_37pol_diff(tsim_bc(6),tsim_bc(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_guess_retrieval,ierrret)
- call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_obs,ierrret)
+ if(amsua.or.atms) then
+ call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret)
+ else if(gmi) then
+ call gmi_37pol_diff(tsim(6),tsim(7),tsim_clr(6),tsim_clr(7),clw_guess_retrieval,ierrret)
+ call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr(6),tsim_clr(7),clw_obs,ierrret)
end if
if (radmod%ex_obserr=='ex_obserr1') then
call radiance_ex_biascor(radmod,nchanl,tsim_bc,tsavg5,zasat, &
clw_guess_retrieval,clw_obs,cld_rbc_idx,ierrret)
- end if
-! if (radmod%ex_obserr=='ex_obserr2') then ! comment out for now, need to be tested
+! else if (radmod%ex_obserr=='ex_obserr2') then ! comment out for now, need to be tested
! call radiance_ex_biascor(radmod,nchanl,cldeff_obs,cldeff_fg,cld_rbc_idx)
! end if
- if (radmod%ex_obserr=='ex_obserr3') then
+ else if (radmod%ex_obserr=='ex_obserr3') then
call radiance_ex_biascor_gmi(radmod,clw_obs,clw_guess_retrieval,nchanl,cld_rbc_idx)
end if
@@ -1296,11 +1332,12 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
do i=1,nchanl
pred(6,i) = zero
pred(7,i) = zero
- clw_avg = half*(clw_obs+clw_guess_retrieval)
+! Need to investigate clw_ave = half*(clw_obs+clw_guess_retrieval)
+ clw_avg = zero
if (i > 3 .and. clw_obs > 0.05_r_kind .and. clw_guess_retrieval > 0.05_r_kind .and. &
- abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = one
+ abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = zero
if (i < 5 .and. clw_obs > 0.2_r_kind .and. clw_guess_retrieval > 0.2_r_kind .and. &
- abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = one
+ abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = zero
if( i > 3 .and. clw_obs > 0.05_r_kind .and. clw_guess_retrieval > 0.05_r_kind .and. cld_rbc_idx(i) == zero) then
pred(6,i) = clw_avg*clw_avg
@@ -1323,17 +1360,17 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
! Assign observation error for all-sky radiances
if (radmod%lcloud_fwd .and. eff_area) then
- if (radmod%ex_obserr=='ex_obserr1') &
+ if (radmod%ex_obserr=='ex_obserr1') then
call radiance_ex_obserr(radmod,nchanl,clw_obs,clw_guess_retrieval,tnoise,tnoise_cld,error0)
- if (radmod%ex_obserr=='ex_obserr3') &
+ else if (radmod%ex_obserr=='ex_obserr3') then
call radiance_ex_obserr_gmi(radmod,nchanl,clw_obs,clw_guess_retrieval,tnoise,tnoise_cld,error0)
+ end if
end if
do i=1,nchanl
mm=ich(i)
- channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0
- if(tnoise(i) < 1.e4_r_kind .or. (channel_passive .and. rad_diagsave) &
- .or. (passive_bc .and. channel_passive))then
+ if(tnoise(i) < 1.e4_r_kind .or. (channel_passive(mm) .and. rad_diagsave) &
+ .or. (passive_bc .and. channel_passive(mm)))then
varinv(i) = varinv(i)/error0(i)**2
errf(i) = error0(i)
else
@@ -1365,20 +1402,18 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
do i=1,nchanl
m=ich(i)
- if (varinv(i) < tiny_r_kind) then
- varinv_use(i) = zero
+ if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then
+ varinv_use(i) = varinv(i)
else
- if ((icld_det(m)>0)) then
- varinv_use(i) = varinv(i)
- else
- varinv_use(i) = zero
- end if
+ varinv_use(i) = zero
end if
end do
- call qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n),goessndr, &
- cris,hirs,zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, &
- wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, &
- id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole(n))
+
+ call qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n),goessndr,airs,cris,iasi, &
+ hirs,zsges,cenlat,frac_sea,pangs,trop5,zasat,tzbgr,tsavg5,tbc,tb_obs,tbcnob,tnoise, &
+ wavenumber,ptau5,prsltmp,tvp,temp,wmix,chan_level,emissivity_k,ts,tsim, &
+ id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,zero_irjaco3_pole(n), &
+ imager_cluster_fraction(:,n), imager_cluster_bt(:,:,n), imager_chan_stdev(:,n),imager_model_bt(:,n))
! --------- MSU -------------------
! QC MSU data
@@ -1399,7 +1434,8 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
call qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse(n), &
zsges,cenlat,tb_obsbc1,cosza,clw_obs,tbc,ptau5,emissivity_k,ts, &
- pred,predchan,id_qc,aivals,errf,errf0,clw_obs,varinv,cldeff_obs,cldeff_fg,factch6, &
+ pred,predchan,id_qc,aivals,errf,errf0,clw_obs,varinv,varinv_sdoei,varinv_grosschk,varinv_after_jsfcchk,varinv_after_sdoei,cldeff_obs,cldeff_fg,factch6,factch4,qc4emiss_out, & !emily
+ ! pred,predchan,id_qc,aivals,errf,errf0,clw_obs,varinv,cldeff_obs,cldeff_fg,factch6, & !orig
cld_rbc_idx,sfc_speed,error0,clw_guess_retrieval,scatp,radmod)
! If cloud impacted channels not used turn off predictor
@@ -1440,7 +1476,8 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
call qc_atms(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse(n), &
zsges,cenlat,tb_obsbc1,cosza,clw_obs,tbc,ptau5,emissivity_k,ts, &
- pred,predchan,id_qc,aivals,errf,errf0,clw_obs,varinv,cldeff_obs,cldeff_fg,factch6, &
+ pred,predchan,id_qc,aivals,errf,errf0,clw_obs,varinv,varinv_sdoei,varinv_grosschk,varinv_after_jsfcchk,varinv_after_sdoei,cldeff_obs,cldeff_fg,factch6,factch4,qc4emiss_out, & ! emily
+ ! pred,predchan,id_qc,aivals,errf,errf0,clw_obs,varinv,cldeff_obs,cldeff_fg,factch6, & !orig
cld_rbc_idx,sfc_speed,error0,clw_guess_retrieval,scatp,radmod)
! ---------- GOES imager --------------
@@ -1464,14 +1501,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
else if (seviri .or. abi .or. ahi) then
do i=1,nchanl
m=ich(i)
- if (varinv(i) < tiny_r_kind) then
- varinv_use(i) = zero
+ if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then
+ varinv_use(i) = varinv(i)
else
- if ((icld_det(m)>0)) then
- varinv_use(i) = varinv(i)
- else
- varinv_use(i) = zero
- end if
+ varinv_use(i) = zero
end if
end do
@@ -1481,7 +1514,21 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
call qc_geocsr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n), &
zsges,trop5,tzbgr,tsavg5,tb_obs_sdv,tbc,tb_obs,tnoise,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, &
- id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,abi,ahi,seviri)
+! id_qc,aivals,errf,varinv,varinv_use,cld,cldp,kmax,abi,ahi,seviri)
+!>>emily
+ id_qc,aivals,errf,varinv,varinv_use, &
+ varinv_after_sfcterrianchk, &
+ varinv_after_rangechk, &
+ varinv_after_topo, &
+ varinv_after_transmittop, &
+ varinv_after_clddet, &
+ varinv_after_stdchk, &
+ varinv_after_grossroutinechk, &
+ varinv_after_stdadj, &
+ varinv_after_nsstret, &
+ varinv_after_jsfcchk, &
+!<>emily
+ do i=1,nchanl
+ varinv_after_clrfracchk(i) = varinv(i)
+ end do
+!< tiny_r_kind .and. &
- (tb_obs(7)-tb_obs(8))-(tsim(7)-tsim(8)) <= -0.75_r_kind) then
- varinv(i)=zero
- varinv_use(i)=zero
- end if
- end if
- end do
+ if(abi .or. ahi) then
+ do i = 1,nchanl
+ if( i/=2 .and. i/=3 .and.varinv(i) > tiny_r_kind) then
+ if((tb_obs(7)-tb_obs(8))-(tsim(7)-tsim(8)) <= -0.75_r_kind) then
+ varinv(i)=zero
+ end if
+ end if
+ end do
+ end if
!
! ---------- AVRHRR --------------
@@ -1526,20 +1580,18 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
! channels with iuse_rad=-1 or 0 are used in cloud detection.
do i=1,nchanl
m=ich(i)
- if (varinv(i) < tiny_r_kind) then
- varinv_use(i) = zero
+ if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then
+ varinv_use(i) = varinv(i)
else
- if ((icld_det(m)>0)) then
- varinv_use(i) = varinv(i)
- else
- varinv_use(i) = zero
- end if
+ varinv_use(i) = zero
end if
end do
call qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n), &
zsges,cenlat,frac_sea,pangs,trop5,tzbgr,tsavg5,tbc,tb_obs,tnoise, &
wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, &
+ varinv_after_wavenum,varinv_after_rangechk,varinv_after_topo,varinv_after_transmittop, & !emily
+ varinv_after_clddet, varinv_after_nsstret, varinv_after_jsfcchk, & !emily
id_qc,aivals,errf,varinv,varinv_use,cld,cldp)
else if (viirs) then
@@ -1549,20 +1601,18 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
! NOTE: use qc_avhrr for viirs qc
do i=1,nchanl
m=ich(i)
- if (varinv(i) < tiny_r_kind) then
- varinv_use(i) = zero
+ if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then
+ varinv_use(i) = varinv(i)
else
- if ((icld_det(m)>0)) then
- varinv_use(i) = varinv(i)
- else
- varinv_use(i) = zero
- end if
+ varinv_use(i) = zero
end if
end do
call qc_avhrr(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n), &
zsges,cenlat,frac_sea,pangs,trop5,tzbgr,tsavg5,tbc,tb_obs,tnoise, &
wavenumber,ptau5,prsltmp,tvp,temp,wmix,emissivity_k,ts, &
+ varinv_after_wavenum,varinv_after_rangechk,varinv_after_topo,varinv_after_transmittop, & !emily
+ varinv_after_clddet, varinv_after_nsstret, varinv_after_jsfcchk, & !emily
id_qc,aivals,errf,varinv,varinv_use,cld,cldp)
! ---------- SSM/I , SSMIS, AMSRE -------------------
@@ -1570,7 +1620,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
else if( ssmi .or. amsre .or. ssmis )then
- frac_sea=data_s(ifrac_sea,n)
if(amsre)then
bearaz= (270._r_kind-data_s(ilazi_ang,n))*deg2rad
sun_zenith=data_s(iszen_ang,n)*deg2rad
@@ -1583,6 +1632,15 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
zsges,luse(n),sea,mixed, &
temp,wmix,ts,emissivity_k,ierrret,kraintype,tpwc_obs,clw_obs,sgagl,tzbgr, &
tbc,tbcnob,tsim,tnoise,ssmi,amsre_low,amsre_mid,amsre_hig,ssmis, &
+ varinv_after_grossroutinechk_over_ocean, & !emily
+ varinv_after_topo, & !emily
+ varinv_after_sfcchk, & !emily
+ varinv_after_ch2chk, & !emily
+ varinv_after_grossroutinechk,& !emily
+ varinv_after_scatteringchk, & !emily
+ varinv_after_nsstret, & !emily
+ varinv_after_jsfcchk, & !emily
+ pred9,pred10,pred11, & !emily
varinv,errf,aivals(1,is),id_qc)
! ---------- AMSR2 -------------------
@@ -1672,23 +1730,33 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
if(luse(n))aivals(7,is) = aivals(7,is) + one
end if
end if
+ varinv_after_grosschk(i) = varinv(i) !emily
end do
if(amsua .or. atms .or. amsub .or. mhs .or. msu .or. hsb)then
- if(amsua)nlev=6
- if(atms)nlev=7
- if(amsub .or. mhs)nlev=5
- if(hsb)nlev=4
- if(msu)nlev=4
+ if(amsua)then
+ nlev=6
+ else if(atms)then
+ nlev=7
+ else if(amsub .or. mhs)then
+ nlev=5
+ else if(hsb)then
+ nlev=4
+ else if(msu)then
+ nlev=4
+ end if
kval=0
do i=2,nlev
! do i=1,nlev
- channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0
- if (varinv(i)=1) .or. &
- (passive_bc .and. channel_passive))) then
+ mm=ich(i)
+ if (varinv(i)=1) .or. &
+ (passive_bc .and. channel_passive(mm)))) then
kval=max(i-1,kval)
- if(amsub .or. hsb .or. mhs)kval=nlev
- if((amsua .or. atms) .and. i <= 3)kval = zero
+ if(amsub .or. hsb .or. mhs)then
+ kval=nlev
+ else if((amsua .or. atms) .and. i <= 3) then
+ kval = zero
+ end if
end if
end do
if(kval > 0)then
@@ -1699,60 +1767,55 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
if(amsua)then
varinv(15)=zero
if(id_qc(15) == igood_qc)id_qc(15)=ifail_interchan_qc
- end if
- if (atms) then
+ else if (atms) then
varinv(16:18)=zero
if(id_qc(16) == igood_qc)id_qc(16)=ifail_interchan_qc
if(id_qc(17) == igood_qc)id_qc(17)=ifail_interchan_qc
if(id_qc(18) == igood_qc)id_qc(18)=ifail_interchan_qc
end if
end if
- end if
-
- if(mhs.or.amsub)then
- do i = 1, nchanl
- m = ich(i)
- if(sea .and. isst_det(m) >0 .and. tsavg5 < 278.0_r_kind) then
- varinv(i) = zero
- if(id_qc(i) == igood_qc)id_qc(i)=ifail_isst_det
- endif
- if(sea .and. iwndspeed_det(m)>0 .and. tsavg5 < 285.0_r_kind .and. sfc_speed > 10.0_r_kind) then
- varinv(i) = zero
- if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwndspeed_det
- endif
- if(iomg_det(m) > 0 .and. abs(tbcnob(2)) > 5.0_r_kind) then
- varinv(i) = zero
- if(id_qc(i) == igood_qc)id_qc(i)=ifail_iomg_det
- endif
-
- if(itopo_det(m) > 0 .and. zsges > 1000.0_r_kind ) then
- varinv(i) = zero
- if(id_qc(i) == igood_qc)id_qc(i)=ifail_itopo_det
- endif
- enddo
+ if(mhs.or.amsub)then
+ do i = 1, nchanl
+ m = ich(i)
+ if(sea)then
+ if(isst_det(m) >0 .and. tsavg5 < 278.0_r_kind) then
+ varinv(i) = zero
+ if(id_qc(i) == igood_qc)id_qc(i)=ifail_isst_det
+
+ else if(iwndspeed_det(m)>0 .and. tsavg5 < 285.0_r_kind .and. sfc_speed > 10.0_r_kind) then
+ varinv(i) = zero
+ if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwndspeed_det
+ endif
+ end if
+ if(iomg_det(m) > 0 .and. abs(tbcnob(2)) > 5.0_r_kind) then
+ varinv(i) = zero
+ if(id_qc(i) == igood_qc)id_qc(i)=ifail_iomg_det
+
+ else if(itopo_det(m) > 0 .and. zsges > 1000.0_r_kind ) then
+ varinv(i) = zero
+ if(id_qc(i) == igood_qc)id_qc(i)=ifail_itopo_det
+ endif
+ enddo
+ endif
endif
! Screen out land surface types by channel. Flags are set in satinfo file.
do i = 1, nchanl
m = ich(i)
- if(iwater_det(m) > 0 .and. sea) then
+ if(sea .and. iwater_det(m) > 0) then
varinv(i) = zero
if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwater_det
- endif
- if(isnow_det(m) > 0 .and. snow) then
+ else if(snow .and. isnow_det(m) > 0 ) then
varinv(i) = zero
if(id_qc(i) == igood_qc)id_qc(i)=ifail_isnow_det
- endif
- if(mixed .and. imix_det(m) > 0) then
+ else if(mixed .and. imix_det(m) > 0) then
varinv(i) = zero
if(id_qc(i) == igood_qc)id_qc(i)=ifail_imix_det
- endif
- if(land .and. iland_det(m) > 0) then
+ else if(land .and. iland_det(m) > 0) then
varinv(i) = zero
if(id_qc(i) == igood_qc)id_qc(i)=ifail_iland_det
- endif
- if(ice .and. iice_det(m) > 0) then
+ else if(ice .and. iice_det(m) > 0) then
varinv(i) = zero
if(id_qc(i) == igood_qc)id_qc(i)=ifail_iice_det
endif
@@ -1767,39 +1830,37 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
endif
endif
- do i = 1,nchanl
-
! Reject radiances for single radiance test
- if (lsingleradob) then
+ if (lsingleradob) then
+ do i = 1,nchanl
+
! if the channels are beyond 0.01 of oblat/oblon, specified
! in gsi namelist, or aren't of type 'oneob_type', reject
if ( (abs(cenlat - oblat) > one/r100 .or. &
abs(cenlon - oblon) > one/r100) .or. &
obstype /= oneob_type ) then
varinv(i) = zero
- varinv_use(i) = zero
if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range
else
! if obchan <= zero, keep all footprints, if obchan > zero,
! keep only that which has channel obchan
if (i /= obchan .and. obchan > zero) then
varinv(i) = zero
- varinv_use(i) = zero
if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range
endif
endif !cenlat/lon
- endif !lsingleradob
- enddo
+ enddo
+ endif !lsingleradob
diagadd=zero
account_for_corr_obs = .false.
- iii=0
varinv0=zero
+ raterr2 = zero
+!$omp parallel do schedule(dynamic,1) private(ii,m,k,asum)
do ii=1,nchanl
m=ich(ii)
if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then
- iii=iii+1
varinv0(ii)=varinv(ii)
raterr2(ii)=error0(ii)**2*varinv0(ii)
if (l_may_be_passive .and. .not. retrieval) then
@@ -1813,10 +1874,18 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
end if
end if
enddo
+ iii=0
+ do ii=1,nchanl
+ m=ich(ii)
+ if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then
+ iii=iii+1
+ end if
+ end do
err2 = one/error0**2
tbc0=tbc
tb_obs0=tb_obs
- wgtjo=varinv0
+! wgtjo=varinv0 !orig
+ wgtjo=varinv !emily
if (l_may_be_passive .and. .not. retrieval) then
if(iii>0 .and. iinstr.ne.-1)then
chan_count=(iii*(iii+1))/2
@@ -1843,18 +1912,14 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
m = ich(i)
if(luse(n))then
- drad = tbc0(i)
- dradnob = tbcnob(i)
+ drad = tbc0(i)*cld_rbc_idx(i)
+ dradnob = tbcnob(i)*cld_rbc_idx(i)
varrad = tbc(i)*varinv(i)
stats(1,m) = stats(1,m) + one !number of obs
-! stats(3,m) = stats(3,m) + drad !obs-mod(w_biascor)
-! stats(4,m) = stats(4,m) + tbc0(i)*drad !(obs-mod(w_biascor))**2
-! stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution
-! stats(6,m) = stats(6,m) + dradnob !obs-mod(w/o_biascor)
- stats(3,m) = stats(3,m) + drad*cld_rbc_idx(i) !obs-mod(w_biascor)
- stats(4,m) = stats(4,m) + tbc0(i)*drad*cld_rbc_idx(i)!(obs-mod(w_biascor))**2
+ stats(3,m) = stats(3,m) + drad !obs-mod(w_biascor)
+ stats(4,m) = stats(4,m) + tbc0(i)*drad !(obs-mod(w_biascor))**2
stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution
- stats(6,m) = stats(6,m) + dradnob*cld_rbc_idx(i) !obs-mod(w/o_biascor)
+ stats(6,m) = stats(6,m) + dradnob !obs-mod(w/o_biascor)
if (account_for_corr_obs .and. (cor_opt ==1 .or. cor_opt ==2) ) then
exp_arg = -half*tbc(i)**2
@@ -1888,7 +1953,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
! summation of observation number
if (newpc4pred) then
- ostats(m) = ostats(m) + one*cld_rbc_idx(i)
+ ostats(m) = ostats(m) + cld_rbc_idx(i)
end if
end if
@@ -1899,12 +1964,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
! At the end of analysis, prepare for bias correction for monitored channels
! Only "good monitoring" obs are included in J_passive calculation.
- channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0
- if (passive_bc .and. (jiter>miter) .and. channel_passive) then
+ if (passive_bc .and. (jiter>miter) .and. channel_passive(m)) then
! summation of observation number,
! skip ostats accumulation for channels without coef. initialization
if (newpc4pred .and. luse(n) .and. any(predx(:,m)/=zero)) then
- ostats(m) = ostats(m) + one*cld_rbc_idx(i)
+ ostats(m) = ostats(m) + cld_rbc_idx(i)
end if
iccm=iccm+1
end if
@@ -1950,7 +2014,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
my_head%raterr2(icc),my_head%pred(npred,icc), &
my_head%dtb_dvar(nsigradjac,icc), &
my_head%ich(icc),&
- my_head%icx(icc))
+ my_head%icx(icc),my_head%iccerr(icc))
if(luse_obsdiag)allocate(my_head%diags(icc))
call get_ij(mm1,slats,slons,my_head%ij,my_head%wij)
@@ -2018,6 +2082,13 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
end if ! end of newpc4pred loop
end if
end do
+ ncr=0
+ do ii=1,iii
+ my_head%iccerr(ii) = ncr
+ do mm=1,ii
+ ncr=ncr+1
+ end do
+ end do
my_head%nchan = iii ! profile observation count
my_head%use_corr_obs=.false.
@@ -2112,23 +2183,28 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
allocate(my_headm%res(iccm),my_headm%err2(iccm), &
my_headm%raterr2(iccm),my_headm%pred(npred,iccm), &
my_headm%ich(iccm), &
- my_headm%icx(iccm))
+ my_headm%icx(iccm),my_headm%iccerr(iccm))
my_headm%nchan = iccm ! profile observation count
my_headm%time=dtime
my_headm%luse=luse(n)
my_headm%ich(:)=-1
iii=0
+ ncr=0
do ii=1,nchanl
m=ich(ii)
- channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0
- if (varinv(ii)>tiny_r_kind .and. channel_passive) then
+ if (varinv(ii)>tiny_r_kind .and. channel_passive(m)) then
iii=iii+1
my_headm%res(iii)=tbc(ii) ! obs-ges innovation
my_headm%err2(iii)=one/error0(ii)**2 ! 1/(obs error)**2 (original uninflated error)
my_headm%raterr2(iii)=error0(ii)**2*varinv(ii) ! (original error)/(inflated error)
my_headm%icx(iii)=m ! channel index
+ do mm=1,ii
+ ncr=ncr+1
+ end do
+
+ my_headm%iccerr(iii)=ncr ! channel index
do k=1,npred
my_headm%pred(k,iii)=pred(k,ii)*upd_pred(k)*max(cld_rbc_idx(ii),cld_rbc_idx2(ii))
end do
@@ -2562,6 +2638,8 @@ subroutine contents_netcdf_diag_(odiags,idv,iob)
real(r_single),parameter:: missing = -9.99e9_r_single
integer(i_kind),parameter:: imissing = -999999
real(r_kind),dimension(:),allocatable :: predbias_angord
+ character(128) :: fieldname
+ integer(i_kind) :: iabsorb, icloud
if (adp_anglebc) then
allocate(predbias_angord(angord) )
@@ -2571,41 +2649,42 @@ subroutine contents_netcdf_diag_(odiags,idv,iob)
do i=1,nchanl_diag
call nc_diag_metadata("Channel_Index", i )
call nc_diag_metadata("Observation_Class", obsclass )
- call nc_diag_metadata("Latitude", sngl(cenlat) ) ! observation latitude (degrees)
- call nc_diag_metadata("Longitude", sngl(cenlon) ) ! observation longitude (degrees)
+ call nc_diag_metadata_to_single("Latitude",cenlat ) ! observation latitude (degrees)
+ call nc_diag_metadata_to_single("Longitude",cenlon ) ! observation longitude (degrees)
- call nc_diag_metadata("Elevation", sngl(zsges) ) ! model (guess) elevation at observation location
+ call nc_diag_metadata_to_single("Elevation",zsges ) ! model (guess) elevation at observation location
- call nc_diag_metadata("Obs_Time", sngl(dtime-time_offset) ) ! observation time (hours relative to analysis time)
+ call nc_diag_metadata_to_single("Obs_Time",dtime,time_offset,'-')
- call nc_diag_metadata("Scan_Position", sngl(data_s(iscan_pos,n)) ) ! sensor scan position
- call nc_diag_metadata("Sat_Zenith_Angle", sngl(zasat*rad2deg) ) ! satellite zenith angle (degrees)
- call nc_diag_metadata("Sat_Azimuth_Angle", sngl(data_s(ilazi_ang,n)) ) ! satellite azimuth angle (degrees)
- call nc_diag_metadata("Sol_Zenith_Angle", sngl(pangs) ) ! solar zenith angle (degrees)
- call nc_diag_metadata("Sol_Azimuth_Angle", sngl(data_s(isazi_ang,n)) ) ! solar azimuth angle (degrees)
- call nc_diag_metadata("Sun_Glint_Angle", sngl(sgagl) ) ! sun glint angle (degrees) (sgagl)
- call nc_diag_metadata("Scan_Angle", sngl(data_s(iscan_ang,n)*rad2deg) ) ! scan angle
+ call nc_diag_metadata_to_single("Scan_Position",data_s(iscan_pos,n) ) ! sensor scan position
+ call nc_diag_metadata_to_single("Sat_Zenith_Angle", zasat,rad2deg,'*') ! satellite zenith angle (degrees)
+ call nc_diag_metadata_to_single("Sat_Azimuth_Angle",data_s(ilazi_ang,n) ) ! satellite azimuth angle (degrees)
+ call nc_diag_metadata_to_single("Sol_Zenith_Angle",pangs ) ! solar zenith angle (degrees)
+ call nc_diag_metadata_to_single("Sol_Azimuth_Angle",data_s(isazi_ang,n) ) ! solar azimuth angle (degrees)
+ call nc_diag_metadata_to_single("Sun_Glint_Angle",sgagl ) ! sun glint angle (degrees) (sgagl)
+ call nc_diag_metadata_to_single("Scan_Angle",data_s(iscan_ang,n),rad2deg,'*' ) ! scan angle
- call nc_diag_metadata("Water_Fraction", sngl(surface(1)%water_coverage) ) ! fractional coverage by water
- call nc_diag_metadata("Land_Fraction", sngl(surface(1)%land_coverage) ) ! fractional coverage by land
- call nc_diag_metadata("Ice_Fraction", sngl(surface(1)%ice_coverage) ) ! fractional coverage by ice
- call nc_diag_metadata("Snow_Fraction", sngl(surface(1)%snow_coverage) ) ! fractional coverage by snow
+ call nc_diag_metadata_to_single("Water_Fraction",surface(1)%water_coverage ) ! fractional coverage by water
+ call nc_diag_metadata_to_single("Land_Fraction",surface(1)%land_coverage ) ! fractional coverage by land
+ call nc_diag_metadata_to_single("Ice_Fraction",surface(1)%ice_coverage ) ! fractional coverage by ice
+ call nc_diag_metadata_to_single("Snow_Fraction",surface(1)%snow_coverage ) ! fractional coverage by snow
+ call nc_diag_metadata_to_single("fractionOfClearPixelsInFOV",cloud_frac ) ! fractional coverage by snow
if(.not. retrieval)then
- call nc_diag_metadata("Water_Temperature", sngl(surface(1)%water_temperature) ) ! surface temperature over water (K)
- call nc_diag_metadata("Land_Temperature", sngl(surface(1)%land_temperature) ) ! surface temperature over land (K)
- call nc_diag_metadata("Ice_Temperature", sngl(surface(1)%ice_temperature) ) ! surface temperature over ice (K)
- call nc_diag_metadata("Snow_Temperature", sngl(surface(1)%snow_temperature) ) ! surface temperature over snow (K)
- call nc_diag_metadata("Soil_Temperature", sngl(surface(1)%soil_temperature) ) ! soil temperature (K)
- call nc_diag_metadata("Soil_Moisture", sngl(surface(1)%soil_moisture_content) ) ! soil moisture
+ call nc_diag_metadata_to_single("Water_Temperature",surface(1)%water_temperature ) ! surface temperature over water (K)
+ call nc_diag_metadata_to_single("Land_Temperature",surface(1)%land_temperature ) ! surface temperature over land (K)
+ call nc_diag_metadata_to_single("Ice_Temperature",surface(1)%ice_temperature ) ! surface temperature over ice (K)
+ call nc_diag_metadata_to_single("Snow_Temperature",surface(1)%snow_temperature ) ! surface temperature over snow (K)
+ call nc_diag_metadata_to_single("Soil_Temperature",surface(1)%soil_temperature ) ! soil temperature (K)
+ call nc_diag_metadata_to_single("Soil_Moisture",surface(1)%soil_moisture_content ) ! soil moisture
call nc_diag_metadata("Land_Type_Index", surface(1)%land_type ) ! surface land type
- call nc_diag_metadata("tsavg5", missing ) ! SST first guess used for SST retrieval
- call nc_diag_metadata("sstcu", missing ) ! NCEP SST analysis at t
- call nc_diag_metadata("sstph", missing ) ! Physical SST retrieval
- call nc_diag_metadata("sstnv", missing ) ! Navy SST retrieval
+ call nc_diag_metadata("tsavg5", tsavg5 ) ! SST first guess used for SST retrieval
+ call nc_diag_metadata("sstcu", missing ) ! NCEP SST analysis at t
+ call nc_diag_metadata("sstph", missing ) ! Physical SST retrieval
+ call nc_diag_metadata("sstnv", missing ) ! Navy SST retrieval
call nc_diag_metadata("dta", missing ) ! d(ta) corresponding to sstph
call nc_diag_metadata("dqa", missing ) ! d(qa) corresponding to sstph
- call nc_diag_metadata("dtp_avh", missing ) ! data type
+ call nc_diag_metadata("dtp_avh", missing ) ! data type
else
call nc_diag_metadata("Water_Temperature", missing ) ! surface temperature over water (K)
call nc_diag_metadata("Land_Temperature", missing ) ! surface temperature over land (K)
@@ -2614,27 +2693,32 @@ subroutine contents_netcdf_diag_(odiags,idv,iob)
call nc_diag_metadata("Soil_Temperature", missing ) ! soil temperature (K)
call nc_diag_metadata("Soil_Moisture", missing ) ! soil moisture
call nc_diag_metadata("Land_Type_Index", imissing ) ! surface land type
- call nc_diag_metadata("tsavg5", sngl(tsavg5) ) ! SST first guess used for SST retrieval
- call nc_diag_metadata("sstcu", sngl(sstcu) ) ! NCEP SST analysis at t
- call nc_diag_metadata("sstph", sngl(sstph) ) ! Physical SST retrieval
- call nc_diag_metadata("sstnv", sngl(sstnv) ) ! Navy SST retrieval
- call nc_diag_metadata("dta", sngl(dta) ) ! d(ta) corresponding to sstph
- call nc_diag_metadata("dqa", sngl(dqa) ) ! d(qa) corresponding to sstph
- call nc_diag_metadata("dtp_avh", sngl(dtp_avh) ) ! data type
+ call nc_diag_metadata_to_single("tsavg5",tsavg5 ) ! SST first guess used for SST retrieval
+ call nc_diag_metadata_to_single("sstcu",sstcu ) ! NCEP SST analysis at t
+ call nc_diag_metadata_to_single("sstph",sstph ) ! Physical SST retrieval
+ call nc_diag_metadata_to_single("sstnv",sstnv ) ! Navy SST retrieval
+ call nc_diag_metadata_to_single("dta",dta ) ! d(ta) corresponding to sstph
+ call nc_diag_metadata_to_single("dqa",dqa ) ! d(qa) corresponding to sstph
+ call nc_diag_metadata_to_single("dtp_avh",dtp_avh ) ! data type
endif
- call nc_diag_metadata("Vegetation_Fraction", sngl(surface(1)%vegetation_fraction) )
- call nc_diag_metadata("Snow_Depth", sngl(surface(1)%snow_depth) )
- call nc_diag_metadata("tpwc", sngl(tpwc_obs) )
- call nc_diag_metadata("clw_guess_retrieval", sngl(clw_guess_retrieval) )
-
- call nc_diag_metadata("Sfc_Wind_Speed", sngl(surface(1)%wind_speed) )
- call nc_diag_metadata("Cloud_Frac", sngl(cld) )
- call nc_diag_metadata("CTP", sngl(cldp) )
- call nc_diag_metadata("CLW", sngl(clw_obs) )
- call nc_diag_metadata("TPWC", sngl(tpwc_obs) )
- call nc_diag_metadata("clw_obs", sngl(clw_obs) )
- call nc_diag_metadata("clw_guess", sngl(clw_guess) )
+ call nc_diag_metadata_to_single("Vegetation_Fraction",surface(1)%vegetation_fraction )
+ call nc_diag_metadata_to_single("Snow_Depth",surface(1)%snow_depth )
+ call nc_diag_metadata_to_single("tpwc",tpwc_obs )
+ call nc_diag_metadata_to_single("clw_guess_retrieval",clw_guess_retrieval )
+
+ call nc_diag_metadata_to_single("Sfc_Wind_Speed", surface(1)%wind_speed)
+ call nc_diag_metadata_to_single("Cloud_Frac", cld)
+ call nc_diag_metadata_to_single("cloudAmountInSegment", cld) !emily
+ call nc_diag_metadata_to_single("amountSegmentCloudFree",100.0-cld) !emily
+ call nc_diag_metadata_to_single("CTP", cldp)
+ call nc_diag_metadata_to_single("CLW", clw_obs)
+ call nc_diag_metadata_to_single("TPWC", tpwc_obs)
+ call nc_diag_metadata_to_single("clw_obs", clw_obs)
+ call nc_diag_metadata_to_single("clw_guess", clw_guess)
+ call nc_diag_metadata_to_single("factch6", factch6)
+ call nc_diag_metadata_to_single("factch4", factch4) !emily
+ call nc_diag_metadata_to_single("qc4emiss", qc4emiss_out) !emily
if (nstinfo==0) then
data_s(itref,n) = missing
@@ -2643,21 +2727,117 @@ subroutine contents_netcdf_diag_(odiags,idv,iob)
data_s(itz_tr,n) = missing
endif
- call nc_diag_metadata("Foundation_Temperature", sngl(data_s(itref,n)) ) ! reference temperature (Tr) in NSST
- call nc_diag_metadata("SST_Warm_layer_dt", sngl(data_s(idtw,n)) ) ! dt_warm at zob
- call nc_diag_metadata("SST_Cool_layer_tdrop", sngl(data_s(idtc,n)) ) ! dt_cool at zob
- call nc_diag_metadata("SST_dTz_dTfound", sngl(data_s(itz_tr,n)) ) ! d(Tz)/d(Tr)
+ call nc_diag_metadata_to_single("Foundation_Temperature",data_s(itref,n) ) ! reference temperature (Tr) in NSST
+ call nc_diag_metadata_to_single("SST_Warm_layer_dt",data_s(idtw,n) ) ! dt_warm at zob
+ call nc_diag_metadata_to_single("SST_Cool_layer_tdrop",data_s(idtc,n) ) ! dt_cool at zob
+ call nc_diag_metadata_to_single("SST_dTz_dTfound",data_s(itz_tr,n) ) ! d(Tz)/d(Tr)
+
+ call nc_diag_metadata_to_single("standard_deviation_clear_bt", tb_obs_sdv(ich_diag(i))) ! needed for seviri qc
+ call nc_diag_metadata_to_single("Observation", tb_obs0(ich_diag(i))) ! observed brightness temperature (K)
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", tbcnob(ich_diag(i))) ! observed - simulated Tb with no bias correction (K)
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted", tbc0(ich_diag(i) )) ! observed - simulated Tb with bias corrrection (K)
+ call nc_diag_metadata_to_single("TotalBias", totbc(ich_diag(i) )) ! total bias corrrection (K) !emily
+ call nc_diag_metadata_to_single("Forecast_unadjusted", tsim(ich_diag(i) )) ! simulated Tb without bias corrrection (K)
+ call nc_diag_metadata_to_single("Forecast_adjusted", tsim(ich_diag(i) ) &
+ + totbc(ich_diag(i) )) ! simulated Tb with bias corrrection (K)
+ ! errinv = sqrt(varinv0(ich_diag(i))) !orig
+ errinv = sqrt(varinv(ich_diag(i))) !emily
+ call nc_diag_metadata_to_single("Inverse_Observation_Error", errinv) ! 1.0/observation error
+ call nc_diag_metadata_to_single("Input_Observation_Error", error0(ich_diag(i))) ! Origial error assignment
+!>>emily
+ if (iasi .or. cris .or. airs .or. avhrr) then
+ errinv_tmp = sqrt(varinv_after_wavenum(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_wavenum", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_rangechk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_range", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_topo(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_topo", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_transmittop(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_transmittop", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_clddet(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_clddet", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_jsfcchk_land(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_jsfcchk_land", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_nsstret(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_nsstret", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_jsfcchk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_jsfcchk", errinv_tmp)
+ endif
+
+ if (amsua .or. atms) then
+ errinv_tmp = sqrt(varinv_after_jsfcchk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_jsfcchk", errinv_tmp )
+ errinv_tmp = sqrt(varinv_after_sdoei(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_sdoei", errinv_tmp)
+ errinv_tmp = sqrt(varinv_sdoei(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_sdoei", errinv_tmp)
+ errinv_tmp = sqrt(varinv_grosschk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_grosschk", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_grosschk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_grosschk", errinv_tmp)
+ output_tmp = cldeff_obs(ich_diag(i))
+ call nc_diag_metadata_to_single("cldeff_obs", output_tmp)
+ output_tmp = cldeff_fg(ich_diag(i))
+ call nc_diag_metadata_to_single("cldeff_bkg", output_tmp)
+ endif
+
+ if (ssmis) then
+ errinv_tmp = sqrt(varinv_after_grossroutinechk_over_ocean(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_grossroutinechk_ocean", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_grossroutinechk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_grossroutinechk", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_topo(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_topo", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_sfcchk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_sfcchk", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_ch2chk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_ch2chk", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_scatteringchk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_scatteringchk", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_jsfcchk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_jsfcchk", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_nsstret(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_nsstret", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_grosschk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_grosschk", errinv_tmp)
+ call nc_diag_metadata_to_single("SSMIS_ScatteringIndexPred9", pred9)
+ call nc_diag_metadata_to_single("SSMIS_ScatteringIndexPred10", pred10)
+ call nc_diag_metadata_to_single("SSMIS_ScatteringIndexPred11", pred11)
+ endif
+
+ if (seviri) then
+ errinv_tmp = sqrt(varinv_after_sfcterrianchk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_sfcterrianchk", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_rangechk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_range", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_topo(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_topo", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_transmittop(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_transmittop", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_clddet(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_clddet", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_stdchk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_stdchk", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_grossroutinechk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_grossroutinechk", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_stdadj(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_stdadj", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_nsstret(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_nsstret", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_jsfcchk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_jsfcchk", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_clrfracchk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_clrfracchk", errinv_tmp)
+ errinv_tmp = sqrt(varinv_after_grosschk(ich_diag(i)))
+ call nc_diag_metadata_to_single("Inverse_Observation_Error_after_grosschk", errinv_tmp)
+ endif
+!< rsig)ratio_errors = zero
+ wgesin=zero
! Interpolate guess u, v, and w to observation location and time.
call tintrp31(ges_u,ugesin,dlat,dlon,dpres,dtime,&
@@ -788,7 +788,7 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa
end if
end if
-! Gross error checks
+ ! Gross error checks
obserror = one/max(ratio_errors*error,tiny_r_kind)
obserrlm = max(cermin(ikx),min(cermax(ikx),obserror))
residual = abs(ddiff)
@@ -871,7 +871,7 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa
jiter=jiter, muse=muse(i), nldepart=ddiff)
end if
endif
-
+
! If obs is "acceptable", load array with obs info for use
! in inner loop minimization (int* and stp* routines)
if ( .not. last .and. muse(i)) then
@@ -903,6 +903,7 @@ subroutine setuprw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsa
my_head%b = cvar_b(ikx)
my_head%pg = cvar_pg(ikx)
+
if (luse_obsdiag) then
call obsdiagNode_assert(my_diag,my_head%idv,my_head%iob,1,myname,'my_diag:my_head')
my_head%diags => my_diag
@@ -972,7 +973,7 @@ subroutine check_vars_ (proceed, include_w)
call gsi_metguess_get ('var::v' , ivar, istatus )
proceed=proceed.and.ivar>0
call gsi_metguess_get ('var::w' , ivar, istatus )
- if (ivar>0) then
+ if (if_use_w_vr.and.ivar>0) then
include_w=.true.
if(if_vterminal)then
if( .not. if_model_dbz ) then
@@ -992,8 +993,9 @@ subroutine check_vars_ (proceed, include_w)
endif
end subroutine check_vars_
- subroutine init_vars_
+ subroutine init_vars_(include_w)
+ logical,intent(in ):: include_w
real(r_kind),dimension(:,: ),pointer:: rank2=>NULL()
real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL()
character(len=5) :: varname
@@ -1319,30 +1321,30 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_metadata("Observation_Class", obsclass )
call nc_diag_metadata("Observation_Type", ictype(ikx) )
call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
- call nc_diag_metadata("Station_Elevation", sngl(data(ielev,i)) )
- call nc_diag_metadata("Pressure", sngl(presw) )
- call nc_diag_metadata("Height", sngl(data(ihgt,i)) )
- call nc_diag_metadata("Time", sngl(dtime-time_offset))
- call nc_diag_metadata("Prep_QC_Mark", sngl(zero) )
- call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) )
+ call nc_diag_metadata_to_single("Latitude",data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude",data(ilone,i) )
+ call nc_diag_metadata_to_single("Station_Elevation",data(ielev,i) )
+ call nc_diag_metadata_to_single("Pressure",presw )
+ call nc_diag_metadata_to_single("Height",data(ihgt,i) )
+ call nc_diag_metadata_to_single("Time",dtime,time_offset,'-')
+ call nc_diag_metadata("Prep_QC_Mark", 0.0_r_single )
+ call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) )
! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb )
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt )
if(muse(i)) then
- call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
+ call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single )
else
- call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
+ call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single )
endif
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
+ call nc_diag_metadata_to_single("Errinv_Input",errinv_input )
+ call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst )
+ call nc_diag_metadata_to_single("Errinv_Final",errinv_final )
+
+ call nc_diag_metadata_to_single("Observation",data(irwob,i) )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",data(irwob,i),rwwind,'-')
- call nc_diag_metadata("Observation", sngl(data(irwob,i)) )
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(irwob,i)-rwwind) )
-
if (lobsdiagsave) then
do jj=1,miter
if (odiag%muse(jj)) then
@@ -1351,18 +1353,18 @@ subroutine contents_netcdf_diag_(odiag)
obsdiag_iuse(jj) = -one
endif
enddo
-
+
call nc_diag_data2d("ObsDiagSave_iuse", obsdiag_iuse )
call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart )
call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart )
- call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen )
+ call nc_diag_data2d("ObsDiagSave_obssen", odiag%obssen )
endif
if (save_jacobian) then
call nc_diag_data2d("Observation_Operator_Jacobian_stind", dhx_dx%st_ind)
call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind)
call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val,r_single))
endif
-
+
end subroutine contents_netcdf_diag_
subroutine final_vars_
diff --git a/src/gsi/setupspd.f90 b/src/gsi/setupspd.f90
index 91b2467bf3..600533ecb7 100644
--- a/src/gsi/setupspd.f90
+++ b/src/gsi/setupspd.f90
@@ -114,7 +114,7 @@ subroutine setupspd(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags
use obsmod, only: netcdf_diag, binary_diag, dirname, ianldate
use obsmod, only: l_obsprvdiag
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
use m_obsNode, only: obsNode
use m_spdNode, only: spdNode
@@ -301,7 +301,7 @@ subroutine setupspd(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
dup=one
@@ -504,7 +504,7 @@ subroutine setupspd(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags
spdges=sqrt(ugesin*ugesin+vgesin*vgesin)
iz = max(1, min( int(dpres), nsig))
- delz = max(zero, min(dpres - float(iz), one))
+ delz = max(zero, min(dpres - real(iz,r_kind), one))
if (save_jacobian) then
@@ -949,29 +949,29 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_metadata("Observation_Class", obsclass )
call nc_diag_metadata("Observation_Type", ictype(ikx) )
call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
- call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) )
- call nc_diag_metadata("Pressure", sngl(presw) )
- call nc_diag_metadata("Height", sngl(data(ihgt,i)) )
- call nc_diag_metadata("Time", sngl(dtime-time_offset))
- call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) )
- call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) )
+ call nc_diag_metadata_to_single("Latitude",data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude",data(ilone,i) )
+ call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) )
+ call nc_diag_metadata_to_single("Pressure",presw )
+ call nc_diag_metadata_to_single("Height",data(ihgt,i) )
+ call nc_diag_metadata_to_single("Time",dtime,time_offset,'-')
+ call nc_diag_metadata_to_single("Prep_QC_Mark",data(iqc,i) )
+ call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) )
! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb )
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt )
if(muse(i)) then
- call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
+ call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single )
else
- call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
+ call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single )
endif
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
+ call nc_diag_metadata_to_single("Errinv_Input",errinv_input )
+ call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst )
+ call nc_diag_metadata_to_single("Errinv_Final",errinv_final )
- call nc_diag_metadata("Observation", sngl(spdob) )
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(spdob0-spdges) )
+ call nc_diag_metadata_to_single("Observation",spdob )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", spdob0,spdges,'-')
if (lobsdiagsave) then
do jj=1,miter
diff --git a/src/gsi/setupsst.f90 b/src/gsi/setupsst.f90
index 6562d0392f..994638142a 100644
--- a/src/gsi/setupsst.f90
+++ b/src/gsi/setupsst.f90
@@ -99,7 +99,7 @@ subroutine setupsst(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags
use obsmod, only: luse_obsdiag
use obsmod, only: netcdf_diag, binary_diag, dirname,ianldate
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
use gsi_4dvar, only: nobs_bins,hr_obsbin
use oneobmod, only: magoberr,maginnov,oneobtest
@@ -585,35 +585,35 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_metadata("Observation_Class", obsclass )
call nc_diag_metadata("Observation_Type", ictype(ikx) )
call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
- call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) )
+ call nc_diag_metadata_to_single("Latitude",data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude",data(ilone,i) )
+ call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) )
call nc_diag_metadata("Pressure", missing )
- call nc_diag_metadata("Height", sngl(data(izob,i)) )
- call nc_diag_metadata("Time", sngl(dtime-time_offset))
- call nc_diag_metadata("Prep_QC_Mark", sngl(data(ipct,i)) )
- call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) )
+ call nc_diag_metadata_to_single("Height",data(izob,i) )
+ call nc_diag_metadata_to_single("Time",dtime,time_offset,'-')
+ call nc_diag_metadata_to_single("Prep_QC_Mark",data(ipct,i) )
+ call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) )
! call nc_diag_metadata("Nonlinear_QC_Var_Jb", var_jb )
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt )
if(muse(i)) then
- call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
+ call nc_diag_metadata("Analysis_Use_Flag", 1.0_r_single )
else
- call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
+ call nc_diag_metadata("Analysis_Use_Flag", -1.0_r_single )
endif
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
+ call nc_diag_metadata_to_single("Errinv_Input",errinv_input )
+ call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst )
+ call nc_diag_metadata_to_single("Errinv_Final",errinv_final )
- call nc_diag_metadata("Observation", sngl(data(isst,i)) )
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(data(isst,i)-sstges) )
+ call nc_diag_metadata_to_single("Observation",data(isst,i) )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",data(isst,i),sstges,'-')
if (nst_gsi>0) then
- call nc_diag_metadata("FoundationTempBG", sngl(data(itref,i)) )
- call nc_diag_metadata("DiurnalWarming_at_zob", sngl(data(idtw,i)) )
- call nc_diag_metadata("SkinLayerCooling_at_zob", sngl(data(idtw,i)) )
- call nc_diag_metadata("Sensitivity_Tzob_Tr", sngl(data(itz_tr,i)) )
+ call nc_diag_metadata_to_single("FoundationTempBG",data(itref,i) )
+ call nc_diag_metadata_to_single("DiurnalWarming_at_zob",data(idtw,i) )
+ call nc_diag_metadata_to_single("SkinLayerCooling_at_zob",data(idtc,i) )
+ call nc_diag_metadata_to_single("Sensitivity_Tzob_Tr",data(itz_tr,i) )
endif
if (lobsdiagsave) then
diff --git a/src/gsi/setupswcp.f90 b/src/gsi/setupswcp.f90
index c65ad1495c..bd9c1e9690 100644
--- a/src/gsi/setupswcp.f90
+++ b/src/gsi/setupswcp.f90
@@ -67,7 +67,7 @@ subroutine setupswcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag
use obsmod, only: netcdf_diag, binary_diag, dirname
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header,nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init,nc_diag_read_get_dim,nc_diag_read_close
use state_vectors, only: svars3d, levels
@@ -268,7 +268,7 @@ subroutine setupswcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag
iobshgt=16 ! index of observation height (m)
do i=1,nobs
- muse(i)=nint(data(11,i)) <= jiter
+ muse(i)=nint(data(11,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
dup=one
@@ -893,28 +893,28 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_metadata("Observation_Class", obsclass )
call nc_diag_metadata("Observation_Type", ictype(ikx) )
call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
- call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) )
- call nc_diag_metadata("Pressure", sngl(data(iobsprs,i)) )
- call nc_diag_metadata("Height", sngl(data(iobshgt,i)) )
- call nc_diag_metadata("Time", sngl(dtime-time_offset))
- call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) )
- call nc_diag_metadata("Setup_QC_Mark", sngl(rmiss_single) )
- call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) )
+ call nc_diag_metadata_to_single("Latitude",data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude",data(ilone,i) )
+ call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i) )
+ call nc_diag_metadata_to_single("Pressure",data(iobsprs,i) )
+ call nc_diag_metadata_to_single("Height",data(iobshgt,i) )
+ call nc_diag_metadata_to_single("Time",dtime,time_offset,'-')
+ call nc_diag_metadata_to_single("Prep_QC_Mark",data(iqc,i) )
+ call nc_diag_metadata("Setup_QC_Mark",rmiss_single )
+ call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) )
if(muse(i)) then
call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
else
call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
endif
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
- call nc_diag_metadata("Observation", sngl(dswcp) )
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(dswcp-swcpges))
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt )
+ call nc_diag_metadata_to_single("Errinv_Input",errinv_input )
+ call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst )
+ call nc_diag_metadata_to_single("Errinv_Final",errinv_final )
+ call nc_diag_metadata_to_single("Observation",dswcp )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted", dswcp,swcpges,'-')
if (lobsdiagsave) then
do jj=1,miter
diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90
index 815c16014d..0fd4691386 100644
--- a/src/gsi/setupt.f90
+++ b/src/gsi/setupt.f90
@@ -42,7 +42,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
use obsmod, only: netcdf_diag, binary_diag, dirname
use obsmod, only: l_obsprvdiag
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
use qcmod, only: npres_print,dfact,dfact1,ptop,pbot,buddycheck_t
@@ -54,11 +54,12 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
use gridmod, only: nsig,twodvar_regional,regional
use gridmod, only: get_ijk,pt_ll
- use jfunc, only: jiter,last,jiterstart,miter
+ use jfunc, only: jiter,last,jiterstart,miter,hofx_2m_sfcfile
use guess_grids, only: nfldsig, hrdifsig,ges_lnprsl,&
geop_hgtl,ges_tsen,pbl_height
- use state_vectors, only: svars3d, levels
+ use guess_grids, only: ges_prsi
+ use state_vectors, only: svars3d, levels, ns3d, svars2d
use constants, only: zero, one, four,t0c,rd_over_cp,three,rd_over_cp_mass,ten
use constants, only: tiny_r_kind,half,two
@@ -228,6 +229,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
! for 3D-RTMA (if l_obsprvdiag is true).
! 2022-03-15 Hu change all th2 to t2m to indicate that 2m temperature
! is sensible instead of potentionl temperature
+! 2023-03-21 Draper added option to interpolate screen-level T from model 2m output.
+! (hofx_2m_sfcfile)
!
! !REMARKS:
! language: f90
@@ -277,16 +280,24 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
real(r_kind),dimension(npredt):: pred
real(r_kind),dimension(npredt):: predcoef
real(r_kind) tgges,roges
- real(r_kind),dimension(nsig):: tvtmp,qtmp,utmp,vtmp,hsges
+ real(r_kind),dimension(nsig):: ttmp,tvtmp,qtmp,utmp,vtmp,hsges
real(r_kind) u10ges,v10ges,t2ges,q2ges,psges2,f10ges
real(r_kind),dimension(34) :: ptablt
real(r_single),allocatable,dimension(:,:)::rdiagbuf
real(r_single),allocatable,dimension(:,:)::rdiagbufp
+ ! GSI profiles are stored with bottom up index; output the profiles
+ ! with top down index
+ real(r_kind),dimension(nsig):: ttmp_reverse,tvtmp_reverse,qtmp_reverse,utmp_reverse,vtmp_reverse
+ real(r_kind),dimension(nsig):: hsges_reverse, zges_reverse,prsltmp2_reverse
+ real(r_kind),dimension(nsig):: zges_read_reverse, zges_geometric_reverse
+ real(r_kind),dimension(nsig+1):: prsitmp_reverse
+ !<< JEDI
real(r_kind),dimension(nsig):: prsltmp2
+ real(r_kind),dimension(nsig+1):: prsitmp
- integer(i_kind) i,j,nchar,nreal,k,ii,iip,jj,l,nn,ibin,idia,idia0,ix,ijb
+ integer(i_kind) i,j,nchar,nreal,k,kk,ii,iip,jj,l,nn,ibin,idia,idia0,ix,ijb
integer(i_kind) mm1,jsig,iqt
integer(i_kind) itype,msges
integer(i_kind) ier,ilon,ilat,ipres,itob,id,itime,ikx,iqc,iptrb,icat,ipof,ivvlc,idx
@@ -309,7 +320,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
logical,dimension(nobs):: luse,muse
integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID
- logical sfctype
+ logical sfctype, landsfctype
logical iqtflg
logical aircraftobst
logical duplogic
@@ -342,6 +353,18 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
integer(i_kind):: ich0
type(obsLList),pointer,dimension(:):: thead
+
+ real(r_kind) :: delta_z, lapse_error
+ real(r_kind), parameter :: T_lapse = -0.0045 ! standard lapse rate, K/m
+! use 4.5 K/km, in place of more standard 6.5 K/km, following
+! https://agupubs.onlinelibrary.wiley.com/doi/10.1029/2019EA000984
+! lapse_error_frac around 0.5 ~ 2K/km, from Figure 2 of above.
+ real(r_kind), parameter :: lapse_error_frac = 0.5 ! inflation factor for obs error when vertically interpolating
+ real(r_kind), parameter :: max_delta_z = 300. ! max. vertical mismatch allowed
+
+! CSD - move this to where the namelists are read in.
+ if (i_use_2mt4b>0) hofx_2m_sfcfile=.false.
+
thead => obsLL(:)
save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf
@@ -398,7 +421,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
end if
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! If HD raobs available move prepbufr version to monitor
if(nhdt > 0)then
@@ -432,8 +455,11 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
hr_offset=min_offset/60.0_r_kind
dup=one
do k=1,nobs
+ ikx=nint(data(ikxx,k))
+ itype=ictype(ikx)
+ landsfctype =( itype==181 .or. itype==183 .or. itype==187 )
do l=k+1,nobs
- if (twodvar_regional) then
+ if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then
duplogic=data(ilat,k) == data(ilat,l) .and. &
data(ilon,k) == data(ilon,l) .and. &
data(ier,k) < r1000 .and. data(ier,l) < r1000 .and. &
@@ -465,6 +491,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
end do
! Run a buddy-check
+! Note: buddy check crashes for hofx_2m_sfcfile option.
if (twodvar_regional .and. buddycheck_t) call buddy_check_t(is,data,luse,mype,nele,nobs,muse,buddyuse)
! If requested, save select data for output to diagnostic file
@@ -494,7 +521,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
if(netcdf_diag) call init_netcdf_diag_
end if
scale=one
- rsig=float(nsig)
+ rsig=real(nsig,r_kind)
mm1=mype+1
! rsli=isli
@@ -521,6 +548,10 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
rstation_id = data(id,i)
prest=r10*exp(dpres) ! in mb
sfctype=(itype>179.and.itype<190).or.(itype>=192.and.itype<=199)
+! hofx_2m_sfcfile option to calculate hofx from 2m model output (rather than LML)
+! is restricted to landsfctype only. GDAS assimilates 180 and 182 over ocean,
+! should we also use 2m model output for the over-ocean obs?
+ landsfctype =( itype==181 .or. itype==183 .or. itype==187 )
iqtflg=nint(data(iqt,i)) == 0
var_jb=data(ijb,i)
@@ -573,6 +604,57 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
if(.not.in_curbin) cycle
+!>>JEDI
+! GEOVALS for UFO eval
+ psges2 = psges ! keep in cb
+ prsltmp2 = exp(prsltmp)
+ call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime,hrdifsig,&
+ nsig+1,mype,nfldsig)
+ call tintrp2a1(ges_tv,tvtmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(ges_tsen,ttmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(ges_q,qtmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(ges_u,utmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(ges_v,vtmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(geop_hgtl,hsges,dlat,dlon,dtime,hrdifsig,& !orig
+ nsig,mype,nfldsig)
+ ! geopotential height at obs location (lat/lon) and time
+ !xxx call tintrp2a1(geop_hgtl,zges_read,dlat,dlon,dtime,hrdifsig, &
+ !xxx nsig,mype,nfldsig)
+ ! model virtual temperature (ges_tv) at obs location (lat/lon)
+ ! obs time, and model surface (lower model level)
+ !xxx call tintrp31(ges_tv,sfctges,dlat,dlon,log(psges),dtime, &
+ !xxx hrdifsig,mype,nfldsig)
+
+! Convert geopotential height at layer midpoints to geometric
+! height using equations (17, 20, 23) in MJ Mahoney's note
+! "A discussion of various measures of altitude" (2001).
+! Available on the web at
+! http://mtp.jpl.nasa.gov/notes/altitude/altitude.html
+!
+! termg = equation 17
+! termr = equation 21
+! termrg = first term in the denominator of equation 23
+! zges = equation 23
+
+!xxx slat = data(ilate,i)*deg2rad
+!xxx sin2 = sin(slat)*sin(slat)
+!xxx termg = grav_equator * &
+!xxx ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2))
+!xxx termr = semi_major_axis /(one + flattening + grav_ratio - &
+!xxx two*flattening*sin2)
+!xxx termrg = (termg/grav)*termr
+!xxx do k=1,nsig
+!xxx zges_geometric(k) = (termr*zges_read(k)) / (termrg-zges_read(k)) ! eq (23)
+!xxx end do
+! END GEOVALS
+!<= 3 mixed
+! for now, use only pure land
+ if (int(data(idomsfc,i)) .NE. 1 ) muse(i) = .false.
+
+ call tintrp2a11(ges_t2m,tges2m,dlat,dlon,dtime,hrdifsig,&
+ mype,nfldsig)
+
+! correct obs to model terrain height using a standard lapse rate.
+! Later: look into updating with lapse-rate from the model (similar to gsd_terrain_match)
+
+ delta_z = data(izz,i) - data(istnelv,i)
+ tob = tob + delta_z*T_lapse
+ !update the station elevation
+ data(istnelv,i) = data(izz,i)
+
+ if(save_jacobian) then
+ t_ind = getindex(svars2d, 't2m')
+ if (t_ind < 0) then
+ print *, 'Error: no variable t2m in state vector.Exiting.'
+ call stop2(1300)
+ endif
+ dhx_dx%st_ind(1) = sum(levels(1:ns3d)) + t_ind
+ dhx_dx%end_ind(1) = sum(levels(1:ns3d)) + t_ind
+ dhx_dx%val(1) = one
+ dhx_dx%val(2) = zero ! in this case, there is no vertical interp
+ ! and nnz (=dim(dhx_dx%val)) should be one,
+ ! but nnz is a file attribute, so need to use
+ ! same value as for vertical profile obs. Get
+ ! around this by setting val(2) to zero.
+ endif
+
+! SCENARIO 3: obs is sfctype, and neither sfcmodel nor hofx_2m_sfcfile is chosen
+! .or. obs is not sfctype. Interpoate hofx from model levels.
else
+
if(iqtflg)then
+! SCENARIO 3a: obs is a virtual temp.
! Interpolate guess tv to observation location and time
call tintrp31(ges_tv,tges,dlat,dlon,dpres,dtime, &
hrdifsig,mype,nfldsig)
iz = max(1, min( int(dpres), nsig))
- delz = max(zero, min(dpres - float(iz), one))
+ delz = max(zero, min(dpres - real(iz,r_kind), one))
if (save_jacobian) then
t_ind = getindex(svars3d, 'tv')
@@ -717,12 +867,13 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
dhx_dx%val(2) = delz ! weight for iz+1's level
endif
else
+! SCENARIO 3b: obs is a sensible temp.
! Interpolate guess tsen to observation location and time
call tintrp31(ges_tsen,tges,dlat,dlon,dpres,dtime, &
hrdifsig,mype,nfldsig)
iz = max(1, min( int(dpres), nsig))
- delz = max(zero, min(dpres - float(iz), one))
+ delz = max(zero, min(dpres - real(iz,r_kind), one))
if (save_jacobian) then
t_ind = getindex(svars3d, 'tsen')
@@ -739,6 +890,8 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
endif
end if
+
+! SCENARIO 4: obs is sfctype, and i_use_2mt4b flag is on (turns on regional sfc DA)
if(i_use_2mt4b>0 .and. sfctype) then
if(i_coastline==1 .or. i_coastline==3) then
@@ -773,17 +926,23 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
call grdcrd1(sfcchk,prsltmp(1),nsig,-1)
! Check to see if observations is above the top of the model (regional mode)
- if(sfctype)then
+ if(sfctype .and. .not. (hofx_2m_sfcfile .and. landsfctype) )then
if(abs(dpres)>four) drpx=1.0e10_r_kind
pres_diff=prest-r10*psges
if (twodvar_regional .and. abs(pres_diff)>=r1000) drpx=1.0e10_r_kind
end if
- rlow=max(sfcchk-dpres,zero)
-! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface]
- if(l_sfcobserror_ramp_t) then
- ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind)
+
+ if (.not. (hofx_2m_sfcfile .and. landsfctype) ) then
+ rlow=max(sfcchk-dpres,zero)
+! linear variation of observation ramp [between grid points 1(~3mb) and 15(~45mb) below the surface]
+ if(l_sfcobserror_ramp_t) then
+ ramp=min(max(((rlow-1.0_r_kind)/(15.0_r_kind-1.0_r_kind)),0.0_r_kind),1.0_r_kind)
+ else
+ ramp=rlow
+ endif
else
- ramp=rlow
+ rlow = zero
+ ramp = zero
endif
rhgh=max(zero,dpres-rsigp-r0_001)
@@ -795,12 +954,26 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
if(rlow/=zero) awork(2) = awork(2) + one
if(rhgh/=zero) awork(3) = awork(3) + one
end if
-
- ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+r8*ramp)
+
+! inflate error for uncertainty in the terrain adjustment
+ lapse_error = 0.
+ if ( hofx_2m_sfcfile .and. landsfctype) then
+ if (abs(delta_z)max_delta_z do not assim.
+ ! inflate obs error to account for error in lapse_rate
+ ! also include some representativity error here (assuming
+ ! delta_z ~ heterogeneity)
+ lapse_error = abs(lapse_error_frac*T_lapse*delta_z)
+ else
+ muse(i)=.false.
+ endif
+ endif
+
+ ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+r8*ramp + lapse_error)
! Compute innovation
- if(i_use_2mt4b>0 .and. sfctype) then
+ if( (sfctype .and. i_use_2mt4b>0) .or. (hofx_2m_sfcfile .and. landsfctype) ) then
ddiff = tob-tges2m
+ if (hofx_2m_sfcfile) tges=tges2m
else
ddiff = tob-tges
endif
@@ -1017,6 +1190,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
my_head%elat= data(ilate,i)
my_head%elon= data(ilone,i)
+ if(npredt <= 0) write(6,*) ' npredt = ',npredt
allocate(my_head%pred(npredt))
! Set (i,j,k) indices of guess gridpoint that bound obs location
@@ -1411,7 +1585,7 @@ subroutine init_vars_
write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
call stop2(999)
endif
- if(i_use_2mt4b>0) then
+ if(i_use_2mt4b>0 .or. hofx_2m_sfcfile) then
! get t2m ...
varname='t2m'
call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus)
@@ -1430,6 +1604,7 @@ subroutine init_vars_
write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
call stop2(999)
endif
+
! get q2m ...
varname='q2m'
call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus)
@@ -1674,36 +1849,43 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_metadata("Observation_Class", obsclass )
call nc_diag_metadata("Observation_Type", ictype(ikx) )
call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
- call nc_diag_metadata("Station_Elevation", sngl(data(istnelv,i)) )
- call nc_diag_metadata("Pressure", sngl(prest) )
- call nc_diag_metadata("Height", sngl(data(iobshgt,i)) )
- call nc_diag_metadata("Time", sngl(dtime-time_offset))
- call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) )
- call nc_diag_metadata("Setup_QC_Mark", sngl(data(iqt,i)) )
- call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) )
+ call nc_diag_metadata_to_single("Latitude",data(ilate,i))
+ call nc_diag_metadata_to_single("Longitude",data(ilone,i))
+! this is the obs height after being interpolated to the model (=model height)
+ call nc_diag_metadata_to_single("Station_Elevation",data(istnelv,i))
+ call nc_diag_metadata_to_single("Pressure",prest)
+! this is the original obs height (= stn elevation, before being interpolated)
+ call nc_diag_metadata_to_single("Height",data(iobshgt,i))
+ call nc_diag_metadata_to_single("Time",dtime,time_offset,'-')
+ call nc_diag_metadata_to_single("Prep_QC_Mark",data(iqc,i))
+ call nc_diag_metadata_to_single("Setup_QC_Mark",data(iqt,i))
+ call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i))
+ call nc_diag_metadata("Virtual_Temperature_Flag",nint(data(iqt,i)))
if(muse(i)) then
- call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
+ call nc_diag_metadata_to_single("Analysis_Use_Flag", one)
else
- call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
+ call nc_diag_metadata_to_single("Analysis_Use_Flag", -one)
endif
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
- call nc_diag_metadata("Observation", sngl(data(itob,i)) )
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(ddiff) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(tob-tges) )
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt)
+ call nc_diag_metadata_to_single("Errinv_Input",errinv_input )
+ call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst )
+ call nc_diag_metadata_to_single("Errinv_Final",errinv_final )
+ if (hofx_2m_sfcfile ) then
+ call nc_diag_metadata_to_single("Observation", tob )
+ else
+ call nc_diag_metadata_to_single("Observation", data(itob,i) )
+ endif
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",tob,tges,'-')
if (aircraft_t_bc_pof .or. aircraft_t_bc .or. aircraft_t_bc_ext) then
- call nc_diag_metadata("Data_Pof", sngl(data(ipof,i)) )
- call nc_diag_metadata("Data_Vertical_Velocity", sngl(data(ivvlc,i)) )
+ call nc_diag_metadata_to_single("Data_Pof",data(ipof,i))
+ call nc_diag_metadata_to_single("Data_Vertical_Velocity",data(ivvlc,i))
if (npredt .gt. one) then
- call nc_diag_data2d("Bias_Correction_Terms", sngl(predbias) )
+ call nc_diag_data2d("Bias_Correction_Terms", sngl(predbias))
else if (npredt .eq. one) then
- call nc_diag_metadata("Bias_Correction_Terms", sngl(predbias(1)) )
+ call nc_diag_metadata_to_single("Bias_Correction_Terms",predbias(1))
endif
else
call nc_diag_metadata("Data_Pof", missing )
@@ -1712,7 +1894,7 @@ subroutine contents_netcdf_diag_(odiag)
do j=1,npredt
predbias(j) = missing
enddo
- call nc_diag_data2d("Bias_Correction_Terms", sngl(predbias) )
+ call nc_diag_data2d("Bias_Correction_Terms", predbias )
else if (npredt .eq. one) then
call nc_diag_metadata("Bias_Correction_Terms", missing )
endif
@@ -1747,6 +1929,51 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_data2d("Observation_Operator_Jacobian_endind", dhx_dx%end_ind)
call nc_diag_data2d("Observation_Operator_Jacobian_val", real(dhx_dx%val,r_single))
endif
+ ! GEOVALS
+ !>>emily
+ do k = 1, nsig
+ kk = nsig-k+1
+ utmp_reverse(kk) = utmp(k)
+ vtmp_reverse(kk) = vtmp(k)
+ ttmp_reverse(kk) = ttmp(k)
+ !tvtmp_reverse(kk) = tges(k) !emily
+ tvtmp_reverse(kk) = tvtmp(k) !ADC
+ qtmp_reverse(kk) = qtmp(k)
+ hsges_reverse(kk) = hsges(k)
+ !zges_read_reverse(kk)= zges_read(k)
+ !zges_geometric_reverse(kk)= zges_geometric(k)
+ !zges_reverse(kk) = zges(k)
+ prsltmp2_reverse(kk) = prsltmp2(k)
+ enddo
+ do k = 1, nsig+1
+ kk = (nsig+1)-k+1
+ prsitmp_reverse(kk) = prsitmp(k)
+ enddo
+
+ call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(prsltmp2_reverse*r1000))
+ call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(prsitmp_reverse*r1000))
+ call nc_diag_data2d("air_temperature", sngl(ttmp_reverse))
+ call nc_diag_data2d("virtual_temperature", sngl(tvtmp_reverse)) !emily
+ call nc_diag_data2d("specific_humidity", sngl(qtmp_reverse))
+ call nc_diag_data2d("eastward_wind", sngl(utmp_reverse))
+ call nc_diag_data2d("northward_wind", sngl(vtmp_reverse))
+ call nc_diag_data2d("geopotential_height", sngl(hsges_reverse) ) !orig
+! call nc_diag_data2d("geopotential_height", sngl(zges_read_reverse) ) !emily
+! call nc_diag_data2d("geometric_height", sngl(zges_geometric_reverse) )
+! !emily
+ !<>emily
+ do k = 1, nsig
+ kk = nsig-k+1
+ utmp_reverse(kk) = utmp(k)
+ vtmp_reverse(kk) = vtmp(k)
+ ttmp_reverse(kk) = ttmp(k)
+ !tvtmp_reverse(kk) = tges(k) !emily
+ tvtmp_reverse(kk) = tvtmp(k) !ADC
+ qtmp_reverse(kk) = qtmp(k)
+ hsges_reverse(kk) = hsges(k)
+ !zges_read_reverse(kk)= zges_read(k)
+ !zges_geometric_reverse(kk)= zges_geometric(k)
+ !zges_reverse(kk) = zges(k)
+ prsltmp2_reverse(kk) = prsltmp2(k)
+ enddo
+ do k = 1, nsig+1
+ kk = (nsig+1)-k+1
+ prsitmp_reverse(kk) = prsitmp(k)
+ enddo
+
+
+ call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(prsltmp2_reverse*r1000))
+ call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(prsitmp_reverse*r1000))
+ call nc_diag_data2d("air_temperature", sngl(ttmp_reverse))
+ call nc_diag_data2d("virtual_temperature", sngl(tvtmp_reverse)) !emily
+ call nc_diag_data2d("specific_humidity", sngl(qtmp_reverse))
+ call nc_diag_data2d("eastward_wind", sngl(utmp_reverse))
+ call nc_diag_data2d("northward_wind", sngl(vtmp_reverse))
+ call nc_diag_data2d("geopotential_height", sngl(hsges_reverse) ) !orig
+! call nc_diag_data2d("geopotential_height", sngl(zges_read_reverse) ) !emily
+! call nc_diag_data2d("geometric_height", sngl(zges_geometric_reverse) )
+! !emily
+ !<psges)then
imin=l
@@ -692,29 +692,29 @@ subroutine contents_netcdf_diag_(odiag)
call nc_diag_metadata("Observation_Class", obsclass )
call nc_diag_metadata("Observation_Type", ictype(ikx) )
call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
+ call nc_diag_metadata_to_single("Latitude",data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude",data(ilone,i) )
call nc_diag_metadata("Station_Elevation", sngl(zero) )
- call nc_diag_metadata("Pressure", sngl(data(ipres,i)*r10))
- call nc_diag_metadata("Height", sngl(zero) )
- call nc_diag_metadata("Time", sngl(dtime-time_offset))
+ call nc_diag_metadata_to_single("Pressure", data(ipres,i),r10,'*')
+ call nc_diag_metadata_to_single("Height",zero )
+ call nc_diag_metadata_to_single("Time",dtime,time_offset,'-')
call nc_diag_metadata("Prep_QC_Mark", sngl(one) )
call nc_diag_metadata("Prep_Use_Flag", sngl(one) )
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",(rwgt) )
if(muse(i)) then
call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
else
- call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
+ call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
endif
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
+ call nc_diag_metadata_to_single("Errinv_Input",errinv_input )
+ call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst )
+ call nc_diag_metadata_to_single("Errinv_Final",errinv_final )
- call nc_diag_metadata("Observation", sngl(pob) )
- call nc_diag_metadata("Obs_Minus_Forecast_adjusted", sngl(pob-pges) )
- call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(pob-pgesorig))
+ call nc_diag_metadata_to_single("Observation",pob )
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",pob,pges,'-')
+ call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",pob,pgesorig,'-')
if (lobsdiagsave) then
do jj=1,miter
diff --git a/src/gsi/setuptd2m.f90 b/src/gsi/setuptd2m.f90
index 9e54171bd7..30f6a8b6e3 100644
--- a/src/gsi/setuptd2m.f90
+++ b/src/gsi/setuptd2m.f90
@@ -191,7 +191,7 @@ subroutine setuptd2m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diag
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
dup=one
diff --git a/src/gsi/setupuwnd10m.f90 b/src/gsi/setupuwnd10m.f90
index 4552a7e81a..dcf7914020 100644
--- a/src/gsi/setupuwnd10m.f90
+++ b/src/gsi/setupuwnd10m.f90
@@ -229,7 +229,7 @@ subroutine setupuwnd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_d
goverrd=grav/rd
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! Check for missing data
@@ -428,7 +428,7 @@ subroutine setupuwnd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_d
lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. &
itype==247.or.itype==250.or.itype==251.or.itype==252.or. &
itype==253.or.itype==254.or.itype==257.or.itype==258.or. &
- itype==259
+ itype==259.or.itype==241
if (lowlevelsat .and. twodvar_regional) then
call windfactor(presw,factw)
data(iuob,i)=factw*data(iuob,i)
diff --git a/src/gsi/setupvis.f90 b/src/gsi/setupvis.f90
index e395c4f7fb..6b514fd47b 100644
--- a/src/gsi/setupvis.f90
+++ b/src/gsi/setupvis.f90
@@ -204,7 +204,7 @@ subroutine setupvis(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diags
isprvd=18 ! index of subprovider
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! Check for missing data !need obs value and error
diff --git a/src/gsi/setupvwnd10m.f90 b/src/gsi/setupvwnd10m.f90
index 0c601e716b..d3c7e573ed 100644
--- a/src/gsi/setupvwnd10m.f90
+++ b/src/gsi/setupvwnd10m.f90
@@ -229,7 +229,7 @@ subroutine setupvwnd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_d
goverrd=grav/rd
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! Check for missing data
@@ -428,7 +428,7 @@ subroutine setupvwnd10m(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_d
lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. &
itype==247.or.itype==250.or.itype==251.or.itype==252.or. &
itype==253.or.itype==254.or.itype==257.or.itype==258.or. &
- itype==259
+ itype==259.or.itype==241
if (lowlevelsat .and. twodvar_regional) then
call windfactor(presw,factw)
data(iuob,i)=factw*data(iuob,i)
diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90
index 174b6e695e..34c62e85dc 100644
--- a/src/gsi/setupw.f90
+++ b/src/gsi/setupw.f90
@@ -44,7 +44,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
use obsmod, only: l_obsprvdiag
use obsmod, only: neutral_stability_windfact_2dvar,use_similarity_2dvar
use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
- nc_diag_write, nc_diag_data2d
+ nc_diag_write, nc_diag_data2d, nc_diag_metadata_to_single
use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
use gsi_4dvar, only: nobs_bins,hr_obsbin,min_offset
use qcmod, only: npres_print,ptop,pbot,dfact,dfact1,qc_satwnds,njqc,vqc
@@ -55,8 +55,10 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
use guess_grids, only: nfldsig,hrdifsig,geop_hgtl,sfcmod_gfs
use guess_grids, only: tropprs,sfcmod_mm5
use guess_grids, only: ges_lnprsl,comp_fact10,pbl_height
+ use guess_grids, only: ges_tsen
+ use guess_grids, only: ges_prsi
use constants, only: zero,half,one,tiny_r_kind,two, &
- three,rd,grav,four,five,huge_single,r1000,wgtlim,r10,r400
+ three,rd,grav,four,five,huge_single,r100,r1000,wgtlim,r10,r400
use constants, only: grav_ratio,flattening,deg2rad, &
grav_equator,somigliana,semi_major_axis,eccentricity
use jfunc, only: jiter,last,jiterstart,miter
@@ -219,7 +221,6 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
! level; they are now loaded by
! aircraftinfo.
! 2020-05-04 wu - no rotate_wind for fv3_regional
-! 2021-07-25 Genkova - write AMVQ in diagnostic files
! 2021-10-xx pondeca/morris/zhao - added observation provider/subprovider
! information in diagonostic file, which is used
! in offline observation quality control program (AutoObsQC)
@@ -265,6 +266,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
real(r_kind) presw,factw,dpres,ugesin,vgesin,rwgt,dpressave
real(r_kind) sfcchk,prsln2,error,dtime,dlon,dlat,r0_001,rsig,thirty,rsigp
real(r_kind) ratio_errors,goverrd,spdges,spdob,ten,psges,zsges
+ real(r_kind) ratio_errors1, in_error_1, in_error_2 !ADC
real(r_kind) slat,sin2,termg,termr,termrg,pobl,uob,vob
real(r_kind) uob_reg,vob_reg,uob_e,vob_e,dlon_e,uges_e,vges_e,dudiff_e,dvdiff_e
real(r_kind) dz,zob,z1,z2,p1,p2,dz21,dlnp21,spdb,dstn
@@ -272,13 +274,28 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
real(r_kind) err_input,err_adjst,err_final,skint,sfcr
real(r_kind) dudiff_opp, dvdiff_opp, vecdiff, vecdiff_opp
real(r_kind) dudiff_opp_rs, dvdiff_opp_rs, vecdiff_rs, vecdiff_opp_rs
- real(r_kind) oscat_vec,ascat_vec,rapidscat_vec
+ real(r_kind) oscat_vec,rapidscat_vec
+! real(r_kind) ascat_vec
real(r_kind),dimension(nele,nobs):: data
real(r_kind),dimension(nobs):: dup
real(r_kind),dimension(nsig)::prsltmp,tges,zges
+ real(r_kind),dimension(nsig)::zges_read !emily: from geop_heigtl
+ real(r_kind),dimension(nsig)::zges_geometric !emily: calculated from zges_read
real(r_kind) wdirob,wdirgesin,wdirdiffmax
real(r_kind),dimension(34)::ptabluv
real(r_single),allocatable,dimension(:,:)::rdiagbuf
+ real(r_kind),dimension(nsig):: prsltmp2
+ real(r_kind),dimension(nsig+1):: prsitmp
+ real(r_kind),dimension(nsig):: ttmp,qtmp,utmp,vtmp,hsges
+ ! GSI profiles are stored with bottom up index; output the profiles
+ ! with top down index
+ real(r_kind),dimension(nsig):: ttmp_reverse,tvtmp_reverse,qtmp_reverse,utmp_reverse,vtmp_reverse
+ real(r_kind),dimension(nsig):: hsges_reverse, zges_reverse,prsltmp2_reverse
+ real(r_kind),dimension(nsig):: zges_read_reverse, zges_geometric_reverse
+ real(r_kind),dimension(nsig+1):: prsitmp_reverse
+ real(r_kind) psges2
+ !<< JEDI
+
integer(i_kind) i,nchar,nreal,k,j,l,ii,itype,ijb
! Variables needed for new polar winds QC based on Log Normalized Vector Departure (LNVD)
@@ -293,7 +310,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
integer(i_kind) ihgt,ier2,iuse,ilate,ilone
integer(i_kind) izz,iprvd,isprvd
integer(i_kind) idomsfc,isfcr,iskint,iff10
- integer(i_kind) ibb,ikk,ihil,idddd,iamvq
+ integer(i_kind) ibb,ikk,ihil,idddd,iamvq,kk
integer(i_kind) num_bad_ikx,iprev_station
@@ -334,6 +351,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
real(r_kind),allocatable,dimension(:,:,: ) :: ges_ps
real(r_kind),allocatable,dimension(:,:,: ) :: ges_z
+ real(r_kind),allocatable,dimension(:,:,:,:) :: ges_q
real(r_kind),allocatable,dimension(:,:,:,:) :: ges_u
real(r_kind),allocatable,dimension(:,:,:,:) :: ges_v
real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv
@@ -385,8 +403,8 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
ijb=25 ! index of non linear qc parameter
ihil=26 ! index of hilbert curve weight
iamvq=27 ! index of AMVQ
- iptrbu=28 ! index of u perturbation
- iptrbv=29 ! index of v perturbation
+ iptrbu=35 ! index of u perturbation
+ iptrbv=36 ! index of v perturbation
mm1=mype+1
scale=one
@@ -402,7 +420,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
if(conv_diagsave)then
ii=0
nchar=1
- ioff0=26
+ ioff0=25
nreal=ioff0
if (lobsdiagsave) nreal=nreal+7*miter+2
if (twodvar_regional .or. l_obsprvdiag) then
@@ -421,14 +439,8 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
if (netcdf_diag) call init_netcdf_diag_
end if
- num_bad_ikx=0
do i=1,nobs
- muse(i)=nint(data(iuse,i)) <= jiter
- ikx=nint(data(ikxx,i))
- if(ikx < 1 .or. ikx > nconvtype) then
- num_bad_ikx=num_bad_ikx+1
- if(num_bad_ikx<=10) write(6,*)' in setupw ',ikx,i,nconvtype,mype
- end if
+ muse(i)=nint(data(iuse,i)) <= jiter .and. nint(data(iqc,i)) < 8
end do
! If HD raobs available move prepbufr version to monitor
if(nhduv > 0)then
@@ -585,6 +597,23 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,&
nsig,mype,nfldsig)
+! GEOVALS for UFO eval
+ psges2 = psges ! keep in cb
+ prsltmp2 = exp(prsltmp)
+ call tintrp2a1(ges_prsi,prsitmp,dlat,dlon,dtime,hrdifsig,&
+ nsig+1,mype,nfldsig)
+ call tintrp2a1(ges_tsen,ttmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(ges_q,qtmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(ges_u,utmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(ges_v,vtmp,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+ call tintrp2a1(geop_hgtl,hsges,dlat,dlon,dtime,hrdifsig,&
+ nsig,mype,nfldsig)
+
+! END GEOVALS
! Type 221=pibal winds contain a mixture of wind observations reported
! by pressure and others by height. Those levels only reported by
! pressure have a missing value (ie, large) value for the reported
@@ -685,7 +714,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
hrdifsig,mype,nfldsig)
iz = max(1, min( int(dpres), nsig))
- delz = max(zero, min(dpres - float(iz), one))
+ delz = max(zero, min(dpres - real(iz,r_kind), one))
if (save_jacobian) then
@@ -813,7 +842,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
hrdifsig,mype,nfldsig)
iz = max(1, min( int(dpres), nsig))
- delz = max(zero, min(dpres - float(iz), one))
+ delz = max(zero, min(dpres - real(iz,r_kind), one))
if (save_jacobian) then
u_ind = getindex(svars3d, 'u')
@@ -880,12 +909,14 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
if(rhgh/=zero) awork(3) = awork(3) + one
end if
ratio_errors=error/(data(ier,i)+drpx+1.0e6_r_kind*rhgh+four*rlow)
-
+ ratio_errors1=ratio_errors ! ADC
+ in_error_1=error ! ADC
+ in_error_2=data(ier,i) ! ADC
! Compute innovations
lowlevelsat=itype==242.or.itype==243.or.itype==245.or.itype==246.or. &
itype==247.or.itype==250.or.itype==251.or.itype==252.or. &
itype==253.or.itype==254.or.itype==257.or.itype==258.or. &
- itype==259
+ itype==259.or.itype==241
if (lowlevelsat .and. twodvar_regional) then
call windfactor(presw,factw)
data(iuob,i)=factw*data(iuob,i)
@@ -902,8 +933,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
if (itype==236) then
magomb=sqrt(dudiff*dudiff+dvdiff*dvdiff)
ratio_errors=error/((uv_doe_a_236*magomb+uv_doe_b_236)+drpx+1.0e6_r_kind*rhgh+four*rlow)
- endif
- if (itype==237) then
+ else if (itype==237) then
magomb=sqrt(dudiff*dudiff+dvdiff*dvdiff)
ratio_errors=error/((uv_doe_a_237*magomb+uv_doe_b_237)+drpx+1.0e6_r_kind*rhgh+four*rlow)
endif
@@ -947,106 +977,102 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
if (itype >=240 .and. itype <=260) then
call intrp2a11(tropprs,trop5,dlat,dlon,mype)
if(presw < trop5-r50) error=zero ! tropopose check for all satellite winds
- endif
-
- if(itype >=240 .and. itype <=260) then
if(i_gsdqc==2) then
prsfc = r10*psges
if( prsfc-presw < 100.0_r_kind) error =zero ! add check for obs within 100 hPa of sfc
else
if( presw >950.0_r_kind) error =zero ! screen data beloww 950mb
endif
- endif
- if(itype ==242 .or. itype ==243 ) then ! visible winds from JMA and EUMETSAT
- if(presw <700.0_r_kind) error=zero ! no visible winds above 700mb
- endif
- if(itype ==245 ) then
- if( presw >399.0_r_kind .and. presw <801.0_r_kind) then !GOES IR winds
- error=zero ! no data between 400-800mb
- endif
- endif
- if(itype == 252 .and. presw >499.0_r_kind .and. presw <801.0_r_kind) then ! JMA IR winds
- error=zero
- endif
- if(itype == 253 ) then
- if(presw >401.0_r_kind .and. presw <801.0_r_kind) then ! EUMET IR winds
- error=zero
- endif
- endif
- if( itype == 246 .or. itype == 250 .or. itype == 254 ) then ! water vapor cloud top
- if(presw >399.0_r_kind) error=zero
- endif
- if(itype ==257 .and. presw <249.0_r_kind) error=zero
- if(itype ==258 .and. presw >600.0_r_kind) error=zero
- if(itype ==259 .and. presw >600.0_r_kind) error=zero
- if(itype ==259 .and. presw <249.0_r_kind) error=zero
- endif ! qc_satwnds
-
-! QC GOES CAWV - some checks above as well
- if (itype==247) then
- prsfc = r10*psges ! surface pressure in hPa
-
-! Compute observed and guess wind speeds (m/s).
- spdges = sqrt(ugesin* ugesin +vgesin* vgesin )
-
-! Set and compute GOES CAWV specific departure parameters
- LNVD_wspd = spdob
- LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff)
- LNVD_ratio = LNVD_omb / log(LNVD_wspd)
- LNVD_threshold = 3.0_r_kind
- if( .not. wrf_nmm_regional) then ! LNVD check not use for CAWV winds in HWRF
- if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check
- (presw > prsfc-110.0_r_kind .and. isli /= 0))then ! near surface check 110 ~1km
- error = zero
- endif
- endif
-! check for direction departure gt 50 deg
- wdirdiffmax=50._r_kind
- call getwdir(uob,vob,wdirob)
- call getwdir(ugesin,vgesin,wdirgesin)
- if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), &
- abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then
- error = zero
- endif
- endif
+ if(itype == 241 ) then
+ if( presw >399.0_r_kind .and. presw <601.0_r_kind) then !CIMISS(enhanced AMV) winds
+ error=zero ! no data between400-600mb
+ endif
+ else if(itype ==242 .or. itype ==243 ) then ! visible winds from JMA and EUMETSAT
+ if(presw <700.0_r_kind) error=zero ! no visible winds above 700mb
+ else if(itype ==245 ) then
+ if( presw >399.0_r_kind .and. presw <801.0_r_kind) then !GOES IR winds
+ error=zero ! no data between 400-800mb
+ endif
+ else if(itype == 252 )then
+ if( presw >499.0_r_kind .and. presw <801.0_r_kind) then ! JMA IR winds
+ error=zero
+ end if
+ else if(itype == 253 ) then
+ if(presw >401.0_r_kind .and. presw <801.0_r_kind) then ! EUMET IR winds
+ error=zero
+ endif
+ else if( itype == 246 .or. itype == 250 .or. itype == 254 ) then ! water vapor cloud top
+ if(presw >399.0_r_kind) error=zero
+
+! QC GOES CAWV - some checks above as well
+ else if (itype==247) then
+ prsfc = r10*psges ! surface pressure in hPa
+
+! Compute observed and guess wind speeds (m/s).
+ spdges = sqrt(ugesin* ugesin +vgesin* vgesin )
+
+! Set and compute GOES CAWV specific departure parameters
+ LNVD_wspd = spdob
+ LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff)
+ LNVD_ratio = LNVD_omb / log(LNVD_wspd)
+ LNVD_threshold = 3.0_r_kind
+ if( .not. wrf_nmm_regional) then ! LNVD check not use for CAWV winds in HWRF
+ if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check
+ (presw > prsfc-110.0_r_kind .and. isli /= 0))then ! near surface check 110 ~1km
+ error = zero
+ endif
+ endif
+! check for direction departure gt 50 deg
+ wdirdiffmax=50._r_kind
+ call getwdir(uob,vob,wdirob)
+ call getwdir(ugesin,vgesin,wdirgesin)
+ if ( min(abs(wdirob-wdirgesin),abs(wdirob-wdirgesin+r360), &
+ abs(wdirob-wdirgesin-r360)) > wdirdiffmax ) then
+ error = zero
+ endif
! QC MODIS winds
- if (itype==257 .or. itype==258 .or. itype==259 .or. itype ==260) then
-! Get guess values of tropopause pressure and sea/land/ice
-! mask at observation location
- prsfc = r10*prsfc ! surface pressure in hPa
-
-! Compute observed and guess wind speeds (m/s).
- spdges = sqrt(ugesin* ugesin +vgesin* vgesin )
+ else if (itype==257 .or. itype==258 .or. itype==259 .or. itype ==260) then
+ if(itype ==257 .and. presw <249.0_r_kind) error=zero
+ if(itype ==258 .and. presw >600.0_r_kind) error=zero
+ if(itype ==259 .and. presw >600.0_r_kind) error=zero
+ if(itype ==259 .and. presw <249.0_r_kind) error=zero
+! Get guess values of tropopause pressure and sea/land/ice
+! mask at observation location
+ prsfc = r10*prsfc ! surface pressure in hPa
+
+! Compute observed and guess wind speeds (m/s).
+ spdges = sqrt(ugesin* ugesin +vgesin* vgesin )
-! Set and computes modis specific qc parameters
- LNVD_wspd = spdob
- LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff)
- LNVD_ratio = LNVD_omb / log(LNVD_wspd)
- LNVD_threshold = 3.0_r_kind
- if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check
- (presw > prsfc-r200 .and. isli /= 0))then ! near surface check
- error = zero
- endif
- endif ! ???
-
-! QC AVHRR winds
- if (itype==244) then
-! Get guess values of tropopause pressure and sea/land/ice
-! mask at observation location
- prsfc = r10*prsfc ! surface pressure in hPa
-
-! Set and computes modis specific qc parameters
- LNVD_wspd = spdob
- LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff)
- LNVD_ratio = LNVD_omb / log(LNVD_wspd)
- LNVD_threshold = 3.0_r_kind
-
- if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check
- (presw > prsfc-r200 .and. isli /= 0))then ! near surface check
- error = zero
+! Set and computes modis specific qc parameters
+ LNVD_wspd = spdob
+ LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff)
+ LNVD_ratio = LNVD_omb / log(LNVD_wspd)
+ LNVD_threshold = 3.0_r_kind
+ if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check
+ (presw > prsfc-r200 .and. isli /= 0))then ! near surface check
+ error = zero
+ endif
+
+! QC AVHRR winds
+ else if (itype==244) then
+! Get guess values of tropopause pressure and sea/land/ice
+! mask at observation location
+ prsfc = r10*prsfc ! surface pressure in hPa
+
+! Set and computes modis specific qc parameters
+ LNVD_wspd = spdob
+ LNVD_omb = sqrt(dudiff*dudiff + dvdiff*dvdiff)
+ LNVD_ratio = LNVD_omb / log(LNVD_wspd)
+ LNVD_threshold = 3.0_r_kind
+
+ if(LNVD_ratio >= LNVD_threshold .or. & ! LNVD check
+ (presw > prsfc-r200 .and. isli /= 0))then ! near surface check
+ error = zero
+ endif
+ endif ! end if all satellite winds
endif
- endif ! end if all satellite winds
+ endif
! QC WindSAT winds
@@ -1058,10 +1084,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
abs(dvdiff) > qcv ) then ! v component check
error = zero
endif
- endif
! QC ASCAT winds
- if (itype==290) then
+ else if (itype==290) then
qcu = five
qcv = five
! Compute innovations for opposite vectors
@@ -1069,7 +1094,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
dvdiff_opp = -vob - vgesin
vecdiff = sqrt(dudiff**2 + dvdiff**2)
vecdiff_opp = sqrt(dudiff_opp**2 + dvdiff_opp**2)
- ascat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2)
+! ascat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2)
if ( abs(dudiff) > qcu .or. & ! u component check
abs(dvdiff) > qcv .or. & ! v component check
@@ -1077,10 +1102,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
error = zero
endif
- endif
! QC RAPIDSCAT winds
- if (itype==296) then
+ else if (itype==296) then
qcu = five
qcv = five
! Compute innovations for opposite vectors
@@ -1094,10 +1118,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
vecdiff_rs > vecdiff_opp_rs ) then ! ambiguity check
error = zero
endif
- endif
! QC OSCAT winds
- if (itype==291) then
+ else if (itype==291) then
qcu = r6
qcv = r6
oscat_vec = sqrt((dudiff**2 + dvdiff**2)/spdob**2)
@@ -1154,7 +1177,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
if(itype ==244) then ! AVHRR, use same as MODIS
qcgross=r0_7*cgross(ikx)
endif
- if( itype == 245 .or. itype ==246) then
+ if( itype == 245 .or. itype ==246 .or. itype ==241) then
if(presw <400.0_r_kind .and. presw >300.0_r_kind ) qcgross=r0_7*cgross(ikx)
endif
if(itype == 253 .or. itype ==254) then
@@ -1254,7 +1277,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
call vqc_setup(vals,ratio_errors,error,cvar,&
cg_t,ibb,ikk,var_jb,rat_err2v,wgt,valqcv)
rwgt = rwgt+0.5_r_kind*wgt/wgtlim
- valqc=valqcu+valqcv
+ valqc=half*(valqcu+valqcv)
! Accumulate statistics for obs belonging to this task
if (muse(i)) then
@@ -1275,7 +1298,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
nn=1
if (.not. muse(i)) then
nn=2
- if(ratio_errors*error >=tiny_r_kind)nn=3
+ if(error*ratio_errors >= tiny_r_kind)nn=3
+! if((data(iqc,i) >= 8 .and. data(iqc,i) <= 10) .or. &
+! error*ratio_errors >= tiny_r_kind)nn=3
end if
do k = 1,npres_print
if(presw >ptop(k) .and. presw<=pbot(k))then
@@ -1333,10 +1358,9 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
my_head%ib=ibeta(ikx)
my_head%ik=ikapa(ikx)
my_head%luse=luse(i)
-! if( i==3) print *,'SETUPW',my_head%ures,my_head%vres,my_head%err2
- if (luse_obsdiag) then
- endif ! (luse_obsdiag)
+! if( i==3) print *,'SETUPW',my_head%ures,my_head%vres,my_head%err2
+
if(oberror_tune) then
my_head%upertb=data(iptrbu,i)/error/ratio_errors
@@ -1361,6 +1385,7 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
endif
endif
+
if (luse_obsdiag) then
call obsdiagNode_assert(my_diagu, my_head%idv,my_head%iob,my_head%ich0+1_i_kind,myname,"my_diagu:my_head")
call obsdiagNode_assert(my_diagv, my_head%idv,my_head%iob,my_head%ich0+2_i_kind,myname,"my_diagv:my_head")
@@ -1571,6 +1596,24 @@ subroutine init_vars_
write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
call stop2(999)
endif
+! get q ...
+ varname='q'
+ call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus)
+ if (istatus==0) then
+ if(allocated(ges_q))then
+ write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
+ call stop2(999)
+ endif
+ allocate(ges_q(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig))
+ ges_q(:,:,:,1)=rank3
+ do ifld=2,nfldsig
+ call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus)
+ ges_q(:,:,:,ifld)=rank3
+ enddo
+ else
+ write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
+ call stop2(999)
+ endif
! get u ...
varname='u'
call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus)
@@ -1725,7 +1768,6 @@ subroutine contents_binary_diag_(udiag,vdiag)
rdiagbuf(23,ii) = factw ! 10m wind reduction factor
rdiagbuf(24,ii) = 1.e+10_r_single ! u spread (filled in by EnKF)
rdiagbuf(25,ii) = 1.e+10_r_single ! v spread (filled in by EnKF)
- rdiagbuf(26,ii) = data(iamvq,i) ! AMVQ mitigation flag for AMVs;only for GOES17,LHP issue
ioff=ioff0
if (lobsdiagsave) then
@@ -1791,39 +1833,47 @@ subroutine contents_netcdf_diag_(udiag,vdiag)
call nc_diag_metadata("Observation_Class", obsclass )
call nc_diag_metadata("Observation_Type", ictype(ikx) )
call nc_diag_metadata("Observation_Subtype", icsubtype(ikx) )
- call nc_diag_metadata("Latitude", sngl(data(ilate,i)) )
- call nc_diag_metadata("Longitude", sngl(data(ilone,i)) )
- call nc_diag_metadata("Station_Elevation", sngl(data(ielev,i)) )
- call nc_diag_metadata("Pressure", sngl(presw) )
- call nc_diag_metadata("Height", sngl(data(ihgt,i)) )
- call nc_diag_metadata("Time", sngl(dtime-time_offset))
- call nc_diag_metadata("Prep_QC_Mark", sngl(data(iqc,i)) )
+ call nc_diag_metadata_to_single("Latitude",data(ilate,i) )
+ call nc_diag_metadata_to_single("Longitude",data(ilone,i) )
+ call nc_diag_metadata_to_single("Station_Elevation",data(ielev,i) )
+ call nc_diag_metadata_to_single("Pressure",presw )
+ call nc_diag_metadata_to_single("Height",data(ihgt,i) )
+ call nc_diag_metadata_to_single("Time",dtime,time_offset,'-')
+ call nc_diag_metadata_to_single("Prep_QC_Mark",data(iqc,i) )
! call nc_diag_metadata("Setup_QC_Mark", rmiss_single )
- call nc_diag_metadata("Setup_QC_Mark", sngl(bmiss) )
- call nc_diag_metadata("Nonlinear_QC_Var_Jb", sngl(var_jb) )
- call nc_diag_metadata("Prep_Use_Flag", sngl(data(iuse,i)) )
+ call nc_diag_metadata_to_single("Setup_QC_Mark",bmiss )
+ call nc_diag_metadata_to_single("Nonlinear_QC_Var_Jb",var_jb )
+ call nc_diag_metadata_to_single("Prep_Use_Flag",data(iuse,i) )
if(muse(i)) then
- call nc_diag_metadata("Analysis_Use_Flag", sngl(one) )
+ call nc_diag_metadata_to_single("Analysis_Use_Flag", one )
else
- call nc_diag_metadata("Analysis_Use_Flag", sngl(-one) )
+ call nc_diag_metadata_to_single("Analysis_Use_Flag", -one )
endif
- call nc_diag_metadata("Nonlinear_QC_Rel_Wgt", sngl(rwgt) )
- call nc_diag_metadata("Errinv_Input", sngl(errinv_input) )
- call nc_diag_metadata("Errinv_Adjust", sngl(errinv_adjst) )
- call nc_diag_metadata("Errinv_Final", sngl(errinv_final) )
+ !call nc_diag_metadata_to_single("drpx",drpx ) ! ADC
+ !call nc_diag_metadata_to_single("rhgh",rhgh ) ! ADC
+ !call nc_diag_metadata_to_single("rlow",rlow ) ! ADC
+ !call nc_diag_metadata_to_single("in_error_1",in_error_1 ) ! ADC
+ !call nc_diag_metadata_to_single("in_error_2",in_error_2 ) ! ADC
+ !call nc_diag_metadata_to_single("ratio_errors",ratio_errors1) ! ADC
+
+
+ call nc_diag_metadata_to_single("Nonlinear_QC_Rel_Wgt",rwgt)
+ call nc_diag_metadata_to_single("Errinv_Input",errinv_input)
+ call nc_diag_metadata_to_single("Errinv_Adjust",errinv_adjst)
+ call nc_diag_metadata_to_single("Errinv_Final",errinv_final)
! AMVQ Mitigated winds
- call nc_diag_metadata("Mitigation_flag_AMVQ", sngl(data(iamvq,i)) )
- call nc_diag_metadata("Wind_Reduction_Factor_at_10m", sngl(factw) )
+ call nc_diag_metadata_to_single("Mitigation_flag_AMVQ",data(iamvq,i) )
+ call nc_diag_metadata_to_single("Wind_Reduction_Factor_at_10m",factw )
if (.not. regional .or. fv3_regional) then
- call nc_diag_metadata("u_Observation", sngl(data(iuob,i)) )
- call nc_diag_metadata("u_Obs_Minus_Forecast_adjusted", sngl(dudiff) )
- call nc_diag_metadata("u_Obs_Minus_Forecast_unadjusted", sngl(uob-ugesin) )
+ call nc_diag_metadata_to_single("u_Observation",data(iuob,i) )
+ call nc_diag_metadata_to_single("u_Obs_Minus_Forecast_adjusted",dudiff )
+ call nc_diag_metadata_to_single("u_Obs_Minus_Forecast_unadjusted",uob,ugesin,'-')
- call nc_diag_metadata("v_Observation", sngl(data(ivob,i)) )
- call nc_diag_metadata("v_Obs_Minus_Forecast_adjusted", sngl(dvdiff) )
- call nc_diag_metadata("v_Obs_Minus_Forecast_unadjusted", sngl(vob-vgesin) )
+ call nc_diag_metadata_to_single("v_Observation",data(ivob,i) )
+ call nc_diag_metadata_to_single("v_Obs_Minus_Forecast_adjusted",dvdiff )
+ call nc_diag_metadata_to_single("v_Obs_Minus_Forecast_unadjusted",vob,vgesin,'-')
else ! (if regional)
! replace positions 17-22 with earth relative wind component information
@@ -1834,13 +1884,13 @@ subroutine contents_netcdf_diag_(udiag,vdiag)
call rotate_wind_xy2ll(ugesin,vgesin,uges_e,vges_e,dlon_e,dlon,dlat)
call rotate_wind_xy2ll(dudiff,dvdiff,dudiff_e,dvdiff_e,dlon_e,dlon,dlat)
- call nc_diag_metadata("u_Observation", sngl(uob_e) )
- call nc_diag_metadata("u_Obs_Minus_Forecast_adjusted", sngl(dudiff_e) )
- call nc_diag_metadata("u_Obs_Minus_Forecast_unadjusted", sngl(uob_e-uges_e) )
+ call nc_diag_metadata_to_single("u_Observation",uob_e )
+ call nc_diag_metadata_to_single("u_Obs_Minus_Forecast_adjusted",dudiff_e )
+ call nc_diag_metadata_to_single("u_Obs_Minus_Forecast_unadjusted",uob_e,uges_e,'-')
- call nc_diag_metadata("v_Observation", sngl(vob_e) )
- call nc_diag_metadata("v_Obs_Minus_Forecast_adjusted", sngl(dvdiff_e) )
- call nc_diag_metadata("v_Obs_Minus_Forecast_unadjusted", sngl(vob_e-vges_e) )
+ call nc_diag_metadata_to_single("v_Observation",vob_e )
+ call nc_diag_metadata_to_single("v_Obs_Minus_Forecast_adjusted",dvdiff_e )
+ call nc_diag_metadata_to_single("v_Obs_Minus_Forecast_unadjusted",vob_e,vges_e,'-')
endif
if (lobsdiagsave) then
@@ -1880,12 +1930,81 @@ subroutine contents_netcdf_diag_(udiag,vdiag)
call nc_diag_data2d("v_Observation_Operator_Jacobian_val", real(dhx_dx_v%val,r_single))
endif
+ ! GEOVALS
+ !>>emily
+ do k = 1, nsig
+ kk = nsig-k+1
+ utmp_reverse(kk) = utmp(k)
+ vtmp_reverse(kk) = vtmp(k)
+ ttmp_reverse(kk) = ttmp(k)
+ tvtmp_reverse(kk) = tges(k) !emily
+ qtmp_reverse(kk) = qtmp(k)
+ hsges_reverse(kk) = hsges(k)
+ zges_read_reverse(kk)= zges_read(k)
+ zges_geometric_reverse(kk)= zges_geometric(k)
+ zges_reverse(kk) = zges(k)
+ prsltmp2_reverse(kk) = prsltmp2(k)
+ enddo
+ do k = 1, nsig+1
+ kk = (nsig+1)-k+1
+ prsitmp_reverse(kk) = prsitmp(k)
+ enddo
+
+ call nc_diag_data2d("atmosphere_pressure_coordinate", sngl(prsltmp2_reverse*r1000))
+ call nc_diag_data2d("atmosphere_pressure_coordinate_interface", sngl(prsitmp_reverse*r1000))
+ call nc_diag_data2d("air_temperature", sngl(ttmp_reverse))
+ call nc_diag_data2d("virtual_temperature", sngl(tvtmp_reverse)) !emily
+ call nc_diag_data2d("specific_humidity", sngl(qtmp_reverse))
+ call nc_diag_data2d("eastward_wind", sngl(utmp_reverse))
+ call nc_diag_data2d("northward_wind", sngl(vtmp_reverse))
+! call nc_diag_data2d("geopotential_height", sngl(hsges_reverse) ) !orig
+ call nc_diag_data2d("geopotential_height", sngl(zges_read_reverse) ) !emily
+ call nc_diag_data2d("geometric_height", sngl(zges_geometric_reverse) ) !emily
+ !<= float(n-1)*binwidth .and. wdir < float(n)*binwidth ) then
+ if ( wdir >= real(n-1,r_kind)*binwidth .and. wdir < real(n,r_kind)*binwidth ) then
ibin=n
exit
endif
diff --git a/src/gsi/smoothzrf.f90 b/src/gsi/smoothzrf.f90
index 06e877ee68..dae656ca1b 100644
--- a/src/gsi/smoothzrf.f90
+++ b/src/gsi/smoothzrf.f90
@@ -81,7 +81,7 @@ subroutine frfhvo(p1,iv)
do k=1,lat2
l=int(rllat1(k,j))
l2=min0(l+1,llmax)
- dl2(k,j)=rllat1(k,j)-float(l)
+ dl2(k,j)=rllat1(k,j)-real(l,r_kind)
dl1(k,j)=one-dl2(k,j)
end do
end do
diff --git a/src/gsi/ssmis_spatial_average_mod.f90 b/src/gsi/ssmis_spatial_average_mod.f90
index 24ac91d3f1..30b69c6223 100644
--- a/src/gsi/ssmis_spatial_average_mod.f90
+++ b/src/gsi/ssmis_spatial_average_mod.f90
@@ -682,26 +682,15 @@ SUBROUTINE SSMIS_Spatial_Average(BufrSat, Method, Num_Obs, NChanl, &
! Define grid box by channel -
! Ch 1-2: 1 scan direction, 1 track direction
! Ch 3-13: 3 scan direction, 3 track direction
- if ((ic == 1) .or. (ic == 2)) then
- ns1 = iscan
- ns2 = iscan
- if (ns1 < 1) ns1=1
- if (ns2 > max_scan) ns2=max_scan
- np1 = ifov
- np2 = ifov
- if (np1 < 1) np1=1
- if (np2 > max_fov_gmi) np2=max_fov_gmi
- else if ((ic > 2) .and. (ic < 14)) then
- ns1 = iscan-1
- ns2 = iscan+1
- if (ns1 < 1) ns1=1
- if (ns2 > max_scan) ns2=max_scan
- np1 = ifov-1
- np2 = ifov+1
- if (np1 < 1) np1=1
- if (np2 > max_fov_gmi) np2=max_fov_gmi
- endif
+ ns1 = iscan-4
+ ns2 = iscan+4
+ if (ns1 < 1) ns1=1
+ if (ns2 > max_scan) ns2=max_scan
+ np1 = ifov-8
+ np2 = ifov+8
+ if (np1 < 1) np1=1
+ if (np2 > max_fov_gmi) np2=max_fov_gmi
xnum = 0.0_r_kind
mta = 0.0_r_kind
if (any(bt_image_orig(np1:np2,ns1:ns2,ic) < btmin .or. &
@@ -716,7 +705,7 @@ SUBROUTINE SSMIS_Spatial_Average(BufrSat, Method, Num_Obs, NChanl, &
lat2 = latitude(ip,is)
lon2 = longitude(ip,is)
dist = distance(lat1,lon1,lat2,lon2)
- if (dist > 50.0_r_kind) cycle gmi_box_x1 ! outside the box
+ if (dist > 20.0_r_kind) cycle gmi_box_x1 ! outside the box
if (gaussian_wgt) then
wgt = exp(-0.5_r_kind*(dist/sigma)*(dist/sigma))
else
@@ -1551,7 +1540,7 @@ SUBROUTINE SFFTCB( X, N, M )
END DO
J = J + K
104 CONTINUE
- XT = 1.0 / FLOAT( N )
+ XT = 1.0 / real( N,r_kind )
DO 99 I = 1, N
X(I) = XT * X(I)
99 CONTINUE
diff --git a/src/gsi/state_vectors.f90 b/src/gsi/state_vectors.f90
index 711043fa57..5a573785e7 100644
--- a/src/gsi/state_vectors.f90
+++ b/src/gsi/state_vectors.f90
@@ -62,7 +62,7 @@ module state_vectors
use GSI_BundleMod, only : GSI_GridCreate
use mpeu_util, only: gettablesize
-use mpeu_util, only: gettable
+use mpeu_util, only: gettable,getindex
implicit none
@@ -83,6 +83,8 @@ module state_vectors
public svars
public levels
public ns2d,ns3d,nsdim
+ public qgpresent,qspresent,qrpresent,qipresent,qlpresent
+ public cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent
! State vector definition
! Could contain model state fields plus other fields required
@@ -101,6 +103,8 @@ module state_vectors
character(len=max_varname_length),allocatable,dimension(:) :: svars2d
integer(i_kind) ,allocatable,dimension(:) :: levels
+logical qgpresent,qspresent,qrpresent,qipresent,qlpresent
+logical cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent
! ----------------------------------------------------------------------
INTERFACE PRT_STATE_NORMS
@@ -245,6 +249,18 @@ subroutine init_anasv
write(6,*) myname_,': 3D-STATE VARIABLES ', svars3d
write(6,*) myname_,': ALL STATE VARIABLES ', svars
end if
+qgpresent=getindex(svars3d,'qg')>0
+qspresent=getindex(svars3d,'qs')>0
+qrpresent=getindex(svars3d,'qr')>0
+qipresent=getindex(svars3d,'qi')>0
+qlpresent=getindex(svars3d,'ql')>0
+cldchpresent=getindex(svars2d,'cldch')>0
+lcbaspresent=getindex(svars2d,'lcbas')>0
+howvpresent=getindex(svars2d,'howv')>0
+wspd10mpresent=getindex(svars2d,'wspd10m')>0
+pblhpresent=getindex(svars2d,'pblh')>0
+vispresent=getindex(svars2d,'vis')>0
+gustpresent=getindex(svars2d,'gust')>0
end subroutine init_anasv
subroutine final_anasv
@@ -370,7 +386,7 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum)
! local variables
real(r_kind),allocatable,dimension(:) :: zloc,nloc
real(r_kind),allocatable,dimension(:,:) :: zall,nall
- integer(i_kind) :: i,ii
+ integer(i_kind) :: i
pmin=zero
pmax=zero
@@ -383,59 +399,32 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum)
zloc=zero
! Independent part of vector
-! Sum
- ii=0
+! Sum,Max,Min and number of points
+!$omp parallel do schedule(static,1) private(i)
do i = 1,ns3d
- ii=ii+1
if(xst%r3(i)%mykind==r_single)then
- zloc(ii)= sum_mask(xst%r3(i)%qr4,ihalo=1)
+ zloc(i)= sum_mask(xst%r3(i)%qr4,ihalo=1)
+ zloc(nvars+i)= minval(xst%r3(i)%qr4)
+ zloc(2*nvars+i)= maxval(xst%r3(i)%qr4)
else
- zloc(ii)= sum_mask(xst%r3(i)%q,ihalo=1)
+ zloc(i)= sum_mask(xst%r3(i)%q,ihalo=1)
+ zloc(nvars+i)= minval(xst%r3(i)%q)
+ zloc(2*nvars+i)= maxval(xst%r3(i)%q)
endif
- nloc(ii) = real((lat2-2)*(lon2-2)*levels(i), r_kind) ! dim of 3d fields
+ nloc(i) = real((lat2-2)*(lon2-2)*levels(i), r_kind) ! dim of 3d fields
enddo
+!$omp parallel do schedule(static,1) private(i)
do i = 1,ns2d
- ii=ii+1
if(xst%r2(i)%mykind==r_single)then
- zloc(ii)= sum_mask(xst%r2(i)%qr4,ihalo=1)
+ zloc(ns3d+i)= sum_mask(xst%r2(i)%qr4,ihalo=1)
+ zloc(nvars+ns3d+i)= minval(xst%r2(i)%qr4)
+ zloc(2*nvars+ns3d+i)= maxval(xst%r2(i)%qr4)
else
- zloc(ii)= sum_mask(xst%r2(i)%q,ihalo=1)
- endif
- nloc(ii) = real((lat2-2)*(lon2-2), r_kind) ! dim of 2d fields
- enddo
-! Min
- do i = 1,ns3d
- ii=ii+1
- if(xst%r3(i)%mykind==r_single)then
- zloc(ii)= minval(xst%r3(i)%qr4)
- else
- zloc(ii)= minval(xst%r3(i)%q)
- endif
- enddo
- do i = 1,ns2d
- ii=ii+1
- if(xst%r2(i)%mykind==r_single)then
- zloc(ii)= minval(xst%r2(i)%qr4)
- else
- zloc(ii)= minval(xst%r2(i)%q)
- endif
- enddo
-! Max
- do i = 1,ns3d
- ii=ii+1
- if(xst%r3(i)%mykind==r_single)then
- zloc(ii)= maxval(xst%r3(i)%qr4)
- else
- zloc(ii)= maxval(xst%r3(i)%q)
- endif
- enddo
- do i = 1,ns2d
- ii=ii+1
- if(xst%r2(i)%mykind==r_single)then
- zloc(ii)= maxval(xst%r2(i)%qr4)
- else
- zloc(ii)= maxval(xst%r2(i)%q)
+ zloc(ns3d+i)= sum_mask(xst%r2(i)%q,ihalo=1)
+ zloc(nvars+ns3d+i)= minval(xst%r2(i)%q)
+ zloc(2*nvars+ns3d+i)= maxval(xst%r2(i)%q)
endif
+ nloc(ns3d+i) = real((lat2-2)*(lon2-2), r_kind) ! dim of 2d fields
enddo
! Gather contributions
@@ -444,20 +433,12 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum)
call mpi_allgather(nloc,size(nloc),mpi_rtype, &
& nall,size(nloc),mpi_rtype, mpi_comm_world,ierror)
- ii=0
- do i=1,ns3d
- ii=ii+1
- psum(ii)=SUM(zall(ii,:))
- pnum(ii)=SUM(nall(ii,:))
- enddo
- do i=1,ns2d
- ii=ii+1
- psum(ii)=SUM(zall(ii,:))
- pnum(ii)=SUM(nall(ii,:))
- enddo
- do ii=1,nvars
- pmin(ii)=MINVAL(zall( nvars+ii,:))
- pmax(ii)=MAXVAL(zall(2*nvars+ii,:))
+!$omp parallel do schedule(static,1) private(i)
+ do i=1,nvars
+ psum(i)=SUM(zall(i,:))
+ pnum(i)=SUM(nall(i,:))
+ pmin(i)=MINVAL(zall( nvars+i,:))
+ pmax(i)=MAXVAL(zall(2*nvars+i,:))
enddo
! Release work space
diff --git a/src/gsi/statsco.f90 b/src/gsi/statsco.f90
index ebef4a31e4..54f28ccfd9 100644
--- a/src/gsi/statsco.f90
+++ b/src/gsi/statsco.f90
@@ -119,7 +119,7 @@ subroutine statsco(stats_co,bwork,awork,ndata)
if (iasim > 0) then
svar = error_co(i)
if (iuse_co(i)/=1) svar = -svar
- rsum = one/float(iasim)
+ rsum = one/real(iasim,r_kind)
icerr = nint(stats_co(2,i))
do j=3,6 ! j=3=obs-mod(w_biascor)
! j=4=(obs-mod(w_biascor))**2
@@ -145,7 +145,7 @@ subroutine statsco(stats_co,bwork,awork,ndata)
do i=1,ndat
if (idisplay(i)) then
cpen=zero
- if (icount_asim(i)>0) cpen=rpenal(i)/float(icount_asim(i))
+ if (icount_asim(i)>0) cpen=rpenal(i)/real(icount_asim(i),r_kind)
write(iout_co,1115) jiter,dplat(i),dtype(i),ndata(i,2), &
ndata(i,3),icount_asim(i),rpenal(i),cpen,qcpenal(i),iqccount_asim(i)
endif
@@ -184,8 +184,8 @@ subroutine statsco(stats_co,bwork,awork,ndata)
num(k)=nint(awork(5*nsig+k+100))
rat=zero ; rat3=zero
if(num(k) > 0) then
- rat=awork(6*nsig+k+100)/float(num(k))
- rat3=awork(3*nsig+k+100)/float(num(k))
+ rat=awork(6*nsig+k+100)/real(num(k),r_kind)
+ rat3=awork(3*nsig+k+100)/real(num(k),r_kind)
end if
ntot=ntot+num(k); o3plty=o3plty+awork(6*nsig+k+100)
o3qcplty=o3qcplty+awork(3*nsig+k+100)
diff --git a/src/gsi/statsconv.f90 b/src/gsi/statsconv.f90
index 7ddb7dea04..fc105515ff 100644
--- a/src/gsi/statsconv.f90
+++ b/src/gsi/statsconv.f90
@@ -2,7 +2,7 @@ subroutine statsconv(mype,&
i_ps,i_uv,i_t,i_q,i_pw,i_rw,i_dw,i_gps,i_sst,i_tcp,i_lag, &
i_gust,i_vis,i_pblh,i_wspd10m,i_td2m,i_mxtm,i_mitm,i_pmsl,i_howv, &
i_tcamt,i_lcbas,i_cldch,i_uwnd10m,i_vwnd10m,&
- i_swcp,i_lwcp,i_dbz,i_ref,bwork,awork,ndata)
+ i_swcp,i_lwcp,i_fed,i_dbz,i_ref,bwork,awork,ndata)
!$$$ subprogram documentation block
! . . . .
! subprogram: statconv prints statistics for conventional data
@@ -74,6 +74,7 @@ subroutine statsconv(mype,&
! i_vwnd10m- index in awork array holding vwnd10m info
! i_swcp - index in awork array holding swcp info
! i_lwcp - index in awork array holding lwcp info
+! i_fed - index in awork array holding fed info
! i_dbz - index in awork array holding dbz info
! i_ref - size of second dimension of awork array
! bwork - array containing information for statistics
@@ -96,12 +97,12 @@ subroutine statsconv(mype,&
iout_gust,iout_vis,iout_pblh,iout_wspd10m,iout_td2m,&
iout_mxtm,iout_mitm,iout_pmsl,iout_howv,iout_tcamt,iout_lcbas,iout_cldch,&
iout_uwnd10m,iout_vwnd10m,&
- iout_dbz,iout_swcp,iout_lwcp,&
+ iout_fed,iout_dbz,iout_swcp,iout_lwcp,&
mype_dw,mype_rw,mype_sst,mype_gps,mype_uv,mype_ps,&
mype_t,mype_pw,mype_q,mype_tcp,ndat,dtype,mype_lag,mype_gust,&
mype_vis,mype_pblh,mype_wspd10m,mype_td2m,mype_mxtm,mype_mitm,&
mype_pmsl,mype_howv,mype_tcamt,mype_lcbas,mype_cldch,mype_uwnd10m,mype_vwnd10m,&
- mype_dbz,mype_swcp,mype_lwcp
+ mype_fed,mype_dbz,mype_swcp,mype_lwcp
use qcmod, only: npres_print,ptop,pbot,ptopq,pbotq
use jfunc, only: first,jiter
use gridmod, only: nsig
@@ -112,7 +113,7 @@ subroutine statsconv(mype,&
integer(i_kind) ,intent(in ) :: mype,i_ps,i_uv,&
i_t,i_q,i_pw,i_rw,i_dw,i_gps,i_sst,i_tcp,i_lag,i_gust,i_vis,i_pblh,&
i_wspd10m,i_td2m,i_mxtm,i_mitm,i_pmsl,i_howv,i_tcamt,i_lcbas,&
- i_cldch,i_uwnd10m,i_vwnd10m,i_swcp,i_lwcp,i_dbz,i_ref
+ i_cldch,i_uwnd10m,i_vwnd10m,i_swcp,i_lwcp,i_fed,i_dbz,i_ref
real(r_kind),dimension(7*nsig+100,i_ref) ,intent(in ) :: awork
real(r_kind),dimension(npres_print,nconvtype,5,3),intent(in ) :: bwork
integer(i_kind),dimension(ndat,3) ,intent(in ) :: ndata
@@ -136,6 +137,7 @@ subroutine statsconv(mype,&
real(r_kind) dwqcplty,tqcplty,qctt,qctrw,rwqcplty,qctdw,qqcplty,qctgps
real(r_kind) gpsqcplty,tpw3,pw3,qctq
real(r_kind) tswcp3,tlwcp3,qctdbz,dbzqcplty
+ real(r_kind) fedmplty,tfed,qctfed,fedqcplty
real(r_kind),dimension(1):: pbotall,ptopall
logical,dimension(nconvtype):: pflag
@@ -154,20 +156,6 @@ subroutine statsconv(mype,&
! Summary report for winds
if(mype==mype_uv) then
-! Open output file so as to point to correct position in output file
- if(first)then
- open(iout_uv)
- else
- open(iout_uv,position='append')
- end if
-
-
-! Compute and write counts, penalties, and ratio of penalty
-! to data counts for each model level
- numssm=nint(awork(6,i_uv)); numgross=nint(awork(4,i_uv))
- umplty=zero; vmplty=zero; uvqcplty=zero ; ntot=0;
- tu=zero; tv=zero ; tuv=zero
- tssm=zero ; qctssm=zero
nread=0
nkeep=0
nreadspd=0
@@ -181,85 +169,92 @@ subroutine statsconv(mype,&
nkeepspd=nkeepspd+ndata(i,3)
end if
end do
- if(nkeep > 0 .or. nkeepspd > 0)then
-! Write header information
- mesage='current vfit of wind data, ranges in m/s$'
+ if(nread > 0 .or. nreadspd > 0)then
+! Open output file so as to point to correct position in output file
+ if(first)then
+ open(iout_uv)
+ else
+ open(iout_uv,position='append')
+ end if
-! Call routine to compute and write count, rms, and penalty information
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'spd' .or. trim(ioctype(j)) == 'uv'
- end do
- call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_uv,pflag)
- numlow = nint(awork(2,i_uv))
- numhgh = nint(awork(3,i_uv))
- write(iout_uv,900) 'wind',numhgh,numlow
- numfailqc=nint(awork(21,i_uv))
-! keep a seperate record of numfailqc for ssmi wind speeds
- numfailqc_ssmi=nint(awork(61,i_uv))
- do k=1,nsig
- num(k)=nint(awork(6*nsig+k+100,i_uv))
- rat1=zero
- rat2=zero
- if(num(k) > 0)then
- rat1=awork(4*nsig+k+100,i_uv)/float(num(k))
- rat2=awork(5*nsig+k+100,i_uv)/float(num(k))
+
+! Compute and write counts, penalties, and ratio of penalty
+! to data counts for each model level
+ numssm=nint(awork(6,i_uv)); numgross=nint(awork(4,i_uv))
+ umplty=zero; vmplty=zero; uvqcplty=zero ; ntot=0;
+ tu=zero; tv=zero ; tuv=zero
+ tssm=zero ; qctssm=zero
+ if(nkeep > 0 .or. nkeepspd > 0)then
+! Write header information
+ mesage='current vfit of wind data, ranges in m/s$'
+
+! Call routine to compute and write count, rms, and penalty information
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'spd' .or. trim(ioctype(j)) == 'uv'
+ end do
+ call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_uv,pflag)
+ numlow = nint(awork(2,i_uv))
+ numhgh = nint(awork(3,i_uv))
+ write(iout_uv,900) 'wind',numhgh,numlow
+ numfailqc=nint(awork(21,i_uv))
+! keep a seperate record of numfailqc for ssmi wind speeds
+ numfailqc_ssmi=nint(awork(61,i_uv))
+ do k=1,nsig
+ num(k)=nint(awork(6*nsig+k+100,i_uv))
+ rat1=zero
+ rat2=zero
+ if(num(k) > 0)then
+ rat1=awork(4*nsig+k+100,i_uv)/real(num(k),r_kind)
+ rat2=awork(5*nsig+k+100,i_uv)/real(num(k),r_kind)
+ end if
+ umplty=umplty+awork(4*nsig+k+100,i_uv)
+ vmplty=vmplty+awork(5*nsig+k+100,i_uv)
+ ntot=ntot+num(k)
+ write(iout_uv,241) 'w',num(k),k,awork(4*nsig+k+100,i_uv),&
+ awork(5*nsig+k+100,i_uv),rat1,rat2
+ end do
+ do k=1,nsig
+ num(k)=nint(awork(6*nsig+k+100,i_uv))
+ rat1=zero
+ rat3=zero
+ if(num(k) > 0)then
+ rat1=(awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv))/real(num(k),r_kind)
+ rat3=awork(3*nsig+k+100,i_uv)/real(num(k),r_kind)
+ end if
+ uvqcplty=uvqcplty+awork(3*nsig+k+100,i_uv)
+ write(iout_uv,240) 'w',num(k),k,awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv), &
+ awork(3*nsig+k+100,i_uv),rat1,rat3
+ end do
+
+! Write statistics gross checks
+ write(iout_uv,920)' number ssm/i winds that fail nonlinear qc =',numfailqc_ssmi
+ write(iout_uv,925) 'wind',numgross,numfailqc
+! Write statistics regarding penalties
+ if(ntot > 0)then
+ tu=umplty/real(ntot,r_kind)
+ tv=vmplty/real(ntot,r_kind)
+ tuv=uvqcplty/real(ntot,r_kind)
end if
- umplty=umplty+awork(4*nsig+k+100,i_uv)
- vmplty=vmplty+awork(5*nsig+k+100,i_uv)
- ntot=ntot+num(k)
- write(iout_uv,241) 'w',num(k),k,awork(4*nsig+k+100,i_uv),&
- awork(5*nsig+k+100,i_uv),rat1,rat2
- end do
- do k=1,nsig
- num(k)=nint(awork(6*nsig+k+100,i_uv))
- rat1=zero
- rat3=zero
- if(num(k) > 0)then
- rat1=(awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv))/float(num(k))
- rat3=awork(3*nsig+k+100,i_uv)/float(num(k))
+ if(numssm > 0)then
+ tssm=awork(5,i_uv)/awork(6,i_uv)
+ qctssm=awork(22,i_uv)/awork(6,i_uv)
end if
- uvqcplty=uvqcplty+awork(3*nsig+k+100,i_uv)
- write(iout_uv,240) 'w',num(k),k,awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv), &
- awork(3*nsig+k+100,i_uv),rat1,rat3
- end do
-
-! Write statistics gross checks
- write(iout_uv,920)' number ssm/i winds that fail nonlinear qc =',numfailqc_ssmi
- write(iout_uv,925) 'wind',numgross,numfailqc
-! Write statistics regarding penalties
- if(ntot > 0)then
- tu=umplty/float(ntot)
- tv=vmplty/float(ntot)
- tuv=uvqcplty/float(ntot)
- end if
- if(numssm > 0)then
- tssm=awork(5,i_uv)/awork(6,i_uv)
- qctssm=awork(22,i_uv)/awork(6,i_uv)
end if
- end if
- write(iout_uv,949) 'u',ntot,umplty,tu
- write(iout_uv,949) 'v',ntot,vmplty,tv
- write(iout_uv,950) 'uv',jiter,nread,nkeep,ntot*2
- write(iout_uv,951) 'uv',umplty+vmplty,uvqcplty,tu+tv,tuv
- write(iout_uv,950) 'spd',jiter,nreadspd,nkeepspd,numssm
- write(iout_uv,951) 'spd',awork(5,i_uv),awork(22,i_uv),tssm,qctssm
+ write(iout_uv,949) 'u',ntot,umplty,tu
+ write(iout_uv,949) 'v',ntot,vmplty,tv
+ write(iout_uv,950) 'uv',jiter,nread,nkeep,ntot*2
+ write(iout_uv,951) 'uv',umplty+vmplty,uvqcplty,tu+tv,tuv
+ write(iout_uv,950) 'spd',jiter,nreadspd,nkeepspd,numssm
+ write(iout_uv,951) 'spd',awork(5,i_uv),awork(22,i_uv),tssm,qctssm
! Close unit receiving summary output
- close(iout_uv)
+ close(iout_uv)
+ end if
end if
! Summary report for gps
if (mype==mype_gps)then
- if(first)then
- open(iout_gps)
- else
- open(iout_gps,position='append')
- end if
-
-
- gpsmplty=zero; gpsqcplty=zero ; ntot=0
- tgps=zero ; qctgps=zero
nread=0
nkeep=0
ctype=' '
@@ -270,67 +265,64 @@ subroutine statsconv(mype,&
ctype=dtype(i)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of gps data in fractional difference$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'gps'
- end do
- call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_gps,pflag)
- do k=1,nsig
- num(k)=nint(awork(5*nsig+k+100,i_gps))
- rat=zero
- rat3=zero
- if(num(k)>0) then
- rat=awork(6*nsig+k+100,i_gps)/float(num(k))
- rat3=awork(3*nsig+k+100,i_gps)/float(num(k))
- end if
- ntot=ntot+num(k); gpsmplty=gpsmplty+awork(6*nsig+k+100,i_gps)
- gpsqcplty=gpsqcplty+awork(3*nsig+k+100,i_gps)
- write(iout_gps,240)'gps',num(k),k,awork(6*nsig+k+100,i_gps), &
- awork(3*nsig+k+100,i_gps),rat,rat3
- end do
- numgross=nint(awork(4,i_gps))
- numfailqc=nint(awork(21,i_gps))
- numfail1_gps=nint(awork(22,i_gps))
- numfail2_gps=nint(awork(23,i_gps))
- numfail3_gps=nint(awork(24,i_gps))
- write(iout_gps,925)'gps',numgross,numfailqc
- write(iout_gps,920)' number of gps obs failed stats qc in NH =',numfail1_gps
- write(iout_gps,920)' number of gps obs failed stats qc in SH =',numfail2_gps
- write(iout_gps,920)' number of gps obs failed stats qc in TR =',numfail3_gps
-
- numlow = nint(awork(2,i_gps))
- numhgh = nint(awork(3,i_gps))
- write(iout_gps,900) 'gps',numhgh,numlow
- if(ntot > 0) then
- tgps=gpsmplty/ntot
- qctgps=gpsqcplty/ntot
- endif
- end if
+ if(nread > 0)then
+ if(first)then
+ open(iout_gps)
+ else
+ open(iout_gps,position='append')
+ end if
- write(iout_gps,950) ctype,jiter,nread,nkeep,ntot
- write(iout_gps,951) ctype,gpsmplty,gpsqcplty,tgps,qctgps
- close(iout_gps)
- endif
+ gpsmplty=zero; gpsqcplty=zero ; ntot=0
+ tgps=zero ; qctgps=zero
+ if(nkeep > 0)then
+ mesage='current fit of gps data in fractional difference$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'gps'
+ end do
+ call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_gps,pflag)
+ do k=1,nsig
+ num(k)=nint(awork(5*nsig+k+100,i_gps))
+ rat=zero
+ rat3=zero
+ if(num(k)>0) then
+ rat=awork(6*nsig+k+100,i_gps)/real(num(k),r_kind)
+ rat3=awork(3*nsig+k+100,i_gps)/real(num(k),r_kind)
+ end if
+ ntot=ntot+num(k); gpsmplty=gpsmplty+awork(6*nsig+k+100,i_gps)
+ gpsqcplty=gpsqcplty+awork(3*nsig+k+100,i_gps)
+ write(iout_gps,240)'gps',num(k),k,awork(6*nsig+k+100,i_gps), &
+ awork(3*nsig+k+100,i_gps),rat,rat3
+ end do
+ numgross=nint(awork(4,i_gps))
+ numfailqc=nint(awork(21,i_gps))
+ numfail1_gps=nint(awork(22,i_gps))
+ numfail2_gps=nint(awork(23,i_gps))
+ numfail3_gps=nint(awork(24,i_gps))
+ write(iout_gps,925)'gps',numgross,numfailqc
+ write(iout_gps,920)' number of gps obs failed stats qc in NH =',numfail1_gps
+ write(iout_gps,920)' number of gps obs failed stats qc in SH =',numfail2_gps
+ write(iout_gps,920)' number of gps obs failed stats qc in TR =',numfail3_gps
+
+ numlow = nint(awork(2,i_gps))
+ numhgh = nint(awork(3,i_gps))
+ write(iout_gps,900) 'gps',numhgh,numlow
+ if(ntot > 0) then
+ tgps=gpsmplty/ntot
+ qctgps=gpsqcplty/ntot
+ endif
+ end if
+ write(iout_gps,950) ctype,jiter,nread,nkeep,ntot
+ write(iout_gps,951) ctype,gpsmplty,gpsqcplty,tgps,qctgps
-! Summary report for specific humidity
- if(mype==mype_q) then
- if(first)then
- open(iout_q)
- else
- open(iout_q,position='append')
+ close(iout_gps)
end if
+ endif
- mesage='current fit of q data, units in per-cent of guess q-sat$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'q'
- end do
- call dtast(bwork,npres_print,pbotq,ptopq,mesage,jiter,iout_q,pflag)
- qmplty=zero; qqcplty=zero ; ntot=0
- tq=zero ; qctq=zero
+! Summary report for specific humidity
+ if(mype==mype_q) then
nread=0
nkeep=0
do i=1,ndat
@@ -339,53 +331,61 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- do k=1,nsig
- num(k)=nint(awork(k+6*nsig+100,i_q))
- rat=zero
- rat3=zero
- if(num(k) > 0)then
- rat=awork(5*nsig+k+100,i_q)/float(num(k))
- rat3=awork(3*nsig+k+100,i_q)/float(num(k))
- end if
- qmplty=qmplty+awork(5*nsig+k+100,i_q)
- qqcplty=qqcplty+awork(3*nsig+k+100,i_q)
- ntot=ntot+num(k)
- write(iout_q,240) 'q',num(k),k,awork(5*nsig+k+100,i_q), &
- awork(3*nsig+k+100,i_q),rat,rat3
+ if(nread > 0)then
+ if(first)then
+ open(iout_q)
+ else
+ open(iout_q,position='append')
+ end if
+
+ mesage='current fit of q data, units in per-cent of guess q-sat$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'q'
end do
- grsmlt=five
- numgrsq=nint(awork(4,i_q))
- numfailqc=nint(awork(21,i_q))
- write(iout_q,924)' (scaled as precent of guess specific humidity)'
- write(iout_q,925) 'q',numgrsq,numfailqc
- write(iout_q,975) grsmlt,'q',awork(5,i_q)
- numlow = nint(awork(2,i_q))
- numhgh = nint(awork(3,i_q))
- write(iout_q,900) 'q',numhgh,numlow
- if(ntot > 0) then
- tq=qmplty/float(ntot)
- qctq=qqcplty/float(ntot)
+ call dtast(bwork,npres_print,pbotq,ptopq,mesage,jiter,iout_q,pflag)
+
+ qmplty=zero; qqcplty=zero ; ntot=0
+ tq=zero ; qctq=zero
+ if(nkeep > 0)then
+ do k=1,nsig
+ num(k)=nint(awork(k+6*nsig+100,i_q))
+ rat=zero
+ rat3=zero
+ if(num(k) > 0)then
+ rat=awork(5*nsig+k+100,i_q)/real(num(k),r_kind)
+ rat3=awork(3*nsig+k+100,i_q)/real(num(k),r_kind)
+ end if
+ qmplty=qmplty+awork(5*nsig+k+100,i_q)
+ qqcplty=qqcplty+awork(3*nsig+k+100,i_q)
+ ntot=ntot+num(k)
+ write(iout_q,240) 'q',num(k),k,awork(5*nsig+k+100,i_q), &
+ awork(3*nsig+k+100,i_q),rat,rat3
+ end do
+ grsmlt=five
+ numgrsq=nint(awork(4,i_q))
+ numfailqc=nint(awork(21,i_q))
+ write(iout_q,924)' (scaled as precent of guess specific humidity)'
+ write(iout_q,925) 'q',numgrsq,numfailqc
+ write(iout_q,975) grsmlt,'q',awork(5,i_q)
+ numlow = nint(awork(2,i_q))
+ numhgh = nint(awork(3,i_q))
+ write(iout_q,900) 'q',numhgh,numlow
+ if(ntot > 0) then
+ tq=qmplty/real(ntot,r_kind)
+ qctq=qqcplty/real(ntot,r_kind)
+ end if
end if
- end if
- write(iout_q,950) 'q',jiter,nread,nkeep,ntot
- write(iout_q,951) 'q',qmplty,qqcplty,tq,qctq
+ write(iout_q,950) 'q',jiter,nread,nkeep,ntot
+ write(iout_q,951) 'q',qmplty,qqcplty,tq,qctq
- close(iout_q)
+ close(iout_q)
+ end if
end if
! Summary report for surface pressure
if(mype==mype_ps) then
- if(first)then
- open(iout_ps)
- else
- open(iout_ps,position='append')
- end if
-
- nump=nint(awork(5,i_ps))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -394,40 +394,42 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of surface pressure data, ranges in mb$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'ps'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_ps,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_ps)
+ else
+ open(iout_ps,position='append')
+ end if
+
+ nump=nint(awork(5,i_ps))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of surface pressure data, ranges in mb$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'ps'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_ps,pflag)
- numgross=nint(awork(6,i_ps))
- numfailqc=nint(awork(21,i_ps))
- write(iout_ps,925) 'psfc',numgross,numfailqc
- if(nump > 0)then
- pw=awork(4,i_ps)/float(nump)
- pw3=awork(22,i_ps)/float(nump)
+ numgross=nint(awork(6,i_ps))
+ numfailqc=nint(awork(21,i_ps))
+ write(iout_ps,925) 'psfc',numgross,numfailqc
+ if(nump > 0)then
+ pw=awork(4,i_ps)/real(nump,r_kind)
+ pw3=awork(22,i_ps)/real(nump,r_kind)
+ end if
end if
- end if
- write(iout_ps,950) 'psfc',jiter,nread,nkeep,nump
- write(iout_ps,951) 'psfc',awork(4,i_ps),awork(22,i_ps),pw,pw3
+ write(iout_ps,950) 'psfc',jiter,nread,nkeep,nump
+ write(iout_ps,951) 'psfc',awork(4,i_ps),awork(22,i_ps),pw,pw3
- close(iout_ps)
+ close(iout_ps)
+ end if
end if
! Summary report for total precipitable water
if(mype==mype_pw) then
- if(first)then
- open(iout_pw)
- else
- open(iout_pw,position='append')
- end if
- nsuperp=nint(awork(4,i_pw))
-
- tpw=zero ; tpw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -436,41 +438,42 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of precip. water data, ranges in mm$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'pw'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pw,pflag)
-
- numgrspw=nint(awork(6,i_pw))
- numfailqc=nint(awork(21,i_pw))
- grsmlt=three
- tpw=zero
- tpw3=zero
- if(nsuperp > 0)then
- tpw=awork(5,i_pw)/nsuperp
- tpw3=awork(22,i_pw)/nsuperp
- end if
- write(iout_pw,925) 'p.w.',numgrspw,numfailqc
- write(iout_pw,975) grsmlt,'p.w.',awork(7,i_pw)
- end if
- write(iout_pw,950) 'pw',jiter,nread,nkeep,nsuperp
- write(iout_pw,951) 'pw',awork(5,i_pw),awork(22,i_pw),tpw,tpw3
+ if(nread > 0)then
+ if(first)then
+ open(iout_pw)
+ else
+ open(iout_pw,position='append')
+ end if
+ tpw=zero ; tpw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of precip. water data, ranges in mm$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'pw'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pw,pflag)
+
+ numgrspw=nint(awork(6,i_pw))
+ numfailqc=nint(awork(21,i_pw))
+ grsmlt=three
+ tpw=zero
+ tpw3=zero
+ nsuperp=nint(awork(4,i_pw))
+ if(nsuperp > 0)then
+ tpw=awork(5,i_pw)/nsuperp
+ tpw3=awork(22,i_pw)/nsuperp
+ end if
+ write(iout_pw,925) 'p.w.',numgrspw,numfailqc
+ write(iout_pw,975) grsmlt,'p.w.',awork(7,i_pw)
+ end if
+ write(iout_pw,950) 'pw',jiter,nread,nkeep,nsuperp
+ write(iout_pw,951) 'pw',awork(5,i_pw),awork(22,i_pw),tpw,tpw3
- close(iout_pw)
+ close(iout_pw)
+ end if
end if
! Summary report for conventional sst
if(mype==mype_sst) then
- if(first)then
- open(iout_sst)
- else
- open(iout_sst,position='append')
- end if
-
- numsst=nint(awork(5,i_sst))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -479,37 +482,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional sst data, ranges in C$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'sst'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_sst,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_sst)
+ else
+ open(iout_sst,position='append')
+ end if
- numgross=nint(awork(6,i_sst))
- numfailqc=nint(awork(21,i_sst))
- if(numsst > 0)then
- pw=awork(4,i_sst)/numsst
- pw3=awork(22,i_sst)/numsst
+ numsst=nint(awork(5,i_sst))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional sst data, ranges in C$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'sst'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_sst,pflag)
+
+ numgross=nint(awork(6,i_sst))
+ numfailqc=nint(awork(21,i_sst))
+ if(numsst > 0)then
+ pw=awork(4,i_sst)/numsst
+ pw3=awork(22,i_sst)/numsst
+ end if
+ write(iout_sst,925) 'sst',numgross,numfailqc
end if
- write(iout_sst,925) 'sst',numgross,numfailqc
- end if
- write(iout_sst,950) 'sst',jiter,nread,nkeep,numsst
- write(iout_sst,951) 'sst',awork(4,i_sst),awork(22,i_sst),pw,pw3
+ write(iout_sst,950) 'sst',jiter,nread,nkeep,numsst
+ write(iout_sst,951) 'sst',awork(4,i_sst),awork(22,i_sst),pw,pw3
- close(iout_sst)
+ close(iout_sst)
+ end if
end if
! Summary report for conventional gust
if(mype==mype_gust) then
- if(first)then
- open(iout_gust)
- else
- open(iout_gust,position='append')
- end if
-
- numgust=nint(awork(5,i_gust))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -518,37 +523,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional gust data, ranges in m/s$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'gust'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_gust,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_gust)
+ else
+ open(iout_gust,position='append')
+ end if
- numgross=nint(awork(6,i_gust))
- numfailqc=nint(awork(21,i_gust))
- if(numgust > 0)then
- pw=awork(4,i_gust)/numgust
- pw3=awork(22,i_gust)/numgust
+ numgust=nint(awork(5,i_gust))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional gust data, ranges in m/s$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'gust'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_gust,pflag)
+
+ numgross=nint(awork(6,i_gust))
+ numfailqc=nint(awork(21,i_gust))
+ if(numgust > 0)then
+ pw=awork(4,i_gust)/numgust
+ pw3=awork(22,i_gust)/numgust
+ end if
+ write(iout_gust,925) 'gust',numgross,numfailqc
end if
- write(iout_gust,925) 'gust',numgross,numfailqc
- end if
- write(iout_gust,950) 'gust',jiter,nread,nkeep,numgust
- write(iout_gust,951) 'gust',awork(4,i_gust),awork(22,i_gust),pw,pw3
+ write(iout_gust,950) 'gust',jiter,nread,nkeep,numgust
+ write(iout_gust,951) 'gust',awork(4,i_gust),awork(22,i_gust),pw,pw3
- close(iout_gust)
+ close(iout_gust)
+ end if
end if
! Summary report for conventional vis
if(mype==mype_vis) then
- if(first)then
- open(iout_vis)
- else
- open(iout_vis,position='append')
- end if
-
- numvis=nint(awork(5,i_vis))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -557,37 +564,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional vis data, ranges in m$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'vis'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vis,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_vis)
+ else
+ open(iout_vis,position='append')
+ end if
- numgross=nint(awork(6,i_vis))
- numfailqc=nint(awork(21,i_vis))
- if(numvis > 0)then
- pw=awork(4,i_vis)/numvis
- pw3=awork(22,i_vis)/numvis
+ numvis=nint(awork(5,i_vis))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional vis data, ranges in m$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'vis'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vis,pflag)
+
+ numgross=nint(awork(6,i_vis))
+ numfailqc=nint(awork(21,i_vis))
+ if(numvis > 0)then
+ pw=awork(4,i_vis)/numvis
+ pw3=awork(22,i_vis)/numvis
+ end if
+ write(iout_vis,925) 'vis',numgross,numfailqc
end if
- write(iout_vis,925) 'vis',numgross,numfailqc
- end if
- write(iout_vis,950) 'vis',jiter,nread,nkeep,numvis
- write(iout_vis,951) 'vis',awork(4,i_vis),awork(22,i_vis),pw,pw3
+ write(iout_vis,950) 'vis',jiter,nread,nkeep,numvis
+ write(iout_vis,951) 'vis',awork(4,i_vis),awork(22,i_vis),pw,pw3
- close(iout_vis)
+ close(iout_vis)
+ end if
end if
! Summary report for conventional pblh
if(mype==mype_pblh) then
- if(first)then
- open(iout_pblh)
- else
- open(iout_pblh,position='append')
- end if
-
- numpblh=nint(awork(5,i_pblh))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -596,37 +605,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional pblh data, ranges in m$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'pblh'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pblh,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_pblh)
+ else
+ open(iout_pblh,position='append')
+ end if
- numgross=nint(awork(6,i_pblh))
- numfailqc=nint(awork(21,i_pblh))
- if(numpblh > 0)then
- pw=awork(4,i_pblh)/numpblh
- pw3=awork(22,i_pblh)/numpblh
+ numpblh=nint(awork(5,i_pblh))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional pblh data, ranges in m$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'pblh'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pblh,pflag)
+
+ numgross=nint(awork(6,i_pblh))
+ numfailqc=nint(awork(21,i_pblh))
+ if(numpblh > 0)then
+ pw=awork(4,i_pblh)/numpblh
+ pw3=awork(22,i_pblh)/numpblh
+ end if
+ write(iout_pblh,925) 'pblh',numgross,numfailqc
end if
- write(iout_pblh,925) 'pblh',numgross,numfailqc
- end if
- write(iout_pblh,950) 'pblh',jiter,nread,nkeep,numpblh
- write(iout_pblh,951) 'pblh',awork(4,i_pblh),awork(22,i_pblh),pw,pw3
+ write(iout_pblh,950) 'pblh',jiter,nread,nkeep,numpblh
+ write(iout_pblh,951) 'pblh',awork(4,i_pblh),awork(22,i_pblh),pw,pw3
- close(iout_pblh)
+ close(iout_pblh)
+ end if
end if
! Summary report for conventional wspd10m
if(mype==mype_wspd10m) then
- if(first)then
- open(iout_wspd10m)
- else
- open(iout_wspd10m,position='append')
- end if
-
- numwspd10m=nint(awork(5,i_wspd10m))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -635,37 +646,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional wspd10m data, ranges in m/s$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'wspd10m'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_wspd10m,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_wspd10m)
+ else
+ open(iout_wspd10m,position='append')
+ end if
- numgross=nint(awork(6,i_wspd10m))
- numfailqc=nint(awork(21,i_wspd10m))
- if(numwspd10m > 0)then
- pw=awork(4,i_wspd10m)/numwspd10m
- pw3=awork(22,i_wspd10m)/numwspd10m
+ numwspd10m=nint(awork(5,i_wspd10m))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional wspd10m data, ranges in m/s$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'wspd10m'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_wspd10m,pflag)
+
+ numgross=nint(awork(6,i_wspd10m))
+ numfailqc=nint(awork(21,i_wspd10m))
+ if(numwspd10m > 0)then
+ pw=awork(4,i_wspd10m)/numwspd10m
+ pw3=awork(22,i_wspd10m)/numwspd10m
+ end if
+ write(iout_wspd10m,925) 'wspd10m',numgross,numfailqc
end if
- write(iout_wspd10m,925) 'wspd10m',numgross,numfailqc
- end if
- write(iout_wspd10m,950) 'wspd10m',jiter,nread,nkeep,numwspd10m
- write(iout_wspd10m,951) 'wspd10m',awork(4,i_wspd10m),awork(22,i_wspd10m),pw,pw3
+ write(iout_wspd10m,950) 'wspd10m',jiter,nread,nkeep,numwspd10m
+ write(iout_wspd10m,951) 'wspd10m',awork(4,i_wspd10m),awork(22,i_wspd10m),pw,pw3
- close(iout_wspd10m)
+ close(iout_wspd10m)
+ end if
end if
! Summary report for conventional td2m
if(mype==mype_td2m) then
- if(first)then
- open(iout_td2m)
- else
- open(iout_td2m,position='append')
- end if
-
- numtd2m=nint(awork(5,i_td2m))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -674,37 +687,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional td2m data, ranges in K $'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'td2m'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_td2m,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_td2m)
+ else
+ open(iout_td2m,position='append')
+ end if
- numgross=nint(awork(6,i_td2m))
- numfailqc=nint(awork(21,i_td2m))
- if(numtd2m > 0)then
- pw=awork(4,i_td2m)/numtd2m
- pw3=awork(22,i_td2m)/numtd2m
+ numtd2m=nint(awork(5,i_td2m))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional td2m data, ranges in K $'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'td2m'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_td2m,pflag)
+
+ numgross=nint(awork(6,i_td2m))
+ numfailqc=nint(awork(21,i_td2m))
+ if(numtd2m > 0)then
+ pw=awork(4,i_td2m)/numtd2m
+ pw3=awork(22,i_td2m)/numtd2m
+ end if
+ write(iout_td2m,925) 'td2m',numgross,numfailqc
end if
- write(iout_td2m,925) 'td2m',numgross,numfailqc
- end if
- write(iout_td2m,950) 'td2m',jiter,nread,nkeep,numtd2m
- write(iout_td2m,951) 'td2m',awork(4,i_td2m),awork(22,i_td2m),pw,pw3
+ write(iout_td2m,950) 'td2m',jiter,nread,nkeep,numtd2m
+ write(iout_td2m,951) 'td2m',awork(4,i_td2m),awork(22,i_td2m),pw,pw3
- close(iout_td2m)
+ close(iout_td2m)
+ end if
end if
! Summary report for conventional mxtm
if(mype==mype_mxtm) then
- if(first)then
- open(iout_mxtm)
- else
- open(iout_mxtm,position='append')
- end if
-
- nummxtm=nint(awork(5,i_mxtm))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -713,37 +728,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional mxtm data, ranges in K $'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'mxtm'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mxtm,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_mxtm)
+ else
+ open(iout_mxtm,position='append')
+ end if
- numgross=nint(awork(6,i_mxtm))
- numfailqc=nint(awork(21,i_mxtm))
- if(nummxtm > 0)then
- pw=awork(4,i_mxtm)/nummxtm
- pw3=awork(22,i_mxtm)/nummxtm
+ nummxtm=nint(awork(5,i_mxtm))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional mxtm data, ranges in K $'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'mxtm'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mxtm,pflag)
+
+ numgross=nint(awork(6,i_mxtm))
+ numfailqc=nint(awork(21,i_mxtm))
+ if(nummxtm > 0)then
+ pw=awork(4,i_mxtm)/nummxtm
+ pw3=awork(22,i_mxtm)/nummxtm
+ end if
+ write(iout_mxtm,925) 'mxtm',numgross,numfailqc
end if
- write(iout_mxtm,925) 'mxtm',numgross,numfailqc
- end if
- write(iout_mxtm,950) 'mxtm',jiter,nread,nkeep,nummxtm
- write(iout_mxtm,951) 'mxtm',awork(4,i_mxtm),awork(22,i_mxtm),pw,pw3
+ write(iout_mxtm,950) 'mxtm',jiter,nread,nkeep,nummxtm
+ write(iout_mxtm,951) 'mxtm',awork(4,i_mxtm),awork(22,i_mxtm),pw,pw3
- close(iout_mxtm)
+ close(iout_mxtm)
+ end if
end if
! Summary report for conventional mitm
if(mype==mype_mitm) then
- if(first)then
- open(iout_mitm)
- else
- open(iout_mitm,position='append')
- end if
-
- nummitm=nint(awork(5,i_mitm))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -752,37 +769,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional mitm data, ranges in K $'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'mitm'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mitm,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_mitm)
+ else
+ open(iout_mitm,position='append')
+ end if
- numgross=nint(awork(6,i_mitm))
- numfailqc=nint(awork(21,i_mitm))
- if(nummitm > 0)then
- pw=awork(4,i_mitm)/nummitm
- pw3=awork(22,i_mitm)/nummitm
+ nummitm=nint(awork(5,i_mitm))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional mitm data, ranges in K $'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'mitm'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mitm,pflag)
+
+ numgross=nint(awork(6,i_mitm))
+ numfailqc=nint(awork(21,i_mitm))
+ if(nummitm > 0)then
+ pw=awork(4,i_mitm)/nummitm
+ pw3=awork(22,i_mitm)/nummitm
+ end if
+ write(iout_mitm,925) 'mitm',numgross,numfailqc
end if
- write(iout_mitm,925) 'mitm',numgross,numfailqc
- end if
- write(iout_mitm,950) 'mitm',jiter,nread,nkeep,nummitm
- write(iout_mitm,951) 'mitm',awork(4,i_mitm),awork(22,i_mitm),pw,pw3
+ write(iout_mitm,950) 'mitm',jiter,nread,nkeep,nummitm
+ write(iout_mitm,951) 'mitm',awork(4,i_mitm),awork(22,i_mitm),pw,pw3
- close(iout_mitm)
+ close(iout_mitm)
+ end if
end if
! Summary report for conventional pmsl
if(mype==mype_pmsl) then
- if(first)then
- open(iout_pmsl)
- else
- open(iout_pmsl,position='append')
- end if
-
- numpmsl=nint(awork(5,i_pmsl))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -791,37 +810,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional pmsl data, ranges in hPa $'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'pmsl'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pmsl,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_pmsl)
+ else
+ open(iout_pmsl,position='append')
+ end if
- numgross=nint(awork(6,i_pmsl))
- numfailqc=nint(awork(21,i_pmsl))
- if(numpmsl > 0)then
- pw=awork(4,i_pmsl)/numpmsl
- pw3=awork(22,i_pmsl)/numpmsl
+ numpmsl=nint(awork(5,i_pmsl))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional pmsl data, ranges in hPa $'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'pmsl'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pmsl,pflag)
+
+ numgross=nint(awork(6,i_pmsl))
+ numfailqc=nint(awork(21,i_pmsl))
+ if(numpmsl > 0)then
+ pw=awork(4,i_pmsl)/numpmsl
+ pw3=awork(22,i_pmsl)/numpmsl
+ end if
+ write(iout_pmsl,925) 'pmsl',numgross,numfailqc
end if
- write(iout_pmsl,925) 'pmsl',numgross,numfailqc
- end if
- write(iout_pmsl,950) 'pmsl',jiter,nread,nkeep,numpmsl
- write(iout_pmsl,951) 'pmsl',awork(4,i_pmsl),awork(22,i_pmsl),pw,pw3
+ write(iout_pmsl,950) 'pmsl',jiter,nread,nkeep,numpmsl
+ write(iout_pmsl,951) 'pmsl',awork(4,i_pmsl),awork(22,i_pmsl),pw,pw3
- close(iout_pmsl)
+ close(iout_pmsl)
+ end if
end if
! Summary report for conventional howv
if(mype==mype_howv) then
- if(first)then
- open(iout_howv)
- else
- open(iout_howv,position='append')
- end if
-
- numhowv=nint(awork(5,i_howv))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -830,37 +851,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional howv data, ranges in m $'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'howv'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_howv,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_howv)
+ else
+ open(iout_howv,position='append')
+ end if
- numgross=nint(awork(6,i_howv))
- numfailqc=nint(awork(21,i_howv))
- if(numhowv > 0)then
- pw=awork(4,i_howv)/numhowv
- pw3=awork(22,i_howv)/numhowv
+ numhowv=nint(awork(5,i_howv))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional howv data, ranges in m $'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'howv'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_howv,pflag)
+
+ numgross=nint(awork(6,i_howv))
+ numfailqc=nint(awork(21,i_howv))
+ if(numhowv > 0)then
+ pw=awork(4,i_howv)/numhowv
+ pw3=awork(22,i_howv)/numhowv
+ end if
+ write(iout_howv,925) 'howv',numgross,numfailqc
end if
- write(iout_howv,925) 'howv',numgross,numfailqc
- end if
- write(iout_howv,950) 'howv',jiter,nread,nkeep,numhowv
- write(iout_howv,951) 'howv',awork(4,i_howv),awork(22,i_howv),pw,pw3
+ write(iout_howv,950) 'howv',jiter,nread,nkeep,numhowv
+ write(iout_howv,951) 'howv',awork(4,i_howv),awork(22,i_howv),pw,pw3
- close(iout_howv)
+ close(iout_howv)
+ end if
end if
! Summary report for tcamt
if(mype==mype_tcamt) then
- if(first)then
- open(iout_tcamt)
- else
- open(iout_tcamt,position='append')
- end if
-
- numtcamt=nint(awork(5,i_tcamt))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -869,37 +892,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional tcamt data, ranges in %$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'tcamt'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcamt,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_tcamt)
+ else
+ open(iout_tcamt,position='append')
+ end if
- numgross=nint(awork(6,i_tcamt))
- numfailqc=nint(awork(21,i_tcamt))
- if(numtcamt > 0)then
- pw=awork(4,i_tcamt)/numtcamt
- pw3=awork(22,i_tcamt)/numtcamt
+ numtcamt=nint(awork(5,i_tcamt))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional tcamt data, ranges in %$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'tcamt'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcamt,pflag)
+
+ numgross=nint(awork(6,i_tcamt))
+ numfailqc=nint(awork(21,i_tcamt))
+ if(numtcamt > 0)then
+ pw=awork(4,i_tcamt)/numtcamt
+ pw3=awork(22,i_tcamt)/numtcamt
+ end if
+ write(iout_tcamt,925) 'tcamt',numgross,numfailqc
end if
- write(iout_tcamt,925) 'tcamt',numgross,numfailqc
- end if
- write(iout_tcamt,950) 'tcamt',jiter,nread,nkeep,numtcamt
- write(iout_tcamt,951) 'tcamt',awork(4,i_tcamt),awork(22,i_tcamt),pw,pw3
+ write(iout_tcamt,950) 'tcamt',jiter,nread,nkeep,numtcamt
+ write(iout_tcamt,951) 'tcamt',awork(4,i_tcamt),awork(22,i_tcamt),pw,pw3
- close(iout_tcamt)
+ close(iout_tcamt)
+ end if
end if
! Summary report for lcbas
if(mype==mype_lcbas) then
- if(first)then
- open(iout_lcbas)
- else
- open(iout_lcbas,position='append')
- end if
-
- numlcbas=nint(awork(5,i_lcbas))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -908,37 +933,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional lcbas data, ranges in m$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'lcbas'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lcbas,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_lcbas)
+ else
+ open(iout_lcbas,position='append')
+ end if
- numgross=nint(awork(6,i_lcbas))
- numfailqc=nint(awork(21,i_lcbas))
- if(numlcbas > 0)then
- pw=awork(4,i_lcbas)/numlcbas
- pw3=awork(22,i_lcbas)/numlcbas
+ numlcbas=nint(awork(5,i_lcbas))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional lcbas data, ranges in m$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'lcbas'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lcbas,pflag)
+
+ numgross=nint(awork(6,i_lcbas))
+ numfailqc=nint(awork(21,i_lcbas))
+ if(numlcbas > 0)then
+ pw=awork(4,i_lcbas)/numlcbas
+ pw3=awork(22,i_lcbas)/numlcbas
+ end if
+ write(iout_lcbas,925) 'lcbas',numgross,numfailqc
end if
- write(iout_lcbas,925) 'lcbas',numgross,numfailqc
- end if
- write(iout_lcbas,950) 'lcbas',jiter,nread,nkeep,numlcbas
- write(iout_lcbas,951) 'lcbas',awork(4,i_lcbas),awork(22,i_lcbas),pw,pw3
+ write(iout_lcbas,950) 'lcbas',jiter,nread,nkeep,numlcbas
+ write(iout_lcbas,951) 'lcbas',awork(4,i_lcbas),awork(22,i_lcbas),pw,pw3
- close(iout_lcbas)
+ close(iout_lcbas)
+ end if
end if
! Summary report for conventional cldch
if(mype==mype_cldch) then
- if(first)then
- open(iout_cldch)
- else
- open(iout_cldch,position='append')
- end if
-
- numcldch=nint(awork(5,i_cldch))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -947,37 +974,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional cldch data, ranges in m$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'cldch'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_cldch,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_cldch)
+ else
+ open(iout_cldch,position='append')
+ end if
- numgross=nint(awork(6,i_cldch))
- numfailqc=nint(awork(21,i_cldch))
- if(numcldch > 0)then
- pw=awork(4,i_cldch)/numcldch
- pw3=awork(22,i_cldch)/numcldch
+ numcldch=nint(awork(5,i_cldch))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional cldch data, ranges in m$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'cldch'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_cldch,pflag)
+
+ numgross=nint(awork(6,i_cldch))
+ numfailqc=nint(awork(21,i_cldch))
+ if(numcldch > 0)then
+ pw=awork(4,i_cldch)/numcldch
+ pw3=awork(22,i_cldch)/numcldch
+ end if
+ write(iout_cldch,925) 'cldch',numgross,numfailqc
end if
- write(iout_cldch,925) 'cldch',numgross,numfailqc
- end if
- write(iout_cldch,950) 'cldch',jiter,nread,nkeep,numcldch
- write(iout_cldch,951) 'cldch',awork(4,i_cldch),awork(22,i_cldch),pw,pw3
+ write(iout_cldch,950) 'cldch',jiter,nread,nkeep,numcldch
+ write(iout_cldch,951) 'cldch',awork(4,i_cldch),awork(22,i_cldch),pw,pw3
- close(iout_cldch)
+ close(iout_cldch)
+ end if
end if
! Summary report for conventional uwnd10m
if(mype==mype_uwnd10m) then
- if(first)then
- open(iout_uwnd10m)
- else
- open(iout_uwnd10m,position='append')
- end if
-
- numuwnd10m=nint(awork(5,i_uwnd10m))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -986,37 +1015,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional uwnd10m data, ranges in m/s$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'uwnd10m'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_uwnd10m,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_uwnd10m)
+ else
+ open(iout_uwnd10m,position='append')
+ end if
- numgross=nint(awork(6,i_uwnd10m))
- numfailqc=nint(awork(21,i_uwnd10m))
- if(numuwnd10m > 0)then
- pw=awork(4,i_uwnd10m)/numuwnd10m
- pw3=awork(22,i_uwnd10m)/numuwnd10m
+ numuwnd10m=nint(awork(5,i_uwnd10m))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional uwnd10m data, ranges in m/s$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'uwnd10m'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_uwnd10m,pflag)
+
+ numgross=nint(awork(6,i_uwnd10m))
+ numfailqc=nint(awork(21,i_uwnd10m))
+ if(numuwnd10m > 0)then
+ pw=awork(4,i_uwnd10m)/numuwnd10m
+ pw3=awork(22,i_uwnd10m)/numuwnd10m
+ end if
+ write(iout_uwnd10m,925) 'uwnd10m',numgross,numfailqc
end if
- write(iout_uwnd10m,925) 'uwnd10m',numgross,numfailqc
- end if
- write(iout_uwnd10m,950) 'uwnd10m',jiter,nread,nkeep,numuwnd10m
- write(iout_uwnd10m,951) 'uwnd10m',awork(4,i_uwnd10m),awork(22,i_uwnd10m),pw,pw3
+ write(iout_uwnd10m,950) 'uwnd10m',jiter,nread,nkeep,numuwnd10m
+ write(iout_uwnd10m,951) 'uwnd10m',awork(4,i_uwnd10m),awork(22,i_uwnd10m),pw,pw3
- close(iout_uwnd10m)
+ close(iout_uwnd10m)
+ end if
end if
! Summary report for conventional vwnd10m
if(mype==mype_vwnd10m) then
- if(first)then
- open(iout_vwnd10m)
- else
- open(iout_vwnd10m,position='append')
- end if
-
- numvwnd10m=nint(awork(5,i_vwnd10m))
- pw=zero ; pw3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -1025,37 +1056,39 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of conventional vwnd10m data, ranges in m/s$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'vwnd10m'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vwnd10m,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_vwnd10m)
+ else
+ open(iout_vwnd10m,position='append')
+ end if
- numgross=nint(awork(6,i_vwnd10m))
- numfailqc=nint(awork(21,i_vwnd10m))
- if(numvwnd10m > 0)then
- pw=awork(4,i_vwnd10m)/numvwnd10m
- pw3=awork(22,i_vwnd10m)/numvwnd10m
+ numvwnd10m=nint(awork(5,i_vwnd10m))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of conventional vwnd10m data, ranges in m/s$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'vwnd10m'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vwnd10m,pflag)
+
+ numgross=nint(awork(6,i_vwnd10m))
+ numfailqc=nint(awork(21,i_vwnd10m))
+ if(numvwnd10m > 0)then
+ pw=awork(4,i_vwnd10m)/numvwnd10m
+ pw3=awork(22,i_vwnd10m)/numvwnd10m
+ end if
+ write(iout_vwnd10m,925) 'vwnd10m',numgross,numfailqc
end if
- write(iout_vwnd10m,925) 'vwnd10m',numgross,numfailqc
- end if
- write(iout_vwnd10m,950) 'vwnd10m',jiter,nread,nkeep,numvwnd10m
- write(iout_vwnd10m,951) 'vwnd10m',awork(4,i_vwnd10m),awork(22,i_vwnd10m),pw,pw3
+ write(iout_vwnd10m,950) 'vwnd10m',jiter,nread,nkeep,numvwnd10m
+ write(iout_vwnd10m,951) 'vwnd10m',awork(4,i_vwnd10m),awork(22,i_vwnd10m),pw,pw3
- close(iout_vwnd10m)
+ close(iout_vwnd10m)
+ end if
end if
! Summary report for temperature
if (mype==mype_t)then
- if(first)then
- open(iout_t)
- else
- open(iout_t,position='append')
- end if
-
- tmplty=zero; tqcplty=zero ; ntot=0
- tt=zero ; qctt=zero
nread=0
nkeep=0
do i=1,ndat
@@ -1064,54 +1097,56 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of temperature data, ranges in K $'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 't'
- end do
- call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_t,pflag)
- do k=1,nsig
- num(k)=nint(awork(5*nsig+k+100,i_t))
- rat=zero ; rat3=zero
- if(num(k) > 0) then
- rat=awork(6*nsig+k+100,i_t)/float(num(k))
- rat3=awork(3*nsig+k+100,i_t)/float(num(k))
+ if(nread > 0)then
+ if(first)then
+ open(iout_t)
+ else
+ open(iout_t,position='append')
+ end if
+
+ tmplty=zero; tqcplty=zero ; ntot=0
+ tt=zero ; qctt=zero
+ if(nkeep > 0)then
+ mesage='current fit of temperature data, ranges in K $'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 't'
+ end do
+ call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_t,pflag)
+ do k=1,nsig
+ num(k)=nint(awork(5*nsig+k+100,i_t))
+ rat=zero ; rat3=zero
+ if(num(k) > 0) then
+ rat=awork(6*nsig+k+100,i_t)/real(num(k),r_kind)
+ rat3=awork(3*nsig+k+100,i_t)/real(num(k),r_kind)
+ end if
+ ntot=ntot+num(k); tmplty=tmplty+awork(6*nsig+k+100,i_t)
+ tqcplty=tqcplty+awork(3*nsig+k+100,i_t)
+ write(iout_t,240) 't',num(k),k,awork(6*nsig+k+100,i_t), &
+ awork(3*nsig+k+100,i_t),rat,rat3
+ end do
+ numgross=nint(awork(4,i_t))
+ numfailqc=nint(awork(21,i_t))
+ write(iout_t,925) 'temp',numgross,numfailqc
+ numlow = nint(awork(2,i_t))
+ numhgh = nint(awork(3,i_t))
+ write(iout_t,900) 't',numhgh,numlow
+ if(ntot > 0) then
+ tt=tmplty/ntot
+ qctt=tqcplty/ntot
end if
- ntot=ntot+num(k); tmplty=tmplty+awork(6*nsig+k+100,i_t)
- tqcplty=tqcplty+awork(3*nsig+k+100,i_t)
- write(iout_t,240) 't',num(k),k,awork(6*nsig+k+100,i_t), &
- awork(3*nsig+k+100,i_t),rat,rat3
- end do
- numgross=nint(awork(4,i_t))
- numfailqc=nint(awork(21,i_t))
- write(iout_t,925) 'temp',numgross,numfailqc
- numlow = nint(awork(2,i_t))
- numhgh = nint(awork(3,i_t))
- write(iout_t,900) 't',numhgh,numlow
- if(ntot > 0) then
- tt=tmplty/ntot
- qctt=tqcplty/ntot
end if
- end if
- write(iout_t,950) 't',jiter,nread,nkeep,ntot
- write(iout_t,951) 't',tmplty,tqcplty,tt,qctt
+ write(iout_t,950) 't',jiter,nread,nkeep,ntot
+ write(iout_t,951) 't',tmplty,tqcplty,tt,qctt
- close(iout_t)
+ close(iout_t)
+ end if
endif
! Summary report for doppler lidar winds
if(mype==mype_dw) then
- if(first)then
- open(iout_dw)
- else
- open(iout_dw,position='append')
- end if
-
- dwmplty=zero; dwqcplty=zero ; ntot=0
- tdw=zero ; qctdw=zero
nread=0
nkeep=0
do i=1,ndat
@@ -1120,56 +1155,58 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current vfit of lidar wind data, ranges in m/s$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'dw'
- end do
- call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dw,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_dw)
+ else
+ open(iout_dw,position='append')
+ end if
+
+ dwmplty=zero; dwqcplty=zero ; ntot=0
+ tdw=zero ; qctdw=zero
+ if(nkeep > 0)then
+ mesage='current vfit of lidar wind data, ranges in m/s$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'dw'
+ end do
+ call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dw,pflag)
- do k=1,nsig
- num(k)=nint(awork(k+5*nsig+100,i_dw))
- rat=zero
- rat3=zero
- if(num(k) > 0) then
- rat=awork(6*nsig+k+100,i_dw)/float(num(k))
- rat3=awork(3*nsig+k+100,i_dw)/float(num(k))
+ do k=1,nsig
+ num(k)=nint(awork(k+5*nsig+100,i_dw))
+ rat=zero
+ rat3=zero
+ if(num(k) > 0) then
+ rat=awork(6*nsig+k+100,i_dw)/real(num(k),r_kind)
+ rat3=awork(3*nsig+k+100,i_dw)/real(num(k),r_kind)
+ end if
+ ntot=ntot+num(k)
+ dwmplty=dwmplty+awork(6*nsig+k+100,i_dw)
+ dwqcplty=dwqcplty+awork(3*nsig+k+100,i_dw)
+ write(iout_dw,240) 'r',num(k),k,awork(6*nsig+k+100,i_dw), &
+ awork(3*nsig+k+100,i_dw),rat,rat3
+ end do
+ numgross=nint(awork(4,i_dw))
+ numfailqc=nint(awork(21,i_dw))
+ if(ntot > 0) then
+ tdw=dwmplty/real(ntot,r_kind)
+ qctdw=dwqcplty/real(ntot,r_kind)
end if
- ntot=ntot+num(k)
- dwmplty=dwmplty+awork(6*nsig+k+100,i_dw)
- dwqcplty=dwqcplty+awork(3*nsig+k+100,i_dw)
- write(iout_dw,240) 'r',num(k),k,awork(6*nsig+k+100,i_dw), &
- awork(3*nsig+k+100,i_dw),rat,rat3
- end do
- numgross=nint(awork(4,i_dw))
- numfailqc=nint(awork(21,i_dw))
- if(ntot > 0) then
- tdw=dwmplty/float(ntot)
- qctdw=dwqcplty/float(ntot)
- end if
- write(iout_dw,925) 'dw',numgross,numfailqc
- numlow = nint(awork(2,i_dw))
- numhgh = nint(awork(3,i_dw))
- write(iout_dw,900) 'dw',numhgh,numlow
- end if
+ write(iout_dw,925) 'dw',numgross,numfailqc
+ numlow = nint(awork(2,i_dw))
+ numhgh = nint(awork(3,i_dw))
+ write(iout_dw,900) 'dw',numhgh,numlow
+ end if
- write(iout_dw,950) 'dw',jiter,nread,nkeep,ntot
- write(iout_dw,951) 'dw',dwmplty,dwqcplty,tdw,qctdw
+ write(iout_dw,950) 'dw',jiter,nread,nkeep,ntot
+ write(iout_dw,951) 'dw',dwmplty,dwqcplty,tdw,qctdw
- close(iout_dw)
+ close(iout_dw)
+ end if
end if
! Summary report for radar radial winds
if(mype==mype_rw) then
- if(first)then
- open(iout_rw)
- else
- open(iout_rw,position='append')
- end if
-
- rwmplty=zero; rwqcplty=zero ; ntot=0
- trw=zero ; qctrw=zero
nread=0
nkeep=0
do i=1,ndat
@@ -1178,57 +1215,59 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current vfit of radar wind data, ranges in m/s$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'rw'
- end do
- call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_rw,pflag)
+ if(nread > 0)then
+ if(first)then
+ open(iout_rw)
+ else
+ open(iout_rw,position='append')
+ end if
- numgross=nint(awork(4,i_rw))
- numfailqc=nint(awork(21,i_rw))
- do k=1,nsig
- num(k)=nint(awork(k+5*nsig+100,i_rw))
- rat=zero
- rat3=zero
- if(num(k) > 0) then
- rat=awork(6*nsig+k+100,i_rw)/float(num(k))
- rat3=awork(3*nsig+k+100,i_rw)/float(num(k))
+ rwmplty=zero; rwqcplty=zero ; ntot=0
+ trw=zero ; qctrw=zero
+ if(nkeep > 0)then
+ mesage='current vfit of radar wind data, ranges in m/s$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'rw'
+ end do
+ call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_rw,pflag)
+
+ numgross=nint(awork(4,i_rw))
+ numfailqc=nint(awork(21,i_rw))
+ do k=1,nsig
+ num(k)=nint(awork(k+5*nsig+100,i_rw))
+ rat=zero
+ rat3=zero
+ if(num(k) > 0) then
+ rat=awork(6*nsig+k+100,i_rw)/real(num(k),r_kind)
+ rat3=awork(3*nsig+k+100,i_rw)/real(num(k),r_kind)
+ end if
+ ntot=ntot+num(k)
+ rwmplty=rwmplty+awork(6*nsig+k+100,i_rw)
+ rwqcplty=rwqcplty+awork(3*nsig+k+100,i_rw)
+ write(iout_rw,240) 'r',num(k),k,awork(6*nsig+k+100,i_rw), &
+ awork(3*nsig+k+100,i_rw),rat,rat3
+ end do
+ if(ntot > 0) then
+ trw=rwmplty/real(ntot,r_kind)
+ qctrw=rwqcplty/real(ntot,r_kind)
end if
- ntot=ntot+num(k)
- rwmplty=rwmplty+awork(6*nsig+k+100,i_rw)
- rwqcplty=rwqcplty+awork(3*nsig+k+100,i_rw)
- write(iout_rw,240) 'r',num(k),k,awork(6*nsig+k+100,i_rw), &
- awork(3*nsig+k+100,i_rw),rat,rat3
- end do
- if(ntot > 0) then
- trw=rwmplty/float(ntot)
- qctrw=rwqcplty/float(ntot)
- end if
- write(iout_rw,925) 'rw',numgross,numfailqc
- numlow = nint(awork(2,i_rw))
- numhgh = nint(awork(3,i_rw))
- nhitopo = nint(awork(5,i_rw))
- ntoodif = nint(awork(6,i_rw))
- write(iout_rw,900) 'rw',numhgh,numlow
- write(iout_rw,905) 'rw',nhitopo,ntoodif
- end if
- write(iout_rw,950) 'rw',jiter,nread,nkeep,ntot
- write(iout_rw,951) 'rw',rwmplty,rwqcplty,trw,qctrw
+ write(iout_rw,925) 'rw',numgross,numfailqc
+ numlow = nint(awork(2,i_rw))
+ numhgh = nint(awork(3,i_rw))
+ nhitopo = nint(awork(5,i_rw))
+ ntoodif = nint(awork(6,i_rw))
+ write(iout_rw,900) 'rw',numhgh,numlow
+ write(iout_rw,905) 'rw',nhitopo,ntoodif
+ end if
+ write(iout_rw,950) 'rw',jiter,nread,nkeep,ntot
+ write(iout_rw,951) 'rw',rwmplty,rwqcplty,trw,qctrw
- close(iout_rw)
+ close(iout_rw)
+ end if
end if
! Summary report for radar reflectivity
if(mype==mype_dbz) then
- if(first)then
- open(iout_dbz)
- else
- open(iout_dbz,position='append')
- end if
-
- dbzmplty=zero; dbzqcplty=zero ; ntot=0
- tdbz=zero ; qctdbz=zero
nread=0
nkeep=0
do i=1,ndat
@@ -1237,56 +1276,120 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current vfit of radar reflectivity data, ranges in dBZ$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'dbz'
- end do
- call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dbz,pflag)
-
- numgross=nint(awork(4,i_dbz))
- numfailqc=nint(awork(21,i_dbz))
- do k=1,nsig
- num(k)=nint(awork(k+5*nsig+100,i_dbz))
- rat=zero
- rat3=zero
- if(num(k) > 0) then
- rat=awork(6*nsig+k+100,i_dbz)/float(num(k))
- rat3=awork(3*nsig+k+100,i_dbz)/float(num(k))
+ if(nread > 0)then
+ if(first)then
+ open(iout_dbz)
+ else
+ open(iout_dbz,position='append')
+ end if
+
+ dbzmplty=zero; dbzqcplty=zero ; ntot=0
+ tdbz=zero ; qctdbz=zero
+ if(nkeep > 0)then
+ mesage='current vfit of radar reflectivity data, ranges in dBZ$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'dbz'
+ end do
+ call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dbz,pflag)
+
+ numgross=nint(awork(4,i_dbz))
+ numfailqc=nint(awork(21,i_dbz))
+ do k=1,nsig
+ num(k)=nint(awork(k+5*nsig+100,i_dbz))
+ rat=zero
+ rat3=zero
+ if(num(k) > 0) then
+ rat=awork(6*nsig+k+100,i_dbz)/real(num(k),r_kind)
+ rat3=awork(3*nsig+k+100,i_dbz)/real(num(k),r_kind)
+ end if
+ ntot=ntot+num(k)
+ dbzmplty=dbzmplty+awork(6*nsig+k+100,i_dbz)
+ dbzqcplty=dbzqcplty+awork(3*nsig+k+100,i_dbz)
+ write(iout_dbz,240) 'r',num(k),k,awork(6*nsig+k+100,i_dbz), &
+ awork(3*nsig+k+100,i_dbz),rat,rat3
+ end do
+ if(ntot > 0) then
+ tdbz=dbzmplty/real(ntot,r_kind)
+ qctdbz=dbzqcplty/real(ntot,r_kind)
end if
- ntot=ntot+num(k)
- dbzmplty=dbzmplty+awork(6*nsig+k+100,i_dbz)
- dbzqcplty=dbzqcplty+awork(3*nsig+k+100,i_dbz)
- write(iout_dbz,240) 'r',num(k),k,awork(6*nsig+k+100,i_dbz), &
- awork(3*nsig+k+100,i_dbz),rat,rat3
- end do
- if(ntot > 0) then
- tdbz=dbzmplty/float(ntot)
- qctdbz=dbzqcplty/float(ntot)
- end if
- write(iout_dbz,925) 'dbz',numgross,numfailqc
- numlow = nint(awork(2,i_dbz))
- numhgh = nint(awork(3,i_dbz))
- nhitopo = nint(awork(5,i_dbz))
- ntoodif = nint(awork(6,i_dbz))
- write(iout_dbz,900) 'dbz',numhgh,numlow
- write(iout_dbz,905) 'dbz',nhitopo,ntoodif
- end if
- write(iout_dbz,950) 'dbz',jiter,nread,nkeep,ntot
- write(iout_dbz,951) 'dbz',dbzmplty,dbzqcplty,tdbz,qctdbz
+ write(iout_dbz,925) 'dbz',numgross,numfailqc
+ numlow = nint(awork(2,i_dbz))
+ numhgh = nint(awork(3,i_dbz))
+ nhitopo = nint(awork(5,i_dbz))
+ ntoodif = nint(awork(6,i_dbz))
+ write(iout_dbz,900) 'dbz',numhgh,numlow
+ write(iout_dbz,905) 'dbz',nhitopo,ntoodif
+ end if
+ write(iout_dbz,950) 'dbz',jiter,nread,nkeep,ntot
+ write(iout_dbz,951) 'dbz',dbzmplty,dbzqcplty,tdbz,qctdbz
- close(iout_dbz)
+ close(iout_dbz)
+ end if
end if
- if(mype==mype_tcp) then
- if(first)then
- open(iout_tcp)
- else
- open(iout_tcp,position='append')
+! Summary report for flash extent density
+ if(mype==mype_fed) then
+ nread=0
+ nkeep=0
+ do i=1,ndat
+ if(dtype(i)== 'fed')then
+ nread=nread+ndata(i,2)
+ nkeep=nkeep+ndata(i,3)
+ end if
+ end do
+ if(nread > 0)then
+ if(first)then
+ open(iout_fed)
+ else
+ open(iout_fed,position='append')
+ end if
+
+ fedmplty=zero; fedqcplty=zero ; ntot=0
+ tfed=zero ; qctfed=zero
+ if(nkeep > 0)then
+ mesage='current vfit of flash extent density, ranges in flashes per minute$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'fed'
+ end do
+ call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_fed,pflag)
+
+ numgross=nint(awork(4,i_fed))
+ numfailqc=nint(awork(21,i_fed))
+ do k=1,nsig
+ num(k)=nint(awork(k+5*nsig+100,i_fed))
+ rat=zero
+ rat3=zero
+ if(num(k) > 0) then
+ rat=awork(6*nsig+k+100,i_fed)/real(num(k),r_kind)
+ rat3=awork(3*nsig+k+100,i_fed)/real(num(k),r_kind)
+ end if
+ ntot=ntot+num(k)
+ fedmplty=fedmplty+awork(6*nsig+k+100,i_fed)
+ fedqcplty=fedqcplty+awork(3*nsig+k+100,i_fed)
+ write(iout_fed,240) 'r',num(k),k,awork(6*nsig+k+100,i_fed), &
+ awork(3*nsig+k+100,i_fed),rat,rat3
+ end do
+ if(ntot > 0) then
+ tfed=fedmplty/real(ntot,r_kind)
+ qctfed=fedqcplty/real(ntot,r_kind)
+ end if
+ write(iout_fed,925) 'fed',numgross,numfailqc
+ numlow = nint(awork(2,i_fed))
+ numhgh = nint(awork(3,i_fed))
+ nhitopo = nint(awork(5,i_fed))
+ ntoodif = nint(awork(6,i_fed))
+ write(iout_fed,900) 'fed',numhgh,numlow
+ write(iout_fed,905) 'fed',nhitopo,ntoodif
+ end if
+ write(iout_fed,950) 'fed',jiter,nread,nkeep,ntot
+ write(iout_fed,951) 'fed',fedmplty,fedqcplty,tfed,qctfed
+
+ close(iout_fed)
end if
+ end if
+
- nump=nint(awork(5,i_tcp))
- pw=zero ; pw3=zero
+ if(mype==mype_tcp) then
nread=0
nkeep=0
do i=1,ndat
@@ -1295,39 +1398,41 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of surface pressure data, ranges in mb$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'tcp'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcp,pflag)
-
- numgross=nint(awork(6,i_tcp))
- numfailqc=nint(awork(21,i_tcp))
- write(iout_tcp,925) 'psfc',numgross,numfailqc
+ if(nread > 0)then
+ if(first)then
+ open(iout_tcp)
+ else
+ open(iout_tcp,position='append')
+ end if
- if(nump > 0)then
- pw=awork(4,i_tcp)/float(nump)
- pw3=awork(22,i_tcp)/float(nump)
+ nump=nint(awork(5,i_tcp))
+ pw=zero ; pw3=zero
+ if(nkeep > 0)then
+ mesage='current fit of surface pressure data, ranges in mb$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'tcp'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcp,pflag)
+
+ numgross=nint(awork(6,i_tcp))
+ numfailqc=nint(awork(21,i_tcp))
+ write(iout_tcp,925) 'psfc',numgross,numfailqc
+
+ if(nump > 0)then
+ pw=awork(4,i_tcp)/real(nump,r_kind)
+ pw3=awork(22,i_tcp)/real(nump,r_kind)
+ end if
end if
- end if
- write(iout_tcp,950) 'psfc',jiter,nread,nkeep,nump
- write(iout_tcp,951) 'psfc',awork(4,i_tcp),awork(22,i_tcp),pw,pw3
+ write(iout_tcp,950) 'psfc',jiter,nread,nkeep,nump
+ write(iout_tcp,951) 'psfc',awork(4,i_tcp),awork(22,i_tcp),pw,pw3
- close(iout_tcp)
+ close(iout_tcp)
+ end if
end if
! Summary report for lagrangian
if (mype==mype_lag)then
- if(first)then
- open(iout_lag)
- else
- open(iout_lag,position='append')
- end if
-
- tmplty=zero; tqcplty=zero ; ntot=0
- tt=zero ; qctt=zero
nread=0
nkeep=0
do i=1,ndat
@@ -1336,53 +1441,54 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of lagangian data, ranges in m $'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'lag'
- end do
- call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_lag,pflag)
- do k=1,nsig
- num(k)=nint(awork(6*nsig+k+100,i_lag))
- rat=zero ; rat3=zero
- if(num(k) > 0) then
- rat=awork(4*nsig+k+100,i_lag)/float(num(k))
- rat3=awork(3*nsig+k+100,i_lag)/float(num(k))
+ if(nread > 0)then
+ if(first)then
+ open(iout_lag)
+ else
+ open(iout_lag,position='append')
+ end if
+
+ tmplty=zero; tqcplty=zero ; ntot=0
+ tt=zero ; qctt=zero
+ if(nkeep > 0)then
+ mesage='current fit of lagangian data, ranges in m $'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'lag'
+ end do
+ call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_lag,pflag)
+ do k=1,nsig
+ num(k)=nint(awork(6*nsig+k+100,i_lag))
+ rat=zero ; rat3=zero
+ if(num(k) > 0) then
+ rat=awork(4*nsig+k+100,i_lag)/real(num(k),r_kind)
+ rat3=awork(3*nsig+k+100,i_lag)/real(num(k),r_kind)
+ end if
+ ntot=ntot+num(k); tmplty=tmplty+awork(4*nsig+k+100,i_lag)
+ tqcplty=tqcplty+awork(3*nsig+k+100,i_lag)
+ write(iout_lag,240) 'lag',num(k),k,awork(4*nsig+k+100,i_lag), &
+ awork(3*nsig+k+100,i_lag),rat,rat3
+ end do
+ numgross=nint(awork(4,i_lag))
+ numfailqc=nint(awork(21,i_lag))
+ write(iout_lag,925) 'lag',numgross,numfailqc
+ ! numlow = nint(awork(2,i_t))
+ ! numhgh = nint(awork(3,i_t))
+ ! write(iout_lag,900) 't',numhgh,numlow
+ if(ntot > 0) then
+ tt=tmplty/ntot
+ qctt=tqcplty/ntot
end if
- ntot=ntot+num(k); tmplty=tmplty+awork(4*nsig+k+100,i_lag)
- tqcplty=tqcplty+awork(3*nsig+k+100,i_lag)
- write(iout_lag,240) 'lag',num(k),k,awork(4*nsig+k+100,i_lag), &
- awork(3*nsig+k+100,i_lag),rat,rat3
- end do
- numgross=nint(awork(4,i_lag))
- numfailqc=nint(awork(21,i_lag))
- write(iout_lag,925) 'lag',numgross,numfailqc
- ! numlow = nint(awork(2,i_t))
- ! numhgh = nint(awork(3,i_t))
- ! write(iout_lag,900) 't',numhgh,numlow
- if(ntot > 0) then
- tt=tmplty/ntot
- qctt=tqcplty/ntot
end if
- end if
- write(iout_lag,950) 'lag',jiter,nread,nkeep,ntot
- write(iout_lag,951) 'lag',tmplty,tqcplty,tt,qctt
+ write(iout_lag,950) 'lag',jiter,nread,nkeep,ntot
+ write(iout_lag,951) 'lag',tmplty,tqcplty,tt,qctt
- close(iout_lag)
+ close(iout_lag)
+ end if
endif
! Summary report for solid-water content path
if(mype==mype_swcp) then
- if(first)then
- open(iout_swcp)
- else
- open(iout_swcp,position='append')
- end if
-
- nsuperp=nint(awork(4,i_swcp))
-
- tswcp=zero ; tswcp3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -1391,42 +1497,44 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of solid-water content path, ranges in kg/m^2$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'swcp'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_swcp,pflag)
-
- numgrsswcp=nint(awork(6,i_swcp))
- numfailqc=nint(awork(21,i_swcp))
- grsmlt=three
- tswcp=zero
- tswcp3=zero
- if(nsuperp > 0)then
- tswcp=awork(5,i_swcp)/nsuperp
- tswcp3=awork(22,i_swcp)/nsuperp
- end if
- write(iout_swcp,925) 'swcp',numgrsswcp,numfailqc
- write(iout_swcp,975) grsmlt,'swcp',awork(7,i_swcp)
- end if
- write(iout_swcp,950) 'swcp',jiter,nread,nkeep,nsuperp
- write(iout_swcp,951) 'swcp',awork(5,i_swcp),awork(22,i_swcp),tswcp,tswcp3
+ if(nread > 0)then
+ if(first)then
+ open(iout_swcp)
+ else
+ open(iout_swcp,position='append')
+ end if
+
+ nsuperp=nint(awork(4,i_swcp))
+
+ tswcp=zero ; tswcp3=zero
+ if(nkeep > 0)then
+ mesage='current fit of solid-water content path, ranges in kg/m^2$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'swcp'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_swcp,pflag)
+
+ numgrsswcp=nint(awork(6,i_swcp))
+ numfailqc=nint(awork(21,i_swcp))
+ grsmlt=three
+ tswcp=zero
+ tswcp3=zero
+ if(nsuperp > 0)then
+ tswcp=awork(5,i_swcp)/nsuperp
+ tswcp3=awork(22,i_swcp)/nsuperp
+ end if
+ write(iout_swcp,925) 'swcp',numgrsswcp,numfailqc
+ write(iout_swcp,975) grsmlt,'swcp',awork(7,i_swcp)
+ end if
+ write(iout_swcp,950) 'swcp',jiter,nread,nkeep,nsuperp
+ write(iout_swcp,951) 'swcp',awork(5,i_swcp),awork(22,i_swcp),tswcp,tswcp3
- close(iout_swcp)
+ close(iout_swcp)
+ end if
end if
! Summary report for liquid-water content path
if(mype==mype_lwcp) then
- if(first)then
- open(iout_lwcp)
- else
- open(iout_lwcp,position='append')
- end if
-
- nsuperp=nint(awork(4,i_lwcp))
-
- tlwcp=zero ; tlwcp3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -1435,29 +1543,40 @@ subroutine statsconv(mype,&
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of liquid-water content path, ranges in kg/m^2$'
- do j=1,nconvtype
- pflag(j)=trim(ioctype(j)) == 'lwcp'
- end do
- call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lwcp,pflag)
-
- numgrslwcp=nint(awork(6,i_lwcp))
- numfailqc=nint(awork(21,i_lwcp))
- grsmlt=three
- tlwcp=zero
- tlwcp3=zero
- if(nsuperp > 0)then
- tlwcp=awork(5,i_lwcp)/nsuperp
- tlwcp3=awork(22,i_lwcp)/nsuperp
- end if
- write(iout_lwcp,925) 'lwcp',numgrslwcp,numfailqc
- write(iout_lwcp,975) grsmlt,'lwcp',awork(7,i_lwcp)
- end if
- write(iout_lwcp,950) 'lwcp',jiter,nread,nkeep,nsuperp
- write(iout_lwcp,951) 'lwcp',awork(5,i_lwcp),awork(22,i_lwcp),tlwcp,tlwcp3
+ if(nread > 0)then
+ if(first)then
+ open(iout_lwcp)
+ else
+ open(iout_lwcp,position='append')
+ end if
- close(iout_lwcp)
+ nsuperp=nint(awork(4,i_lwcp))
+
+ tlwcp=zero ; tlwcp3=zero
+ if(nkeep > 0)then
+ mesage='current fit of liquid-water content path, ranges in kg/m^2$'
+ do j=1,nconvtype
+ pflag(j)=trim(ioctype(j)) == 'lwcp'
+ end do
+ call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lwcp,pflag)
+
+ numgrslwcp=nint(awork(6,i_lwcp))
+ numfailqc=nint(awork(21,i_lwcp))
+ grsmlt=three
+ tlwcp=zero
+ tlwcp3=zero
+ if(nsuperp > 0)then
+ tlwcp=awork(5,i_lwcp)/nsuperp
+ tlwcp3=awork(22,i_lwcp)/nsuperp
+ end if
+ write(iout_lwcp,925) 'lwcp',numgrslwcp,numfailqc
+ write(iout_lwcp,975) grsmlt,'lwcp',awork(7,i_lwcp)
+ end if
+ write(iout_lwcp,950) 'lwcp',jiter,nread,nkeep,nsuperp
+ write(iout_lwcp,951) 'lwcp',awork(5,i_lwcp),awork(22,i_lwcp),tlwcp,tlwcp3
+
+ close(iout_lwcp)
+ end if
end if
@@ -1472,7 +1591,7 @@ subroutine statsconv(mype,&
' number with abs(guess topography-station elevation) > 200m = ',i8)
920 format(a44,i7)
924 format(a50)
-925 format(' number of ',a5,' obs that failed gross test = ',I5,' nonlin qc test = ',I5)
+925 format(' number of ',a7,' obs that failed gross test = ',I6,' nonlin qc test = ',I6)
949 format(' number of ',a5,' obs = ',i7,' pen= ',e25.18,' cpen= ',g13.6)
950 format(' type ',a7,' jiter ',i3,' nread ',i9,' nkeep ',i7,' num ',i7)
951 format(' type ',a7,' pen= ',e25.18,' qcpen= ',e25.18,' r= ',g13.6,' qcr= ',g13.6)
diff --git a/src/gsi/statslight.f90 b/src/gsi/statslight.f90
index ffcdef6a0a..7f8e7c8349 100644
--- a/src/gsi/statslight.f90
+++ b/src/gsi/statslight.f90
@@ -56,31 +56,14 @@ subroutine statslight(mype,i_light,bwork,awork,i_ref,ndata)
real(r_kind) grsmlt,tlight
real(r_kind) tlight3
- real(r_kind),dimension(1):: pbotall,ptopall
logical,dimension(nlighttype):: pflag
!*********************************************************************************
-! Initialize constants and variables.
- ptopall(1)=zero; pbotall(1)=2000.0_r_kind
-
-
-! Generate summary statistics
-
- pflag=.FALSE.
-
-! Summary report for lightning flash rate
+! Generate statistics Summary report for lightning flash rate
if(mype==mype_light) then
- if(first)then
- open(iout_light)
- else
- open(iout_light,position='append')
- end if
-
- nsuperl=nint(awork(4,i_light))
- tlight=zero ; tlight3=zero
nread=0
nkeep=0
do i=1,ndat
@@ -89,29 +72,40 @@ subroutine statslight(mype,i_light,bwork,awork,i_ref,ndata)
nkeep=nkeep+ndata(i,3)
end if
end do
- if(nkeep > 0)then
- mesage='current fit of lightning data, range in #hits km-2 hr-1$'
- do j=1,nlighttype
- pflag(j)=trim(nulight(j)) == 'light'
- enddo
-
- call dtast(bwork,1,pbot,ptop,mesage,jiter,iout_light,pflag)
+ if(nread > 0)then
+ pflag=.FALSE.
+ if(first)then
+ open(iout_light)
+ else
+ open(iout_light,position='append')
+ end if
- numgrslight=nint(awork(6,i_light))
- numfailqc=nint(awork(21,i_light))
- grsmlt=three
- tlight=zero
- if(nsuperl > 0)then
- tlight=awork(5,i_light)/nsuperl
- tlight3=awork(22,i_light)/nsuperl
+ nsuperl=nint(awork(4,i_light))
+ tlight=zero ; tlight3=zero
+ if(nkeep > 0)then
+ mesage='current fit of lightning data, range in #hits km-2 hr-1$'
+ do j=1,nlighttype
+ pflag(j)=trim(nulight(j)) == 'light'
+ enddo
+
+ call dtast(bwork,1,pbot,ptop,mesage,jiter,iout_light,pflag)
+
+ numgrslight=nint(awork(6,i_light))
+ numfailqc=nint(awork(21,i_light))
+ grsmlt=three
+ tlight=zero
+ if(nsuperl > 0)then
+ tlight=awork(5,i_light)/nsuperl
+ tlight3=awork(22,i_light)/nsuperl
+ end if
+ write(iout_light,925) 'light',numgrslight,numfailqc
+ write(iout_light,975) grsmlt,'light',awork(7,i_light)
end if
- write(iout_light,925) 'light',numgrslight,numfailqc
- write(iout_light,975) grsmlt,'light',awork(7,i_light)
- end if
- write(iout_light,950) 'light',jiter,nread,nkeep,nsuperl
- write(iout_light,951) 'light',awork(5,i_light),awork(22,i_light),tlight,tlight3
+ write(iout_light,950) 'light',jiter,nread,nkeep,nsuperl
+ write(iout_light,951) 'light',awork(5,i_light),awork(22,i_light),tlight,tlight3
- close(iout_light)
+ close(iout_light)
+ end if
end if
diff --git a/src/gsi/statsoz.f90 b/src/gsi/statsoz.f90
index 069082d6b7..fb5f536914 100644
--- a/src/gsi/statsoz.f90
+++ b/src/gsi/statsoz.f90
@@ -101,7 +101,7 @@ subroutine statsoz(stats_oz,ndata)
if (iasim > 0) then
svar = error_oz(i)
if (iuse_oz(i)/=1) svar = -svar
- rsum = one/float(iasim)
+ rsum = one/real(iasim,r_kind)
icerr = nint(stats_oz(2,i))
do j=3,6 ! j=3=obs-mod(w_biascor)
! j=4=(obs-mod(w_biascor))**2
@@ -127,7 +127,7 @@ subroutine statsoz(stats_oz,ndata)
do i=1,ndat
if (idisplay(i)) then
cpen=zero
- if (icount_asim(i)>0) cpen=rpenal(i)/float(icount_asim(i))
+ if (icount_asim(i)>0) cpen=rpenal(i)/real(icount_asim(i),r_kind)
write(iout_oz,1115) jiter,dplat(i),dtype(i),ndata(i,2), &
ndata(i,3),icount_asim(i),rpenal(i),cpen,qcpenal(i),iqccount_asim(i)
endif
diff --git a/src/gsi/statspcp.f90 b/src/gsi/statspcp.f90
index e16f6dfbe5..ad79aed67d 100644
--- a/src/gsi/statspcp.f90
+++ b/src/gsi/statspcp.f90
@@ -210,7 +210,7 @@ subroutine statspcp(aivals,ndata)
if (isum > 0 .and. display(is)) then
rpen(is) = aivals(15,is)
qcpen(is) = aivals(39,is)
- rsum = one/float(isum)
+ rsum = one/real(isum,r_kind)
icerr = nint(aivals(12,is))
do j=13,16
aivals(j,is)=aivals(j,is)*rsum
diff --git a/src/gsi/statsrad.f90 b/src/gsi/statsrad.f90
index c6a993092c..d42a53f7d6 100644
--- a/src/gsi/statsrad.f90
+++ b/src/gsi/statsrad.f90
@@ -120,7 +120,7 @@ subroutine statsrad(aivals,stats,ndata)
if (iasim > 0) then
svar = varch(i)
if (iuse_rad(i) < 1) svar=-svar
- rsum = one/float(iasim)
+ rsum = one/real(iasim,r_kind)
icerr = nint(stats(2,i))
do j=3,6 ! j=3=obs-mod(w_biascor)
! j=4=(obs-mod(w_biascor))**2
@@ -142,7 +142,7 @@ subroutine statsrad(aivals,stats,ndata)
! Write obs count to runtime output file
write(iout_rad,1109)
do i=1,ndat
- if(idisplay(i))then
+ if(idisplay(i) .and. ndata(i,2) > 0)then
iobs2 = nint(aivals(38,i))
qcpenal = aivals(39,i)
rpenal = aivals(40,i)
@@ -162,9 +162,9 @@ subroutine statsrad(aivals,stats,ndata)
2012 format(12x,A7,5x,8(a7,1x))
2999 format(' Illegal satellite type ')
1102 format(1x,i4,i5,1x,a16,2i7,1x,f10.3,1x,6(f11.7,1x))
-1109 format(t5,'it',t13,'satellite',t23,'instrument',t38, &
- '# read',t49,'# keep',t59,'# assim',&
- t68,'penalty',t81,'qcpnlty',t95,'cpen',t105,'qccpen')
+1109 format(t5,'it',t13,'satellite',t23,'instrument',t40, &
+ '# read',t53,'# keep',t65,'# assim',&
+ t75,'penalty',t88,'qcpnlty',t104,'cpen',t115,'qccpen')
1115 format('o-g',1x,i2.2,1x,'rad',2x,2A10,2x,3(i11,2x),4(g12.5,1x))
! Close output unit
diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90
index 80fac64d61..34030763db 100644
--- a/src/gsi/stpcalc.f90
+++ b/src/gsi/stpcalc.f90
@@ -226,17 +226,19 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
use stpjcmod, only: stplimq,stplimg,stplimv,stplimp,stplimw10m,&
stplimhowv,stplimcldch,stpjcdfi,stpjcpdry,stpliml,stplimqc
use bias_predictors, only: predictors
- use control_vectors, only: control_vector,qdot_prod_sub,cvars2d,cvars3d
+ use control_vectors, only: control_vector,qdot_prod_sub
+ use state_vectors, only: qgpresent,qspresent,qrpresent,qipresent,qlpresent
+ use state_vectors, only: cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent
use state_vectors, only: allocate_state,deallocate_state
use gsi_bundlemod, only: gsi_bundle
use gsi_bundlemod, only: gsi_bundlegetpointer
use gsi_bundlemod, only: assignment(=)
use guess_grids, only: ntguessig,nfldsig
use mpl_allreducemod, only: mpl_allreduce
- use mpeu_util, only: getindex
use timermod, only: timer_ini,timer_fnl
use stpjomod, only: stpjo
use gsi_io, only: verbose
+ use gridmod, only: minmype
implicit none
! Declare passed variables
@@ -261,25 +263,24 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
real(r_quad),parameter:: one_tenth_quad = 0.1_r_quad
! Declare local variables
- integer(i_kind) i,j,mm1,ii,iis,ibin,ipenloc,it
+ integer(i_kind) i,j,mm1,ii,final_ii,ibin,ipenloc,it
integer(i_kind) istp_use,nstep,nsteptot,kprt
real(r_quad),dimension(4,ipen):: pbc
real(r_quad),dimension(4,nobs_type):: pbcjo
real(r_quad),dimension(4,nobs_type,nobs_bins):: pbcjoi
- real(r_quad),dimension(4,nobs_bins):: pbcqmin,pbcqmax
+ real(r_quad),dimension(4):: pbcqmin,pbcqmax
real(r_quad),dimension(4,nobs_bins):: pbcql,pbcqi,pbcqr,pbcqs,pbcqg
real(r_quad),dimension(ipen):: pen_est
real(r_quad),dimension(3,ipenlin):: pstart
real(r_quad) bx,cx,ccoef,bcoef,dels,sges1,sgesj
real(r_quad),dimension(0:istp_iter):: stp
real(r_kind),dimension(istp_iter):: stprat
- real(r_quad),dimension(ipen):: bsum,csum,bsum_save,csum_save,pen_save
+ real(r_quad),dimension(ipen):: bsum,csum
real(r_quad),dimension(ipen,nobs_bins):: pj
real(r_kind) delpen
real(r_kind) outpensave
real(r_kind),dimension(4)::sges
real(r_kind),dimension(ioutpen):: outpen,outstp
- logical :: cxterm,change_dels,ifound
logical :: print_verbose,pjcalc
@@ -290,7 +291,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
! Initialize variable
print_verbose=.false.
if(verbose)print_verbose=.true.
- cxterm=.false.
mm1=mype+1
stp(0)=stpinout
outpen = zero
@@ -299,6 +299,7 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
kprt=3
pjcalc=.false.
pj=zero_quad
+ final_ii=1
! Begin calculating contributions to penalty and stepsize for various terms
!
@@ -387,10 +388,10 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
! there, if one has to know or to reference them explicitly.
pstart=zero_quad
- pbc=zero_quad
if(iter == 0 .and. kprt >= 2)pjcalc=.true.
+
! penalty, b and c for background terms
pstart(1,1) = qdot_prod_sub(xhatsave,yhatsave)
@@ -426,11 +427,10 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
dels = one_tenth_quad
stepsize: do ii=1,istp_iter
+ pbc=zero_quad
pjcalc=.false.
if(iter == 0 .and. kprt >= 2 .and. ii == 1)pjcalc=.true.
- iis=ii
! Delta stepsize
- change_dels=.true.
sges(1)= stp(ii-1)
sges(2)=(one_quad-dels)*stp(ii-1)
@@ -448,7 +448,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
end if
! Calculate penalty values for linear terms
-
do i=1,ipenlin
sges1=real(sges(1),r_quad)
pbc(1,i)=pstart(1,i)-(2.0_r_quad*pstart(2,i)-pstart(3,i)*sges1)*sges1
@@ -462,6 +461,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
! penalties for moisture constraint
if(.not. ltlint)then
+!$omp parallel sections
+!$omp section
if(.not.ljc4tlevs) then
call stplimq(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,4),pbc(1,5),nstep,ntguessig)
if(pjcalc)then
@@ -475,216 +476,226 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
else
it=ibin
end if
- call stplimq(dval(ibin),sval(ibin),sges,pbcqmin(1,ibin),pbcqmax(1,ibin),nstep,it)
- end do
- pbc(:,4)=zero_quad
- pbc(:,5)=zero_quad
- do ibin=1,nobs_bins
+ call stplimq(dval(ibin),sval(ibin),sges,pbcqmin,pbcqmax,nstep,it)
do j=1,nstep
- pbc(j,4) = pbc(j,4)+pbcqmin(j,ibin)
- pbc(j,5) = pbc(j,5)+pbcqmax(j,ibin)
+ pbc(j,4) = pbc(j,4)+pbcqmin(j)
+ pbc(j,5) = pbc(j,5)+pbcqmax(j)
end do
+ if(pjcalc)then
+ pj(4,ibin)=pj(4,ibin)+pbcqmin(1)+pbcqmin(ipenloc)
+ pj(5,ibin)=pj(5,ibin)+pbcqmax(1)+pbcqmax(ipenloc)
+ end if
end do
- if(pjcalc)then
- do ibin=1,nobs_bins
- pj(4,ibin)=pj(4,ibin)+pbcqmin(1,ibin)+pbcqmin(ipenloc,ibin)
- pj(5,ibin)=pj(5,ibin)+pbcqmax(1,ibin)+pbcqmax(ipenloc,ibin)
- end do
- end if
end if
+!$omp section
! penalties for gust constraint
- if(getindex(cvars2d,'gust')>0) &
- call stplimg(dval(1),sval(1),sges,pbc(1,6),nstep)
- if(pjcalc)pj(6,1)=pbc(1,6)+pbc(ipenloc,6)
+ if(gustpresent) then
+ call stplimg(dval(1),sval(1),sges,pbc(1,6),nstep)
+ if(pjcalc)pj(6,1)=pbc(1,6)+pbc(ipenloc,6)
+ end if
+!$omp section
! penalties for vis constraint
- if(getindex(cvars2d,'vis')>0) &
- call stplimv(dval(1),sval(1),sges,pbc(1,7),nstep)
- if(pjcalc)pj(7,1)=pbc(1,7)+pbc(ipenloc,7)
+ if(vispresent) then
+ call stplimv(dval(1),sval(1),sges,pbc(1,7),nstep)
+ if(pjcalc)pj(7,1)=pbc(1,7)+pbc(ipenloc,7)
+ end if
! penalties for pblh constraint
- if(getindex(cvars2d,'pblh')>0) &
- call stplimp(dval(1),sval(1),sges,pbc(1,8),nstep)
- if(pjcalc)pj(8,1)=pbc(1,8)+pbc(ipenloc,8)
+!$omp section
+ if(pblhpresent) then
+ call stplimp(dval(1),sval(1),sges,pbc(1,8),nstep)
+ if(pjcalc)pj(8,1)=pbc(1,8)+pbc(ipenloc,8)
+ end if
! penalties for wspd10m constraint
- if(getindex(cvars2d,'wspd10m')>0) &
- call stplimw10m(dval(1),sval(1),sges,pbc(1,9),nstep)
- if(pjcalc)pj(9,1)=pbc(1,9)+pbc(ipenloc,9)
+!$omp section
+ if(wspd10mpresent) then
+ call stplimw10m(dval(1),sval(1),sges,pbc(1,9),nstep)
+ if(pjcalc)pj(9,1)=pbc(1,9)+pbc(ipenloc,9)
+ end if
! penalties for howv constraint
- if(getindex(cvars2d,'howv')>0) &
- call stplimhowv(dval(1),sval(1),sges,pbc(1,10),nstep)
- if(pjcalc)pj(10,1)=pbc(1,10)+pbc(ipenloc,10)
+!$omp section
+ if(howvpresent) then
+ call stplimhowv(dval(1),sval(1),sges,pbc(1,10),nstep)
+ if(pjcalc)pj(10,1)=pbc(1,10)+pbc(ipenloc,10)
+ end if
! penalties for lcbas constraint
- if(getindex(cvars2d,'lcbas')>0) &
- call stpliml(dval(1),sval(1),sges,pbc(1,11),nstep)
- if(pjcalc)pj(11,1)=pbc(1,11)+pbc(ipenloc,11)
+!$omp section
+ if(lcbaspresent) then
+ call stpliml(dval(1),sval(1),sges,pbc(1,11),nstep)
+ if(pjcalc)pj(11,1)=pbc(1,11)+pbc(ipenloc,11)
+ end if
! penalties for cldch constraint
- if(getindex(cvars2d,'cldch')>0) &
- call stplimcldch(dval(1),sval(1),sges,pbc(1,12),nstep)
- if(pjcalc)pj(12,1)=pbc(1,12)+pbc(ipenloc,12)
-
- if (ljclimqc) then
- if (getindex(cvars3d,'ql')>0) then
- if(.not.ljc4tlevs) then
- call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,13),nstep,ntguessig,'ql')
- if(pjcalc) pj(13,1)=pbc(1,13)+pbc(ipenloc,13)
- else
- do ibin=1,nobs_bins
- if (nobs_bins /= nfldsig) then
- it=ntguessig
- else
- it=ibin
- end if
- call stplimqc(dval(ibin),sval(ibin),sges,pbcql(1,ibin),nstep,it,'ql')
- end do
- pbc(:,13)=zero_quad
- do ibin=1,nobs_bins
- do j=1,nstep
- pbc(j,13) = pbc(j,13)+pbcql(j,ibin)
- end do
- end do
- if(pjcalc)then
- do ibin=1,nobs_bins
- pj(13,ibin)=pj(13,ibin)+pbcql(1,ibin)+pbcql(ipenloc,ibin)
- end do
- end if
- end if
+!$omp section
+ if(cldchpresent) then
+ call stplimcldch(dval(1),sval(1),sges,pbc(1,12),nstep)
+ if(pjcalc)pj(12,1)=pbc(1,12)+pbc(ipenloc,12)
+ end if
+
+! if (ljclimqc) then
+!$omp section
+ if (qlpresent .and. ljclimqc ) then
+ if(.not.ljc4tlevs) then
+ call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,13),nstep,ntguessig,'ql')
+ if(pjcalc) pj(13,1)=pbc(1,13)+pbc(ipenloc,13)
+ else
+ do ibin=1,nobs_bins
+ if (nobs_bins /= nfldsig) then
+ it=ntguessig
+ else
+ it=ibin
+ end if
+ call stplimqc(dval(ibin),sval(ibin),sges,pbcql(1,ibin),nstep,it,'ql')
+ end do
+ do ibin=1,nobs_bins
+ do j=1,nstep
+ pbc(j,13) = pbc(j,13)+pbcql(j,ibin)
+ end do
+ end do
+ if(pjcalc)then
+ do ibin=1,nobs_bins
+ pj(13,ibin)=pj(13,ibin)+pbcql(1,ibin)+pbcql(ipenloc,ibin)
+ end do
+ end if
end if
- if (getindex(cvars3d,'qi')>0) then
- if(.not.ljc4tlevs) then
- call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,14),nstep,ntguessig,'qi')
- if(pjcalc) pj(14,1)=pbc(1,14)+pbc(ipenloc,14)
- else
- do ibin=1,nobs_bins
- if (nobs_bins /= nfldsig) then
- it=ntguessig
- else
- it=ibin
- end if
- call stplimqc(dval(ibin),sval(ibin),sges,pbcqi(1,ibin),nstep,it,'qi')
- end do
- pbc(:,14)=zero_quad
- do ibin=1,nobs_bins
- do j=1,nstep
- pbc(j,14) = pbc(j,14)+pbcqi(j,ibin)
- end do
- end do
- if(pjcalc)then
- do ibin=1,nobs_bins
- pj(14,ibin)=pj(14,ibin)+pbcqi(1,ibin)+pbcqi(ipenloc,ibin)
- end do
- end if
- end if
+ end if
+!$omp section
+ if (qipresent .and. ljclimqc ) then
+ if(.not.ljc4tlevs) then
+ call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,14),nstep,ntguessig,'qi')
+ if(pjcalc) pj(14,1)=pbc(1,14)+pbc(ipenloc,14)
+ else
+ do ibin=1,nobs_bins
+ if (nobs_bins /= nfldsig) then
+ it=ntguessig
+ else
+ it=ibin
+ end if
+ call stplimqc(dval(ibin),sval(ibin),sges,pbcqi(1,ibin),nstep,it,'qi')
+ end do
+ do ibin=1,nobs_bins
+ do j=1,nstep
+ pbc(j,14) = pbc(j,14)+pbcqi(j,ibin)
+ end do
+ end do
+ if(pjcalc)then
+ do ibin=1,nobs_bins
+ pj(14,ibin)=pj(14,ibin)+pbcqi(1,ibin)+pbcqi(ipenloc,ibin)
+ end do
+ end if
end if
- if (getindex(cvars3d,'qr')>0) then
- if(.not.ljc4tlevs) then
- call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,15),nstep,ntguessig,'qr')
- if(pjcalc) pj(15,1)=pbc(1,15)+pbc(ipenloc,15)
- else
- do ibin=1,nobs_bins
- if (nobs_bins /= nfldsig) then
- it=ntguessig
- else
- it=ibin
- end if
- call stplimqc(dval(ibin),sval(ibin),sges,pbcqr(1,ibin),nstep,it,'qr')
- end do
- pbc(:,15)=zero_quad
- do ibin=1,nobs_bins
- do j=1,nstep
- pbc(j,15) = pbc(j,15)+pbcqr(j,ibin)
- end do
- end do
- if(pjcalc)then
- do ibin=1,nobs_bins
- pj(15,ibin)=pj(15,ibin)+pbcqr(1,ibin)+pbcqr(ipenloc,ibin)
- end do
- end if
- end if
+ end if
+!$omp section
+ if (qrpresent .and. ljclimqc ) then
+ if(.not.ljc4tlevs) then
+ call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,15),nstep,ntguessig,'qr')
+ if(pjcalc) pj(15,1)=pbc(1,15)+pbc(ipenloc,15)
+ else
+ do ibin=1,nobs_bins
+ if (nobs_bins /= nfldsig) then
+ it=ntguessig
+ else
+ it=ibin
+ end if
+ call stplimqc(dval(ibin),sval(ibin),sges,pbcqr(1,ibin),nstep,it,'qr')
+ end do
+ do ibin=1,nobs_bins
+ do j=1,nstep
+ pbc(j,15) = pbc(j,15)+pbcqr(j,ibin)
+ end do
+ end do
+ if(pjcalc)then
+ do ibin=1,nobs_bins
+ pj(15,ibin)=pj(15,ibin)+pbcqr(1,ibin)+pbcqr(ipenloc,ibin)
+ end do
+ end if
end if
- if (getindex(cvars3d,'qs')>0) then
- if(.not.ljc4tlevs) then
- call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,16),nstep,ntguessig,'qs')
- if(pjcalc) pj(16,1)=pbc(1,16)+pbc(ipenloc,16)
- else
- do ibin=1,nobs_bins
- if (nobs_bins /= nfldsig) then
- it=ntguessig
- else
- it=ibin
- end if
- call stplimqc(dval(ibin),sval(ibin),sges,pbcqs(1,ibin),nstep,it,'qs')
- end do
- pbc(:,16)=zero_quad
- do ibin=1,nobs_bins
- do j=1,nstep
- pbc(j,16) = pbc(j,16)+pbcqs(j,ibin)
- end do
- end do
- if(pjcalc)then
- do ibin=1,nobs_bins
- pj(16,ibin)=pj(16,ibin)+pbcqs(1,ibin)+pbcqs(ipenloc,ibin)
- end do
- end if
- end if
+ end if
+!$omp section
+ if (qspresent .and. ljclimqc ) then
+ if(.not.ljc4tlevs) then
+ call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,16),nstep,ntguessig,'qs')
+ if(pjcalc) pj(16,1)=pbc(1,16)+pbc(ipenloc,16)
+ else
+ do ibin=1,nobs_bins
+ if (nobs_bins /= nfldsig) then
+ it=ntguessig
+ else
+ it=ibin
+ end if
+ call stplimqc(dval(ibin),sval(ibin),sges,pbcqs(1,ibin),nstep,it,'qs')
+ end do
+ do ibin=1,nobs_bins
+ do j=1,nstep
+ pbc(j,16) = pbc(j,16)+pbcqs(j,ibin)
+ end do
+ end do
+ if(pjcalc)then
+ do ibin=1,nobs_bins
+ pj(16,ibin)=pj(16,ibin)+pbcqs(1,ibin)+pbcqs(ipenloc,ibin)
+ end do
+ end if
end if
- if (getindex(cvars3d,'qg')>0) then
- if(.not.ljc4tlevs) then
- call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,17),nstep,ntguessig,'qg')
- if(pjcalc) pj(17,1)=pbc(1,17)+pbc(ipenloc,17)
- else
- do ibin=1,nobs_bins
- if (nobs_bins /= nfldsig) then
- it=ntguessig
- else
- it=ibin
- end if
- call stplimqc(dval(ibin),sval(ibin),sges,pbcqg(1,ibin),nstep,it,'qg')
- end do
- pbc(:,17)=zero_quad
- do ibin=1,nobs_bins
- do j=1,nstep
- pbc(j,17) = pbc(j,17)+pbcqg(j,ibin)
- end do
- end do
- if(pjcalc)then
- do ibin=1,nobs_bins
- pj(17,ibin)=pj(17,ibin)+pbcqg(1,ibin)+pbcqg(ipenloc,ibin)
- end do
- end if
- end if
+ end if
+!$omp section
+ if (qgpresent .and. ljclimqc ) then
+ if(.not.ljc4tlevs) then
+ call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,17),nstep,ntguessig,'qg')
+ if(pjcalc) pj(17,1)=pbc(1,17)+pbc(ipenloc,17)
+ else
+ do ibin=1,nobs_bins
+ if (nobs_bins /= nfldsig) then
+ it=ntguessig
+ else
+ it=ibin
+ end if
+ call stplimqc(dval(ibin),sval(ibin),sges,pbcqg(1,ibin),nstep,it,'qg')
+ end do
+ do ibin=1,nobs_bins
+ do j=1,nstep
+ pbc(j,17) = pbc(j,17)+pbcqg(j,ibin)
+ end do
+ end do
+ if(pjcalc)then
+ do ibin=1,nobs_bins
+ pj(17,ibin)=pj(17,ibin)+pbcqg(1,ibin)+pbcqg(ipenloc,ibin)
+ end do
+ end if
end if
- end if ! ljclimqc
+ end if
+!$omp end parallel sections
+! end if ! ljclimqc
end if
+
! penalties for Jo
pbcjoi=zero_quad
call stpjo(dval,dbias,sval,sbias,sges,pbcjoi,nstep)
pbcjo=zero_quad
- do ibin=1,size(pbcjoi,3) ! == obs_bins
- do j=1,size(pbcjoi,2)
- do i=1,size(pbcjoi,1)
+ do ibin=1,nobs_bins ! == obs_bins
+ do j=1,nobs_type
+ do i=1,nstep
pbcjo(i,j)=pbcjo(i,j)+pbcjoi(i,j,ibin)
end do
end do
enddo
+ do j=1,nobs_type
+ do i=1,nstep
+ pbc(i,n0+j)=pbcjo(i,j)
+ end do
+ end do
if(pjcalc)then
- do ibin=1,size(pbcjoi,3)
- do j=1,size(pbcjoi,2)
+ do ibin=1,nobs_bins
+ do j=1,nobs_type
pj(n0+j,ibin)=pj(n0+j,ibin)+pbcjoi(ipenloc,j,ibin)+pbcjoi(1,j,ibin)
end do
enddo
endif
- do j=1,size(pbcjo,2)
- do i=1,size(pbcjo,1)
- pbc(i,n0+j)=pbcjo(i,j)
- end do
- end do
! Gather J contributions
call mpl_allreduce(4,ipen,pbc)
@@ -718,114 +729,99 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
! estimate of stepsize
+ istp_use=ii
stp(ii)=stp(ii-1)
- if(cx > 1.e-20_r_kind) then
- stp(ii)=stp(ii)+bx/cx ! step size estimate
- else
-! Check for cx <= 0. (probable error or large nonlinearity)
- if(mype == 0) then
- write(iout_iter,*) ' entering cx <=0 stepsize option',cx,stp(ii)
- write(iout_iter,105) (bsum(i),i=1,ipen)
- write(iout_iter,110) (csum(i),i=1,ipen)
- end if
- stp(ii)=outstp(ipenloc)
- outpensave=outpen(ipenloc)
- do i=1,nsteptot
- if(outpen(i) < outpensave)then
- stp(ii)=outstp(i)
- outpensave=outpen(i)
- end if
- end do
- if(outpensave < outpen(ipenloc))then
- if(mype == 0)write(iout_iter,*) ' early termination due to cx <=0 ',cx,stp(ii)
- cxterm=.true.
- else
-! Try different (better?) stepsize
- stp(ii)=max(outstp(1),1.0e-20_r_kind)
- do i=2,nsteptot
- if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i)
- end do
- stp(ii)=one_tenth_quad*stp(ii)
- change_dels=.false.
- end if
- end if
-
+ if(cx > 1.e-20_r_quad) stp(ii)=stp(ii)+bx/cx ! step size estimate
! estimate various terms in penalty on first iteration
if(ii == 1)then
- do i=1,ipen
- pen_save(i)=pbc(1,i)
- bsum_save(i)=bsum(i)
- csum_save(i)=csum(i)
- end do
- pjcost(1) = pen_save(1)+pbc(ipenloc,1) ! Jb
+ pjcost(1) = pbc(1,1)+pbc(ipenloc,1) ! Jb
pjcost(2) = zero_quad
do i=1,nobs_type
- pjcost(2) = pjcost(2)+pen_save(n0+i)+pbc(ipenloc,n0+i) ! Jo
+ pjcost(2) = pjcost(2)+pbc(1,n0+i)+pbc(ipenloc,n0+i) ! Jo
end do
- pjcost(3) = pen_save(2) + pen_save(3)+pbc(ipenloc,3) ! Jc
+ pjcost(3) = pbc(1,2) + pbc(1,3)+pbc(ipenloc,3) ! Jc
pjcost(4) = zero_quad
do i=4,n0
- pjcost(4) = pjcost(4) + pen_save(i)+pbc(ipenloc,i) ! Jl
+ pjcost(4) = pjcost(4) + pbc(1,i)+pbc(ipenloc,i) ! Jl
end do
penalty=pjcost(1)+pjcost(2)+pjcost(3)+pjcost(4) ! J = Jb + Jo + Jc +Jl
! Write out detailed results to iout_iter
- if(mype == 0) then
- write(iout_iter,100) (pen_save(i)+pbc(ipenloc,i),i=1,ipen)
- if(print_verbose)then
- write(iout_iter,105) (bsum(i),i=1,ipen)
- write(iout_iter,110) (csum(i),i=1,ipen)
- end if
- end if
- endif
-
-! estimate of change in penalty
- delpen = stp(ii)*(bx - 0.5_r_quad*stp(ii)*cx )
-
-! If change in penalty is very small end stepsize calculation
- if(abs(delpen/penalty) < 1.e-17_r_kind) then
- if(mype == 0)then
- write(iout_iter,*) ' minimization has converged '
- write(iout_iter,140) ii,delpen,bx,cx,stp(ii)
+ if(mype == minmype) then
write(iout_iter,100) (pbc(1,i)+pbc(ipenloc,i),i=1,ipen)
if(print_verbose)then
write(iout_iter,105) (bsum(i),i=1,ipen)
write(iout_iter,110) (csum(i),i=1,ipen)
end if
end if
- end_iter = .true.
-! Finalize timer
- call timer_fnl('stpcalc')
- istp_use=ii
- exit stepsize
- end if
+ endif
-! Check for negative stepsize (probable error or large nonlinearity)
- if(stp(ii) <= zero_quad) then
- if(mype == 0) then
- write(iout_iter,*) ' entering negative stepsize option',stp(ii)
+ if(cx <= 1.e-20_r_quad .or. stp(ii) <= zero_quad)then
+! Check for cx <= 0 or. stp(ii) < zero. (probable error or large nonlinearity)
+ if(mype == minmype) then
+ write(iout_iter,*) ' entering cx <=0 or stp <= 0 stepsize option',cx,stp(ii)
write(iout_iter,105) (bsum(i),i=1,ipen)
write(iout_iter,110) (csum(i),i=1,ipen)
end if
stp(ii)=outstp(ipenloc)
outpensave=outpen(ipenloc)
- do i=1,nsteptot
+ do i=1,ii
if(outpen(i) < outpensave)then
- stp(ii)=outstp(i)
outpensave=outpen(i)
+ istp_use=i
end if
end do
+ if(istp_use /= ii .and. stp(istp_use) > zero_quad)then
+ if(mype == minmype)then
+ write(iout_iter,*) ' early termination due to cx or stp <=0 ',cx,stp(ii)
+ write(iout_iter,*) ' better stepsize found',cx,stp(ii)
+ end if
+ final_ii=ii
+ exit stepsize
+ else if(ii == istp_iter)then
+ if(mype == minmype)then
+ write(iout_iter,*) ' early termination due to no decrease in penalty ',cx,stp(ii)
+ end if
+ stp(istp_use)=zero
+ end_iter = .true.
+ final_ii=ii
+ exit stepsize
+ else
! Try different (better?) stepsize
- if(stp(ii) <= zero_quad .and. ii /= istp_iter)then
- stp(ii)=max(outstp(1),1.0e-20_r_kind)
- do i=2,nsteptot
- if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i)
- end do
- stp(ii)=one_tenth_quad*stp(ii)
- change_dels=.false.
+ stp(ii)=one_tenth_quad*max(outstp(1),1.0e-20_r_kind)
end if
+ else
+
+! estimate of change in penalty
+ delpen = stp(ii)*(bx - 0.5_r_quad*stp(ii)*cx )
+
+! If change in penalty is very small end stepsize calculation
+ if(abs(delpen/penalty) < 1.e-17_r_kind) then
+ if(mype == minmype)then
+ write(iout_iter,*) ' minimization has converged '
+ write(iout_iter,140) ii,delpen,bx,cx,stp(ii)
+ write(iout_iter,100) (pbc(1,i)+pbc(ipenloc,i),i=1,ipen)
+ if(print_verbose)then
+ write(iout_iter,105) (bsum(i),i=1,ipen)
+ write(iout_iter,110) (csum(i),i=1,ipen)
+ end if
+ end if
+ end_iter = .true.
+! Finalize timer
+ call timer_fnl('stpcalc')
+ final_ii=ii
+ exit stepsize
+ end if
+! Check for convergence in stepsize estimation
+ stprat(ii)=zero
+ if(stp(ii) > zero_quad)stprat(ii)=abs((stp(ii)-stp(ii-1))/stp(ii))
+ if(stprat(ii) < 1.e-4_r_kind) then
+ final_ii=ii
+ exit stepsize
+ end if
+ dels = one_tenth_quad*dels
end if
100 format(' J=',3e25.18/,(3x,3e25.18))
@@ -839,75 +835,50 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
141 format('***WARNING*** reduced penalty not found in search direction',/, &
' - probable error',(5e25.18))
-! Check for convergence in stepsize estimation
- istp_use=ii
- if(cxterm) exit stepsize
- stprat(ii)=zero
- if(stp(ii) > zero)then
- stprat(ii)=abs((stp(ii)-stp(ii-1))/stp(ii))
- end if
- if(stprat(ii) < 1.e-4_r_kind) exit stepsize
- if(change_dels)dels = one_tenth_quad*dels
! If stepsize estimate has not converged use best stepsize estimate or zero
if( ii == istp_iter)then
stp(ii)=outstp(ipenloc)
outpensave=outpen(ipenloc)
- ifound=.false.
! Find best stepsize to this point
do i=1,nsteptot
if(outpen(i) < outpensave)then
stp(ii)=outstp(i)
outpensave=outpen(i)
- ifound=.true.
+ istp_use=ii
end if
end do
- if(ifound)exit stepsize
+ if(istp_use /= nsteptot) then
+ final_ii=ii
+ exit stepsize
+ end if
! If no best stepsize set to zero and end minimization
- if(mype == 0)then
+ if(mype == minmype)then
write(iout_iter,141)(outpen(i),i=1,nsteptot)
end if
end_iter = .true.
stp(ii)=zero_quad
istp_use=ii
+ final_ii=ii
exit stepsize
end if
+ final_ii=ii
end do stepsize
+
if(kprt >= 2 .and. iter == 0)then
call mpl_allreduce(ipen,nobs_bins,pj)
- if(mype == 0)call prnt_j(pj,n0,ipen,kprt)
+ if(mype == minmype)call prnt_j(pj,n0,ipen,kprt)
end if
stpinout=stp(istp_use)
-! Estimate terms in penalty
- if(mype == 0 .and. print_verbose)then
- do i=1,ipen
- pen_est(i)=pen_save(i)-(stpinout-stp(0))*(2.0_r_quad*bsum_save(i)- &
- (stpinout-stp(0))*csum_save(i))
- end do
- write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen)
- end if
- pjcostnew(1) = pbc(1,1) ! Jb
- pjcostnew(3) = pbc(1,2)+pbc(1,3) ! Jc
- pjcostnew(4)=zero
- do i=4,n0
- pjcostnew(4) = pjcostnew(4) + pbc(1,i) ! Jl
- end do
- pjcostnew(2) = zero
- do i=1,nobs_type
- pjcostnew(2) = pjcostnew(2)+pbc(1,n0+i) ! Jo
- end do
- penaltynew=pjcostnew(1)+pjcostnew(2)+pjcostnew(3)+pjcostnew(4)
- if(mype == 0 .and. print_verbose)then
- write(iout_iter,200) (stp(i),i=0,istp_use)
- write(iout_iter,199) (stprat(ii),ii=1,istp_use)
- write(iout_iter,201) (outstp(i),i=1,nsteptot)
- write(iout_iter,202) (outpen(i)-outpen(4),i=1,nsteptot)
- end if
! Check for final stepsize negative (probable error)
if(stpinout <= zero)then
- if(mype == 0)then
- write(iout_iter,130) ii,bx,cx,stp(ii)
+ if(mype == minmype)then
+ do i=1,ipen
+ pen_est(i)=pbc(1,i)-(stpinout-stp(0))*(2.0_r_quad*bsum(i)- &
+ (stpinout-stp(0))*csum(i))
+ end do
+ write(iout_iter,130) final_ii,bx,cx,stp(final_ii)
write(iout_iter,105) (bsum(i),i=1,ipen)
write(iout_iter,110) (csum(i),i=1,ipen)
write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen)
@@ -920,26 +891,49 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
202 format(' penalties = ',(10(e13.6,1x)))
! If convergence or failure of stepsize calculation return
- if (end_iter) then
- call timer_fnl('stpcalc')
- return
- endif
+! Estimate terms in penalty
+ if(mype == minmype)then
+ pjcostnew(1) = pbc(1,1) ! Jb
+ pjcostnew(3) = pbc(1,2)+pbc(1,3) ! Jc
+ pjcostnew(4)=zero
+ do i=4,n0
+ pjcostnew(4) = pjcostnew(4) + pbc(1,i) ! Jl
+ end do
+ pjcostnew(2) = zero
+ do i=1,nobs_type
+ pjcostnew(2) = pjcostnew(2)+pbc(1,n0+i) ! Jo
+ end do
+ penaltynew=pjcostnew(1)+pjcostnew(2)+pjcostnew(3)+pjcostnew(4)
+
+ if(print_verbose)then
+ write(iout_iter,200) (stp(i),i=0,istp_use)
+ write(iout_iter,199) (stprat(i),i=1,istp_use)
+ write(iout_iter,201) (outstp(i),i=1,nsteptot)
+ write(iout_iter,202) (outpen(i)-outpen(4),i=1,nsteptot)
+ end if
+ end if
+
+ if (.not. end_iter) then
! Update solution
- do i=1,nrclen
- sbias%values(i)=sbias%values(i)+stpinout*dbias%values(i)
- end do
!$omp parallel do schedule(dynamic,1) private(i,ii)
- do ii=1,nobs_bins
- do i=1,sval(ii)%ndim
- sval(ii)%values(i)=sval(ii)%values(i)+stpinout*dval(ii)%values(i)
+ do ii=1,nobs_bins+2
+ if(ii <= nobs_bins)then
+ do i=1,sval(ii)%ndim
+ sval(ii)%values(i)=sval(ii)%values(i)+stpinout*dval(ii)%values(i)
+ end do
+ else if(ii == nobs_bins+1)then
+ do i=1,nrclen
+ sbias%values(i)=sbias%values(i)+stpinout*dbias%values(i)
+ end do
+ else
+ do i=1,nclen
+ xhatsave%values(i)=xhatsave%values(i)+stpinout*dirx%values(i)
+ yhatsave%values(i)=yhatsave%values(i)+stpinout*diry%values(i)
+ end do
+ end if
end do
- end do
-!DIR$ IVDEP
- do i=1,nclen
- xhatsave%values(i)=xhatsave%values(i)+stpinout*dirx%values(i)
- yhatsave%values(i)=yhatsave%values(i)+stpinout*diry%values(i)
- end do
+ endif
! Finalize timer
@@ -975,6 +969,7 @@ subroutine prnt_j(pj,n0,ipen,kprt)
use mpimod, only: mype
use gsi_obOperTypeManager, only: nobs_type => obOper_count
use gsi_obOperTypeManager, only: obOper_typeInfo
+ use gridmod, only: minmype
real(r_quad),dimension(ipen,nobs_bins),intent(in ) :: pj
integer(i_kind) ,intent(in ) :: n0,ipen,kprt
@@ -986,7 +981,7 @@ subroutine prnt_j(pj,n0,ipen,kprt)
integer(i_kind) :: ii,jj
character(len=20) :: ctype(ipen)
- if(kprt <=0 .or. mype /=0)return
+ if(kprt <=0 .or. mype /=minmype)return
ctype(:)=".unknown."
ctype(1)='background '
ctype(2)=' '
diff --git a/src/gsi/stpfed.f90 b/src/gsi/stpfed.f90
new file mode 100644
index 0000000000..6511a27968
--- /dev/null
+++ b/src/gsi/stpfed.f90
@@ -0,0 +1,169 @@
+module stpfedmod
+
+!$$$ module documentation block
+! . . . .
+! module: stpfedmod module for stpfed and its tangent linear stpfed_tl
+! prgmmr:
+!
+! abstract: module for stpfed and its tangent linear stpfed_tl
+!
+! program history log:
+! 2023-08-23 H. Wang - Modified based on sftdbzmod
+! - add adjoint of fed operator
+!
+! subroutines included:
+! sub stpfed
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+implicit none
+
+PRIVATE
+PUBLIC stpfed
+
+contains
+
+subroutine stpfed(fedhead,rval,sval,out,sges,nstep)
+!$$$ subprogram documentation block
+! . . . .
+! subprogram: stpfed calculate penalty and contribution to
+! stepsize with nonlinear qc added.
+! prgmmr: derber org: np23 date: 1991-02-26
+!
+!
+! program history log:
+! 2019-08-23 H.Wang - added for FED DA
+! input argument list:
+! fedhead
+! sges - step size estimates (nstep)
+! nstep - number of step sizes (== 0 means use outer iteration value)
+!
+! output argument list - output for step size calculation
+! out(1:nstep) - penalty from fed sges(1:nstep)
+!
+! attributes:
+! language: f90
+! machine: ibm RS/6000 SP
+!
+!$$$
+ use kinds, only: r_kind,i_kind,r_quad
+ use qcmod, only: nlnqc_iter,varqc_iter
+ use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,r3600
+ use gsi_bundlemod, only: gsi_bundle
+ use gsi_bundlemod, only: gsi_bundlegetpointer
+ use wrf_vars_mod, only : fed_exist
+ use m_obsNode, only: obsNode
+ use m_fedNode , only: fedNode
+ use m_fedNode , only: fedNode_typecast
+ use m_fedNode , only: fedNode_nextcast
+! use directDA_radaruse_mod, only: l_use_fed_directDA
+
+ implicit none
+
+! Declare passed variables
+ class(obsNode), pointer ,intent(in ) :: fedhead
+ integer(i_kind) ,intent(in ) :: nstep
+ real(r_quad),dimension(max(1,nstep)),intent(inout) :: out
+ type(gsi_bundle) ,intent(in ) :: rval,sval
+ real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges
+
+! Declare local variables
+ integer(i_kind) ier,istatus
+ integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,kk
+ real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8
+ real(r_kind) valfed
+ real(r_kind) fedcur
+ real(r_kind) cg_fed,fed,wgross,wnotgross
+ real(r_kind),dimension(max(1,nstep))::pen
+ real(r_kind) pg_fed
+ real(r_kind),pointer,dimension(:) :: sfed
+ real(r_kind),pointer,dimension(:) :: rfed
+ type(fedNode), pointer :: fedptr
+
+ out=zero_quad
+
+! If no fed data return
+ if(.not. associated(fedhead))return
+
+! Retrieve pointers
+! Simply return if any pointer not found
+ ier=0
+ if(fed_exist)then
+ call gsi_bundlegetpointer(sval,'fed',sfed,istatus);ier=istatus+ier
+ call gsi_bundlegetpointer(rval,'fed',rfed,istatus);ier=istatus+ier
+ else
+ return
+ end if
+
+ if(ier/=0)return
+
+ fedptr => fedNode_typecast(fedhead)
+ do while (associated(fedptr))
+ if(fedptr%luse)then
+ if(nstep > 0)then
+ j1=fedptr%ij(1)
+ j2=fedptr%ij(2)
+ j3=fedptr%ij(3)
+ j4=fedptr%ij(4)
+ j5=fedptr%ij(5)
+ j6=fedptr%ij(6)
+ j7=fedptr%ij(7)
+ j8=fedptr%ij(8)
+ w1=fedptr%wij(1)
+ w2=fedptr%wij(2)
+ w3=fedptr%wij(3)
+ w4=fedptr%wij(4)
+ w5=fedptr%wij(5)
+ w6=fedptr%wij(6)
+ w7=fedptr%wij(7)
+ w8=fedptr%wij(8)
+
+ if( fed_exist )then
+ valfed= w1* rfed(j1)+w2*rfed(j2)+w3*rfed(j3)+w4*rfed(j4)+ &
+ w5* rfed(j5)+w6*rfed(j6)+w7*rfed(j7)+w8*rfed(j8)
+
+ fedcur= w1* sfed(j1)+w2* sfed(j2)+w3* sfed(j3)+w4*sfed(j4)+ &
+ w5* sfed(j5)+w6* sfed(j6)+w7* sfed(j7)+w8* sfed(j8)- &
+ fedptr%res
+ end if
+
+
+ do kk=1,nstep
+ fed=fedcur+sges(kk)*valfed
+ pen(kk)=fed*fed*fedptr%err2
+ end do
+ else
+ pen(1)=fedptr%res*fedptr%res*fedptr%err2
+ end if
+
+! Modify penalty term if nonlinear QC
+ if (nlnqc_iter .and. fedptr%pg > tiny_r_kind .and. &
+ fedptr%b > tiny_r_kind) then
+
+ pg_fed=fedptr%pg*varqc_iter
+ cg_fed=cg_term/fedptr%b
+ wnotgross= one-pg_fed
+ wgross = pg_fed*cg_fed/wnotgross
+ do kk=1,max(1,nstep)
+ pen(kk)= -two*log((exp(-half*pen(kk)) + wgross)/(one+wgross))
+ end do
+ end if
+
+ out(1) = out(1)+pen(1)*fedptr%raterr2
+ kk=1
+ do kk=2,nstep
+ out(kk) = out(kk)+(pen(kk)-pen(1))*fedptr%raterr2
+ end do
+ end if
+
+ fedptr => fedNode_nextcast(fedptr)
+
+ end do
+ return
+end subroutine stpfed
+
+end module stpfedmod
diff --git a/src/gsi/stpgps.f90 b/src/gsi/stpgps.f90
index f55e9f4292..d357df1c05 100644
--- a/src/gsi/stpgps.f90
+++ b/src/gsi/stpgps.f90
@@ -107,12 +107,13 @@ subroutine stpgps(gpshead,rval,sval,out,sges,nstep)
real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges
! Declare local variables
- integer(i_kind) j,kk,ier,istatus
- integer(i_kind),dimension(nsig):: i1,i2,i3,i4
+ integer(i_kind):: j,kk,ier,istatus
+ integer(i_kind):: i1,i2,i3,i4
real(r_kind) :: val,val2
real(r_kind) :: w1,w2,w3,w4
real(r_kind) :: q_TL,p_TL,t_TL
real(r_kind) :: rq_TL,rp_TL,rt_TL
+ real(r_kind),dimension(nsig) :: valk2,valk
real(r_kind),pointer,dimension(:) :: st,sq
real(r_kind),pointer,dimension(:) :: rt,rq
real(r_kind),pointer,dimension(:) :: sp
@@ -149,34 +150,33 @@ subroutine stpgps(gpshead,rval,sval,out,sges,nstep)
val2=-gpsptr%res
if(nstep > 0)then
- do j=1,nsig
- i1(j)= gpsptr%ij(1,j)
- i2(j)= gpsptr%ij(2,j)
- i3(j)= gpsptr%ij(3,j)
- i4(j)= gpsptr%ij(4,j)
- enddo
w1=gpsptr%wij(1)
w2=gpsptr%wij(2)
w3=gpsptr%wij(3)
w4=gpsptr%wij(4)
- val=zero
-
-
+!$omp parallel do schedule(dynamic,1) private(j,t_TL,rt_TL,q_TL,rq_TL,p_TL,rp_TL,i1,i2,i3,i4)
do j=1,nsig
- t_TL =w1* st(i1(j))+w2* st(i2(j))+w3* st(i3(j))+w4* st(i4(j))
- rt_TL=w1* rt(i1(j))+w2* rt(i2(j))+w3* rt(i3(j))+w4* rt(i4(j))
- q_TL =w1* sq(i1(j))+w2* sq(i2(j))+w3* sq(i3(j))+w4* sq(i4(j))
- rq_TL=w1* rq(i1(j))+w2* rq(i2(j))+w3* rq(i3(j))+w4* rq(i4(j))
- p_TL =w1* sp(i1(j))+w2* sp(i2(j))+w3* sp(i3(j))+w4* sp(i4(j))
- rp_TL=w1* rp(i1(j))+w2* rp(i2(j))+w3* rp(i3(j))+w4* rp(i4(j))
- val2 = val2 + t_tl*gpsptr%jac_t(j)+ q_tl*gpsptr%jac_q(j)+p_tl*gpsptr%jac_p(j)
- val = val + rt_tl*gpsptr%jac_t(j)+rq_tl*gpsptr%jac_q(j)+rp_tl*gpsptr%jac_p(j)
-
+ i1= gpsptr%ij(1,j)
+ i2= gpsptr%ij(2,j)
+ i3= gpsptr%ij(3,j)
+ i4= gpsptr%ij(4,j)
+ t_TL =w1* st(i1)+w2* st(i2)+w3* st(i3)+w4* st(i4)
+ rt_TL=w1* rt(i1)+w2* rt(i2)+w3* rt(i3)+w4* rt(i4)
+ q_TL =w1* sq(i1)+w2* sq(i2)+w3* sq(i3)+w4* sq(i4)
+ rq_TL=w1* rq(i1)+w2* rq(i2)+w3* rq(i3)+w4* rq(i4)
+ p_TL =w1* sp(i1)+w2* sp(i2)+w3* sp(i3)+w4* sp(i4)
+ rp_TL=w1* rp(i1)+w2* rp(i2)+w3* rp(i3)+w4* rp(i4)
+ valk2(j) = t_tl*gpsptr%jac_t(j)+ q_tl*gpsptr%jac_q(j)+ p_tl*gpsptr%jac_p(j)
+ valk(j) = rt_tl*gpsptr%jac_t(j)+rq_tl*gpsptr%jac_q(j)+rp_tl*gpsptr%jac_p(j)
enddo
-
+ val=zero
+ do j=1,nsig
+ val2 = val2 + valk2(j)
+ val = val + valk(j)
+ enddo
! penalty and gradient
do kk=1,nstep
diff --git a/src/gsi/stpjcmod.f90 b/src/gsi/stpjcmod.f90
index 2c811912a0..1cdabe60eb 100644
--- a/src/gsi/stpjcmod.f90
+++ b/src/gsi/stpjcmod.f90
@@ -871,7 +871,7 @@ subroutine stpjcpdry(rval,sval,pen,b,c,nbins)
it=ntguessig
dmass=zero_quad
- rcon=one_quad/(two_quad*float(nlon))
+ rcon=one_quad/(two_quad*real(nlon,r_quad))
mm1=mype+1
return_now = .false.
do n=1,nbins
diff --git a/src/gsi/stpjo.f90 b/src/gsi/stpjo.f90
index b0ff730823..0f80d9b4a2 100644
--- a/src/gsi/stpjo.f90
+++ b/src/gsi/stpjo.f90
@@ -267,8 +267,6 @@ subroutine stpjo(dval,dbias,xval,xbias,sges,pbcjo,nstep)
use m_obsdiags, only: obOper_destroy
use gsi_obOperTypeManager, only: obOper_typeInfo
- use intradmod, only: setrad
-
use mpeu_util, only: perr,die
use mpeu_util, only: tell
use mpeu_mpif, only: MPI_comm_world
@@ -290,7 +288,6 @@ subroutine stpjo(dval,dbias,xval,xbias,sges,pbcjo,nstep)
class(obOper),pointer:: it_obOper
!************************************************************************************
- call setrad(xval(1))
!$omp parallel do schedule(dynamic,1) private(ll,mm,ib,it_obOper)
do mm=1,stpcnt
diff --git a/src/gsi/stprad.f90 b/src/gsi/stprad.f90
index 0def855d61..e81688f7e3 100644
--- a/src/gsi/stprad.f90
+++ b/src/gsi/stprad.f90
@@ -110,7 +110,7 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep)
use gsi_metguess_mod, only: gsi_metguess_get
use mpeu_util, only: getindex
use intradmod, only: luseu,lusev,luset,luseq,lusecw,luseoz,luseqg,luseqh,luseqi,luseql, &
- luseqr,luseqs
+ luseqr,luseqs,lusesst
use intradmod, only: itsen,iqv,ioz,icw,ius,ivs,isst,iqg,iqh,iqi,iql,iqr,iqs,lgoback
use m_obsNode, only: obsNode
use m_radNode, only: radNode
@@ -128,14 +128,15 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep)
type(gsi_bundle),intent(in) :: xval
! Declare local variables
- integer(i_kind) istatus
- integer(i_kind) nn,n,ic,k,nx,j1,j2,j3,j4,kk, mm, ic1,ncr
+ integer(i_kind) istatus,icx
+ integer(i_kind) nn,n,ic,k,nx,j1,j2,j3,j4,kk,mm,ncr
real(r_kind) val2,val,w1,w2,w3,w4
real(r_kind),dimension(nsigradjac):: tdir,rdir
real(r_kind) cg_rad,wgross,wnotgross
integer(i_kind),dimension(nsig) :: j1n,j2n,j3n,j4n
- real(r_kind),dimension(max(1,nstep)) :: term,rad
+ real(r_kind),dimension(max(1,nstep)) :: rad
type(radNode), pointer :: radptr
+ real(r_kind),allocatable,dimension(:,:) :: term
real(r_kind),allocatable,dimension(:) :: biasvects
real(r_kind),allocatable,dimension(:) :: biasvectr
real(r_kind),pointer,dimension(:) :: rt,rq,rcw,roz,ru,rv,rqg,rqh,rqi,rql,rqr,rqs
@@ -150,34 +151,59 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep)
if(lgoback)return
-! Retrieve pointers
- call gsi_bundlegetpointer(xval,'u', su, istatus)
- call gsi_bundlegetpointer(xval,'v', sv, istatus)
- call gsi_bundlegetpointer(xval,'tsen' ,st, istatus)
- call gsi_bundlegetpointer(xval,'q', sq, istatus)
- call gsi_bundlegetpointer(xval,'cw' ,scw,istatus)
- call gsi_bundlegetpointer(xval,'oz' ,soz,istatus)
- call gsi_bundlegetpointer(xval,'sst',sst,istatus)
- call gsi_bundlegetpointer(xval,'qg' ,sqg,istatus)
- call gsi_bundlegetpointer(xval,'qh' ,sqh,istatus)
- call gsi_bundlegetpointer(xval,'qi' ,sqi,istatus)
- call gsi_bundlegetpointer(xval,'ql' ,sql,istatus)
- call gsi_bundlegetpointer(xval,'qr' ,sqr,istatus)
- call gsi_bundlegetpointer(xval,'qs' ,sqs,istatus)
-
- call gsi_bundlegetpointer(dval,'u', ru, istatus)
- call gsi_bundlegetpointer(dval,'v', rv, istatus)
- call gsi_bundlegetpointer(dval,'tsen' ,rt, istatus)
- call gsi_bundlegetpointer(dval,'q', rq, istatus)
- call gsi_bundlegetpointer(dval,'cw' ,rcw,istatus)
- call gsi_bundlegetpointer(dval,'oz' ,roz,istatus)
- call gsi_bundlegetpointer(dval,'sst',rst,istatus)
- call gsi_bundlegetpointer(dval,'qg' ,rqg,istatus)
- call gsi_bundlegetpointer(dval,'qh' ,rqh,istatus)
- call gsi_bundlegetpointer(dval,'qi' ,rqi,istatus)
- call gsi_bundlegetpointer(dval,'ql' ,rql,istatus)
- call gsi_bundlegetpointer(dval,'qr' ,rqr,istatus)
- call gsi_bundlegetpointer(dval,'qs' ,rqs,istatus)
+! Retrieve pointers for used variables
+ if(luseu)then
+ call gsi_bundlegetpointer(dval,'u', ru, istatus)
+ call gsi_bundlegetpointer(xval,'u', su, istatus)
+ end if
+ if(lusev)then
+ call gsi_bundlegetpointer(xval,'v', sv, istatus)
+ call gsi_bundlegetpointer(dval,'v', rv, istatus)
+ end if
+ if(luset)then
+ call gsi_bundlegetpointer(xval,'tsen' ,st, istatus)
+ call gsi_bundlegetpointer(dval,'tsen' ,rt, istatus)
+ end if
+ if(luseq)then
+ call gsi_bundlegetpointer(xval,'q', sq, istatus)
+ call gsi_bundlegetpointer(dval,'q', rq, istatus)
+ end if
+ if(lusecw)then
+ call gsi_bundlegetpointer(xval,'cw' ,scw,istatus)
+ call gsi_bundlegetpointer(dval,'cw' ,rcw,istatus)
+ end if
+ if(luseoz)then
+ call gsi_bundlegetpointer(xval,'oz' ,soz,istatus)
+ call gsi_bundlegetpointer(dval,'oz' ,roz,istatus)
+ end if
+ if(lusesst)then
+ call gsi_bundlegetpointer(xval,'sst',sst,istatus)
+ call gsi_bundlegetpointer(dval,'sst',rst,istatus)
+ end if
+ if(luseqg)then
+ call gsi_bundlegetpointer(xval,'qg' ,sqg,istatus)
+ call gsi_bundlegetpointer(dval,'qg' ,rqg,istatus)
+ end if
+ if(luseqh)then
+ call gsi_bundlegetpointer(xval,'qh' ,sqh,istatus)
+ call gsi_bundlegetpointer(dval,'qh' ,rqh,istatus)
+ end if
+ if(luseqi)then
+ call gsi_bundlegetpointer(xval,'qi' ,sqi,istatus)
+ call gsi_bundlegetpointer(dval,'qi' ,rqi,istatus)
+ end if
+ if(luseql)then
+ call gsi_bundlegetpointer(xval,'ql' ,sql,istatus)
+ call gsi_bundlegetpointer(dval,'ql' ,rql,istatus)
+ end if
+ if(luseqr)then
+ call gsi_bundlegetpointer(xval,'qr' ,sqr,istatus)
+ call gsi_bundlegetpointer(dval,'qr' ,rqr,istatus)
+ end if
+ if(luseqs)then
+ call gsi_bundlegetpointer(xval,'qs' ,sqs,istatus)
+ call gsi_bundlegetpointer(dval,'qs' ,rqs,istatus)
+ end if
tdir=zero
@@ -187,118 +213,117 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep)
do while(associated(radptr))
if(radptr%luse)then
if(nstep > 0)then
- j1=radptr%ij(1)
- j2=radptr%ij(2)
- j3=radptr%ij(3)
- j4=radptr%ij(4)
w1=radptr%wij(1)
w2=radptr%wij(2)
w3=radptr%wij(3)
w4=radptr%wij(4)
- if(luseu)then
- tdir(ius+1)=w1* su(j1) + w2* su(j2) + w3* su(j3) + w4* su(j4)
- rdir(ius+1)=w1* ru(j1) + w2* ru(j2) + w3* ru(j3) + w4* ru(j4)
- endif
- if(lusev)then
- tdir(ivs+1)=w1* sv(j1) + w2* sv(j2) + w3* sv(j3) + w4* sv(j4)
- rdir(ivs+1)=w1* rv(j1) + w2* rv(j2) + w3* rv(j3) + w4* rv(j4)
- endif
- if (isst>=0) then
- tdir(isst+1)=w1*sst(j1) + w2*sst(j2) + w3*sst(j3) + w4*sst(j4)
- rdir(isst+1)=w1*rst(j1) + w2*rst(j2) + w3*rst(j3) + w4*rst(j4)
- end if
- j1n(1) = j1
- j2n(1) = j2
- j3n(1) = j3
- j4n(1) = j4
+ j1n(1) = radptr%ij(1)
+ j2n(1) = radptr%ij(2)
+ j3n(1) = radptr%ij(3)
+ j4n(1) = radptr%ij(4)
do n=2,nsig
j1n(n) = j1n(n-1)+latlon11
j2n(n) = j2n(n-1)+latlon11
j3n(n) = j3n(n-1)+latlon11
j4n(n) = j4n(n-1)+latlon11
enddo
- do n=1,nsig
- j1 = j1n(n)
- j2 = j2n(n)
- j3 = j3n(n)
- j4 = j4n(n)
-
-! Input state vector
-! Input search direction vector
- if(luset)then
- tdir(itsen+n)=w1* st(j1) +w2* st(j2) + w3* st(j3) +w4* st(j4)
- rdir(itsen+n)=w1* rt(j1) +w2* rt(j2) + w3* rt(j3) +w4* rt(j4)
- endif
- if(luseq)then
- tdir(iqv+n)=w1* sq(j1) +w2* sq(j2) + w3* sq(j3) +w4* sq(j4)
- rdir(iqv+n)=w1* rq(j1) +w2* rq(j2) + w3* rq(j3) +w4* rq(j4)
- endif
- if (luseoz) then
- tdir(ioz+n)=w1*soz(j1)+w2*soz(j2)+ w3*soz(j3)+w4*soz(j4)
- rdir(ioz+n)=w1*roz(j1)+w2*roz(j2)+ w3*roz(j3)+w4*roz(j4)
- end if
- if (lusecw) then
- tdir(icw+n)=w1*scw(j1)+w2*scw(j2)+ w3*scw(j3)+w4*scw(j4)
- rdir(icw+n)=w1*rcw(j1)+w2*rcw(j2)+ w3*rcw(j3)+w4*rcw(j4)
- end if
- if (luseqg) then
- tdir(iqg+n)=w1*sqg(j1)+w2*sqg(j2)+ w3*sqg(j3)+w4*sqg(j4)
- rdir(iqg+n)=w1*rqg(j1)+w2*rqg(j2)+ w3*rqg(j3)+w4*rqg(j4)
- end if
- if (luseqh) then
- tdir(iqh+n)=w1*sqh(j1)+w2*sqh(j2)+ w3*sqh(j3)+w4*sqh(j4)
- rdir(iqh+n)=w1*rqh(j1)+w2*rqh(j2)+ w3*rqh(j3)+w4*rqh(j4)
- end if
- if (luseqi) then
- tdir(iqi+n)=w1*sqi(j1)+w2*sqi(j2)+ w3*sqi(j3)+w4*sqi(j4)
- rdir(iqi+n)=w1*rqi(j1)+w2*rqi(j2)+ w3*rqi(j3)+w4*rqi(j4)
- end if
- if (luseql) then
- tdir(iql+n)=w1*sql(j1)+w2*sql(j2)+ w3*sql(j3)+w4*sql(j4)
- rdir(iql+n)=w1*rql(j1)+w2*rql(j2)+ w3*rql(j3)+w4*rql(j4)
- end if
- if (luseqr) then
- tdir(iqr+n)=w1*sqr(j1)+w2*sqr(j2)+ w3*sqr(j3)+w4*sqr(j4)
- rdir(iqr+n)=w1*rqr(j1)+w2*rqr(j2)+ w3*rqr(j3)+w4*rqr(j4)
+ allocate(biasvects(radptr%nchan))
+ allocate(biasvectr(radptr%nchan))
+ allocate(term(max(1,nstep),radptr%nchan))
+
+!$omp parallel do schedule(dynamic,1) private(n,j1,j2,j3,j4,icx,vals_quad,valr_quad,nx)
+ do n=1,max(nsig,radptr%nchan)
+ if(n <= nsig)then
+ j1 = j1n(n)
+ j2 = j2n(n)
+ j3 = j3n(n)
+ j4 = j4n(n)
+ if(n == 1)then
+ if(luseu)then
+ tdir(ius+1)=w1* su(j1) + w2* su(j2) + w3* su(j3) + w4* su(j4)
+ rdir(ius+1)=w1* ru(j1) + w2* ru(j2) + w3* ru(j3) + w4* ru(j4)
+ endif
+ if(lusev)then
+ tdir(ivs+1)=w1* sv(j1) + w2* sv(j2) + w3* sv(j3) + w4* sv(j4)
+ rdir(ivs+1)=w1* rv(j1) + w2* rv(j2) + w3* rv(j3) + w4* rv(j4)
+ endif
+ if (lusesst) then
+ tdir(isst+1)=w1*sst(j1) + w2*sst(j2) + w3*sst(j3) + w4*sst(j4)
+ rdir(isst+1)=w1*rst(j1) + w2*rst(j2) + w3*rst(j3) + w4*rst(j4)
+ end if
+ end if
+
+! Input state vector
+! Input search direction vector
+ if(luset)then
+ tdir(itsen+n)=w1* st(j1) +w2* st(j2) + w3* st(j3) +w4* st(j4)
+ rdir(itsen+n)=w1* rt(j1) +w2* rt(j2) + w3* rt(j3) +w4* rt(j4)
+ endif
+ if(luseq)then
+ tdir(iqv+n)=w1* sq(j1) +w2* sq(j2) + w3* sq(j3) +w4* sq(j4)
+ rdir(iqv+n)=w1* rq(j1) +w2* rq(j2) + w3* rq(j3) +w4* rq(j4)
+ endif
+ if (luseoz) then
+ tdir(ioz+n)=w1*soz(j1)+w2*soz(j2)+ w3*soz(j3)+w4*soz(j4)
+ rdir(ioz+n)=w1*roz(j1)+w2*roz(j2)+ w3*roz(j3)+w4*roz(j4)
+ end if
+ if (lusecw) then
+ tdir(icw+n)=w1*scw(j1)+w2*scw(j2)+ w3*scw(j3)+w4*scw(j4)
+ rdir(icw+n)=w1*rcw(j1)+w2*rcw(j2)+ w3*rcw(j3)+w4*rcw(j4)
+ end if
+ if (luseqg) then
+ tdir(iqg+n)=w1*sqg(j1)+w2*sqg(j2)+ w3*sqg(j3)+w4*sqg(j4)
+ rdir(iqg+n)=w1*rqg(j1)+w2*rqg(j2)+ w3*rqg(j3)+w4*rqg(j4)
+ end if
+ if (luseqh) then
+ tdir(iqh+n)=w1*sqh(j1)+w2*sqh(j2)+ w3*sqh(j3)+w4*sqh(j4)
+ rdir(iqh+n)=w1*rqh(j1)+w2*rqh(j2)+ w3*rqh(j3)+w4*rqh(j4)
+ end if
+ if (luseqi) then
+ tdir(iqi+n)=w1*sqi(j1)+w2*sqi(j2)+ w3*sqi(j3)+w4*sqi(j4)
+ rdir(iqi+n)=w1*rqi(j1)+w2*rqi(j2)+ w3*rqi(j3)+w4*rqi(j4)
+ end if
+ if (luseql) then
+ tdir(iql+n)=w1*sql(j1)+w2*sql(j2)+ w3*sql(j3)+w4*sql(j4)
+ rdir(iql+n)=w1*rql(j1)+w2*rql(j2)+ w3*rql(j3)+w4*rql(j4)
+ end if
+ if (luseqr) then
+ tdir(iqr+n)=w1*sqr(j1)+w2*sqr(j2)+ w3*sqr(j3)+w4*sqr(j4)
+ rdir(iqr+n)=w1*rqr(j1)+w2*rqr(j2)+ w3*rqr(j3)+w4*rqr(j4)
+ end if
+ if (luseqs) then
+ tdir(iqs+n)=w1*sqs(j1)+w2*sqs(j2)+ w3*sqs(j3)+w4*sqs(j4)
+ rdir(iqs+n)=w1*rqs(j1)+w2*rqs(j2)+ w3*rqs(j3)+w4*rqs(j4)
+ end if
end if
- if (luseqs) then
- tdir(iqs+n)=w1*sqs(j1)+w2*sqs(j2)+ w3*sqs(j3)+w4*sqs(j4)
- rdir(iqs+n)=w1*rqs(j1)+w2*rqs(j2)+ w3*rqs(j3)+w4*rqs(j4)
+ if(n <= radptr%nchan)then
+ icx=radptr%icx(n)
+ vals_quad = zero_quad
+ valr_quad = zero_quad
+ do nx=1,npred
+ vals_quad = vals_quad + spred(nx,icx)*radptr%pred(nx,n)
+ valr_quad = valr_quad + rpred(nx,icx)*radptr%pred(nx,n)
+ end do
+ biasvects(n) = vals_quad
+ biasvectr(n) = valr_quad
end if
-
end do
- end if
- if(nstep > 0)then
- allocate(biasvects(radptr%nchan))
- allocate(biasvectr(radptr%nchan))
- do nn=1,radptr%nchan
- ic1=radptr%icx(nn)
- vals_quad = zero_quad
- valr_quad = zero_quad
- do nx=1,npred
- vals_quad = vals_quad + spred(nx,ic1)*radptr%pred(nx,nn)
- valr_quad = valr_quad + rpred(nx,ic1)*radptr%pred(nx,nn)
- end do
- biasvects(nn) = vals_quad
- biasvectr(nn) = valr_quad
- end do
endif
- ncr=0
+! !$omp parallel do schedule(dynamic,1) private(nn,ic,mm,ncr,k,kk,rad,val,val2,cg_rad,wnotgross,wgross)
do nn=1,radptr%nchan
- val2=-radptr%res(nn)
-
if(nstep > 0)then
val = zero
+ val2=-radptr%res(nn)
! contribution from bias corection
ic=radptr%icx(nn)
if(radptr%use_corr_obs) then
do mm=1,nn
- ncr=ncr+1
+ ncr=radptr%iccerr(nn)+mm
val2=val2+radptr%rsqrtinv(ncr)*biasvects(mm)
val =val +radptr%rsqrtinv(ncr)*biasvectr(mm)
end do
@@ -318,12 +343,12 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep)
rad(kk)=val2+sges(kk)*val
end do
else
- rad(kk)= val2
+ rad(1)= -radptr%res(nn)
end if
! calculate contribution to J
do kk=1,max(1,nstep)
- term(kk) = radptr%err2(nn)*rad(kk)*rad(kk)
+ term(kk,nn) = radptr%err2(nn)*rad(kk)*rad(kk)
end do
! Modify penalty term if nonlinear QC
@@ -333,18 +358,23 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep)
wnotgross= one-pg_rad(ic)*varqc_iter
wgross = varqc_iter*pg_rad(ic)*cg_rad/wnotgross
do kk=1,max(1,nstep)
- term(kk) = -two*log((exp(-half*term(kk) ) + wgross)/(one+wgross))
+ term(kk,nn) = -two*log((exp(-half*term(kk,nn) ) + wgross)/(one+wgross))
end do
endif
- out(1) = out(1) + term(1)*radptr%raterr2(nn)
+ end do
+
+ deallocate(biasvects, biasvectr)
+
+ do nn=1,radptr%nchan
+ out(1) = out(1) + term(1,nn)*radptr%raterr2(nn)
do kk=2,nstep
- out(kk) = out(kk) + (term(kk)-term(1))*radptr%raterr2(nn)
+ out(kk) = out(kk) + (term(kk,nn)-term(1,nn))*radptr%raterr2(nn)
end do
end do
- if(nstep > 0) deallocate(biasvects, biasvectr)
+ deallocate(term)
end if
diff --git a/src/gsi/stprw.f90 b/src/gsi/stprw.f90
index 710d9baa23..a61a53f54b 100644
--- a/src/gsi/stprw.f90
+++ b/src/gsi/stprw.f90
@@ -83,6 +83,7 @@ subroutine stprw(rwhead,rval,sval,out,sges,nstep)
!
!$$$
use kinds, only: r_kind,i_kind,r_quad
+ use obsmod, only: if_use_w_vr
use qcmod, only: nlnqc_iter,varqc_iter
use constants, only: half,one,two,tiny_r_kind,cg_term,zero_quad,r3600
use gsi_bundlemod, only: gsi_bundle
@@ -123,19 +124,13 @@ subroutine stprw(rwhead,rval,sval,out,sges,nstep)
ier=0
call gsi_bundlegetpointer(sval,'u',su,istatus);ier=istatus+ier
call gsi_bundlegetpointer(sval,'v',sv,istatus);ier=istatus+ier
- call gsi_bundlegetpointer(sval,'w',sw,istatus)
- if (istatus==0) then
- include_w=.true.
- else
- include_w=.false.
- end if
call gsi_bundlegetpointer(rval,'u',ru,istatus);ier=istatus+ier
call gsi_bundlegetpointer(rval,'v',rv,istatus);ier=istatus+ier
- call gsi_bundlegetpointer(rval,'w',rw,istatus)
- if (istatus==0) then
- include_w=.true.
- else
- include_w=.false.
+ include_w=.false.
+ call gsi_bundlegetpointer(sval,'w',sw,istatus)
+ if (if_use_w_vr.and.istatus==0) then
+ call gsi_bundlegetpointer(rval,'w',rw,istatus)
+ if(istatus == 0)include_w=.true.
end if
if(ier/=0)return
diff --git a/src/gsi/stpsst.f90 b/src/gsi/stpsst.f90
index 222b67862c..765676010b 100644
--- a/src/gsi/stpsst.f90
+++ b/src/gsi/stpsst.f90
@@ -101,13 +101,13 @@ subroutine stpsst(ssthead,rval,sval,out,sges,nstep)
real(r_kind) pg_sst
real(r_kind),pointer,dimension(:) :: ssst
real(r_kind),pointer,dimension(:) :: rsst
- real(r_kind) tdir,rdir
type(sstNode), pointer :: sstptr
out=zero_quad
! If no sst data return
if(.not. associated(ssthead))return
+ if(.not. nst_gsi > 2 ) return
! Retrieve pointers
! Simply return if any pointer not found
@@ -129,15 +129,12 @@ subroutine stpsst(ssthead,rval,sval,out,sges,nstep)
w3=sstptr%wij(3)
w4=sstptr%wij(4)
- if ( nst_gsi > 2 .and. (sstptr%tz_tr > zero .and. sstptr%tz_tr <= one) ) then
- tdir = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4)
- rdir = w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4)
- val = sstptr%tz_tr*rdir
- val2 = sstptr%tz_tr*tdir - sstptr%res
- else
- val =w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4)
- val2=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4)-sstptr%res
- endif
+ val =w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4)
+ val2=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4)
+
+ val = sstptr%tz_tr*val
+ val2 = sstptr%tz_tr*val2
+ val2=val2-sstptr%res
do kk=1,nstep
sst=val2+sges(kk)*val
diff --git a/src/gsi/stpt.f90 b/src/gsi/stpt.f90
index 27f5385ac1..5911d87b9d 100644
--- a/src/gsi/stpt.f90
+++ b/src/gsi/stpt.f90
@@ -184,7 +184,6 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred)
w6=tptr%wij(6)
w7=tptr%wij(7)
w8=tptr%wij(8)
-! Note time derivative stuff not consistent for virtual temperature
if(tptr%tv_ob)then
val= w1*rtv(j1)+w2*rtv(j2)+w3*rtv(j3)+w4*rtv(j4)+ &
@@ -208,9 +207,6 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred)
end do
end if
- do kk=1,nstep
- tt(kk)=val2+sges(kk)*val
- end do
if(tptr%use_sfc_model) then
@@ -229,8 +225,9 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred)
valv2=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4)
valp =w1* rp(j1)+w2* rp(j2)+w3* rp(j3)+w4* rp(j4)
valp2=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4)
+
do kk=1,nstep
- ts_prime=tt(kk)
+ ts_prime=val2+sges(kk)*val
tg_prime=valsst2+sges(kk)*valsst
qs_prime=valq2+sges(kk)*valq
us_prime=valu2+sges(kk)*valu
@@ -239,14 +236,18 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred)
tt(kk)=psfc_prime*tptr%tlm_tsfc(1) + tg_prime*tptr%tlm_tsfc(2) + &
ts_prime *tptr%tlm_tsfc(3) + qs_prime*tptr%tlm_tsfc(4) + &
- us_prime *tptr%tlm_tsfc(5) + vs_prime*tptr%tlm_tsfc(6)
+ us_prime *tptr%tlm_tsfc(5) + vs_prime*tptr%tlm_tsfc(6) - &
+ tptr%res
+ end do
+
+ else
+
+ do kk=1,nstep
+ tt(kk)=val2+sges(kk)*val-tptr%res
end do
end if
- do kk=1,nstep
- tt(kk)=tt(kk)-tptr%res
- end do
else
tt(1)=tptr%res
end if
diff --git a/src/gsi/stub_wrf_binary_interface.f90 b/src/gsi/stub_wrf_binary_interface.f90
index 201482df13..58ef9e004e 100644
--- a/src/gsi/stub_wrf_binary_interface.f90
+++ b/src/gsi/stub_wrf_binary_interface.f90
@@ -29,18 +29,26 @@ end subroutine convert_binary_mass_dummy
subroutine convert_binary_nmm_dummy(this,update_pint,ctph0,stph0,tlm0)
use kinds, only: r_kind
+ use constants, only: zero
implicit none
class(get_wrf_binary_interface_class), intent(inout) :: this
logical ,intent(inout) :: update_pint
real(r_kind),intent( out) :: ctph0,stph0,tlm0
+ ctph0 = zero
+ stph0 = zero
+ tlm0 = zero
end subroutine convert_binary_nmm_dummy
subroutine convert_nems_nmmb_dummy(this,update_pint,ctph0,stph0,tlm0)
use kinds, only: r_kind
+ use constants, only: zero
implicit none
class(get_wrf_binary_interface_class), intent(inout) :: this
logical ,intent(inout) :: update_pint
real(r_kind),intent( out) :: ctph0,stph0,tlm0
+ ctph0 = zero
+ stph0 = zero
+ tlm0 = zero
end subroutine convert_nems_nmmb_dummy
end module get_wrf_binary_interface_mod
diff --git a/src/gsi/stub_wrf_netcdf_interface.f90 b/src/gsi/stub_wrf_netcdf_interface.f90
index d80b765300..4235318686 100644
--- a/src/gsi/stub_wrf_netcdf_interface.f90
+++ b/src/gsi/stub_wrf_netcdf_interface.f90
@@ -30,12 +30,15 @@ end subroutine convert_netcdf_mass_dummy
subroutine convert_netcdf_nmm_dummy(this,update_pint,ctph0,stph0,tlm0,guess)
use kinds, only: r_single,i_kind,r_kind
+ use constants, only: zero
implicit none
class(convert_netcdf_class) ,intent(inout) :: this
logical ,intent(in ) :: guess
logical ,intent(inout) :: update_pint
real(r_kind),intent( out) :: ctph0,stph0,tlm0
-
+ ctph0 = zero
+ stph0 = zero
+ tlm0 = zero
end subroutine convert_netcdf_nmm_dummy
subroutine update_netcdf_mass_dummy(this)
diff --git a/src/gsi/support_2dvar.f90 b/src/gsi/support_2dvar.f90
index 35599ba548..0a83e96942 100644
--- a/src/gsi/support_2dvar.f90
+++ b/src/gsi/support_2dvar.f90
@@ -2465,19 +2465,19 @@ subroutine relocsfcob(rlon8,rlat8,cobtypein,cstationin,kxin)
js=max(1,(jstart-jneighbour))
je=min((jstart+jneighbour),ny)
- ris=float(is)
- rie=float(ie)
- rjs=float(js)
- rje=float(je)
+ ris=real(is,r_single)
+ rie=real(ie,r_single)
+ rjs=real(js,r_single)
+ rje=real(je,r_single)
distmin=1.e+20_r_single
lfound=.false.
do j=1,npts
- rj=rjs+float(j-1)*dy
+ rj=rjs+real(j-1,r_single)*dy
if (rj > rje) cycle
do i=1,npts
- ri=ris+float(i-1)*dx
+ ri=ris+real(i-1,r_single)*dx
if (ri > rie) cycle
call bilinear_2d0(slmask,nx,ny,slmask0,rj,ri)
@@ -2655,7 +2655,7 @@ subroutine mkvalley_file
endif
enddo
enddo
- hmean=hmean/max(1._r_single,float(ncount))
+ hmean=hmean/max(1._r_single,real(ncount,r_single))
if ((hmax-hmin)>=hdiff0 .and. terrain(i,j)0) then
ptr3dges = max(ptr3dges+ptr3dinc,zero)
@@ -454,7 +458,7 @@ subroutine update_guess(sval,sbias)
endif
call gsd_update_soil_tq(tinc_1st,is_t,qinc_1st,is_q,it)
endif ! l_gsd_soilTQ_nudge
- if (i_use_2mt4b > 0 .and. is_t>0) then
+ if ( (i_use_2mt4b > 0.or. hofx_2m_sfcfile) .and. is_t>0) then
do j=1,lon2
do i=1,lat2
tinc_1st(i,j)=p_tv(i,j,1)
@@ -462,7 +466,7 @@ subroutine update_guess(sval,sbias)
end do
call gsd_update_t2m(tinc_1st,it)
endif ! l_gsd_t2m_adjust
- if (i_use_2mq4b > 0 .and. is_q>0) then
+ if ( (i_use_2mq4b > 0.or. hofx_2m_sfcfile) .and. is_q>0) then
do j=1,lon2
do i=1,lat2
qinc_1st(i,j)=p_q(i,j,1)
diff --git a/src/gsi/vqc_int.f90 b/src/gsi/vqc_int.f90
index 714ee23ea3..12abc53b35 100644
--- a/src/gsi/vqc_int.f90
+++ b/src/gsi/vqc_int.f90
@@ -27,12 +27,12 @@ subroutine vqc_int(error2,rat_error2,t_pgv,cg_tv,var_jbv,ibv,ikv,valv,gradv)
real(r_kind), intent(out) :: gradv
! Declare local variables
- real(r_kind) wnotgross,wgross,g_nvqc,w_nvqc,p0,qq
+ real(r_kind) wnotgross,wgross,g_nvqc,w_nvqc,p0,qq
- if (vqc .and. nlnqc_iter .and. t_pgv > tiny_r_kind .and. &
+ if (vqc .and. nlnqc_iter .and. t_pgv > tiny_r_kind .and. &
cg_tv > tiny_r_kind) then
wnotgross= one-t_pgv
wgross =t_pgv*cg_tv/wnotgross
diff --git a/src/gsi/vqc_stp.f90 b/src/gsi/vqc_stp.f90
index 1c8f296853..04d9a91245 100644
--- a/src/gsi/vqc_stp.f90
+++ b/src/gsi/vqc_stp.f90
@@ -41,7 +41,7 @@ subroutine vqc_stp(pen_v,nstep_v,tpg_v,cgt_v,&
! Note: if wgross=0 (no gross error, then wnotgross=1 and this
! all reduces to the linear case (no qc)
- if (vqc .and. nlnqc_iter .and. tpg_v > tiny_r_kind .and. cgt_v >tiny_r_kind) then
+ if (vqc .and. nlnqc_iter .and. tpg_v > tiny_r_kind .and. cgt_v >tiny_r_kind) then
wnotgross= one-tpg_v
wgross =tpg_v*cgt_v/wnotgross
do kk=1,max(1,nstep_v)
diff --git a/src/gsi/wind_fft.f90 b/src/gsi/wind_fft.f90
index 449ceb120a..cc21843d8b 100644
--- a/src/gsi/wind_fft.f90
+++ b/src/gsi/wind_fft.f90
@@ -123,8 +123,8 @@ subroutine divvort_to_psichi(nx0,ny0,mmax0,nmax0,rld0,qg)
pi = four*atan(one)
- xmax = float(nx-1)
- ymax = float(ny-1)
+ xmax = real(nx-1,r_kind)
+ ymax = real(ny-1,r_kind)
! write(6,*) ' in divvort_to_psichi: xmax,ymax,=',xmax,ymax
!
!==> compute trig tables for fft routines.
@@ -134,14 +134,14 @@ subroutine divvort_to_psichi(nx0,ny0,mmax0,nmax0,rld0,qg)
!
!==> set up wavenumbers used in fourier differentiation.
do 100 i=1,nwavesx
- rk(i) = two*pi*float(i-1)/xmax
+ rk(i) = two*pi*real(i-1,r_kind)/xmax
100 continue
ny2 = (ny/2)+1
do 200 j=1,ny
mm = j/ny2
m = mm*ny+1
- wavey = two*pi*float(j-m)/ymax
+ wavey = two*pi*real(j-m,r_kind)/ymax
if (j<=nmax+1 .or. j>=ny-nmax+1) then
indx = j-m+nmax+1
indxy(indx) = j
diff --git a/src/gsi/windht.f90 b/src/gsi/windht.f90
index 09207d38b8..bd685155c4 100644
--- a/src/gsi/windht.f90
+++ b/src/gsi/windht.f90
@@ -139,7 +139,7 @@ subroutine destroy_windht_lists
end subroutine destroy_windht_lists
- subroutine find_wind_height(cprov,csubprov,finalheight)
+ subroutine find_wind_height(cprov,csubprov,finalheight,kcount)
!abstract: Find provider and subprovider in pre-determined arrays
!Then return wind sensor height
@@ -149,6 +149,7 @@ subroutine find_wind_height(cprov,csubprov,finalheight)
character(len=8),intent(in)::cprov,csubprov
real(r_kind),intent(out)::finalheight
+ integer,dimension(3),intent(inout)::kcount
!local vars
integer(i_kind)::i
@@ -156,16 +157,35 @@ subroutine find_wind_height(cprov,csubprov,finalheight)
!sanity check
if (.not.fexist) then
- print*, "WARNING: File containing sensor heights does not exist. Defaulting to 10 m..."
+
+ if(kcount(1) < 10)then
+ print*, "WARNING: File containing sensor heights does not exist. Defaulting to 10 m..."
+ else if(kcount(1) == 10)then
+ print*, "WARNING: List of providers not properly in memory. Defaulting to 10 m..."
+ print*, "Many values see kcount (1) below "
+ end if
+ kcount(1) = kcount(1) + 1
finalheight=r10
return
elseif(.not.listexist) then
- print*, "WARNING: List of providers not properly in memory. Defaulting to 10 m..."
+ if(kcount(2) < 10)then
+ print*, "WARNING: List of providers not properly in memory. Defaulting to 10 m..."
+ else if(kcount(2) == 10)then
+ print*, "WARNING: List of providers not properly in memory. Defaulting to 10 m..."
+ print*, "Many values see kcount (2) below "
+ end if
+ kcount(2) = kcount(2) + 1
finalheight=r10
return
elseif (numprovs>nmax) then
- print*, "WARNING: Invalid number of provider/subprovider combinations (number,max)=",numprovs,nmax
- print*, "WARNING: Defaulting to 10 m wind sensor height!"
+ if(kcount(3) < 10)then
+ print*, "WARNING: Invalid number of provider/subprovider combinations (number,max)=",numprovs,nmax
+ print*, "WARNING: Defaulting to 10 m wind sensor height!"
+ else if(kcount(3) == 10)then
+ print*, "WARNING: Invalid number of provider/subprovider combinations (number,max)=",numprovs,nmax
+ print*, "Many values see kcount (3) below "
+ end if
+ kcount(3) = kcount(3) + 1
finalheight=r10
return
endif
diff --git a/src/gsi/wrf_vars_mod.f90 b/src/gsi/wrf_vars_mod.f90
index 97c36c43cf..f7a5e6c83d 100644
--- a/src/gsi/wrf_vars_mod.f90
+++ b/src/gsi/wrf_vars_mod.f90
@@ -39,6 +39,8 @@ module wrf_vars_mod
use mpimod, only: mype
use control_vectors, only: nc3d,cvars3d
use kinds, only: i_kind
+use gsi_metguess_mod, only: gsi_metguess_get
+use constants, only: max_varname_length
implicit none
private
! public methods
@@ -46,21 +48,54 @@ module wrf_vars_mod
! common block variables
public :: w_exist
public :: dbz_exist
+public :: fed_exist
-logical,save :: w_exist, dbz_exist
+logical,save :: w_exist, dbz_exist, fed_exist
contains
subroutine init_wrf_vars
-integer(i_kind) ii
+integer(i_kind) ii,istatus
+character(max_varname_length),allocatable,dimension(:) :: cloud
+integer(i_kind) ncloud
+logical :: dbz_cloud_exist,fed_cloud_exist
w_exist=.false.
dbz_exist=.false.
+fed_exist=.false.
+dbz_cloud_exist=.false.
+fed_cloud_exist=.false.
+
do ii=1,nc3d
if(mype == 0 ) write(6,*)"anacv cvars3d is ",cvars3d(ii)
if(trim(cvars3d(ii)) == 'w'.or.trim(cvars3d(ii))=='W') w_exist=.true.
if(trim(cvars3d(ii))=='dbz'.or.trim(cvars3d(ii))=='DBZ') dbz_exist=.true.
+ if(trim(cvars3d(ii))=='fed'.or.trim(cvars3d(ii))=='FED') fed_exist=.true.
enddo
+! Inquire about clouds
+
+call gsi_metguess_get('clouds::3d',ncloud,istatus)
+if (ncloud>0) then
+ allocate(cloud(ncloud))
+ call gsi_metguess_get('clouds::3d',cloud,istatus)
+endif
+
+do ii=1,ncloud
+ if(mype == 0 ) write(6,*)"metguess cloud3d is ",cloud(ii)
+ if(trim(cloud(ii))=='fed'.or.trim(cloud(ii))=='FED')fed_cloud_exist=.true.
+ if(trim(cloud(ii))=='dbz'.or.trim(cloud(ii))=='DBZ')dbz_cloud_exist=.true.
+end do
+
+if(.not.fed_exist .or. .not.fed_cloud_exist )then
+ fed_exist=.false.
+endif
+
+if(.not.dbz_exist .or. .not.dbz_cloud_exist )then
+ dbz_exist=.false.
+endif
+
+if(ncloud>0) deallocate(cloud)
+
end subroutine init_wrf_vars
end module wrf_vars_mod
diff --git a/src/gsi/write_fv3_spread.f90 b/src/gsi/write_fv3_spread.f90
index 4baef4c6bd..e1348c9449 100644
--- a/src/gsi/write_fv3_spread.f90
+++ b/src/gsi/write_fv3_spread.f90
@@ -227,10 +227,10 @@ subroutine write_fv3_enspread_ (grdin,filename,en_spread,ibin)
start = (/1/), count = (/grdin%nlon,grdin%nlat/)))
! levels
do k=1,grdin%nsig
- levsout(k) = float(k)
- ilevsout(k) = float(k)
+ levsout(k) = real(k,r_kind)
+ ilevsout(k) = real(k,r_kind)
end do
- ilevsout(grdin%nsig+1) = float(grdin%nsig+1)
+ ilevsout(grdin%nsig+1) = real(grdin%nsig+1,r_kind)
! write to file
call ncceck_enspread(nf90_put_var(ncid_out, levvarid, sngl(levsout), &
start = (/1/), count = (/grdin%nsig/)))
diff --git a/src/gsi/write_incr.f90 b/src/gsi/write_incr.f90
index 69ad96e281..02160c9ccd 100644
--- a/src/gsi/write_incr.f90
+++ b/src/gsi/write_incr.f90
@@ -26,7 +26,7 @@ module write_incr
contains
- subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin)
+ subroutine write_fv3_inc_ (grd,filename,mype_out,gfs_bundle,ibin)
!$$$ subprogram documentation block
! . . .
@@ -76,6 +76,7 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin)
use general_sub2grid_mod, only: sub2grid_info
use gsi_bundlemod, only: gsi_bundle, gsi_bundlegetpointer
+ use gsi_bundlemod, only: assignment(=)
use control_vectors, only: control_vector
use constants, only: one, rad2deg, r1000
@@ -93,13 +94,14 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin)
use state_vectors, only: svars3d
use mpeu_util, only: getindex
+ use control2state_mod, only: control2state
+ use ensctl2state_mod, only: ensctl2state
implicit none
! !INPUT PARAMETERS:
type(sub2grid_info), intent(in) :: grd
- type(spec_vars), intent(in) :: sp_a
character(len=24), intent(in) :: filename ! file to open and write to
integer(i_kind), intent(in) :: mype_out ! mpi task to write output file
type(gsi_bundle), intent(in) :: gfs_bundle
@@ -158,7 +160,6 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin)
! set up state space based off of xhatsave
! Convert from control space directly to physical
! space for comparison with obs.
- call allocate_preds(sbiasinc)
do iii=1,nobs_bins
call allocate_state(svalinc(iii))
end do
@@ -168,7 +169,10 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin)
do iii=1,ntlevs_ens
call allocate_state(evalinc(iii))
end do
+
+ call allocate_preds(sbiasinc)
call control2state(xhatsave,mvalinc,sbiasinc)
+ call deallocate_preds(sbiasinc)
if (l4dvar) then
if (l_hyb_ens) then
@@ -193,6 +197,12 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin)
end do
end if
end if
+ do iii=1,ntlevs_ens
+ call deallocate_state(evalinc(iii))
+ end do
+ do iii=1,nsubwin
+ call deallocate_state(mvalinc(iii))
+ end do
! Check hydrometeors in control variables
iql = getindex(svars3d,'ql')
@@ -334,10 +344,10 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin)
start = (/1/), count = (/grd%nlon/)))
! levels
do k=1,grd%nsig
- levsout(k) = float(k)
- ilevsout(k) = float(k)
+ levsout(k) = real(k,r_kind)
+ ilevsout(k) = real(k,r_kind)
end do
- ilevsout(grd%nsig+1) = float(grd%nsig+1)
+ ilevsout(grd%nsig+1) = real(grd%nsig+1,r_kind)
! write to file
call nccheck_incr(nf90_put_var(ncid_out, levvarid, sngl(levsout), &
start = (/1/), count = (/grd%nsig/)))
@@ -366,10 +376,9 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin)
ncstart = (/ jstart(mype+1), 1, 1 /)
nccount = (/ grd%lon1, grd%lat1-1, grd%nsig /)
j1 = 2
- j2 = grd%lat1-1
else if (istart(mype+1)+grd%lat1 == grd%nlat+1) then
nccount = (/ grd%lon1, grd%lat1-1, grd%nsig /)
- j2 = grd%lat1-2
+ j2 = grd%lat1-1
end if
call mpi_barrier(mpi_comm_world,ierror)
allocate(out3d(nccount(1),nccount(2),grd%nsig))
@@ -528,6 +537,10 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin)
endif
! ! cleanup and exit
call nccheck_incr(nf90_close(ncid_out))
+ deallocate(out3d)
+ do iii=1,nobs_bins
+ call deallocate_state(svalinc(iii))
+ end do
if ( mype == mype_out ) then
write(6,*) "FV3 netCDF increment written, file= "//trim(filename)//".nc"
end if
diff --git a/src/gsi/xhat_vordivmod.f90 b/src/gsi/xhat_vordivmod.f90
index bff52aa9d4..e271fb9fb3 100644
--- a/src/gsi/xhat_vordivmod.f90
+++ b/src/gsi/xhat_vordivmod.f90
@@ -77,6 +77,8 @@ subroutine init_
allocate(xhat_vor(lat2,lon2,nsig,nobs_bins))
allocate(xhat_div(lat2,lon2,nsig,nobs_bins))
+ xhat_vor=zero
+ xhat_div=zero
end subroutine init_
subroutine clean_
@@ -146,18 +148,6 @@ subroutine calc_(sval)
!*******************************************************************************
-! Initialize local arrays
- do ii=1,nobs_bins
- do k=1,nsig
- do j=1,lon2
- do i=1,lat2
- xhat_vor(i,j,k,ii) = zero
- xhat_div(i,j,k,ii) = zero
- end do
- end do
- end do
- end do
-
! The GSI analyzes stream function (sf) and velocity potential (vp).
! Wind field observations are in terms of zonal (u) and meridional
! (v) wind components or wind speed. Thus, the GSI carries wind
diff --git a/src/mgbf/CMakeLists.txt b/src/mgbf/CMakeLists.txt
new file mode 100644
index 0000000000..9ee36c8329
--- /dev/null
+++ b/src/mgbf/CMakeLists.txt
@@ -0,0 +1,98 @@
+cmake_minimum_required(VERSION 3.15)
+
+project(mgbf
+ VERSION 1.0.0
+ LANGUAGES Fortran)
+
+list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake")
+set(CMAKE_DIRECTORY_LABELS ${PROJECT_NAME})
+
+include(GNUInstallDirs)
+
+if(NOT CMAKE_BUILD_TYPE MATCHES "^(Debug|Release|RelWithDebInfo|MinSizeRel)$")
+ message(STATUS "Setting build type to 'Release' as none was specified.")
+ set(CMAKE_BUILD_TYPE
+ "Release"
+ CACHE STRING "Choose the type of build." FORCE)
+ set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" "MinSizeRel" "RelWithDebInfo")
+endif()
+
+if(NOT CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU|Intel)$")
+ message(WARNING "${CMAKE_Fortran_COMPILER_ID} is not supported.")
+endif()
+
+if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$")
+ set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -g -traceback -convert big_endian")
+elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$")
+ set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -g -fbacktrace -fconvert=big-endian")
+endif()
+
+if(NOT CMAKE_BUILD_TYPE MATCHES "Debug")
+ add_definitions(-DNDEBUG)
+endif()
+
+list(APPEND MGBF_SRC
+kinds.f90
+jp_pkind.f90
+jp_pkind2.f90
+jp_pietc.f90
+jp_pietc_s.f90
+jp_pmat.f90
+jp_pmat4.f90
+jp_pbfil.f90
+jp_pbfil2.f90
+jp_pbfil3.f90
+mg_mppstuff.f90
+mg_domain.f90
+mg_domain_loc.f90
+mg_parameter.f90
+mg_bocos.f90
+mg_transfer.f90
+mg_generations.f90
+mg_interpolate.f90
+mg_filtering.f90
+mg_timers.f90
+mg_entrymod.f90
+mg_intstate.f90
+mg_input.f90
+)
+
+set(module_dir "${CMAKE_CURRENT_BINARY_DIR}/include/mgbf")
+add_library(mgbf STATIC ${MGBF_SRC})
+add_library(${PROJECT_NAME}::mgbf ALIAS mgbf)
+set_target_properties(mgbf PROPERTIES Fortran_MODULE_DIRECTORY "${module_dir}")
+target_include_directories(mgbf PUBLIC $
+ $)
+
+install(DIRECTORY ${module_dir} DESTINATION ${CMAKE_INSTALL_PREFIX}/include)
+
+install(TARGETS mgbf
+ EXPORT ${PROJECT_NAME}Exports
+ LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}
+ ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR})
+
+# Package config
+include(CMakePackageConfigHelpers)
+set(CONFIG_INSTALL_DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME})
+
+export(EXPORT ${PROJECT_NAME}Exports
+ NAMESPACE ${PROJECT_NAME}::
+ FILE ${PROJECT_NAME}-targets.cmake)
+
+configure_package_config_file(
+ ${CMAKE_CURRENT_SOURCE_DIR}/cmake/PackageConfig.cmake.in ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config.cmake
+ INSTALL_DESTINATION ${CONFIG_INSTALL_DESTINATION})
+install(FILES ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config.cmake
+ DESTINATION ${CONFIG_INSTALL_DESTINATION})
+
+write_basic_package_version_file(
+ ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake
+ VERSION ${PROJECT_VERSION}
+ COMPATIBILITY AnyNewerVersion)
+install(FILES ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake
+ DESTINATION ${CONFIG_INSTALL_DESTINATION})
+
+install(EXPORT ${PROJECT_NAME}Exports
+ NAMESPACE ${PROJECT_NAME}::
+ FILE ${PROJECT_NAME}-targets.cmake
+ DESTINATION ${CONFIG_INSTALL_DESTINATION})
diff --git a/src/mgbf/cmake/PackageConfig.cmake.in b/src/mgbf/cmake/PackageConfig.cmake.in
new file mode 100644
index 0000000000..e64cb4ef87
--- /dev/null
+++ b/src/mgbf/cmake/PackageConfig.cmake.in
@@ -0,0 +1,19 @@
+@PACKAGE_INIT@
+
+#@PROJECT_NAME@-config.cmake
+#
+# Imported interface targets provided:
+# * @PROJECT_NAME@::MGBF - MGBF library target
+
+# Include targets file. This will create IMPORTED target @PROJECT_NAME@
+include("${CMAKE_CURRENT_LIST_DIR}/@PROJECT_NAME@-targets.cmake")
+include("${CMAKE_CURRENT_LIST_DIR}/@PROJECT_NAME@-config-version.cmake")
+include(CMakeFindDependencyMacro)
+
+# Get the build type from library target
+get_target_property(@PROJECT_NAME@_BUILD_TYPES @PROJECT_NAME@::@PROJECT_NAME@ IMPORTED_CONFIGURATIONS)
+
+check_required_components("@PROJECT_NAME@")
+
+get_target_property(location @PROJECT_NAME@::@PROJECT_NAME@ LOCATION)
+message(STATUS "Found @PROJECT_NAME@: ${location} (found version \"${PACKAGE_VERSION}\")")
diff --git a/src/mgbf/jp_pbfil.f90 b/src/mgbf/jp_pbfil.f90
new file mode 100644
index 0000000000..89a9196596
--- /dev/null
+++ b/src/mgbf/jp_pbfil.f90
@@ -0,0 +1,1119 @@
+submodule(mg_parameter) jp_pbfil
+!$$$ submodule documentation block
+! . . . .
+! module: jp_pbfil
+! prgmmr: purser org: NOAA/EMC date: 2019-03
+!
+! abstract: Codes for the beta filters
+!
+! module history log:
+! 2023-04-19 lei - object-oriented coding
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! cholaspect1 -
+! cholaspect2 -
+! cholaspect3 -
+! cholaspect4 -
+! getlinesum1 -
+! getlinesum2 -
+! getlinesum3 -
+! getlinesum4 -
+! rbeta1 -
+! rbeta2 -
+! rbeta3 -
+! rbeta4 -
+! vrbeta4 -
+! rbeta1T -
+! rbeta2T -
+! rbeta3T -
+! rbeta4T -
+! vrbeta4t -
+! vrbeta1 -
+! vrbeta2 -
+! vrbeta3 -
+! vrbeta1T -
+! vrbeta2T -
+! vrbeta3T -
+!
+! Functions Included:
+!
+! remarks:
+! The filters invoke the aspect tensor information encoded by the
+! Cholesky lower-triangular factors, el, of the INVERSE aspect tensors.
+! The routines, "cholaspect", convert (in place) the field of given
+! aspect tensors A to the equivalent cholesky factors of A^(-1).
+! The routines, "getlinesum" precompute the normalization coefficients
+! for each line (row) of the implied matrix form of the beta filter
+! so that the normalized line sum associated with each point of
+! application becomes unity.
+! This makes the application of each filter significantly faster
+! than having to work out the normalization on the fly.
+! Be sure to have run cholaspect, and then getlinesum, prior to applying
+! the beta filters themselves.
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+use kinds, only: dp=>r_kind
+use jp_pietc, only: u1
+implicit none
+
+contains
+
+!=============================================================================
+module subroutine cholaspect1(lx,mx, el) ! [cholaspect]
+!=============================================================================
+! Convert the given field, el, of aspect tensors into the equivalent
+! field
+! of Cholesky lower-triangular factors of the inverses of the aspect
+! tensors.
+!=============================================================================
+use jp_pmat, only: inv, l1lm
+integer, intent(in ):: lx,mx
+real(dp),dimension(1,1,lx:mx),intent(inout):: el
+!-----------------------------------------------------------------------------
+integer :: ix
+!=============================================================================
+do ix=lx,mx; el(1,1,ix)=u1/sqrt(el(1,1,ix)); enddo
+end subroutine cholaspect1
+!=============================================================================
+module subroutine cholaspect2(lx,mx, ly,my, el) ! [cholaspect]
+!=============================================================================
+! Convert the given field, el, of aspect tensors into the equivalent
+! field
+! of Cholesky lower-triangular factors of the inverses of the aspect
+! tensors.
+!=============================================================================
+use jp_pmat, only: inv, l1lm
+integer, intent(in ):: lx,mx, ly,my
+real(dp),dimension(2,2,lx:mx,ly:my),intent(inout):: el
+!-----------------------------------------------------------------------------
+real(dp),dimension(2,2):: tel
+integer :: ix,iy
+!=============================================================================
+do iy=ly,my; do ix=lx,mx
+ tel=el(:,:,ix,iy); call inv(tel); call l1lm(tel,el(:,:,ix,iy))
+enddo; enddo
+end subroutine cholaspect2
+!=============================================================================
+module subroutine cholaspect3(lx,mx, ly,my, lz,mz, el) ! [cholaspect]
+!=============================================================================
+! Convert the given field, el, of aspect tensors into the equivalent
+! field
+! of Cholesky lower-triangular factors of the inverses of the aspect
+! tensors.
+!=============================================================================
+use jp_pmat, only: inv, l1lm
+integer, intent(in ):: lx,mx, ly,my, lz,mz
+real(dp),dimension(3,3,lx:mx,ly:my,lz:mz),intent(inout):: el
+!-----------------------------------------------------------------------------
+real(dp),dimension(3,3):: tel
+integer :: ix,iy,iz
+!=============================================================================
+do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ tel=el(:,:,ix,iy,iz); call inv(tel); call l1lm(tel,el(:,:,ix,iy,iz))
+enddo; enddo; enddo
+end subroutine cholaspect3
+!=============================================================================
+module subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el) ! [cholaspect]
+!=============================================================================
+! Convert the given field, el, of aspect tensors into the equivalent
+! field
+! of Cholesky lower-triangular factors of the inverses of the aspect
+! tensors.
+!=============================================================================
+use jp_pmat, only: inv, l1lm
+integer, intent(in ):: lx,mx, ly,my, lz,mz, lw,mw
+real(dp),dimension(4,4,lx:mx,ly:my,lz:mz,lw:mw),&
+ intent(inout):: el
+!-----------------------------------------------------------------------------
+real(dp),dimension(4,4):: tel
+integer :: ix,iy,iz,iw
+!=============================================================================
+do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ tel=el(:,:,ix,iy,iz,iw); call inv(tel); call l1lm(tel,el(:,:,ix,iy,iz,iw))
+enddo; enddo; enddo; enddo
+end subroutine cholaspect4
+
+!=============================================================================
+module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [getlinesum]
+!=============================================================================
+! Get inverse of the line-sum of the matrix representing the
+! unnormalized
+! beta function with aspect tensor pasp=(el*el^T)^(-1), and invert the
+! result
+! so it can be used subsequently in the normalized version of this
+! filter.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx
+real(dp),dimension(1,1,Lx:Mx),intent(in ):: el
+real(dp),dimension(lx:mx),intent( out):: ss
+!-----------------------------------------------------------------------------
+real(dp),parameter:: eps=1.e-12
+real(dp) :: s,rr,rrc,exx,x
+integer :: ix,gxl,gxm,gx
+!=============================================================================
+do ix=Lx,Mx
+ s=0
+ exx=el(1,1,ix)*this%rmom2_1
+ x=u1/exx
+ gxl=ceiling(-x+eps); gxm=floor( x-eps)
+ if(gxl<-hx.or.gxm>hx)&
+ stop 'In getlinesum1; filter reach fx becomes too large for hx'
+ do gx=gxl,gxm
+ x=gx
+ rr=(x*exx)**2; rrc=u1-rr
+ s=s+rrc**this%p
+ enddo
+ ss(ix)=u1/s
+enddo
+end subroutine getlinesum1
+!=============================================================================
+module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum]
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx, &
+ hy,ly,my
+real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el
+real(dp),dimension( lx:mx,ly:my),intent( out):: ss
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(2,2):: tel
+real(dp) :: s,rr,rrx,rrc,exx,eyy,eyx,x,y,xc
+integer :: ix,gx,gxl,gxm
+integer :: iy,gy,gyl,gym
+!=============================================================================
+do iy=Ly,My; do ix=Lx,Mx
+ s=0
+ tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled
+ exx=tel(1,1); eyy=tel(2,2)
+ eyx=tel(2,1)
+ y=u1/eyy
+ gyl=ceiling(-y+eps); gym=floor( y-eps)
+ if(gyl<-hy.or.gym>hy)&
+ stop 'In getlinesum2; filter reach becomes too large for hy'
+ do gy=gyl,gym
+ y=gy; xc=-y*eyx
+ rrx=(y*eyy)**2; x=sqrt(u1-rrx)
+ gxl=ceiling((xc-x)/exx+eps); gxm=floor((xc+x)/exx-eps)
+ if(gxl<-hx.or.gxm>hx)&
+ stop 'In getlinesum2; filter reach becomes too large for hx'
+ do gx=gxl,gxm
+ x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ s=s+rrc**this%p
+ enddo! gx
+ enddo! gy
+ ss(ix,iy)=u1/s
+enddo; enddo! ix, iy
+end subroutine getlinesum2
+!=============================================================================
+module subroutine getlinesum3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss) ! [getlinesum]
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx, &
+ hy,ly,my, &
+ hz,lz,mz
+real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el
+real(dp),dimension( lx:mx,ly:my,lz:mz),intent( out):: ss
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(3,3):: tel
+real(dp) :: s,rr,rrx,rry,rrc,&
+ exx,eyy,ezz,eyx,ezx,ezy, x,y,z,xc,yc
+integer :: ix,gx,gxl,gxm
+integer :: iy,gy,gyl,gym
+integer :: iz,gz,gzl,gzm
+!=============================================================================
+ss=0
+do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx
+ s=0
+ tel=el(:,:,ix,iy,iz)*this%rmom2_3
+ exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3)
+ eyx=tel(2,1); ezx=tel(3,1)
+ ezy=tel(3,2)
+ z=u1/ezz
+ gzl=ceiling(-z+eps); gzm=floor( z-eps)
+ if(gzl<-hz.or.gzm>hz)&
+ stop 'In getlinesum3; filter reach becomes too large for hz'
+ do gz=gzl,gzm
+ z=gz; yc=-z*ezy
+ rry=(z*ezz)**2; y =sqrt(u1-rry)
+ gyl=ceiling((yc-y)/eyy+eps); gym=floor((yc+y)/eyy-eps)
+ if(gyl<-hy.or.gym>hy)&
+ stop 'In getlinesum3; filter reach becomes too large for hy'
+ do gy=gyl,gym
+ y=gy; xc=-y*eyx-z*ezx
+ rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx)
+ gxl=ceiling((xc-x)/exx+eps); gxm=floor((xc+x)/exx-eps)
+ if(gxl<-hx.or.gxm>hx)&
+ stop 'In getlinesum3; filter reach becomes too large for hx'
+ do gx=gxl,gxm
+ x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ s=s+rrc**this%p
+ enddo! gx
+ enddo! gy
+ enddo! gz
+ ss(ix,iy,iz)=u1/s
+enddo; enddo; enddo! ix, iy, iz
+end subroutine getlinesum3
+!=============================================================================
+module subroutine getlinesum4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, &
+ el, ss) ! [getlinesum]
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx, &
+ hy,ly,my, &
+ hz,lz,mz, &
+ hw,lw,mw
+real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el
+real(dp),dimension( lx:mx,ly:my,lz:mz,Lw:Mw),intent( out):: ss
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(4,4):: tel
+real(dp) :: s,rr,rrx,rry,rrz,rrc, &
+ exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz, x,y,z,w,&
+ xc,yc,zc
+integer :: ix,gx,gxl,gxm
+integer :: iy,gy,gyl,gym
+integer :: iz,gz,gzl,gzm
+integer :: iw,gw,gwl,gwm
+!=============================================================================
+ss=0
+do iw=Lw,Mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx
+ s=0
+ tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4
+ exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4)
+ eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1)
+ ezy=tel(3,2); ewy=tel(4,2)
+ ewz=tel(4,3)
+ w=u1/eww
+ gwl=ceiling(-w+eps); gwm=floor( w-eps)
+ if(gwl<-hw.or.gwm>hw)&
+ stop 'In getlinesum4; filter reach becomes too large for hw'
+ do gw=gwl,gwm
+ w=gw; zc=-w*ewz
+ rrz=(w-eww)**2; z =sqrt(u1-rrz)
+ gzl=ceiling((zc-z)/ezz+eps); gzm=floor((zc+z)/ezz-eps)
+ if(gzl<-hz.or.gzm>hz)&
+ stop 'In getlinesum4; filter reach becomes too large for hz'
+ do gz=gzl,gzm
+ z=gz; yc=-z*ezy-w*ewy
+ rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry)
+ gyl=ceiling((yc-y)/eyy+eps); gym=floor((yc+y)/eyy-eps)
+ if(gyl<-hy.or.gym>hy)&
+ stop 'In getlinesum4; filter reach becomes too large for hy'
+ do gy=gyl,gym
+ y=gy; xc=-y*eyx-z*ezx-w*ewx
+ rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx)
+ gxl=ceiling((xc-x)/exx+eps); gxm=floor((xc+x)/exx-eps)
+ if(gxl<-hx.or.gxm>hx)&
+ stop 'In getlinesum4; filter reach becomes too large for hx'
+ do gx=gxl,gxm
+ x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ s=s+rrc**this%p
+ enddo! gx
+ enddo! gy
+ enddo! gz
+ enddo! gw
+ ss(ix,iy,iz,iw)=u1/s
+enddo; enddo; enddo; enddo! ix, iy, iz, iw
+end subroutine getlinesum4
+
+!=============================================================================
+module subroutine rbeta1(this,hx,lx,mx, el,ss, a) ! [rbeta]
+!=============================================================================
+! Perform a radial beta-function filter in 1D.
+! It averages the surrounding density values, and so preserves the value
+! (in its target region) when presented with a constant-density input
+! field.
+! The input data occupy the extended region:
+! Lx-hx <= jx <= mx+hx.
+! The output data occupy the central region
+! Lx <= ix <= Mx.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx
+real(dp),dimension( Lx:Mx), intent(in ):: el
+real(dp),dimension( Lx:Mx), intent(in ):: ss
+real(dp),dimension(lx-hx:mx+hx),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(lx-hx:mx+hx):: b
+real(dp) :: x,tb,s,rr,rrc,frow,exx
+integer :: ix,jx,gx
+!=============================================================================
+b=0
+do ix=Lx,Mx
+ tb=0; s=ss(ix)
+ exx=el(ix)*this%rmom2_1
+ x=u1/exx
+ do gx=ceiling(-x+eps),floor( x-eps)
+ jx=ix+gx; x=gx
+ rr=(x*exx)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ tb=tb+frow*a(jx)
+ enddo
+ b(ix)=tb
+enddo
+a=b
+end subroutine rbeta1
+!=============================================================================
+module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta]
+!=============================================================================
+! Perform a radial beta-function filter in 2D.
+! It averages the surrounding density values, and so preserves the value
+! (in its target region) when presented with a constant-density input
+! field.
+! The input data occupy the extended region:
+! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy
+! The output data occupy the central region
+! Lx <= ix <= Mx, Ly <= iy <= My.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx, &
+ hy,ly,my
+real(dp),dimension(2,2,Lx:Mx,Ly:My), intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy):: b
+real(dp),dimension(2,2) :: tel
+real(dp) :: tb,s,rr,rrx,rrc,&
+ frow,exx,eyy,eyx,x,y,xc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+!=============================================================================
+b=0
+do iy=Ly,My; do ix=Lx,Mx
+ tb=0; s=ss(ix,iy)
+ tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled
+ exx=tel(1,1); eyy=tel(2,2)
+ eyx=tel(2,1)
+ y=u1/eyy
+ do gy=ceiling(-y+eps),floor( y-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx
+ rrx=(y*eyy)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ tb=tb+frow*a(jx,jy)
+ enddo! gx
+ enddo! gy
+ b(ix,iy)=tb
+enddo; enddo! ix, iy
+a=b
+end subroutine rbeta2
+!=============================================================================
+module subroutine rbeta3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta]
+!=============================================================================
+! Perform a radial beta-function filter in 3D.
+! It averages the surrounding density values, and so preserves the value
+! (in its target region) when presented with a constant-density input
+! field.
+! The input data occupy the extended region:
+! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy, Lz-hz <= Jz <= mz+hz
+! The output data occupy the central region
+! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx,&
+ hy,ly,my,&
+ hz,lz,mz
+real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz), intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz), intent(in ):: ss
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,&
+ lz-hz:mz+hz),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz):: b
+real(dp),dimension(3,3) :: tel
+real(dp):: s,tb,rr,rrx,rry,rrc,frow,&
+ exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+integer :: iz,jz,gz
+!=============================================================================
+b=0
+do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx
+ tb=0; s=ss(ix,iy,iz)
+ tel=el(:,:,ix,iy,iz)*this%rmom2_3
+ exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3)
+ eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2)
+ z=u1/ezz
+ do gz=ceiling(-z+eps),floor( z-eps)
+ jz=iz+gz; z=gz; yc=-z*ezy
+ rry=(z*ezz)**2; y =sqrt(u1-rry)
+ do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx-z*ezx
+ rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ tb=tb+frow*a(jx,jy,jz)
+ enddo! gx
+ enddo! gy
+ enddo! gz
+ b(ix,iy,iz)=tb
+enddo; enddo; enddo! ix, iy, iz
+a=b
+end subroutine rbeta3
+!=============================================================================
+module subroutine rbeta4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a) ! [rbeta]
+!=============================================================================
+! Perform a radial beta-function filter in 4D.
+! It averages the surrounding density values, and so preserves the value
+! (in its target region) when presented with a constant-density input
+! field.
+! The input data occupy the extended region:
+! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy, Lz-hz <= Jz <= mz+hz,
+! Lw-hw <= Jw <= mw+hw
+! The output data occupy the central region
+! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz, Lw <= iw <= Mw.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx,&
+ hy,ly,my,&
+ hz,lz,mz,&
+ hw,lw,mw
+real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy, &
+ lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,&
+ lz-hz:mz+hz,lw-hw:mw+hw) :: b
+real(dp),dimension(4,4) :: tel
+real(dp):: s,tb,rr,rrx,rry,rrz,rrc,frow,&
+ exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz,x,y,z,w,xc,yc,zc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+integer :: iz,jz,gz
+integer :: iw,jw,gw
+!=============================================================================
+b=0
+do iw=lw,mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx
+ tb=0; s=ss(ix,iy,iz,iw)
+ tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4
+ exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4)
+ eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1)
+ ezy=tel(3,2); ewy=tel(4,2)
+ ewz=tel(4,3)
+ w=u1/eww
+ do gw=ceiling(-w+eps),floor( w-eps)
+ jw=iw+gw; w=gw; zc=-w*ewz
+ rrz=(w*eww)**2; z =sqrt(u1-rrz)
+ do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps)
+ jz=iz+gz; z=gz; yc=-z*ezy-w*ewy
+ rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry)
+ do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx
+ rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ tb=tb+frow*a(jx,jy,jz,jw)
+ enddo! gx
+ enddo! gy
+ enddo! gz
+ enddo! gw
+ b(ix,iy,iz,iw)=tb
+enddo; enddo; enddo; enddo! ix, iy, iz, iw
+a=b
+end subroutine rbeta4
+
+!=============================================================================
+! Vector versions of the above routines:
+!=============================================================================
+module subroutine vrbeta4(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, &
+ el,ss,a) ! [rbeta]
+!=============================================================================
+! Vector version of rbeta4 filtering nv fields at once.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: nv, &
+ hx,Lx,mx,&
+ hy,ly,my,&
+ hz,lz,mz,&
+ hw,lw,mw
+real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy, &
+ lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,&
+ lz-hz:mz+hz,lw-hw:mw+hw) :: b
+real(dp),dimension(nv) :: tb
+real(dp),dimension(4,4) :: tel
+real(dp):: s,rr,rrx,rry,rrz,rrc,frow,&
+ exx,eyy,ezz,eww, eyx,ezx,ewx, ezy,ewy, ewz,&
+ x,y,z,w,xc,yc,zc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+integer :: iz,jz,gz
+integer :: iw,jw,gw
+!=============================================================================
+b=0
+do iw=lw,mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx
+ tb=0; s=ss(ix,iy,iz,iw)
+ tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4
+ exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4)
+ eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1)
+ ezy=tel(3,2); ewy=tel(4,2)
+ ewz=tel(4,3)
+ w=u1/eww
+ do gw=ceiling(-w+eps),floor( w-eps)
+ jw=iw+gw; w=gw; zc=-w*ewz
+ rrz=(w*eww)**2; z =sqrt(u1-rrz)
+ do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps)
+ jz=iz+gz; z=gz; yc=-z*ezy-w*ewy
+ rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry)
+ do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx
+ rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ tb=tb+frow*a(:,jx,jy,jz,jw)
+ enddo! gx
+ enddo! gy
+ enddo! gz
+ enddo! gw
+ b(:,ix,iy,iz,iw)=tb
+enddo; enddo; enddo; enddo! ix, iy, iz, iw
+a=b
+end subroutine vrbeta4
+
+!=============================================================================
+module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) ! [rbetat]
+!=============================================================================
+! Perform an ADJOINT radial beta-function filter in 1D.
+! It conserves "masses" initially distributed only at the closure of
+! the central domain,
+! Lx <= ix <= Mx.
+! The output field of the redistributed masses occupies the
+! the extended domain,
+! Lx-hx <= jx <= mx+hx.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx
+real(dp),dimension(1,1,Lx:Mx), intent(in ):: el
+real(dp),dimension( Lx:Mx), intent(in ):: ss
+real(dp),dimension(lx-hx:mx+hx),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(lx-hx:mx+hx):: b
+real(dp) :: ta,s,rr,rrc,frow,exx,x
+integer :: ix,jx,gx
+!=============================================================================
+b=0
+do ix=Lx,Mx
+ ta=a(ix); s=ss(ix)
+ exx=el(1,1,ix)*this%rmom2_1
+ x=u1/exx
+ do gx=ceiling(-x+eps),floor( x-eps)
+ jx=ix+gx; x=gx
+ rr=(x*exx)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ b(jx)=b(jx)+frow*ta
+ enddo
+enddo
+a=b
+end subroutine rbeta1t
+!=============================================================================
+module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat]
+!=============================================================================
+! Perform an ADJOINT radial beta-function filter in 2D.
+! It conserved "masses" initially distributed only at the closure of
+! the central domain,
+! Lx <= ix <= Mx, Ly <= iy <= My.
+! The output field of the redistributed masses occupies the
+! the extended domain,
+! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx, &
+ hy,ly,my
+real(dp),dimension(2,2,Lx:Mx,Ly:My), intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy):: b
+real(dp),dimension(2,2) :: tel
+real(dp) :: ta,s,rr,rrx,rrc, &
+ frow,exx,eyy,eyx,x,y,xc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+!=============================================================================
+b=0
+do iy=Ly,My; do ix=Lx,Mx
+ ta=a(ix,iy); s=ss(ix,iy)
+ tel=el(:,:,ix,iy)*this%rmom2_2 ! sThis el, rescaled
+ exx=tel(1,1); eyy=tel(2,2)
+ eyx=tel(2,1)
+ y=u1/eyy
+ do gy=ceiling(-y+eps),floor( y-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx
+ rrx=(y*eyy)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ b(jx,jy)=b(jx,jy)+frow*ta
+ enddo! gx
+ enddo! gy
+enddo; enddo! ix, iy
+a=b
+end subroutine rbeta2t
+!=============================================================================
+module subroutine rbeta3T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat]
+!=============================================================================
+! Perform an ADJOINT radial beta-function filter in 3D.
+! It conserves "masses" initially distributed only at the closure of
+! the central domain,
+! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz.
+! The output field of the redistributed masses occupies the
+! the extended domain,
+! Lx-hx <= jx <= Mx+hx, Ly-hy <= Jy <= My+hy, Lz-hz <= Jz <= Mz+hz.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx,&
+ hy,ly,my,&
+ hz,lz,mz
+real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz), intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz), intent(in ):: ss
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,&
+ lz-hz:mz+hz),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz):: b
+real(dp),dimension(3,3) :: tel
+real(dp):: ta,s,rr,rrx,rry,rrc,frow,&
+ exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+integer :: iz,jz,gz
+!=============================================================================
+b=0
+do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx
+ ta=a(ix,iy,iz); s=ss(ix,iy,iz)
+ tel=el(:,:,ix,iy,iz)*this%rmom2_3
+ exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3)
+ eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2)
+ z=u1/ezz
+ do gz=ceiling(-z+eps),floor( z-eps)
+ jz=iz+gz; z=gz; yc=-z*ezy
+ rry=(z*ezz)**2; y =sqrt(u1-rry)
+ do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx-z*ezx
+ rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ b(jx,jy,jz)=b(jx,jy,jz)+frow*ta
+ enddo! gx
+ enddo! gy
+ enddo ! gz
+enddo; enddo; enddo ! ix, iy, iz
+a=b
+end subroutine rbeta3t
+!=============================================================================
+module subroutine rbeta4T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, &
+ el,ss, a) ! [rbetat]
+!=============================================================================
+! Perform an ADJOINT radial beta-function filter in 4D.
+! It conserves "masses" initially distributed only at the closure of
+! the central domain,
+! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz, Lw <= iw <= Mw.
+! The output field of the redistributed masses occupies the
+! the extended domain,
+! Lx-hx <= jx <= Mx+hx, Ly-hy <= Jy <= My+hy, Lz-hz <= Jz <= Mz+hz,
+! Lw-hw <= Jw <= Mw+hw.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: hx,Lx,mx,&
+ hy,ly,my,&
+ hz,lz,mz,&
+ hw,lw,mw
+real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,&
+ lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,&
+ lz-hz:mz+hz,lw-hw:mw+hw) :: b
+real(dp),dimension(4,4) :: tel
+real(dp):: ta,s,rr,rrx,rry,rrz,rrc,frow,&
+ exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz,x,y,z,w,xc,yc,zc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+integer :: iz,jz,gz
+integer :: iw,jw,gw
+!=============================================================================
+b=0
+do iw=Lw,Mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx
+ ta=a(ix,iy,iz,iw); s=ss(ix,iy,iz,iw)
+ tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4
+ exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4)
+ eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1)
+ ezy=tel(3,2); ewy=tel(4,2)
+ ewz=tel(4,3)
+ z=u1/ezz
+ do gw=ceiling(-w+eps),floor( w-eps)
+ jw=iw+gw; w=gw; zc=-w*ewz
+ rrz=(w*eww)**2; z =sqrt(u1-rrz)
+ do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps)
+ jz=iz+gz; z=gz; yc=-z*ezy-w*ewy
+ rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry)
+ do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx
+ rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ b(jx,jy,jz,jw)=b(jx,jy,jz,jw)+frow*ta
+ enddo! gx
+ enddo! gy
+ enddo! gz
+ enddo! gw
+enddo; enddo; enddo; enddo! ix, iy, iz, iw
+a=b
+end subroutine rbeta4t
+
+
+!=============================================================================
+module subroutine vrbeta4t(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, &
+ hw,lw,mw, el,ss, a) ! [rbetat]
+!=============================================================================
+! Vector version of rbeta4t filtering nv fields at once.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: nv, &
+ hx,Lx,mx,&
+ hy,ly,my,&
+ hz,lz,mz,&
+ hw,lw,mw
+real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,&
+ lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,&
+ lz-hz:mz+hz,lw-hw:mw+hw) :: b
+real(dp),dimension(nv) :: ta
+real(dp),dimension(4,4) :: tel
+real(dp):: s,rr,rrx,rry,rrz,rrc,frow,&
+ exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz,x,y,z,w,xc,yc,zc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+integer :: iz,jz,gz
+integer :: iw,jw,gw
+!=============================================================================
+b=0
+do iw=Lw,Mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx
+ ta=a(:,ix,iy,iz,iw); s=ss(ix,iy,iz,iw)
+ tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4
+ exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4)
+ eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1)
+ ezy=tel(3,2); ewy=tel(4,2)
+ ewz=tel(4,3)
+ z=u1/ezz
+ do gw=ceiling(-w+eps),floor( w-eps)
+ jw=iw+gw; w=gw; zc=-w*ewz
+ rrz=(w*eww)**2; z =sqrt(u1-rrz)
+ do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps)
+ jz=iz+gz; z=gz; yc=-z*ezy-w*ewy
+ rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry)
+ do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx
+ rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ b(:,jx,jy,jz,jw)=b(:,jx,jy,jz,jw)+frow*ta
+ enddo! gx
+ enddo! gy
+ enddo! gz
+ enddo! gw
+enddo; enddo; enddo; enddo! ix, iy, iz, iw
+a=b
+end subroutine vrbeta4t
+
+! Vector versions of the above routines:
+!=============================================================================
+module subroutine vrbeta1(this,nv,hx,lx,mx, el,ss, a) ! [rbeta]
+!=============================================================================
+! Vector version of rbeta1 filtering nv fields at once.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: nv,hx,Lx,mx
+real(dp),dimension(1,1, Lx:Mx), intent(in ):: el
+real(dp),dimension( Lx:Mx), intent(in ):: ss
+real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(nv,lx-hx:mx+hx):: b
+real(dp),dimension(nv) :: tb
+real(dp) :: x,s,rr,rrc,frow,exx
+integer :: ix,jx,gx
+!=============================================================================
+b=0
+do ix=Lx,Mx
+ tb=0; s=ss(ix)
+ exx=el(1,1,ix)*this%rmom2_1
+ x=u1/exx
+ do gx=ceiling(-x+eps),floor( x-eps)
+ jx=ix+gx; x=gx
+ rr=(x*exx)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ tb=tb+frow*a(:,jx)
+ enddo
+ b(:,ix)=tb
+enddo
+a=b
+end subroutine vrbeta1
+
+!=============================================================================
+module subroutine vrbeta2(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta]
+!=============================================================================
+! Vector version of rbeta2 filtering nv fields at once.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: nv, &
+ hx,Lx,mx, &
+ hy,ly,my
+real(dp),dimension( 2,2,Lx:Mx,Ly:My), intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy):: b
+real(dp),dimension(nv) :: tb
+real(dp),dimension(2,2) :: tel
+real(dp) :: s,rr,rrx,rrc,&
+ frow,exx,eyy,eyx,x,y,xc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+!=============================================================================
+b=0
+do iy=Ly,My; do ix=Lx,Mx
+ tb=0; s=ss(ix,iy)
+ tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled
+ exx=tel(1,1); eyy=tel(2,2)
+ eyx=tel(2,1)
+ y=u1/eyy
+ do gy=ceiling(-y+eps),floor( y-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx
+ rrx=(y*eyy)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ tb=tb+frow*a(:,jx,jy)
+ enddo! gx
+ enddo! gy
+ b(:,ix,iy)=tb
+enddo; enddo! ix, iy
+a=b
+end subroutine vrbeta2
+
+!=============================================================================
+module subroutine vrbeta3(this,nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta]
+!=============================================================================
+! Vector version of rbeta3 filtering nv fields at once.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: nv, &
+ hx,Lx,mx,&
+ hy,ly,my,&
+ hz,lz,mz
+real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz), intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz), intent(in ):: ss
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,&
+ lz-hz:mz+hz),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz):: b
+real(dp),dimension(nv) :: tb
+real(dp),dimension(3,3) :: tel
+real(dp):: s,rr,rrx,rry,rrc,frow,&
+ exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+integer :: iz,jz,gz
+!=============================================================================
+b=0
+do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx
+ tb=0; s=ss(ix,iy,iz)
+ tel=el(:,:,ix,iy,iz)*this%rmom2_3
+ exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3)
+ eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2)
+ z=u1/ezz
+ do gz=ceiling(-z+eps),floor( z-eps)
+ jz=iz+gz; z=gz; yc=-z*ezy
+ rry=(z*ezz)**2; y =sqrt(u1-rry)
+ do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx-z*ezx
+ rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ tb=tb+frow*a(:,jx,jy,jz)
+ enddo! gx
+ enddo! gy
+ enddo! gz
+ b(:,ix,iy,iz)=tb
+enddo; enddo; enddo! ix, iy, iz
+a=b
+end subroutine vrbeta3
+
+! Vector versions of the above routines:
+!=============================================================================
+module subroutine vrbeta1T(this,nv, hx,lx,mx, el,ss, a) ! [rbetat]
+!=============================================================================
+! Vector version of rbeta1t filtering nv fields at once.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: nv,hx,Lx,mx
+real(dp),dimension(1,1,Lx:Mx), intent(in ):: el
+real(dp),dimension( Lx:Mx), intent(in ):: ss
+real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(nv,lx-hx:mx+hx):: b
+real(dp),dimension(nv) :: ta
+real(dp) :: s,rr,rrc,frow,exx,x
+integer :: ix,jx,gx
+!=============================================================================
+b=0
+do ix=Lx,Mx
+ ta=a(:,ix); s=ss(ix)
+ exx=el(1,1,ix)*this%rmom2_1
+ x=u1/exx
+ do gx=ceiling(-x+eps),floor( x-eps)
+ jx=ix+gx; x=gx
+ rr=(x*exx)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ b(:,jx)=b(:,jx)+frow*ta
+ enddo
+enddo
+a=b
+end subroutine vrbeta1t
+!=============================================================================
+module subroutine vrbeta2T(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat]
+!=============================================================================
+! Vector version of rbeta2t filtering nv fields at once.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: nv, &
+ hx,Lx,mx, &
+ hy,ly,my
+real(dp),dimension( 2,2,Lx:Mx,Ly:My), intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy):: b
+real(dp),dimension(nv) :: ta
+real(dp),dimension(2,2) :: tel
+real(dp) :: s,rr,rrx,rrc, &
+ frow,exx,eyy,eyx,x,y,xc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+!=============================================================================
+b=0
+do iy=Ly,My; do ix=Lx,Mx
+ ta=a(:,ix,iy); s=ss(ix,iy)
+ tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled
+ exx=tel(1,1); eyy=tel(2,2)
+ eyx=tel(2,1)
+ y=u1/eyy
+ do gy=ceiling(-y+eps),floor( y-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx
+ rrx=(y*eyy)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ b(:,jx,jy)=b(:,jx,jy)+frow*ta
+ enddo! gx
+ enddo! gy
+enddo; enddo ! ix, iy
+a=b
+end subroutine vrbeta2t
+
+!=============================================================================
+module subroutine vrbeta3T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat]
+!=============================================================================
+! Vector version of rbeta3t filtering nv fields at once.
+!=============================================================================
+class(mg_parameter_type)::this
+integer, intent(in ):: nv, &
+ hx,Lx,mx,&
+ hy,ly,my,&
+ hz,lz,mz
+real(dp),dimension( 3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el
+real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,&
+ lz-hz:mz+hz),intent(inout):: a
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-12
+real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,&
+ lz-hz:mz+hz):: b
+real(dp),dimension(nv) :: ta
+real(dp),dimension(3,3) :: tel
+real(dp):: s,rr,rrx,rry,rrc,frow,&
+ exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc
+integer :: ix,jx,gx
+integer :: iy,jy,gy
+integer :: iz,jz,gz
+!=============================================================================
+b=0
+do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx
+ ta=a(:,ix,iy,iz); s=ss(ix,iy,iz)
+ tel=el(:,:,ix,iy,iz)*this%rmom2_3
+ exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3)
+ eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2)
+ z=u1/ezz
+ do gz=ceiling(-z+eps),floor( z-eps)
+ jz=iz+gz; z=gz; yc=-z*ezy
+ rry=(z*ezz)**2; y =sqrt(u1-rry)
+ do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps)
+ jy=iy+gy; y=gy; xc=-y*eyx-z*ezx
+ rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx)
+ do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps)
+ jx=ix+gx; x=gx
+ rr=rrx+(x*exx-xc)**2; rrc=u1-rr
+ frow=s*rrc**this%p
+ b(:,jx,jy,jz)=b(:,jx,jy,jz)+frow*ta
+ enddo! gx
+ enddo! gy
+ enddo! gz
+enddo; enddo; enddo! ix, iy, iz
+a=b
+end subroutine vrbeta3t
+
+end submodule jp_pbfil
+
diff --git a/src/mgbf/jp_pbfil2.f90 b/src/mgbf/jp_pbfil2.f90
new file mode 100644
index 0000000000..63493f9727
--- /dev/null
+++ b/src/mgbf/jp_pbfil2.f90
@@ -0,0 +1,1173 @@
+module jp_pbfil2
+!$$$ module documentation block
+! . . . .
+! module: jp_pbfil2
+! prgmmr: purser org: NOAA/EMC date: 2019-08
+!
+! abstract: Module of data defining the exact transition rules
+! of the decad algorithm based on the PG(3,2) reference
+! geometry
+!
+! module history log:
+!
+! Subroutines Included:
+!
+! Functions Included:
+!
+! remarks:
+! An overview of this topic is given NOAA/NCEP Office Note 500.
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+use jp_pkind, only: spi,dp
+implicit none
+public
+private :: X, A, B
+integer(spi),parameter :: X=99,A=10,B=11
+!---- Items that relate to beta line filters generally:
+real(dp),allocatable,dimension(:) :: bnorm,bsprds
+integer(spi) :: p,nh
+!---- Items that relate only to 4D "decad" line filters:
+integer(spi),dimension(4,0:9) :: dec0,dodec0t
+integer(spi),dimension(4,0:11) :: dodec0
+integer(spi),dimension(0:14,0:14) :: typ
+integer(spi),dimension(0:3,0:3,0:9,0:11) :: umat10
+integer(spi),dimension(0:3,0:3,0:3,12:59):: umat12
+integer(spi),dimension(0:3,0:3,4:9) :: umats
+integer(spi),dimension(0:9,0:59) :: nei
+integer(spi),dimension(0:9,0:11) :: dcol10
+integer(spi),dimension(0:3,12:59) :: dcol12
+integer(spi),dimension(2, 0:3) :: nei0a,jcora
+integer(spi),dimension(2,1:2,4:9) :: nei0b,jcorb
+integer(spi),dimension(2) :: nei17,nei22,nei33,nei38
+integer(spi),dimension(4,4,0:12) :: tcors
+integer(spi),dimension(0:2,0:3) :: kcor10a5
+integer(spi),dimension(0:2,4:9) :: kcor10b1,kcor10b2
+integer(spi),dimension(12:59) :: kcor12b0
+integer(spi),dimension(0:2) :: kcor17c0,kcor22c0,kcor33c0,kcor38c0, &
+ kcor44c0,kcor51c0,kcor53c0,kcor58c0
+integer(spi),dimension(0:9,0:2) :: twt10a5,twt10b1,twt10b2,twt12c0
+integer(spi),dimension(0:9,0:9) :: qwt10a,qwt10b,qwt10c,qwt10d,qwt10e, &
+ qwt12a,qwt12b
+integer(spi),dimension(0:9,0:2) :: qwt12b0
+integer(spi),dimension(0:9,0:12) :: tperms
+integer(spi),dimension(0:9,0:9,0:11) :: perm10
+integer(spi),dimension(0:9,0:3,12:59) :: perm12
+integer(spi),dimension(0:9,4:9) :: perms
+data p/0/
+data nh/0/
+data dec0/1,0,0,0, 0,1, 0,0, 0, 0,1, 0, 0,0,0,1, -1,-1,-1,-1, &
+ 1,0,1,1, -1,0,-1,0, 0,-1,0,-1, 1,1,0,1, -1, 0, 0,-1/
+data dodec0t/ &
+ +2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, &
+ -1,-1,-1,-1, 1, 1,-1,-1, 1,-1, 1,-1, &
+ -1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1 /
+data dodec0/ &
+ +2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, &
+ -1,-1,-1,-1, 1, 1,-1,-1, 1,-1, 1,-1, 1,-1,-1, 1, &
+ -1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1, -1,-1,-1, 1/
+data typ/ X,6,8,X,X,X,X,7,3,9,5,1,0,2,4, &! 3;1;1;1;9
+ X,3,6,9,8,5,X,1,X,0,X,2,X,4,7, &! 6;2;2;2;3
+ X,X,3,0,6,X,9,2,8,X,5,4,X,7,1, &! 1;4;4;3;3
+ X,8,X,X,3,5,0,4,6,X,X,7,9,1,2, &! 2;1;6;1;5
+!---------
+ X,X,X,8,6,4,X,X,7,3,9,2,1,0,5, &! 1;1;4;1;8
+ X,7,X,3,X,9,8,2,6,1,4,0,X,5,X, &! 2;2;8;2;1
+ X,6,7,1,X,4,3,0,X,X,9,5,8,X,2, &! 4;4;1;4;2
+ X,X,6,X,7,9,1,5,X,8,4,X,3,2,0, &! 1;2;5;3;4
+!---------
+ 9,X,0,5,X,4,X,7,3,X,X,1,8,6,2, &! 3;2;3;1;6
+ 9,3,X,X,0,X,5,1,X,8,4,6,X,2,7, &! 1;2;3;4;5
+!---------
+ X,1,5,9,6,4,2,X,7,8,3,X,0,X,X, &! 4;2;1;1;7
+!---------
+ X,7,0,X,9,8,X,4,1,X,3,5,X,2,6, &! 3;3;3;3;3
+!+++++++++
+ X,1,X,4,2,3,5,B,X,A,0,9,8,7,6, &! 2;6;7
+ X,X,1,A,X,0,4,9,2,8,3,7,5,6,B, &! 1;3;11
+!---------
+ X,0,3,B,2,X,4,7,1,5,X,8,9,6,A/ ! 5;5;5
+data umat10/&
+!---------------- 0
+ 1, 1, 1, 1, 0, 1,-1, 1, 0, 0, 0, 1, -1, 0, 0,-1, &
+ 0, 0, 1, 0, -2,-1,-1,-2, 0,-1, 0,-1, 0, 0, 0, 1, &
+ 0, 0, 0, 1, -1,-1,-1,-1, -1,-1, 0,-1, 2, 0, 1, 1, &
+ 1, 1, 1, 1, 1, 0, 0, 0, 1,-1, 1, 0, -1, 0, 0,-1, &
+ 1, 0, 0, 1, 0,-1, 0,-1, 1, 0, 1, 0, 0, 1,-1, 0, &
+ 1, 1, 0, 1, 0,-1,-1, 0, 0, 0, 0, 1, 1, 0, 1, 0, &
+ 1, 1, 0, 1, 0,-1,-1,-1, -1, 0,-1,-1, 0, 0, 0, 1, &
+ 0, 0, 1, 0, 0, 1, 0, 0, 2, 1, 1, 1, 0, 0, 0, 1, &
+ 1, 0, 1, 1, -1, 0, 0, 0, 0, 1, 0, 1, 0,-1,-1, 0, &
+ 0, 1, 0, 1, -1, 0,-1,-1, 1, 1, 0, 0, 0, 0, 1, 0, &
+!---------------- 1
+ 1, 1, 1, 1, 0, 1,-1, 1, 0, 0, 0, 1, -1, 0, 0,-1, &
+ 0, 0, 1, 0, -2,-1,-1,-2, 0,-1, 0,-1, 0, 0, 0, 1, &
+ 0, 0, 0, 1, -1,-1,-1,-1, -1,-1, 0,-1, 2, 0, 1, 1, &
+ 1, 1, 1, 1, -1, 1,-1, 0, -1, 0, 0, 0, 1, 0, 0, 1, &
+ 1, 0, 0, 1, -1, 0,-1, 0, 0, 1, 0, 1, 0,-1, 1, 0, &
+ 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, &
+ 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 1, 0, 0, 0,-1, &
+ 0, 0, 1, 0, -2,-1,-1,-1, 0,-1, 0, 0, 0, 0, 0,-1, &
+ 1, 0, 1, 1, 0,-1, 0,-1, 1, 0, 0, 0, 0, 1, 1, 0, &
+ 0, 1, 0, 1, -1,-1, 0, 0, 1, 0, 1, 1, 0, 0,-1, 0, &
+!---------------- 2
+ 1, 1, 1, 1, 0, 0, 0,-1, 0,-1, 1,-1, 1, 0, 0, 1, &
+ 0, 0, 1, 0, 0, 1, 0, 1, 2, 1, 1, 2, 0, 0, 0,-1, &
+ 0, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, -2, 0,-1,-1, &
+ 1, 1, 1, 1, -1, 1,-1, 0, -1, 0, 0, 0, 1, 0, 0, 1, &
+ 1, 0, 0, 1, -1, 0,-1, 0, 0, 1, 0, 1, 0,-1, 1, 0, &
+ 1, 1, 0, 1, 0,-1,-1, 0, 0, 0, 0, 1, 1, 0, 1, 0, &
+ 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 1, 0, 0, 0,-1, &
+ 0, 0, 1, 0, -2,-1,-1,-1, 0,-1, 0, 0, 0, 0, 0,-1, &
+ 1, 0, 1, 1, 0,-1, 0,-1, 1, 0, 0, 0, 0, 1, 1, 0, &
+ 0, 1, 0, 1, -1,-1, 0, 0, 1, 0, 1, 1, 0, 0,-1, 0, &
+ !---------------- 3
+ 1, 1, 1, 1, 0, 0, 0,-1, 0,-1, 1,-1, 1, 0, 0, 1, &
+ 0, 0, 1, 0, 0, 1, 0, 1, 2, 1, 1, 2, 0, 0, 0,-1, &
+ 0, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, -2, 0,-1,-1, &
+ 1, 1, 1, 1, 1, 0, 0, 0, 1,-1, 1, 0, -1, 0, 0,-1, &
+ 1, 0, 0, 1, 0,-1, 0,-1, 1, 0, 1, 0, 0, 1,-1, 0, &
+ 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, &
+ 1, 1, 0, 1, 0,-1,-1,-1, -1, 0,-1,-1, 0, 0, 0, 1, &
+ 0, 0, 1, 0, 0, 1, 0, 0, 2, 1, 1, 1, 0, 0, 0, 1, &
+ 1, 0, 1, 1, -1, 0, 0, 0, 0, 1, 0, 1, 0,-1,-1, 0, &
+ 0, 1, 0, 1, -1, 0,-1,-1, 1, 1, 0, 0, 0, 0, 1, 0, &
+!---------------- 4
+ 1, 0, 1, 1, 0,-1, 0,-1, -1,-1, 0,-1, 0, 0,-1, 1, &
+ 1, 0, 1, 0, -1,-1,-1,-2, -1, 0, 0,-1, 1, 1, 0, 1, &
+ 0, 0, 0, 1, 2, 0, 1, 1, 1, 1, 0, 1, -1,-1,-1,-1, &
+ 0, 0, 1, 0, 0, 1, 0, 0, -2, 0,-1,-1, 0,-1, 0,-1, &
+ 0, 0, 0, 1, 0, 0, 1, 0, 1,-1, 1, 0, 1, 1, 0, 1, &
+ 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, &
+ 1, 0, 0, 1, 0,-1, 0,-1, 0, 0,-1,-1, 1, 1, 1, 1, &
+ 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 1, 0, -1,-1,-1,-1, &
+ 1, 0, 1, 0, 0,-1,-1,-1, 0,-1, 0, 0, -1, 0, 0,-1, &
+ 0, 1, 0, 1, 0, 0,-1, 0, 1, 1, 0, 0, 1, 0, 1, 1, &
+!---------------- 5
+ 1, 0, 1, 1, 0,-1, 0,-1, -1,-1, 0,-1, 0, 0,-1, 1, &
+ 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 0, 1, -1,-1,-1,-2, &
+ 0, 0, 0, 1, -1,-1,-1,-1, -1,-1, 0,-1, 2, 0, 1, 1, &
+ 0, 0, 1, 0, 0, 1, 0, 0, -2, 0,-1,-1, 0,-1, 0,-1, &
+ 0, 0, 0, 1, -1, 1,-1, 0, 0, 0,-1, 0, -1,-1, 0,-1, &
+ 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, &
+ 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0, 1, -1,-1,-1,-1, &
+ 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 1, 0, -1,-1,-1,-1, &
+ 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, &
+ 0, 1, 0, 1, -1,-1, 0, 0, 0, 0, 1, 0, -1, 0,-1,-1, &
+!---------------- 6
+ 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, &
+ 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 2, -1, 0,-1,-1, &
+ 0, 0, 0, 1, 2, 0, 1, 1, 1, 1, 0, 1, -1,-1,-1,-1, &
+ 0, 0, 1, 0, 2, 0, 1, 1, 0,-1, 0, 0, 0, 1, 0, 1, &
+ 0, 0, 0, 1, -1, 1,-1, 0, 0, 0,-1, 0, -1,-1, 0,-1, &
+ 1, 1, 0, 1, 0, 0, 0, 1, -1, 0,-1, 0, 0, 1, 1, 0, &
+ 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0, 1, -1,-1,-1,-1, &
+ 1, 0, 0, 1, -1, 0,-1, 0, -1,-1, 0, 0, 1, 1, 1, 1, &
+ 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, &
+ 0, 1, 0, 1, -1,-1, 0, 0, 0, 0, 1, 0, -1, 0,-1,-1, &
+!---------------- 7
+ 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, &
+ 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 0, 1, -1,-1,-1,-2, &
+ 0, 1, 0, 1, 2, 1, 1, 1, 1, 0, 1, 1, -1, 0, 0,-1, &
+ 0, 0, 1, 0, 2, 0, 1, 1, 0,-1, 0, 0, 0, 1, 0, 1, &
+ 0, 0, 0, 1, 0, 0, 1, 0, 1,-1, 1, 0, 1, 1, 0, 1, &
+ 1, 1, 0, 1, 0, 0, 0, 1, -1, 0,-1, 0, 0, 1, 1, 0, &
+ 1, 0, 0, 1, 0,-1, 0,-1, 0, 0,-1,-1, 1, 1, 1, 1, &
+ 1, 0, 0, 1, -1, 0,-1, 0, -1,-1, 0, 0, 1, 1, 1, 1, &
+ 1, 0, 1, 0, 0,-1,-1,-1, 0,-1, 0, 0, -1, 0, 0,-1, &
+ 0, 1, 0, 1, 0, 0,-1, 0, 1, 1, 0, 0, 1, 0, 1, 1, &
+!---------------- 8
+ 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, &
+ 1, 0, 0, 0, -1,-1, 0,-2, -1,-1,-1,-1, 1, 0, 1, 1, &
+ 0, 0, 0, 1, -2, 0,-1,-1, -1,-1,-1,-1, 1, 1, 0, 1, &
+ 1, 1, 0, 1, -1, 0,-1, 0, -1, 0,-1,-1, 1,-1, 0, 0, &
+ 1, 0, 0, 1, 1, 0, 1, 0, 0,-1, 0,-1, 0, 1,-1, 0, &
+ 1, 0, 0, 0, 0,-1, 0, 0, 0, 0,-1, 1, 1, 1, 1, 1, &
+ 0, 1, 0, 0, 0, 0, 1, 0, 1, 1, 1, 2, 1, 0, 0, 0, &
+ 0, 0, 1, 0, -2,-1,-1,-1, 0,-1, 0, 0, 0, 0, 0,-1, &
+ 0, 0, 0, 1, -1, 1, 0, 0, 0, 0, 1, 0, -1,-1,-1,-1, &
+ 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,-1, 0,-1, 1, 0, &
+!---------------- 9
+ 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, &
+ 1, 0, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, -1,-1, 0,-2, &
+ 0, 1, 0, 0, 2, 1, 1, 2, 1, 0, 0, 0, -1, 0,-1, 0, &
+ 1, 1, 0, 1, -1, 0,-1, 0, -1, 0,-1,-1, 1,-1, 0, 0, &
+ 1, 0, 0, 1, 0, 1, 0, 1, -1, 0,-1, 0, 0,-1, 1, 0, &
+ 1, 0, 0, 0, 0,-1, 0, 0, 0, 0,-1, 1, 1, 1, 1, 1, &
+ 0, 1, 0, 0, -1,-1,-1,-2, 0, 0,-1, 0, -1, 0, 0, 0, &
+ 0, 0, 1, 0, 0, 1, 0, 0, 2, 1, 1, 1, 0, 0, 0, 1, &
+ 0, 0, 0, 1, -1, 1, 0, 0, 0, 0, 1, 0, -1,-1,-1,-1, &
+ 1, 1, 1, 1, 0, 0, 0, 1, -1, 0, 0, 0, 0, 1,-1, 0, &
+!---------------- 10
+ 0, 1, 0, 0, 1, 1, 0, 2, -1, 0,-1, 0, 0, 0, 1, 0, &
+ 1, 0, 1, 0, 1, 0, 0, 1, 1, 1, 1, 2, -1,-1, 0,-1, &
+ 0, 1, 0, 1, -2,-1,-1,-1, -1, 0,-1,-1, 1, 0, 0, 1, &
+ 1, 1, 1, 1, -1, 0, 0,-1, -1, 0, 0, 0, 1,-1, 1, 0, &
+ 0, 0, 0, 1, 1, 1, 0, 1, 0, 0,-1, 0, 1,-1, 1, 0, &
+ 0, 1, 0, 1, 0, 0,-1, 0, -1,-1,-1, 0, -1, 0, 0,-1, &
+ 0, 1, 0, 0, -1,-1,-1,-2, 1, 0, 0, 0, 0, 0, 1, 0, &
+ 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, -1, 0, 0, 0, &
+ 1, 0, 1, 1, 0, 1, 0, 1, 0, 1, 1, 0, 1, 0, 0, 0, &
+ 1, 0, 1, 0, 0, 1, 0, 0, 0, 0,-1,-1, -1,-1, 0,-1, &
+!---------------- 11
+ 1, 1, 1, 1, -1, 0, 0,-1, 0, 0, 0,-1, 0, 1,-1, 1, &
+ 0, 0, 1, 0, 0, 0, 0,-1, 0,-1, 0,-1, 2, 1, 1, 2, &
+ 0, 1, 0, 0, -1, 0,-1, 0, -1, 0, 0, 0, 2, 1, 1, 2, &
+ 1, 1, 0, 1, -1, 0,-1,-1, -1, 0,-1, 0, 1,-1, 0, 0, &
+ 1, 0, 0, 0, 0, 1, 0, 0, -1, 0,-1,-1, 0,-1, 1,-1, &
+ 0, 1, 0, 1, 0, 0, 1, 0, -1, 0, 0,-1, -1,-1,-1, 0, &
+ 1, 0, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 0, 0,-1,-1, &
+ 1, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 1, -1,-1,-1, 0, &
+ 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 1, 0, 1,-1, 0, 0, &
+ 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 0, 0, 0, 1, 1/
+data umat12/&
+!---------------- 12
+ 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, &
+ 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, &
+ 1, 1,-1,-1, 0,-2, 0,-2, -2, 0, 0, 0, 0, 0, 0, 2, &
+ 0, 0, 2, 0, -1, 1,-1,-1, -1, 1,-1, 1, 0,-2, 0, 0, &
+!---------------- 13
+ 0, 0, 2, 2, -1,-1, 1,-1, 1,-1, 1,-1, 0, 2, 0, 0, &
+ 1, 1, 1, 1, 1,-1, 1, 1, 0, 0,-2, 0, -2, 0, 0, 0, &
+ 1, 1,-1, 1, 1,-1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, &
+ 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, &
+!---------------- 14
+ 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, &
+ 1,-1,-1,-1, -1,-1, 1,-1, -1, 1,-1,-1, 1, 1, 1, 1, &
+ 1, 1,-1,-1, 0,-2, 0,-2, 1,-1, 1, 1, -1, 1, 1, 1, &
+ 1,-1,-1,-1, -1,-1, 1,-1, -1,-1, 1, 1, 1, 1, 1, 1, &
+!---------------- 15
+ 0, 2, 0, 2, 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, &
+ 1, 1,-1, 1, 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, &
+ 1,-1,-1,-1, -1, 1,-1, 1, 0, 2, 0, 0, -1,-1, 1,-1, &
+ 1,-1,-1,-1, 1,-1, 1, 1, -1, 1,-1, 1, 0, 2, 0, 0, &
+!---------------- 16
+ 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, &
+ 0, 0, 2, 0, 2, 0, 0, 0, 0, 0, 0, 2, -1,-1,-1,-1, &
+ 1, 1, 1, 1, -1,-1, 1, 1, -1, 1,-1, 1, 1,-1,-1,-1, &
+ 1, 1, 1, 1, -1,-1, 1, 1, -1,-1, 1,-1, 1,-1,-1,-1, &
+!---------------- 17
+ 0, 2, 0, 2, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, &
+ 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0,-2,-2, &
+ 1, 1,-1, 1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 0, 0,-2, &
+ 0, 0, 2, 0, -1,-1, 1, 1, 1, 1,-1, 1, 1,-1,-1,-1, &
+ !---------------- 18
+ 0, 2,-2, 0, -1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0,-2, &
+ 0, 0, 2, 2, -1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, &
+ 0, 2, 0, 2, 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, &
+ 0, 0, 2, 0, -2, 0, 0, 0, 0, 2,-2, 0, 1,-1,-1,-1, &
+!---------------- 19
+ 0, 2,-2, 0, 0, 0, 0,-2, -1,-1,-1,-1, -1, 1, 1, 1, &
+ 1, 1,-1,-1, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, &
+ 1, 1,-1, 1, 0, 2, 0, 0, 1,-1, 1,-1, -1,-1, 1, 1, &
+ 1,-1, 1, 1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 2,-2, 0, &
+!---------------- 20
+ 0, 2, 0, 2, 1,-1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, &
+ 1, 1,-1,-1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 0, 0, 2, &
+ 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, &
+ 0, 2,-2, 0, -1,-1,-1,-1, 1,-1, 1,-1, 1,-1, 1, 1, &
+!---------------- 21
+ 0, 2,-2, 0, -1,-1,-1,-1, 1,-1,-1,-1, 0, 0, 0, 2, &
+ 1, 1,-1,-1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0, 0, 2, &
+ 1, 1,-1, 1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 0, 0,-2, &
+ 1,-1,-1,-1, 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, &
+!---------------- 22
+ 0, 0, 2, 2, 1,-1, 1,-1, 0,-2, 0, 0, 1, 1,-1, 1, &
+ 0, 0, 0, 2, -2, 0, 0, 0, 0, 0, 2, 0, 1, 1,-1,-1, &
+ 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 2, 0, 2, &
+ 0, 2, 0, 0, 1, 1,-1, 1, -1,-1, 1, 1, -1,-1,-1,-1, &
+!---------------- 23
+ 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, &
+ 1, 1,-1,-1, -1, 1,-1, 1, 0, 0, 2, 2, -1,-1, 1,-1, &
+ 1,-1,-1,-1, -1, 1,-1, 1, -1,-1, 1, 1, 1, 1, 1, 1, &
+ 1,-1, 1, 1, 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, &
+!---------------- 24
+ 0, 0, 2, 2, 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1,-1, &
+ 1, 1, 1, 1, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, &
+ 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, &
+ 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, &
+!---------------- 25
+ 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, &
+ 1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1, 1,-1,-1,-1, &
+ 0, 0, 0, 2, -1, 1, 1, 1, 1,-1, 1,-1, 1, 1,-1,-1, &
+ 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, &
+!---------------- 26
+ 0, 2,-2, 0, 1,-1,-1,-1, 0, 0, 0,-2, 1, 1, 1, 1, &
+ 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, -1,-1, 1,-1, &
+ 1, 1,-1, 1, -1,-1,-1,-1, 0, 0, 0,-2, -1, 1, 1, 1, &
+ 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, &
+!---------------- 27
+ 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, &
+ 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1, 1, 0, 0,-2,-2, &
+ 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1, 1, 0,-2, 0,-2, &
+ 1,-1,-1,-1, -1, 1,-1,-1, -1, 1,-1, 1, 1, 1, 1, 1, &
+!---------------- 28
+ 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, &
+ 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, &
+ 1, 1,-1,-1, 0,-2, 0,-2, -2, 0, 0, 0, 0, 0, 0, 2, &
+ 0, 2, 0, 0, 1,-1, 1,-1, 1,-1, 1, 1, 0, 0,-2, 0, &
+!---------------- 29
+ 0, 0, 2, 2, -1,-1, 1,-1, 1,-1, 1,-1, 0, 2, 0, 0, &
+ 1, 1, 1, 1, 1,-1, 1, 1, 0, 0,-2, 0, -2, 0, 0, 0, &
+ 1, 1,-1, 1, 1,-1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, &
+ 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, &
+!---------------- 30
+ 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, &
+ 1,-1,-1,-1, -1,-1, 1,-1, -1, 1,-1,-1, 1, 1, 1, 1, &
+ 1,-1, 1, 1, -1,-1, 1,-1, 0, 2, 0, 0, -1, 1,-1, 1, &
+ 1,-1,-1,-1, -1,-1, 1,-1, -1,-1, 1, 1, 1, 1, 1, 1, &
+!---------------- 31
+ 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, &
+ 1, 1,-1, 1, 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, &
+ 1,-1,-1,-1, -1, 1,-1, 1, 0, 2, 0, 0, -1,-1, 1,-1, &
+ 1,-1,-1,-1, 1,-1, 1, 1, -1, 1,-1, 1, 0, 2, 0, 0, &
+!---------------- 32
+ 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, &
+ 0, 0, 0, 2, 1,-1,-1,-1, -1,-1, 1,-1, -1, 1,-1,-1, &
+ 1, 1, 1, 1, -1,-1, 1, 1, -1, 1,-1, 1, 1,-1,-1,-1, &
+ 1, 1, 1, 1, -1,-1, 1, 1, -1,-1, 1,-1, 1,-1,-1,-1, &
+!---------------- 33
+ 0, 2, 0, 2, -1,-1, 1, 1, 0, 0, 2, 0, -1, 1,-1,-1, &
+ 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0,-2,-2, &
+ 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 0, 0, -1,-1, 1,-1, &
+ 0, 0, 2, 0, -1,-1, 1, 1, 1, 1,-1, 1, 1,-1,-1,-1, &
+!---------------- 34
+ 0, 2,-2, 0, -1,-1,-1,-1, 1,-1,-1,-1, 0, 0, 0, 2, &
+ 0, 0, 2, 2, -1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, &
+ 0, 2, 0, 2, 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, &
+ 1,-1, 1, 1, -1, 1, 1, 1, -1,-1, 1,-1, 1, 1,-1,-1, &
+!---------------- 35
+ 0, 2,-2, 0, 0, 0, 0,-2, -1,-1,-1,-1, -1, 1, 1, 1, &
+ 1, 1,-1,-1, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, &
+ 1, 1,-1, 1, 0, 2, 0, 0, 1,-1, 1,-1, -1,-1, 1, 1, &
+ 1,-1, 1, 1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 2,-2, 0, &
+!---------------- 36
+ 0, 2, 0, 2, 1,-1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, &
+ 1, 1,-1,-1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 0, 0, 2, &
+ 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, &
+ 0, 2,-2, 0, -1,-1,-1,-1, 1,-1, 1,-1, 1,-1, 1, 1, &
+!---------------- 37
+ 0, 2,-2, 0, -1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0,-2, &
+ 1, 1,-1,-1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0, 0, 2, &
+ 1, 1,-1, 1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 0, 0,-2, &
+ 0, 0, 2, 0, -1,-1, 1, 1, -1,-1,-1,-1, 0, 2,-2, 0, &
+!---------------- 38
+ 0, 2, 0, 2, 1, 1,-1,-1, -1, 1,-1,-1, 0, 0, 2, 0, &
+ 1, 1,-1,-1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0, 0, 2, &
+ 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 2, 0, 2, &
+ 0, 2, 0, 0, 1, 1,-1, 1, -1,-1, 1, 1, -1,-1,-1,-1, &
+!---------------- 39
+ 0, 2, 0, 2, 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, &
+ 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, 1,-1,-1,-1, &
+ 1,-1,-1,-1, -1, 1,-1, 1, -1,-1, 1, 1, 1, 1, 1, 1, &
+ 1,-1, 1, 1, 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, &
+!---------------- 40
+ 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, &
+ 1, 1, 1, 1, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, &
+ 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, &
+ 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, &
+!---------------- 41
+ 0, 0, 2, 2, 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1,-1, &
+ 1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1, 1,-1,-1,-1, &
+ 1,-1, 1,-1, 0, 2, 0, 0, 1, 1,-1, 1, -1,-1,-1,-1, &
+ 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, &
+!---------------- 42
+ 0, 2,-2, 0, 1,-1,-1,-1, 0, 0, 0,-2, 1, 1, 1, 1, &
+ 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, -1,-1, 1,-1, &
+ 1, 1,-1, 1, -1,-1,-1,-1, 0, 0, 0,-2, -1, 1, 1, 1, &
+ 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, &
+ !---------------- 43
+ 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, &
+ 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1, 1, 0, 0,-2,-2, &
+ 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1, 1, 0,-2, 0,-2, &
+ 1, 1, 1, 1, -1, 1,-1, 1, -1, 1,-1,-1, 1,-1,-1,-1, &
+!---------------- 44
+ 0, 2,-2, 0, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, &
+ 1,-1, 1,-1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0,-2, 0, &
+ 0, 0, 0, 2, -2, 0, 0, 0, 0,-2, 0,-2, 1, 1,-1,-1, &
+ 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, 0,-2, 0, 0, &
+!---------------- 45
+ 0, 0, 2, 2, 0,-2, 0, 0, -1,-1, 1,-1, -1, 1,-1, 1, &
+ 1,-1,-1,-1, 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, &
+ 2, 0, 0, 0, 0, 0, 0,-2, -1, 1, 1, 1, -1, 1,-1, 1, &
+ 1, 1,-1,-1, -1,-1,-1,-1, 0,-2, 2, 0, -1, 1, 1, 1, &
+!---------------- 46
+ 0, 2, 0, 2, 0, 0,-2, 0, 1, 1,-1,-1, 1,-1, 1, 1, &
+ 1, 1,-1, 1, -1, 1,-1,-1, 0, 0, 2, 0, -1,-1, 1, 1, &
+ 1,-1, 1, 1, 0,-2, 0,-2, 1, 1,-1,-1, -1, 1,-1, 1, &
+ 1, 1, 1, 1, 0, 2,-2, 0, 1,-1,-1,-1, -1,-1, 1,-1, &
+!---------------- 47
+ 0, 2, 0, 2, 0, 0, 2, 0, 1,-1, 1, 1, 1, 1,-1,-1, &
+ 1, 1,-1, 1, 0, 0, 2, 2, 1,-1, 1,-1, -1,-1,-1,-1, &
+ 1,-1,-1,-1, -1, 1,-1,-1, 0, 2, 0, 2, -1,-1, 1, 1, &
+ 1, 1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, -1, 1,-1,-1, &
+!---------------- 48
+ 0, 2,-2, 0, -1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0,-2, &
+ 1, 1,-1,-1, 1,-1, 1,-1, 0, 0, 2, 2, -2, 0, 0, 0, &
+ 2, 0, 0, 0, 0, 2, 0, 2, -1, 1,-1,-1, -1,-1, 1,-1, &
+ 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, &
+!---------------- 49
+ 0, 0, 2, 2, -1, 1,-1, 1, 1, 1,-1, 1, 0,-2, 0, 0, &
+ 1, 1,-1, 1, 1,-1,-1,-1, -1,-1, 1, 1, 0, 0, 2, 0, &
+ 2, 0, 0, 0, 0, 2, 0, 2, -1,-1, 1, 1, -1,-1,-1,-1, &
+ 1,-1, 1, 1, 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, &
+!---------------- 50
+ 0, 2,-2, 0, 1, 1, 1, 1, 0, 0, 0, 2, 1,-1,-1,-1, &
+ 1,-1, 1, 1, -1,-1, 1,-1, 0, 0,-2,-2, -1, 1,-1, 1, &
+ 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, &
+ 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, &
+!---------------- 51
+ 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, &
+ 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, &
+ 0, 2, 0, 0, -2, 0, 0, 0, 0,-2, 0,-2, 1,-1, 1, 1, &
+ 0, 0, 2, 0, -2, 0, 0, 0, 0, 2,-2, 0, 1,-1,-1,-1, &
+!---------------- 52
+ 0, 0, 2, 2, 1, 1,-1, 1, 0, 2, 0, 0, 1,-1, 1,-1, &
+ 1,-1,-1,-1, 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, &
+ 2, 0, 0, 0, 0, 0, 0,-2, -1, 1, 1, 1, -1, 1,-1, 1, &
+ 1, 1,-1,-1, -1,-1,-1,-1, 0,-2, 2, 0, -1, 1, 1, 1, &
+!---------------- 53
+ 0, 2,-2, 0, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, &
+ 0, 0, 2, 0, 2, 0, 0, 0, 0, 0,-2,-2, -1, 1,-1, 1, &
+ 0, 0, 0, 2, -2, 0, 0, 0, 0,-2, 0,-2, 1, 1,-1,-1, &
+ 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, 0,-2, 0, 0, &
+!---------------- 54
+ 0, 2, 0, 2, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, &
+ 1, 1,-1, 1, 0, 0, 2, 2, 1,-1, 1,-1, -1,-1,-1,-1, &
+ 1, 1,-1,-1, 0,-2, 0,-2, 1,-1, 1, 1, -1, 1, 1, 1, &
+ 1, 1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, -1, 1,-1,-1, &
+!---------------- 55
+ 0, 2, 0, 2, -1,-1, 1, 1, 0, 0, 2, 0, -1, 1,-1,-1, &
+ 1, 1,-1, 1, -1, 1,-1,-1, 0, 0, 2, 0, -1,-1, 1, 1, &
+ 1,-1, 1,-1, -1,-1, 1, 1, 0, 2, 0, 2, -1, 1,-1,-1, &
+ 1, 1, 1, 1, 0, 2,-2, 0, 1,-1,-1,-1, -1,-1, 1,-1, &
+!---------------- 56
+ 0, 0, 2, 2, -1,-1, 1,-1, 1,-1, 1,-1, 0, 2, 0, 0, &
+ 1, 1,-1, 1, 1,-1,-1,-1, -1,-1, 1, 1, 0, 0, 2, 0, &
+ 2, 0, 0, 0, 0, 2, 0, 2, -1,-1, 1, 1, -1,-1,-1,-1, &
+ 2, 0, 0, 0, 0,-2, 2, 0, -1, 1, 1, 1, -1, 1,-1,-1, &
+!---------------- 57
+ 0, 2,-2, 0, -1,-1,-1,-1, 1,-1,-1,-1, 0, 0, 0, 2, &
+ 2, 0, 0, 0, 0, 0,-2,-2, -1, 1,-1, 1, -1,-1, 1, 1, &
+ 2, 0, 0, 0, 0, 2, 0, 2, -1, 1,-1,-1, -1,-1, 1,-1, &
+ 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, &
+!---------------- 58
+ 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, &
+ 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, &
+ 0, 2, 0, 0, -2, 0, 0, 0, 0,-2, 0,-2, 1,-1, 1, 1, &
+ 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, 0, 0, 2, 0, &
+!---------------- 59
+ 0, 2,-2, 0, 0, 0, 0,-2, -1,-1,-1,-1, -1, 1, 1, 1, &
+ 1,-1, 1, 1, -1,-1, 1,-1, 0, 0,-2,-2, -1, 1,-1, 1, &
+ 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, &
+ 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0/
+data umats/& ! Divide all these elements by 2 for simplicity:
+ 0, 0, 0, 2, 0, 0,-2, 0, 0,-2, 0, 0, 2, 0, 0, 0, &
+ 0, 0, 2, 0, 0, 0, 0,-2, 2, 0, 0, 0, 0,-2, 0, 0, &
+ 0, 2, 0, 0, 2, 0, 0, 0, 0, 0, 0,-2, 0, 0,-2, 0, &
+ 0, 0, 0, 2, 0, 0, 2, 0, 0, 2, 0, 0, 2, 0, 0, 0, &
+ 0, 0, 2, 0, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 0, 0, &
+ 0, 2, 0, 0, 2, 0, 0, 0, 0, 0, 0, 2, 0, 0, 2, 0/
+
+data nei/ &
+!===== 0--3:
+18,12,25,43,32,56,36,37,38,42, &
+34,28,41,27,14,48,13,21,17,19, &
+18,12,23,43,30,49,29,37,33,35, &
+34,28,39,27,16,57,20,21,22,26, &
+!---- 4--7:
+20,54,52,22,40,24,32,25,42,31, &
+36,46,50,38,15,40,14,41,19,24, &
+13,48,45,17,31,15,30,23,35,40, &
+29,55,50,33,24,31,16,39,26,15, &
+!---- 8--9
+26,57,48,19,43,20,33,38,13,28, &
+42,56,53,35,27,36,22,17,29,12, &
+!---- 10:
+39,14,23,37,21,30,16,32,25,41, &
+!---- 11:
+34,34,18,18,18,34,34,18,34,18, &
+!==== 12--27:
+27, 0, 2, 9,14,13,15,16,24,20, & ! 12
+19, 8, 1, 6,15,12,14,17,25,21, &
+16, 5,10, 1,12,15,13,18,26,22, &
+39, 5, 7, 6,13,14,12,19,27,23, &
+!--
+14,10, 7, 3,18,17,19,12,20,24, & ! 16
+55, 6, 9, 1,19,16,18,13,21,25, &
+34, 0, 2,11,16,19,17,14,22,26, &
+13, 1, 5, 8,17,18,16,15,23,27, &
+!--
+26, 3, 8, 4,22,21,23,24,16,12, & ! 20
+37, 1, 3,10,23,20,22,25,17,13, &
+46, 9, 4, 3,20,23,21,26,18,14, &
+40,10, 6, 2,21,22,20,27,19,15, &
+!--
+41, 5, 7, 4,26,25,27,20,12,16, & ! 24
+31, 4,10, 0,27,24,26,21,13,17, &
+20, 7, 3, 8,24,27,25,22,14,18, &
+12, 1, 3, 9,25,26,24,23,15,19, &
+!----- 28--43:
+43, 1, 3, 8,30,29,31,32,40,36, & !28
+35, 9, 2, 7,31,28,30,33,41,37, &
+32, 6,10, 2,28,31,29,34,42,38, &
+25, 6, 4, 7,29,30,28,35,43,39, &
+!--
+30,10, 4, 0,34,33,35,28,36,40, & ! 32
+54, 7, 8, 2,35,32,34,29,37,41, &
+18, 1, 3,11,32,35,33,30,38,42, &
+29, 2, 6, 9,33,34,32,31,39,43, &
+!--
+42, 0, 9, 5,38,37,39,40,32,28, & ! 36
+21, 2, 0,10,39,36,38,41,33,29, &
+50, 8, 5, 0,36,39,37,42,34,30, &
+15,10, 7, 3,37,38,36,43,35,31, &
+!--
+23, 6, 4, 5,42,41,43,36,28,32, & ! 40
+24, 5,10, 1,43,40,42,37,29,33, &
+36, 4, 0, 9,40,43,41,38,30,34, &
+28, 2, 0, 8,41,42,40,39,31,35, &
+!------ 44--59:
+53, 9, 4, 6,45,46,47,56,48,52, & ! 44
+17, 6, 0, 4,44,47,46,57,49,53, &
+22, 1, 9, 5,47,44,45,58,50,54, &
+38, 6, 8, 2,46,45,44,59,51,55, &
+!--
+17, 8, 6, 1,49,50,51,52,44,56, & ! 48
+33, 2, 7, 9,48,51,50,53,45,57, &
+38, 7, 3, 5,51,48,49,54,46,58, &
+58, 7, 5, 8,50,49,48,55,47,59, &
+!--
+22, 4, 2, 6,53,54,55,48,56,44, & ! 52
+44, 9, 6, 4,52,55,54,49,57,45, &
+33, 4, 8, 0,55,52,53,50,58,46, &
+17, 3, 9, 7,54,53,52,51,59,47, &
+!--
+38, 0, 5, 9,57,58,59,44,52,48, & ! 56
+22, 8, 4, 3,56,59,58,45,53,49, &
+51, 5, 7, 8,59,56,57,46,54,50, &
+33, 5, 1, 7,58,57,56,47,55,51/
+data dcol10/ &
+!==== 0--3:
+ 4, 3,13, 4,14, 0, 0, 3, 2, 5, &
+ 8, 6,11, 8,13, 0, 0, 6, 4,10, & ! previous row *2
+ 1,12, 7, 1,11, 0, 0,12, 8, 5, & !
+ 2, 9,14, 2, 7, 0, 0, 9, 1,10, & !
+!---- 4--7:
+13, 2, 1, 7, 1,14, 0, 0, 2, 6, & ! previous row *2, except cols 1 and 2
+11, 4, 2,14, 2,13, 0, 0, 4,12, &
+ 7, 3, 4,13, 4,11, 0, 0, 8, 9, &
+14, 1, 3,11, 8, 7, 0, 0, 1, 3, &
+!---- 8--9:
+ 2, 1, 4, 8, 5, 1, 9, 6, 4, 0, &
+ 4, 2, 3, 1,10, 2, 3,12, 8, 0, &
+!---- 10:
+11,14,13,10, 5,13,11, 7, 7,14, &
+!---- 11:
+ 2, 8,13,10, 7,11,14, 1, 5, 4/
+data dcol12/ &
+!===== 12--27:
+10,12, 3, 0, & ! 12
+ 4,11, 0, 8, & ! 13
+12, 0, 1, 2, & ! 14
+12,13,12, 4, & ! 15
+!--
+ 3, 4, 0, 8, & ! 16
+ 1, 2, 3,11, & ! 17
+10,11,14, 2, & ! 18
+11, 5,11, 7, & ! 19
+!--
+ 1, 0,14, 2, & ! 20
+ 5, 9, 6,10, & ! 21
+ 4,12, 8,14, & ! 22
+ 9, 2, 0, 8, & ! 23
+!--
+ 3, 3, 7, 1, & ! 24
+ 6, 0, 8, 2, & ! 25
+14,14, 5,13, & ! 26
+ 5, 7,13, 5, & ! 27
+!------ 28--43:
+ 5, 9, 6, 0, & ! 28
+ 8, 7, 0, 1, & ! 29
+ 9, 0, 2, 4, & ! 30
+ 9,11, 9, 8, & ! 31
+!--
+ 6, 8, 0, 1, & ! 32
+ 2, 4, 6, 7, & ! 33
+ 5, 7,13, 1, & ! 34
+ 7,10, 7,14, & ! 35
+!--
+ 2, 0,13, 4, & ! 36
+10, 3,12, 5, & ! 37
+ 3, 9, 1,13, & ! 38
+ 3, 4, 0, 1, & ! 39
+!--
+ 6, 6,14, 2, & ! 40
+12, 0, 1, 4, & ! 41
+13,13,10,11, & ! 42
+10,14,11,10, & ! 43
+!------- 44--59:
+ 1, 3, 4, 2, & ! 44
+ 9,11, 5, 9, & ! 45
+11, 5, 8,11, & ! 46
+ 7, 7, 1,10, & ! 47
+!--
+ 4,11,12, 0, & ! 48
+ 8, 0, 9, 7, & ! 49
+12,12,10,13, & ! 50
+ 2, 4, 8, 6, & ! 51
+!--
+ 6,14, 5, 6, & ! 52
+ 4,12, 1, 8, & ! 53
+13,13, 4,10, & ! 54
+14, 5, 2,14, & ! 55
+!--
+ 2, 0, 6,13, & ! 56
+ 1,14, 3, 0, & ! 57
+ 3, 1, 2, 9, & ! 58
+ 3, 3,10, 7/ ! 59
+data nei0a/45,54, 46,59, 52,47, 55,50/ ! k=0--3
+data nei0b/57,53, 44,45, 58,56, 59,51,& ! k=4--5
+ 44,47, 53,52, 51,49, 58,59,& ! k=6--7
+ 54,58, 47,51, 44,46, 55,49/ ! k=8--9
+data nei17/48,45/
+data nei22/57,52/
+data nei33/59,49/
+data nei38/56,47/
+data jcora/6,3, 2,5, 6,3, 2,5/ ! k=0--3
+data jcorb/6,3,6,3, 2,5,2,5, 4,1,6,3, 2,5,6,3, 6,3,6,3, 2,5,6,3/
+data tcors/2,0,0,0, 0,2,0,0, 0,0,2,0, 0,0,0,2, & ! twice the identity
+ 1,1,-1,-1, 1,-1,-1,1, -1,1,-1,1, 1,1,1,1, & ! A_1
+ 1,-1,-1,-1, -1,-1,-1,1, 1,-1,1,1, -1,-1,1,-1, & ! A_2
+ 1,-1,1,-1, -1,-1,-1,-1, -1,-1,1,1, -1,1,1,-1, & ! B_1
+ 1,-1,1,1, 1,1,-1,1, 1,-1,-1,-1, 1,1,1,-1, & ! B_2
+ 1,1,1,1, -1,1,-1,1, 1,-1,-1,1, 1,1,-1,-1, & ! C_1
+ 1,1,-1,1, 1,-1,1,1, -1,-1,-1,1, -1,1,1,1, &
+ 2,0,2,0, 2,2,0,2, 0,0,0,2, -2,-2,-2,-2, & ! to 11, jcol=1
+ 2,0,2,2, 2,0,0,0, -2,-2,-2,-2, -2,0,0,-2, & ! to 11 jcol=2
+ 0,2,0,0, -2,0,-2,0, 2,0,0,2, 0,-2,0,-2, & ! to 11 jcol=3
+ 2,2,0,2, -2,0,-2,-2, 0,-2,0,-2, 0,0,2,0, & ! to 11 jcol=4
+ 1,1,1,-1, -1,1,1,1, -1,-1,1,-1, 1,-1,1,1, & ! >11 to>43,jcol=1
+ 1,-1,-1,1, 1,1,-1,-1, 1,1,1,1, -1,1,-1,1/ ! >11 to>43,jcol=2
+data kcor10a5/0,2,1, 0,1,2, 0,2,1, 0,1,2/
+data kcor10b1/0,1,2, 0,2,1, 1,2,0, 0,2,1, 1,0,2, 1,2,0/
+data kcor10b2/0,2,1, 0,1,2, 0,2,1, 1,2,0, 0,1,2, 2,1,0/
+
+data kcor12b0/0,1,2,2, 1,2,0,0, 2,0,1,2, 1,1,0,0, &
+ 0,1,2,2, 1,2,0,0, 2,0,1,2, 1,1,0,0, &
+ 0,1,2,2, 0,1,0,1, 1,0,2,2, 1,0,0,0/
+data kcor17c0/0,1,2/
+data kcor22c0/2,1,0/
+data kcor33c0/0,2,1/
+data kcor38c0/0,1,2/
+data kcor44c0/1,0,2/
+data kcor51c0/2,1,0/
+data kcor53c0/1,0,2/
+data kcor58c0/1,0,2/
+data twt10a5/ &
+ 0,-1,-1, 0,-1, 2, 0, 0, 1,-1, & !
+ 0,-1, 0,-1,-1, 2,-1, 1, 0, 0, & !
+ 1, 0,-1,-1, 0, 2,-1, 0, 0,-1/ !
+data twt10b1/ &
+ 0, 2, 0,-1,-1,-1, 1,-1, 0, 0, & !
+ 1, 2, 0,-1, 0, 0, 0,-1,-1,-1, & !
+ 0, 2, 1, 0,-1,-1, 0, 0,-1,-1/
+data twt10b2/ &
+-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & !
+-1, 0, 2, 0,-1, 0,-1, 1,-1, 0, & !
+ 0, 1, 2, 0,-1,-1, 0, 0,-1,-1/ !
+data twt12c0/ &
+ 2, 0, 1, 0,-1, 0,-1,-1, 0,-1, & ! 0
+ 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0
+ 2, 1, 0, 0,-1,-1, 0,-1,-1, 0/ ! 0
+data qwt10a/ &
+! -------------------------------------------- 0
+ 2, 0,-1, 0, 1, 0,-1,-1,-1, 0, & ! 0
+ 0, 2, 1, 0,-1,-1, 0, 0,-1,-1, & ! 1
+-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & ! 2
+ 0,-1, 0, 2, 1,-1,-1,-1, 0, 0, & ! 3
+ 0,-1,-1, 0, 2,-1, 0, 0,-1, 1, & ! 4
+ 0,-1,-1, 0,-1, 2, 0, 0, 1,-1, & ! 5
+-1, 0,-1, 0,-1, 0, 2,-1, 1, 0, & ! 6
+-1, 0, 1, 0,-1, 0,-1, 2,-1, 0, & ! 7
+ 0,-1,-1, 0,-1, 1, 0, 0, 2,-1, & ! 8
+-1,-1, 0,-1, 0, 0, 0, 1,-1, 2/ ! 9
+data qwt10b/ &
+! -------------------------------------------- 4
+ 2, 0,-1,-1, 0, 1,-1, 0, 0,-1, & ! 0
+ 0, 2, 0,-1,-1,-1, 1,-1, 0, 0, & ! 1
+-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & ! 2
+-1, 0, 1, 2, 0,-1,-1, 0, 0,-1, & ! 3
+ 0,-1, 0, 1, 2,-1,-1,-1, 0, 0, & ! 4
+ 0,-1,-1, 0,-1, 2, 0, 0, 1,-1, & ! 5
+-1, 0,-1,-1, 0,-1, 2, 0, 0, 1, & ! 6
+-1,-1, 0,-1, 0, 0, 0, 2,-1, 1, & ! 7
+-1, 0,-1, 0,-1, 0, 1,-1, 2, 0, & ! 8
+-1,-1, 0,-1, 0, 0, 0, 1,-1, 2/ ! 9
+data qwt10c/ &
+! -------------------------------------------- 8
+ 2, 0,-1,-1, 0, 1,-1, 0, 0,-1, & ! 0
+ 1, 2, 0,-1, 0, 0, 0,-1,-1,-1, & ! 1
+-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & ! 2
+-1,-1, 0, 2, 0, 0, 0,-1, 1,-1, & ! 3
+ 0,-1,-1, 0, 2,-1, 0, 0,-1, 1, & ! 4
+ 1, 0,-1,-1, 0, 2,-1, 0, 0,-1, & ! 5
+ 0, 1, 0,-1,-1,-1, 2,-1, 0, 0, & ! 6
+-1, 0, 1, 0,-1, 0,-1, 2,-1, 0, & ! 7
+-1,-1, 0, 1, 0, 0, 0,-1, 2,-1, & ! 8
+ 0,-1,-1, 0, 1,-1, 0, 0,-1, 2/ ! 9
+data qwt10d/ &
+! -------------------------------------------- 10
+ 2, 1, 0,-1, 0, 0, 0,-1,-1,-1, & ! 0
+ 0, 2, 0,-1,-1,-1, 1,-1, 0, 0, & ! 1
+-1, 0, 2, 0,-1, 0,-1, 1,-1, 0, & ! 2
+ 0,-1, 0, 2, 1,-1,-1,-1, 0, 0, & ! 3
+ 0,-1, 0, 1, 2,-1,-1,-1, 0, 0, & ! 4
+ 0,-1, 0,-1,-1, 2,-1, 1, 0, 0, & ! 5
+ 0, 1, 0,-1,-1,-1, 2,-1, 0, 0, & ! 6
+ 0,-1, 0,-1,-1, 1,-1, 2, 0, 0, & ! 7
+ 0,-1,-1, 0,-1, 1, 0, 0, 2,-1, & ! 8
+-1, 0,-1,-1, 0,-1, 1, 0, 0, 2/ ! 9
+data qwt10e/ &
+! -------------------------------------------- 11
+ 2, 0,-1, 0, 1, 0,-1,-1,-1, 0, & ! 0
+ 0, 2, 1, 0,-1,-1, 0, 0,-1,-1, & ! 1
+ 0, 1, 2, 0,-1,-1, 0, 0,-1,-1, & ! 2
+-1,-1, 0, 2, 0, 0, 0,-1, 1,-1, & ! 3
+ 1, 0,-1, 0, 2, 0,-1,-1,-1, 0, & ! 4
+ 0,-1, 0,-1,-1, 2,-1, 1, 0, 0, & ! 5
+-1, 0,-1,-1, 0,-1, 2, 0, 0, 1, & ! 6
+ 0,-1, 0,-1,-1, 1,-1, 2, 0, 0, & ! 7
+-1,-1, 0, 1, 0, 0, 0,-1, 2,-1, & ! 8
+-1, 0,-1,-1, 0,-1, 1, 0, 0, 2/ ! 9
+data qwt12a/ &
+! -------------------------------------------- 12
+ 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0
+ 1, 2, 0, 0,-1,-1, 0,-1,-1, 0, & ! 1
+ 1, 0, 2, 0,-1, 0,-1,-1, 0,-1, & ! 2
+ 1, 0, 0, 2, 0,-1,-1, 0,-1,-1, & ! 3
+-1,-1,-1,-1, 2, 1, 1, 0, 0, 0, & ! 4
+-1,-1,-1,-1, 1, 2, 1, 0, 0, 0, & ! 5
+-1,-1,-1,-1, 1, 1, 2, 0, 0, 0, & ! 6
+-1,-1,-1,-1, 0, 0, 0, 2, 1, 1, & ! 7
+-1,-1,-1,-1, 0, 0, 0, 1, 2, 1, & ! 8
+-1,-1,-1,-1, 0, 0, 0, 1, 1, 2/ ! 9
+data qwt12b/ &
+! -------------------------------------------- 44
+ 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0
+ 1, 2, 0, 0,-1,-1, 0,-1,-1, 0, & ! 1
+ 1, 0, 2, 0,-1, 0,-1,-1, 0,-1, & ! 2
+ 1, 0, 0, 2, 0,-1,-1, 0,-1,-1, & ! 3
+-1,-1,-1,-1, 2, 1, 1, 0, 0, 0, & ! 4
+-1,-1,-1,-1, 1, 2, 1, 0, 0, 0, & ! 5
+-1,-1,-1,-1, 1, 1, 2, 0, 0, 0, & ! 6
+-1,-1,-1,-1, 0, 0, 0, 2, 1, 1, & ! 7
+-1,-1,-1,-1, 0, 0, 0, 1, 2, 1, & ! 8
+-1,-1,-1,-1, 0, 0, 0, 1, 1, 2/! 9
+data qwt12b0/ &
+ 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0
+ 2, 1, 0, 0,-1,-1, 0,-1,-1, 0, & ! 12
+ 2, 0, 1, 0,-1, 0,-1,-1, 0,-1/! 0
+data tperms/ &
+0,1,2,3,4,5,6,7,8,9, &
+9,8,1,7,3,0,2,5,6,4, & ! 1
+6,4,5,1,9,7,8,0,2,3, & ! 2
+7,3,8,9,1,2,0,5,6,4, & ! 3
+4,6,3,5,9,7,8,2,0,1, & ! 4
+8,9,7,2,0,3,1,5,6,4, & ! 5
+5,2,6,4,9,7,8,3,1,0, & ! 6
+8,5,7,2,3,6,0,9,1,4, & ! 7
+1,6,9,7,2,0,8,4,5,3, & ! 8
+5,0,4,9,7,8,1,3,6,2, & ! 9
+6,8,3,4,9,1,5,2,0,7, & ! 10
+0,5,4,6,9,7,8,1,3,2, & ! 11
+0,7,9,8,2,1,3,5,6,4/ ! 12
+data perm10/ &
+! -------------------------------- 0
+1,9,8,2,0,6,7,4,5,3, & ! 0
+9,1,0,3,7,8,6,2,4,5, & ! 1
+6,4,3,0,1,8,5,7,2,9, & ! 2
+1,9,8,2,0,6,4,7,5,3, & ! 3
+4,5,9,7,3,6,2,1,8,0, & ! 4
+9,7,5,2,8,1,3,6,0,4, & ! 5
+5,6,4,3,7,2,1,8,0,9, & ! 6
+9,1,0,3,4,8,6,2,7,5, & ! 7
+1,9,5,4,6,0,7,2,3,8, & ! 8
+9,4,3,7,8,1,5,0,6,2, & ! 9
+! -------------------------------- 1
+1,9,8,2,0,6,7,4,5,3, & ! 0
+9,1,0,3,7,8,6,2,4,5, & ! 1
+6,4,3,0,1,8,5,7,2,9, & ! 2
+2,5,6,1,0,8,7,4,9,3, & ! 3
+7,9,5,4,3,8,1,2,6,0, & ! 4
+4,6,8,2,5,3,1,7,0,9, & ! 5
+9,8,7,3,4,1,2,6,0,5, & ! 6
+5,2,0,3,7,6,8,1,4,9, & ! 7
+2,5,9,7,8,0,4,1,3,6, & ! 8
+5,7,3,4,6,2,9,0,8,1, & ! 9
+! -------------------------------- 2
+2,5,6,1,0,8,4,7,9,3, & ! 0
+5,2,0,3,4,6,8,1,7,9, & ! 1
+8,7,3,0,2,6,9,4,1,5, & ! 2
+2,5,6,1,0,8,7,4,9,3, & ! 3
+7,9,5,4,3,8,1,2,6,0, & ! 4
+9,7,5,2,8,1,3,6,0,4, & ! 5
+9,8,7,3,4,1,2,6,0,5, & ! 6
+5,2,0,3,7,6,8,1,4,9, & ! 7
+2,5,9,7,8,0,4,1,3,6, & ! 8
+5,7,3,4,6,2,9,0,8,1, & ! 9
+! -------------------------------- 3
+2,5,6,1,0,8,4,7,9,3, & ! 0
+5,2,0,3,4,6,8,1,7,9, & ! 1
+8,7,3,0,2,6,9,4,1,5, & ! 2
+1,9,8,2,0,6,4,7,5,3, & ! 3
+4,5,9,7,3,6,2,1,8,0, & ! 4
+4,6,8,2,5,3,1,7,0,9, & ! 5
+5,6,4,3,7,2,1,8,0,9, & ! 6
+9,1,0,3,4,8,6,2,7,5, & ! 7
+1,9,5,4,6,0,7,2,3,8, & ! 8
+9,4,3,7,8,1,5,0,6,2, & ! 9
+! -------------------------------- 4
+3,4,6,8,7,0,5,1,2,9, & ! 0
+9,1,6,4,8,7,0,5,3,2, & ! 1
+7,9,1,0,3,5,8,6,2,4, & ! 2
+6,1,0,2,5,7,9,3,8,4, & ! 3
+5,6,1,0,2,4,7,9,3,8, & ! 4
+4,6,8,2,5,3,1,7,0,9, & ! 5
+4,5,6,7,3,9,2,1,8,0, & ! 6
+4,8,9,7,3,6,2,1,5,0, & ! 7
+5,2,8,9,7,6,0,4,1,3, & ! 8
+7,6,1,9,8,3,5,0,4,2, & ! 9
+! -------------------------------- 5
+3,4,6,8,7,0,5,1,2,9, & ! 0
+4,3,7,9,5,6,0,8,1,2, & ! 1
+6,4,3,0,1,8,5,7,2,9, & ! 2
+6,1,0,2,5,7,9,3,8,4, & ! 3
+9,8,2,0,1,7,4,5,3,6, & ! 4
+4,6,8,2,5,3,1,7,0,9, & ! 5
+7,9,8,4,3,5,1,2,6,0, & ! 6
+4,8,9,7,3,6,2,1,5,0, & ! 7
+9,1,6,5,4,8,0,7,2,3, & ! 8
+4,8,2,5,6,3,9,0,7,1, & ! 9
+! -------------------------------- 6
+3,7,8,6,4,0,9,2,1,5, & ! 0
+0,2,8,9,1,3,5,7,4,6, & ! 1
+7,9,1,0,3,5,8,6,2,4, & ! 2
+8,2,0,1,9,4,5,3,6,7, & ! 3
+9,8,2,0,1,7,4,5,3,6, & ! 4
+7,8,6,1,9,3,2,4,0,5, & ! 5
+7,9,8,4,3,5,1,2,6,0, & ! 6
+7,6,5,4,3,8,1,2,9,0, & ! 7
+9,1,6,5,4,8,0,7,2,3, & ! 8
+4,8,2,5,6,3,9,0,7,1, & ! 9
+! -------------------------------- 7
+3,7,8,6,4,0,9,2,1,5, & ! 0
+4,3,7,9,5,6,0,8,1,2, & ! 1
+8,9,1,6,4,2,7,0,5,3, & ! 2
+8,2,0,1,9,4,5,3,6,7, & ! 3
+5,6,1,0,2,4,7,9,3,8, & ! 4
+7,8,6,1,9,3,2,4,0,5, & ! 5
+4,5,6,7,3,9,2,1,8,0, & ! 6
+7,6,5,4,3,8,1,2,9,0, & ! 7
+5,2,8,9,7,6,0,4,1,3, & ! 8
+7,6,1,9,8,3,5,0,4,2, & ! 9
+! -------------------------------- 8
+3,7,8,6,4,0,9,2,1,5, & ! 0
+0,1,6,5,2,3,9,4,7,8, & ! 1
+5,6,1,0,2,7,4,9,3,8, & ! 2
+8,6,4,3,7,2,1,5,0,9, & ! 3
+4,6,8,7,3,5,1,2,9,0, & ! 4
+0,1,6,7,3,2,9,5,8,4, & ! 5
+3,0,1,9,4,7,2,6,8,5, & ! 6
+5,2,0,3,7,6,8,1,4,9, & ! 7
+4,8,2,0,3,6,9,5,1,7, & ! 8
+1,6,8,2,0,9,4,7,5,3, & ! 9
+! -------------------------------- 9
+3,7,8,6,4,0,9,2,1,5, & ! 0
+0,3,7,8,2,1,4,9,6,5, & ! 1
+2,0,1,6,5,8,3,9,4,7, & ! 2
+8,6,4,3,7,2,1,5,0,9, & ! 3
+7,8,6,4,3,9,2,1,5,0, & ! 4
+0,1,6,7,3,2,9,5,8,4, & ! 5
+3,0,2,5,7,4,1,8,6,9, & ! 6
+9,1,0,3,4,8,6,2,7,5, & ! 7
+4,8,2,0,3,6,9,5,1,7, & ! 8
+2,8,6,1,0,5,7,4,9,3, & ! 9
+! -------------------------------- 10
+1,0,3,7,9,6,2,4,5,8, & ! 0
+5,2,8,7,6,4,0,9,3,1, & ! 1
+5,6,1,9,7,2,4,0,8,3, & ! 2
+2,5,4,3,0,8,9,6,7,1, & ! 3
+7,8,2,0,3,9,6,5,1,4, & ! 4
+8,9,1,6,7,2,4,0,5,3, & ! 5
+2,0,3,4,8,5,1,7,6,9, & ! 6
+3,7,9,8,4,0,5,1,2,6, & ! 7
+3,7,6,5,4,0,8,1,2,9, & ! 8
+6,1,9,4,5,7,0,8,3,2, & ! 9
+! -------------------------------- 11
+3,4,5,2,0,7,6,9,8,1, & ! 0
+7,3,0,1,9,8,4,2,6,5, & ! 1
+2,0,3,7,8,5,1,4,9,6, & ! 2
+9,5,4,3,7,1,2,6,0,8, & ! 3
+0,1,6,4,3,2,9,8,5,7, & ! 4
+4,6,1,9,5,3,8,0,7,2, & ! 5
+8,7,9,5,2,6,3,1,4,0, & ! 6
+1,9,7,8,6,0,5,3,2,4, & ! 7
+6,8,2,0,1,4,7,5,3,9, & ! 8
+5,2,8,6,4,9,0,7,1,3/ ! 9
+data perm12/ &
+! -------------------------------- 12
+0,4,7,3,1,9,6,2,8,5, & ! 0
+2,1,7,3,8,9,6,4,5,0, & ! 1
+2,7,1,3,4,0,5,8,6,9, & ! 2
+4,3,0,9,7,5,2,6,1,8, & ! 3
+! -------------------------------- 13
+0,3,4,7,8,5,2,9,6,1, & ! 0
+3,8,2,4,0,7,5,9,1,6, & ! 1
+8,5,6,3,4,9,7,2,1,0, & ! 2
+5,8,7,0,4,9,3,1,2,6, & ! 3
+! -------------------------------- 14
+0,9,1,6,5,2,8,4,3,7, & ! 0
+9,6,7,4,3,5,8,0,2,1, & ! 1
+6,9,1,8,5,0,4,3,2,7, & ! 2
+9,6,7,4,3,2,8,0,5,1, & ! 3
+! -------------------------------- 15
+0,5,2,8,9,1,6,7,3,4, & ! 0
+3,4,2,8,6,7,9,5,1,0, & ! 1
+7,2,9,5,8,6,1,0,4,3, & ! 2
+8,3,6,5,7,9,2,0,1,4, & ! 3
+! -------------------------------- 16
+0,2,5,8,7,4,3,9,6,1, & ! 0
+1,6,0,2,3,5,8,7,4,9, & ! 1
+9,7,6,4,0,1,2,3,8,5, & ! 2
+9,7,6,4,0,1,5,3,8,2, & ! 3
+! -------------------------------- 17
+0,5,2,8,7,3,4,9,1,6, & ! 0
+2,3,1,7,5,6,8,9,0,4, & ! 1
+2,1,7,3,4,9,6,8,5,0, & ! 2
+5,7,0,8,6,1,9,3,4,2, & ! 3
+! -------------------------------- 18
+0,4,7,3,2,8,5,1,9,6, & ! 0
+4,0,3,9,7,8,5,6,2,1, & ! 1
+4,3,0,9,6,1,2,7,5,8, & ! 2
+1,6,0,2,7,5,9,3,4,8, & ! 3
+! -------------------------------- 19
+0,9,6,1,2,5,8,3,4,7, & ! 0
+7,9,5,2,3,0,4,1,8,6, & ! 1
+6,1,8,9,4,3,2,7,5,0, & ! 2
+8,6,5,3,2,7,1,4,0,9, & ! 3
+! -------------------------------- 20
+0,7,3,4,5,2,8,6,1,9, & ! 0
+8,6,5,3,2,0,1,4,7,9, & ! 1
+0,1,5,4,9,7,2,3,8,6, & ! 2
+5,7,8,0,1,6,2,4,3,9, & ! 3
+! -------------------------------- 21
+0,7,4,3,1,6,9,2,5,8, & ! 0
+2,7,1,3,8,0,5,4,6,9, & ! 1
+2,1,7,3,4,9,6,8,5,0, & ! 2
+3,8,2,4,9,7,6,0,1,5, & ! 3
+! -------------------------------- 22
+0,2,5,8,9,6,1,7,4,3, & ! 0
+1,6,2,0,5,3,8,4,7,9, & ! 1
+2,1,3,7,9,4,0,5,8,6, & ! 2
+5,0,7,8,3,2,4,6,9,1, & ! 3
+! -------------------------------- 23
+0,9,1,6,5,2,8,4,3,7, & ! 0
+7,2,5,9,6,0,1,4,8,3, & ! 1
+9,6,7,4,3,2,1,0,5,8, & ! 2
+3,8,4,2,7,9,5,1,0,6, & ! 3
+! -------------------------------- 24
+0,1,9,6,4,7,3,5,8,2, & ! 0
+7,9,2,5,0,3,4,8,1,6, & ! 1
+3,2,4,8,5,0,1,6,9,7, & ! 2
+8,6,3,5,0,4,1,7,2,9, & ! 3
+! -------------------------------- 25
+0,2,5,8,7,4,3,9,6,1, & ! 0
+9,7,6,4,0,8,5,3,1,2, & ! 1
+5,7,8,0,4,3,2,1,6,9, & ! 2
+3,4,8,2,1,6,0,7,5,9, & ! 3
+! -------------------------------- 26
+0,8,5,2,3,4,7,1,6,9, & ! 0
+6,8,1,9,7,0,5,4,2,3, & ! 1
+7,5,9,2,1,6,8,3,4,0, & ! 2
+5,8,7,0,4,9,3,1,2,6, & ! 3
+! -------------------------------- 27
+0,4,7,3,1,9,6,2,8,5, & ! 0
+4,3,0,9,7,1,2,6,5,8, & ! 1
+4,0,3,9,6,8,5,7,2,1, & ! 2
+9,7,6,4,3,8,2,0,1,5, & ! 3
+! -------------------------------- 28
+0,4,7,3,1,9,6,2,8,5, & ! 0
+2,1,7,3,8,9,6,4,5,0, & ! 1
+2,7,1,3,4,0,5,8,6,9, & ! 2
+4,0,3,9,6,8,1,7,2,5, & ! 3
+! -------------------------------- 29
+0,3,4,7,8,5,2,9,6,1, & ! 0
+3,8,2,4,0,7,5,9,1,6, & ! 1
+8,5,6,3,4,9,7,2,1,0, & ! 2
+5,8,7,0,4,9,3,1,2,6, & ! 3
+! -------------------------------- 30
+0,9,1,6,5,2,8,4,3,7, & ! 0
+9,6,7,4,3,5,8,0,2,1, & ! 1
+7,2,5,9,6,8,3,4,0,1, & ! 2
+9,6,7,4,3,2,8,0,5,1, & ! 3
+! -------------------------------- 31
+0,9,1,6,5,2,8,4,3,7, & ! 0
+3,4,2,8,6,7,9,5,1,0, & ! 1
+7,2,9,5,8,6,1,0,4,3, & ! 2
+8,3,6,5,7,9,2,0,1,4, & ! 3
+! -------------------------------- 32
+0,2,5,8,7,4,3,9,6,1, & ! 0
+5,7,8,0,4,6,9,1,3,2, & ! 1
+9,7,6,4,0,1,2,3,8,5, & ! 2
+9,7,6,4,0,1,5,3,8,2, & ! 3
+! -------------------------------- 33
+0,8,2,5,6,1,9,4,3,7, & ! 0
+2,3,1,7,5,6,8,9,0,4, & ! 1
+1,2,6,0,4,9,7,5,8,3, & ! 2
+5,7,0,8,6,1,9,3,4,2, & ! 3
+! -------------------------------- 34
+0,7,4,3,1,6,9,2,5,8, & ! 0
+4,0,3,9,7,8,5,6,2,1, & ! 1
+4,3,0,9,6,1,2,7,5,8, & ! 2
+9,7,4,6,8,3,5,1,0,2, & ! 3
+! -------------------------------- 35
+0,9,6,1,2,5,8,3,4,7, & ! 0
+7,9,5,2,3,0,4,1,8,6, & ! 1
+6,1,8,9,4,3,2,7,5,0, & ! 2
+8,6,5,3,2,7,1,4,0,9, & ! 3
+! -------------------------------- 36
+0,7,3,4,5,2,8,6,1,9, & ! 0
+8,6,5,3,2,0,1,4,7,9, & ! 1
+0,1,5,4,9,7,2,3,8,6, & ! 2
+5,7,8,0,1,6,2,4,3,9, & ! 3
+! -------------------------------- 37
+0,4,7,3,2,8,5,1,9,6, & ! 0
+2,7,1,3,8,0,5,4,6,9, & ! 1
+2,1,7,3,4,9,6,8,5,0, & ! 2
+4,9,0,3,2,1,7,8,5,6, & ! 3
+! -------------------------------- 38
+0,4,3,7,9,1,6,8,2,5, & ! 0
+2,7,1,3,8,0,5,4,6,9, & ! 1
+2,1,3,7,9,4,0,5,8,6, & ! 2
+5,0,7,8,3,2,4,6,9,1, & ! 3
+! -------------------------------- 39
+0,5,2,8,9,1,6,7,3,4, & ! 0
+1,0,6,2,7,8,5,3,9,4, & ! 1
+9,6,7,4,3,2,1,0,5,8, & ! 2
+3,8,4,2,7,9,5,1,0,6, & ! 3
+! -------------------------------- 40
+0,2,5,8,7,4,3,9,6,1, & ! 0
+7,9,2,5,0,3,4,8,1,6, & ! 1
+3,2,4,8,5,0,1,6,9,7, & ! 2
+8,6,3,5,0,4,1,7,2,9, & ! 3
+! -------------------------------- 41
+0,1,9,6,4,7,3,5,8,2, & ! 0
+9,7,6,4,0,8,5,3,1,2, & ! 1
+6,1,9,8,3,4,0,5,7,2, & ! 2
+3,4,8,2,1,6,0,7,5,9, & ! 3
+! -------------------------------- 42
+0,8,5,2,3,4,7,1,6,9, & ! 0
+6,8,1,9,7,0,5,4,2,3, & ! 1
+7,5,9,2,1,6,8,3,4,0, & ! 2
+5,8,7,0,4,9,3,1,2,6, & ! 3
+! -------------------------------- 43
+0,4,7,3,1,9,6,2,8,5, & ! 0
+4,3,0,9,7,1,2,6,5,8, & ! 1
+4,0,3,9,6,8,5,7,2,1, & ! 2
+9,6,7,4,0,5,1,3,2,8, & ! 3
+! -------------------------------- 44
+0,5,8,2,3,7,4,1,9,6, & ! 0
+2,1,3,7,5,4,0,9,8,6, & ! 1
+1,6,2,0,4,3,8,5,7,9, & ! 2
+2,3,7,1,0,5,4,6,9,8, & ! 3
+! -------------------------------- 45
+0,1,6,9,7,4,3,8,5,2, & ! 0
+3,2,8,4,9,5,7,0,6,1, & ! 1
+0,4,5,1,6,8,3,2,7,9, & ! 2
+7,9,5,2,1,0,6,3,8,4, & ! 3
+! -------------------------------- 46
+0,6,1,9,8,2,5,7,3,4, & ! 0
+7,5,2,9,6,3,8,4,1,0, & ! 1
+6,8,1,9,7,2,3,4,0,5, & ! 2
+6,8,9,1,0,4,5,2,7,3, & ! 3
+! -------------------------------- 47
+0,9,1,6,4,3,7,5,2,8, & ! 0
+6,1,9,8,3,7,2,5,4,0, & ! 1
+7,9,2,5,8,3,4,0,1,6, & ! 2
+7,9,2,5,0,1,4,8,3,6, & ! 3
+! -------------------------------- 48
+0,4,7,3,2,8,5,1,9,6, & ! 0
+3,2,4,8,6,0,1,5,9,7, & ! 1
+0,4,1,5,8,6,9,7,2,3, & ! 2
+8,6,3,5,0,4,1,7,2,9, & ! 3
+! -------------------------------- 49
+0,3,7,4,6,9,1,5,8,2, & ! 0
+8,5,3,6,9,2,7,1,4,0, & ! 1
+0,5,1,4,3,2,7,9,6,8, & ! 2
+3,8,4,2,7,9,5,1,0,6, & ! 3
+! -------------------------------- 50
+0,5,8,2,1,9,6,3,7,4, & ! 0
+7,2,5,9,4,8,3,6,0,1, & ! 1
+0,1,5,4,9,7,2,3,8,6, & ! 2
+3,4,8,2,1,6,0,7,5,9, & ! 3
+! -------------------------------- 51
+0,2,5,8,7,4,3,9,6,1, & ! 0
+2,1,7,3,8,9,6,4,5,0, & ! 1
+1,0,2,6,9,7,5,8,3,4, & ! 2
+1,6,0,2,7,5,9,3,4,8, & ! 3
+! -------------------------------- 52
+0,2,8,5,4,7,3,6,9,1, & ! 0
+3,2,8,4,9,5,7,0,6,1, & ! 1
+0,4,5,1,6,8,3,2,7,9, & ! 2
+7,9,5,2,1,0,6,3,8,4, & ! 3
+! -------------------------------- 53
+0,5,8,2,3,7,4,1,9,6, & ! 0
+1,2,0,6,8,4,3,9,5,7, & ! 1
+1,6,2,0,4,3,8,5,7,9, & ! 2
+2,3,7,1,0,5,4,6,9,8, & ! 3
+! -------------------------------- 54
+0,5,2,8,7,3,4,9,1,6, & ! 0
+6,1,9,8,3,7,2,5,4,0, & ! 1
+6,9,1,8,5,0,4,3,2,7, & ! 2
+7,9,2,5,0,1,4,8,3,6, & ! 3
+! -------------------------------- 55
+0,8,2,5,6,1,9,4,3,7, & ! 0
+7,5,2,9,6,3,8,4,1,0, & ! 1
+7,5,2,9,6,1,0,4,3,8, & ! 2
+6,8,9,1,0,4,5,2,7,3, & ! 3
+! -------------------------------- 56
+0,3,4,7,8,5,2,9,6,1, & ! 0
+8,5,3,6,9,2,7,1,4,0, & ! 1
+0,5,1,4,3,2,7,9,6,8, & ! 2
+0,5,4,1,6,9,8,2,3,7, & ! 3
+! -------------------------------- 57
+0,7,4,3,1,6,9,2,5,8, & ! 0
+0,1,4,5,7,3,2,8,9,6, & ! 1
+0,4,1,5,8,6,9,7,2,3, & ! 2
+8,6,3,5,0,4,1,7,2,9, & ! 3
+! -------------------------------- 58
+0,4,7,3,1,9,6,2,8,5, & ! 0
+2,1,7,3,8,9,6,4,5,0, & ! 1
+1,0,2,6,9,7,5,8,3,4, & ! 2
+2,7,3,1,6,8,9,0,4,5, & ! 3
+! -------------------------------- 59
+0,9,6,1,2,5,8,3,4,7, & ! 0
+7,2,5,9,4,8,3,6,0,1, & ! 1
+0,1,5,4,9,7,2,3,8,6, & ! 2
+3,4,8,2,1,6,0,7,5,9/ ! 3
+!======
+data perms/ &
+3,2,1,0,4,6,5,7,8,9, & ! 4
+2,3,0,1,6,5,4,7,8,9, & ! 5
+1,0,3,2,5,4,6,7,8,9, & ! 6
+3,2,1,0,4,5,6,7,9,8, & ! 7
+2,3,0,1,4,5,6,9,8,7, & ! 8
+1,0,3,2,4,5,6,8,7,9/ ! 9
+end module jp_pbfil2
+!#
diff --git a/src/mgbf/jp_pbfil3.f90 b/src/mgbf/jp_pbfil3.f90
new file mode 100644
index 0000000000..61a6932577
--- /dev/null
+++ b/src/mgbf/jp_pbfil3.f90
@@ -0,0 +1,2620 @@
+module jp_pbfil3
+!$$$ module documentation block
+! . . . .
+! module: jp_pbfil3
+! prgmmr: purser org: NOAA/EMC date: 2021-08
+!
+! abstract: Codes for the beta line filters
+!
+! module history log:
+!
+! Subroutines Included:
+! t22_to_3 -
+! t2_to_3 -
+! t3_to_22 -
+! t33_to_6 -
+! t3_to_6 -
+! t6_to_33 -
+! t44_to_10 -
+! t4_to_10 -
+! t10_to_44 -
+! finmomtab -
+! inimomtab -
+! tritform -
+! tritformi -
+! triad -
+! gettrilu -
+! querytcol -
+! hextform -
+! hextformi -
+! hexad -
+! gethexlu -
+! queryhcol -
+! dectform -
+! dectformi -
+! decad -
+! getdeclu -
+! querydcol -
+! standardizeb -
+! hstform -
+! hstformi -
+! blinfil -
+! dibeta -
+! dibetat -
+!
+! Functions Included:
+!
+! remarks:
+! The routines of this module mostly involve the beta line filters.
+! Versions of these routines are provided in 2D, 3D and 4D, based respectively
+! on the Triad (3-lines), Hexad (6-lines), and Decad (10-lines) algorithms.
+! Some technical explanations are provided in the series of office notes,
+! ON498, ON499, ON500.
+!
+! The style of line filtering is the "Dibeta" combination of two
+! nonnegatively-weighted consecutive-imteger-half-span beta filters, whose
+! normalization coefficients are stored in the table, "bnorm" and whose
+! second moments (spread**2) are stored in the table "bsprds"; these
+! moment tables must be initialized in subr. inimomtab before any filtering
+! can be done. The max-halp-span size of the table is set by the user, so
+! the tables use allocatable space (in module jp_pbfil2); to deallocate this
+! storage, the user must invoke fintabmom once all filtering operations
+! have been completed.
+!
+! Aspect tensors in N dimensions are positive-definite and symmetric, and
+! therefore require M=(N*(N+1))/2 independent components, which we can arrange
+! into a vector of this size. The utility routines tNN_to_M do this; tM_to_NN
+! do the opposite. tN_to_M put the outer-product of an N-vector into the
+! corresponding M-vector.
+!
+! The filtering is preceded by a decomposition of the M components of the
+! aspect tensor, at each grid point, into M distinct line-second-moments
+! and the line-generators they each act along, at every grid point. And
+! since, in the general case, the aspect tensor is no longer needed once
+! the line filter specifications have been determined, it ic convenient to
+! over-write the old aspect tensor components with the new line-second-
+! moments ("spread**2"). In other word, we can express the needed action
+! as a formal "transform" (and invert it if ever needed, to recover the
+! original aspect tensor). The basic decomposition of the aspect tensor
+! into its spread**2 components and line generators is done, at a single
+! grid point using subroutine triad (2D), hexad (3D), decad (4D). Working
+! this into "transform" for a single point, is done in tritform, hextform,
+! dectform, and their respective inverse transforms in tritformi, hextfotmi,
+! dectformi. In the case of the 3D hexad method, although there are 6 active
+! line filters at any given point, each of those lines is associated with
+! one of the 7 different "colors" (our term for the nonnull Galois field
+! elements) no two of these colors in a given hexad are the same. The
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+use jp_pkind, only: spi,sp,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: T,F,u0,u1,u3,u4,u5,pi2
+implicit none
+private
+public:: t22_to_3,t2_to_3,t3_to_22,t33_to_6,t3_to_6,t6_to_33,&
+ t44_to_10,t4_to_10,t10_to_44, &
+ finmomtab,inimomtab, &
+ tritform,tritformi,triad,gettrilu,querytcol, &
+ hextform,hextformi,hexad,gethexlu,queryhcol, &
+ dectform,dectformi,decad,getdeclu,querydcol, &
+ hstform,hstformi,blinfil,dibeta,dibetat
+integer(spi),dimension(2,0:2):: i2pair
+integer(spi),dimension(2,6) :: i3pair
+integer(spi),dimension(2,10) :: i4pair
+data i2pair/1,1, 2,2, 1,2/
+data i3pair/1,1, 2,2, 3,3, 2,3, 3,1, 1,2/
+data i4pair/1,1, 2,2, 3,3, 4,4, 1,2, 1,3, 1,4, 3,4, 2,4, 2,3/
+
+interface t22_to_3; module procedure i22_to_3, r22_to_3; end interface
+interface t2_to_3; module procedure i2_to_3, r2_to_3; end interface
+interface t3_to_22; module procedure i3_to_22, r3_to_22; end interface
+interface t33_to_6; module procedure i33_to_6, r33_to_6; end interface
+interface t3_to_6; module procedure i3_to_6, r3_to_6; end interface
+interface t6_to_33; module procedure i6_to_33, r6_to_33; end interface
+interface t44_to_10; module procedure i44_to_10,r44_to_10; end interface
+interface t4_to_10; module procedure i4_to_10, r4_to_10; end interface
+interface t10_to_44; module procedure i10_to_44,r10_to_44; end interface
+!---
+interface finmomtab; module procedure finmomtab; end interface
+interface inimomtab; module procedure inimomtab; end interface
+interface tritform; module procedure tritforms,tritform; end interface
+interface tritformi; module procedure tritformi; end interface
+interface triad; module procedure triad; end interface
+interface gettrilu; module procedure gettrilu; end interface
+interface querytcol; module procedure querytcol; end interface
+interface hextform; module procedure hextforms,hextform; end interface
+interface hextformi; module procedure hextformi; end interface
+interface hexad; module procedure hexad; end interface
+interface gethexlu; module procedure gethexlu; end interface
+interface queryhcol; module procedure queryhcol; end interface
+interface dectform; module procedure dectforms,dectform; end interface
+interface dectformi; module procedure dectformi; end interface
+interface decad; module procedure decad; end interface
+interface getdeclu; module procedure getdeclu; end interface
+interface querydcol; module procedure querydcol; end interface
+!---
+interface standardizeb;module procedure standardizeb; end interface
+interface hstform; module procedure hstform; end interface
+interface hstformi; module procedure hstformi; end interface
+interface blinfil; module procedure blinfil; end interface
+interface dibeta
+ module procedure dibeta1,dibeta2,dibeta3,dibeta4, dibetax3,dibetax4, &
+ vdibeta1,vdibeta2,vdibeta3,vdibeta4, vdibetax3,vdibetax4
+end interface
+interface dibetat
+ module procedure dibeta1t,dibeta2t,dibeta3t,dibeta4t,dibetax3t, dibetax4t, &
+ vdibeta1t,vdibeta2t,vdibeta3t,vdibeta4t,vdibetax3t,vdibetax4t
+end interface
+
+contains
+
+!==============================================================================
+subroutine i22_to_3(i22,i3)! [t22_to_3]
+!==============================================================================
+use jp_pkind, only: spi
+implicit none
+integer(spi),dimension(2,2),intent(in ):: i22
+integer(spi),dimension(0:2),intent(out):: i3
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=0,2; i3(L)=i22(i2pair(1,L),i2pair(2,L)); enddo
+end subroutine i22_to_3
+!==============================================================================
+subroutine r22_to_3(r22,r3)! [t22_to_3]
+!==============================================================================
+use jp_pkind, only: spi,dp
+implicit none
+real(dp),dimension(2,2),intent(in ):: r22
+real(dp),dimension(0:2),intent(out):: r3
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=0,2; r3(L)=r22(i2pair(1,L),i2pair(2,L)); enddo
+end subroutine r22_to_3
+
+!==============================================================================
+subroutine i2_to_3(i2,i3)! [t2_to_3]
+!==============================================================================
+use jp_pkind, only: spi
+use jp_pmat4, only: outer_product
+implicit none
+integer(spi),dimension(2),intent(in ):: i2
+integer(spi),dimension(3),intent(out):: i3
+!------------------------------------------------------------------------------
+call t22_to_3(outer_product(i2,i2),i3)
+end subroutine i2_to_3
+!==============================================================================
+subroutine r2_to_3(r2,r3)! [t2_to_3]
+!==============================================================================
+use jp_pkind, only: dp
+use jp_pmat4, only: outer_product
+implicit none
+real(dp),dimension(2),intent(in ):: r2
+real(dp),dimension(3),intent(out):: r3
+!------------------------------------------------------------------------------
+call t22_to_3(outer_product(r2,r2),r3)
+end subroutine r2_to_3
+
+!==============================================================================
+subroutine i3_to_22(i3,i22)! [t3_to_22]
+!==============================================================================
+use jp_pkind, only: spi
+implicit none
+integer(spi),dimension(0:2),intent(in ):: i3
+integer(spi),dimension(2,2),intent(out):: i22
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=0,2
+ i22(i2pair(1,L),i2pair(2,L))=i3(L)
+ i22(i2pair(2,L),i2pair(1,L))=i3(L)
+enddo
+end subroutine i3_to_22
+!==============================================================================
+subroutine r3_to_22(r3,r22)! [t3_to_22]
+!==============================================================================
+use jp_pkind, only: spi,dp
+implicit none
+real(dp),dimension(0:2),intent(in ):: r3
+real(dp),dimension(2,2),intent(out):: r22
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=0,2
+ r22(i2pair(1,L),i2pair(2,L))=r3(L)
+ r22(i2pair(2,L),i2pair(1,L))=r3(L)
+enddo
+end subroutine r3_to_22
+
+!==============================================================================
+subroutine i33_to_6(i33,i6)! [t33_to_6]
+!==============================================================================
+use jp_pkind, only: spi
+implicit none
+integer(spi),dimension(3,3),intent(in ):: i33
+integer(spi),dimension(6) ,intent(out):: i6
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=1,6; i6(L)=i33(i3pair(1,L),i3pair(2,L)); enddo
+end subroutine i33_to_6
+!==============================================================================
+subroutine r33_to_6(r33,r6)! [t33_to_6]
+!==============================================================================
+use jp_pkind, only: spi,dp
+implicit none
+real(dp),dimension(3,3),intent(in ):: r33
+real(dp),dimension(6) ,intent(out):: r6
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=1,6; r6(L)=r33(i3pair(1,L),i3pair(2,L)); enddo
+end subroutine r33_to_6
+
+!==============================================================================
+subroutine i3_to_6(i3,i6)! [t3_to_6]
+!==============================================================================
+use jp_pkind, only: spi
+use jp_pmat4, only: outer_product
+implicit none
+integer(spi),dimension(3),intent(in ):: i3
+integer(spi),dimension(6),intent(out):: i6
+!------------------------------------------------------------------------------
+call t33_to_6(outer_product(i3,i3),i6)
+end subroutine i3_to_6
+!==============================================================================
+subroutine r3_to_6(r3,r6)! [t3_to_6]
+!==============================================================================
+use jp_pkind, only: dp
+use jp_pmat4, only: outer_product
+implicit none
+real(dp),dimension(3),intent(in ):: r3
+real(dp),dimension(6),intent(out):: r6
+!------------------------------------------------------------------------------
+call t33_to_6(outer_product(r3,r3),r6)
+end subroutine r3_to_6
+
+!==============================================================================
+subroutine i6_to_33(i6,i33)! [t6_to_33]
+!==============================================================================
+use jp_pkind, only: spi
+implicit none
+integer(spi),dimension(6), intent(in ):: i6
+integer(spi),dimension(3,3),intent(out):: i33
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=1,6
+ i33(i3pair(1,L),i3pair(2,L))=i6(L)
+ i33(i3pair(2,L),i3pair(1,L))=i6(L)
+enddo
+end subroutine i6_to_33
+!==============================================================================
+subroutine r6_to_33(r6,r33)! [t6_to_33]
+!==============================================================================
+use jp_pkind, only: spi,dp
+implicit none
+real(dp),dimension(6), intent(in ):: r6
+real(dp),dimension(3,3),intent(out):: r33
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=1,6
+ r33(i3pair(1,L),i3pair(2,L))=r6(L)
+ r33(i3pair(2,L),i3pair(1,L))=r6(L)
+enddo
+end subroutine r6_to_33
+
+!==============================================================================
+subroutine i44_to_10(i44,i10)! [t44_to_10]
+!==============================================================================
+use jp_pkind, only: spi
+implicit none
+integer(spi),dimension(4,4),intent(in ):: i44
+integer(spi),dimension(10) ,intent(out):: i10
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=1,10; i10(L)=i44(i4pair(1,L),i4pair(2,L)); enddo
+end subroutine i44_to_10
+!==============================================================================
+subroutine r44_to_10(r44,r10)! [t44_to_10]
+!==============================================================================
+use jp_pkind, only: spi,dp
+implicit none
+real(dp),dimension(4,4),intent(in ):: r44
+real(dp),dimension(10) ,intent(out):: r10
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=1,10; r10(L)=r44(i4pair(1,L),i4pair(2,L)); enddo
+end subroutine r44_to_10
+
+!==============================================================================
+subroutine i4_to_10(i4,i10)! [t4_to_10]
+!==============================================================================
+use jp_pkind, only: spi
+use jp_pmat4, only: outer_product
+implicit none
+integer(spi),dimension(4), intent(in ):: i4
+integer(spi),dimension(10),intent(out):: i10
+!------------------------------------------------------------------------------
+call t44_to_10(outer_product(i4,i4),i10)
+end subroutine i4_to_10
+!==============================================================================
+subroutine r4_to_10(r4,r10)! [t4_to_10]
+!==============================================================================
+use jp_pkind, only: dp
+use jp_pmat4, only: outer_product
+implicit none
+real(dp),dimension(4), intent(in ):: r4
+real(dp),dimension(10),intent(out):: r10
+!------------------------------------------------------------------------------
+call t44_to_10(outer_product(r4,r4),r10)
+end subroutine r4_to_10
+
+!==============================================================================
+subroutine i10_to_44(i10,i44)! [t10_to_44]
+!==============================================================================
+use jp_pkind, only: spi
+implicit none
+integer(spi),dimension(10), intent(in ):: i10
+integer(spi),dimension(4,4),intent(out):: i44
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=1,10
+ i44(i4pair(1,L),i4pair(2,L))=i10(L)
+ i44(i4pair(2,L),i4pair(1,L))=i10(L)
+enddo
+end subroutine i10_to_44
+!==============================================================================
+subroutine r10_to_44(r10,r44)! [t10_to_44]
+!==============================================================================
+use jp_pkind, only: spi,dp
+implicit none
+real(dp),dimension(10), intent(in ):: r10
+real(dp),dimension(4,4),intent(out):: r44
+!------------------------------------------------------------------------------
+integer(spi):: L
+!==============================================================================
+do L=1,10
+ r44(i4pair(1,L),i4pair(2,L))=r10(L)
+ r44(i4pair(2,L),i4pair(1,L))=r10(L)
+enddo
+end subroutine r10_to_44
+
+!--
+
+!================================================================== [finmomtab]
+subroutine finmomtab
+!==============================================================================
+! Finalize the moments table for dibeta filter applications.
+! Deallocate the space reserved for moment tables and reset p and nh to their
+! zero defaults.
+!==============================================================================
+use jp_pbfil2, only: p,nh,bnorm,bsprds
+implicit none
+p=0; nh=0
+if(allocated(bnorm))deallocate(bnorm)
+if(allocated(bsprds))deallocate(bsprds)
+end subroutine finmomtab
+
+!================================================================== [inimomtab]
+subroutine inimomtab(p_prescribe,nh_prescribe,ff)
+!==============================================================================
+! Initialize the moments table for dibeta filter applications.
+! For the given beta function exponent index, p, and nh half-spans, initialize
+! table of the normalizing coefficients, bnorm, and spread**2s, bsprds.
+! The calculation involves computing the continuum approximations, m0 and m2,
+! to the 0th and 2nd moments, and using the Euler-Maclaurin expansions
+! for the correction terms hm0 and hm2 so that the final corrected moments
+! cm0 and cm2 for each integer halfwidth up to nh .
+!==============================================================================
+use jp_pkind, only: spi,dp
+use jp_pietc, only: u0,u1,u2
+use jp_pbfil2, only: p,nh,bnorm,bsprds
+implicit none
+integer(spi),intent(in ):: p_prescribe,nh_prescribe
+logical, intent(out):: ff
+!------------------------------------------------------------------------------
+integer(spi),parameter :: nk0=2,nk2=nk0+1,np=6,np2p3=np*2+3
+real(dp),dimension(-1:np2p3) :: ffac
+real(dp) :: x,xx,m0,m2,hm0,hm2,cm0,cm2
+integer(spi),dimension(0:nk0,np):: n0pk
+integer(spi),dimension(0:nk2,np):: n2pk
+integer(spi) :: h,i,k,mk0,mk2,p2,p2m1,p2p1,p2p3
+data n0pk/ &
+ -1, 0, 0, &
+ -1, 0, 0, &
+ -5, 14, 0, &
+ -63, 240, 0, &
+ -1575, 6930, -2640, &
+ -68409, 327600, -216216/
+data n2pk/ &
+ 1, -5, 0, 0, &
+ 5, -21, 0, 0, &
+ 63, -285, 126, 0, &
+ 1575, -7623, 5280, 0, &
+ 68409, -348075, 306306, -34320, &
+ 4729725,-24969285, 25552800, -5405400/
+!==============================================================================
+call finmomtab ! Table arrays bnorm and bsprds must start off deallocated
+ff=(p_prescribe<1 .or. p_prescribe>np)
+if(ff)then
+ print'(" In inimomtab; prescribed exponent p out of bounds")'
+ return
+endif
+ff=(nh_prescribe<2 .or. nh_prescribe>1000)
+if(ff)then
+ print'(" In inimomtab; prescribed table size nh out of bounds")'
+ return
+endif
+p =p_prescribe
+nh=nh_prescribe
+allocate(bnorm(nh),bsprds(nh))
+! set up the ffac tables (double-factorial function)
+p2=p*2; p2m1=p2-1; p2p1=p2+1; p2p3=p2+3
+ffac(-1)=u1
+ffac(0)=u1
+do i=1,np2p3
+ ffac(i)=i*ffac(i-2)
+enddo
+mk0=(p-1)/2
+mk2=mk0+1
+do h=1,nh
+ x=h
+ xx=x*x
+ m0=u2*ffac(p2)*x/ffac(p2p1)
+ m2=u2*ffac(p2)*x**3/ffac(p2p3)
+ hm0=u0
+ do k=0,mk0
+ hm0=hm0+n0pk(k,p)*xx**k
+ enddo
+ hm2=u0
+ do k=0,mk2
+ hm2=hm2+n2pk(k,p)*xx**k
+ enddo
+ cm0=m0+hm0/(ffac(p2p1)*x**p2m1)
+ cm2=m2+hm2/(ffac(p2p3)*x**p2m1)
+ bnorm(h)=u1/cm0
+ bsprds(h)=cm2/cm0
+enddo
+end subroutine inimomtab
+
+!================================================================== [tritform]
+subroutine tritforms(lx,mx, ly,my, aspects, dixs,diys, ff)
+!=============================================================================
+! Perform direct Triad and hs transforms in a proper subdomain
+! domains extents in x, y, are lx:mx, ly:my
+! aspects: upon input, these are the 3-vectors of grid-relative aspect tensor
+! upon output, these are the 3 active line-filter half-spans.
+! dixs: x-component of each of the 6 active line generators
+! diys: y-component
+! ff: Logical failure flag, output .true. when failure occurs.
+! Note that the integer arrays, doxs, diys, are 1-byte integers.
+!==============================================================================
+
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+implicit none
+integer(spi), intent(in ):: lx,mx,ly,my
+real(dp), dimension(3,lx:mx,ly:my),intent(inout):: aspects
+integer(fpi),dimension(lx:mx,ly:my,3),intent( out):: dixs,diys
+logical, intent( out):: ff
+!-----------------------------------------------------------------------------
+integer(spi) :: ix,iy
+integer(fpi),dimension(2,3):: ltri
+!=============================================================================
+do iy=ly,my
+ do ix=lx,mx
+ call tritform(aspects(:,ix,iy),ltri,ff)
+ if(ff)then
+ print'(" Failure in tritform at ix,iy=",2i5)',ix,iy
+ return
+ endif
+ dixs(ix,iy,:)=ltri(1,:)
+ diys(ix,iy,:)=ltri(2,:)
+ enddo
+enddo
+end subroutine tritforms
+
+!=================================================================== [tritform]
+subroutine tritform(aspect ,ltri, ff)
+!==============================================================================
+! Perform the direct Triad and hs transform.
+! Take a 3-vector representation of the aspect tensor and
+! transform it to the vector of half-spans for the beta line filter
+! and 1-byte-integer line generators.
+! aspect: input as aspect tensor components, output as spread**2
+! ltri : three active line generators in ascending color order
+! ff : logical failure flag.
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+implicit none
+real(dp),dimension(3), intent(inout):: aspect
+integer(fpi),dimension(2,3),intent( out):: ltri
+logical, intent( out):: ff
+!------------------------------------------------------------------------------
+real(dp), dimension( 3):: wtri
+integer(fpi),dimension(2,3):: ltri3
+integer(spi) :: i
+!==============================================================================
+call triad(aspect, ltri3,wtri,ff)
+if(ff)then
+ print'(" In tritform; triad failed; check aspect tensor")'
+ return
+endif
+ltri=ltri3
+aspect=wtri
+do i=1,3
+ call hstform(aspect(i),ff)
+ if(ff)then
+ print'(" In tritform; hstform failed at i=",i2)',i
+ print'(" Check that inimomtab has been called to initialize exponent")'
+ print'(" p, table size, nh, and the moment tables for line filters")'
+ return
+ endif
+enddo
+end subroutine tritform
+
+!================================================================== [tritformi]
+subroutine tritformi(aspect ,ltri, ff)
+!==============================================================================
+! Perform the inverse hs and triad transform.
+! Take a 3-vector of the active spreads**2,
+! and their line generators, and return the implied
+! aspect tensor in the same 3-vector that contained the half-spans
+! aspect: input as half-spans; output as aspect tensor components
+! ltri : corresponding successive line generators (using 1-byte integers)
+! ff : logical failure flag.
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+use jp_pmat4, only: outer_product
+implicit none
+real(dp),dimension(3),intent(inout) :: aspect
+integer(fpi),dimension(2,3),intent(in ):: ltri
+logical, intent( out):: ff
+!------------------------------------------------------------------------------
+real(dp),dimension(2,2):: a22
+real(dp),dimension(2) :: vec
+integer(spi) :: i
+!==============================================================================
+a22=u0
+do i=1,3
+ vec=ltri(:,i)
+ call hstformi(aspect(i),ff)
+ if(ff)then
+ print'(" In tritformi; hstformi failed at i=",i2)',i
+ print'(" Check that inimomtab has been called to initialize exponent")'
+ print'(" p, table size, nh, and the moment tables for line filters")'
+ return
+ endif
+ a22=a22+outer_product(vec,vec)*aspect(i)
+enddo
+call t22_to_3(a22,aspect)
+end subroutine tritformi
+
+!===================================================================== [triad]
+subroutine triad(aspect,ltri,wtri,ff)
+!=============================================================================
+! A version of the Triad iterative algorithm for resolving a given aspect
+! tensor, A, rearranged as the 3-vector,
+! Aspect = (/A_11, A_22, A_12/)
+! onto a bisis of generator directions, the integer 2-vectors ltri, together
+! with their corresponding aspect projections, or "weights", wtri.
+!
+! Aspect: The given aspect tensor in the form of a 3-vector (see above)
+! Ltri: The three integer 2-vectors whose members define a triad
+! and whose outer-products imply basis 3-vectors into which the aspect
+! is resolved. This matrix of 3-vectors is denoted Lu, but only its
+! inverse, Lui, is needed in this routine.
+! wtri: Real nonnegative weights (projected aspect) corresponding to ltri.
+! ff : Failure flag, raised on output only when iterations exceed limit.
+!=============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pmat4, only: outer_product
+implicit none
+real(dp), dimension(3), intent(in ):: aspect
+integer(fpi),dimension(2,0:2),intent(out):: ltri
+real(dp), dimension(0:2) ,intent(out):: wtri
+logical, intent(out):: ff
+!-----------------------------------------------------------------------------
+integer(spi),parameter :: nit=200
+real(dp), parameter :: bcmins=-1.e-14_dp
+real(dp), dimension(3,0:2):: rlui
+real(dp) :: dwtri
+integer(spi),dimension(-2:2) :: ssigns
+integer(spi),dimension(0:2) :: signs
+integer(fpi),dimension(2,0:2):: defltri ! <- default Ltri
+integer(spi),dimension(3,0:2):: deflui ! <- default Lui
+integer(spi),dimension(3,0:2):: lui
+integer(spi),dimension(3) :: dlui
+integer(spi),dimension(1) :: ii
+integer(spi) :: it,kcol,lcol,mcol
+data ssigns/1,1,-1,1,1/
+data deflui/1, 0,-1, 0, 1,-1, 0, 0, 1/
+data defltri/ 1, 0, 0,1, -1,-1/
+!==============================================================================
+ltri=defltri; lui=deflui
+rlui=lui; wtri=matmul(aspect,rlui)
+do it=1,nit
+ ii=minloc(wtri)-1; kcol=ii(1); dwtri=wtri(kcol)*2; if(dwtri>=bcmins)exit
+ lcol=mod(kcol+1,3); mcol=mod(lcol+1,3); dlui=lui(:,kcol)*2
+ Ltri(:,lcol)=-Ltri(:,Lcol); Ltri(:,kcol)=-Ltri(:,Lcol)-Ltri(:,mcol)
+ signs=ssigns(-kcol:2-kcol)
+ lui=lui+outer_product(dlui,signs)
+ wtri=wtri+signs*dwtri
+enddo
+ff=it>nit
+end subroutine triad
+
+!=================================================================== [gettrilu]
+subroutine gettrilu(ltri,lu)
+!==============================================================================
+use jp_pkind, only: spi; use jp_pkind2, only: fpi
+implicit none
+integer(fpi),dimension(2,0:2),intent(in ):: ltri
+integer(fpi),dimension(2,0:2),intent(out):: lu
+!-----------------------------------------------------------------------------
+integer(spi):: i,L
+!==============================================================================
+do i=0,2; do L=1,2; lu(L,i)=Ltri(i2pair(1,L),i)*Ltri(i2pair(2,L),i);enddo;enddo
+end subroutine gettrilu
+
+!==============================================================================
+subroutine querytcol(vin,tcol)! [querytcol]
+!==============================================================================
+use jp_pkind, only: spi
+implicit none
+integer(spi),dimension(2),intent(in ):: vin
+integer(spi), intent(out):: tcol
+!------------------------------------------------------------------------------
+integer(spi),dimension(3):: tcols
+integer(spi) :: i
+data tcols/0,1,2/
+!==============================================================================
+i=modulo(vin(1),2)+2*modulo(vin(2),2)
+if(i==0)stop 'In querytcol; invalid 2-vector vin has all components even'
+tcol=tcols(i)
+end subroutine querytcol
+
+!=================================================================== [hextform]
+subroutine hextforms(lx,mx,ly,my,lz,mz, aspects, qcols,dixs,diys,dizs, ff)
+!==============================================================================
+! Perform direct hexad and hs transforms in a proper subdomain
+! domains extents in x, y, z, are lx:mx, ly:my, lz:mz
+! aspects: upon input, these are the 6-vectors of grid-relative aspect tensor
+! upon output, these are the six active-line-filter half-spans.
+! qcols: outout as the Galois "colors" of each successive line-filter, listed
+! in ascending order but with zeros at positions 0 and 7 of each list.
+! dixs: x-component of each of the 6 active line generators
+! diys: y-component
+! dizs: z-component
+! ff: Logical failure flag, output .true. when failure occurs.
+! Note that the integer arrays, qcols, doxs, diys, dizs, are 1-byte integers.
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+implicit none
+integer(spi), intent(in ):: lx,mx, &
+ ly,my, &
+ lz,mz
+real(dp), dimension( 6,lx:mx,ly:my,lz:mz),intent(inout):: aspects
+integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent( out):: qcols
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent( out):: dixs,diys,dizs
+logical, intent( out):: ff
+!------------------------------------------------------------------------------
+integer(spi) :: ix,iy,iz
+integer(fpi),dimension(3,6):: lhex
+!==============================================================================
+do iz=lz,mz
+ do iy=ly,my
+ do ix=lx,mx
+ call hextform(aspects(:,ix,iy,iz),qcols(:,ix,iy,iz),&
+ lhex,ff)
+ if(ff)then
+ print'(" Failure in hextform at ix,iy,iz=",3i5)',ix,iy,iz
+ return
+ endif
+ dixs(ix,iy,iz,:)=lhex(1,:)
+ diys(ix,iy,iz,:)=lhex(2,:)
+ dizs(ix,iy,iz,:)=lhex(3,:)
+ enddo
+ enddo
+enddo
+end subroutine hextforms
+
+!=================================================================== [hextform]
+subroutine hextform(aspect, qcol,lhex, ff)
+!==============================================================================
+! Perform the direct Hexad and hs transform.
+! Take a 6-vector representation of the aspect tensor and
+! transform it to the vector of half-spans for the dibeta filter,
+! and 1-byte-integer line generators, and color list.
+! aspect: input as aspect tensor components, output as half-spans
+! qcol : output as colors of successive active lines, but with
+! "spare" null elements 0 and 7.
+! lhex : six active line generators in ascending color order
+! ff : logical failure flag.
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+implicit none
+real(dp),dimension(6), intent(inout):: aspect
+integer(fpi),dimension(0:7),intent( out):: qcol
+integer(fpi),dimension(3,6),intent( out):: lhex
+logical, intent( out):: ff
+!------------------------------------------------------------------------------
+real(dp), dimension( 7):: whex7
+integer(fpi),dimension(3,7):: lhex7
+integer(fpi) :: i,j
+!==============================================================================
+call hexad(aspect, lhex7,whex7,ff)
+if(ff)then
+ print'(" In hextform; hexad, failed; check aspect tensor")'
+ return
+endif
+qcol(0)=0; qcol(7)=0
+j=1
+do i=1,7
+ if(sum(abs(lhex7(:,i)))==0)cycle
+ qcol(j)=i
+ lhex(:,j)=lhex7(:,i)
+ aspect(j)=whex7( i)
+ j=j+1_fpi
+enddo
+do i=1,6
+ call hstform(aspect(i),ff)
+ if(ff)then
+ print'(" In hextform; hstform failed at i=",i2)',i
+ print'(" Check that inimomtab has been called to initialize exponent")'
+ print'(" p, table size, nh, and the moment tables for line filters")'
+ return
+ endif
+enddo
+ff=(j/=7)
+if(ff)print'(" In hextform; inconsistent hexad generator set found")'
+end subroutine hextform
+
+!================================================================== [hextformi]
+subroutine hextformi(aspect, qcol,lhex, ff)
+!==============================================================================
+! Perform the inverse hs and hexad transform.
+! Take a 6-vector of the active half-spans, their respective
+! colors, and their line generators, and return the implied
+! aspect tensor in the same 6-vector that contained the spreads**2
+! aspect: input as spreads**2; output as aspect tensor components
+! qcol : colors of successive active hexad members (using 1-byte integers)
+! lhex : corresponding successive line generators (using 1-byte integers)
+! ff : logical failure flag.
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+use jp_pmat4, only: outer_product
+implicit none
+real(dp), dimension( 6),intent(inout):: aspect
+integer(fpi),dimension(0:7),intent(in ):: qcol
+integer(fpi),dimension(3,6),intent(in ):: lhex
+logical, intent( out):: ff
+!------------------------------------------------------------------------------
+real(dp),dimension(3,3):: a33
+real(dp),dimension(3) :: vec
+integer(fpi) :: i,j
+!==============================================================================
+a33=u0
+j=1
+do i=1,7
+ if(qcol(j)/=i)cycle
+ call hstformi(aspect(j),ff)
+ if(ff)then
+ print'(" In hextformi; hstformi failed at i,j=",2i2)',i,j
+ print'(" Check that inimomtab has been called to initialize exponent")'
+ print'(" p, table size, nh, and the moment tables for line filters")'
+ return
+ endif
+ vec=lhex(:,j)
+ a33=a33+outer_product(vec,vec)*aspect(j)
+ j=j+1_fpi
+enddo
+ff=(j/=7)
+if(ff)print'(" In hextformi; Inconsistent qcol")'
+call t33_to_6(a33,aspect)
+end subroutine hextformi
+
+!====================================================================== [hexad]
+subroutine hexad(aspect,lhex7,whex7,ff)
+!==============================================================================
+! A version of the Hexad iterative algorithm for resolving a given aspect
+! tensor, A, rearranged as the 6-vector,
+! Aspect= (/ A_11, A_22, A_33, A_23, A_31, A_12 /)
+! onto a basis of generator directions, the integer 3-vectors lhex7, together
+! with their corresponding aspect projections, or "weights", whex7.
+! Although seven lhex vectors and weights are given (arranged by "colors" 0--6)
+! only six of these -- those that do NOT equal the "color" of the hexad
+! itself --- are nonzero (and are positive when the hexad is correctly
+! resolving the target aspect tensor, Aspect). The style of this algorithm
+! is as close as possible to the the description in documentation "Note 7".
+!
+! Aspect: the given aspect tensor in the form of a 6-vector (see above).
+! Lhex7: The seven integer 3-vectors whose 6 non-null members define a Hexad
+! and whose outer-products imply basis 6-vectors into which the aspect
+! is resolved. This matrix of 6-vectors is denoted Lu, but only its
+! inverse, Lui, is needed in this routine. These seven 3-vectors are
+! arranged in decreasing order of "cardinality",
+! meaning that the cardinal
+! directions' colors define the first three vectors, the next three have
+! two odd components, and the seventh has all odd components.
+! whex7: Seven real nonnegative weights (projected aspect)
+! corresponding to lhex
+! (zero value in the case of the null vector of lhex7)
+! ff : failure flag, raised only when the iterations exceed their limit.
+! The algorithm here benefits from using the symmetry of the Fano plane
+! and related GF(8) nonnull elements which, arranged cyclically, imply that
+! the Jth "line" comprises points j+line(0), j+line(1), j+line(2), where
+! Line = (/ 1, 2, 4/) and j is taken modulo 7.
+! Note: the "K-set" of 3 members of the Lhex (indexed hcol+6, hcol+5, hcol+3)
+! or equivalently, hcol-line(0),hcol-line(1),hclo-line(2),
+! where arithmetic is modulo-7, are sufficient to form a "basis" from which
+! the other ("L-set") nonnull members of Lhex are implied. To make the
+! iterations efficient, we can iterate just this K-set, because the changes
+! made to the effective projection operator, Lui, are, by the Woodbury
+! formula, of rank-1 at each iteration, and the whex components change by
+! a corresponding pattern of increments that do not need us to find the full
+! set of Lhex, nor the explicit Lu, each iteration.
+! Note that some integer arrays use 1-byte integer type to save space.
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+use jp_pmat4, only: outer_product
+implicit none
+real(dp), dimension(6), intent(in ):: aspect
+integer(fpi),dimension(3,7), intent(out):: lhex7
+real(dp), dimension(7), intent(out):: whex7
+logical, intent(out):: ff
+!------------------------------------------------------------------------------
+integer(spi),parameter :: nit=200
+real(dp), parameter :: bcmins=-1.e-14_dp
+real(dp), dimension(6,0:6) :: rlui
+real(dp), dimension(0:6) :: whex
+real(dp) :: dwhex
+integer(spi),dimension(0:6) :: signs
+integer(fpi),dimension(3,0:6) :: deflhex
+integer(spi),dimension(6,0:6) :: deflui
+integer(spi),dimension(-6:6) :: sstriad
+integer(spi),dimension(6) :: dlui,ttriad
+integer(fpi),dimension(3,0:2) :: Kset
+integer(fpi),dimension(3,3,6) :: mmats
+integer(spi),dimension(0:2) :: Line
+integer(spi),dimension(1) :: ii
+integer(fpi),dimension(3,0:6) :: lhex
+integer(spi),dimension(6,0:6) :: lui
+integer(spi),dimension(0:6) :: jcol
+integer(spi) :: hcol
+integer(spi) :: i,ip,it,j,kcol,dcol,L
+data deflhex/0,0,0, 1,-1,0, 0,1,-1, 0,0,1, -1,0,1, 0,1,0, 1,0,0/
+data deflui/ 6*0, 0, 0, 0, 0, 0,-1, 0, 0, 0,-1, 0, 0, 0, 0, 1, 1, 1, 0, &
+ 0, 0, 0, 0,-1, 0, 0, 1, 0, 1, 0, 1, 1, 0, 0, 0, 1, 1/
+data Mmats/1, 1,-1, 1, 0, 0, 1, 0,-1, -1, 1, 0, -1, 1, 1, 0, 1, 0, &
+ 0,-1, 1, 1,-1, 0, 1, 0, 0, 0, 0, 1, 0,-1, 1, 1,-1, 1, &
+ -1, 0, 1, 0, 0, 1, -1, 1, 0, 0, 1, 0, 1, 0,-1, 0, 1,-1/
+data ttriad/5,3,3,6,5,6/
+data sstriad/-1,-1, 1,-1, 1, 1, 1,-1,-1, 1,-1, 1, 1/
+data Line/1,2,4/
+data jcol/7,4,6,3,5,2,1/
+!==============================================================================
+lhex=deflhex; lui=deflui; hcol=0
+rlui=lui; whex=matmul(aspect,rlui)
+do i=0,2; Kset(:,i)=Lhex(:,modulo(hcol-line(i),7)); enddo
+do it=1,nit
+ ii=minloc(whex)-1; kcol=ii(1); dwhex=whex(kcol); if(dwhex>=bcmins)exit
+ dcol=modulo(kcol-hcol,7); hcol=kcol; L=modulo(hcol+ttriad(dcol),7)
+ Kset=matmul(Kset,Mmats(:,:,dcol))
+ dlui=lui(:,hcol)
+ signs=sstriad(-L:6-L)
+ lui =lui+outer_product(dlui,signs)
+ whex=whex+signs*dwhex
+enddo
+ff=it>nit; if(ff)return
+do i=0,2; ip=modulo(i+1,3)
+ lhex(:,modulo(hcol-line(i),7))=Kset(:,i)
+ lhex(:,modulo(hcol+line(i),7))=Kset(:,i)-Kset(:,ip)
+enddo
+lhex(:,kcol)=0
+lhex7=0
+whex7=u0
+do i=0,6
+ j=jcol(i)
+ lhex7(:,j)=lhex(:,i)
+ whex7( j)=whex( i)
+enddo
+
+end subroutine hexad
+
+!=================================================================== [gethexlu]
+subroutine gethexlu(lhex,lu)
+!==============================================================================
+use jp_pkind, only: spi; use jp_pkind2, only: fpi
+implicit none
+integer(fpi),dimension(3,0:6),intent(in ):: lhex
+integer(fpi),dimension(6,0:6),intent(out):: lu
+!------------------------------------------------------------------------------
+integer(spi):: i,L
+!==============================================================================
+do i=0,6; do L=1,6; lu(L,i)=Lhex(i3pair(1,L),i)*Lhex(i3pair(2,L),i);enddo;enddo
+end subroutine gethexlu
+
+!==============================================================================
+subroutine queryhcol(vin,hcol)! [queryhcol]
+!==============================================================================
+use jp_pkind, only: spi
+implicit none
+integer(spi),dimension(3),intent(in ):: vin
+integer(spi), intent(out):: hcol
+!------------------------------------------------------------------------------
+integer(spi),dimension(7):: hcols
+integer(spi) :: i
+data hcols/6,5,1,3,4,2,0/
+!==============================================================================
+i=modulo(vin(1),2)+2*modulo(vin(2),2)+4*modulo(vin(3),2)
+if(i==0)stop 'In queryhcol; invalid 3-vector Vin has all components even'
+hcol=hcols(i)
+end subroutine queryhcol
+
+!=================================================================== [dectform]
+subroutine dectforms(lx,mx,ly,my,lz,mz,lw,mw,aspects,qcols, &
+ dixs,diys,dizs,diws, ff)
+!==============================================================================
+! Perform direct Decad and ha transforms in a proper subdomain
+! domains extents in x, y, z, w, are lx:mx, ly:my, lz:mz, lw:mw
+! aspects: upon input, these are the 10-vectors of grid-relative aspect tensor
+! upon output, these are the ten active-line-filter half-spans.
+! qcols: outout as the Galois "colors" of each successive line-filter, listed
+! in ascending order, with zeros at positions 0 and 11 of each list.
+! dixs: x-component of each of the 6 active line generators
+! diys: y-component
+! dizs: z-component
+! diws: w-component
+! ff: Logical failure flag, output .true. when failure occurs.
+! Note that the integer arrays, qcols, doxs, diys, dizs, diws,
+! are 1-byte integers.
+!
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+implicit none
+integer(spi), intent(in ):: lx,mx,&
+ ly,my,&
+ lz,mz,&
+ lw,mw
+real(dp),dimension(10,lx:mx,ly:my,lz:mz,lw:mw), intent(inout):: aspects
+integer(fpi),dimension(0:11,lx:mx,ly:my,lz:mz,lw:mw),intent( out):: qcols
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,10), intent( out):: dixs,&
+ diys,&
+ dizs,&
+ diws
+logical, intent( out):: ff
+!------------------------------------------------------------------------------
+integer(spi) :: ix,iy,iz,iw
+integer(fpi),dimension(4,10):: ldec
+!==============================================================================
+do iw=lw,mw
+ do iz=lz,mz
+ do iy=ly,my
+ do ix=lx,mx
+ call dectform(aspects(:,ix,iy,iz,iw),qcols(0:11,ix,iy,iz,iw),&
+ ldec,ff)
+ if(ff)then
+ print'(" Failure in dectform at ix,iy,iz,iw=",4i5)',&
+ ix,iy,iz,iw
+ return
+ endif
+ dixs(ix,iy,iz,iw,:)=ldec(1,:)
+ diys(ix,iy,iz,iw,:)=ldec(2,:)
+ dizs(ix,iy,iz,iw,:)=ldec(3,:)
+ diws(ix,iy,iz,iw,:)=ldec(4,:)
+ enddo
+ enddo
+ enddo
+enddo
+end subroutine dectforms
+
+!=================================================================== [dectform]
+subroutine dectform(aspect, qcol,ldec, ff)
+!==============================================================================
+! Perform the direct Decad and hs transform.
+! Take a 10-vector representation of the aspect tensor and
+! transform it to the vector of half-spans
+! and 1-byte-integer line generators, and color list.
+! aspect: input as aspect tensor components, output as spread**2
+! qcol : output as colors of successive active lines, but with
+! "spare" null elements 0 and 11.
+! ldec : ten active line generators in ascending color order
+! ff : logical failure flag.
+!=============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+implicit none
+real(dp),dimension(10), intent(inout):: aspect
+integer(fpi),dimension(0:11),intent( out):: qcol
+integer(fpi),dimension(4,10),intent( out):: ldec
+logical, intent( out):: ff
+!-----------------------------------------------------------------------------
+real(dp), dimension( 15):: wdec15
+integer(fpi),dimension(4,15):: ldec15
+integer(fpi) :: i,j
+!=============================================================================
+call decad(aspect, ldec15,wdec15,ff)
+if(ff)then
+ print'(" In dectform; decad, failed; check aspect tensor")'
+ return
+endif
+qcol(0)=0; qcol(11)=0
+j=1
+do i=1,15
+ if(sum(abs(ldec15(:,i)))==0)cycle
+ qcol(j)=i
+ ldec(:,j)=ldec15(:,i)
+ aspect(j)=wdec15( i)
+ j=j+1_fpi
+enddo
+do i=1,10
+ call hstform(aspect(i),ff)
+ if(ff)then
+ print'(" In dectform; hstform failed at i=",i2)',i
+ print'(" Check that inimomtab has been called to initialize exponent")'
+ print'(" p, table size, nh, and the moment tables for line filters")'
+ return
+ endif
+enddo
+
+ff=(j/=11)
+if(ff)print'(" In dectform; inconsistent decad generator set found")'
+end subroutine dectform
+
+!================================================================= [dectformi]
+subroutine dectformi(aspect, qcol,ldec, ff)
+!=============================================================================
+! Perform the inverse hs and decad transform.
+! Take a 10-vector of the active half-spans, their respective
+! colors, and their line generators, and return the implied
+! aspect tensor in the same 10-vector that contained the spreads**2
+! aspect: input as spreads**2; output as aspect tensor components
+! qcol : colors of successive active decad members (using 1-byte integers)
+! ldec : corresponding successive line generators (using 1-byte integers)
+! ff : logical failure flag.
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+use jp_pmat4, only: outer_product
+implicit none
+real(dp), dimension( 10),intent(inout):: aspect
+integer(fpi),dimension(0:11),intent(in ):: qcol
+integer(fpi),dimension(4,10),intent(in ):: ldec
+logical, intent( out):: ff
+!------------------------------------------------------------------------------
+real(dp),dimension(4,4):: a44
+real(dp),dimension(4) :: vec
+integer(spi) :: i,j
+!==============================================================================
+a44=u0
+j=1
+do i=1,15
+ if(qcol(j)/=i)cycle
+ call hstformi(aspect(j),ff)
+ if(ff)then
+ print'(" In dectformi; hstformi failed at i,j=",2i3)',i,j
+ print'(" Check that inimomtab has been called to initialize exponent")'
+ print'(" p, table size, nh, and the moment tables for line filters")'
+ return
+ endif
+ vec=ldec(:,j)
+ a44=a44+outer_product(vec,vec)*aspect(j)
+ j=j+1
+enddo
+ff=(j/=11)
+if(ff)then
+ print'(" In dectformi; Inconsistent qcol")'
+ return
+endif
+call t44_to_10(a44,aspect)
+end subroutine dectformi
+
+!====================================================================== [decad]
+subroutine decad(aspect,ldec15,wdec15,ff)
+!==============================================================================
+! This version is derived from $HOMES/on500/decadf.f90
+! In this version ALWAYS start from the default decad
+! Also, rearrange the 10 active line directions and weights
+! into arrays of 15, ordered according the colors of the fundamental
+! 3*3*3*3 cube's surface generators' degrees of "cardinality". By this
+! we mean that the colors of (1,0,0,0), (0,1,0,0), (0,0,1,0), (0,0,0,1)
+! come first, followed by the colors of (1,1,0,0), (1,0,1,0), (1,0,0,1),
+! (0,1,1,0), (0,1,0,1), (0,0,1,1), followed by the colors of (1,1,1,0),
+! (1,1,0,1), (1,0,1,1), (0,1,1,1), and followed finally by the color
+! of the "least cardinal" (or "most diagonal") type of element, (1,1,1,1).
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+use jp_pbfil2,only: dec0,dodec0t,umat10,umat12,umats,nei,dcol10,dcol12,&
+ nei0a,jcora,nei0b,jcorb,nei17,nei22,nei33,nei38, tcors,&
+ kcor10a5,kcor10b1,kcor10b2,kcor12b0, &
+ kcor17c0,kcor22c0,kcor33c0,kcor38c0,kcor44c0,kcor51c0,kcor53c0,kcor58c0,&
+ twt10a5,twt10b1,twt10b2,twt12c0,qwt10a,qwt10b,qwt10c,qwt10d,qwt10e, &
+ qwt12a,qwt12b0,tperms,perm10,perm12,perms
+use jp_pmat, only: inv
+use jp_pmat4, only: outer_product,det
+implicit none
+real(dp),dimension(10), intent(in ):: aspect
+integer(fpi),dimension(4,15),intent(out):: ldec15
+real(dp), dimension( 15),intent(out):: wdec15
+logical, intent(out):: ff
+!------------------------------------------------------------------------------
+integer(spi), parameter :: nit=40
+real(dp),parameter :: bcmins=-1.e-14_dp
+real(dp),dimension(10,0:9) :: rlui
+real(dp),dimension(0:9) :: awdec,xwdec,newwdec,wdec
+real(dp) :: dwdec
+integer(spi) :: ktyp,dcol ! Redundant?
+integer(spi),dimension(0:9) :: palet !
+integer(spi),dimension(4,0:9) :: eldec !
+integer(spi),dimension(10,0:9) :: lu,lui
+integer(fpi),dimension(4,0:9) :: defeldec
+integer(spi),dimension(4,0:9) :: neweldec
+integer(spi),dimension(0:9) :: defpalet
+integer(spi),dimension(1) :: ii
+integer(spi),dimension(4,4) :: tcor
+integer(spi) :: i,it,j,k,newktyp,newdcol,abscol,&
+ jcol,kcor,jcor
+integer(spi),dimension(4,0:3) :: newbase
+integer(spi),dimension(0:9) :: perm,qwt,tperm
+integer(spi),dimension(0:14) :: icol15
+data icol15/1,2,3,4,5,8,10,12,6,9,11,14,15,13,7/
+data defeldec/ &
+ 0, 0, 1, 0, 0,-1, 0, 0, 1, 0, 0, 0, -1, 0,-1,-1, 0, 1, 0, 1, &
+ 0, 0, 0,-1, -1, 0,-1, 0, 1, 1, 1, 1, -1,-1, 0,-1, 1, 0, 0, 1/
+data defpalet/ 2, 1, 0,13, 9, 3, 8,12, 7,14/
+!==============================================================================
+eldec=defeldec; palet=defpalet; ktyp=4; dcol=4
+do j=0,9; call t4_to_10(eldec(:,j),lu(:,j)); enddo
+lui=transpose(lu)
+call inv(lui,ff)
+if(ff)then
+ print'(" In decad, at A; lu cannot be inverted")'
+ return
+endif
+rlui=lui
+wdec=matmul(aspect,rlui)
+do it=1,nit
+ ii=minloc(wdec)-1; k=ii(1); dwdec=wdec(k);
+ if(dwdec>=bcmins)exit
+!-- The following is translated from the "x" block of old tdecadf:
+ newktyp=nei(k,ktyp)
+ if(ktyp<12)then
+ abscol=modulo(dcol+dcol10(k,ktyp),15)! Anticipated uncorrected abs col
+ newbase(:,:)=matmul(eldec(:,0:3),umat10(:,:,k,ktyp))
+ else
+ if(k<4)then
+ abscol=modulo(dcol+dcol12(k,ktyp),15)
+ newbase(:,:)=matmul(eldec(:,0:3),umat12(:,:,k,ktyp))/2
+ else
+ abscol=dcol
+ newbase(:,:)=matmul(eldec(:,0:3),umats(:,:,k))/2
+ endif
+ endif
+ jcol=0
+ jcor=0
+ if(newktyp==11)then
+ jcol=abscol/3
+ if(jcol>0)then
+ jcor=6+jcol
+ endif
+ abscol=modulo(abscol,3)
+ elseif(newktyp>=44)then
+ jcol=abscol/5
+ if(jcol>0)then
+ select case(ktyp)
+ case(0:3)
+ newktyp=nei0a(jcol,ktyp)
+ jcor=jcora(jcol,ktyp)
+ case(4:9)
+ newktyp=nei0b(jcol,k,ktyp)
+ jcor=jcorb(jcol,k,ktyp)
+ case(17); newktyp=nei17(jcol); jcor=10+jcol
+ case(22); newktyp=nei22(jcol); jcor=10+jcol
+ case(33); newktyp=nei33(jcol); jcor=10+jcol
+ case(38); newktyp=nei38(jcol); jcor=10+jcol
+ case(44); jcor=10+jcol
+ case(51); jcor=10+jcol
+ case(53); jcor=10+jcol
+ case(58); jcor=10+jcol
+ case default
+ print'(" In decad. Unrecognized ktyp=",i10)',ktyp
+ ff=.true.
+ return
+ end select
+ endif
+ abscol=modulo(abscol,5)
+ if(ktyp<12)then
+ newdcol=modulo(abscol-dcol10(k,ktyp),15)
+ else
+ if(k<4)then
+ newdcol=modulo(abscol-dcol12(k,ktyp),15)
+ else
+ newdcol=dcol
+ endif
+ endif
+ endif
+ if(jcor /= 0)then
+ tcor=tcors(:,:,jcor)
+ newbase=matmul(newbase(:,:),tcor)/2
+ endif
+
+ if(ktyp<12)then
+ perm=perm10(:,k,ktyp)
+ select case(ktyp)
+ case(0:3)
+ if(k==5)then
+ kcor=kcor10a5(jcol,ktyp)
+ qwt=twt10a5(:,kcor)
+ else
+ qwt=qwt10a(:,k)
+ endif
+ case(4:7)
+ if(k==1)then
+ kcor=kcor10b1(jcol,ktyp)
+ qwt=twt10b1(:,kcor)
+ elseif(k==2)then
+ kcor=kcor10b2(jcol,ktyp)
+ qwt=twt10b2(:,kcor)
+ else
+ qwt=qwt10b(:,k)
+ endif
+ case(8:9)
+ if(k==1)then
+ kcor=kcor10b1(jcol,ktyp)
+ qwt=twt10b1(:,kcor)
+ elseif(k==2)then
+ kcor=kcor10b2(jcol,ktyp)
+ qwt=twt10b2(:,kcor)
+ else
+ qwt=qwt10c(:,k)
+ endif
+ case(10)
+ qwt=qwt10d(:,k)
+ case(11)
+ qwt=qwt10e(:,k)
+ end select
+ else
+ if(k==0)then
+ perm=perm12(:,k,ktyp)
+ kcor=kcor12b0(ktyp)
+ select case(ktyp)
+ case(17); kcor=kcor17c0(jcol); qwt=twt12c0(:,kcor)
+ case(22); kcor=kcor22c0(jcol); qwt=twt12c0(:,kcor)
+ case(33); kcor=kcor33c0(jcol); qwt=twt12c0(:,kcor)
+ case(38); kcor=kcor38c0(jcol); qwt=twt12c0(:,kcor)
+ case(44); kcor=kcor44c0(jcol); qwt=twt12c0(:,kcor)
+ case(51); kcor=kcor51c0(jcol); qwt=twt12c0(:,kcor)
+ case(53); kcor=kcor53c0(jcol); qwt=twt12c0(:,kcor)
+ case(58); kcor=kcor58c0(jcol); qwt=twt12c0(:,kcor)
+ case default
+ qwt=qwt12b0(:,kcor)
+ end select
+ elseif(k<4)then
+ perm=perm12(:,k,ktyp)
+ qwt=qwt12a(:,k)
+ else
+ perm=perms(:,k)
+ qwt=qwt12a(:,k)
+ endif
+ endif
+ if(jcor/=0)then
+ do i=0,9
+ tperm(i)=tperms(perm(i),jcor)
+ enddo
+ perm=tperm
+ endif
+ call standardizeb(newbase(:,:),FF)
+ if(FF)then
+ print'(" In decad, at B; failure of subr. standardizedb")'
+ return
+ endif
+
+!--------
+ awdec=wdec-qwt*dwdec
+ do i=0,9
+ newwdec(perm(i))=awdec(i)
+ enddo
+ if(newktyp<12)then
+ neweldec=matmul(newbase,dec0)
+ else
+ neweldec=matmul(newbase,dodec0t)/2
+ endif
+ do j=0,9
+ call t4_to_10(neweldec(:,j),lu(:,j))
+ enddo
+ lui=transpose(lu)
+ call inv(lui,ff)
+ if(ff)then
+ print'(" In decad, at C; lu cannot be inverted")'
+ return
+ endif
+ rlui=lui
+ xwdec=matmul(aspect,rlui)
+! if(maxval(abs(xwdec-newwdec))>.001)read(*,*)
+ eldec=neweldec
+ ktyp=newktyp
+ dcol=abscol
+ wdec=xwdec
+enddo
+if(it>nit)then
+ ff=.true.
+ print '(" in decad, at D; failure of decad iterations to converge")'
+ return
+endif
+do j=0,9
+ call querydcol(eldec(:,j),palet(j))
+enddo
+print'(" departing decad having used it = ",i5," iterations.")',it
+! Insert the decad into its proper color slots in order of decreasing
+! "cardinality:"
+wdec15=u0
+ldec15=0
+do i=0,9
+ j=icol15(palet(i))
+! ldec15(:,j)=int(eldec(:,i),kind(fpi))
+ ldec15(:,j)=int(eldec(:,i),fpi)
+ wdec15( j)= wdec( i)
+enddo
+end subroutine decad
+
+!=================================================================== [getdeclu]
+subroutine getdeclu(ldec,lu)
+!==============================================================================
+use jp_pkind, only: spi; use jp_pkind2, only: fpi
+implicit none
+integer(spi),dimension( 4,0:14),intent(in ):: ldec
+integer(spi),dimension(10,0:14),intent(out):: lu
+!------------------------------------------------------------------------------
+integer(spi):: i,L
+!==============================================================================
+do i=0,14;do L=1,10;lu(L,i)=Ldec(i4pair(1,L),i)*Ldec(i4pair(2,L),i);enddo;enddo
+end subroutine getdeclu
+
+!==============================================================================
+subroutine querydcol(vin,dcol)! [querydcol]
+!==============================================================================
+use jp_pkind, only: spi; use jp_pkind2, only: fpi
+implicit none
+integer(spi),dimension(4),intent(in ):: vin
+integer(spi), intent(out):: dcol
+!------------------------------------------------------------------------------
+integer(spi),dimension(15):: dcols
+integer(spi),dimension(4) :: bbbb
+integer(spi) :: i
+data dcols/ 0, 1, 4, 2, 8, 5,10, 3,14, 9, 7, 6,13,11,12/
+data bbbb/1,2,4,8/
+!==============================================================================
+i=dot_product(bbbb,modulo(vin,2))
+if(i==0)stop 'In querydcol; invalid 4-vector Vin has all components even'
+dcol=dcols(i)
+end subroutine querydcol
+
+!=============================================================== [standardizeb]
+subroutine standardizeb(bases,FF)
+!==============================================================================
+! Standardize 4*4 bases vectors by making sure the first nonzero component
+! of the first column is positive in the standardized version.
+! If the first column is null, raise the (logical) failure flag, FF.
+!==============================================================================
+use jp_pkind, only: spi
+implicit none
+integer(spi),dimension(4,4),intent(inout):: bases
+logical, intent( out):: FF
+integer(spi) :: i,b
+!==============================================================================
+FF=.false.
+do i=1,4
+ b=bases(i,1)
+ if(b==0)cycle
+ if(b<0)bases=-bases
+ return
+enddo
+print'(" WARNING! In subroutine standardizeb, first column is null:")'
+FF=.true.
+end subroutine standardizeb
+
+!==================================================================== [hstform]
+subroutine hstform(hs,ff)!
+!==============================================================================
+! Perform the "hspan transform". For a given spread**2, replace it with the
+! corresponding effective half-span corresponding to beta filters of the
+! already-initialized exponent p. Generally, hs>=1, lies between consecutive
+! integers, h, h+1 <=nh (nh is also already given in jp_pbfil2.mod). The linear
+! interpolation weights at h and h+1 for this target, applied to the
+! "interpolation" of the two standardized p-exponent beta distributions of
+! half-spans h and h+1 will also be standardized (sum of gridded responses = 1)
+! and will possess exactly the prescribed spread**2, the input hs.
+! This transform is obviously invertible (see subr. hstformi).
+! But if the given hs does not fit within the range of the
+! table, bsprds, return a raised failure flag, ff.
+!==============================================================================
+use jp_pkind, only: spi,dp
+use jp_pietc, only: u0
+use jp_pbfil2,only: nh,bsprds
+implicit none
+real(dp),intent(inout):: hs
+logical, intent( out):: ff
+!------------------------------------------------------------------------------
+integer(spi):: h
+!==============================================================================
+ff=hs= hs)then
+ hs=h-(bsprds(h)-hs)/(bsprds(h)-bsprds(h-1))
+ return
+ endif
+enddo
+ff=.true.
+end subroutine hstform
+
+!=================================================================== [hstformi]
+subroutine hstformi(hs,ff)
+!==============================================================================
+! Perform the "inverse hspan transform" (inverse function of hstform) so that
+! an effective p-exponent beta filter half-span, hs, is replaced by the second
+! moment (spread**2) of the dibeta filter this half-span implies.
+! If the given half-span is not accommodated by the prepared table, bsprds, of
+! module jp_pbfil3, return a raised failure flag, ff.
+!==============================================================================
+use jp_pkind, only: spi,dp
+use jp_pietc, only: u1
+use jp_pbfil2,only: nh,bsprds
+implicit none
+real(dp),intent(inout):: hs
+logical, intent( out):: ff
+!------------------------------------------------------------------------------
+real(dp) :: w
+integer(spi):: h
+!==============================================================================
+h=1+int(hs)
+ff=(h<2 .or. h>nh)
+if(ff)then
+ print'(" In hstformi; hs out of bounds")'
+ return
+endif
+! Linearly interpolate the spread**2 from the table bsprds:
+w=h-hs
+hs=w*bsprds(h-1)+(u1-w)*bsprds(h)
+end subroutine hstformi
+
+!==================================================================== [blinfil]
+subroutine blinfil(nfil,hspan, h,fil,ff)
+!==============================================================================
+! Find the discrete halfspan h and the filtering weights, fil(0:h), of
+! the normalized dibeta filter of formal real half-span, hspan. The dibeta
+! filter is just a weighted combination of two consecutive-halfspan
+! beta filters such that the spread**2 of the dibeta is the weighted
+! intermediate of the spreads**2 of the pair of beta filters from which it
+! is composed.
+!
+! p: beta filter exponent index
+! nh: size of the table listing the normalization factors and spreads**2
+! bnorm: table of normalization factors for beta filters of integer halfspan
+! bsprds: table of squared-spreads of the beta filters
+! hspan: formal real half-span of the dibeta filter
+! fil: a real array, [0:nh], sufficient to accommodate one half of the
+! symmetric discrete dibeta filter.
+! ff: logical failure flag raised when hspan lies outside the table range.
+!==============================================================================
+use jp_pkind, only: spi,dp
+use jp_pietc, only: u1
+use jp_pbfil2,only: p,nh,bnorm
+implicit none
+integer(spi), intent(in ):: nfil
+real(dp), intent(in ):: hspan
+integer(spi), intent(out):: h
+real(dp),dimension(0:nfil),intent(out):: fil
+logical, intent(out):: ff
+!------------------------------------------------------------------------------
+real(dp) :: wh,whp,z
+integer(spi):: hp,i
+!==============================================================================
+h=int(hspan); hp=h+1; ff=h<1 .or. hp>nh .or. hp>nfil; if(ff)return
+whp =(hspan-h)*bnorm(hp)! linear interpolation weight at hp=h+1
+wh=(hp-hspan)*bnorm(h)! linear interpolation weight at h
+! start with the contribution of the filter of formal halfspan h+1:
+do i=0,h; z=i; z=(z/hp)**2; fil(i)= whp*(u1-z)**p; enddo
+! add the contribution of the filter of formal halfspan h:
+do i=0,h-1; z=i; z=(z/h)**2; fil(i)=fil(i)+wh*(u1-z)**p; enddo
+end subroutine blinfil
+
+!-- The following routines share the interface, dibeta:
+!===================================================================== [dibeta]
+subroutine dibeta1(kx,lx,mx,nx, nfil,dixs,hss,a,ff,ix)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx, nfil
+integer(fpi),dimension(lx:mx),intent(in ):: dixs
+real(dp), dimension(lx:mx),intent(in ):: hss
+real(dp), dimension(kx:nx),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil):: fil
+real(dp),dimension(kx:nx) :: b
+real(dp) :: fili
+integer(spi) :: h,i,dix,dixi
+!==============================================================================
+b=u0
+do ix=lx,mx
+ dix=dixs(ix)
+ if(dix==0)then;b(ix)=a(ix)
+ else
+ call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return
+ b(ix)=fil(0)*a(ix)
+ do i=1,h
+ fili=fil(i); dixi=dix*i
+ b(ix)=b(ix)+fili*(a(ix+dixi)+a(ix-dixi))
+ enddo
+ endif
+enddo
+a=b
+end subroutine dibeta1
+!===================================================================== [dibeta]
+subroutine dibeta2(kx,lx,mx,nx, ky,ly,my,ny, nfil, &
+ dixs,diys,hss, a, ff,ix,iy)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys
+real(dp), dimension(lx:mx,ly:my),intent(in ):: hss
+real(dp), dimension(kx:nx,ky:ny),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(kx:nx,ky:ny):: b
+real(dp) :: fili
+integer(spi) :: h,i,dix,diy,dixi,diyi
+!==============================================================================
+b=u0
+do iy=ly,my; do ix=lx,mx
+ dix=dixs(ix,iy); diy=diys(ix,iy)
+ if(abs(dix)+abs(diy)==0)then;b(ix,iy)=a(ix,iy)
+ else
+ call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return
+ b(ix,iy)=fil(0)*a(ix,iy)
+ do i=1,h
+ fili=fil(i); dixi=dix*i; diyi=diy*i
+ b(ix,iy)=b(ix,iy)+fili*(a(ix+dixi,iy+diyi)+a(ix-dixi,iy-diyi))
+ enddo
+ endif
+enddo; enddo
+a=b
+end subroutine dibeta2
+!===================================================================== [dibeta]
+subroutine dibeta3(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, nfil, &
+ dixs,diys,dizs,hss, a, ff,ix,iy,iz)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ kz,lz,mz,nz,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs
+real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss
+real(dp), dimension(kx:nx,ky:ny,kz:nz),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(kx:nx,ky:ny,kz:nz):: b
+real(dp) :: fili
+integer(spi) :: h,i, &
+ dix,diy,diz, &
+ dixi,diyi,dizi
+!==============================================================================
+b=u0
+do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz)
+ if(abs(dix)+abs(diy)+abs(diz)==0)then;b(ix,iy,iz)=a(ix,iy,iz)
+ else
+ call blinfil(nfil,hss(ix,iy,iz),h,fil,ff); if(ff)return
+ b(ix,iy,iz)=fil(0)*a(ix,iy,iz)
+ do i=1,h
+ fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i
+ b(ix,iy,iz)=b(ix,iy,iz)+fili* &
+ (a(ix+dixi,iy+diyi,iz+dizi)&
+ +a(ix-dixi,iy-diyi,iz-dizi))
+ enddo
+ endif
+enddo; enddo; enddo
+a=b
+end subroutine dibeta3
+!===================================================================== [dibeta]
+subroutine dibeta4(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, &
+ nfil, dixs,diys,dizs,diws,hss, a, ff,ix,iy,iz,iw)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ kz,lz,mz,nz,&
+ kw,lw,mw,nw,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,&
+ dizs,diws
+real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss
+real(dp), dimension(kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz,iw
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b
+real(dp) :: fili
+integer(spi) :: h,i, &
+ dix,diy,diz,diw, &
+ dixi,diyi,dizi,diwi
+!==============================================================================
+b=u0
+do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ dix=dixs(ix,iy,iz,iw);diy=diys(ix,iy,iz,iw)
+ diz=dizs(ix,iy,iz,iw);diw=diws(ix,iy,iz,iw)
+ if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then;b(ix,iy,iz,iw)=a(ix,iy,iz,iw)
+ else
+ call blinfil(nfil,hss(ix,iy,iz,iw),h,fil,ff); if(ff)return
+ b(ix,iy,iz,iw)=fil(0)*a(ix,iy,iz,iw)
+ do i=1,h
+ fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i
+ b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fili* &
+ (a(ix+dixi,iy+diyi,iz+dizi,iw+diwi)&
+ +a(ix-dixi,iy-diyi,iz-dizi,iw-diwi))
+ enddo
+ endif
+enddo; enddo; enddo; enddo
+a=b
+end subroutine dibeta4
+
+!===================================================================== [dibeta]
+subroutine dibetax3(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,&
+ qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz)
+!=============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx, &
+ ky,ly,my,ny, &
+ kz,lz,mz,nz, &
+ icol,nfil
+integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs
+
+integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol
+real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss
+real(dp),dimension(kx:nx,ky:ny,kz:nz), intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(kx:nx,ky:ny,kz:nz):: b
+real(dp) :: fili,hs
+integer(spi) :: h,i, &
+ dix,diy,diz, &
+ dixi,diyi,dizi
+integer(fpi) :: j
+!==============================================================================
+b=u0
+if(icol==1)jcol=1
+do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ j=jcol(ix,iy,iz)
+ if(icol/=qcols(j,ix,iy,iz))then
+ b(ix,iy,iz)=a(ix,iy,iz)
+ cycle
+ else
+ jcol(ix,iy,iz)=j+1_fpi
+ dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j)
+ hs=hss(j,ix,iy,iz)
+ call blinfil(nfil,hs,h,fil,ff); if(ff)return
+ b(ix,iy,iz)=fil(0)*a(ix,iy,iz)
+ do i=1,h
+ fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i
+ b(ix,iy,iz)=b(ix,iy,iz)+fili* &
+ (a(ix+dixi,iy+diyi,iz+dizi)&
+ +a(ix-dixi,iy-diyi,iz-dizi))
+ enddo
+ endif
+enddo; enddo; enddo
+a=b
+end subroutine dibetax3
+!===================================================================== [dibeta]
+subroutine dibetax4(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, &
+ icol,nfil,&
+ qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw)
+!=============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx, &
+ ky,ly,my,ny, &
+ kz,lz,mz,nz, &
+ kw,lw,mw,nw, &
+ icol,nfil
+integer(fpi),dimension(0:11,lx:mx,ly:my,lz:mz,lw:mw),&
+ intent(in ):: qcols
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,10),&
+ intent(in ):: dixs,diys,&
+ dizs,diws
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(inout):: jcol
+real(dp),dimension(10,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss
+real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz,iw
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b
+real(dp) :: fili,hs
+integer(spi) :: h,i, &
+ dix,diy,diz,diw, &
+ dixi,diyi,dizi,diwi
+integer(fpi) :: j
+!==============================================================================
+b=u0
+if(icol==1)jcol=1
+do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ j=jcol(ix,iy,iz,iw)
+ if(icol/=qcols(j,ix,iy,iz,iw))then
+ b(ix,iy,iz,iw)=a(ix,iy,iz,iw)
+ cycle
+ else
+ jcol(ix,iy,iz,iw)=j+1_fpi
+ dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j)
+ diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j)
+ hs=hss(j,ix,iy,iz,iw)
+ call blinfil(nfil,hs,h,fil,ff); if(ff)return
+ b(ix,iy,iz,iw)=fil(0)*a(ix,iy,iz,iw)
+ do i=1,h
+ fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i
+ b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fili* &
+ (a(ix+dixi,iy+diyi,iz+dizi,iw+diwi)&
+ +a(ix-dixi,iy-diyi,iz-dizi,iw-diwi))
+ enddo
+ endif
+enddo; enddo; enddo; enddo
+a=b
+end subroutine dibetax4
+
+!===================================================================== [dibeta]
+subroutine vdibeta1(nv,kx,lx,mx,nx, nfil,dixs,hss,a,ff,ix)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv,kx,lx,mx,nx, nfil
+integer(fpi),dimension(lx:mx),intent(in ):: dixs
+real(dp), dimension(lx:mx),intent(in ):: hss
+real(dp), dimension(nv,kx:nx),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx) :: b
+real(dp) :: fili
+integer(spi) :: h,i,dix,dixi
+!==============================================================================
+b=u0
+do ix=lx,mx
+ dix=dixs(ix)
+ if(dix==0)then; b(:,ix)=a(:,ix)
+ else
+ call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return
+ b(:,ix)=fil(0)*a(:,ix)
+ do i=1,h
+ fili=fil(i); dixi=dix*i
+ b(:,ix)=b(:,ix)+fili*(a(:,ix+dixi)+a(:,ix-dixi))
+ enddo
+ endif
+enddo
+a=b
+end subroutine vdibeta1
+!===================================================================== [dibeta]
+subroutine vdibeta2(nv, kx,lx,mx,nx, ky,ly,my,ny, nfil, &
+ dixs,diys,hss, a, ff,ix,iy)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv, &
+ kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys
+real(dp), dimension(lx:mx,ly:my),intent(in ):: hss
+real(dp), dimension(nv,kx:nx,ky:ny),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx,ky:ny):: b
+real(dp) :: fili
+integer(spi) :: h,i,dix,diy,dixi,diyi
+!==============================================================================
+b=u0
+do iy=ly,my; do ix=lx,mx
+ dix=dixs(ix,iy); diy=diys(ix,iy)
+ if(abs(dix)+abs(diy)==0)then;b(:,ix,iy)=a(:,ix,iy)
+ else
+ call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return
+ b(:,ix,iy)=fil(0)*a(:,ix,iy)
+ do i=1,h
+ fili=fil(i); dixi=dix*i; diyi=diy*i
+ b(:,ix,iy)=b(:,ix,iy)+fili* &
+ (a(:,ix+dixi,iy+diyi)+a(:,ix-dixi,iy-diyi))
+ enddo
+ endif
+enddo; enddo
+a=b
+end subroutine vdibeta2
+!===================================================================== [dibeta]
+subroutine vdibeta3(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, nfil, &
+ dixs,diys,dizs,hss, a, ff,ix,iy,iz)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv, &
+ kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ kz,lz,mz,nz,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs
+real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss
+real(dp), dimension(nv,kx:nx,ky:ny,kz:nz),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b
+real(dp) :: fili
+integer(spi) :: h,i, &
+ dix,diy,diz, &
+ dixi,diyi,dizi
+!==============================================================================
+b=u0
+do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz)
+ if(abs(dix)+abs(diy)+abs(diz)==0)then;b(:,ix,iy,iz)=a(:,ix,iy,iz)
+ else
+ call blinfil(nfil,hss(ix,iy,iz),h,fil,ff); if(ff)return
+ b(:,ix,iy,iz)=fil(0)*a(:,ix,iy,iz)
+ do i=1,h
+ fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i
+ b(:,ix,iy,iz)=b(:,ix,iy,iz)+fili* &
+ (a(:,ix+dixi,iy+diyi,iz+dizi)&
+ +a(:,ix-dixi,iy-diyi,iz-dizi))
+ enddo
+ endif
+enddo; enddo; enddo
+a=b
+end subroutine vdibeta3
+!===================================================================== [dibeta]
+subroutine vdibeta4(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, &
+ nfil, dixs,diys,dizs,diws,hss, a, ff,ix,iy,iz,iw)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv, &
+ kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ kz,lz,mz,nz,&
+ kw,lw,mw,nw,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,&
+ dizs,diws
+real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss
+real(dp), dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz,iw
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b
+real(dp) :: fili
+integer(spi) :: h,i, &
+ dix,diy,diz,diw, &
+ dixi,diyi,dizi,diwi
+!==============================================================================
+b=u0
+do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ dix=dixs(ix,iy,iz,iw);diy=diys(ix,iy,iz,iw)
+ diz=dizs(ix,iy,iz,iw);diw=diws(ix,iy,iz,iw)
+ if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then
+ b(:,ix,iy,iz,iw)=a(:,ix,iy,iz,iw)
+ else
+ call blinfil(nfil,hss(ix,iy,iz,iw),h,fil,ff); if(ff)return
+ b(:,ix,iy,iz,iw)=fil(0)*a(:,ix,iy,iz,iw)
+ do i=1,h
+ fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i
+ b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fili* &
+ (a(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)&
+ +a(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi))
+ enddo
+ endif
+enddo; enddo; enddo; enddo
+a=b
+end subroutine vdibeta4
+
+!===================================================================== [dibeta]
+subroutine vdibetax3(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,&
+ qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz)
+!=============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv, &
+ kx,lx,mx,nx, &
+ ky,ly,my,ny, &
+ kz,lz,mz,nz, &
+ icol,nfil
+integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs
+integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol
+real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz), intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b
+real(dp) :: fili,hs
+integer(spi) :: h,i, &
+ dix,diy,diz, &
+ dixi,diyi,dizi
+integer(fpi) :: j
+!==============================================================================
+b=u0
+if(icol==1)jcol=1
+do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ j=jcol(ix,iy,iz)
+ if(icol/=qcols(j,ix,iy,iz))then
+ b(:,ix,iy,iz)=a(:,ix,iy,iz)
+ cycle
+ else
+ jcol(ix,iy,iz)=j+1_fpi
+ dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j)
+ hs=hss(j,ix,iy,iz)
+ call blinfil(nfil,hs,h,fil,ff); if(ff)return
+ b(:,ix,iy,iz)=fil(0)*a(:,ix,iy,iz)
+ do i=1,h
+ fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i
+ b(:,ix,iy,iz)=b(:,ix,iy,iz)+fili* &
+ (a(:,ix+dixi,iy+diyi,iz+dizi)&
+ +a(:,ix-dixi,iy-diyi,iz-dizi))
+ enddo
+ endif
+enddo; enddo; enddo
+a=b
+end subroutine vdibetax3
+!===================================================================== [dibeta]
+subroutine vdibetax4(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, &
+ icol,nfil,&
+ qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw)
+!=============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv, &
+ kx,lx,mx,nx, &
+ ky,ly,my,ny, &
+ kz,lz,mz,nz, &
+ kw,lw,mw,nw, &
+ icol,nfil
+integer(fpi),dimension(0:11,lx:mx,ly:my,lz:mz,lw:mw),&
+ intent(in ):: qcols
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,10),&
+ intent(in ):: dixs,diys,&
+ dizs,diws
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(inout):: jcol
+real(dp),dimension(10,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz,iw
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b
+real(dp) :: fili,hs
+integer(spi) :: h,i, &
+ dix,diy,diz,diw, &
+ dixi,diyi,dizi,diwi
+integer(fpi) :: j
+!==============================================================================
+b=u0
+if(icol==1)jcol=1
+do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ j=jcol(ix,iy,iz,iw)
+ if(icol/=qcols(j,ix,iy,iz,iw))then
+ b(:,ix,iy,iz,iw)=a(:,ix,iy,iz,iw)
+ cycle
+ else
+ jcol(ix,iy,iz,iw)=j+1_fpi
+ dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j)
+ diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j)
+ hs=hss(j,ix,iy,iz,iw)
+ call blinfil(nfil,hs,h,fil,ff); if(ff)return
+ b(:,ix,iy,iz,iw)=fil(0)*a(:,ix,iy,iz,iw)
+ do i=1,h
+ fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i
+ b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fili* &
+ (a(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)&
+ +a(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi))
+ enddo
+ endif
+enddo; enddo; enddo; enddo
+a=b
+end subroutine vdibetax4
+
+!--- The following routine share the interface, dibetat:
+
+!==================================================================== [dibetat]
+subroutine dibeta1t(kx,lx,mx,nx, nfil, dixs,hss, a, ff,ix)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx,nfil
+integer(fpi),dimension(lx:mx),intent(in ):: dixs
+real(dp), dimension(lx:mx),intent(in ):: hss
+real(dp), dimension(kx:nx),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil):: fil
+real(dp),dimension(kx:nx) :: b
+real(dp) :: filiat,at
+integer(spi) :: h,i,dix,dixi
+!==============================================================================
+b=u0
+do ix=lx,mx
+ at=a(ix)
+ dix=dixs(ix)
+ if(dix==0)then;b(ix)=b(ix)+at
+ else
+ call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return
+ b(ix)=b(ix)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i
+ b(ix+dixi)=b(ix+dixi)+filiat
+ b(ix-dixi)=b(ix-dixi)+filiat
+ enddo
+ endif
+enddo
+a=b
+end subroutine dibeta1t
+!==================================================================== [dibetat]
+subroutine dibeta2t(kx,lx,mx,nx, ky,ly,my,ny, &
+ nfil, dixs,diys,hss, a, ff,ix,iy)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys
+real(dp), dimension(lx:mx,ly:my),intent(in ):: hss
+real(dp), dimension(kx:nx,ky:ny),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(kx:nx,ky:ny):: b
+real(dp) :: filiat,at
+integer(spi) :: h,i,dix,diy,dixi,diyi
+!==============================================================================
+b=u0
+do iy=ly,my; do ix=lx,mx
+ at=a(ix,iy)
+ dix=dixs(ix,iy); diy=diys(ix,iy)
+ if(abs(dix)+abs(diy)==0)then;b(ix,iy)=b(ix,iy)+at
+ else
+ call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return
+ b(ix,iy)=b(ix,iy)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i; diyi=diy*i
+ b(ix+dixi,iy+diyi)=b(ix+dixi,iy+diyi)+filiat
+ b(ix-dixi,iy-diyi)=b(ix-dixi,iy-diyi)+filiat
+ enddo
+ endif
+enddo; enddo
+a=b
+end subroutine dibeta2t
+!==================================================================== [dibetat]
+subroutine dibeta3t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, &
+ nfil, dixs,diys,dizs,hss, a, ff,ix,iy,iz)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ kz,lz,mz,nz,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs
+real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss
+real(dp), dimension(kx:nx,ky:ny,kz:nz),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(kx:nx,ky:ny,kz:nz):: b
+real(dp) :: filiat,at
+integer(spi) :: h,i, &
+ dix,diy,diz,&
+ dixi,diyi,dizi
+!==============================================================================
+b=u0
+do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ at=a(ix,iy,iz)
+ dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz)
+ if(abs(dix)+abs(diy)+abs(diz)==0)then;b(ix,iy,iz)=b(ix,iy,iz)+at
+ else
+ call blinfil(nfil,hss(ix,iy,iz),h,fil,ff); if(ff)return
+ b(ix,iy,iz)=b(ix,iy,iz)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i
+ b(ix+dixi,iy+diyi,iz+dizi)=b(ix+dixi,iy+diyi,iz+dizi)+filiat
+ b(ix-dixi,iy-diyi,iz-dizi)=b(ix-dixi,iy-diyi,iz-dizi)+filiat
+ enddo
+ endif
+enddo; enddo; enddo
+a=b
+end subroutine dibeta3t
+
+!==================================================================== [dibetat]
+subroutine dibeta4t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, &
+ nfil,dixs,diys,dizs,diws,hss, a,ff,ix,iy,iz,iw)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ kz,lz,mz,nz,&
+ kw,lw,mw,nw,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,&
+ dizs,diws
+real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss
+real(dp), dimension(kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz,iw
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b
+real(dp) :: filiat,at
+integer(spi) :: h,i, &
+ dix,diy,diz,diw, &
+ dixi,diyi,dizi,diwi
+!==============================================================================
+b=u0
+do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ at=a(ix,iy,iz,iw)
+ dix=dixs(ix,iy,iz,iw); diy=diys(ix,iy,iz,iw)
+ diz=dizs(ix,iy,iz,iw); diw=diws(ix,iy,iz,iw)
+ if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then
+ b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+at
+ else
+ call blinfil(nfil,hss(ix,iy,iz,iw),h,fil,ff); if(ff)return
+ b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i
+ b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)= &
+ b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat
+ b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)= &
+ b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat
+ enddo
+ endif
+enddo; enddo; enddo; enddo
+a=b
+end subroutine dibeta4t
+
+!==================================================================== [dibetat]
+subroutine dibetax3t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,&
+ qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz)
+!=============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx, &
+ ky,ly,my,ny, &
+ kz,lz,mz,nz, &
+ icol,nfil
+integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs
+integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol
+real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss
+real(dp),dimension(kx:nx,ky:ny,kz:nz), intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(kx:nx,ky:ny,kz:nz):: b
+real(dp) :: filiat,hs,at
+integer(spi) :: h,i, &
+ dix,diy,diz, &
+ dixi,diyi,dizi
+integer(fpi) :: j
+!==============================================================================
+b=u0
+if(icol==7)jcol=6
+do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ at=a(ix,iy,iz)
+ j=jcol(ix,iy,iz)
+ if(icol/=qcols(j,ix,iy,iz))then
+ b(ix,iy,iz)=b(ix,iy,iz)+at
+ cycle
+ else
+ jcol(ix,iy,iz)=j-1_fpi
+ dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j)
+ hs=hss(j,ix,iy,iz)
+ call blinfil(nfil,hs,h,fil,ff); if(ff)return
+ b(ix,iy,iz)=b(ix,iy,iz)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i
+ b(ix+dixi,iy+diyi,iz+dizi)=b(ix+dixi,iy+diyi,iz+dizi)+filiat
+ b(ix-dixi,iy-diyi,iz-dizi)=b(ix-dixi,iy-diyi,iz-dizi)+filiat
+ enddo
+ endif
+enddo; enddo; enddo
+a=b
+end subroutine dibetax3t
+
+!==================================================================== [dibetat]
+subroutine dibetax4t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, &
+ icol,nfil,&
+ qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw)
+!=============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: kx,lx,mx,nx, &
+ ky,ly,my,ny, &
+ kz,lz,mz,nz, &
+ kw,lw,mw,nw, &
+ icol,nfil
+integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: qcols
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,6), intent(in ):: dixs,diys,&
+ dizs,diws
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw), intent(inout):: jcol
+real(dp),dimension(6,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss
+real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz,iw
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b
+real(dp) :: filiat,hs,at
+integer(spi) :: h,i, &
+ dix,diy,diz,diw, &
+ dixi,diyi,dizi,diwi
+integer(fpi) :: j
+!==============================================================================
+b=u0
+if(icol==15)jcol=10
+do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ at=a(ix,iy,iz,iw)
+ j=jcol(ix,iy,iz,iw)
+ if(icol/=qcols(j,ix,iy,iz,iw))then
+ b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+at
+ cycle
+ else
+ jcol(ix,iy,iz,iw)=j-1_fpi
+ dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j)
+ diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j)
+ hs=hss(j,ix,iy,iz,iw)
+ call blinfil(nfil,hs,h,fil,ff); if(ff)return
+ b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i
+ b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)= &
+ b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat
+ b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)= &
+ b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat
+ enddo
+ endif
+enddo; enddo; enddo; enddo
+a=b
+end subroutine dibetax4t
+
+!==================================================================== [dibetat]
+subroutine vdibeta1t(nv,kx,lx,mx,nx, nfil, dixs,hss, a, ff,ix)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv,kx,lx,mx,nx,nfil
+integer(fpi),dimension(lx:mx),intent(in ):: dixs
+real(dp), dimension(lx:mx),intent(in ):: hss
+real(dp), dimension(nv,kx:nx),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx):: b
+real(dp),dimension(nv) :: filiat,at
+integer(spi) :: h,i,dix,dixi
+!==============================================================================
+b=u0
+do ix=lx,mx
+ at=a(:,ix)
+ dix=dixs(ix)
+ if(dix==0)then;b(:,ix)=b(:,ix)+at
+ else
+ call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return
+ b(:,ix)=b(:,ix)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i
+ b(:,ix+dixi)=b(:,ix+dixi)+filiat
+ b(:,ix-dixi)=b(:,ix-dixi)+filiat
+ enddo
+ endif
+enddo
+a=b
+end subroutine vdibeta1t
+!==================================================================== [dibetat]
+subroutine vdibeta2t(nv, kx,lx,mx,nx, ky,ly,my,ny, &
+ nfil, dixs,diys,hss, a, ff,ix,iy)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv,&
+ kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys
+real(dp), dimension(lx:mx,ly:my),intent(in ):: hss
+real(dp), dimension(nv,kx:nx,ky:ny),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx,ky:ny):: b
+real(dp),dimension(nv) :: filiat,at
+integer(spi) :: h,i,dix,diy,dixi,diyi
+!==============================================================================
+b=u0
+do iy=ly,my; do ix=lx,mx
+ at=a(:,ix,iy)
+ dix=dixs(ix,iy); diy=diys(ix,iy)
+ if(abs(dix)+abs(diy)==0)then;b(:,ix,iy)=b(:,ix,iy)+at
+ else
+ call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return
+ b(:,ix,iy)=b(:,ix,iy)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i; diyi=diy*i
+ b(:,ix+dixi,iy+diyi)=b(:,ix+dixi,iy+diyi)+filiat
+ b(:,ix-dixi,iy-diyi)=b(:,ix-dixi,iy-diyi)+filiat
+ enddo
+ endif
+enddo; enddo
+a=b
+end subroutine vdibeta2t
+!==================================================================== [dibetat]
+subroutine vdibeta3t(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, &
+ nfil, dixs,diys,dizs,hss, a, ff,ix,iy,iz)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv, &
+ kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ kz,lz,mz,nz,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs
+real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss
+real(dp), dimension(nv,kx:nx,ky:ny,kz:nz),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b
+real(dp),dimension(nv) :: filiat,at
+integer(spi) :: h,i, &
+ dix,diy,diz,&
+ dixi,diyi,dizi
+!==============================================================================
+b=u0
+do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ at=a(:,ix,iy,iz)
+ dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz)
+ if(abs(dix)+abs(diy)+abs(diz)==0)then;b(:,ix,iy,iz)=b(:,ix,iy,iz)+at
+ else
+ call blinfil(nfil, hss(ix,iy,iz),h,fil,ff); if(ff)return
+ b(:,ix,iy,iz)=b(:,ix,iy,iz)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i
+ b(:,ix+dixi,iy+diyi,iz+dizi)=b(:,ix+dixi,iy+diyi,iz+dizi)+filiat
+ b(:,ix-dixi,iy-diyi,iz-dizi)=b(:,ix-dixi,iy-diyi,iz-dizi)+filiat
+ enddo
+ endif
+enddo; enddo; enddo
+a=b
+end subroutine vdibeta3t
+!==================================================================== [dibetat]
+subroutine vdibeta4t(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, &
+ nfil, dixs,diys,dizs,diws,hss, a,ff,ix,iy,iz,iw)
+!==============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv, &
+ kx,lx,mx,nx,&
+ ky,ly,my,ny,&
+ kz,lz,mz,nz,&
+ kw,lw,mw,nw,&
+ nfil
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,&
+ dizs,diws
+real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss
+real(dp), dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz,iw
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b
+real(dp),dimension(nv) :: filiat,at
+integer(spi) :: h,i, &
+ dix,diy,diz,diw, &
+ dixi,diyi,dizi,diwi
+!==============================================================================
+b=u0
+do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ at=a(:,ix,iy,iz,iw)
+ dix=dixs(ix,iy,iz,iw); diy=diys(ix,iy,iz,iw)
+ diz=dizs(ix,iy,iz,iw); diw=diws(ix,iy,iz,iw)
+ if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then
+ b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+at
+ else
+ call blinfil(nfil, hss(ix,iy,iz,iw),h,fil,ff); if(ff)return
+ b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i
+ b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)= &
+ b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat
+ b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)= &
+ b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat
+ enddo
+ endif
+enddo; enddo; enddo; enddo
+a=b
+end subroutine vdibeta4t
+
+!==================================================================== [dibetat]
+subroutine vdibetax3t(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,&
+ qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz)
+!=============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv, &
+ kx,lx,mx,nx, &
+ ky,ly,my,ny, &
+ kz,lz,mz,nz, &
+ icol,nfil
+integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs
+integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol
+real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz), intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b
+real(dp),dimension(nv) :: filiat,at
+real(dp) :: hs
+integer(spi) :: h,i, &
+ dix,diy,diz, &
+ dixi,diyi,dizi
+integer(fpi) :: j
+!==============================================================================
+b=u0
+if(icol==7)jcol=6
+do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ at=a(:,ix,iy,iz)
+ j=jcol(ix,iy,iz)
+ if(icol/=qcols(j,ix,iy,iz))then
+ b(:,ix,iy,iz)=b(:,ix,iy,iz)+at
+ cycle
+ else
+ jcol(ix,iy,iz)=j-1_fpi
+ dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j)
+ hs=hss(j,ix,iy,iz)
+ call blinfil(nfil,hs,h,fil,ff); if(ff)return
+ b(:,ix,iy,iz)=b(:,ix,iy,iz)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i
+ b(:,ix+dixi,iy+diyi,iz+dizi)=b(:,ix+dixi,iy+diyi,iz+dizi)+filiat
+ b(:,ix-dixi,iy-diyi,iz-dizi)=b(:,ix-dixi,iy-diyi,iz-dizi)+filiat
+ enddo
+ endif
+enddo; enddo; enddo
+a=b
+end subroutine vdibetax3t
+
+!==================================================================== [dibetat]
+subroutine vdibetax4t(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, &
+ icol,nfil,&
+ qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw)
+!=============================================================================
+use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi
+use jp_pietc, only: u0
+implicit none
+integer(spi), intent(in ):: nv, &
+ kx,lx,mx,nx, &
+ ky,ly,my,ny, &
+ kz,lz,mz,nz, &
+ kw,lw,mw,nw, &
+ icol,nfil
+integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: qcols
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,6), intent(in ):: dixs,diys,&
+ dizs,diws
+integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw), intent(inout):: jcol
+real(dp),dimension(6,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a
+logical, intent( out):: ff
+integer(spi), intent( out):: ix,iy,iz,iw
+!------------------------------------------------------------------------------
+real(dp),dimension(0:nfil) :: fil
+real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b
+real(dp),dimension(nv) :: filiat,at
+real(dp) :: hs
+integer(spi) :: h,i, &
+ dix,diy,diz,diw, &
+ dixi,diyi,dizi,diwi
+integer(fpi) :: j
+!==============================================================================
+b=u0
+if(icol==15)jcol=10
+do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx
+ at=a(:,ix,iy,iz,iw)
+ j=jcol(ix,iy,iz,iw)
+ if(icol/=qcols(j,ix,iy,iz,iw))then
+ b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+at
+ cycle
+ else
+ jcol(ix,iy,iz,iw)=j-1_fpi
+ dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j)
+ diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j)
+ hs=hss(j,ix,iy,iz,iw)
+ call blinfil(nfil,hs,h,fil,ff); if(ff)return
+ b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fil(0)*at
+ do i=1,h
+ filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i
+ b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)= &
+ b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat
+ b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)= &
+ b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat
+ enddo
+ endif
+enddo; enddo; enddo; enddo
+a=b
+end subroutine vdibetax4t
+
+end module jp_pbfil3
+
+!#
diff --git a/src/mgbf/jp_pietc.f90 b/src/mgbf/jp_pietc.f90
new file mode 100644
index 0000000000..b102d22b7a
--- /dev/null
+++ b/src/mgbf/jp_pietc.f90
@@ -0,0 +1,111 @@
+module jp_pietc
+!$$$ module documentation block
+! . . . .
+! module: jp_pietc
+! prgmmr: purser org: NOAA/EMC date: 2014
+!
+! abstract: Some of the commonly used constants (pi etc)
+! mainly for double-precision subroutines.
+!
+! module history log:
+!
+! Subroutines Included:
+!
+! Functions Included:
+!
+! remarks:
+! ms10 etc are needed to satisfy the some (eg., gnu fortran) compilers'
+! more rigorous standards regarding the way "data" statements are initialized.
+! Zero and the first few units are u0,u1,u2, etc., their reciprocals being,
+! o2,o3 etc and their square roots, r2,r3. Reciprocal roots are or2,or3 etc.
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+use jp_pkind, only: dp,dpc
+implicit none
+logical ,parameter:: T=.true.,F=.false. !<- for pain-relief in logical ops
+real(dp),parameter:: &
+ u0=0,u1=1,mu1=-u1,u2=2,mu2=-u2,u3=3,mu3=-u3,u4=4,mu4=-u4,u5=5,mu5=-u5, &
+ u6=6,mu6=-u6,o2=u1/2,o3=u1/3,o4=u1/4,o5=u1/5,o6=u1/6, &
+ pi =3.1415926535897932384626433832795028841971693993751058209749e0_dp, &
+ pi2=6.2831853071795864769252867665590057683943387987502116419498e0_dp, &
+ pih=1.5707963267948966192313216916397514420985846996875529104874e0_dp, &
+ rpi=1.7724538509055160272981674833411451827975494561223871282138e0_dp, &
+! Important square-roots
+ r2 =1.4142135623730950488016887242096980785696718753769480731766e0_dp, &
+ r3 =1.7320508075688772935274463415058723669428052538103806280558e0_dp, &
+ r5 =2.2360679774997896964091736687312762354406183596115257242708e0_dp, &
+ or2=u1/r2,or3=u1/r3,or5=u1/r5, &
+! Golden number:
+ phi=1.6180339887498948482045868343656381177203091798057628621354e0_dp, &
+! Euler-Mascheroni constant:
+ euler=0.57721566490153286060651209008240243104215933593992359880e0_dp, &
+! Degree to radians; radians to degrees:
+ dtor=pi/180,rtod=180/pi, &
+! Sines of all main fractions of 90 degrees (down to ninths):
+ s10=.173648177666930348851716626769314796000375677184069387236241e0_dp,&
+ s11=.195090322016128267848284868477022240927691617751954807754502e0_dp,&
+ s13=.222520933956314404288902564496794759466355568764544955311987e0_dp,&
+ s15=.258819045102520762348898837624048328349068901319930513814003e0_dp,&
+ s18=.309016994374947424102293417182819058860154589902881431067724e0_dp,&
+ s20=.342020143325668733044099614682259580763083367514160628465048e0_dp,&
+ s22=.382683432365089771728459984030398866761344562485627041433800e0_dp,&
+ s26=.433883739117558120475768332848358754609990727787459876444547e0_dp,&
+ s30=o2, &
+ s34=.555570233019602224742830813948532874374937190754804045924153e0_dp,&
+ s36=.587785252292473129168705954639072768597652437643145991072272e0_dp,&
+ s39=.623489801858733530525004884004239810632274730896402105365549e0_dp,&
+ s40=.642787609686539326322643409907263432907559884205681790324977e0_dp,&
+ s45=or2, &
+ s50=.766044443118978035202392650555416673935832457080395245854045e0_dp,&
+ s51=.781831482468029808708444526674057750232334518708687528980634e0_dp,&
+ s54=.809016994374947424102293417182819058860154589902881431067724e0_dp,&
+ s56=.831469612302545237078788377617905756738560811987249963446124e0_dp,&
+ s60=r3*o2, &
+ s64=.900968867902419126236102319507445051165919162131857150053562e0_dp,&
+ s68=.923879532511286756128183189396788286822416625863642486115097e0_dp,&
+ s70=.939692620785908384054109277324731469936208134264464633090286e0_dp,&
+ s72=.951056516295153572116439333379382143405698634125750222447305e0_dp,&
+ s75=.965925826289068286749743199728897367633904839008404550402343e0_dp,&
+ s77=.974927912181823607018131682993931217232785800619997437648079e0_dp,&
+ s79=.980785280403230449126182236134239036973933730893336095002916e0_dp,&
+ s80=.984807753012208059366743024589523013670643251719842418790025e0_dp,&
+! ... and their minuses:
+ ms10=-s10,ms11=-s11,ms13=-s13,ms15=-s15,ms18=-s18,ms20=-s20,ms22=-s22,&
+ ms26=-s26,ms30=-s30,ms34=-s34,ms36=-s36,ms39=-s39,ms40=-s40,ms45=-s45,&
+ ms50=-s50,ms51=-s51,ms54=-s54,ms56=-s56,ms60=-s60,ms64=-s64,ms68=-s68,&
+ ms70=-s70,ms72=-s72,ms75=-s75,ms77=-s77,ms79=-s79,ms80=-s80
+
+complex(dpc),parameter:: &
+ c0=(u0,u0),c1=(u1,u0),mc1=-c1,ci=(u0,u1),mci=-ci,cipi=ci*pi, &
+! Main fractional rotations, as unimodualr complex numbers:
+ z000=c1 ,z010=( s80,s10),z011=( s79,s11),z013=( s77,s13),&
+ z015=( s75,s15),z018=( s72,s18),z020=( s70,s20),z022=( s68,s22),&
+ z026=( s64,s26),z030=( s60,s30),z034=( s56,s34),z036=( s54,s36),&
+ z039=( s51,s39),z040=( s50,s40),z045=( s45,s45),z050=( s40,s50),&
+ z051=( s39,s51),z054=( s36,s54),z056=( s34,s56),z060=( s30,s60),&
+ z064=( s26,s64),z068=( s22,s68),z070=( s20,s70),z072=( s18,s72),&
+ z075=( s15,s75),z077=( s13,s77),z079=( s11,s79),z080=( s10,s80),&
+ z090=ci, z100=(ms10,s80),z101=(ms11,s79),z103=(ms13,s77),&
+ z105=(ms15,s75),z108=(ms18,s72),z110=(ms20,s70),z112=(ms22,s68),&
+ z116=(ms26,s64),z120=(ms30,s60),z124=(ms34,s56),z126=(ms36,s54),&
+ z129=(ms39,s51),z130=(ms40,s50),z135=(ms45,s45),z140=(ms50,s40),&
+ z141=(ms51,s39),z144=(ms54,s36),z146=(ms56,s34),z150=(ms60,s30),&
+ z154=(ms64,s26),z158=(ms68,s22),z160=(ms70,s20),z162=(ms72,s18),&
+ z165=(ms75,s15),z167=(ms77,s13),z169=(ms79,s11),z170=(ms80,s10),&
+ z180=-z000,z190=-z010,z191=-z011,z193=-z013,z195=-z015,z198=-z018,&
+ z200=-z020,z202=-z022,z206=-z026,z210=-z030,z214=-z034,z216=-z036,&
+ z219=-z039,z220=-z040,z225=-z045,z230=-z050,z231=-z051,z234=-z054,&
+ z236=-z056,z240=-z060,z244=-z064,z248=-z068,z250=-z070,z252=-z072,&
+ z255=-z075,z257=-z077,z259=-z079,z260=-z080,z270=-z090,z280=-z100,&
+ z281=-z101,z283=-z103,z285=-z105,z288=-z108,z290=-z110,z292=-z112,&
+ z296=-z116,z300=-z120,z304=-z124,z306=-z126,z309=-z129,z310=-z130,&
+ z315=-z135,z320=-z140,z321=-z141,z324=-z144,z326=-z146,z330=-z150,&
+ z334=-z154,z338=-z158,z340=-z160,z342=-z162,z345=-z165,z347=-z167,&
+ z349=-z169,z350=-z170
+end module jp_pietc
diff --git a/src/mgbf/jp_pietc_s.f90 b/src/mgbf/jp_pietc_s.f90
new file mode 100644
index 0000000000..8f3097225b
--- /dev/null
+++ b/src/mgbf/jp_pietc_s.f90
@@ -0,0 +1,113 @@
+module jp_pietc_s
+!$$$ module documentation block
+! . . . .
+! module: jp_pietc_s
+! prgmmr: purser org: NOAA/EMC date: 2014
+!
+! abstract: Some of the commonly used constants (pi etc)
+!
+! module history log:
+!
+! Subroutines Included:
+!
+! Functions Included:
+!
+! remarks:
+! ms10 etc are needed to satisfy the some (eg., gnu fortran) compilers'
+! more rigorous standards regarding the way "data" statements are initialized.
+! Zero and the first few units are u0,u1,u2, etc., their reciprocals being,
+! o2,o3 etc and their square roots, r2,r3. Reciprocal roots are or2,or3 etc.
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+!=============================================================================
+use mpi
+use jp_pkind, only: sp,spc
+implicit none
+logical ,parameter:: T=.true.,F=.false. !<- for pain-relief in logical ops
+real(sp),parameter:: &
+ u0=0_sp,u1=1_sp,mu1=-u1,u2=2_sp,mu2=-u2,u3=3_sp,mu3=-u3,u4=4_sp, &
+ mu4=-u4,u5=5_sp,mu5=-u5,u6=6_sp,mu6=-u6,o2=u1/u2,o3=u1/u3,o4=u1/u4, &
+ o5=u1/u5,o6=u1/u6,mo2=-o2,mo3=-o3,mo4=-o4,mo5=-o5,mo6=-06, &
+ pi =3.1415926535897932384626433832795028841971693993751058209749e0_sp, &
+ pi2=6.2831853071795864769252867665590057683943387987502116419498e0_sp, &
+ pih=1.5707963267948966192313216916397514420985846996875529104874e0_sp, &
+ rpi=1.7724538509055160272981674833411451827975494561223871282138e0_sp, &
+! Important square-roots
+ r2 =1.4142135623730950488016887242096980785696718753769480731766e0_sp, &
+ r3 =1.7320508075688772935274463415058723669428052538103806280558e0_sp, &
+ r5 =2.2360679774997896964091736687312762354406183596115257242708e0_sp, &
+ or2=u1/r2,or3=u1/r3,or5=u1/r5, &
+! Golden number:
+ phi=1.6180339887498948482045868343656381177203091798057628621354e0_sp, &
+! Euler-Mascheroni constant:
+ euler=0.57721566490153286060651209008240243104215933593992359880e0_sp, &
+! Degree to radians; radians to degrees:
+ dtor=pi/180,rtod=180/pi, &
+! Sines of all main fractions of 90 degrees (down to ninths):
+ s10=.173648177666930348851716626769314796000375677184069387236241e0_sp,&
+ s11=.195090322016128267848284868477022240927691617751954807754502e0_sp,&
+ s13=.222520933956314404288902564496794759466355568764544955311987e0_sp,&
+ s15=.258819045102520762348898837624048328349068901319930513814003e0_sp,&
+ s18=.309016994374947424102293417182819058860154589902881431067724e0_sp,&
+ s20=.342020143325668733044099614682259580763083367514160628465048e0_sp,&
+ s22=.382683432365089771728459984030398866761344562485627041433800e0_sp,&
+ s26=.433883739117558120475768332848358754609990727787459876444547e0_sp,&
+ s30=o2, &
+ s34=.555570233019602224742830813948532874374937190754804045924153e0_sp,&
+ s36=.587785252292473129168705954639072768597652437643145991072272e0_sp,&
+ s39=.623489801858733530525004884004239810632274730896402105365549e0_sp,&
+ s40=.642787609686539326322643409907263432907559884205681790324977e0_sp,&
+ s45=or2, &
+ s50=.766044443118978035202392650555416673935832457080395245854045e0_sp,&
+ s51=.781831482468029808708444526674057750232334518708687528980634e0_sp,&
+ s54=.809016994374947424102293417182819058860154589902881431067724e0_sp,&
+ s56=.831469612302545237078788377617905756738560811987249963446124e0_sp,&
+ s60=r3*o2, &
+ s64=.900968867902419126236102319507445051165919162131857150053562e0_sp,&
+ s68=.923879532511286756128183189396788286822416625863642486115097e0_sp,&
+ s70=.939692620785908384054109277324731469936208134264464633090286e0_sp,&
+ s72=.951056516295153572116439333379382143405698634125750222447305e0_sp,&
+ s75=.965925826289068286749743199728897367633904839008404550402343e0_sp,&
+ s77=.974927912181823607018131682993931217232785800619997437648079e0_sp,&
+ s79=.980785280403230449126182236134239036973933730893336095002916e0_sp,&
+ s80=.984807753012208059366743024589523013670643251719842418790025e0_sp,&
+! ... and their minuses:
+ ms10=-s10,ms11=-s11,ms13=-s13,ms15=-s15,ms18=-s18,ms20=-s20,ms22=-s22,&
+ ms26=-s26,ms30=-s30,ms34=-s34,ms36=-s36,ms39=-s39,ms40=-s40,ms45=-s45,&
+ ms50=-s50,ms51=-s51,ms54=-s54,ms56=-s56,ms60=-s60,ms64=-s64,ms68=-s68,&
+ ms70=-s70,ms72=-s72,ms75=-s75,ms77=-s77,ms79=-s79,ms80=-s80
+
+complex(spc),parameter:: &
+ c0=(u0,u0),c1=(u1,u0),mc1=-c1,ci=(u0,u1),mci=-ci,cipi=ci*pi, &
+! Main fractional rotations, as unimodualr complex numbers:
+ z000=c1 ,z010=( s80,s10),z011=( s79,s11),z013=( s77,s13),&
+ z015=( s75,s15),z018=( s72,s18),z020=( s70,s20),z022=( s68,s22),&
+ z026=( s64,s26),z030=( s60,s30),z034=( s56,s34),z036=( s54,s36),&
+ z039=( s51,s39),z040=( s50,s40),z045=( s45,s45),z050=( s40,s50),&
+ z051=( s39,s51),z054=( s36,s54),z056=( s34,s56),z060=( s30,s60),&
+ z064=( s26,s64),z068=( s22,s68),z070=( s20,s70),z072=( s18,s72),&
+ z075=( s15,s75),z077=( s13,s77),z079=( s11,s79),z080=( s10,s80),&
+ z090=ci, z100=(ms10,s80),z101=(ms11,s79),z103=(ms13,s77),&
+ z105=(ms15,s75),z108=(ms18,s72),z110=(ms20,s70),z112=(ms22,s68),&
+ z116=(ms26,s64),z120=(ms30,s60),z124=(ms34,s56),z126=(ms36,s54),&
+ z129=(ms39,s51),z130=(ms40,s50),z135=(ms45,s45),z140=(ms50,s40),&
+ z141=(ms51,s39),z144=(ms54,s36),z146=(ms56,s34),z150=(ms60,s30),&
+ z154=(ms64,s26),z158=(ms68,s22),z160=(ms70,s20),z162=(ms72,s18),&
+ z165=(ms75,s15),z167=(ms77,s13),z169=(ms79,s11),z170=(ms80,s10),&
+ z180=-z000,z190=-z010,z191=-z011,z193=-z013,z195=-z015,z198=-z018,&
+ z200=-z020,z202=-z022,z206=-z026,z210=-z030,z214=-z034,z216=-z036,&
+ z219=-z039,z220=-z040,z225=-z045,z230=-z050,z231=-z051,z234=-z054,&
+ z236=-z056,z240=-z060,z244=-z064,z248=-z068,z250=-z070,z252=-z072,&
+ z255=-z075,z257=-z077,z259=-z079,z260=-z080,z270=-z090,z280=-z100,&
+ z281=-z101,z283=-z103,z285=-z105,z288=-z108,z290=-z110,z292=-z112,&
+ z296=-z116,z300=-z120,z304=-z124,z306=-z126,z309=-z129,z310=-z130,&
+ z315=-z135,z320=-z140,z321=-z141,z324=-z144,z326=-z146,z330=-z150,&
+ z334=-z154,z338=-z158,z340=-z160,z342=-z162,z345=-z165,z347=-z167,&
+ z349=-z169,z350=-z170
+end module jp_pietc_s
+
diff --git a/src/mgbf/jp_pkind.f90 b/src/mgbf/jp_pkind.f90
new file mode 100644
index 0000000000..cdbf19f4eb
--- /dev/null
+++ b/src/mgbf/jp_pkind.f90
@@ -0,0 +1,34 @@
+module jp_pkind
+!$$$ module documentation block
+! . . . .
+! module: jp_pkind
+!
+! abstract: Kinds for single- and double-precision
+!
+! module history log:
+!
+! Subroutines Included:
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+integer,parameter:: spi=selected_int_kind(6),&
+ dpi=selected_int_kind(12),&
+ sp =selected_real_kind(6,30),&
+ dp =selected_real_kind(15,300),&
+ spc=sp,dpc=dp
+!private:: one_dpi; integer(8),parameter:: one_dpi=1
+!integer,parameter:: dpi=kind(one_dpi)
+!integer,parameter:: sp=kind(1.0)
+!integer,parameter:: dp=kind(1.0d0)
+!integer,parameter:: spc=kind((1.0,1.0))
+!integer,parameter:: dpc=kind((1.0d0,1.0d0))
+end module jp_pkind
diff --git a/src/mgbf/jp_pkind2.f90 b/src/mgbf/jp_pkind2.f90
new file mode 100644
index 0000000000..3dcecc5635
--- /dev/null
+++ b/src/mgbf/jp_pkind2.f90
@@ -0,0 +1,25 @@
+module jp_pkind2
+!$$$ module documentation block
+! . . . .
+! module: jp_pkind2
+!
+! abstract: Integer kinds for helf- and fourth-precision integers
+!
+! module history log:
+!
+! Subroutines Included:
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+integer,parameter:: hpi=selected_int_kind(3),&
+ fpi=selected_int_kind(2)
+end module jp_pkind2
diff --git a/src/mgbf/jp_pmat.f90 b/src/mgbf/jp_pmat.f90
new file mode 100644
index 0000000000..f139feea06
--- /dev/null
+++ b/src/mgbf/jp_pmat.f90
@@ -0,0 +1,1096 @@
+module jp_pmat
+!$$$ module documentation block
+! . . . .
+! module: jp_pmat
+! prgmmr: fujita org: NOAA/EMC date: 1993
+!
+! abstract: Utility routines for various linear inversions and Cholesky
+!
+! module history log:
+! 2002 purser
+! 2009 purser
+! 2012 purser
+!
+! Subroutines Included:
+! swpvv -
+! inv -
+! ldum -
+! udlmm -
+! l1lm -
+! ldlm -
+! invu -
+! invl -
+!
+! Functions Included:
+!
+! remarks:
+! Originally, these routines were copies of the purely "inversion" members
+! of pmat1.f90 (a most extensive collection of matrix routines -- not just
+! inversions). As well as having both single and double precision versions
+! of each routine, these versions also make provision for a more graceful
+! termination in cases where the system matrix is detected to be
+! essentially singular (and therefore noninvertible). This provision takes
+! the form of an optional "failure flag", FF, which is normally returned
+! as .FALSE., but is returned as .TRUE. when inversion fails.
+! In Sep 2012, these routines were collected together into jp_pmat.f90 so
+! that all the main matrix routines could be in the same library, jp_pmat.a.
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+use jp_pkind, only: sp,dp,spc,dpc
+use jp_pietc, only: t,f
+implicit none
+private
+public:: ldum,udlmm,inv,L1Lm,LdLm,invl,invu
+interface swpvv; module procedure sswpvv,dswpvv,cswpvv; end interface
+interface ldum
+ module procedure sldum,dldum,cldum,sldumf,dldumf,cldumf; end interface
+interface udlmm
+ module procedure sudlmm,dudlmm,cudlmm,sudlmv,dudlmv,cudlmv; end interface
+interface inv
+ module procedure &
+sinvmt, dinvmt, cinvmt, slinmmt, dlinmmt, clinmmt, slinmvt, dlinmvt, clinmvt, &
+sinvmtf,dinvmtf,cinvmtf,slinmmtf,dlinmmtf,clinmmtf,slinmvtf,dlinmvtf,clinmvtf,&
+iinvf
+ end interface
+interface L1Lm; module procedure sL1Lm,dL1Lm,sL1Lmf,dL1Lmf; end interface
+interface LdLm; module procedure sLdLm,dLdLm,sLdLmf,dLdLmf; end interface
+interface invl; module procedure sinvl,dinvl,slinlv,dlinlv; end interface
+interface invu; module procedure sinvu,dinvu,slinuv,dlinuv; end interface
+
+contains
+
+!=============================================================================
+subroutine sswpvv(d,e)! [swpvv]
+!=============================================================================
+! Swap vectors
+!-------------
+real(sp), intent(inout) :: d(:), e(:)
+real(sp) :: tv(size(d))
+!=============================================================================
+tv = d; d = e; e = tv
+end subroutine sswpvv
+!=============================================================================
+subroutine dswpvv(d,e)! [swpvv]
+!=============================================================================
+real(dp), intent(inout) :: d(:), e(:)
+real(dp) :: tv(size(d))
+!=============================================================================
+tv = d; d = e; e = tv
+end subroutine dswpvv
+!=============================================================================
+subroutine cswpvv(d,e)! [swpvv]
+!=============================================================================
+complex(dpc),intent(inout) :: d(:), e(:)
+complex(dpc) :: tv(size(d))
+!=============================================================================
+tv = d; d = e; e = tv
+end subroutine cswpvv
+
+!=============================================================================
+subroutine sinvmt(a)! [inv]
+!=============================================================================
+real(sp),dimension(:,:),intent(INOUT):: a
+logical :: ff
+call sinvmtf(a,ff)
+if(ff)stop 'In sinvmt; Unable to invert matrix'
+end subroutine sinvmt
+!=============================================================================
+subroutine dinvmt(a)! [inv]
+!=============================================================================
+real(dp),dimension(:,:),intent(inout):: a
+logical :: ff
+call dinvmtf(a,ff)
+if(ff)stop 'In dinvmt; Unable to invert matrix'
+end subroutine dinvmt
+!=============================================================================
+subroutine cinvmt(a)! [inv]
+!=============================================================================
+complex(dpc),dimension(:,:),intent(inout):: a
+logical :: ff
+call cinvmtf(a,ff)
+if(ff)stop 'In cinvmt; Unable to invert matrix'
+end subroutine cinvmt
+!=============================================================================
+subroutine sinvmtf(a,ff)! [inv]
+!=============================================================================
+! Invert matrix (or flag if can't)
+!----------------
+real(sp),dimension(:,:),intent(inout):: a
+logical, intent( out):: ff
+integer :: m,i,j,jp,l
+real(sp) :: d
+integer,dimension(size(a,1)) :: ipiv
+!=============================================================================
+m=size(a,1)
+if(m /= size(a,2))stop 'In sinvmtf; matrix passed to sinvmtf is not square'
+! Perform a pivoted L-D-U decomposition on matrix a:
+call sldumf(a,ipiv,d,ff)
+if(ff)then
+ print '(" In sinvmtf; failed call to sldumf")'
+ return
+endif
+
+! Invert upper triangular portion U in place:
+do i=1,m; a(i,i)=1./a(i,i); enddo
+do i=1,m-1
+ do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo
+enddo
+
+! Invert lower triangular portion L in place:
+do j=1,m-1; jp=j+1
+ do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo
+enddo
+
+! Form the product of U**-1 and L**-1 in place
+do j=1,m-1; jp=j+1
+ do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo
+ do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo
+enddo
+
+! Permute columns according to ipiv
+do j=m-1,1,-1; l=ipiv(j); call sswpvv(a(:,j),a(:,l)); enddo
+end subroutine sinvmtf
+!=============================================================================
+subroutine dinvmtf(a,ff)! [inv]
+!=============================================================================
+real(DP),dimension(:,:),intent(INOUT):: a
+logical, intent( OUT):: ff
+integer :: m,i,j,jp,l
+real(DP) :: d
+integer, dimension(size(a,1)) :: ipiv
+!=============================================================================
+m=size(a,1)
+if(m /= size(a,2))stop 'In inv; matrix passed to dinvmtf is not square'
+! Perform a pivoted L-D-U decomposition on matrix a:
+call dldumf(a,ipiv,d,ff)
+if(ff)then
+ print '(" In dinvmtf; failed call to dldumf")'
+ return
+endif
+
+! Invert upper triangular portion U in place:
+do i=1,m; a(i,i)=1/a(i,i); enddo
+do i=1,m-1
+ do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo
+enddo
+
+! Invert lower triangular portion L in place:
+do j=1,m-1; jp=j+1
+ do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo
+enddo
+
+! Form the product of U**-1 and L**-1 in place
+do j=1,m-1; jp=j+1
+ do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo
+ do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo
+enddo
+
+! Permute columns according to ipiv
+do j=m-1,1,-1; l=ipiv(j); call dswpvv(a(:,j),a(:,l)); enddo
+end subroutine dinvmtf
+!=============================================================================
+subroutine cinvmtf(a,ff)! [inv]
+!=============================================================================
+complex(dpc),dimension(:,:),intent(INOUT):: a
+logical, intent( OUT):: ff
+integer :: m,i,j,jp,l
+complex(dpc) :: d
+integer, dimension(size(a,1)) :: ipiv
+!=============================================================================
+m=size(a,1)
+if(m /= size(a,2))stop 'In inv; matrix passed to cinvmtf is not square'
+! Perform a pivoted L-D-U decomposition on matrix a:
+call cldumf(a,ipiv,d,ff)
+if(ff)then
+ print '(" In cinvmtf; failed call to cldumf")'
+ return
+endif
+
+! Invert upper triangular portion U in place:
+do i=1,m; a(i,i)=1/a(i,i); enddo
+do i=1,m-1
+ do j=i+1,m; a(i,j)=-a(j,j)*sum(a(i:j-1,j)*a(i,i:j-1)); enddo
+enddo
+
+! Invert lower triangular portion L in place:
+do j=1,m-1; jp=j+1
+ do i=jp,m; a(i,j)=-a(i,j)-sum(a(jp:i-1,j)*a(i,jp:i-1)); enddo
+enddo
+
+! Form the product of U**-1 and L**-1 in place
+do j=1,m-1; jp=j+1
+ do i=1,j; a(i,j)=a(i,j)+sum(a(jp:m,j)*a(i,jp:m)); enddo
+ do i=jp,m; a(i,j)=sum(a(i:m,j)*a(i,i:m)); enddo
+enddo
+
+! Permute columns according to ipiv
+do j=m-1,1,-1; l=ipiv(j); call cswpvv(a(:,j),a(:,l)); enddo
+end subroutine cinvmtf
+
+!=============================================================================
+subroutine slinmmt(a,b)! [inv]
+!=============================================================================
+real(sp),dimension(:,:),intent(inout):: a,b
+logical :: ff
+call slinmmtf(a,b,ff)
+if(ff)stop 'In slinmmt; unable to invert linear system'
+end subroutine slinmmt
+!=============================================================================
+subroutine dlinmmt(a,b)! [inv]
+!=============================================================================
+real(dp),dimension(:,:),intent(inout):: a,b
+logical :: ff
+call dlinmmtf(a,b,ff)
+if(ff)stop 'In dlinmmt; unable to invert linear system'
+end subroutine dlinmmt
+!=============================================================================
+subroutine clinmmt(a,b)! [inv]
+!=============================================================================
+complex(dpc),dimension(:,:),intent(inout):: a,b
+logical :: ff
+call clinmmtf(a,b,ff)
+if(ff)stop 'In clinmmt; unable to invert linear system'
+end subroutine clinmmt
+!=============================================================================
+subroutine slinmmtf(a,b,ff)! [inv]
+!=============================================================================
+real(SP), dimension(:,:),intent(INOUT):: a,b
+logical, intent( OUT):: ff
+integer,dimension(size(a,1)) :: ipiv
+integer :: m
+real(sp) :: d
+!=============================================================================
+m=size(a,1)
+if(m /= size(a,2))stop 'In inv; matrix passed to slinmmtf is not square'
+if(m /= size(b,1))&
+ stop 'In inv; matrix and vectors in slinmmtf have unmatched sizes'
+call sldumf(a,ipiv,d,ff)
+if(ff)then
+ print '("In slinmmtf; failed call to sldumf")'
+ return
+endif
+call sudlmm(a,b,ipiv)
+end subroutine slinmmtf
+!=============================================================================
+subroutine dlinmmtf(a,b,ff)! [inv]
+!=============================================================================
+real(dp),dimension(:,:), intent(inout):: a,b
+logical, intent( out):: ff
+integer, dimension(size(a,1)) :: ipiv
+integer :: m
+real(dp) :: d
+!=============================================================================
+m=size(a,1)
+if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square'
+if(m /= size(b,1))&
+ stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes'
+call dldumf(a,ipiv,d,ff)
+if(ff)then
+ print '("In dlinmmtf; failed call to dldumf")'
+ return
+endif
+call dudlmm(a,b,ipiv)
+end subroutine dlinmmtf
+!=============================================================================
+subroutine clinmmtf(a,b,ff)! [inv]
+!=============================================================================
+complex(dpc),dimension(:,:),intent(INOUT):: a,b
+logical, intent( OUT):: ff
+integer, dimension(size(a,1)) :: ipiv
+integer :: m
+complex(dpc) :: d
+!=============================================================================
+m=size(a,1)
+if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square'
+if(m /= size(b,1))&
+ stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes'
+call cldumf(a,ipiv,d,ff)
+if(ff)then
+ print '("In clinmmtf; failed call to cldumf")'
+ return
+endif
+call cudlmm(a,b,ipiv)
+end subroutine clinmmtf
+
+!=============================================================================
+subroutine slinmvt(a,b)! [inv]
+!=============================================================================
+real(sp), dimension(:,:),intent(inout):: a
+real(sp), dimension(:), intent(inout):: b
+logical :: ff
+call slinmvtf(a,b,ff)
+if(ff)stop 'In slinmvt; matrix singular, unable to continue'
+end subroutine slinmvt
+!=============================================================================
+subroutine dlinmvt(a,b)! [inv]
+!=============================================================================
+real(dp), dimension(:,:),intent(inout):: a
+real(dp), dimension(:), intent(inout):: b
+logical :: ff
+call dlinmvtf(a,b,ff)
+if(ff)stop 'In dlinmvt; matrix singular, unable to continue'
+end subroutine dlinmvt
+!=============================================================================
+subroutine clinmvt(a,b)! [inv]
+!=============================================================================
+complex(dpc), dimension(:,:),intent(inout):: a
+complex(dpc), dimension(:), intent(inout):: b
+logical :: ff
+call clinmvtf(a,b,ff)
+if(ff)stop 'In clinmvt; matrix singular, unable to continue'
+end subroutine clinmvt
+!=============================================================================
+subroutine slinmvtf(a,b,ff)! [inv]
+!=============================================================================
+real(sp),dimension(:,:),intent(inout):: a
+real(sp),dimension(:), intent(inout):: b
+logical, intent( out):: ff
+integer,dimension(size(a,1)) :: ipiv
+real(sp) :: d
+!=============================================================================
+if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))&
+ stop 'In inv; In slinmvtf; incompatible array dimensions'
+call sldumf(a,ipiv,d,ff)
+if(ff)then
+ print '("In slinmvtf; failed call to sldumf")'
+ return
+endif
+call sudlmv(a,b,ipiv)
+end subroutine slinmvtf
+!=============================================================================
+subroutine dlinmvtf(a,b,ff)! [inv]
+!=============================================================================
+real(dp),dimension(:,:),intent(inout):: a
+real(dp),dimension(:), intent(inout):: b
+logical, intent( out):: ff
+integer, dimension(size(a,1)) :: ipiv
+real(dp) :: d
+!=============================================================================
+if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))&
+ stop 'In inv; incompatible array dimensions passed to dlinmvtf'
+call dldumf(a,ipiv,d,ff)
+if(ff)then
+ print '("In dlinmvtf; failed call to dldumf")'
+ return
+endif
+call dudlmv(a,b,ipiv)
+end subroutine dlinmvtf
+!=============================================================================
+subroutine clinmvtf(a,b,ff)! [inv]
+!=============================================================================
+complex(dpc),dimension(:,:),intent(inout):: a
+complex(dpc),dimension(:), intent(inout):: b
+logical, intent( out):: ff
+integer, dimension(size(a,1)) :: ipiv
+complex(dpc) :: d
+!=============================================================================
+if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))&
+ stop 'In inv; incompatible array dimensions passed to clinmvtf'
+call cldumf(a,ipiv,d,ff)
+if(ff)then
+ print '("In clinmvtf; failed call to cldumf")'
+ return
+endif
+call cudlmv(a,b,ipiv)
+end subroutine clinmvtf
+
+!=============================================================================
+subroutine iinvf(imat,ff)! [inv]
+!=============================================================================
+! Invert integer square array, imat, if possible, but flag ff=.true.
+! if not possible. (Determinant of imat must be +1 or -1
+!=============================================================================
+integer,dimension(:,:),intent(INOUT):: imat
+logical, intent( OUT):: ff
+!-----------------------------------------------------------------------------
+real(dp),parameter :: eps=1.e-10_dp
+real(dp),dimension(size(imat,1),size(imat,1)):: dmat
+integer :: m,i,j
+!=============================================================================
+m=size(imat,1)
+if(m /= size(imat,2))stop 'In inv; matrix passed to iinvf is not square'
+dmat=imat; call inv(dmat,ff)
+if(.not.ff)then
+ do j=1,m
+ do i=1,m
+ imat(i,j)=nint(dmat(i,j)); if(abs(dmat(i,j)-imat(i,j))>eps)ff=t
+ enddo
+ enddo
+endif
+end subroutine iinvf
+
+!=============================================================================
+subroutine sldum(a,ipiv,d)! [ldum]
+!=============================================================================
+real(sp),intent(inout) :: a(:,:)
+real(sp),intent(out ) :: d
+integer, intent(out ) :: ipiv(:)
+logical :: ff
+call sldumf(a,ipiv,d,ff)
+if(ff)stop 'In sldum; matrix singular, unable to continue'
+end subroutine sldum
+!=============================================================================
+subroutine dldum(a,ipiv,d)! [ldum]
+!=============================================================================
+real(dp),intent(inout) :: a(:,:)
+real(dp),intent(out ) :: d
+integer, intent(out ) :: ipiv(:)
+logical:: ff
+call dldumf(a,ipiv,d,ff)
+if(ff)stop 'In dldum; matrix singular, unable to continue'
+end subroutine dldum
+!=============================================================================
+subroutine cldum(a,ipiv,d)! [ldum]
+!=============================================================================
+complex(dpc),intent(inout) :: a(:,:)
+complex(dpc),intent(out ) :: d
+integer, intent(out ) :: ipiv(:)
+logical:: ff
+call cldumf(a,ipiv,d,ff)
+if(ff)stop 'In cldum; matrix singular, unable to continue'
+end subroutine cldum
+!=============================================================================
+subroutine sldumf(a,ipiv,d,ff)! [ldum]
+!=============================================================================
+! R.J.Purser, NCEP, Washington D.C. 1996
+! SUBROUTINE LDUM
+! perform l-d-u decomposition of square matrix a in place with
+! pivoting.
+!
+! <-> a square matrix to be factorized
+! <-- ipiv array encoding the pivoting sequence
+! <-- d indicator for possible sign change of determinant
+! <-- ff: failure flag, set to .true. when determinant of a vanishes.
+!=============================================================================
+real(SP),intent(INOUT) :: a(:,:)
+real(SP),intent(OUT ) :: d
+integer, intent(OUT ) :: ipiv(:)
+logical, intent(OUT ) :: ff
+integer :: m,i, j, jp, ibig, jm
+real(SP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij
+!=============================================================================
+ff=f
+m=size(a,1)
+do i=1,m
+ aam=0
+ do j=1,m
+ aa=abs(a(i,j))
+ if(aa > aam)aam=aa
+ enddo
+ if(aam == 0)then
+ print '("In sldumf; row ",i6," of matrix vanishes")',i
+ ff=t
+ return
+ endif
+ s(i)=1/aam
+enddo
+d=1.
+ipiv(m)=m
+do j=1,m-1
+ jp=j+1
+ abig=s(j)*abs(a(j,j))
+ ibig=j
+ do i=jp,m
+ aa=s(i)*abs(a(i,j))
+ if(aa > abig)then
+ ibig=i
+ abig=aa
+ endif
+ enddo
+! swap rows, recording changed sign of determinant
+ ipiv(j)=ibig
+ if(ibig /= j)then
+ d=-d
+ call sswpvv(a(j,:),a(ibig,:))
+ s(ibig)=s(j)
+ endif
+ ajj=a(j,j)
+ if(ajj == 0)then
+ jm=j-1
+ print '(" failure in sldumf:"/" matrix singular, rank=",i3)',jm
+ ff=t
+ return
+ endif
+ ajji=1/ajj
+ do i=jp,m
+ aij=ajji*a(i,j)
+ a(i,j)=aij
+ a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m)
+ enddo
+enddo
+end subroutine sldumf
+!=============================================================================
+subroutine DLDUMf(A,IPIV,D,ff)! [ldum]
+!=============================================================================
+real(DP), intent(INOUT) :: a(:,:)
+real(DP), intent(OUT ) :: d
+integer, intent(OUT ) :: ipiv(:)
+logical, intent(OUT ) :: ff
+integer :: m,i, j, jp, ibig, jm
+real(DP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij
+!=============================================================================
+ff=f
+m=size(a,1)
+do i=1,m
+ aam=0
+ do j=1,m
+ aa=abs(a(i,j))
+ if(aa > aam)aam=aa
+ enddo
+ if(aam == 0)then
+ print '("In dldumf; row ",i6," of matrix vanishes")',i
+ ff=t
+ return
+ endif
+ s(i)=1/aam
+enddo
+d=1.
+ipiv(m)=m
+do j=1,m-1
+ jp=j+1
+ abig=s(j)*abs(a(j,j))
+ ibig=j
+ do i=jp,m
+ aa=s(i)*abs(a(i,j))
+ if(aa > abig)then
+ ibig=i
+ abig=aa
+ endif
+ enddo
+! swap rows, recording changed sign of determinant
+ ipiv(j)=ibig
+ if(ibig /= j)then
+ d=-d
+ call dswpvv(a(j,:),a(ibig,:))
+ s(ibig)=s(j)
+ endif
+ ajj=a(j,j)
+ if(ajj == 0)then
+ jm=j-1
+ print '(" Failure in dldumf:"/" matrix singular, rank=",i3)',jm
+ ff=t
+ return
+ endif
+ ajji=1/ajj
+ do i=jp,m
+ aij=ajji*a(i,j)
+ a(i,j)=aij
+ a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m)
+ enddo
+enddo
+end subroutine DLDUMf
+!=============================================================================
+subroutine cldumf(a,ipiv,d,ff)! [ldum]
+!=============================================================================
+use jp_pietc, only: c0
+complex(dpc), intent(INOUT) :: a(:,:)
+complex(dpc), intent(OUT ) :: d
+integer, intent(OUT ) :: ipiv(:)
+logical, intent(OUT ) :: ff
+integer :: m,i, j, jp, ibig, jm
+complex(dpc) :: ajj, ajji, aij
+real(dp) :: aam,aa,abig
+real(dp),dimension(size(a,1)):: s
+!=============================================================================
+ff=f
+m=size(a,1)
+do i=1,m
+ aam=0
+ do j=1,m
+ aa=abs(a(i,j))
+ if(aa > aam)aam=aa
+ enddo
+ if(aam == 0)then
+ print '("In cldumf; row ",i6," of matrix vanishes")',i
+ ff=t
+ return
+ endif
+ s(i)=1/aam
+enddo
+d=1.
+ipiv(m)=m
+do j=1,m-1
+ jp=j+1
+ abig=s(j)*abs(a(j,j))
+ ibig=j
+ do i=jp,m
+ aa=s(i)*abs(a(i,j))
+ if(aa > abig)then
+ ibig=i
+ abig=aa
+ endif
+ enddo
+! swap rows, recording changed sign of determinant
+ ipiv(j)=ibig
+ if(ibig /= j)then
+ d=-d
+ call cswpvv(a(j,:),a(ibig,:))
+ s(ibig)=s(j)
+ endif
+ ajj=a(j,j)
+ if(ajj == c0)then
+ jm=j-1
+ print '(" Failure in cldumf:"/" matrix singular, rank=",i3)',jm
+ ff=t
+ return
+ endif
+ ajji=1/ajj
+ do i=jp,m
+ aij=ajji*a(i,j)
+ a(i,j)=aij
+ a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m)
+ enddo
+enddo
+end subroutine cldumf
+
+!=============================================================================
+subroutine sudlmm(a,b,ipiv)! [udlmm]
+!=============================================================================
+! R.J.Purser, National Meteorological Center, Washington D.C. 1993
+! SUBROUTINE UDLMM
+! use l-u factors in A to back-substitute for several rhs in B, using ipiv to
+! define the pivoting permutation used in the l-u decomposition.
+!
+! --> A L-D-U factorization of linear system matrux
+! <-> B rt-hand-sides vectors on input, corresponding solutions on return
+! --> IPIV array encoding the pivoting sequence
+!=============================================================================
+integer, dimension(:), intent(in) :: ipiv
+real(sp),dimension(:,:),intent(in) :: a
+real(sp),dimension(:,:),intent(inout) :: b
+integer :: m,i, k, l
+real(sp) :: s,aiii
+!=============================================================================
+m=size(a,1)
+do k=1,size(b,2) !loop over columns of b
+ do i=1,m
+ l=ipiv(i)
+ s=b(l,k)
+ b(l,k)=b(i,k)
+ s = s - sum(b(1:i-1,k)*a(i,1:i-1))
+ b(i,k)=s
+ enddo
+ b(m,k)=b(m,k)/a(m,m)
+ do i=m-1,1,-1
+ aiii=1/a(i,i)
+ b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m))
+ b(i,k)=b(i,k)*aiii
+ enddo
+enddo
+end subroutine sudlmm
+!=============================================================================
+subroutine dudlmm(a,b,ipiv)! [udlmm]
+!=============================================================================
+integer, dimension(:), intent(in ) :: ipiv
+real(dp), dimension(:,:),intent(in ) :: a
+real(dp), dimension(:,:),intent(inout) :: b
+integer :: m,i, k, l
+real(dp) :: s,aiii
+!=============================================================================
+m=size(a,1)
+do k=1, size(b,2)!loop over columns of b
+ do i=1,m
+ l=ipiv(i)
+ s=b(l,k)
+ b(l,k)=b(i,k)
+ s = s - sum(b(1:i-1,k)*a(i,1:i-1))
+ b(i,k)=s
+ enddo
+ b(m,k)=b(m,k)/a(m,m)
+ do i=m-1,1,-1
+ aiii=1/a(i,i)
+ b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m))
+ b(i,k)=b(i,k)*aiii
+ enddo
+enddo
+end subroutine dudlmm
+!=============================================================================
+subroutine cudlmm(a,b,ipiv)! [udlmm]
+!=============================================================================
+integer, dimension(:), intent(in ) :: ipiv
+complex(dpc),dimension(:,:),intent(in ) :: a
+complex(dpc),dimension(:,:),intent(inout) :: b
+integer :: m,i, k, l
+complex(dpc) :: s,aiii
+!=============================================================================
+m=size(a,1)
+do k=1, size(b,2)!loop over columns of b
+ do i=1,m
+ l=ipiv(i)
+ s=b(l,k)
+ b(l,k)=b(i,k)
+ s = s - sum(b(1:i-1,k)*a(i,1:i-1))
+ b(i,k)=s
+ enddo
+ b(m,k)=b(m,k)/a(m,m)
+ do i=m-1,1,-1
+ aiii=1/a(i,i)
+ b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m))
+ b(i,k)=b(i,k)*aiii
+ enddo
+enddo
+end subroutine cudlmm
+
+!=============================================================================
+subroutine sudlmv(a,b,ipiv)! [udlmv]
+!=============================================================================
+! R.J.Purser, National Meteorological Center, Washington D.C. 1993
+! SUBROUTINE UDLMV
+! use l-u factors in A to back-substitute for 1 rhs in B, using ipiv to
+! define the pivoting permutation used in the l-u decomposition.
+!
+! --> A L-D-U factorization of linear system matrix
+! <-> B right-hand-side vector on input, corresponding solution on return
+! --> IPIV array encoding the pivoting sequence
+!=============================================================================
+integer, dimension(:), intent(in) :: ipiv
+real(sp),dimension(:,:),intent(in) :: a
+real(sp),dimension(:), intent(inout) :: b
+integer :: m,i, l
+real(sp) :: s,aiii
+!=============================================================================
+m=size(a,1)
+do i=1,m
+ l=ipiv(i)
+ s=b(l)
+ b(l)=b(i)
+ s = s - sum(b(1:i-1)*a(i,1:i-1))
+ b(i)=s
+enddo
+b(m)=b(m)/a(m,m)
+do i=m-1,1,-1
+ aiii=1/a(i,i)
+ b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m))
+ b(i)=b(i)*aiii
+enddo
+end subroutine sudlmv
+!=============================================================================
+subroutine dudlmv(a,b,ipiv)! [udlmv]
+!=============================================================================
+integer, dimension(:), intent(in ) :: ipiv(:)
+real(dp), dimension(:,:),intent(in ) :: a(:,:)
+real(dp), dimension(:), intent(inout) :: b(:)
+integer :: m,i, l
+real(dp) :: s,aiii
+!=============================================================================
+m=size(a,1)
+do i=1,m
+ l=ipiv(i)
+ s=b(l)
+ b(l)=b(i)
+ s = s - sum(b(1:i-1)*a(i,1:i-1))
+ b(i)=s
+enddo
+b(m)=b(m)/a(m,m)
+do i=m-1,1,-1
+ aiii=1/a(i,i)
+ b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m))
+ b(i)=b(i)*aiii
+enddo
+end subroutine dudlmv
+!=============================================================================
+subroutine cudlmv(a,b,ipiv)! [udlmv]
+!=============================================================================
+integer, dimension(:), intent(in ) :: ipiv(:)
+complex(dpc),dimension(:,:),intent(in ) :: a(:,:)
+complex(dpc),dimension(:), intent(inout) :: b(:)
+integer :: m,i, l
+complex(dpc) :: s,aiii
+!=============================================================================
+m=size(a,1)
+do i=1,m
+ l=ipiv(i)
+ s=b(l)
+ b(l)=b(i)
+ s = s - sum(b(1:i-1)*a(i,1:i-1))
+ b(i)=s
+enddo
+b(m)=b(m)/a(m,m)
+do i=m-1,1,-1
+ aiii=1/a(i,i)
+ b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m))
+ b(i)=b(i)*aiii
+enddo
+end subroutine cudlmv
+
+!=============================================================================
+subroutine sl1lm(a,b) ! [l1lm]
+!=============================================================================
+! Cholesky, M -> L*U, U(i,j)=L(j,i)
+!=============================================================================
+real(sp), intent(in ) :: a(:,:)
+real(sp), intent(inout) :: b(:,:)
+!-----------------------------------------------------------------------------
+logical:: ff
+call sl1lmf(a,b,ff)
+if(ff)stop 'In sl1lm; matrix singular, unable to continue'
+end subroutine sl1lm
+!=============================================================================
+subroutine dl1lm(a,b) ! [l1lm]
+!=============================================================================
+! Cholesky, M -> L*U, U(i,j)=L(j,i)
+!=============================================================================
+real(dp), intent(in ) :: a(:,:)
+real(dp), intent(inout) :: b(:,:)
+!-----------------------------------------------------------------------------
+logical:: ff
+call dl1lmf(a,b,ff)
+if(ff)stop 'In dl1lm; matrix singular, unable to continue'
+end subroutine dl1lm
+
+!=============================================================================
+subroutine sl1lmf(a,b,ff)! [L1Lm]
+!=============================================================================
+! Cholesky, M -> L*U, U(i,j)=L(j,i)
+!=============================================================================
+real(sp), intent(IN ) :: a(:,:)
+real(sp), intent(INOUT) :: b(:,:)
+logical :: ff
+!-----------------------------------------------------------------------------
+integer :: m,j, jm, jp, i
+real(sp) :: s, bjji
+!=============================================================================
+m=size(a,1)
+ff=f
+do j=1,m
+ jm=j-1
+ jp=j+1
+ s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm))
+ ff=(S <= 0)
+ if(ff)then
+ print '("sL1Lmf detects nonpositive a, rank=",i6)',jm
+ return
+ endif
+ b(j,j)=sqrt(s)
+ bjji=1/b(j,j)
+ do i=jp,m
+ s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm))
+ b(i,j)=s*bjji
+ enddo
+ b(1:jm,j) = 0
+enddo
+end subroutine sl1lmf
+!=============================================================================
+subroutine dl1lmf(a,b,ff) ! [L1Lm]
+!=============================================================================
+real(dp), intent(IN ) :: a(:,:)
+real(dp), intent(INOUT) :: b(:,:)
+logical :: ff
+!-----------------------------------------------------------------------------
+integer :: m,j, jm, jp, i
+real(dp) :: s, bjji
+!=============================================================================
+m=size(a,1)
+ff=f
+do j=1,m
+ jm=j-1
+ jp=j+1
+ s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm))
+ ff=(s <= 0)
+ if(ff)then
+ print '("dL1LMF detects nonpositive A, rank=",i6)',jm
+ return
+ endif
+ b(j,j)=sqrt(s)
+ bjji=1/b(j,j)
+ do i=jp,m
+ s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm))
+ b(i,j)=s*bjji
+ enddo
+ b(1:jm,j) = 0
+enddo
+return
+end subroutine dl1lmf
+
+!=============================================================================
+subroutine sldlm(a,b,d)! [LdLm]
+!=============================================================================
+! Modified Cholesky decompose Q --> L*D*U, U(i,j)=L(j,i)
+!=============================================================================
+real(sp), intent(IN ):: a(:,:)
+real(sp), intent(INOUT):: b(:,:)
+real(sp), intent( OUT):: d(:)
+!-----------------------------------------------------------------------------
+logical:: ff
+call sldlmf(a,b,d,ff)
+if(ff)stop 'In sldlm; matrix singular, unable to continue'
+end subroutine sldlm
+!=============================================================================
+subroutine dldlm(a,b,d)! [LdLm]
+!=============================================================================
+real(dp), intent(IN ):: a(:,:)
+real(dp), intent(INOUT):: b(:,:)
+real(dp), intent( OUT):: d(:)
+!-----------------------------------------------------------------------------
+logical:: ff
+call dldlmf(a,b,d,ff)
+if(ff)stop 'In dldlm; matrix singular, unable to continue'
+end subroutine dldlm
+
+!=============================================================================
+subroutine sldlmf(a,b,d,ff) ! [LDLM]
+!=============================================================================
+! Modified Cholesky decompose Q --> L*D*U
+!=============================================================================
+real(sp), intent(IN ):: a(:,:)
+real(sp), intent(INOUT):: b(:,:)
+real(sp), intent( OUT):: d(:)
+logical, intent( OUT):: ff
+!-----------------------------------------------------------------------------
+integer :: m,j, jm, jp, i
+real(sp) :: bjji
+!=============================================================================
+m=size(a,1)
+ff=f
+do j=1,m
+ jm=j-1
+ jp=j+1
+ d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm))
+ b(j,j) = 1
+ ff=(d(j) == 0)
+ if(ff)then
+ print '("In sldlmf; singularity of matrix detected")'
+ print '("Rank of matrix: ",i6)',jm
+ return
+ endif
+ bjji=1/d(j)
+ do i=jp,m
+ b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm))
+ b(i,j)=b(j,i)*bjji
+ enddo
+ b(1:jm,j)=0
+enddo
+end subroutine sldlmf
+!=============================================================================
+subroutine dldlmf(a,b,d,ff) ! [LDLM]
+!=============================================================================
+! Modified Cholesky Q --> L*D*U, U(i,j)=L(j,i)
+!=============================================================================
+real(dp), intent(IN ) :: a(:,:)
+real(dp), intent(INOUT) :: b(:,:)
+real(dp), intent( OUT) :: d(:)
+logical, intent( OUT) :: ff
+!-----------------------------------------------------------------------------
+integer :: m,j, jm, jp, i
+real(dp) :: bjji
+!=============================================================================
+m=size(a,1)
+ff=f
+do j=1,m; jm=j-1; jp=j+1
+ d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm))
+ b(j,j) = 1
+ ff=(d(j) == 0)
+ if(ff)then
+ print '("In dldlmf; singularity of matrix detected")'
+ print '("Rank of matrix: ",i6)',jm
+ return
+ endif
+ bjji=1/d(j)
+ do i=jp,m
+ b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm))
+ b(i,j)=b(j,i)*bjji
+ enddo
+ b(1:jm,j)=0
+enddo
+end subroutine dldlmf
+
+!==============================================================================
+subroutine sinvu(a)! [invu]
+!==============================================================================
+! Invert the upper triangular matrix in place by transposing, calling
+! invl, and transposing again.
+!==============================================================================
+real,dimension(:,:),intent(inout):: a
+a=transpose(a); call sinvl(a); a=transpose(a)
+end subroutine sinvu
+!==============================================================================
+subroutine dinvu(a)! [invu]
+!==============================================================================
+real(dp),dimension(:,:),intent(inout):: a
+a=transpose(a); call dinvl(a); a=transpose(a)
+end subroutine dinvu
+!==============================================================================
+subroutine sinvl(a)! [invl]
+!==============================================================================
+! Invert lower triangular matrix in place
+!==============================================================================
+real(sp), intent(inout) :: a(:,:)
+integer :: m,j, i
+m=size(a,1)
+do j=m,1,-1
+ a(1:j-1,j) = 0.0
+ a(j,j)=1./a(j,j)
+ do i=j+1,m
+ a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1))
+ enddo
+enddo
+end subroutine sinvl
+!==============================================================================
+subroutine dinvl(a)! [invl]
+!==============================================================================
+real(dp), intent(inout) :: a(:,:)
+integer :: m,j, i
+m=size(a,1)
+do j=m,1,-1
+ a(1:j-1,j) = 0.0
+ a(j,j)=1./a(j,j)
+ do i=j+1,m
+ a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1))
+ enddo
+enddo
+end subroutine dinvl
+
+!==============================================================================
+subroutine slinlv(a,u)! [invl]
+!==============================================================================
+! Solve linear system involving lower triangular system matrix.
+!==============================================================================
+real, intent(in ) :: a(:,:)
+real, intent(inout) :: u(:)
+integer :: i
+if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))&
+ stop 'In slinlv; incompatible array dimensions'
+do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo
+end subroutine slinlv
+!==============================================================================
+subroutine dlinlv(a,u)! [invl]
+!==============================================================================
+real(dp), intent(in ) :: a(:,:)
+real(dp), intent(inout) :: u(:)
+integer :: i
+if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))&
+ stop 'In dlinlv; incompatible array dimensions'
+do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo
+end subroutine dlinlv
+
+!==============================================================================
+subroutine slinuv(a,u)! [invu]
+!==============================================================================
+! Solve linear system involving upper triangular system matrix.
+!==============================================================================
+real, intent(in ) :: a(:,:)
+real, intent(inout) :: u(:)
+integer :: i
+if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))&
+ stop 'In linuv; incompatible array dimensions'
+do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo
+end subroutine slinuv
+!==============================================================================
+subroutine dlinuv(a,u)! [invu]
+!==============================================================================
+real(dp), intent(in ) :: a(:,:)
+real(dp), intent(inout) :: u(:)
+integer :: i
+if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))&
+ stop 'In dlinuv; incompatible array dimensions'
+do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo
+end subroutine dlinuv
+
+end module jp_pmat
+
diff --git a/src/mgbf/jp_pmat4.f90 b/src/mgbf/jp_pmat4.f90
new file mode 100644
index 0000000000..552d5efdeb
--- /dev/null
+++ b/src/mgbf/jp_pmat4.f90
@@ -0,0 +1,2086 @@
+module jp_pmat4
+!$$$ module documentation block
+! . . . .
+! module: jp_pmat4
+! prgmmr: purser org: NOAA/EMC date: 2005-10
+!
+! abstract: Euclidean geometry, geometric (stereographic) projections,
+! related transformations (Mobius)
+!
+! module history log:
+! 2012-05-18 purser
+! 2017-05 purser - Added routines to facilitate manipulation of 3D
+! rotations, their representations by axial vectors,
+! and routines to compute the exponentials of matrices
+! (without resort to eigen methods).
+! Also added Quaternion and spinor representations
+! of 3D rotations, and their conversion routines.
+!
+! Subroutines Included:
+! gram - Right-handed orthogonal basis and rank, nrank. The first
+! nrank basis vectors span the column range of matrix given,
+! OR ("plain" version) simple unpivoted Gram-Schmidt of a
+! square matrix.
+!
+! In addition, we include routines that relate to
+! stereographic projections and some associated mobius
+! transformation utilities, since these complex operations
+! have a strong geometrical flavor.
+! dlltoxy -
+! normalize -
+! rowops -
+! corral -
+! rottoax -
+! axtorot -
+! spintoq -
+! qtospin -
+! rottoq -
+! qtorot -
+! axtoq -
+! qtoax -
+! setem -
+! expmat -
+! zntay -
+! znfun -
+! ctoz -
+! ztoc -
+! setmobius -
+! mobius -
+! mobiusi -
+!
+! Functions Included:
+! absv - Absolute magnitude of vector as its euclidean length
+! normalized - Normalized version of given real vector
+! orthogonalized - Orthogonalized version of second vector rel. to first unit v.
+! cross_product - Vector cross-product of the given 2 vectors
+! outer_product - outer-product matrix of the given 2 vectors
+! triple_product - Scalar triple product of given 3 vectors
+! det - Determinant of given matrix
+! axial - Convert axial-vector <--> 2-form (antisymmetric matrix)
+! diag - Diagnl of given matrix, or diagonal matrix of given elements
+! trace - Trace of given matrix
+! identity - Identity 3*3 matrix, or identity n*n matrix for a given n
+! sarea - Spherical area subtended by three vectors, or by lat-lon
+! increments forming a triangle or quadrilateral
+! huarea - Spherical area subtended by right-angled spherical triangle
+! hav -
+! mulqq -
+!
+! remarks:
+! Package for handy vector and matrix operations in Euclidean geometry.
+! This package is primarily intended for 3D operations and three of the
+! functions (Cross_product, Triple_product and Axial) do not possess simple
+! generalizations to a generic number N of dimensions. The others, while
+! admitting such N-dimensional generalizations, have not all been provided
+! with such generic forms here at the time of writing, though some of these
+! may be added at a future date.
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+use jp_pkind, only: spi,sp,dp,dpc
+implicit none
+private
+public:: absv,normalized,orthogonalized, &
+ cross_product,outer_product,triple_product,det,axial, &
+ diag,trace,identity,sarea,huarea,dlltoxy, &
+ normalize,gram,rowops,corral, &
+ axtoq,qtoax, &
+ rottoax,axtorot,spintoq,qtospin,rottoq,qtorot,mulqq, &
+ expmat,zntay,znfun, &
+ ctoz,ztoc,setmobius, &
+ mobius,mobiusi
+
+interface absv; module procedure absv_s,absv_d; end interface
+interface normalized;module procedure normalized_s,normalized_d;end interface
+interface orthogonalized
+ module procedure orthogonalized_s,orthogonalized_d; end interface
+interface cross_product
+ module procedure cross_product_s,cross_product_d, &
+ triple_cross_product_s,triple_cross_product_d; end interface
+interface outer_product
+ module procedure outer_product_s,outer_product_d,outer_product_i
+ end interface
+interface triple_product
+ module procedure triple_product_s,triple_product_d; end interface
+interface det; module procedure det_s,det_d,det_i,det_id; end interface
+interface axial
+ module procedure axial3_s,axial3_d,axial33_s,axial33_d; end interface
+interface diag
+ module procedure diagn_s,diagn_d,diagn_i,diagnn_s,diagnn_d,diagnn_i
+ end interface
+interface trace; module procedure trace_s,trace_d,trace_i; end interface
+interface identity; module procedure identity_i,identity3_i; end interface
+interface huarea; module procedure huarea_s,huarea_d; end interface
+interface sarea
+ module procedure sarea_s,sarea_d,dtarea_s,dtarea_d,dqarea_s,dqarea_d
+ end interface
+interface dlltoxy; module procedure dlltoxy_s,dlltoxy_d; end interface
+interface hav; module procedure hav_s, hav_d; end interface
+interface normalize;module procedure normalize_s,normalize_d; end interface
+interface gram
+ module procedure gram_s,gram_d,graml_d,plaingram_s,plaingram_d,rowgram
+ end interface
+interface rowops; module procedure rowops; end interface
+interface corral; module procedure corral; end interface
+interface rottoax; module procedure rottoax; end interface
+interface axtorot; module procedure axtorot; end interface
+interface spintoq; module procedure spintoq; end interface
+interface qtospin; module procedure qtospin; end interface
+interface rottoq; module procedure rottoq; end interface
+interface qtorot; module procedure qtorot; end interface
+interface axtoq; module procedure axtoq; end interface
+interface qtoax; module procedure qtoax; end interface
+interface setem; module procedure setem; end interface
+interface mulqq; module procedure mulqq; end interface
+interface expmat; module procedure expmat,expmatd,expmatdd; end interface
+interface zntay; module procedure zntay; end interface
+interface znfun; module procedure znfun; end interface
+interface ctoz; module procedure ctoz; end interface
+interface ztoc; module procedure ztoc,ztocd; end interface
+interface setmobius;module procedure setmobius,zsetmobius; end interface
+interface mobius; module procedure zmobius,cmobius; end interface
+interface mobiusi; module procedure zmobiusi; end interface
+
+contains
+
+!=============================================================================
+function absv_s(a)result(s)! [absv]
+!=============================================================================
+implicit none
+real(sp),dimension(:),intent(in):: a
+real(sp) :: s
+s=sqrt(dot_product(a,a))
+end function absv_s
+!=============================================================================
+function absv_d(a)result(s)! [absv]
+!=============================================================================
+implicit none
+real(dp),dimension(:),intent(in):: a
+real(dp) :: s
+s=sqrt(dot_product(a,a))
+end function absv_d
+
+!=============================================================================
+function normalized_s(a)result(b)! [normalized]
+!=============================================================================
+use jp_pietc_s, only: u0
+implicit none
+real(sp),dimension(:),intent(IN):: a
+real(sp),dimension(size(a)) :: b
+real(sp) :: s
+s=absv_s(a); if(s==u0)then; b=u0;else;b=a/s;endif
+end function normalized_s
+!=============================================================================
+function normalized_d(a)result(b)! [normalized]
+!=============================================================================
+use jp_pietc, only: u0
+implicit none
+real(dp),dimension(:),intent(IN):: a
+real(dp),dimension(size(a)) :: b
+real(dp) :: s
+s=absv_d(a); if(s==u0)then; b=u0;else;b=a/s;endif
+end function normalized_d
+
+!=============================================================================
+function orthogonalized_s(u,a)result(b)! [orthogonalized]
+!=============================================================================
+implicit none
+real(sp),dimension(:),intent(in):: u,a
+real(sp),dimension(size(u)) :: b
+real(sp) :: s
+! Note: this routine assumes u is already normalized
+s=dot_product(u,a); b=a-u*s
+end function orthogonalized_s
+!=============================================================================
+function orthogonalized_d(u,a)result(b)! [orthogonalized]
+!=============================================================================
+implicit none
+real(dp),dimension(:),intent(in):: u,a
+real(dp),dimension(size(u)) :: b
+real(dp) :: s
+! Note: this routine assumes u is already normalized
+s=dot_product(u,a); b=a-u*s
+end function orthogonalized_d
+
+!=============================================================================
+function cross_product_s(a,b)result(c)! [cross_product]
+!=============================================================================
+implicit none
+real(sp),dimension(3),intent(in):: a,b
+real(sp),dimension(3) :: c
+c(1)=a(2)*b(3)-a(3)*b(2); c(2)=a(3)*b(1)-a(1)*b(3); c(3)=a(1)*b(2)-a(2)*b(1)
+end function cross_product_s
+!=============================================================================
+function cross_product_d(a,b)result(c)! [cross_product]
+!=============================================================================
+implicit none
+real(dp),dimension(3),intent(in):: a,b
+real(dp),dimension(3) :: c
+c(1)=a(2)*b(3)-a(3)*b(2); c(2)=a(3)*b(1)-a(1)*b(3); c(3)=a(1)*b(2)-a(2)*b(1)
+end function cross_product_d
+!=============================================================================
+function triple_cross_product_s(u,v,w)result(x)! [cross_product]
+!=============================================================================
+! Deliver the triple-cross-product, x, of the
+! three 4-vectors, u, v, w, with the sign convention
+! that ordered, {u,v,w,x} form a right-handed quartet
+! in the generic case (determinant >= 0).
+!=============================================================================
+implicit none
+real(sp),dimension(4),intent(in ):: u,v,w
+real(sp),dimension(4) :: x
+!-----------------------------------------------------------------------------
+real(sp):: uv12,uv13,uv14,uv23,uv24,uv34
+!=============================================================================
+uv12=u(1)*v(2)-u(2)*v(1); uv13=u(1)*v(3)-u(3)*v(1); uv14=u(1)*v(4)-u(4)*v(1)
+ uv23=u(2)*v(3)-u(3)*v(2); uv24=u(2)*v(4)-u(4)*v(2)
+ uv34=u(3)*v(4)-u(4)*v(3)
+x(1)=-uv23*w(4)+uv24*w(3)-uv34*w(2)
+x(2)= uv13*w(4)-uv14*w(3) +uv34*w(1)
+x(3)=-uv12*w(4) +uv14*w(2)-uv24*w(1)
+x(4)= uv12*w(3)-uv13*w(2)+uv23*w(1)
+end function triple_cross_product_s
+!=============================================================================
+function triple_cross_product_d(u,v,w)result(x)! [cross_product]
+!=============================================================================
+implicit none
+real(dp),dimension(4),intent(in ):: u,v,w
+real(dp),dimension(4) :: x
+!-----------------------------------------------------------------------------
+real(dp):: uv12,uv13,uv14,uv23,uv24,uv34
+!=============================================================================
+uv12=u(1)*v(2)-u(2)*v(1); uv13=u(1)*v(3)-u(3)*v(1); uv14=u(1)*v(4)-u(4)*v(1)
+ uv23=u(2)*v(3)-u(3)*v(2); uv24=u(2)*v(4)-u(4)*v(2)
+ uv34=u(3)*v(4)-u(4)*v(3)
+x(1)=-uv23*w(4)+uv24*w(3)-uv34*w(2)
+x(2)= uv13*w(4)-uv14*w(3) +uv34*w(1)
+x(3)=-uv12*w(4) +uv14*w(2)-uv24*w(1)
+x(4)= uv12*w(3)-uv13*w(2)+uv23*w(1)
+end function triple_cross_product_d
+
+!=============================================================================
+function outer_product_s(a,b)result(c)! [outer_product]
+!=============================================================================
+implicit none
+real(sp),dimension(:), intent(in ):: a
+real(sp),dimension(:), intent(in ):: b
+real(sp),DIMENSION(size(a),size(b)):: c
+integer(spi) :: nb,i
+nb=size(b)
+do i=1,nb; c(:,i)=a*b(i); enddo
+end function outer_product_s
+!=============================================================================
+function outer_product_d(a,b)result(c)! [outer_product]
+!=============================================================================
+implicit none
+real(dp),dimension(:), intent(in ):: a
+real(dp),dimension(:), intent(in ):: b
+real(dp),dimension(size(a),size(b)):: c
+integer(spi) :: nb,i
+nb=size(b)
+do i=1,nb; c(:,i)=a*b(i); enddo
+end function outer_product_d
+!=============================================================================
+function outer_product_i(a,b)result(c)! [outer_product]
+!=============================================================================
+implicit none
+integer(spi),dimension(:), intent(in ):: a
+integer(spi),dimension(:), intent(in ):: b
+integer(spi),dimension(size(a),size(b)):: c
+integer(spi) :: nb,i
+nb=size(b)
+do i=1,nb; c(:,i)=a*b(i); enddo
+end function outer_product_i
+
+!=============================================================================
+function triple_product_s(a,b,c)result(tripleproduct)! [triple_product]
+!=============================================================================
+implicit none
+real(sp),dimension(3),intent(IN ):: a,b,c
+real(sp) :: tripleproduct
+tripleproduct=dot_product( cross_product(a,b),c )
+end function triple_product_s
+!=============================================================================
+function triple_product_d(a,b,c)result(tripleproduct)! [triple_product]
+!=============================================================================
+implicit none
+real(dp),dimension(3),intent(IN ):: a,b,c
+real(dp) :: tripleproduct
+tripleproduct=dot_product( cross_product(a,b),c )
+end function triple_product_d
+
+!=============================================================================
+function det_s(a)result(det)! [det]
+!=============================================================================
+use jp_pietc_s, only: u0
+implicit none
+real(sp),dimension(:,:),intent(IN ) :: a
+real(sp) :: det
+real(sp),dimension(size(a,1),size(a,1)):: b
+integer(spi) :: n,nrank
+n=size(a,1)
+if(n==3)then
+ det=triple_product(a(:,1),a(:,2),a(:,3))
+else
+ call gram(a,b,nrank,det)
+ if(nranku0
+implicit none
+real(sp),dimension(3),intent(IN ):: v1,v2,v3
+real(sp) :: area
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+real(sp) :: s123,a1,a2,b,d1,d2,d3
+real(sp),dimension(3) :: u0,u1,u2,u3,x,y
+!=============================================================================
+area=zero
+u1=normalized(v1); u2=normalized(v2); u3=normalized(v3)
+s123=triple_product(u1,u2,u3)
+if(s123==zero)return
+
+d1=dot_product(u3-u2,u3-u2)
+d2=dot_product(u1-u3,u1-u3)
+d3=dot_product(u2-u1,u2-u1)
+
+! Triangle that is not degenerate. Cyclically permute, so side 3 is longest:
+if(d3u0
+implicit none
+real(dp),dimension(3),intent(IN ):: v1,v2,v3
+real(dp) :: area
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+real(dp) :: s123,a1,a2,b,d1,d2,d3
+real(dp),dimension(3) :: u0,u1,u2,u3,x,y
+!=============================================================================
+area=zero
+u1=normalized(v1); u2=normalized(v2); u3=normalized(v3)
+s123=triple_product(u1,u2,u3)
+if(s123==zero)return
+
+d1=dot_product(u3-u2,u3-u2)
+d2=dot_product(u1-u3,u1-u3)
+d3=dot_product(u2-u1,u2-u1)
+
+! Triangle that is not degenerate. Cyclically permute, so side 3 is longest:
+if(d3nrank)exit
+ ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) )
+ ii =maxloc( abs( ab(k:m,k:n)) )+k-1
+ val=maxval( abs( ab(k:m,k:n)) )
+ if(val<=vcrit)then
+ nrank=k-1
+ exit
+ endif
+ i=ii(1)
+ j=ii(2)
+ tv=b(:,j)
+ b(:,j)=-b(:,k)
+ b(:,k)=tv
+ tv=a(:,i)
+ a(:,i)=-a(:,k)
+ a(:,k)=tv
+ w(k:n)=matmul( transpose(b(:,k:n)),tv )
+ b(:,k)=matmul(b(:,k:n),w(k:n) )
+ s=dot_product(b(:,k),b(:,k))
+ s=sqrt(s)
+ if(w(k)nrank)exit
+ ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) )
+ ii =maxloc( abs( ab(k:m,k:n)) )+k-1
+ val=maxval( abs( ab(k:m,k:n)) )
+ if(val<=vcrit)then
+ nrank=k-1
+ exit
+ endif
+ i=ii(1)
+ j=ii(2)
+ tv=b(:,j)
+ b(:,j)=-b(:,k)
+ b(:,k)=tv
+ tv=a(:,i)
+ a(:,i)=-a(:,k)
+ a(:,k)=tv
+ w(k:n)=matmul( transpose(b(:,k:n)),tv )
+ b(:,k)=matmul(b(:,k:n),w(k:n) )
+ s=dot_product(b(:,k),b(:,k))
+ s=sqrt(s)
+ if(w(k)nrank)exit
+ ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) )
+ ii =maxloc( abs( ab(k:m,k:n)) )+k-1
+ val=maxval( abs( ab(k:m,k:n)) )
+ if(val<=vcrit)then
+ nrank=k-1
+ exit
+ endif
+ i=ii(1)
+ j=ii(2)
+ tv=b(:,j)
+ b(:,j)=-b(:,k)
+ b(:,k)=tv
+ tv=a(:,i)
+ a(:,i)=-a(:,k)
+ a(:,k)=tv
+ w(k:n)=matmul( transpose(b(:,k:n)),tv )
+ b(:,k)=matmul(b(:,k:n),w(k:n) )
+ s=dot_product(b(:,k),b(:,k))
+ s=sqrt(s)
+ if(w(k)u0)then
+ ldet=ldet+log(s)
+ else
+ detsign=0
+ endif
+
+ b(:,k)=b(:,k)/s
+ do l=k,n
+ do j=l+1,n
+ s=dot_product(b(:,l),b(:,j))
+ b(:,j)=normalized( b(:,j)-b(:,l)*s )
+ enddo
+ enddo
+enddo
+end subroutine graml_d
+
+!=============================================================================
+subroutine plaingram_s(b,nrank)! [gram]
+!=============================================================================
+! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only.
+use jp_pietc_s, only: u0
+implicit none
+real(sp),dimension(:,:),intent(INOUT) :: b
+integer(spi), intent( OUT) :: nrank
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+real(sp),parameter :: crit=1.e-5_sp
+real(sp) :: val,vcrit
+integer(spi) :: j,k,n
+!=============================================================================
+n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square'
+val=maxval(abs(b))
+nrank=0
+if(val==0)then
+ b=u0
+ return
+endif
+vcrit=val*crit
+do k=1,n
+ val=sqrt(dot_product(b(:,k),b(:,k)))
+ if(val<=vcrit)then
+ b(:,k:n)=u0
+ return
+ endif
+ b(:,k)=b(:,k)/val
+ nrank=k
+ do j=k+1,n
+ b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j))
+ enddo
+enddo
+end subroutine plaingram_s
+
+!=============================================================================
+subroutine plaingram_d(b,nrank)! [gram]
+!=============================================================================
+! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only.
+use jp_pietc, only: u0
+implicit none
+real(dp),dimension(:,:),intent(INOUT):: b
+integer(spi), intent( OUT):: nrank
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+real(dp),parameter:: crit=1.e-9_dp
+real(dp) :: val,vcrit
+integer(spi) :: j,k,n
+!=============================================================================
+n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square'
+val=maxval(abs(b))
+nrank=0
+if(val==u0)then
+ b=u0
+ return
+endif
+vcrit=val*crit
+do k=1,n
+ val=sqrt(dot_product(b(:,k),b(:,k)))
+ if(val<=vcrit)then
+ b(:,k:n)=u0
+ return
+ endif
+ b(:,k)=b(:,k)/val
+ nrank=k
+ do j=k+1,n
+ b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j))
+ enddo
+enddo
+end subroutine plaingram_d
+
+!=============================================================================
+subroutine rowgram(m,n,a,ipiv,tt,b,rank)! [gram]
+!=============================================================================
+! Without changing (tall) rectangular input matrix a, perform pivoted gram-
+! Schmidt operations to orthogonalize the rows, until rows that remain become
+! negligible. Record the pivoting sequence in ipiv, and the row-normalization
+! in tt(j,j) and the row-orthogonalization in tt(i,j), for i>j. Note that
+! tt(i,j)=0 for i=n please'
+nepss=n*epss
+rank=n
+aa=a
+tt=u0
+do ii=1,n
+
+! At this stage, all rows less than ii are already orthonormalized and are
+! orthogonal to all rows at and beyond ii. Find the norms of these lower
+! rows and pivot the largest of them into position ii:
+ maxp=u0
+ maxi=ii
+ do i=ii,m
+ p(i)=dot_product(aa(i,:),aa(i,:))
+ if(p(i)>maxp)then
+ maxp=p(i)
+ maxi=i
+ endif
+ enddo
+ if(maxpu0,one=>u1,two=>u2
+implicit none
+real(dp),dimension(3,3),intent(IN ):: rot
+real(dp),dimension(0:3),intent(OUT):: q
+!------------------------------------------------------------------------------
+real(dp),dimension(3,3) :: t1,t2
+real(dp),dimension(3) :: u1,u2
+real(dp) :: gamma,gammah,s,ss
+integer(spi) :: i,j
+integer(spi),dimension(1):: ii
+!==============================================================================
+! construct the orthogonal matrix, t1, whose third row is the rotation axis
+! of rot:
+t1=rot; do i=1,3; t1(i,i)=t1(i,i)-1; u1(i)=dot_product(t1(i,:),t1(i,:)); enddo
+ii=maxloc(u1); j=ii(1); ss=u1(j)
+if(ss<1.e-16_dp)then
+ q=zero; q(0)=one; return
+endif
+t1(j,:)=t1(j,:)/sqrt(ss)
+if(j/=1)then
+ u2 =t1(1,:)
+ t1(1,:)=t1(j,:)
+ t1(j,:)=u2
+endif
+do i=2,3
+ t1(i,:)=t1(i,:)-dot_product(t1(1,:),t1(i,:))*t1(1,:)
+ u1(i)=dot_product(t1(i,:),t1(i,:))
+enddo
+if(u1(3)>u1(2))then
+ j=3
+else
+ j=2
+endif
+ss=u1(j)
+if(ss==zero)stop 'In rotov; invalid rot'
+if(j/=2)t1(2,:)=t1(3,:)
+t1(2,:)=t1(2,:)/sqrt(ss)
+
+! Form t1(3,:) as the cross product of t1(1,:) and t1(2,:)
+t1(3,1)=t1(1,2)*t1(2,3)-t1(1,3)*t1(2,2)
+t1(3,2)=t1(1,3)*t1(2,1)-t1(1,1)*t1(2,3)
+t1(3,3)=t1(1,1)*t1(2,2)-t1(1,2)*t1(2,1)
+
+! Project rot into the frame whose axes are the rows of t1:
+t2=matmul(t1,matmul(rot,transpose(t1)))
+
+! Obtain the rotation angle, gamma, implied by rot, and gammah=gamma/2:
+gamma=atan2(t2(2,1),t2(1,1)); gammah=gamma/two
+
+! Hence deduce coefficients (in the form of a real 4-vector) of one of the two
+! possible equivalent spinors:
+s=sin(gammah)
+q(0)=cos(gammah)
+q(1:3)=t1(3,:)*s
+end subroutine rottoq
+
+!==============================================================================
+subroutine qtorot(q,rot)! [qtorot]
+!==============================================================================
+! Go from quaternion to rotation matrix representations
+!==============================================================================
+implicit none
+real(dp),dimension(0:3),intent(IN ):: q
+real(dp),dimension(3,3),intent(OUT):: rot
+!=============================================================================
+call setem(q(0),q(1),q(2),q(3),rot)
+end subroutine qtorot
+
+!=============================================================================
+subroutine axtoq(v,q)! [axtoq]
+!=============================================================================
+! Go from an axial 3-vector to its equivalent quaternion
+!=============================================================================
+implicit none
+real(dp),dimension(3), intent(in ):: v
+real(dp),dimension(0:3),intent(out):: q
+!-----------------------------------------------------------------------------
+real(dp),dimension(3,3):: rot
+!=============================================================================
+call axtorot(v,rot)
+call rottoq(rot,q)
+end subroutine axtoq
+
+!=============================================================================
+subroutine qtoax(q,v)! [qtoax]
+!=============================================================================
+! Go from quaternion to axial 3-vector
+!=============================================================================
+implicit none
+real(dp),dimension(0:3),intent(in ):: q
+real(dp),dimension(3), intent(out):: v
+!-----------------------------------------------------------------------------
+real(dp),dimension(3,3):: rot
+!=============================================================================
+call qtorot(q,rot)
+call rottoax(rot,v)
+end subroutine qtoax
+
+!=============================================================================
+subroutine setem(c,d,e,g,r)! [setem]
+!=============================================================================
+implicit none
+real(dp), intent(IN ):: c,d,e,g
+real(dp),dimension(3,3),intent(OUT):: r
+!-----------------------------------------------------------------------------
+real(dp):: cc,dd,ee,gg,de,dg,eg,dc,ec,gc
+!=============================================================================
+cc=c*c; dd=d*d; ee=e*e; gg=g*g
+de=d*e; dg=d*g; eg=e*g
+dc=d*c; ec=e*c; gc=g*c
+r(1,1)=cc+dd-ee-gg; r(2,2)=cc-dd+ee-gg; r(3,3)=cc-dd-ee+gg
+r(2,3)=2*(eg-dc); r(3,1)=2*(dg-ec); r(1,2)=2*(de-gc)
+r(3,2)=2*(eg+dc); r(1,3)=2*(dg+ec); r(2,1)=2*(de+gc)
+end subroutine setem
+
+!=============================================================================
+function mulqq(a,b)result(c)! [mulqq]
+!=============================================================================
+! Multiply quaternions, a*b, assuming operation performed from right to left
+!=============================================================================
+implicit none
+real(dp),dimension(0:3),intent(IN ):: a,b
+real(dp),dimension(0:3) :: c
+!-------------------------------------------
+c(0)=a(0)*b(0) -a(1)*b(1) -a(2)*b(2) -a(3)*b(3)
+c(1)=a(0)*b(1) +a(1)*b(0) +a(2)*b(3) -a(3)*b(2)
+c(2)=a(0)*b(2) +a(2)*b(0) +a(3)*b(1) -a(1)*b(3)
+c(3)=a(0)*b(3) +a(3)*b(0) +a(1)*b(2) -a(2)*b(1)
+end function mulqq
+!=============================================================================
+subroutine expmat(n,a,b,detb)! [expmat]
+!=============================================================================
+! Evaluate the exponential, b, of a matrix, a, of degree n.
+! Apply the iterated squaring method, m times, to the approximation to
+! exp(a/(2**m)) obtained as a Taylor expansion of degree L
+! See Fung, T. C., 2004, Int. J. Numer. Meth. Engng, 59, 1273--1286.
+!=============================================================================
+use jp_pietc, only: u0,u1,u2,o2
+implicit none
+integer(spi), intent(IN ):: n
+real(dp),dimension(n,n),intent(IN ):: a
+real(dp),dimension(n,n),intent(OUT):: b
+real(dp), intent(OUT):: detb
+!-----------------------------------------------------------------------------
+integer(spi),parameter :: L=5
+real(dp),dimension(n,n):: c,p
+real(dp) :: t
+integer(spi) :: i,m
+!=============================================================================
+m=10+floor(log(u1+maxval(abs(a)))/log(u2))
+t=o2**m
+c=a*t
+p=c
+b=p
+do i=2,L
+ p=matmul(p,c)/i
+ b=b+p
+enddo
+do i=1,m
+ b=b*u2+matmul(b,b)
+enddo
+do i=1,n
+ b(i,i)=b(i,i)+u1
+enddo
+detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb)
+end subroutine expmat
+
+!=============================================================================
+subroutine expmatd(n,a,b,bd,detb,detbd)! [expmat]
+!=============================================================================
+! Like expmat, but for the 1st derivatives also.
+!=============================================================================
+use jp_pietc, only: u0,u1,u2,o2
+implicit none
+integer(spi), intent(IN ):: n
+real(dp),dimension(n,n), intent(IN ):: a
+real(dp),dimension(n,n), intent(OUT):: b
+real(dp),dimension(n,n,(n*(n+1))/2),intent(OUT):: bd
+real(dp), intent(OUT):: detb
+real(dp),dimension((n*(n+1))/2), intent(OUT):: detbd
+!-----------------------------------------------------------------------------
+integer(spi),parameter :: L=5
+real(dp),dimension(n,n) :: c,p
+real(dp),dimension(n,n,(n*(n+1))/2):: pd,cd
+real(dp) :: t
+integer(spi) :: i,j,k,m,n1
+!=============================================================================
+n1=(n*(n+1))*o2
+m=10+floor(log(u1+maxval(abs(a)))/log(u2))
+t=o2**m
+c=a*t
+p=c
+pd=u0
+do k=1,n
+ pd(k,k,k)=t
+enddo
+k=n
+do i=1,n-1
+ do j=i+1,n
+ k=k+1
+ pd(i,j,k)=t
+ pd(j,i,k)=t
+ enddo
+enddo
+if(k/=n1)stop 'In expmatd; n1 is inconsistent with n'
+cd=pd
+b=p
+bd=pd
+
+do i=2,L
+ do k=1,n1
+ pd(:,:,k)=(matmul(cd(:,:,k),p)+matmul(c,pd(:,:,k)))/i
+ enddo
+ p=matmul(c,p)/i
+ b=b+p
+ bd=bd+pd
+enddo
+do i=1,m
+ do k=1,n1
+ bd(:,:,k)=2*bd(:,:,k)+matmul(bd(:,:,k),b)+matmul(b,bd(:,:,k))
+ enddo
+ b=b*u2+matmul(b,b)
+enddo
+do i=1,n
+ b(i,i)=b(i,i)+u1
+enddo
+detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb)
+detbd=u0; do k=1,n; detbd(k)=detb; enddo
+end subroutine expmatd
+
+!=============================================================================
+subroutine expmatdd(n,a,b,bd,bdd,detb,detbd,detbdd)! [expmat]
+!=============================================================================
+! Like expmat, but for the 1st and 2nd derivatives also.
+!=============================================================================
+use jp_pietc, only: u0,u1,u2,o2
+implicit none
+integer(spi), intent(IN ):: n
+real(dp),dimension(n,n), intent(IN ):: a
+real(dp),dimension(n,n), intent(OUT):: b
+real(dp),dimension(n,n,(n*(n+1))/2), intent(OUT):: bd
+real(dp),dimension(n,n,(n*(n+1))/2,(n*(n+1))/2),intent(OUT):: bdd
+real(dp), intent(OUT):: detb
+real(dp),dimension((n*(n+1))/2), intent(OUT):: detbd
+real(dp),dimension((n*(n+1))/2,(n*(n+1))/2), intent(OUT):: detbdd
+!-----------------------------------------------------------------------------
+integer(spi),parameter :: L=5
+real(dp),dimension(n,n) :: c,p
+real(dp),dimension(n,n,(n*(n+1))/2) :: pd,cd
+real(dp),dimension(n,n,(n*(n+1))/2,(n*(n+1))/2):: pdd,cdd
+real(dp) :: t
+integer(spi) :: i,j,k,ki,kj,m,n1
+!=============================================================================
+n1=(n*(n+1))/2
+m=10+floor(log(u1+maxval(abs(a)))/log(u2))
+t=o2**m
+c=a*t
+p=c
+pd=u0
+pdd=u0
+do k=1,n
+ pd(k,k,k)=t
+enddo
+k=n
+do i=1,n-1
+ do j=i+1,n
+ k=k+1
+ pd(i,j,k)=t
+ pd(j,i,k)=t
+ enddo
+enddo
+if(k/=n1)stop 'In expmatd; n1 is inconsistent with n'
+cd=pd
+cdd=u0
+b=p
+bd=pd
+bdd=u0
+
+do i=2,L
+ do ki=1,n1
+ do kj=1,n1
+ pdd(:,:,ki,kj)=(matmul(cd(:,:,ki),pd(:,:,kj)) &
+ + matmul(cd(:,:,kj),pd(:,:,ki)) &
+ + matmul(c,pdd(:,:,ki,kj)))/i
+ enddo
+ enddo
+ do k=1,n1
+ pd(:,:,k)=(matmul(cd(:,:,k),p)+matmul(c,pd(:,:,k)))/i
+ enddo
+ p=matmul(c,p)/i
+ b=b+p
+ bd=bd+pd
+ bdd=bdd+pdd
+enddo
+do i=1,m
+ do ki=1,n1
+ do kj=1,n1
+ bdd(:,:,ki,kj)=u2*bdd(:,:,ki,kj) &
+ +matmul(bdd(:,:,ki,kj),b) &
+ +matmul(bd(:,:,ki),bd(:,:,kj)) &
+ +matmul(bd(:,:,kj),bd(:,:,ki)) &
+ +matmul(b,bdd(:,:,ki,kj))
+ enddo
+ enddo
+ do k=1,n1
+ bd(:,:,k)=2*bd(:,:,k)+matmul(bd(:,:,k),b)+matmul(b,bd(:,:,k))
+ enddo
+ b=b*u2+matmul(b,b)
+enddo
+do i=1,n
+ b(i,i)=b(i,i)+u1
+enddo
+detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb)
+detbd=u0; do k=1,n; detbd(k)=detb; enddo
+detbdd=u0; do ki=1,n; do kj=1,n; detbdd(ki,kj)=detb; enddo; enddo
+end subroutine expmatdd
+
+!=============================================================================
+subroutine zntay(n,z,zn)! [zntay]
+!=============================================================================
+use jp_pietc, only: u2
+implicit none
+integer(spi), intent(IN ):: n
+real(dp), intent(IN ):: z
+real(dp), intent(OUT):: zn
+!-----------------------------------------------------------------------------
+integer(spi),parameter:: ni=100
+real(dp),parameter :: eps0=1.e-16_dp
+integer(spi) :: i,i2,n2
+real(dp) :: t,eps,z2
+!=============================================================================
+z2=z*u2
+n2=n*2
+t=1
+do i=1,n
+ t=t/(i*2-1)
+enddo
+eps=t*eps0
+zn=t
+do i=1,ni
+ i2=i*2
+ t=t*z2/(i2*(i2+n2-1))
+ zn=zn+t
+ if(abs(t)u0)then
+ zn=cosh(rz2)
+ znd=sinh(rz2)/rz2
+ zndd=(zn-znd)/z2
+ znddd=(znd-u3*zndd)/z2
+ do i=1,n
+ i2p3=i*2+3
+ zn=znd
+ znd=zndd
+ zndd=znddd
+ znddd=(znd-i2p3*zndd)/z2
+ enddo
+ else
+ zn=cos(rz2)
+ znd=sin(rz2)/rz2
+ zndd=-(zn-znd)/z2
+ znddd=-(znd-u3*zndd)/z2
+ do i=1,n
+ i2p3=i*2+3
+ zn=znd
+ znd=zndd
+ zndd=znddd
+ znddd=-(znd-i2p3*zndd)/z2
+ enddo
+ endif
+endif
+end subroutine znfun
+
+!=============================================================================
+! Utility code for various Mobius transformations. If aa1,bb1,cc1,dd1 are
+! the coefficients for one transformation, and aa2,bb2,cc2,dd2 are the
+! coefficients for a second one, then the coefficients for the mapping
+! of a test point, zz, by aa1 etc to zw, followed by a mapping of zw, by
+! aa2 etc to zv, is equivalent to a single mapping zz-->zv by the transformatn
+! with coefficients aa3,bb3,cc3,dd3, such that, as 2*2 complex matrices:
+!
+! [ aa3, bb3 ] [ aa2, bb2 ] [ aa1, bb1 ]
+! [ ] = [ ] * [ ]
+! [ cc3, dd3 ] [ cc2, dd2 ] [ cc1, dd1 ] .
+!
+! Note that the determinant of these matrices is always +1
+!
+!=============================================================================
+subroutine ctoz(v, z,infz)! [ctoz]
+!=============================================================================
+use jp_pietc, only: u0,u1
+implicit none
+real(dp),dimension(3),intent(IN ):: v
+complex(dpc), intent(OUT):: z
+logical, intent(OUT):: infz
+!-----------------------------------------------------------------------------
+real(dp) :: rr,zzpi
+!=============================================================================
+infz=.false.
+z=cmplx(v(1),v(2),dpc)
+if(v(3)>u0)then
+ zzpi=u1/(u1+v(3))
+else
+ rr=v(1)**2+v(2)**2
+ infz=(rr==u0); if(infz)return ! <- The point is mapped to infinity (90S)
+ zzpi=(u1-v(3))/rr
+endif
+z=z*zzpi
+end subroutine ctoz
+
+!=============================================================================
+subroutine ztoc(z,infz, v)! [ztoc]
+!=============================================================================
+implicit none
+complex(dpc), intent(IN ):: z
+logical, intent(IN ):: infz
+real(dp),dimension(3),intent(OUT):: v
+!-----------------------------------------------------------------------------
+real(dp),parameter:: zero=0_dp,one=1_dp,two=2_dp
+real(dp) :: r,q,rs,rsc,rsbi
+!=============================================================================
+if(infz)then; v=(/zero,zero,-one/); return; endif
+r=real(z); q=aimag(z); rs=r*r+q*q
+rsc=one-rs
+rsbi=one/(one+rs)
+v(1)=two*rsbi*r
+v(2)=two*rsbi*q
+v(3)=rsc*rsbi
+end subroutine ztoc
+
+!=============================================================================
+subroutine ztocd(z,infz, v,vd)! [ztoc]
+!=============================================================================
+! The convention adopted for the complex derivative is that, for a complex
+! infinitesimal map displacement, delta_z, the corresponding infinitesimal
+! change of cartesian vector position is delta_v given by:
+! delta_v = Real(vd*delta_z).
+! Thus, by a kind of Cauchy-Riemann relation, Imag(vd)=v CROSS Real(vd).
+! THE DERIVATIVE FOR THE IDEAL POINT AT INFINITY HAS NOT BEEN CODED YET!!!
+!=============================================================================
+implicit none
+complex(dpc), intent(IN ):: z
+logical, intent(IN ):: infz
+real(dp),dimension(3), intent(OUT):: v
+complex(dpc),dimension(3),intent(OUT):: vd
+!-----------------------------------------------------------------------------
+real(dp),parameter :: zero=0_dp,one=1_dp,two=2_dp,four=4_dp
+real(dp) :: r,q,rs,rsc,rsbi,rsbis
+real(dp),dimension(3):: u1,u2
+integer(spi) :: i
+!=============================================================================
+if(infz)then; v=(/zero,zero,-one/); return; endif
+r=real(z); q=aimag(z); rs=r*r+q*q
+rsc=one-rs
+rsbi=one/(one+rs)
+rsbis=rsbi**2
+v(1)=two*rsbi*r
+v(2)=two*rsbi*q
+v(3)=rsc*rsbi
+u1(1)=two*(one+q*q-r*r)*rsbis
+u1(2)=-four*r*q*rsbis
+u1(3)=-four*r*rsbis
+u2=cross_product(v,u1)
+do i=1,3
+ vd(i)=cmplx(u1(i),-u2(i),dpc)
+enddo
+end subroutine ztocd
+
+!============================================================================
+subroutine setmobius(xc0,xc1,xc2, aa,bb,cc,dd)! [setmobius]
+!============================================================================
+! Find the Mobius transformation complex coefficients, aa,bb,cc,dd,
+! with aa*dd-bb*cc=1, for a standard (north-)polar stereographic transformation
+! that takes cartesian point, xc0 to the north pole, xc1 to (lat=0,lon=0),
+! xc2 to the south pole (=complex infinity).
+!============================================================================
+implicit none
+real(dp),dimension(3),intent(IN ):: xc0,xc1,xc2
+complex(dpc), intent(OUT):: aa,bb,cc,dd
+!----------------------------------------------------------------------------
+real(dp),parameter:: zero=0_dp,one=1_dp
+logical :: infz0,infz1,infz2
+complex(dpc) :: z0,z1,z2,z02,z10,z21
+!============================================================================
+call ctoz(xc0,z0,infz0)
+call ctoz(xc1,z1,infz1)
+call ctoz(xc2,z2,infz2)
+z21=z2-z1
+z02=z0-z2
+z10=z1-z0
+
+if( (z0==z1.and.infz0.eqv.infz1).or.&
+ (z1==z2.and.infz1.eqv.infz2).or.&
+ (z2==z0.and.infz2.eqv.infz0)) &
+ stop 'In setmobius; anchor points must be distinct'
+
+if(infz2 .or. (.not.infz0 .and. abs(z0)= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_S(:,i,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j)=W(:,i,jmax-nby+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+
+ end if
+!
+! RECEIVE boundaries from NORTH and SOUTH
+!
+
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ end if
+!
+! Assign received values from NORTH and SOUTH
+!
+! From SOUTH
+
+ if(lsouth) then
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j)=W(:,i,nby+1-j)
+ end do
+ end do
+
+ else
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j)=rBuf_S(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+! --- from NORTH ---
+
+ if( lnorth) then
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j)=W(:,i,jmax+1-j)
+ enddo
+ enddo
+
+ else
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j)=rBuf_N(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!----------------------------------------------------------------------
+!
+! SEND extended boundaries toward WEST and EAST
+!
+
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_W(:,i,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_E(:,i,j) = W(:,imax-nbx+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE boundaries from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( rBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+ allocate( rBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ end if
+
+
+!
+! Assign received values from EAST and WEST
+!
+
+! From west
+
+ if(lwest) then
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,-nbx+i,j)= W(:,nbx+1-i,j)
+ end do
+ end do
+
+ else
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,-nbx+i,j)= rBuf_W(:,i,j)
+ enddo
+ enddo
+
+
+ endif
+
+! From east
+
+ if(least) then
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax+i,j)=W(:,imax+1-i,j)
+ end do
+ end do
+
+ else
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax+i,j)=rBuf_E(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+
+ if( itarg_s >= 0 ) then
+ deallocate( rBuf_S, stat = iderr)
+ end if
+ if( itarg_n >= 0 ) then
+ deallocate( rBuf_N, stat = iderr)
+ end if
+ if( itarg_e >= 0 ) then
+ deallocate( rBuf_E, stat = iderr)
+ end if
+ if( itarg_w >= 0 ) then
+ deallocate( rBuf_W, stat = iderr)
+ end if
+
+!
+! DEALLOCATE sBufferes
+!
+
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_S, stat = ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_N, stat = ierr )
+ end if
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_E, stat = ierr )
+ end if
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_W, stat = ierr )
+ end if
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine boco_2d_g1
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine boco_2d_gh &
+!**********************************************************************!
+! !
+! Side sending subroutine: !
+! Supplies (nbx,nby) lines of halos in (x,y) directions assuming !
+! mirror boundary conditions. Version for high generations !
+! !
+! - offset version - !
+! !
+!**********************************************************************!
+(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_N,sBuf_E,sBuf_S,sBuf_W &
+ ,rBuf_N,rBuf_E,rBuf_S,rBuf_W
+
+integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax
+logical:: lwest,least,lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,l,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax,ndatay
+integer(i_kind) g_ind,g
+logical l_sidesend
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Limit communications to selected number of generations
+!
+
+ if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then
+ g_ind=2
+ g = my_hgen
+ l_sidesend=.true.
+ else
+ l_sidesend=.false.
+ endif
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+FILT_GRID: if(l_sidesend) then
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+!
+! from mg_domain
+!
+ itarg_n = Fitarg_n(g_ind)
+ itarg_s = Fitarg_s(g_ind)
+ itarg_w = Fitarg_w(g_ind)
+ itarg_e = Fitarg_e(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+
+ if(least) then
+ imax = Fimax_in(g)
+ else
+ imax = im_in ! << Note that is not necesseraly im from
+ endif ! mg_parameter. Could be also imL >>>
+ if(lnorth) then
+ jmax = Fjmax_in(g)
+ else
+ jmax = jm_in
+ endif
+
+
+!-----------------------------------------------------------------------
+ ndatay = km_in*imax*nby
+ ndatax = km_in*(jmax+2*nby)*nbx
+
+
+!
+! SEND boundaries to SOUTH and NORTH
+!
+
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_S(:,i,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j)=W(:,i,jmax-nby+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+
+ end if
+!
+! RECEIVE boundaries from NORTH and SOUTH
+!
+
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ end if
+
+!
+! Assign received values from NORTH and SOUTH
+!
+
+
+! From south
+
+ if(lsouth) then
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j)=W(:,i,nby+1-j)
+ end do
+ end do
+
+ else
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j)=rBuf_S(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+! --- from NORTH ---
+
+ if( lnorth) then
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j)=W(:,i,jmax+1-j)
+ enddo
+ enddo
+
+ else
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j)=rBuf_N(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!
+! SEND extended boundaries to WEST and EASTH
+!
+
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_W(:,i,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_E(:,i,j) = W(:,imax-nbx+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE extended boundaries from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( rBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+ allocate( rBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ end if
+
+!
+! Assign received values from WEST and EAST
+!
+
+! From west
+
+ if(lwest) then
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,-nbx+i,j)= W(:,nbx+1-i,j)
+ end do
+ end do
+
+ else
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,-nbx+i,j)= rBuf_W(:,i,j)
+ enddo
+ enddo
+
+
+ endif
+
+! From east
+
+ if(least) then
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax+i,j)=W(:,imax+1-i,j)
+ end do
+ end do
+
+ else
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax+i,j)=rBuf_E(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+ if( itarg_w >= 0 ) then
+ deallocate( rBuf_W, stat = iderr)
+ end if
+ if( itarg_e >= 0 ) then
+ deallocate( rBuf_E, stat = iderr)
+ end if
+ if( itarg_s >= 0 ) then
+ deallocate( rBuf_S, stat = iderr)
+ end if
+ if( itarg_n >= 0 ) then
+ deallocate( rBuf_N, stat = iderr)
+ end if
+
+!
+! DEALLOCATE sBufferes
+!
+
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_W, stat = ierr )
+ end if
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_E, stat = ierr )
+ end if
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_S, stat = ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_N, stat = ierr )
+ end if
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+ endif FILT_GRID
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine boco_2d_gh
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocoT_2d_g1 &
+!***********************************************************************
+! !
+! Adjoint of side sending subroutine: !
+! Supplies (nbx,nby) lines of halos in (x,y) directions, including !
+! values at the edges of the subdomains and assuming mirror boundary !
+! conditions just for generation 1 !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,km_in,im_in,jm_in,nbx,nby)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby
+real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_N,sBuf_E,sBuf_S,sBuf_W &
+ ,rBuf_N,rBuf_E,rBuf_S,rBuf_W
+
+integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax
+logical lwest,least,lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,L,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax,ndatay
+logical l_sidesend
+integer(i_kind) g_ind,g,k
+!-----------------------------------------------------------------------
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!
+! Limit comminications to selected number of generations
+!
+
+
+ g_ind=1
+!
+! from mg_domain
+!
+ itarg_n = Fitarg_n(g_ind)
+ itarg_s = Fitarg_s(g_ind)
+ itarg_w = Fitarg_w(g_ind)
+ itarg_e = Fitarg_e(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+ imax = im_in
+ jmax = jm_in
+
+
+!----------------------------------------------------------------------
+ ndatax =km_in*(jmax+2*nby)*nbx
+ ndatay =km_in*imax*nby
+!
+! SEND extended halos toward WEST and EAST
+!
+
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_W(:,i,j) = W(:,-nbx+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_E(:,i,j) = W(:,imax+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE extended halos from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+
+ allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+
+ allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+
+ end if
+
+!
+! Assign received halos from WEST and EAST to interrior of domains
+!
+
+! From west
+
+ if(lwest) then
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,i,j)= W(:,i,j)+W(:,1-i,j)
+ end do
+ end do
+ else
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j)
+ end do
+ end do
+ endif
+
+! From east
+
+ if(least) then
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+1+nbx-i,j)
+ end do
+ end do
+ else
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j)
+ end do
+ end do
+ endif
+
+!
+! SEND boundaries SOUTH and NORTH
+!
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr )
+
+ do j=1-nby,0
+ do i=1,imax
+ sBuf_S(:,i,j+nby) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j)=W(:,i,jmax+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+
+ end if
+
+!
+! RECEIVE boundaries from NORTH and SOUTH
+!
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+
+ allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+
+ allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+
+ end if
+
+!
+! ASSIGN received values from SOUTH and NORTH
+!
+
+! From south
+
+ if(lsouth) then
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j)= W(:,i,j)+W(:,i,1-j)
+ end do
+ end do
+ else
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j)
+ end do
+ end do
+ endif
+
+! From north
+
+ if(lnorth) then
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+1+nby-j)
+ enddo
+ enddo
+ else
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j)
+ enddo
+ enddo
+ endif
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+
+ deallocate( rBuf_W, stat = iderr)
+ deallocate( rBuf_E, stat = iderr)
+ deallocate( rBuf_S, stat = iderr)
+ deallocate( rBuf_N, stat = iderr)
+
+!
+! DEALLOCATE sBufferes
+!
+
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ end if
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ end if
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ end if
+
+
+!-----------------------------------------------------------------------
+endsubroutine bocoT_2d_g1
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocoT_2d_gh &
+!***********************************************************************
+! !
+! Supply n-lines inside of domains, including edges, with halos from !
+! the surrounding domains. Assume mirror boundary conditions at the !
+! boundaries of the domain. For high multigrid generations. !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_N,sBuf_E,sBuf_S,sBuf_W &
+ ,rBuf_N,rBuf_E,rBuf_S,rBuf_W
+integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax
+logical lwest,least,lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,L,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax,ndatay
+logical l_sidesend
+integer(i_kind) g_ind,g,k
+!-----------------------------------------------------------------------
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!
+! Limit comminications to selected number of generations
+!
+
+
+ if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then
+ g_ind=2
+ g = my_hgen
+ l_sidesend=.true.
+ else
+ l_sidesend=.false.
+ endif
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+FILT_GRID: if(l_sidesend) then
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!
+! from mg_domain
+!
+ itarg_n = Fitarg_n(g_ind)
+ itarg_s = Fitarg_s(g_ind)
+ itarg_w = Fitarg_w(g_ind)
+ itarg_e = Fitarg_e(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+
+ if(least) then
+ imax = Fimax_in(g)
+ else
+ imax = im_in ! << Note that is not necesseraly im from
+ endif ! mg_parameter. Could be also imL >>>
+ if(lnorth) then
+ jmax = Fjmax_in(g)
+ else
+ jmax = jm_in
+ endif
+
+
+!----------------------------------------------------------------------
+ ndatax =km_in*(jmax+2*nby)*nbx
+ ndatay =km_in*imax*nby
+
+!
+! SEND extended halos toward WEST and EAST
+!
+
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_W(:,i,j) = W(:,-nbx+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_E(:,i,j) = W(:,imax+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE extended halos from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+ allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ end if
+!
+! Assign received values from WEST and EAST
+!
+
+! From west
+
+ if(lwest) then
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,i,j)= W(:,i,j)+W(:,1-i,j)
+ end do
+ end do
+ else
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j)
+ end do
+ end do
+ endif
+
+! From east
+
+ if(least) then
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+1+nbx-i,j)
+ end do
+ end do
+ else
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j)
+ end do
+ end do
+ endif
+
+!
+! SEND halos toward SOUTH and NORTH
+!
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_S(:,i,j) = W(:,i,-nby+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j)=W(:,i,jmax+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+
+ end if
+
+!
+! RECEIVE halos from NORTH and SOUTH
+!
+!
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+
+ allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+
+ allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+
+ end if
+
+!
+! Assign received values from SOUTH and NORTH
+!
+
+! From south
+
+ if(lsouth) then
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j)= W(:,i,j)+W(:,i,1-j)
+ end do
+ end do
+ else
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j)
+ end do
+ end do
+ endif
+
+! From north
+
+ if(lnorth) then
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+1+nby-j)
+ enddo
+ enddo
+ else
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j)
+ enddo
+ enddo
+ endif
+
+!-----------------------------------------------------------------------
+
+! DEALLOCATE rBufferes
+
+ deallocate( rBuf_W, stat = iderr)
+ deallocate( rBuf_E, stat = iderr)
+ deallocate( rBuf_S, stat = iderr)
+ deallocate( rBuf_N, stat = iderr)
+
+! DEALLOCATE sBufferes
+
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ end if
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ end if
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ end if
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+ endif FILT_GRID
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine bocoT_2d_gh
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine boco_3d_g1 &
+!**********************************************************************!
+! !
+! Side sending subroutine: !
+! Supplies (nbx,nby) lines of halos in (x,y) directions assuming !
+! mirror boundary conditions. Version for generation 1 !
+! !
+! - offset version - !
+! !
+!**********************************************************************!
+(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz
+real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) &
+ ,intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+
+real(r_kind), allocatable, dimension(:,:,:,:):: &
+ sBuf_N,sBuf_E,sBuf_S,sBuf_W &
+ ,rBuf_N,rBuf_E,rBuf_S,rBuf_W
+
+integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax
+logical:: lwest,least,lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,l,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax,ndatay
+integer(i_kind) g_ind,g
+logical l_sidesend
+!-----------------------------------------------------------------------
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!
+! Limit communications to generation one
+!
+ g_ind=1
+
+ itarg_n = Fitarg_n(g_ind)
+ itarg_s = Fitarg_s(g_ind)
+ itarg_w = Fitarg_w(g_ind)
+ itarg_e = Fitarg_e(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+ imax = im_in
+ jmax = jm_in
+
+!-----------------------------------------------------------------------
+ ndatay = km3_in*imax*nby*Lm
+ ndatax = km3_in*(jmax+2*nby)*nbx*Lm_in
+
+
+!
+! SEND boundaries toward SOUTH and NORTH
+!
+
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr )
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ sBuf_S(:,i,j,L) = W(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr )
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j,L)=W(:,i,jmax-nby+j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+
+ end if
+!
+! RECEIVE boundaries from NORTH and SOUTH
+!
+
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( rBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( rBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ end if
+!
+! Assign received values from NORTH and SOUTH
+!
+
+! --- from NORTH ---
+
+ if( lnorth) then
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j,L)=W(:,i,jmax+1-j,L)
+ enddo
+ enddo
+ enddo
+
+ else
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j,L)=rBuf_N(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+! From south
+
+ if(lsouth) then
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j,L)=W(:,i,nby+1-j,L)
+ end do
+ end do
+ end do
+
+ else
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j,L)=rBuf_S(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!
+! SEND extended boundaries toward WEST and EAST
+!
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_W(:,i,j,L) = W(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_E(:,i,j,L) = W(:,imax-nbx+i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE boundaries WEST and EAST
+!
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+ allocate( rBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ end if
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( rBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+!
+! Assign received values from EAST and WEST
+!
+! From west
+
+ if(lwest) then
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,-nbx+i,j,L)= W(:,nbx+1-i,j,L)
+ end do
+ end do
+ end do
+
+ else
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,-nbx+i,j,L)= rBuf_W(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+
+ endif
+
+! From east
+
+ if(least) then
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax+i,j,L)=W(:,imax-i,j,L)
+ end do
+ end do
+ end do
+
+ else
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax+i,j,L)=rBuf_E(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+
+ if( itarg_w >= 0 ) then
+ deallocate( rBuf_W, stat = iderr)
+ end if
+ if( itarg_e >= 0 ) then
+ deallocate( rBuf_E, stat = iderr)
+ end if
+ if( itarg_s >= 0 ) then
+ deallocate( rBuf_S, stat = iderr)
+ end if
+ if( itarg_n >= 0 ) then
+ deallocate( rBuf_N, stat = iderr)
+ end if
+
+!
+! DEALLOCATE sBufferes
+!
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_W, stat = ierr )
+ end if
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_E, stat = ierr )
+ end if
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_S, stat = ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_N, stat = ierr )
+ end if
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+
+!-----------------------------------------------------------------------
+endsubroutine boco_3d_g1
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine boco_3d_gh &
+!**********************************************************************!
+
+! Side sending subroutine: !
+! Supplies (nbx,nby) lines of halos in (x,y) directions assuming !
+! mirror boundary conditions. Version for high generations !
+! !
+! - offset version - !
+! !
+!**********************************************************************!
+(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max
+real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) &
+ ,intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+
+real(r_kind), allocatable, dimension(:,:,:,:):: &
+ sBuf_N,sBuf_E,sBuf_S,sBuf_W &
+ ,rBuf_N,rBuf_E,rBuf_S,rBuf_W
+
+integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax
+logical:: lwest,least,lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,l,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax,ndatay
+integer(i_kind) g_ind,g
+logical l_sidesend
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Limit communications to selected number of generations
+!
+ if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then
+ g_ind=2
+ g = my_hgen
+ l_sidesend=.true.
+ else
+ l_sidesend=.false.
+ endif
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+FILT_GRID: if(l_sidesend) then
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+!
+! from mg_domain
+!
+ itarg_n = Fitarg_n(g_ind)
+ itarg_s = Fitarg_s(g_ind)
+ itarg_w = Fitarg_w(g_ind)
+ itarg_e = Fitarg_e(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+ if(least) then
+ imax = Fimax_in(g)
+ else
+ imax = im_in ! << Note that is not necesseraly im from
+ endif ! mg_parameter. Could be also imL >>>
+ if(lnorth) then
+ jmax = Fjmax_in(g)
+ else
+ jmax = jm_in
+ endif
+
+
+!-----------------------------------------------------------------------
+ ndatay = km3_in*imax*nby*Lm
+ ndatax = km3_in*(jmax+2*nby)*nbx*Lm
+
+!
+! SEND boundaries to SOUTH and NORTH
+!
+
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr )
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ sBuf_S(:,i,j,L) = W(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr )
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j,L)=W(:,i,jmax-nby+j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+
+ end if
+!
+! RECEIVE boundaries from SOUTH and NORTH
+!
+
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( rBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( rBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ end if
+
+!TEST
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_N, stat = ierr )
+ end if
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_S, stat = ierr )
+ end if
+!TEST
+
+!
+! Assign received values from NORTH and SOUTH
+!
+
+! --- from NORTH ---
+
+ if( lnorth) then
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j,L)=W(:,i,jmax+1-j,L)
+ enddo
+ enddo
+ enddo
+
+ else
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j,L)=rBuf_N(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+! From south
+
+ if(lsouth) then
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j,L)=W(:,i,nby+1-j,L)
+ end do
+ end do
+ end do
+
+ else
+
+ do L=1,Lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j,L)=rBuf_S(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!TEST
+ if( itarg_n >= 0 ) then
+ deallocate( rBuf_N, stat = iderr)
+ endif
+
+ if( itarg_s >= 0 ) then
+ deallocate( rBuf_S, stat = iderr)
+ endif
+!TEST
+
+
+!
+! SEND extended boundaries to WEST and EAST
+!
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_W(:,i,j,L) = W(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_E(:,i,j,L) = W(:,imax-nbx+i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE boundaries from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( rBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+ allocate( rBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+!
+! Deallocate send bufferes from EAST and WEST
+!
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_E, stat = ierr )
+ end if
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_W, stat = ierr )
+ end if
+
+!
+! Assign received values from WEST and EAST
+!
+! From west
+
+ if(lwest) then
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,-nbx+i,j,L)= W(:,nbx+1-i,j,L)
+ end do
+ end do
+ end do
+
+ else
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,-nbx+i,j,L)= rBuf_W(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+
+ endif
+
+! From east
+
+ if(least) then
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax+i,j,L)=W(:,imax+1-i,j,L)
+ end do
+ end do
+ end do
+
+ else
+
+ do L=1,Lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax+i,j,L)=rBuf_E(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!
+! Set up mirror b.c. at the bottom and top of domain
+!
+ do L=1,nbz
+ W(:,:,:,1-L )=W(:,:,:, 1+L)
+ W(:,:,:,LM+L)=W(:,:,:,LM-L)
+ end do
+
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+
+ if( itarg_w >= 0 ) then
+ deallocate( rBuf_W, stat = iderr)
+ endif
+ if( itarg_e >= 0 ) then
+ deallocate( rBuf_E, stat = iderr)
+ endif
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+ endif FILT_GRID
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine boco_3d_gh
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocoT_3d_g1 &
+!***********************************************************************
+! *
+! Supply n-lines inside of domains, including edges, with halos from *
+! the surrounding domains. Assume mirror boundary conditions at the *
+! boundaries of the domain *
+! !
+! - offset version - !
+! *
+!***********************************************************************
+(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz
+real(r_kind), dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) &
+ ,intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+
+real(r_kind), allocatable, dimension(:,:,:,:):: &
+ sBuf_N,sBuf_E,sBuf_S,sBuf_W &
+ ,rBuf_N,rBuf_E,rBuf_S,rBuf_W
+
+integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax
+logical lwest,least,lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,L,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax,ndatay
+logical l_sidesend
+integer(i_kind) g_ind,g,k
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Limit comminications to selected number of generations
+!
+
+ g_ind=1
+
+!
+! from mg_domain
+!
+ itarg_n = Fitarg_n(g_ind)
+ itarg_s = Fitarg_s(g_ind)
+ itarg_w = Fitarg_w(g_ind)
+ itarg_e = Fitarg_e(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+
+ imax = im
+ jmax = jm
+
+!----------------------------------------------------------------------
+ ndatax =km3_in*(jmax+2*nby)*nbx *Lm_in
+ ndatay =km3_in*imax*nby *Lm_in
+
+!
+! SEND extended halos toward WEST and EAST
+!
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+
+ do L=Lm_in,1,-1
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_W(:,i,j,L) = W(:,-nbx+i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+
+ do L=Lm_in,1,-1
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_E(:,i,j,L) = W(:,imax+i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+
+ end if
+!
+! RECEIVE extended halos from EAST and WEST
+!
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+
+ allocate( rBuf_E(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+
+ allocate( rBuf_W(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+
+ end if
+!
+! Assign received extended halos from WEST and EAST to interior of domains
+!
+
+! From west
+
+ if(lwest) then
+ do L=1,lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,i,j,L)= W(:,i,j,L)+W(:,1-i,j,L)
+ end do
+ end do
+ end do
+ else
+ do L=1,lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,i,j,L)= W(:,i,j,L)+rBuf_W(:,i,j,L)
+ end do
+ end do
+ end do
+ endif
+
+! From east
+
+ if(least) then
+ do L=1,lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+W(:,imax+nbx-i,j,L)
+ end do
+ end do
+ end do
+ else
+ do L=1,lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+rBuf_E(:,i,j,L)
+ end do
+ end do
+ end do
+ endif
+
+!
+! Send halos SOUTH and NORTH
+!
+
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr )
+
+ do L=Lm_in,1,-1
+ do j=1-nby,0
+ do i=1,imax
+ sBuf_S(:,i,j+nby,L) = W(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr )
+
+ do L=Lm_in,1,-1
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j,L)=W(:,i,jmax+j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+
+ end if
+
+
+!
+! RECEIVE boundaries from NORTH and SOUTH
+!
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+
+ allocate( rBuf_N(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+
+ allocate( rBuf_S(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+
+ end if
+
+!
+! Assign received values from SOUTH and NORTH
+!
+
+! From south
+
+ if(lsouth) then
+ do L=1,lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j,L)= W(:,i,j,L)+W(:,i,1-j,L)
+ end do
+ end do
+ end do
+ else
+ do L=1,lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j,L)= W(:,i,j,L)+rBuf_S(:,i,j,L)
+ end do
+ end do
+ end do
+ endif
+
+! From north
+
+ if(lnorth) then
+ do L=1,lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+W(:,i,jmax+nby-j,L)
+ enddo
+ enddo
+ enddo
+ else
+ do L=1,lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+rBuf_N(:,i,j,L)
+ enddo
+ enddo
+ enddo
+ endif
+
+!----------------------------------------------------------------------
+!
+! Set up mirror b.c. at the bottom and top of domain
+!
+ do L=1,nbz
+ W(:,:,:,1+L )=W(:,:,:, 1+L)+W(:,:,:, 1-L)
+ W(:,:,:,LM-L)=W(:,:,:,LM-L)+W(:,:,:,LM+L)
+ end do
+
+
+!----------------------------------------------------------------------
+!
+! DEALLOCATE sBufferes
+!
+
+
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_W, stat = ierr )
+ end if
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_E, stat = ierr )
+ end if
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_S, stat = ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_N, stat = ierr )
+ end if
+
+
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+
+ if( itarg_w >= 0 ) then
+ deallocate( rBuf_W, stat = iderr)
+ endif
+ if( itarg_e >= 0 ) then
+ deallocate( rBuf_E, stat = iderr)
+ endif
+ if( itarg_s >= 0 ) then
+ deallocate( rBuf_S, stat = iderr)
+ endif
+ if( itarg_n >= 0 ) then
+ deallocate( rBuf_N, stat = iderr)
+ endif
+
+
+!-----------------------------------------------------------------------
+endsubroutine bocoT_3d_g1
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocoT_3d_gh &
+!***********************************************************************
+! *
+! Supply n-lines inside of domains, including edges, with halos from *
+! the surrounding domains. Assume mirror boundary conditions at the *
+! boundaries of the domain *
+! !
+! - offset version - !
+! *
+!***********************************************************************
+(this,W,km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max
+real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) &
+ ,intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:,:):: &
+ sBuf_N,sBuf_E,sBuf_S,sBuf_W &
+ ,rBuf_N,rBuf_E,rBuf_S,rBuf_W
+
+integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax
+logical lwest,least,lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,L,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax,ndatay
+logical l_sidesend
+integer(i_kind) g_ind,g,k
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Limit comminications to selected number of generations
+!
+
+ if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then
+ g_ind=2
+ g = my_hgen
+ l_sidesend=.true.
+ else
+ l_sidesend=.false.
+ endif
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+FILT_GRID: if(l_sidesend) then
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!
+! from mg_domain
+!
+ itarg_n = Fitarg_n(g_ind)
+ itarg_s = Fitarg_s(g_ind)
+ itarg_w = Fitarg_w(g_ind)
+ itarg_e = Fitarg_e(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+ if(least) then
+ imax = Fimax_in(g)
+ else
+ imax = im_in ! << Note that is not necesseraly im from
+ endif ! mg_parameter. Could be also imL >>>
+ if(lnorth) then
+ jmax = Fjmax_in(g)
+ else
+ jmax = jm_in
+ endif
+
+
+!----------------------------------------------------------------------
+ ndatax =km_in*(jmax+2*nby)*nbx *Lm_in
+ ndatay =km_in*imax*nby *Lm_in
+
+!
+! SEND extended halos toward WEST and EAST
+!
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+
+ do L=Lm_in,1,-1
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_W(:,i,j,L) = W(:,-nbx+i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+
+ do L=Lm_in,1,-1
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_E(:,i,j,L) = W(:,imax+i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+ end if
+
+!
+! RECEIVE extended halos from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+
+ allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+
+ allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+
+ end if
+
+!
+! Assign received extended halos from WEST and EAST
+!
+
+! From west
+
+ if(lwest) then
+ do L=1,lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,i,j,L)= W(:,i,j,L)+W(:,1-i,j,L)
+ end do
+ end do
+ end do
+ else
+ do L=1,lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,i,j,L)= W(:,i,j,L)+rBuf_W(:,i,j,L)
+ end do
+ end do
+ end do
+ endif
+
+! From east
+
+ if(least) then
+ do L=1,lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+W(:,imax+1+nbx-i,j,L)
+ end do
+ end do
+ end do
+ else
+ do L=1,lm_in
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+rBuf_E(:,i,j,L)
+ end do
+ end do
+ end do
+ endif
+
+!
+! SEND halos toward SOUTH and NORTH
+!
+
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr )
+
+ do L=Lm_in,1,-1
+ do j=1-nby,0
+ do i=1,imax
+ sBuf_S(:,i,j+nby,L) = W(:,i,j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr )
+
+ do L=Lm_in,1,-1
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j,L)=W(:,i,jmax+j,L)
+ enddo
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+
+ end if
+
+!
+! RECEIVE halos from NORTH and SOUTH
+!
+!
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+
+ allocate( rBuf_N(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+
+ allocate( rBuf_S(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+
+ end if
+
+
+!-----------------------------------------------------------------------
+!
+! Assign received halos from SOUTH and NORTH
+!
+
+ if(lsouth) then
+ do L=1,lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j,L)= W(:,i,j,L)+W(:,i,1-j,L)
+ end do
+ end do
+ end do
+ else
+ do L=1,lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j,L)= W(:,i,j,L)+rBuf_S(:,i,j,L)
+ end do
+ end do
+ end do
+ endif
+
+! From north
+
+ if(lnorth) then
+ do L=1,lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+W(:,i,jmax+1+nby-j,L)
+ enddo
+ enddo
+ enddo
+ else
+ do L=1,lm_in
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+rBuf_N(:,i,j,L)
+ enddo
+ enddo
+ enddo
+ endif
+
+
+!
+! Set up mirror b.c. at the bottom and top of domain
+!
+ do L=1,nbz
+ W(:,:,:,1+L )=W(:,:,:, 1+L)+W(:,:,:, 1-L)
+ W(:,:,:,LM-L)=W(:,:,:,LM-L)+W(:,:,:,LM+L)
+ end do
+
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE sBufferes
+!
+
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_W, stat = ierr )
+ end if
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_E, stat = ierr )
+ end if
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_S, stat = ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_N, stat = ierr )
+ end if
+!
+! DEALLOCATE rBufferes
+!
+
+ if( itarg_w >= 0 ) then
+ deallocate( rBuf_W, stat = iderr)
+ endif
+ if( itarg_e >= 0 ) then
+ deallocate( rBuf_E, stat = iderr)
+ endif
+ if( itarg_s >= 0 ) then
+ deallocate( rBuf_S, stat = iderr)
+ endif
+ if( itarg_n >= 0 ) then
+ deallocate( rBuf_N, stat = iderr)
+ endif
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+ endif FILT_GRID
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine bocoT_3d_gh
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsend_all_g1 &
+!***********************************************************************
+! !
+! Upsend data from generation one to generation two !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,Harray,Warray,km_in)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in
+real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray
+real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE &
+ ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE
+
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,ndata,i,j
+integer(i_kind) isend,irecv,nebpe
+
+integer(i_kind):: mygen_dn,mygen_up
+logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne,flag_up
+integer(i_kind):: itarg_up
+integer:: g_ind
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+
+!-----------------------------------------------------------------------
+ mygen_dn=1
+ mygen_up=2
+!
+! Define generational flags
+!
+ g_ind=1
+
+ lsendup_sw=Flsendup_sw(g_ind)
+ lsendup_se=Flsendup_se(g_ind)
+ lsendup_nw=Flsendup_nw(g_ind)
+ lsendup_ne=Flsendup_ne(g_ind)
+
+
+ itarg_up=Fitarg_up(g_ind)
+
+
+!-----------------------------------------------------------------------
+
+ if(my_hgen==mygen_up) then
+ Warray(:,:,:) = 0.0d0
+ endif
+
+ ndata =km_in*imL*jmL
+
+!
+! --- Send data to SW portion of processors at higher generation
+!
+
+ if( lsendup_sw ) then
+
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_SW(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SW(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+ call MPI_WAIT( sHandle(1), istat, ierr )
+
+ deallocate( sBuf_SW, stat = ierr )
+
+ endif
+
+ endif
+!
+! --- Receive SW portion of data at higher generation
+!
+
+ if( my_hgen==mygen_up .and. itargdn_sw >= 0 ) then
+
+ nebpe = itargdn_sw
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ Warray(:,i,j)=dBuf_SW(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!
+! --- Send data to SE portion of processors at higher generation
+!
+
+ if( lsendup_se ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_SE(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SE(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+ call MPI_WAIT( sHandle(2), istat, ierr )
+
+ deallocate( sBuf_SE, stat = ierr )
+
+ endif
+
+ end if
+
+!
+! --- Receive SE portion of data at higher generation
+!
+
+ if( my_hgen==mygen_up .and. itargdn_se >= 0 ) then
+
+ nebpe = itargdn_se
+
+ if(nebpe /= mype) then
+
+ call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ endif
+ do j=1,jmL
+ do i=1,imL
+ Warray(:,imL+i,j)=dBuf_SE(:,i,j)
+ enddo
+ enddo
+
+ endif
+!
+! --- Send data to NW portion of processors at higher generation
+!
+
+ if( lsendup_nw ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_NW(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NW(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(3), isend)
+
+ call MPI_WAIT( sHandle(3), istat, ierr )
+
+ deallocate( sBuf_NW, stat = ierr )
+
+ end if
+
+ end if
+
+!
+! --- Receive NW portion of data at higher generation
+!
+
+ if( my_hgen==mygen_up .and. itargdn_nw >= 0 ) then
+
+ nebpe = itargdn_nw
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ Warray(:,i,jmL+j)=dBuf_NW(:,i,j)
+ enddo
+ enddo
+
+ endif
+!
+! --- Send data to NE portion of processors at higher generation
+!
+
+ if( lsendup_ne ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_NE(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NE(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(4), isend)
+ call MPI_WAIT( sHandle(4), istat, ierr )
+
+ deallocate( sBuf_NE, stat = ierr )
+
+ endif
+
+ end if
+
+!
+! --- Receive NE portion of data at higher generation
+!
+
+ if( my_hgen==mygen_up .and. itargdn_ne >= 0 ) then
+
+ nebpe = itargdn_ne
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ Warray(:,imL+i,jmL+j)=dBuf_NE(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+!-----------------------------------------------------------------------
+endsubroutine upsend_all_g1
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsend_all_gh &
+!***********************************************************************
+! *
+! Upsend data from one grid generation to another *
+! (Just for high grid generations) *
+! !
+! - offset version - !
+! *
+!***********************************************************************
+(this,Harray,Warray,km_in,mygen_dn,mygen_up)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in
+real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray
+real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray
+integer(i_kind),intent(in):: mygen_dn,mygen_up
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE &
+ ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE
+
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L
+integer(i_kind) isend,irecv,nebpe
+
+logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne,flag_up
+integer(i_kind):: itarg_up
+integer:: g_ind
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+
+!-----------------------------------------------------------------------
+!
+! Define generational flags
+!
+
+ g_ind=2
+
+ lsendup_sw=Flsendup_sw(g_ind).and.(my_hgen==mygen_dn)
+ lsendup_se=Flsendup_se(g_ind).and.(my_hgen==mygen_dn)
+ lsendup_nw=Flsendup_nw(g_ind).and.(my_hgen==mygen_dn)
+ lsendup_ne=Flsendup_ne(g_ind).and.(my_hgen==mygen_dn)
+
+ itarg_up=Fitarg_up(g_ind)
+
+
+!-----------------------------------------------------------------------
+
+ if(my_hgen==mygen_up) then
+ Warray(:,:,:)=0.0d0
+ endif
+
+ ndata =km_in*imL*jmL
+
+ if( lsendup_sw ) then
+
+ nebpe = itarg_up
+
+
+ allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SW(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+ call MPI_WAIT( sHandle(1), istat, ierr )
+
+ deallocate( sBuf_SW, stat = ierr )
+
+
+ end if
+
+!
+! --- Receive SW portion of data at higher generation
+!
+
+ if( my_hgen==mygen_up .and. itargdn_sw >= 0 ) then
+
+ nebpe = itargdn_sw
+
+ allocate( rBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Warray(:,i,j)=Rbuf_SW(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!
+! --- Send data to SE portion of processors at higher generation
+!
+
+ if( lsendup_se ) then
+ nebpe = itarg_up
+
+
+ allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SE(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+
+ call MPI_WAIT( sHandle(2), istat, ierr )
+
+ deallocate( sBuf_SE, stat = ierr )
+
+ end if
+
+!
+! --- Receive SE portion of data at higher generation
+
+
+ if( my_hgen==mygen_up .and. itargdn_se >= 0 ) then
+ nebpe = itargdn_se
+
+
+ allocate( rBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Warray(:,imL+i,j)=Rbuf_SE(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+!
+! --- Send data to NW portion of processors at higher generation
+!
+
+ if( lsendup_nw ) then
+ nebpe = itarg_up
+
+ allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NW(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+
+ call MPI_WAIT( sHandle(3), istat, ierr )
+
+ deallocate( sBuf_NW, stat = ierr )
+
+
+ end if
+
+!
+! --- Receive NW portion of data at higher generation
+!
+
+ if( my_hgen==mygen_up .and. itargdn_nw >= 0 ) then
+ nebpe = itargdn_nw
+
+
+ allocate( rBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Warray(:,i,jmL+j)=rBuf_NW(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_NW, stat = iderr)
+
+ end if
+
+!
+! --- Send data to NE portion of processors at higher generation
+!
+
+ if( lsendup_ne ) then
+ nebpe = itarg_up
+
+ allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NE(:,i,j) = Harray(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+
+ call MPI_WAIT( sHandle(4), istat, ierr )
+
+ deallocate( sBuf_NE, stat = ierr )
+
+ end if
+
+!
+! --- Receive NE portion of data at higher generation
+!
+
+ if( my_hgen==mygen_up .and. itargdn_ne >= 0 ) then
+ nebpe = itargdn_ne
+
+ allocate( rBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Warray(:,imL+i,jmL+j)=rBuf_NE(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_NE, stat = iderr)
+
+ endif
+
+!-----------------------------------------------------------------------
+endsubroutine upsend_all_gh
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsend_all_gh &
+!***********************************************************************
+! *
+! Downsending data from low resolution pes (mygen_up) *
+! to the concurent high-resolution pes (mygen_dn) *
+! and add the existing and the recevied values *
+! !
+! - offset version - !
+! *
+!***********************************************************************
+(this,Warray,Harray,km_in,mygen_up,mygen_dn)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in
+real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray
+real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray
+integer, intent(in):: mygen_up,mygen_dn
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE &
+ ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE
+
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L
+integer(i_kind) isend,irecv,nebpe
+
+logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne
+integer(i_kind):: itarg_up
+integer(i_kind):: g_ind
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+
+ Harray(:,:,:) = 0.0d0
+!
+! Define generational flags
+!
+
+ g_ind=2
+ lsendup_sw=Flsendup_sw(g_ind).and.(my_hgen==mygen_dn)
+ lsendup_se=Flsendup_se(g_ind).and.(my_hgen==mygen_dn)
+ lsendup_nw=Flsendup_nw(g_ind).and.(my_hgen==mygen_dn)
+ lsendup_ne=Flsendup_ne(g_ind).and.(my_hgen==mygen_dn)
+
+ itarg_up=Fitarg_up(g_ind)
+
+ ndata =km_in*imL*jmL
+
+!
+! --- Send data from SW portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+
+ if(my_hgen==mygen_up .and. itargdn_sw >= 0 ) then
+ nebpe = itargdn_sw
+
+
+ allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SW(:,i,j) = Warray(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_SW, stat = ierr )
+
+
+ endif
+!
+! --- Receive SW portion of data at lower generation
+
+
+ if( lsendup_sw ) then
+
+ nebpe = itarg_up
+
+
+ allocate( rBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Harray(:,i,j)=rBuf_SW(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_SW, stat = iderr)
+
+ endif
+
+!
+! --- Send data from SE portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ if(my_hgen==mygen_up .and. itargdn_se >= 0 ) then
+ nebpe = itargdn_se
+
+ allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SE(:,i,j) = Warray(:,imL+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_SE, stat = ierr )
+
+
+ endif
+!
+! --- Receive SE portion of data at lower generation
+
+
+ if( lsendup_se ) then
+ nebpe = itarg_up
+
+
+ allocate( rBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Harray(:,i,j)=Rbuf_SE(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_SE, stat = iderr)
+
+ end if
+
+!
+! --- Send data from NW portion of processors at the higher generation
+! to corresponding PE's at lower generantion
+
+ if(my_hgen==mygen_up .and. itargdn_nw >= 0 ) then
+ nebpe = itargdn_nw
+
+
+ allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NW(:,i,j) = Warray(:,i,jmL+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_NW, stat = ierr )
+
+
+ endif
+!
+! --- Receive NW portion of data at lower generation
+
+
+ if( lsendup_nw ) then
+
+ nebpe = itarg_up
+
+ allocate( rBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Harray(:,i,j)=Rbuf_NW(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_NW, stat = iderr)
+
+
+ end if
+
+
+! --- Send data from NE portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ if(my_hgen==mygen_up .and. itargdn_ne >= 0 ) then
+ nebpe = itargdn_ne
+
+
+ allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NE(:,i,j) = Warray(:,imL+i,jmL+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_NE, stat = ierr )
+
+
+ endif
+!
+! --- Receive NE portion of data at lower generation
+!
+
+ if( lsendup_ne ) then
+ nebpe = itarg_up
+
+ allocate( rBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Harray(:,i,j)=rBuf_NE(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_NE, stat = iderr)
+
+ end if
+
+!-----------------------------------------------------------------------
+endsubroutine downsend_all_gh
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsend_all_g2 &
+!***********************************************************************
+! *
+! Downsending data from low resolution pes (mygen_up) *
+! to the concurent high-resolution pes (mygen_dn) *
+! and add the existing and the recevied values *
+! *
+! - offset version - *
+! *
+!***********************************************************************
+(this,Warray,Harray,km_in)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in
+real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray
+real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE
+
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW
+real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L
+integer(i_kind) isend,irecv,nebpe
+
+logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne
+integer:: mygen_up,mygen_dn
+integer(i_kind):: itarg_up
+integer(i_kind):: g_ind
+!-----------------------------------------------------------------------
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!
+! Define generational flags
+!
+ mygen_up=2
+ mygen_dn=1
+
+ g_ind=1
+ lsendup_sw=Flsendup_sw(g_ind)
+ lsendup_se=Flsendup_se(g_ind)
+ lsendup_nw=Flsendup_nw(g_ind)
+ lsendup_ne=Flsendup_ne(g_ind)
+
+ itarg_up=Fitarg_up(g_ind)
+
+
+ ndata =km_in*imL*jmL
+
+
+!
+! Send data down to generation 1
+!
+LSEND: if(my_hgen==mygen_up) then
+!
+! --- Send data from SW portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ nebpe = itargdn_sw
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_SW(:,i,j) = Warray(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SW(:,i,j) = Warray(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_SW, stat = ierr )
+
+ endif
+!
+! --- Send data from SE portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ nebpe = itargdn_se
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_SE(:,i,j) = Warray(:,imL+i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SE(:,i,j) = Warray(:,imL+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_SE, stat = ierr )
+
+ endif
+
+! --- Send data from NW portion of processors at the higher generation
+! to corresponding PE's at lower generantion
+
+ nebpe = itargdn_nw
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_NW(:,i,j) = Warray(:,i,jmL+j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NW(:,i,j) = Warray(:,i,jmL+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(3), isend)
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_NW, stat = ierr )
+
+ endif
+
+!
+! --- Send data from NE portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ nebpe = itargdn_ne
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_NE(:,i,j) = Warray(:,imL+i,jmL+j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NE(:,i,j) = Warray(:,imL+i,jmL+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(4), isend)
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_NE, stat = ierr )
+
+ endif
+
+
+ endif LSEND
+
+!
+! --- Receive SW portion of data at lower generation
+!
+
+ if( lsendup_sw .and. mype /= itarg_up ) then
+
+ nebpe = itarg_up
+
+
+ call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+
+ else &
+
+!
+! --- Receive SE portion of data at lower generation
+
+
+ if( lsendup_se .and. mype /= itarg_up) then
+
+ nebpe = itarg_up
+
+ call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+
+ else &
+
+
+!
+! --- Receive NW portion of data at lower generation
+
+
+ if( lsendup_nw .and. mype /= itarg_up) then
+
+ nebpe = itarg_up
+
+ call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+
+ else &
+
+
+!
+! --- Receive NE portion of data at lower generation
+!
+
+ if( lsendup_ne .and. mype /= itarg_up) then
+ nebpe = itarg_up
+
+ call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+
+ end if
+
+!
+! Assign received and prescribed values
+!
+ if( lsendup_sw ) then
+
+ do j=1,jmL
+ do i=1,imL
+ Harray(:,i,j)=dBuf_SW(:,i,j)
+ enddo
+ enddo
+
+ else &
+ if( lsendup_se ) then
+
+ do j=1,jmL
+ do i=1,imL
+ Harray(:,i,j)=dBuf_SE(:,i,j)
+ enddo
+ enddo
+
+ else &
+ if( lsendup_nw ) then
+
+ do j=1,jmL
+ do i=1,imL
+ Harray(:,i,j)=dBuf_NW(:,i,j)
+ enddo
+ enddo
+
+ else &
+ if( lsendup_ne ) then
+
+ do j=1,jmL
+ do i=1,imL
+ Harray(:,i,j)=dBuf_NE(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+!-----------------------------------------------------------------------
+endsubroutine downsend_all_g2
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocox_2d_g1 &
+!**********************************************************************!
+! !
+! Side sending subroutine: !
+! Supplies nbx lines of halos in x direction assuming mirror boundary !
+! conditions at the end of domain. Version for generation 1 !
+! !
+! - offset version - !
+! !
+!**********************************************************************!
+(this,W,km_in,im_in,jm_in,nbx,nby)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby
+real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W &
+ ,rBuf_E,rBuf_W
+
+integer(i_kind) itarg_w,itarg_e,imax,jmax
+logical:: lwest,least
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,l,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax
+integer(i_kind) g_ind,g
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Limit communications to selected number of generations
+!
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+!
+! from mg_domain
+!
+ g_ind = 1
+
+ itarg_w = Fitarg_w(g_ind)
+ itarg_e = Fitarg_e(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+
+ imax = im_in
+ jmax = jm_in
+
+
+!-----------------------------------------------------------------------
+ ndatax = km_in*jmax*nbx
+
+!----------------------------------------------------------------------
+!
+! SEND extended boundaries toward WEST and EAST
+!
+
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km_in,nbx,1:jmax), stat = iaerr )
+
+ do j=1,jmax
+ do i=1,nbx
+ sBuf_W(:,i,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km_in,nbx,1:jmax), stat = iaerr )
+
+ do j=1,jmax
+ do i=1,nbx
+ sBuf_E(:,i,j) = W(:,imax-nbx+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE boundaries from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( rBuf_E(1:km_in,nbx,1:jmax), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+ allocate( rBuf_W(1:km_in,nbx,1:jmax), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ end if
+
+
+!
+! Assign received values from EAST and WEST
+!
+
+! From west
+
+ if(lwest) then
+
+ do j=1,jmax
+ do i=1,nbx
+ W(:,-nbx+i,j)= W(:,nbx+1-i,j)
+ end do
+ end do
+
+ else
+
+ do j=1,jmax
+ do i=1,nbx
+ W(:,-nbx+i,j)= rBuf_W(:,i,j)
+ enddo
+ enddo
+
+
+ endif
+
+! From east
+
+ if(least) then
+
+ do j=1,jmax
+ do i=1,nbx
+ W(:,imax+i,j)=W(:,imax+1-i,j)
+ end do
+ end do
+
+ else
+
+ do j=1,jmax
+ do i=1,nbx
+ W(:,imax+i,j)=rBuf_E(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+
+ if( itarg_e >= 0 ) then
+ deallocate( rBuf_E, stat = iderr)
+ endif
+ if( itarg_w >= 0 ) then
+ deallocate( rBuf_W, stat = iderr)
+ endif
+
+!
+! DEALLOCATE sBufferes
+!
+
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_E, stat = ierr )
+ end if
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_W, stat = ierr )
+ end if
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine bocox_2d_g1
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocox_2d_gh &
+!**********************************************************************!
+! !
+! Side sending subroutine: !
+! Supplies nbx lines of halos in x direction assuming mirror boundary !
+! conditions at the end of domain. Version for high generations !
+! !
+! - offset version - !
+! !
+!**********************************************************************!
+(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W &
+ ,rBuf_E,rBuf_W
+
+integer(i_kind) itarg_w,itarg_e,imax,jmax
+logical:: lwest,least,lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,l,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax
+integer(i_kind) g_ind,g
+logical l_sidesend
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Limit communications to selected number of generations
+!
+
+ if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then
+ g_ind=2
+ g = my_hgen
+ l_sidesend=.true.
+ else
+ l_sidesend=.false.
+ endif
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+FILT_GRID: if(l_sidesend) then
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+!
+! from mg_domain
+!
+ itarg_w = Fitarg_w(g_ind)
+ itarg_e = Fitarg_e(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+
+ if(least) then
+ imax = Fimax_in(g)
+ else
+ imax = im ! << Note that is not necesseraly im from
+ endif ! mg_parameter. Could be also imL >>>
+ if(lnorth) then
+ jmax = Fjmax_in(g)
+ else
+ jmax = jm
+ endif
+
+
+!-----------------------------------------------------------------------
+ ndatax = km_in*jmax*nbx
+
+!
+! SEND halos to WEST and EASTH
+!
+
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km_in,nbx,1:jmax), stat = iaerr )
+
+ do j=1,jmax
+ do i=1,nbx
+ sBuf_W(:,i,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km_in,nbx,1:jmax), stat = iaerr )
+
+ do j=1,jmax
+ do i=1,nbx
+ sBuf_E(:,i,j) = W(:,imax-nbx+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE extended boundaries from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( rBuf_E(1:km_in,nbx,1:jmax), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+ allocate( rBuf_W(1:km_in,nbx,1:jmax), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ end if
+
+!
+! Assign received values from WEST and EAST
+!
+
+! From west
+
+ if(lwest) then
+
+ do j=1,jmax
+ do i=1,nbx
+ W(:,-nbx+i,j)= W(:,nbx+1-i,j)
+ end do
+ end do
+
+ else
+
+ do j=1,jmax
+ do i=1,nbx
+ W(:,-nbx+i,j)= rBuf_W(:,i,j)
+ enddo
+ enddo
+
+
+ endif
+
+! From east
+
+ if(least) then
+
+ do j=1,jmax
+ do i=1,nbx
+ W(:,imax+i,j)=W(:,imax-i,j)
+ end do
+ end do
+
+ else
+
+ do j=1,jmax
+ do i=1,nbx
+ W(:,imax+i,j)=rBuf_E(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+
+ if( itarg_e >= 0 ) then
+ deallocate( rBuf_E, stat = iderr)
+ endif
+ if( itarg_w >= 0 ) then
+ deallocate( rBuf_W, stat = iderr)
+ endif
+
+!
+! DEALLOCATE sBufferes
+!
+
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_E, stat = ierr )
+ end if
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_W, stat = ierr )
+ end if
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+ endif FILT_GRID
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine bocox_2d_gh
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocoy_2d_g1 &
+!**********************************************************************!
+! !
+! Side sending subroutine: !
+! Supplies nby lines of halos in y direction assuming mirror boundary !
+! conditions at the end of domain. Version for generation 1 !
+! !
+! - offset version - !
+! !
+!**********************************************************************!
+(this,W,km_in,im_in,jm_in,nbx,nby)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby
+real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S &
+ ,rBuf_N,rBuf_S
+
+integer(i_kind) itarg_n,itarg_s,imax,jmax
+logical:: lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,l,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatay
+integer(i_kind) g_ind,g
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Limit communications to selected number of generations
+!
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+!
+! from mg_domain
+!
+ g_ind = 1
+
+ itarg_n = Fitarg_n(g_ind)
+ itarg_s = Fitarg_s(g_ind)
+
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+ imax = im_in
+ jmax = jm_in
+
+
+!-----------------------------------------------------------------------
+ ndatay = km_in*imax*nby
+
+
+!
+! SEND boundaries toward SOUTH and NORTH
+!
+
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_S(:,i,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j)=W(:,i,jmax-nby+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+
+ end if
+
+!
+! RECEIVE boundaries from NORTH and SOUTH
+!
+
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ end if
+!
+! Assign received values from NORTH and SOUTH
+!
+
+! --- from NORTH ---
+
+ if( lnorth) then
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j)=W(:,i,jmax+1-j)
+ enddo
+ enddo
+
+ else
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j)=rBuf_N(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+! From SOUTH
+
+ if(lsouth) then
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j)=W(:,i,nby+1-j)
+ end do
+ end do
+
+ else
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j)=rBuf_S(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+
+ if( itarg_s >= 0 ) then
+ deallocate( rBuf_S, stat = iderr)
+ endif
+ if( itarg_n >= 0 ) then
+ deallocate( rBuf_N, stat = iderr)
+ endif
+
+!
+! DEALLOCATE sBufferes
+!
+
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_S, stat = ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_N, stat = ierr )
+ end if
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine bocoy_2d_g1
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocoy_2d_gh &
+!**********************************************************************!
+! !
+! Side sending subroutine: !
+! Supplies nby lines of halos in y direction assuming mirror boundary !
+! conditions at the end of domain. Version for high generations !
+! !
+! - offset version - !
+! !
+!**********************************************************************!
+(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S &
+ ,rBuf_N,rBuf_S
+
+integer(i_kind) itarg_n,itarg_s,imax,jmax
+logical:: lwest,least,lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,l,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatay
+integer(i_kind) g_ind,g
+logical l_sidesend
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Limit communications to selected number of generations
+!
+
+ if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then
+ g_ind=2
+ g = my_hgen
+ l_sidesend=.true.
+ else
+ l_sidesend=.false.
+ endif
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+FILT_GRID: if(l_sidesend) then
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+!
+! from mg_domain
+!
+ itarg_n = Fitarg_n(g_ind)
+ itarg_s = Fitarg_s(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+
+ if(least) then
+ imax = Fimax_in(g)
+ else
+ imax = im_in ! << Note that is not necesseraly im from
+ endif ! mg_parameter. Could be also imL >>>
+ if(lnorth) then
+ jmax = Fjmax_in(g)
+ else
+ jmax = jm_in
+ endif
+
+
+!-----------------------------------------------------------------------
+ ndatay = km_in*imax*nby
+
+!
+! SEND boundaries to SOUTH and NORTH
+!
+
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_S(:,i,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j)=W(:,i,jmax-nby+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+
+ end if
+!
+! RECEIVE boundaries from NORTH and SOUTH
+!
+
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ end if
+
+!
+! Assign received values from NORTH and SOUTH
+!
+
+! --- from NORTH ---
+
+ if( lnorth) then
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j)=W(:,i,jmax+1-j)
+ enddo
+ enddo
+
+ else
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j)=rBuf_N(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+! From south
+
+ if(lsouth) then
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j)=W(:,i,nby+1-j)
+ end do
+ end do
+
+ else
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j)=rBuf_S(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+
+ if( itarg_s >= 0 ) then
+ deallocate( rBuf_S, stat = iderr)
+ endif
+ if( itarg_n >= 0 ) then
+ deallocate( rBuf_N, stat = iderr)
+ endif
+
+!
+! DEALLOCATE sBufferes
+!
+
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_S, stat = ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_N, stat = ierr )
+ end if
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+ endif FILT_GRID
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine bocoy_2d_gh
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocoTx_2d_g1 &
+!***********************************************************************
+! !
+! Side sending subroutine: !
+! Supplies nbx lines close to edges of the subdomins from neighboring !
+! halos in x direction assuming mirror boundary conditions !
+! Version for generation 1 !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,km_in,im_in,jm_in,nbx,nby)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby
+real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W &
+ ,rBuf_E,rBuf_W
+
+integer(i_kind) itarg_w,itarg_e,imax,jmax
+logical lwest,least
+
+integer(i_kind) sHandle(2),rHandle(2),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,L,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax
+logical l_sidesend
+integer(i_kind) g_ind,g,k
+!-----------------------------------------------------------------------
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!
+! Limit comminications to selected number of generations
+!
+
+
+ g_ind=1
+!
+! from mg_domain
+!
+ itarg_w = Fitarg_w(g_ind)
+ itarg_e = Fitarg_e(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+
+ imax = im_in
+ jmax = jm_in
+
+
+!----------------------------------------------------------------------
+ ndatax =km_in*jmax*nbx
+
+!
+! SEND halos toward WEST and EAST
+!
+
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr )
+
+ do j=1,jmax
+ do i=1-nbx,0
+ sBuf_W(:,i+nbx,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr )
+
+ do j=1,jmax
+ do i=1,nbx
+ sBuf_E(:,i,j) = W(:,imax+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE halos from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+
+ allocate( rBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+
+ allocate( rBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+
+ end if
+
+!
+! Assign received halos from WEST and EAST to interrior of domains
+!
+
+! From west
+
+ if(lwest) then
+ do j=1,jmax
+ do i=1,nbx
+ W(:,i,j)= W(:,i,j)+W(:,1-i,j)
+ end do
+ end do
+ else
+ do j=1,jmax
+ do i=1,nbx
+ W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j)
+ end do
+ end do
+ endif
+
+! From east
+
+ if(least) then
+ do j=1,jmax
+ do i=1,nbx
+ W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+nbx+1-i,j)
+ end do
+ end do
+ else
+ do j=1,jmax
+ do i=1,nbx
+ W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j)
+ end do
+ end do
+ endif
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+
+ if( itarg_w >= 0 ) then
+ deallocate( rBuf_W, stat = iderr)
+ endif
+ if( itarg_e >= 0 ) then
+ deallocate( rBuf_E, stat = iderr)
+ endif
+
+!
+! DEALLOCATE sBufferes
+!
+
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ end if
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ end if
+
+!-----------------------------------------------------------------------
+endsubroutine bocoTx_2d_g1
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocoTx_2d_gh &
+!***********************************************************************
+! !
+! Side sending subroutine: !
+! Supplies nbx lines close to edges of the subdomins from neighboring !
+! halos in x direction assuming mirror boundary conditions !
+! Version for high generations !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W &
+ ,rBuf_E,rBuf_W
+integer(i_kind) itarg_w,itarg_e,imax,jmax
+logical lwest,least,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,L,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax,ndatay
+logical l_sidesend
+integer(i_kind) g_ind,g,k
+!-----------------------------------------------------------------------
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!
+! Limit comminications to selected number of generations
+!
+
+ if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then
+ g_ind=2
+ g = my_hgen
+ l_sidesend=.true.
+ else
+ l_sidesend=.false.
+ endif
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+FILT_GRID: if(l_sidesend) then
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!
+! from mg_domain
+!
+ itarg_w = Fitarg_w(g_ind)
+ itarg_e = Fitarg_e(g_ind)
+
+ lwest = Flwest(g_ind)
+ least = Fleast(g_ind)
+
+ lnorth = Flnorth(g_ind)
+
+
+ if(least) then
+ imax = Fimax_in(g)
+ else
+ imax = im_in ! << Note that is not necesseraly im from
+ endif ! mg_parameter. Could be also imL >>>
+ if(lnorth) then
+ jmax = Fjmax_in(g)
+ else
+ jmax = jm_in
+ endif
+
+
+!----------------------------------------------------------------------
+ ndatax =km_in*jmax*nbx
+!
+! SEND halos toward WEST and EAST
+!
+
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr )
+
+ do j=1,jmax
+ do i=1-nbx,0
+ sBuf_W(:,i+nbx,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr )
+
+ do j=1,jmax
+ do i=1,nbx
+ sBuf_E(:,i,j) = W(:,imax+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE halos from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( rBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+ allocate( rBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ end if
+!
+! Assign received values from WEST and EAST
+!
+
+! From west
+
+ if(lwest) then
+ do j=1,jmax
+ do i=1,nbx
+ W(:,i,j)= W(:,i,j)+W(:,1-i,j)
+ end do
+ end do
+ else
+ do j=1,jmax
+ do i=1,nbx
+ W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j)
+ end do
+ end do
+ endif
+
+! From east
+
+ if(least) then
+ do j=1,jmax
+ do i=1,nbx
+ W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+nbx+1-i,j)
+ end do
+ end do
+ else
+ do j=1,jmax
+ do i=1,nbx
+ W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j)
+ end do
+ end do
+ endif
+
+!-----------------------------------------------------------------------
+
+! DEALLOCATE rBufferes
+
+ if( itarg_w >= 0 ) then
+ deallocate( rBuf_W, stat = iderr)
+ end if
+ if( itarg_e >= 0 ) then
+ deallocate( rBuf_E, stat = iderr)
+ end if
+
+! DEALLOCATE sBufferes
+
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ end if
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ end if
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+ endif FILT_GRID
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine bocoTx_2d_gh
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocoTy_2d_g1 &
+!***********************************************************************
+! !
+! Side sending subroutine: !
+! Supplies nby lines close to edges of the subdomins from neighboring !
+! halos in y direction assuming mirror boundary conditions !
+! Version for generation 1 !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,km_in,im_in,jm_in,nbx,nby)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby
+real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S &
+ ,rBuf_N,rBuf_S
+
+integer(i_kind) itarg_n,itarg_s,imax,jmax
+logical lsouth,lnorth
+
+integer(i_kind) sHandle(2),rHandle(2),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,L,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatay
+logical l_sidesend
+integer(i_kind) g_ind,g,k
+!-----------------------------------------------------------------------
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!
+! Limit comminications to selected number of generations
+!
+
+ g_ind=1
+!
+! from mg_domain
+!
+ itarg_n = Fitarg_n(g_ind)
+ itarg_s = Fitarg_s(g_ind)
+
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+ imax = im_in
+ jmax = jm_in
+
+
+!----------------------------------------------------------------------
+ ndatay =km_in*imax*nby
+
+!
+! SEND SOUTH and NORTH halos
+!
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr )
+
+ do j=1-nby,0
+ do i=1,imax
+ sBuf_S(:,i,j+nby) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j)=W(:,i,jmax+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE halos from NORTH and SOUTH
+!
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+
+ allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+
+ allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+
+ end if
+
+!
+! ASSIGN received values from SOUTH and NORTH
+!
+
+! From south
+
+ if(lsouth) then
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j)= W(:,i,j)+W(:,i,1-j)
+ end do
+ end do
+ else
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j)
+ end do
+ end do
+ endif
+
+! From north
+
+ if(lnorth) then
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+nby+1-j)
+ enddo
+ enddo
+ else
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j)
+ enddo
+ enddo
+ endif
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+
+ if( itarg_s >= 0 ) then
+ deallocate( rBuf_S, stat = iderr)
+ end if
+ if( itarg_n >= 0 ) then
+ deallocate( rBuf_N, stat = iderr)
+ end if
+
+!
+! DEALLOCATE sBufferes
+!
+
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ end if
+
+
+!-----------------------------------------------------------------------
+endsubroutine bocoTy_2d_g1
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocoTy_2d_gh &
+!***********************************************************************
+! !
+! Side sending subroutine: !
+! Supplies nby lines close to edges of the subdomins from neighboring !
+! halos in y direction assuming mirror boundary conditions !
+! Version for high generations !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S &
+ ,rBuf_N,rBuf_S
+integer(i_kind) itarg_n,itarg_s,itarg_e,imax,jmax
+logical least,lsouth,lnorth
+
+integer(i_kind) sHandle(2),rHandle(2),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,L,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatay
+logical l_sidesend
+integer(i_kind) g_ind,g,k
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Limit comminications to selected number of generations
+!
+
+
+ if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then
+ g_ind=2
+ g = my_hgen
+ l_sidesend=.true.
+ else
+ l_sidesend=.false.
+ endif
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+FILT_GRID: if(l_sidesend) then
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!
+! from mg_domain
+!
+ itarg_n = Fitarg_n(g_ind)
+ itarg_s = Fitarg_s(g_ind)
+
+ least = Fleast(g_ind)
+ lsouth = Flsouth(g_ind)
+ lnorth = Flnorth(g_ind)
+
+
+ if(least) then
+ imax = Fimax_in(g)
+ else
+ imax = im_in ! << Note that is not necesseraly im from
+ endif ! mg_parameter. Could be also imL >>>
+ if(lnorth) then
+ jmax = Fjmax_in(g)
+ else
+ jmax = jm_in
+ endif
+
+
+!----------------------------------------------------------------------
+
+ ndatay =km_in*imax*nby
+!
+! SEND halos toward SOUTH and NORTH
+!
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr )
+
+ do j=1-nby,0
+ do i=1,imax
+ sBuf_S(:,i,j+nby) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j)=W(:,i,jmax+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE halos from NORTH and SOUTH
+!
+!
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+
+ allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+
+ allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+
+ end if
+
+!
+! Assign received values from SOUTH and NORTH
+!
+
+! From south
+
+ if(lsouth) then
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j)= W(:,i,j)+W(:,i,1-j)
+ end do
+ end do
+ else
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j)
+ end do
+ end do
+ endif
+
+! From north
+
+ if(lnorth) then
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+nby+1-j)
+ enddo
+ enddo
+ else
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j)
+ enddo
+ enddo
+ endif
+
+!-----------------------------------------------------------------------
+
+! DEALLOCATE rBufferes
+
+ if( itarg_s >= 0 ) then
+ deallocate( rBuf_S, stat = iderr)
+ end if
+ if( itarg_n >= 0 ) then
+ deallocate( rBuf_N, stat = iderr)
+ end if
+
+! DEALLOCATE sBufferes
+
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ end if
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+ endif FILT_GRID
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine bocoTy_2d_gh
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine boco_2d_loc &
+!**********************************************************************!
+! !
+! Side sending subroutine: !
+! Supplies (nbx,nby) lines of halos in (x,y) directions assuming !
+! mirror boundary conditions. Version for localiztion !
+! !
+! - offset version - !
+! !
+!**********************************************************************!
+(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g
+real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_N,sBuf_E,sBuf_S,sBuf_W &
+ ,rBuf_N,rBuf_E,rBuf_S,rBuf_W
+
+integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax
+logical:: lwest,least,lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,l,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax,ndatay
+integer(i_kind) g_ind
+logical l_sidesend
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Limit communications to selected number of generations
+!
+
+ l_sidesend=.true.
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+FILT_GRID: if(l_sidesend) then
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+!
+! from mg_domain
+!
+ itarg_n = Fitarg_n_loc(g)
+ itarg_s = Fitarg_s_loc(g)
+ itarg_w = Fitarg_w_loc(g)
+ itarg_e = Fitarg_e_loc(g)
+
+ lwest = Flwest_loc(g)
+ least = Fleast_loc(g)
+ lsouth = Flsouth_loc(g)
+ lnorth = Flnorth_loc(g)
+
+
+!
+! Keep this for now but use only Mod(nxm,8)=Mod(nym,8)=0
+!
+
+ if(least) then
+ imax = Fimax_in(g)
+ else
+ imax = im_in ! << Note that is not necesseraly im from
+ endif ! mg_parameter. Could be also imL >>>
+ if(lnorth) then
+ jmax = Fjmax_in(g)
+ else
+ jmax = jm_in
+ endif
+
+
+!-----------------------------------------------------------------------
+ ndatay = km_in*imax*nby
+ ndatax = km_in*(jmax+2*nby)*nbx
+
+
+!
+! SEND boundaries to SOUTH and NORTH
+!
+
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_S(:,i,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j)=W(:,i,jmax-nby+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+
+ end if
+!
+! RECEIVE boundaries from NORTH and SOUTH
+!
+
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ end if
+
+!
+! Assign received values from NORTH and SOUTH
+!
+
+
+! From south
+
+ if(lsouth) then
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j)=W(:,i,nby+1-j)
+ end do
+ end do
+
+ else
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,-nby+j)=rBuf_S(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+! --- from NORTH ---
+
+ if( lnorth) then
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j)=W(:,i,jmax+1-j)
+ enddo
+ enddo
+
+ else
+
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax+j)=rBuf_N(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!
+! SEND extended boundaries to WEST and EASTH
+!
+
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_W(:,i,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_E(:,i,j) = W(:,imax-nbx+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE extended boundaries from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( rBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+ allocate( rBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ end if
+
+!
+! Assign received values from WEST and EAST
+!
+
+! From west
+
+ if(lwest) then
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,-nbx+i,j)= W(:,nbx+1-i,j)
+ end do
+ end do
+
+ else
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,-nbx+i,j)= rBuf_W(:,i,j)
+ enddo
+ enddo
+
+
+ endif
+
+! From east
+
+ if(least) then
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax+i,j)=W(:,imax+1-i,j)
+ end do
+ end do
+
+ else
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax+i,j)=rBuf_E(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!-----------------------------------------------------------------------
+!
+! DEALLOCATE rBufferes
+!
+ if( itarg_w >= 0 ) then
+ deallocate( rBuf_W, stat = iderr)
+ end if
+ if( itarg_e >= 0 ) then
+ deallocate( rBuf_E, stat = iderr)
+ end if
+ if( itarg_s >= 0 ) then
+ deallocate( rBuf_S, stat = iderr)
+ end if
+ if( itarg_n >= 0 ) then
+ deallocate( rBuf_N, stat = iderr)
+ end if
+
+!
+! DEALLOCATE sBufferes
+!
+
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_W, stat = ierr )
+ end if
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_E, stat = ierr )
+ end if
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_S, stat = ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_N, stat = ierr )
+ end if
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+ endif FILT_GRID
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine boco_2d_loc
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine bocoT_2d_loc &
+!***********************************************************************
+! !
+! Supply n-lines inside of domains, including edges, with halos from !
+! the surrounding domains. Assume mirror boundary conditions at the !
+! boundaries of the domain. Vesrion for localization. !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g
+real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_N,sBuf_E,sBuf_S,sBuf_W &
+ ,rBuf_N,rBuf_E,rBuf_S,rBuf_W
+integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax
+logical lwest,least,lsouth,lnorth
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,L,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind) ndatax,ndatay
+logical l_sidesend
+integer(i_kind) g_ind,k
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Limit comminications to selected number of generations
+!
+
+
+ g_ind=g
+ l_sidesend=.true.
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+FILT_GRID: if(l_sidesend) then
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!
+! from mg_domain
+!
+ itarg_n = Fitarg_n_loc(g_ind)
+ itarg_s = Fitarg_s_loc(g_ind)
+ itarg_w = Fitarg_w_loc(g_ind)
+ itarg_e = Fitarg_e_loc(g_ind)
+
+ lwest = Flwest_loc(g_ind)
+ least = Fleast_loc(g_ind)
+ lsouth = Flsouth_loc(g_ind)
+ lnorth = Flnorth_loc(g_ind)
+
+
+ if(least) then
+ imax = Fimax_in(g)
+ else
+ imax = im_in ! << Note that is not necesseraly im from
+ endif ! mg_parameter. Could be also imL >>>
+ if(lnorth) then
+ jmax = Fjmax_in(g)
+ else
+ jmax = jm_in
+ endif
+
+
+!----------------------------------------------------------------------
+ ndatax =km_in*(jmax+2*nby)*nbx
+ ndatay =km_in*imax*nby
+
+!
+! SEND extended halos toward WEST and EAST
+!
+
+! --- toward WEST ---
+
+ if( itarg_w >= 0) then
+ nebpe = itarg_w
+
+ allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_W(:,i,j) = W(:,-nbx+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+
+ end if
+
+! --- toward EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ sBuf_E(:,i,j) = W(:,imax+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+
+ end if
+
+!
+! RECEIVE extended halos from EAST and WEST
+!
+
+! --- from EAST ---
+
+ if( itarg_e >= 0 ) then
+ nebpe = itarg_e
+
+ allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ end if
+
+! --- from WEST ---
+
+ if( itarg_w >= 0 ) then
+ nebpe = itarg_w
+
+ allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr )
+ call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ end if
+!
+! Assign received values from WEST and EAST
+!
+
+! From west
+
+ if(lwest) then
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,i,j)= W(:,i,j)+W(:,1-i,j)
+ end do
+ end do
+ else
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j)
+ end do
+ end do
+ endif
+
+! From east
+
+ if(least) then
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+1+nbx-i,j)
+ end do
+ end do
+ else
+ do j=1-nby,jmax+nby
+ do i=1,nbx
+ W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j)
+ end do
+ end do
+ endif
+
+!
+! SEND halos toward SOUTH and NORTH
+!
+! --- toward SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+ allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_S(:,i,j) = W(:,i,-nby+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+ end if
+
+! --- toward NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+ allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr )
+
+ do j=1,nby
+ do i=1,imax
+ sBuf_N(:,i,j)=W(:,i,jmax+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+
+ end if
+
+!
+! RECEIVE halos from NORTH and SOUTH
+!
+!
+! --- from NORTH ---
+
+ if( itarg_n >= 0 ) then
+ nebpe = itarg_n
+
+
+ allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr )
+ call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ end if
+
+! --- from SOUTH ---
+
+ if( itarg_s >= 0 ) then
+ nebpe = itarg_s
+
+
+ allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr )
+ call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+
+ end if
+
+!
+! Assign received values from SOUTH and NORTH
+!
+
+! From south
+
+ if(lsouth) then
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j)= W(:,i,j)+W(:,i,1-j)
+ end do
+ end do
+ else
+ do j=1,nby
+ do i=1,imax
+ W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j)
+ end do
+ end do
+ endif
+
+! From north
+
+ if(lnorth) then
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+1+nby-j)
+ enddo
+ enddo
+ else
+ do j=1,nby
+ do i=1,imax
+ W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j)
+ enddo
+ enddo
+ endif
+
+!-----------------------------------------------------------------------
+
+! DEALLOCATE rBufferes
+
+ deallocate( rBuf_W, stat = iderr)
+ deallocate( rBuf_E, stat = iderr)
+ deallocate( rBuf_S, stat = iderr)
+ deallocate( rBuf_N, stat = iderr)
+
+! DEALLOCATE sBufferes
+
+ if( itarg_w >= 0 ) then
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ end if
+ if( itarg_e >= 0 ) then
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ end if
+ if( itarg_s >= 0 ) then
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ end if
+ if( itarg_n >= 0 ) then
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ end if
+
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+ endif FILT_GRID
+
+!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+
+!-----------------------------------------------------------------------
+endsubroutine bocoT_2d_loc
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsend_loc_g12 &
+!***********************************************************************
+! !
+! Upsend data from generation one to generation two !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,V_in,H,km_4_in,flag)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_4_in,flag
+real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(in):: V_in
+real(r_kind), dimension(km_4_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE &
+ ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE
+
+real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SW
+real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SE
+real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NW
+real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NE
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,ndata,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind):: mygen_dn,mygen_up
+integer(i_kind):: itarg_up
+logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+ mygen_dn=1
+ mygen_up=2
+!
+! Define generational flags
+!
+
+ itarg_up=Fitargup_loc12(flag)
+
+ lsendup_sw = lsendup_sw_loc
+ lsendup_se = lsendup_se_loc
+ lsendup_nw = lsendup_nw_loc
+ lsendup_ne = lsendup_ne_loc
+!-----------------------------------------------------------------------
+
+!N if(my_hgen==mygen_up) then
+ H(:,:,:) = 0.0d0
+!N endif
+
+ ndata =km_4_in*imL*jmL
+
+!
+! --- Send data to SW portion of processors at higher generation
+!
+
+ if( lsendup_sw ) then
+
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_SW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_SW(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+ call MPI_WAIT( sHandle(1), istat, ierr )
+
+ deallocate( sBuf_SW, stat = ierr )
+
+ endif
+
+ endif
+!
+! --- Receive SW portion of data at higher generation
+!
+
+!N if( my_hgen==mygen_up .and. itargdn_sw_loc21 >= 0 ) then
+ if( itargdn_sw_loc21 >= 0 ) then
+
+ nebpe = itargdn_sw_loc21
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,i,j)=dBuf_SW(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!
+! --- Send data to SE portion of processors at higher generation
+!
+
+ if( lsendup_se ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_SE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_SE(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+ call MPI_WAIT( sHandle(2), istat, ierr )
+
+ deallocate( sBuf_SE, stat = ierr )
+
+ endif
+
+ end if
+
+!
+! --- Receive SE portion of data at higher generation
+!
+
+!N if( my_hgen==mygen_up .and. itargdn_se_loc21 >= 0 ) then
+ if( itargdn_se_loc21 >= 0 ) then
+
+ nebpe = itargdn_se_loc21
+
+ if(nebpe /= mype) then
+
+ call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ endif
+ do j=1,jmL
+ do i=1,imL
+ H(:,imL+i,j)=dBuf_SE(:,i,j)
+ enddo
+ enddo
+
+ endif
+!
+! --- Send data to NW portion of processors at higher generation
+!
+
+ if( lsendup_nw ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_NW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_NW(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(3), isend)
+
+ call MPI_WAIT( sHandle(3), istat, ierr )
+
+ deallocate( sBuf_NW, stat = ierr )
+
+ end if
+
+ end if
+
+!
+! --- Receive NW portion of data at higher generation
+!
+
+! if( my_hgen==mygen_up .and. itargdn_nw_loc21 >= 0 ) then
+ if( itargdn_nw_loc21 >= 0 ) then
+
+ nebpe = itargdn_nw_loc21
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,i,jmL+j)=dBuf_NW(:,i,j)
+ enddo
+ enddo
+
+ endif
+!
+! --- Send data to NE portion of processors at higher generation
+!
+
+ if( lsendup_ne ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_NE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_NE(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(4), isend)
+ call MPI_WAIT( sHandle(4), istat, ierr )
+
+ deallocate( sBuf_NE, stat = ierr )
+
+ endif
+
+ end if
+
+!
+! --- Receive NE portion of data at higher generation
+!
+
+!N if( my_hgen==mygen_up .and. itargdn_ne_loc21 >= 0 ) then
+ if( itargdn_ne_loc21 >= 0 ) then
+
+ nebpe = itargdn_ne_loc21
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,imL+i,jmL+j)=dBuf_NE(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+!-----------------------------------------------------------------------
+endsubroutine upsend_loc_g12
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsend_loc_g23 &
+!***********************************************************************
+! !
+! Upsend data from generation three to generation four !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,V_in,H,km_16_in,flag)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_16_in,flag
+real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(in):: V_in
+real(r_kind), dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE &
+ ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE
+
+real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SW
+real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SE
+real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NW
+real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NE
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,ndata,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind):: mygen_dn,mygen_up
+integer(i_kind):: itarg_up
+logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+ mygen_dn=2
+ mygen_up=3
+!
+! Define generational flags
+!
+
+ itarg_up=Fitargup_loc23(flag)
+
+ lsendup_sw = lsendup_sw_loc
+ lsendup_se = lsendup_se_loc
+ lsendup_nw = lsendup_nw_loc
+ lsendup_ne = lsendup_ne_loc
+!-----------------------------------------------------------------------
+
+!N if(my_hgen==mygen_up) then
+ H(:,:,:) = 0.0d0
+!N endif
+
+ ndata =km_16_in*imL*jmL
+
+!
+! --- Send data to SW portion of processors at higher generation
+!
+
+ if( lsendup_sw ) then
+
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_SW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_SW(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+ call MPI_WAIT( sHandle(1), istat, ierr )
+
+ deallocate( sBuf_SW, stat = ierr )
+
+ endif
+
+ endif
+!
+! --- Receive SW portion of data at higher generation
+!
+
+!N if( my_hgen==mygen_up .and. itargdn_sw_loc32 >= 0 ) then
+ if( itargdn_sw_loc32 >= 0 ) then
+
+ nebpe = itargdn_sw_loc32
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,i,j)=dBuf_SW(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!
+! --- Send data to SE portion of processors at higher generation
+!
+
+ if( lsendup_se ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_SE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_SE(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+ call MPI_WAIT( sHandle(2), istat, ierr )
+
+ deallocate( sBuf_SE, stat = ierr )
+
+ endif
+
+ end if
+
+!
+! --- Receive SE portion of data at higher generation
+!
+
+!N if( my_hgen==mygen_up .and. itargdn_se_loc32 >= 0 ) then
+ if( itargdn_se_loc32 >= 0 ) then
+
+ nebpe = itargdn_se_loc32
+
+ if(nebpe /= mype) then
+
+ call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ endif
+ do j=1,jmL
+ do i=1,imL
+ H(:,imL+i,j)=dBuf_SE(:,i,j)
+ enddo
+ enddo
+
+ endif
+!
+! --- Send data to NW portion of processors at higher generation
+!
+
+ if( lsendup_nw ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_NW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_NW(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(3), isend)
+
+ call MPI_WAIT( sHandle(3), istat, ierr )
+
+ deallocate( sBuf_NW, stat = ierr )
+
+ end if
+
+ end if
+
+!
+! --- Receive NW portion of data at higher generation
+!
+
+! if( my_hgen==mygen_up .and. itargdn_nw_loc32 >= 0 ) then
+ if( itargdn_nw_loc32 >= 0 ) then
+
+ nebpe = itargdn_nw_loc32
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,i,jmL+j)=dBuf_NW(:,i,j)
+ enddo
+ enddo
+
+ endif
+!
+! --- Send data to NE portion of processors at higher generation
+!
+
+ if( lsendup_ne ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_NE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_NE(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(4), isend)
+ call MPI_WAIT( sHandle(4), istat, ierr )
+
+ deallocate( sBuf_NE, stat = ierr )
+
+ endif
+
+ end if
+
+!
+! --- Receive NE portion of data at higher generation
+!
+
+!N if( my_hgen==mygen_up .and. itargdn_ne_loc32 >= 0 ) then
+ if( itargdn_ne_loc32 >= 0 ) then
+
+ nebpe = itargdn_ne_loc32
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,imL+i,jmL+j)=dBuf_NE(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+!-----------------------------------------------------------------------
+endsubroutine upsend_loc_g23
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsend_loc_g34 &
+!***********************************************************************
+! !
+! Upsend data from generation three to generation four !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,V_in,H,km_64_in,flag)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_64_in,flag
+real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(in):: V_in
+real(r_kind), dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE &
+ ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE
+
+real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SW
+real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SE
+real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NW
+real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NE
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,ndata,i,j
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind):: mygen_dn,mygen_up
+integer(i_kind):: itarg_up
+logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+ mygen_dn=3
+ mygen_up=4
+!
+! Define generational flags
+!
+
+ itarg_up=Fitargup_loc34(flag)
+
+ lsendup_sw = lsendup_sw_loc
+ lsendup_se = lsendup_se_loc
+ lsendup_nw = lsendup_nw_loc
+ lsendup_ne = lsendup_ne_loc
+!-----------------------------------------------------------------------
+
+!N if(my_hgen==mygen_up) then
+ H(:,:,:) = 0.0d0
+!N endif
+
+ ndata =km_64_in*imL*jmL
+
+!
+! --- Send data to SW portion of processors at higher generation
+!
+
+ if( lsendup_sw ) then
+
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_SW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_SW(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(1), isend)
+ call MPI_WAIT( sHandle(1), istat, ierr )
+
+ deallocate( sBuf_SW, stat = ierr )
+
+ endif
+
+ endif
+!
+! --- Receive SW portion of data at higher generation
+!
+
+ if( itargdn_sw_loc43 >= 0 ) then
+
+ nebpe = itargdn_sw_loc43
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,i,j)=dBuf_SW(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+!
+! --- Send data to SE portion of processors at higher generation
+!
+
+ if( lsendup_se ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_SE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_SE(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(2), isend)
+ call MPI_WAIT( sHandle(2), istat, ierr )
+
+ deallocate( sBuf_SE, stat = ierr )
+
+ endif
+
+ end if
+
+!
+! --- Receive SE portion of data at higher generation
+!
+
+ if( itargdn_se_loc43 >= 0 ) then
+
+ nebpe = itargdn_se_loc43
+
+ if(nebpe /= mype) then
+
+ call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ endif
+ do j=1,jmL
+ do i=1,imL
+ H(:,imL+i,j)=dBuf_SE(:,i,j)
+ enddo
+ enddo
+
+ endif
+!
+! --- Send data to NW portion of processors at higher generation
+!
+
+ if( lsendup_nw ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_NW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_NW(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NW(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(3), isend)
+
+ call MPI_WAIT( sHandle(3), istat, ierr )
+
+ deallocate( sBuf_NW, stat = ierr )
+
+ end if
+
+ end if
+
+!
+! --- Receive NW portion of data at higher generation
+!
+
+! if( my_hgen==mygen_up .and. itargdn_nw_loc43 >= 0 ) then
+ if( itargdn_nw_loc43 >= 0 ) then
+
+ nebpe = itargdn_nw_loc43
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,i,jmL+j)=dBuf_NW(:,i,j)
+ enddo
+ enddo
+
+ endif
+!
+! --- Send data to NE portion of processors at higher generation
+!
+
+ if( lsendup_ne ) then
+ nebpe = itarg_up
+
+ if(nebpe == mype) then
+
+ do j=1,jmL
+ do i=1,imL
+ dBuf_NE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ else
+
+ allocate( sBuf_NE(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NE(:,i,j) = V_in(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, &
+ mpi_comm_comp, sHandle(4), isend)
+ call MPI_WAIT( sHandle(4), istat, ierr )
+
+ deallocate( sBuf_NE, stat = ierr )
+
+ endif
+
+ end if
+
+!
+! --- Receive NE portion of data at higher generation
+!
+
+!N if( my_hgen==mygen_up .and. itargdn_ne_loc43 >= 0 ) then
+ if( itargdn_ne_loc43 >= 0 ) then
+
+ nebpe = itargdn_ne_loc43
+
+ if(nebpe /= mype) then
+ call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_comp, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+ endif
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,imL+i,jmL+j)=dBuf_NE(:,i,j)
+ enddo
+ enddo
+
+ endif
+
+
+!-----------------------------------------------------------------------
+endsubroutine upsend_loc_g34
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsend_loc_g43 &
+!***********************************************************************
+! *
+! Downsending data from low resolution pes (mygen_up) *
+! to the concurent high-resolution pes (mygen_dn) *
+! and add the existing and the recevied values *
+! !
+! - offset version - !
+! *
+!***********************************************************************
+(this,W,Z,km_64_in,flag)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_64_in,flag
+real(r_kind), dimension(km_64_in,1:this%im,1:this%jm),intent(in):: W
+real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(out):: Z
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE &
+ ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE
+
+real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SW
+real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SE
+real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NW
+real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NE
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind):: itarg_up
+logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+
+ Z(:,:,:) = 0.0d0
+!
+! Define generational flags
+!
+
+ itarg_up=Fitargup_loc34(flag)
+
+ ndata =km_64_in*imL*jmL
+
+!
+! --- Send data from SW portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ if(itargdn_sw_loc43 >= 0) then
+
+ nebpe = itargdn_sw_loc43
+
+
+ allocate( sBuf_SW(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SW(:,i,j) = W(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_SW, stat = ierr )
+
+ endif
+
+!
+! --- Receive SW portion of data at lower generation
+
+
+ if( lsendup_sw ) then
+
+ nebpe = itarg_up
+
+
+ allocate( rBuf_SW(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Z(:,i,j)=rBuf_SW(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_SW, stat = iderr)
+
+ endif
+
+!
+! --- Send data from SE portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ if(itargdn_se_loc43 >= 0) then
+
+ nebpe = itargdn_se_loc43
+
+ allocate( sBuf_SE(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SE(:,i,j) = W(:,imL+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_SE, stat = ierr )
+
+ endif
+!
+! --- Receive SE portion of data at lower generation
+
+
+ if( lsendup_se ) then
+ nebpe = itarg_up
+
+
+ allocate( rBuf_SE(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Z(:,i,j)=Rbuf_SE(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_SE, stat = iderr)
+
+ end if
+
+!
+! --- Send data from NW portion of processors at the higher generation
+! to corresponding PE's at lower generantion
+
+ if(itargdn_nw_loc43 >= 0) then
+
+ nebpe = itargdn_nw_loc43
+
+
+ allocate( sBuf_NW(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NW(:,i,j) = W(:,i,jmL+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_NW, stat = ierr )
+
+ endif
+
+!
+! --- Receive NW portion of data at lower generation
+
+
+ if( lsendup_nw ) then
+
+ nebpe = itarg_up
+
+ allocate( rBuf_NW(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Z(:,i,j)=Rbuf_NW(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_NW, stat = iderr)
+
+
+ end if
+
+
+! --- Send data from NE portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ if(itargdn_ne_loc43 >= 0) then
+
+ nebpe = itargdn_ne_loc43
+
+ allocate( sBuf_NE(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NE(:,i,j) = W(:,imL+i,jmL+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_NE, stat = ierr )
+
+ endif
+
+!
+! --- Receive NE portion of data at lower generation
+!
+
+ if( lsendup_ne ) then
+ nebpe = itarg_up
+
+ allocate( rBuf_NE(1:km_64_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ Z(:,i,j)=rBuf_NE(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_NE, stat = iderr)
+
+ end if
+
+!-----------------------------------------------------------------------
+endsubroutine downsend_loc_g43
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsend_loc_g32 &
+!***********************************************************************
+! *
+! Downsending data from low resolution pes (mygen_up) *
+! to the concurent high-resolution pes (mygen_dn) *
+! and add the existing and the recevied values *
+! !
+! - offset version - !
+! *
+!***********************************************************************
+(this,Z,H,km_16_in,flag)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_16_in,flag
+real(r_kind), dimension(km_16_in,1:this%im,1:this%jm),intent(in):: Z
+real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(out):: H
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE &
+ ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE
+
+real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SW
+real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SE
+real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NW
+real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NE
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind):: itarg_up
+logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+
+ H(:,:,:) = 0.0d0
+!
+! Define generational flags
+!
+
+ itarg_up=Fitargup_loc23(flag)
+
+ ndata =km_16_in*imL*jmL
+
+!
+! --- Send data from SW portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+
+ if( itargdn_sw_loc32 >= 0 ) then
+
+ nebpe = itargdn_sw_loc32
+
+
+ allocate( sBuf_SW(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SW(:,i,j) = Z(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_SW, stat = ierr )
+
+ endif
+
+!
+! --- Receive SW portion of data at lower generation
+
+
+ if( lsendup_sw ) then
+
+ nebpe = itarg_up
+
+
+ allocate( rBuf_SW(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,i,j)=rBuf_SW(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_SW, stat = iderr)
+
+ endif
+
+!
+! --- Send data from SE portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ if( itargdn_se_loc32 >= 0 ) then
+
+ nebpe = itargdn_se_loc32
+
+ allocate( sBuf_SE(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SE(:,i,j) = Z(:,imL+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_SE, stat = ierr )
+
+
+ endif
+!
+! --- Receive SE portion of data at lower generation
+
+
+ if( lsendup_se ) then
+ nebpe = itarg_up
+
+
+ allocate( rBuf_SE(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,i,j)=Rbuf_SE(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_SE, stat = iderr)
+
+ end if
+
+!
+! --- Send data from NW portion of processors at the higher generation
+! to corresponding PE's at lower generantion
+
+ if( itargdn_nw_loc32 >= 0 ) then
+
+ nebpe = itargdn_nw_loc32
+
+
+ allocate( sBuf_NW(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NW(:,i,j) = Z(:,i,jmL+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_NW, stat = ierr )
+
+
+ endif
+!
+! --- Receive NW portion of data at lower generation
+
+
+ if( lsendup_nw ) then
+
+ nebpe = itarg_up
+
+ allocate( rBuf_NW(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,i,j)=Rbuf_NW(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_NW, stat = iderr)
+
+
+ end if
+
+
+! --- Send data from NE portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ if( itargdn_ne_loc32 >= 0 ) then
+ nebpe = itargdn_ne_loc32
+
+
+ allocate( sBuf_NE(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NE(:,i,j) = Z(:,imL+i,jmL+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_NE, stat = ierr )
+
+ endif
+!
+! --- Receive NE portion of data at lower generation
+!
+
+ if( lsendup_ne ) then
+ nebpe = itarg_up
+
+ allocate( rBuf_NE(1:km_16_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ H(:,i,j)=rBuf_NE(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_NE, stat = iderr)
+
+ end if
+
+!-----------------------------------------------------------------------
+endsubroutine downsend_loc_g32
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsend_loc_g21 &
+!***********************************************************************
+! *
+! Downsending data from low resolution pes (mygen_up) *
+! to the concurent high-resolution pes (mygen_dn) *
+! and add the existing and the recevied values *
+! !
+! - offset version - !
+! *
+!***********************************************************************
+(this,H,V_out,km_4_in,flag)
+!-----------------------------------------------------------------------
+use mpi
+implicit none
+class(mg_intstate_type),target::this
+!-----------------------------------------------------------------------
+integer(i_kind), intent(in):: km_4_in,flag
+real(r_kind), dimension(km_4_in,1:this%im,1:this%jm),intent(in):: H
+real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(out):: V_out
+!-----------------------------------------------------------------------
+real(r_kind), allocatable, dimension(:,:,:):: &
+ sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE &
+ ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE
+
+real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SW
+real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SE
+real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NW
+real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NE
+
+integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE)
+integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L
+integer(i_kind) isend,irecv,nebpe
+integer(i_kind):: itarg_up
+logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+
+ V_out(:,:,:) = 0.0d0
+!
+! Define generational flags
+!
+
+ itarg_up=Fitargup_loc12(flag)
+
+ ndata =km_4_in*imL*jmL
+
+!
+! --- Send data from SW portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+
+ if( itargdn_sw_loc21 >= 0 ) then
+ nebpe = itargdn_sw_loc21
+
+
+ allocate( sBuf_SW(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SW(:,i,j) = H(:,i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(1), isend)
+ call MPI_WAIT( sHandle(1), istat, ierr )
+ deallocate( sBuf_SW, stat = ierr )
+
+ endif
+
+!
+! --- Receive SW portion of data at lower generation
+!
+
+
+ if( lsendup_sw ) then
+
+ nebpe = itarg_up
+
+
+ allocate( rBuf_SW(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(1), irecv)
+ call MPI_WAIT( rHandle(1), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ V_out(:,i,j)=rBuf_SW(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_SW, stat = iderr)
+
+ endif
+
+!
+! --- Send data from SE portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ if( itargdn_se_loc21 >= 0 ) then
+ nebpe = itargdn_se_loc21
+
+ allocate( sBuf_SE(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_SE(:,i,j) = H(:,imL+i,j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(2), isend)
+ call MPI_WAIT( sHandle(2), istat, ierr )
+ deallocate( sBuf_SE, stat = ierr )
+
+
+ endif
+!
+! --- Receive SE portion of data at lower generation
+
+
+ if( lsendup_se ) then
+ nebpe = itarg_up
+
+
+ allocate( rBuf_SE(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(2), irecv)
+ call MPI_WAIT( rHandle(2), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ V_out(:,i,j)=Rbuf_SE(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_SE, stat = iderr)
+
+ end if
+
+!
+! --- Send data from NW portion of processors at the higher generation
+! to corresponding PE's at lower generantion
+
+ if( itargdn_nw_loc21 >= 0 ) then
+
+ nebpe = itargdn_nw_loc21
+
+
+ allocate( sBuf_NW(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NW(:,i,j) = H(:,i,jmL+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(3), isend)
+ call MPI_WAIT( sHandle(3), istat, ierr )
+ deallocate( sBuf_NW, stat = ierr )
+
+
+ endif
+!
+! --- Receive NW portion of data at lower generation
+
+
+ if( lsendup_nw ) then
+
+ nebpe = itarg_up
+
+ allocate( rBuf_NW(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(3), irecv)
+ call MPI_WAIT( rHandle(3), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ V_out(:,i,j)=Rbuf_NW(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_NW, stat = iderr)
+
+
+ end if
+
+
+! --- Send data from NE portion of processors at the higher generation
+! to corresponding PE's at lower generation
+
+ if( itargdn_ne_loc21 >= 0 ) then
+
+ nebpe = itargdn_ne_loc21
+
+
+ allocate( sBuf_NE(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ do j=1,jmL
+ do i=1,imL
+ sBuf_NE(:,i,j) = H(:,imL+i,jmL+j)
+ enddo
+ enddo
+
+ call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, &
+ mpi_comm_work, sHandle(4), isend)
+ call MPI_WAIT( sHandle(4), istat, ierr )
+ deallocate( sBuf_NE, stat = ierr )
+
+
+ endif
+!
+! --- Receive NE portion of data at lower generation
+!
+
+ if( lsendup_ne ) then
+
+ nebpe = itarg_up
+
+ allocate( rBuf_NE(1:km_4_in,1:imL,1:jmL), stat = iaerr )
+
+ call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, &
+ mpi_comm_work, rHandle(4), irecv)
+ call MPI_WAIT( rHandle(4), istat, ierr )
+
+ do j=1,jmL
+ do i=1,imL
+ V_out(:,i,j)=rBuf_NE(:,i,j)
+ enddo
+ enddo
+
+ deallocate( rBuf_NE, stat = iderr)
+
+ end if
+
+!-----------------------------------------------------------------------
+endsubroutine downsend_loc_g21
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+end submodule mg_bocos
diff --git a/src/mgbf/mg_domain.f90 b/src/mgbf/mg_domain.f90
new file mode 100644
index 0000000000..d56d1a5f9f
--- /dev/null
+++ b/src/mgbf/mg_domain.f90
@@ -0,0 +1,644 @@
+submodule(mg_parameter) mg_domain
+!$$$ submodule documentation block
+! . . . .
+! module: mg_domain
+! prgmmr: rancic org: NCEP/EMC date: 2020
+!
+! abstract: Definition of a squared integration domain
+!
+! module history log:
+! 2023-04-19 lei - object-oriented coding
+! 2024-01-11 rancic - optimization for ensemble localization
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! init_mg_domain -
+! init_domain -
+! init_topology_2d -
+! real_itarg -
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+use kinds, only: i_kind
+
+implicit none
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+contains
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine init_mg_domain(this)
+!***********************************************************************
+! *
+! Initialize square domain *
+! *
+!***********************************************************************
+implicit none
+class(mg_parameter_type)::this
+
+call init_domain(this)
+call init_topology_2d(this)
+
+!-----------------------------------------------------------------------
+endsubroutine init_mg_domain
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine init_domain(this)
+!***********************************************************************
+! *
+! Definition of constants that control filtering domain *
+! *
+!***********************************************************************
+implicit none
+class(mg_parameter_type),target::this
+
+integer(i_kind) n,nstrd,i,j
+logical:: F=.false., T=.true.
+
+integer(i_kind):: loc_pe,g
+include "type_parameter_locpointer.inc"
+include "type_parameter_point2this.inc"
+!-----------------------------------------------------------------------
+
+ Flwest(1)=nx.eq.1
+ Fleast(1)=nx.eq.nxm
+ Flsouth(1)=my.eq.1
+ Flnorth(1)=my.eq.nym
+
+ if(l_hgen) then
+
+ loc_pe=mype_hgen-maxpe_fgen(my_hgen-1)
+ jy=loc_pe/ixm(my_hgen)+1
+ ix=mod(loc_pe,ixm(my_hgen))+1
+
+ Flwest(2)=ix.eq.1
+ Fleast(2)=ix.eq.ixm(my_hgen)
+ Flsouth(2)=jy.eq.1
+ Flnorth(2)=jy.eq.jym(my_hgen)
+
+ else
+
+ jy = -1
+ ix = -1
+
+ Flwest(2)=F
+ Fleast(2)=F
+ Flsouth(2)=F
+ Flnorth(2)=F
+
+ endif
+
+ mype_filt(1)=mype
+ mype_filt(2)=mype_hgen
+
+!
+! Communication params for analysis grid
+!
+ if(nx==1) then
+ itarg_wA=-1
+ else
+ itarg_wA=mype-1
+ endif
+
+ if(nx==nxm) then
+ itarg_eA=-1
+ else
+ itarg_eA=mype+1
+ endif
+
+ if(my==1) then
+ itarg_sA=-1
+ else
+ itarg_sA=mype-nxm
+ endif
+
+ if(my==nym) then
+ itarg_nA=-1
+ else
+ itarg_nA=mype+nxm
+ endif
+
+ lwestA=nx.eq.1
+ leastA=nx.eq.nxm
+ lsouthA=my.eq.1
+ lnorthA=my.eq.nym
+
+
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+! write(100+mype,'(a)')'---------------------------------'
+! write(100+mype,'(a)')'From init_domain'
+! write(100+mype,'(a,2i5)')'mype=',mype
+! write(100+mype,'(a,i5)')'nx=',nx
+! write(100+mype,'(a,i5)')'my=',my
+! write(100+mype,'(a)')'---------------------------------'
+! write(100+mype_filt,'(a)')'---------------------------------'
+! write(100+mype_filt,'(a,3i5)')'mype,mype_filt,mygen :',mype,mype_filt,mygen
+! write(100+mype_filt,'(a,2i5)')'ix,jy= ',ix,jy
+! write(100+mype_filt,'(a,l5)')'lwest = ',lwest
+! write(100+mype_filt,'(a,l5)')'least = ',least
+! write(100+mype_filt,'(a,l5)')'lsouth= ',lsouth
+! write(100+mype_filt,'(a,l5)')'lnorth= ',lnorth
+! write(100+mype_filt,'(a,l5)')'lcorner_sw ',lcorner_sw
+! write(100+mype_filt,'(a,l5)')'lcorner_se ',lcorner_se
+! write(100+mype_filt,'(a,l5)')'lcorner_nw ',lcorner_nw
+! write(100+mype_filt,'(a,l5)')'lcorner_ne ',lcorner_ne
+! write(100+mype_filt,'(a)')'----------------------------------'
+! write(100+mype_filt,'(a)')' '
+!-----------------------------------------------------------------------
+! if(mype==0) then
+! write(27,'(a,i4)') 'nb=',nb
+! write(27,'(a,i4)') 'mb=',mb
+! endif
+!
+! call finishMPI
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+
+!-----------------------------------------------------------------------
+endsubroutine init_domain
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine init_topology_2d(this)
+!***********************************************************************
+! *
+! Define topology of filter grid *
+! - Four generations - *
+! *
+!***********************************************************************
+implicit none
+class(mg_parameter_type),target::this
+!-----------------------------------------------------------------------
+logical:: F=.false., T=.true.
+
+integer(i_kind) mx2,my2,ix_up,jy_up,ix_dn,jy_dn
+integer(i_kind) g,naux,nx_up,my_up
+include "type_parameter_locpointer.inc"
+include "type_parameter_point2this.inc"
+!-----------------------------------------------------------------------
+!
+! Topology of generations of the squared domain
+!
+! G1
+! _____ _____ _____ _____ _____ _____ _____ _____
+! | | | | | | | | |
+! | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 |
+! |_____|_____|_____|_____|_____|_____|_____|_____|
+! | | | | | | | | |
+! | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 |
+! |_____|_____|_____|_____|_____|_____|_____|_____|
+! | | | | | | | | |
+! | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 |
+! |_____|_____|_____|_____|_____|_____|_____|_____|
+! | | | | | | | | |
+! | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 |
+! |_____|_____|_____|_____|_____|_____|_____|_____|
+! | | | | | | | | |
+! | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 |
+! |_____|_____|_____|_____|_____|_____|_____|_____|
+! | | | | | | | | |
+! | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 |
+! |_____|_____|_____|_____|_____|_____|_____|_____|
+! | | | | | | | | |
+! | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 |
+! |_____|_____|_____|_____|_____|_____|_____|_____|
+! | | | | | | | | |
+! | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 |
+! |_____|_____|_____|_____|_____|_____|_____|_____|
+!
+!
+! G2
+! ___________ ___________ ___________ ___________
+! | | | | |
+! | | | | |
+! | 76 | 77 | 78 | 79 |
+! | | | | |
+! | | | | |
+! |___________|___________|___________|___________|
+! | | | | |
+! | | | | |
+! | 72 | 73 | 74 | 75 |
+! | | | | |
+! | | | | |
+! |___________|___________|___________|___________|
+! | | | | |
+! | | | | |
+! | 68 | 69 | 70 | 71 |
+! | | | | |
+! | | | | |
+! |___________|___________|___________|___________|
+! | | | | |
+! | | | | |
+! | 64 | 65 | 66 | 67 |
+! | | | | |
+! | | | | |
+! |___________|___________|___________|___________|
+!
+!
+! G3
+! _______________________ _______________________
+! | | |
+! | | |
+! | | |
+! | | |
+! | | |
+! | 82 | 83 |
+! | | |
+! | | |
+! | | |
+! | | |
+! | | |
+! |_______________________|_______________________|
+! | | |
+! | | |
+! | | |
+! | | |
+! | | |
+! | 80 | 81 |
+! | | |
+! | | |
+! | | |
+! | | |
+! | | |
+! |_______________________|_______________________|
+!
+!
+! G4
+! _______________________________________________
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | 84 |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! | |
+! |_______________________________________________|
+!
+!----------------------------------------------------------------------
+
+ do g = 1,2
+!***
+!*** Send WEST
+!***
+ if(Flwest(g)) then
+ Fitarg_w(g) = -1
+ else
+ if(g==1.or.l_hgen) then
+ Fitarg_w(g) = mype_filt(g)-1
+ else
+ Fitarg_w(g) = -1
+ endif
+ endif
+!***
+!*** Send EAST
+!***
+ if(Fleast(g)) then
+ Fitarg_e(g) = -1
+ else
+ if(g==1.or.l_hgen) then
+ Fitarg_e(g) = mype_filt(g)+1
+ else
+ Fitarg_e(g) = -1
+ endif
+ endif
+
+!***
+!*** Send SOUTH
+!***
+
+ if(Flsouth(g)) then
+ Fitarg_s(g)=-1
+ else
+ select case(g)
+ case(1)
+ naux = nxm
+ case(2)
+ if(l_hgen) then
+ naux = ixm(my_hgen)
+ endif
+ endselect
+ if(g==1.or.l_hgen) then
+ Fitarg_s(g)=mype_filt(g)-naux
+ else
+ Fitarg_s(g)=-1
+ endif
+ endif
+
+!***
+!*** Send NORTH
+!***
+ if(Flnorth(g)) then
+ Fitarg_n(g)=-1
+ else
+ select case(g)
+ case(1)
+ naux = nxm
+ case(2)
+ if(l_hgen) then
+ naux = ixm(my_hgen)
+ endif
+ endselect
+ if(g==1.or.l_hgen) then
+ Fitarg_n(g)=mype_filt(g)+naux
+ else
+ Fitarg_n(g)=-1
+ endif
+ endif
+
+!***
+!*** Send SOUTH-WEST
+!***
+
+ if(Flsouth(g).and.Flwest(g)) then
+ Fitarg_sw(g)=-1
+ else &
+ if(Flsouth(g)) then
+ Fitarg_sw(g)=Fitarg_w(g)
+ else &
+ if(Flwest(g)) then
+ Fitarg_sw(g)=Fitarg_s(g)
+ else
+ Fitarg_sw(g)=Fitarg_s(g)-1
+ endif
+ if(g>1 .and. .not.l_hgen) then
+ Fitarg_sw(g)=-1
+ endif
+
+!***
+!*** Send SOUTH-EAST
+!***
+
+ if(Flsouth(g).and.Fleast(g)) then
+ Fitarg_se(g)=-1
+ else &
+ if(Flsouth(g)) then
+ Fitarg_se(g)=Fitarg_e(g)
+ else &
+ if(Fleast(g)) then
+ Fitarg_se(g)=Fitarg_s(g)
+ else
+ Fitarg_se(g)=Fitarg_s(g)+1
+ endif
+ if(g>1 .and. .not.l_hgen) then
+ Fitarg_se(g)=-1
+ endif
+
+!***
+!*** Send NORTH-WEST
+!***
+ if(Flnorth(g).and.Flwest(g)) then
+ Fitarg_nw(g)=-1
+ else &
+ if(Flnorth(g)) then
+ Fitarg_nw(g)=Fitarg_w(g)
+ else &
+ if(Flwest(g)) then
+ Fitarg_nw(g)=Fitarg_n(g)
+ else
+ Fitarg_nw(g)=Fitarg_n(g)-1
+ endif
+ if(g>1 .and. .not.l_hgen) then
+ Fitarg_nw(g)=-1
+ endif
+
+
+!***
+!*** Send NORTH-EAST
+!***
+
+ if(Flnorth(g).and.Fleast(g)) then
+ Fitarg_ne(g)=-1
+ else &
+ if(Flnorth(g)) then
+ Fitarg_ne(g)=Fitarg_e(g)
+ else &
+ if(Fleast(g)) then
+ Fitarg_ne(g)=Fitarg_n(g)
+ else
+ Fitarg_ne(g)=Fitarg_n(g)+1
+ endif
+ if(g>1 .and. .not.l_hgen) then
+ Fitarg_ne(g)=-1
+ endif
+
+
+ enddo
+
+!-----------------------------------------------------------------------
+!
+! Upsending flags
+!
+
+ mx2=mod(nx,2)
+ my2=mod(my,2)
+
+ if(mx2==1.and.my2==1) then
+ Flsendup_sw(1)=T
+ else &
+ if(mx2==0.and.my2==1) then
+ Flsendup_se(1)=T
+ else &
+ if(mx2==1.and.my2==0) then
+ Flsendup_nw(1)=T
+ else
+ Flsendup_ne(1)=T
+ end if
+
+ nx_up=(nx-1)/2 !+1
+ my_up=(my-1)/2 !+1
+
+
+ Fitarg_up(1)=maxpe_fgen(1)+my_up*ixm(2)+nx_up
+
+
+ if(l_hgen.and.my_hgen < gm) then
+
+ mx2=mod(ix,2)
+ my2=mod(jy,2)
+
+ if(mx2==1.and.my2==1) then
+ Flsendup_sw(2)=T
+ else &
+ if(mx2==0.and.my2==1) then
+ Flsendup_se(2)=T
+ else &
+ if(mx2==1.and.my2==0) then
+ Flsendup_nw(2)=T
+ else
+ Flsendup_ne(2)=T
+ end if
+
+ ix_up=(ix-1)/2 !+1
+ jy_up=(jy-1)/2 !+1
+
+ Fitarg_up(2)=maxpe_fgen(my_hgen)+jy_up*ixm(my_hgen+1)+ix_up
+
+ else
+
+ Flsendup_sw(2)=F
+ Flsendup_se(2)=F
+ Flsendup_nw(2)=F
+ Flsendup_ne(2)=F
+
+ Fitarg_up(2)=-1
+
+ endif
+
+!
+! Downsending flags
+!
+
+ if(my_hgen > 1) then
+
+ ix_dn = 2*ix-1
+ jy_dn = 2*jy-1
+
+ itargdn_sw=maxpe_fgen(my_hgen-2)+(jy_dn-1)*ixm(my_hgen-1)+(ix_dn-1)
+ itargdn_nw=itargdn_sw+ixm(my_hgen-1)
+ itargdn_se=itargdn_sw+1
+ itargdn_ne=itargdn_nw+1
+
+ if(Fimax(my_hgen) <= imL .and. Fleast(2)) then
+ itargdn_se=-1
+ itargdn_ne=-1
+ endif
+ if(Fjmax(my_hgen) <= jmL .and. Flnorth(2)) then
+ itargdn_nw=-1
+ itargdn_ne=-1
+ end if
+
+ else
+
+ itargdn_sw=-1
+ itargdn_se=-1
+ itargdn_nw=-1
+ itargdn_ne=-1
+
+ end if
+!
+! Convert targets in higher generations into real targets
+!
+ call real_itarg(this,Fitarg_w(2))
+ call real_itarg(this,Fitarg_e(2))
+ call real_itarg(this,Fitarg_s(2))
+ call real_itarg(this,Fitarg_n(2))
+
+ call real_itarg(this,Fitarg_sw(2))
+ call real_itarg(this,Fitarg_se(2))
+ call real_itarg(this,Fitarg_nw(2))
+ call real_itarg(this,Fitarg_ne(2))
+
+ if(itargdn_sw .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_sw)
+ if(itargdn_se .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_se)
+ if(itargdn_nw .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_nw)
+ if(itargdn_ne .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_ne)
+
+ call real_itarg(this,Fitarg_up(1))
+ call real_itarg(this,Fitarg_up(2))
+
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+! write(200+mype_filt,'(a)')'---------------------------------'
+! write(200+mype_filt,'(a)')'From init_topology_2d'
+! write(200+mype_filt,'(a,2i5)')'mype=',mype
+! write(200+mype_filt,'(a,i5)')'nx=',nx
+! write(200+mype_filt,'(a,i5)')'my=',my
+! write(200+mype_filt,'(a)')'---------------------------------'
+! if(l_hgen ) then
+! write(100+mype_filt,*)' '
+! write(100+mype_filt,'(a,2i5)')'I AM (f),(a):',mype_filt,mype
+! write(100+mype_filt,'(a,i5)') 'mygen= ',mygen
+!
+! write(100+mype_filt,'(a,2i5)')'itarg_w=',itarg_w
+! write(100+mype_filt,'(a,2i5)')'itarg_e=',itarg_e
+! write(100+mype_filt,'(a,2i5)')'itarg_s=',itarg_s
+! write(100+mype_filt,'(a,2i5)')'itarg_n=',itarg_n
+!
+! write(100+mype_filt,'(a,2i5)')'itarg_sw=',itarg_sw
+! write(100+mype_filt,'(a,2i5)')'itarg_se=',itarg_se
+! write(100+mype_filt,'(a,2i5)')'itarg_nw=',itarg_nw
+! write(100+mype_filt,'(a,2i5)')'itarg_ne=',itarg_ne
+! write(100+mype_filt,'(a)')' '
+!
+! if(lsendup_sw) write(100+mype_filt,'(a,l5)')'lsendup_sw=',lsendup_sw
+! if(lsendup_se) write(100+mype_filt,'(a,l5)')'lsendup_se=',lsendup_se
+! if(lsendup_nw) write(100+mype_filt,'(a,l5)')'lsendup_nw=',lsendup_nw
+! if(lsendup_ne) write(100+mype_filt,'(a,l5)')'lsendup_ne=',lsendup_ne
+!
+! write(100+mype_filt,'(a,i5)')'itarg_up=',itarg_up
+!
+! if(lsend_dn) write(100+mype_filt,'(a,l5)')'lsend_dn=',lsend_dn
+!
+! if(my_hgen > 1) then
+! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_sw=',mype_hgen,itargdn_sw
+! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_se=',mype_hgen,itargdn_se
+! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_nw=',mype_hgen,itargdn_nw
+! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_ne=',mype_hgen,itargdn_ne
+! write(100+mype_hgen,'(a,2i5)')' '
+! if(Flsendup_sw(2)) then
+! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_sw(2),Fitarg_up(2)= ' &
+! ,mype_hgen,Flsendup_sw(2),Fitarg_up(2)
+! endif
+! if(Flsendup_se(2)) then
+! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_se(2),Fitarg_up(2)= ' &
+! ,mype_hgen,Flsendup_se(2),Fitarg_up(2)
+! endif
+! if(Flsendup_nw(2)) then
+! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_nw(2),Fitarg_up(2)= ' &
+! ,mype_hgen,Flsendup_nw(2),Fitarg_up(2)
+! endif
+! if(Flsendup_ne(2)) then
+! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_ne(2),Fitarg_up(2)= ' &
+! ,mype_hgen,Flsendup_ne(2),Fitarg_up(2)
+! endif
+! call finishMPI
+!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+!-----------------------------------------------------------------------
+endsubroutine init_topology_2d
+!----------------------------------------------------------------------
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine real_itarg &
+!***********************************************************************
+! *
+! Definite real targets for high generations *
+! *
+!***********************************************************************
+(this,itarg)
+!-----------------------------------------------------------------------
+implicit none
+class(mg_parameter_type),target::this
+integer(i_kind), intent(inout):: itarg
+include "type_parameter_locpointer.inc"
+include "type_parameter_point2this.inc"
+!-----------------------------------------------------------------------
+if(itarg>-1) then
+ itarg = itarg-nxy(1)
+endif
+!-----------------------------------------------------------------------
+endsubroutine real_itarg
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+end submodule mg_domain
diff --git a/src/mgbf/mg_domain_loc.f90 b/src/mgbf/mg_domain_loc.f90
new file mode 100644
index 0000000000..183a5f23d7
--- /dev/null
+++ b/src/mgbf/mg_domain_loc.f90
@@ -0,0 +1,796 @@
+submodule(mg_parameter) mg_domain_loc
+!$$$ submodule documentation block
+! . . . .
+! module: mg_domain_loc
+! prgmmr: rancic org: NCEP/EMC date: 2020
+!
+! abstract: Module that defines control paramters for application
+! of MGBF to localization
+!
+! module history log:
+! 2023-04-19 lei - object-oriented coding
+! 2024-01-11 rancic - optimization for ensemble localization
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! init_domain_loc -
+! sidesend_loc -
+! targup_loc -
+! targdn21_loc -
+! targdn32_loc -
+! targdn43_loc -
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use kinds, only: i_kind
+implicit none
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+contains
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine init_domain_loc(this)
+!***********************************************************************
+! !
+! Initialize localization with application of MGBF !
+! !
+!***********************************************************************
+implicit none
+class(mg_parameter_type)::this
+!----------------------------------------------------------------------
+
+call sidesend_loc(this)
+call targup_loc(this)
+call targdn21_loc(this)
+call targdn32_loc(this)
+call targdn43_loc(this)
+
+!----------------------------------------------------------------------
+endsubroutine init_domain_loc
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine sidesend_loc(this)
+!***********************************************************************
+! !
+! Initialize sidesending pararameters for application MGBF to !
+! localization !
+! !
+!***********************************************************************
+implicit none
+class(mg_parameter_type),target::this
+integer(i_kind):: ix_0,jy_0
+integer(i_kind):: ix_c,jy_c
+integer(i_kind):: ix_cc,jy_cc
+integer(i_kind):: ix_ccc,jy_ccc
+include "type_parameter_locpointer.inc"
+include "type_parameter_point2this.inc"
+!-----------------------------------------------------------------------
+
+! write(10,'(a)') ' Generation 2'
+! write(10,'(a)') '----------------------'
+! write(10,'(a)') 'mype Flsouth_loc(1) '
+
+! write(11,'(a)') ' Generation 2'
+! write(11,'(a)') '----------------------'
+! write(11,'(a)') 'mype Flnorth_loc(1) '
+
+! write(12,'(a)') ' Generation 2'
+! write(12,'(a)') '----------------------'
+! write(12,'(a)') 'mype Flwest_loc(1) '
+
+! write(13,'(a)') ' Generation 2'
+! write(13,'(a)') '----------------------'
+! write(13,'(a)') 'mype Fleast_loc(1) '
+
+! write(14,'(a)') ' Generation 2'
+! write(14,'(a)') '----------------------'
+! write(14,'(a)') 'mype Fitarg_s_loc(1) '
+
+! write(15,'(a)') ' Generation 2'
+! write(15,'(a)') '----------------------'
+! write(15,'(a)') 'mype Fitarg_n_loc(1) '
+
+! write(16,'(a)') ' Generation 2'
+! write(16,'(a)') '----------------------'
+! write(16,'(a)') 'mype Fitarg_w_loc(1) '
+
+! write(17,'(a)') ' Generation 2'
+! write(17,'(a)') '----------------------'
+! write(17,'(a)') 'mype Fitarg_e_loc(1) '
+
+! do mype=0,nxm*nym-1
+
+!
+! Generation 1
+!
+ jy_0 = mype/nxm
+ ix_0 = mype - jy_0*nxm +1
+ jy_0 = jy_0 + 1
+
+ Flsouth_loc(1)=jy_0==1
+ Flnorth_loc(1)=jy_0==nym
+ Flwest_loc(1) =ix_0==1
+ Fleast_loc(1) =ix_0==nxm
+
+ if(Flsouth_loc(1)) then
+ Fitarg_s_loc(1) = -1
+ else
+ Fitarg_s_loc(1) = mype-nxm
+ endif
+
+ if(Flnorth_loc(1)) then
+ Fitarg_n_loc(1) = -1
+ else
+ Fitarg_n_loc(1) = mype+nxm
+ endif
+
+ if(Flwest_loc(1)) then
+ Fitarg_w_loc(1) = -1
+ else
+ Fitarg_w_loc(1) = mype-1
+ endif
+
+ if(Fleast_loc(1)) then
+ Fitarg_e_loc(1) = -1
+ else
+ Fitarg_e_loc(1) = mype+1
+ endif
+
+! write(10,'(i5,a,l5)') mype, ' ---> ',Flsouth_loc(1)
+! write(11,'(i5,a,l5)') mype, ' ---> ',Flnorth_loc(1)
+! write(12,'(i5,a,l5)') mype, ' ---> ',Flwest_loc(1)
+! write(13,'(i5,a,l5)') mype, ' ---> ',Fleast_loc(1)
+! write(14,'(i5,a,i5)') mype, ' ---> ',Fitarg_s_loc(1)
+! write(15,'(i5,a,i5)') mype, ' ---> ',Fitarg_n_loc(1)
+! write(16,'(i5,a,i5)') mype, ' ---> ',Fitarg_w_loc(1)
+! write(17,'(i5,a,i5)') mype, ' ---> ',Fitarg_e_loc(1)
+
+!
+! Generation 2
+!
+
+ if(ix_0 <= nxm/2 .and. jy_0 <= nym/2) then
+ ix_c = ix_0
+ jy_c = jy_0
+ else &
+ if( (nxm/2 < ix_0 .and. ix_0 <=nxm) .and. jy_0 <= nym/2) then
+ ix_c = ix_0 - nxm/2
+ jy_c = jy_0
+ else &
+ if(ix_0 <= nxm/2 .and. (nym/2 < jy_0 .and. jy_0 <=nym) ) then
+ ix_c = ix_0
+ jy_c = jy_0 - nym/2
+ else &
+ if( (nxm/2 < ix_0 .and. ix_0 <=nxm) .and. (nym/2 < jy_0 .and. jy_0 <=nym) ) then
+ ix_c = ix_0 - nxm/2
+ jy_c = jy_0 - nym/2
+ end if
+
+ Flsouth_loc(2)=jy_c==1
+ Flnorth_loc(2)=jy_c==nym/2
+ Flwest_loc(2) =ix_c==1
+ Fleast_loc(2) =ix_c==nxm/2
+
+ if(Flsouth_loc(2)) then
+ Fitarg_s_loc(2) = -1
+ else
+ Fitarg_s_loc(2) = mype-nxm
+ endif
+
+ if(Flnorth_loc(2)) then
+ Fitarg_n_loc(2) = -1
+ else
+ Fitarg_n_loc(2) = mype+nxm
+ endif
+
+ if(Flwest_loc(2)) then
+ Fitarg_w_loc(2) = -1
+ else
+ Fitarg_w_loc(2) = mype-1
+ endif
+
+ if(Fleast_loc(2)) then
+ Fitarg_e_loc(2) = -1
+ else
+ Fitarg_e_loc(2) = mype+1
+ endif
+
+! write(10,'(i5,a,l5)') mype, ' ---> ',Flsouth_loc(2)
+! write(11,'(i5,a,l5)') mype, ' ---> ',Flnorth_loc(2)
+! write(12,'(i5,a,l5)') mype, ' ---> ',Flwest_loc(2)
+! write(13,'(i5,a,l5)') mype, ' ---> ',Fleast_loc(2)
+! write(14,'(i5,a,i5)') mype, ' ---> ',Fitarg_s_loc(2)
+! write(15,'(i5,a,i5)') mype, ' ---> ',Fitarg_n_loc(2)
+
+!
+! Generation 3
+!
+ if(ix_c <= nxm/4 .and. jy_c <= nym/4) then
+ ix_cc = ix_c
+ jy_cc = jy_c
+ else &
+ if(ix_c > nxm/4 .and. jy_c <= nym/4) then
+ ix_cc = ix_c-nxm/4
+ jy_cc =jy_c
+ else &
+ if(ix_c <= nxm/4 .and. jy_c > nym/4) then
+ ix_cc = ix_c
+ jy_cc =jy_c-nym/4
+ else &
+ if(ix_c > nxm/4 .and. jy_c > nym/4) then
+ ix_cc = ix_c-nxm/4
+ jy_cc = jy_c-nym/4
+ endif
+
+ Flsouth_loc(3)=jy_cc==1
+ Flnorth_loc(3)=jy_cc==nym/4
+ Flwest_loc(3) =ix_cc==1
+ Fleast_loc(3) =ix_cc==nxm/4
+
+ if(Flsouth_loc(3)) then
+ Fitarg_s_loc(3) = -1
+ else
+ Fitarg_s_loc(3) = mype-nxm
+ endif
+
+ if(Flnorth_loc(3)) then
+ Fitarg_n_loc(3) = -1
+ else
+ Fitarg_n_loc(3) = mype+nxm
+ endif
+
+ if(Flwest_loc(3)) then
+ Fitarg_w_loc(3) = -1
+ else
+ Fitarg_w_loc(3) = mype-1
+ endif
+
+ if(Fleast_loc(3)) then
+ Fitarg_e_loc(3) = -1
+ else
+ Fitarg_e_loc(3) = mype+1
+ endif
+
+! write(10,'(i5,a,l5)') mype, ' ---> ',Flsouth_loc(3)
+! write(11,'(i5,a,l5)') mype, ' ---> ',Flnorth_loc(3)
+! write(12,'(i5,a,l5)') mype, ' ---> ',Flwest_loc(3)
+! write(13,'(i5,a,l5)') mype, ' ---> ',Fleast_loc(3)
+! write(14,'(i5,a,i5)') mype, ' ---> ',Fitarg_s_loc(3)
+! write(15,'(i5,a,i5)') mype, ' ---> ',Fitarg_n_loc(3)
+
+!
+! Generation 4
+!
+ if(ix_cc <= nxm/8 .and. jy_cc <= nym/8) then
+ ix_ccc = ix_cc; jy_ccc = jy_cc
+ else &
+ if(ix_cc > nxm/8 .and. jy_cc <= nym/8) then
+ ix_ccc = ix_cc-nxm/8; jy_ccc =jy_cc
+ else &
+ if(ix_cc <= nxm/8 .and. jy_cc > nym/8) then
+ ix_ccc = ix_cc; jy_ccc =jy_cc-nym/8
+ else &
+ if(ix_cc > nxm/8 .and. jy_cc > nym/8) then
+ ix_ccc = ix_cc-nxm/8; jy_ccc =jy_cc-nym/8
+ endif
+
+ Flsouth_loc(4)=jy_ccc==1
+ Flnorth_loc(4)=jy_ccc==nym/8
+ Flwest_loc(4) =ix_ccc==1
+ Fleast_loc(4) =ix_ccc==nxm/8
+
+ if(Flsouth_loc(4)) then
+ Fitarg_s_loc(4) = -1
+ else
+ Fitarg_s_loc(4) = mype-nxm
+ endif
+
+ if(Flnorth_loc(4)) then
+ Fitarg_n_loc(4) = -1
+ else
+ Fitarg_n_loc(4) = mype+nxm
+ endif
+
+ if(Flwest_loc(4)) then
+ Fitarg_w_loc(4) = -1
+ else
+ Fitarg_w_loc(4) = mype-1
+ endif
+
+ if(Fleast_loc(4)) then
+ Fitarg_e_loc(4) = -1
+ else
+ Fitarg_e_loc(4) = mype+1
+ endif
+
+! enddo
+
+!----------------------------------------------------------------------
+endsubroutine sidesend_loc
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine targup_loc(this)
+!***********************************************************************
+! !
+! Initialize upsending pararameters for application MGBF to !
+! localization !
+! !
+!***********************************************************************
+implicit none
+class(mg_parameter_type),target::this
+integer(i_kind):: ix_0,jy_0
+integer(i_kind):: ix_c,jy_c,mype_c
+integer(i_kind):: ix_prox,jy_prox,targup
+integer(i_kind):: n,is,js, mj2, il,jl
+include "type_parameter_locpointer.inc"
+include "type_parameter_point2this.inc"
+!--------------------------------------------------------------------
+
+!do mype=0,nxm*nym-1
+
+ jy_0 = mype/nxm+1
+ ix_0 = mype-(jy_0-1)*nxm+1
+
+ mj2=mod(jy_0,2)
+ mype_c=(nxm/2)*(jy_0-2+mj2)/2+(ix_0-1)/2
+
+ jy_c = mype_c/(nxm/2)+1
+ ix_c = mype_c-(jy_c-1)*(nxm/2)+1
+
+ lsendup_sw_loc=(mod(ix_0,2)==1).and.(mod(jy_0,2)==1)
+ lsendup_se_loc=(mod(ix_0,2)==0).and.(mod(jy_0,2)==1)
+ lsendup_nw_loc=(mod(ix_0,2)==1).and.(mod(jy_0,2)==0)
+ lsendup_ne_loc=(mod(ix_0,2)==0).and.(mod(jy_0,2)==0)
+
+!
+! g1 --> g2
+!
+
+ do n=1,4
+ js=(n-1)/2
+ is= n-1 -js*2
+ ix_prox=ix_c+is*nxm/2
+ jy_prox=jy_c+js*nym/2
+
+ Fitargup_loc12(n)=nxm*(jy_prox-1)+ix_prox-1
+ enddo
+
+! write(12,'(i5,a,4i5)') mype,' ---> ', Fitargup_loc12(1),Fitargup_loc12(2),Fitargup_loc12(3),Fitargup_loc12(4)
+
+!
+! g2 --> g3
+!
+ il = (ix_0-1)/(nxm/2)
+ jl = (jy_0-1)/(nym/2)
+
+ do n=1,4
+ js=(n-1)/2
+ is= n-1-js*2
+ ix_prox=ix_c +is*nxm/4 + il*nxm/4
+ jy_prox=jy_c +js*nym/4 + jl*nym/4
+
+ Fitargup_loc23(n)=nxm*(jy_prox-1)+ix_prox-1
+ enddo
+
+! write(23,'(i5,a,4i5)') mype,' ---> ', Fitargup_loc23(1),Fitargup_loc23(2),Fitargup_loc23(3),Fitargup_loc23(4)
+
+!
+! g3 --> g4
+!
+ il = (ix_0-1)/(nxm/4)
+ jl = (jy_0-1)/(nym/4)
+
+ do n=1,4
+ js=(n-1)/2
+ is= n-1-js*2
+ ix_prox=ix_c +is*nxm/8 + il*nxm/8
+ jy_prox=jy_c +js*nym/8 + jl*nym/8
+
+ Fitargup_loc34(n)=nxm*(jy_prox-1)+ix_prox-1
+ enddo
+
+! write(34,'(i5,a,4i5)') mype,' ---> ',
+!Fitargup_loc34(1),Fitargup_loc34(2),Fitargup_loc34(3),Fitargup_loc34(4)
+
+!enddo
+
+!----------------------------------------------------------------------
+endsubroutine targup_loc
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine targdn21_loc(this)
+!***********************************************************************
+! !
+! Initialize downsending pararameters for application MGBF to !
+! localization from g2 go g1 !
+! !
+!***********************************************************************
+implicit none
+class(mg_parameter_type),target::this
+integer:: ix_t,jy_t
+integer:: ix_l,jy_l
+integer:: ix_sw,jy_sw
+integer:: ix_se,jy_se
+integer:: ix_nw,jy_nw
+integer:: ix_ne,jy_ne
+include "type_parameter_locpointer.inc"
+include "type_parameter_point2this.inc"
+!------------------------------------------------------------------------
+
+! write(11,'(a)') 'mype itargdn_xx_loc21 nsq21 '
+! write(11,'(a)') '---------------------------------'
+
+! do mype=0,nxm*nym-1
+
+ jy_t = mype/nxm+1
+ ix_t = mype-(jy_t-1)*nxm+1
+
+!
+! Square 1
+!
+ if(ix_t <= nxm/2 .and. jy_t <= nym/2) then
+ ix_l = ix_t
+ jy_l = jy_t
+ nsq21 = 1
+ else &
+!
+! Square 2
+!
+ if( (nxm/2 < ix_t .and. ix_t <= nxm) .and. jy_t <= nym/2) then
+ ix_l = ix_t-nxm/2
+ jy_l = jy_t
+ nsq21 = 2
+ else &
+!
+! Square 3
+!
+ if( ix_t <= nxm/2 .and. (nym/2 < jy_t .and. jy_t <= nym)) then
+ ix_l = ix_t
+ jy_l = jy_t-nym/2
+ nsq21 = 3
+ else &
+!
+! Square 4
+!
+ if( (nxm/2 < ix_t .and. ix_t <= nxm) .and. (nym/2 < jy_t .and. jy_t <= nym)) then
+ ix_l = ix_t-nxm/2
+ jy_l = jy_t-nym/2
+ nsq21 = 4
+ endif
+
+ ix_sw = 2*ix_l-1
+ jy_sw = 2*jy_l-1
+ itargdn_sw_loc21 = nxm*(jy_sw-1)+ix_sw-1
+
+ ix_se = ix_sw+1
+ jy_se = jy_sw
+ itargdn_se_loc21 = nxm*(jy_se-1)+ix_se-1
+
+ ix_nw = ix_sw
+ jy_nw = jy_sw+1
+ itargdn_nw_loc21 = nxm*(jy_nw-1)+ix_nw-1
+
+ ix_ne = ix_nw+1
+ jy_ne = jy_nw
+ itargdn_ne_loc21 = nxm*(jy_ne-1)+ix_ne-1
+
+! write(11,'(i6,a,2i4)') mype,' <-- itargdn_sw_loc21 ',itargdn_sw_loc21,nsq
+! write(11,'(i6,a,2i4)') mype,' <-- itargdn_se_loc21 ',itargdn_se_loc21,nsq
+! write(11,'(i6,a,2i4)') mype,' <-- itargdn_nw_loc21 ',itargdn_nw_loc21,nsq
+! write(11,'(i6,a,2i4)') mype,' <-- itargdn_ne_loc21 ',itargdn_ne_loc21,nsq
+
+! end do
+!-----------------------------------------------------------
+endsubroutine targdn21_loc
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine targdn32_loc(this)
+!***********************************************************************
+! !
+! Initialize downsending pararameters for application MGBF to !
+! localization from g3 go g2 !
+! !
+!***********************************************************************
+implicit none
+class(mg_parameter_type),target::this
+integer(i_kind):: ix_t,jy_t
+integer(i_kind):: ix_l,jy_l
+integer(i_kind):: ix_sw,jy_sw
+integer(i_kind):: ix_se,jy_se
+integer(i_kind):: ix_nw,jy_nw
+integer(i_kind):: ix_ne,jy_ne
+integer(i_kind):: facx,facy
+include "type_parameter_locpointer.inc"
+include "type_parameter_point2this.inc"
+!-----------------------------------------------------------
+
+! write(32,'(a)') 'mype itargdn_xx_loc32 nsq32 '
+! write(32,'(a)') '---------------------------------'
+
+! do mype=0,nxm*nym-1
+
+ jy_t = mype/nxm+1
+ ix_t = mype-(jy_t-1)*nxm+1
+
+!
+! Square 1
+!
+ if(ix_t <= nxm/4 .and. jy_t <= nym/4) then
+ ix_l = ix_t
+ jy_l = jy_t
+ nsq32 = 1
+ facx = 0
+ facy = 0
+ else &
+!
+! Square 2
+!
+ if( (nxm/4 < ix_t .and.ix_t<=nxm/2 ) .and. jy_t <= nym/4) then
+ ix_l = ix_t-nxm/4
+ jy_l = jy_t
+ nsq32 = 2
+ facx = 0
+ facy = 0
+ else &
+!
+! Square 3
+!
+ if( ix_t <= nxm/4 .and. (nym/4 < jy_t .and. jy_t <= nym/2)) then
+ ix_l = ix_t
+ jy_l = jy_t-nym/4
+ nsq32 = 3
+ facx = 0
+ facy = 0
+ else &
+!
+! Square 4
+!
+ if( (nxm/4 < ix_t .and. ix_t <= nxm/2) .and. (nym/4 < jy_t .and. jy_t <= nym/2)) then
+ ix_l = ix_t-nxm/4
+ jy_l = jy_t-nym/4
+ nsq32 = 4
+ facx = 0
+ facy = 0
+ else &
+!
+! Square 5
+!
+ if( (nxm/2 1) call this%init_mg_MPI
+
+!***
+!*** Initialize integration domain
+!***
+call this%init_mg_domain
+if(this%l_loc) then
+ call this%init_domain_loc
+endif
+
+!---------------------------------------------------------------------------
+!
+! All others are function of km2,km3,km,nm,mm,im,jm
+! and needs to be called separately for each application
+!
+!---------------------------------------------------------------------------
+!***
+!*** Define km and WORKA array based on input from mg_parameters and
+!*** depending on specific application
+!***
+
+!***
+!*** Allocate variables, define weights, prepare mapping
+!*** between analysis and filter grid
+!***
+
+call this%allocate_mg_intstate
+
+call this%def_offset_coef
+
+call this%def_mg_weights
+
+if(this%mgbf_line) then
+ call this%init_mg_line
+endif
+
+call this%lsqr_mg_coef
+
+call this%lwq_vertical_coef(this%lm_a,this%lm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref)
+
+!***
+!*** Just for testing of standalone version. In GSI WORKA will be given
+!*** through a separate subroutine
+!***
+
+!call input_3d(WORKA( 1: lm,:,:),1,1, 1,mm,nm, lm,mm0,4,3)
+!call input_3d(WORKA( lm+1:2*lm,:,:),1,1, lm+1,mm,nm,2*lm,mm0,6,5)
+!call input_3d(WORKA(2*lm+1:3*lm,:,:),1,1,2*lm+1,mm,nm,3*lm,mm0,2,1)
+!call input_3d(WORKA(3*lm+1:4*lm,:,:),1,1,3*lm+1,mm,nm,4*lm,mm0,3,2)
+!call input_3d(WORKA(4*lm+1:5*lm,:,:),1,1,4*lm+1,mm,nm,5*lm,mm0,7,3)
+!call input_3d(WORKA(5*lm+1:6*lm,:,:),1,1,5*lm+1,mm,nm,6*lm,mm0,4,5)
+
+!call input_3d(WORKA(6*lm+1:6*lm+1,:,:),1,1,6*lm+1,mm,nm,6*lm+1,mm0,2,1)
+!call input_3d(WORKA(6*lm+2:6*lm+2,:,:),1,1,6*lm+2,mm,nm,6*lm+2,mm0,4,1)
+!call input_3d(WORKA(6*lm+3:6*lm+3,:,:),1,1,6*lm+3,mm,nm,6*lm+3,mm0,5,1)
+!call input_3d(WORKA(6*lm+4:6*lm+4,:,:),1,1,6*lm+4,mm,nm,6*lm+4,mm0,7,1)
+
+!-----------------------------------------------------------------------
+endsubroutine mg_initialize
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine mg_finalize(this)
+!**********************************************************************!
+! !
+! Finalize multigrid Beta Function !
+! M. Rancic (2020) !
+!***********************************************************************
+implicit none
+class (mg_intstate_type)::this
+
+real(r_kind), allocatable, dimension(:,:):: PA, VA
+integer(i_kind):: n,m,L
+integer:: nm,mm,lm
+!-----------------------------------------------------------------------
+
+if(this%ldelta) then
+ !
+ ! Horizontal cross-section
+ !
+ nm=this%nm
+ mm=this%mm
+ lm=this%lm
+endif
+
+if(this%nxm*this%nym>1) call this%barrierMPI
+
+call this%deallocate_mg_intstate
+
+!-----------------------------------------------------------------------
+endsubroutine mg_finalize
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+end submodule mg_entrymod
diff --git a/src/mgbf/mg_filtering.f90 b/src/mgbf/mg_filtering.f90
new file mode 100644
index 0000000000..714a4b6bf4
--- /dev/null
+++ b/src/mgbf/mg_filtering.f90
@@ -0,0 +1,1629 @@
+submodule(mg_intstate) mg_filtering
+!$$$ submodule documentation block
+! . . . .
+! module: mg_filtering
+! prgmmr: rancic org: NCEP/EMC date: 2020
+!
+! abstract: Contains all multigrid filtering prodecures
+!
+! module history log:
+! 2023-04-19 lei - object-oriented coding
+! 2024-01-11 rancic - optimization for ensemble localization
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! filtering_procedure -
+! filtering_rad3 -
+! filtering_lin3 -
+! filtering_rad2_bkg -
+! filtering_lin2_bkg -
+! filtering_fast_bkg -
+! filtering_rad2_ens -
+! filtering_lin2_ens -
+! filtering_fast_ens -
+! filtering_rad_highest -
+! sup_vrbeta1 -
+! sup_vrbeta1T -
+! sup_vrbeta3 -
+! sup_vrbeta3T -
+! sup_vrbeta1_ens -
+! sup_vrbeta1T_ens -
+! sup_vrbeta1_bkg -
+! sup_vrbeta1T_bkg -
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mg_timers
+use kinds, only: r_kind,i_kind
+use jp_pbfil3, only: dibetat,dibeta
+use mpi
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+contains
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filtering_procedure(this,mg_filt,mg_filt_flag)
+!***********************************************************************
+! !
+! Driver for Multigrid filtering procedures with Helmholtz operator !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: mg_filt
+integer(i_kind),intent(in):: mg_filt_flag
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+if(this%nxm*this%nym>1) then
+ select case(mg_filt)
+ case(1)
+ call this%filtering_rad3
+ case(2)
+ call this%filtering_lin3
+ case(3)
+ call this%filtering_rad2_bkg
+ case(4)
+ call this%filtering_lin2_bkg
+ case(5)
+ call this%filtering_fast_bkg
+ case(6)
+ call this%filtering_rad2_ens(mg_filt_flag)
+ case(7)
+ call this%filtering_lin2_ens(mg_filt_flag)
+ case(8)
+ call this%filtering_fast_ens(mg_filt_flag)
+ end select
+else
+ call this%filtering_rad_highest
+endif
+!-----------------------------------------------------------------------
+endsubroutine filtering_procedure
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filtering_rad3(this)
+!***********************************************************************
+! !
+! Multigrid filtering procedure: !
+! !
+! - Multiple of 2D and 3D variables !
+! - 1 upsending and downsending !
+! - Applicaton of Helmholtz differential operator !
+! - 3d radial filter !
+! !
+!***********************************************************************
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target::this
+real(r_kind), allocatable, dimension(:,:,:):: VM2D
+real(r_kind), allocatable, dimension(:,:,:):: HM2D
+real(r_kind), allocatable, dimension(:,:,:,:):: VM3D
+real(r_kind), allocatable, dimension(:,:,:,:):: HM3D
+integer(i_kind) L,i,j
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+allocate(VM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; VM3D=0.
+allocate(VM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; VM2D=0.
+allocate(HM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; HM3D=0.
+allocate(HM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; HM2D=0.
+
+!***
+!*** Adjoint interpolate and upsend
+!***
+ call btim(upsend_tim)
+ call this%upsending_all(VALL,HALL,lquart)
+ call etim(upsend_tim)
+!***
+!*** Apply adjoint of Beta filter at all generations
+!***
+ call btim(hfiltT_tim)
+ call this%stack_to_composite(VALL,VM2D,VM3D)
+ call this%rbetaT(km2,hx,1,im,hy,1,jm,pasp2,ss2,VM2D)
+ call this%sup_vrbeta3T(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,VM3D)
+ call this%composite_to_stack(VM2D,VM3D,VALL)
+
+ if(l_hgen) then
+ call this%stack_to_composite(HALL,HM2D,HM3D)
+ call this%rbetaT(km2,hx,1,im,hy,1,jm,pasp2,ss2,HM2D)
+ call this%sup_vrbeta3T(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,HM3D)
+ call this%composite_to_stack(HM2D,HM3D,HALL)
+ endif
+ call etim(hfiltT_tim)
+
+ call btim(bocoT_tim)
+ call this%bocoT_2d(VALL,km,im,jm,hx,hy)
+ call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(bocoT_tim)
+!***
+!*** Apply (a-b\nabla^2)
+!***
+ call btim(weight_tim)
+ call this%weighting_all(VALL,HALL,lhelm)
+ call etim(weight_tim)
+!***
+!*** Apply Beta filter at all generations
+!***
+ call btim(boco_tim)
+ call this%boco_2d(VALL,km,im,jm,hx,hy)
+ call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(boco_tim)
+
+ call btim(hfilt_tim)
+ call this%stack_to_composite(VALL,VM2D,VM3D)
+ call this%rbeta(km2,hx,1,im,hy,1,jm,pasp2,ss2,VM2D(:,:,:))
+ call this%sup_vrbeta3(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,VM3D)
+ call this%composite_to_stack(VM2D,VM3D,VALL)
+ if(l_hgen) then
+ call this%stack_to_composite(HALL,HM2D,HM3D)
+ call this%rbeta(km2,hx,1,im,hy,1,jm,pasp2,ss2,HM2D(:,:,:))
+ call this%sup_vrbeta3(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,HM3D)
+ call this%composite_to_stack(HM2D,HM3D,HALL)
+ endif
+ call etim(hfilt_tim)
+!***
+!*** Downsend, interpolate and add
+!*** Then zero high generations
+!***
+ call btim(dnsend_tim)
+ call this%downsending_all(HALL,VALL,lquart)
+ call etim(dnsend_tim)
+
+deallocate(VM3D)
+deallocate(VM2D)
+deallocate(HM3D)
+deallocate(HM2D)
+!-----------------------------------------------------------------------
+endsubroutine filtering_rad3
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filtering_lin3(this)
+!***********************************************************************
+! !
+! Multigrid filtering procedure: !
+! !
+! - Multiple of 2D line filter !
+! - 1 upsending and downsending !
+! - Applicaton of Helmholtz differential operator !
+! - 3d line filter !
+! !
+!***********************************************************************
+!TEST
+use, intrinsic :: ieee_arithmetic
+!TEST
+use jp_pkind2, only: fpi
+implicit none
+class (mg_intstate_type),target::this
+integer(i_kind) k,i,j,L
+integer(i_kind) icol,iout,jout,lout
+logical:: ff
+real(r_kind), allocatable, dimension(:,:,:):: VM2D
+real(r_kind), allocatable, dimension(:,:,:):: HM2D
+real(r_kind), allocatable, dimension(:,:,:,:):: VM3D
+real(r_kind), allocatable, dimension(:,:,:,:):: HM3D
+real(r_kind), allocatable, dimension(:,:,:,:):: W
+real(r_kind), allocatable, dimension(:,:,:,:):: H
+integer(fpi), allocatable, dimension(:,:,:):: JCOL
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+allocate(VM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; VM3D=0.
+allocate(VM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; VM2D=0.
+allocate(HM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; HM3D=0.
+allocate(HM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; HM2D=0.
+allocate(W(km3,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz)) ; W=0.
+allocate(H(km3,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz)) ; H=0.
+allocate(JCOL(1:im,1:jm,1:Lm)) ; JCOL=0
+
+!***
+!*** Adjoint interpolate and upsend
+!***
+ call btim(upsend_tim)
+ call this%upsending_all(VALL,HALL,lquart)
+ call etim(upsend_tim)
+!***
+!*** Apply adjoint of Beta filter at all generations
+!***
+
+!
+! From single stack to composite variables
+!
+ call btim(hfiltT_tim)
+ call this%stack_to_composite(VALL,VM2D,VM3D)
+ if(l_hgen) then
+ call this%stack_to_composite(HALL,HM2D,HM3D)
+ endif
+ call etim(hfiltT_tim)
+!
+! Apply adjoint filter to 2D variables first
+!
+ do icol=3,1,-1
+ call btim(hfiltT_tim)
+ call dibetat(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout)
+ call etim(hfiltT_tim)
+ call btim(bocoT_tim)
+ call this%bocoT_2d(VM2D,km2,im,jm,hx,hy)
+ call etim(bocoT_tim)
+ enddo
+
+ do icol=3,1,-1
+ if(l_hgen) then
+ call btim(hfiltT_tim)
+ call dibetat(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout)
+ call etim(hfiltT_tim)
+ endif
+ call btim(bocoT_tim)
+ call this%bocoT_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(bocoT_tim)
+ enddo
+!
+! Create and apply adjoint filter to extended 3D variables
+!
+ W(:,:,:,1:lm)=VM3D(:,:,:,1:lm)
+ do icol=7,1,-1
+ call btim(hfiltT_tim)
+ do L=1,hz
+ W(:,:,:,1-L )=W(:,:,:,1+L )
+ W(:,:,:,LM+L)=W(:,:,:,LM-L)
+ enddo
+ call dibetat(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil &
+ ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout)
+ call etim(hfiltT_tim)
+ call btim(bocoT_tim)
+ call this%bocoT_3d(W,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax)
+ call etim(bocoT_tim)
+ enddo
+
+ if(l_hgen) then
+ H(:,:,:,1:lm)=HM3D(:,:,:,1:lm)
+ endif
+ do icol=7,1,-1
+ if(l_hgen) then
+ call btim(hfiltT_tim)
+ do L=1,hz
+ H(:,:,:,1-L )=H(:,:,:,1+L )
+ H(:,:,:,LM+L)=H(:,:,:,LM-L)
+ end do
+ call dibetat(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil &
+ ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout)
+ call etim(hfiltT_tim)
+ endif
+ call btim(bocoT_tim)
+ call this%bocoT_3d(H,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax,2,gm)
+ call etim(bocoT_tim)
+ enddo
+!
+! Go back from extended 3D variables and combine them with 2D variables in one stacked variable
+!
+ call btim(hfiltT_tim)
+ VM3D(:,:,:,1:lm)=W(:,:,:,1:lm)
+ call this%composite_to_stack(VM2D,VM3D,VALL)
+ if(l_hgen) then
+ HM3D(:,:,:,1:lm)=H(:,:,:,1:lm)
+ call this%composite_to_stack(HM2D,HM3D,HALL)
+ endif
+ call etim(hfiltT_tim)
+!***
+!*** Apply (a-b\nabla^2)
+!***
+ call btim(weight_tim)
+ call this%weighting_all(VALL,HALL,lhelm)
+ call etim(weight_tim)
+!***
+!*** Apply Beta filter at all generations
+!***
+
+!
+! From single stacked to composite variables
+!
+ call btim(hfilt_tim)
+ call this%stack_to_composite(VALL,VM2D,VM3D)
+ if(l_hgen) then
+ call this%stack_to_composite(HALL,HM2D,HM3D)
+ endif
+ call etim(hfilt_tim)
+!
+! Apply filter to 2D variables first
+!
+ do icol=1,3
+ call btim(boco_tim)
+ call this%boco_2d(VM2D,km2,im,jm,hx,hy)
+ call etim(boco_tim)
+ call btim(hfilt_tim)
+ call dibeta(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout)
+ call etim(hfilt_tim)
+ enddo
+
+ do icol=1,3
+ call btim(boco_tim)
+ call this%boco_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(boco_tim)
+ if(l_hgen) then
+ call btim(hfilt_tim)
+ call dibeta(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout)
+ call etim(hfilt_tim)
+ endif
+ enddo
+!
+! Create and apply filter to extended 3D variables
+!
+ W(:,:,:,1:lm)=VM3D(:,:,:,1:lm)
+ do L=1,hz
+ do j=1-hy,jm+hy
+ do i=1-hx,im+hx
+ W(:,i,j,1-L )=W(:,i,j,1+L )
+ W(:,i,j,LM+L)=W(:,i,j,LM-L)
+ enddo
+ enddo
+ enddo
+
+ do icol=1,7
+ call btim(boco_tim)
+ call this%boco_3d(W,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax)
+ call etim(boco_tim)
+ call btim(hfilt_tim)
+ call dibeta(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil &
+ ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout)
+ call etim(hfilt_tim)
+ enddo
+
+ if(l_hgen) then
+ H(:,:,:,1:lm)=HM3D(:,:,:,1:lm)
+ do L=1,hz
+ do j=1-hy,jm+hy
+ do i=1-hx,im+hx
+ H(:,i,j,1-L )=H(:,i,j,1+L )
+ H(:,i,j,LM+L)=H(:,i,j,LM-L)
+ enddo
+ enddo
+ enddo
+ endif
+ do icol=1,7
+ call btim(boco_tim)
+ call this%boco_3d(H,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax,2,gm)
+ call etim(boco_tim)
+ if(l_hgen) then
+ call btim(hfilt_tim)
+ call dibeta(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil &
+ ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout)
+ call etim(hfilt_tim)
+ endif
+ enddo
+!
+! Go back from extended 3D variables and combine them with 2D variables in one stacked variable
+!
+ call btim(hfilt_tim)
+ VM3D(:,:,:,1:lm)=W(:,:,:,1:lm)
+ call this%composite_to_stack(VM2D,VM3D,VALL)
+ if(l_hgen) then
+ HM3D(:,:,:,1:lm)=H(:,:,:,1:lm)
+ call this%composite_to_stack(HM2D,HM3D,HALL)
+ endif
+ call etim(hfilt_tim)
+!***
+!*** Downsend, interpolate and add, then zero high generations
+!***
+ call btim(dnsend_tim)
+ call this%downsending_all(HALL,VALL,lquart)
+ call etim(dnsend_tim)
+
+deallocate(VM3D)
+deallocate(VM2D)
+deallocate(HM3D)
+deallocate(HM2D)
+deallocate(W)
+deallocate(H)
+deallocate(JCOL)
+!-----------------------------------------------------------------------
+endsubroutine filtering_lin3
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filtering_rad2_bkg(this)
+!***********************************************************************
+! !
+! Multigrid filtering procedure: !
+! !
+! - Apply vertical filter before and after horizontal !
+! - 2d radial filter !
+! !
+!***********************************************************************
+implicit none
+class (mg_intstate_type),target::this
+integer(i_kind) L,i,j
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!***
+!*** Adjoint of beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfiltT_tim)
+ call this%sup_vrbeta1T_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfiltT_tim)
+ endif
+!***
+!*** Adjoint interpolate and upsend
+!***
+ call btim(upsend_tim)
+ call this%upsending_all(VALL,HALL,lquart)
+ call etim(upsend_tim)
+!***
+!*** Apply adjoint of Beta filter at all generations
+!***
+ call btim(hfiltT_tim)
+ call this%rbetaT(km,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:))
+ if(l_hgen) then
+ call this%rbetaT(km,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:))
+ endif
+ call etim(hfiltT_tim)
+
+ call btim(bocoT_tim)
+ call this%bocoT_2d(VALL,km,im,jm,hx,hy)
+ call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(bocoT_tim)
+!***
+!*** Apply (a-b\nabla^2)
+!***
+ call btim(weight_tim)
+ call this%weighting_all(VALL,HALL,lhelm)
+ call etim(weight_tim)
+!***
+!*** Apply Beta filter at all generations
+!***
+ call btim(boco_tim)
+ call this%boco_2d(VALL,km,im,jm,hx,hy)
+ call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(boco_tim)
+
+ call btim(hfilt_tim)
+ call this%rbeta(km,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:))
+ if(l_hgen) then
+ call this%rbeta(km,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:))
+ endif
+ call etim(hfilt_tim)
+!***
+!*** Downsend, interpolate and add, then zero high generations
+!***
+ call btim(dnsend_tim)
+ call this%downsending_all(HALL,VALL,lquart)
+ call etim(dnsend_tim)
+!***
+!*** Apply beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfilt_tim)
+ call this%sup_vrbeta1_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfilt_tim)
+ endif
+!-----------------------------------------------------------------------
+endsubroutine filtering_rad2_bkg
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filtering_lin2_bkg(this)
+!***********************************************************************
+! !
+! Multigrid filtering procedure: !
+! !
+! - Apply vertical filter before and after horizontal !
+! - 2d line filter !
+! !
+!***********************************************************************
+implicit none
+class (mg_intstate_type),target::this
+integer(i_kind) L,i,j
+integer(i_kind) icol,iout,jout
+logical:: ff
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+!***
+!*** Adjoint of beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfiltT_tim)
+ call this%sup_vrbeta1T_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfiltT_tim)
+ endif
+!***
+!*** Adjoint interpolate and upsend
+!***
+
+ call btim(upsend_tim)
+ call this%upsending_all(VALL,HALL,lquart)
+ call etim(upsend_tim)
+!***
+!*** Apply adjoint of Beta filter at all generations
+!***
+ do icol=3,1,-1
+ call btim(hfiltT_tim)
+ call dibetat(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout)
+ call etim(hfiltT_tim)
+ call btim(bocoT_tim)
+ call this%bocoT_2d(VALL,km,im,jm,hx,hy)
+ call etim(bocoT_tim)
+ enddo
+
+ do icol=3,1,-1
+ if(l_hgen) then
+ call btim(hfiltT_tim)
+ call dibetat(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout)
+ call etim(hfiltT_tim)
+ endif
+ call btim(bocoT_tim)
+ call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(bocoT_tim)
+ enddo
+!***
+!*** Apply (a-b\nabla^2)
+!***
+ call btim(weight_tim)
+ call this%weighting_all(VALL,HALL,lhelm)
+ call etim(weight_tim)
+!***
+!*** Apply Beta filter at all generations
+!***
+ do icol=1,3
+ call btim(boco_tim)
+ call this%boco_2d(VALL,km,im,jm,hx,hy)
+ call etim(boco_tim)
+ call btim(hfilt_tim)
+ call dibeta(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout)
+ call etim(hfilt_tim)
+ enddo
+
+ do icol=1,3
+ call btim(boco_tim)
+ call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(boco_tim)
+ if(l_hgen) then
+ call btim(hfilt_tim)
+ call dibeta(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout)
+ call etim(hfilt_tim)
+ endif
+ enddo
+!***
+!*** Downsend, interpolate and add, then zero high generations
+!***
+ call btim(dnsend_tim)
+ call this%downsending_all(HALL,VALL,lquart)
+ call etim(dnsend_tim)
+!***
+!*** Apply beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfilt_tim)
+ call this%sup_vrbeta1_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfilt_tim)
+ endif
+!-----------------------------------------------------------------------
+endsubroutine filtering_lin2_bkg
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filtering_fast_bkg(this)
+!***********************************************************************
+! !
+! Fast multigrid filtering procedure: !
+! !
+! - Apply adjoint of vertical filter before and directec vertical !
+! filter after horizontal !
+! - 1d+1d horizontal filter !
+! !
+!***********************************************************************
+implicit none
+class (mg_intstate_type),target::this
+integer(i_kind) L,i,j
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+!***
+!*** Adjoint of beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfiltT_tim)
+ call this%sup_vrbeta1T_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfiltT_tim)
+ endif
+!***
+!*** Adjoint interpolate and upsend
+!***
+ call btim(upsend_tim)
+ call this%upsending_all(VALL,HALL,lquart)
+ call etim(upsend_tim)
+!***
+!*** Apply adjoint of Beta filter at all generations
+!***
+ call btim(hfiltT_tim)
+ do i=im,1,-1
+ call this%rbetaT(km,hy,1,jm,paspy,ssy,VALL(:,i,:))
+ enddo
+ call etim(hfiltT_tim)
+ call btim(bocoT_tim)
+ call this%bocoTy(VALL,km,im,jm,hx,hy)
+ call etim(bocoT_tim)
+ call btim(hfiltT_tim)
+ do j=jm,1,-1
+ call this%rbetaT(km,hx,1,im,paspx,ssx,VALL(:,:,j))
+ enddo
+ call etim(hfiltT_tim)
+ call btim(bocoT_tim)
+ call this%bocoTx(VALL,km,im,jm,hx,hy)
+ call etim(bocoT_tim)
+ if(l_hgen) then
+ call btim(hfiltT_tim)
+ do i=im,1,-1
+ call this%rbetaT(km,hy,1,jm,paspy,ssy,HALL(:,i,:))
+ enddo
+ call etim(hfiltT_tim)
+ endif
+ call btim(bocoT_tim)
+ call this%bocoTy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(bocoT_tim)
+ if(l_hgen) then
+ call btim(hfiltT_tim)
+ do j=jm,1,-1
+ call this%rbetaT(km,hx,1,im,paspx,ssx,HALL(:,:,j))
+ enddo
+ call etim(hfiltT_tim)
+ endif
+ call btim(bocoT_tim)
+ call this%bocoTx(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(bocoT_tim)
+!***
+!*** Apply (a-b\nabla^2)
+!***
+ call btim(weight_tim)
+ call this%weighting_all(VALL,HALL,lhelm)
+ call etim(weight_tim)
+!***
+!*** Apply Beta filter at all generations
+!***
+ call btim(boco_tim)
+ call this%bocox(VALL,km,im,jm,hx,hy)
+ call etim(boco_tim)
+ call btim(hfilt_tim)
+ do j=1,jm
+ call this%rbeta(km,hx,1,im,paspx,ssx,VALL(:,:,j))
+ enddo
+ call etim(hfilt_tim)
+ call btim(boco_tim)
+ call this%bocoy(VALL,km,im,jm,hx,hy)
+ call etim(boco_tim)
+ call btim(hfilt_tim)
+ do i=1,im
+ call this%rbeta(km,hy,1,jm,paspy,ssy,VALL(:,i,:))
+ enddo
+ call etim(hfilt_tim)
+ call btim(boco_tim)
+ call this%bocox(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(boco_tim)
+ if(l_hgen) then
+ call btim(hfilt_tim)
+ do j=1,jm
+ call this%rbeta(km,hx,1,im,paspx,ssx,HALL(:,:,j))
+ enddo
+ call etim(hfilt_tim)
+ endif
+ call btim(boco_tim)
+ call this%bocoy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(boco_tim)
+ if(l_hgen) then
+ call btim(hfilt_tim)
+ do i=1,im
+ call this%rbeta(km,hy,1,jm,paspy,ssy,HALL(:,i,:))
+ enddo
+ call etim(hfilt_tim)
+ endif
+!***
+!*** Downsend, interpolate and add, then zero high generations
+!***
+ call btim(dnsend_tim)
+ call this%downsending_all(HALL,VALL,lquart)
+ call etim(dnsend_tim)
+!***
+!*** Apply beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfilt_tim)
+ call this%sup_vrbeta1_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfilt_tim)
+ endif
+!-----------------------------------------------------------------------
+endsubroutine filtering_fast_bkg
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filtering_rad2_ens(this,mg_filt_flag)
+!***********************************************************************
+! !
+! Multigrid filtering procedure for ensemble: !
+! !
+! - Apply vertical filter before and after horizontal !
+! - 2d radial filter !
+! - Version for localization of ensemble !
+! !
+!***********************************************************************
+implicit none
+class (mg_intstate_type),target::this
+integer(i_kind),intent(in):: mg_filt_flag
+integer(i_kind) L,i,j
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+if(mg_filt_flag==1) then
+ call btim(upsend_tim)
+ call this%upsending_ens_nearest(VALL,HALL,km_all)
+ call etim(upsend_tim)
+else
+!***
+!*** Adjoint of beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfiltT_tim)
+ call this%sup_vrbeta1T_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfiltT_tim)
+ endif
+!***
+!*** Adjoint interpolate and upsend
+!***
+ call btim(upsend_tim)
+ if(lquart) then
+ call this%upsending2_ens(VALL,HALL,km_all)
+ else
+ call this%upsending_ens(VALL,HALL,km_all)
+ endif
+ call etim(upsend_tim)
+!***
+!*** Apply adjoint of Beta filter at all generations
+!***
+ call btim(hfiltT_tim)
+ if(l_filt_g1) then
+ call this%rbetaT(km_all,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:))
+ endif
+ if(l_hgen) then
+ call this%rbetaT(km_all,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:))
+ endif
+ call etim(hfiltT_tim)
+
+ call btim(bocoT_tim)
+ if(l_filt_g1) then
+ call this%bocoT_2d(VALL,km_all,im,jm,hx,hy)
+ endif
+ call this%bocoT_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(bocoT_tim)
+endif
+!***
+!*** Apply (a-b\nabla^2)
+!***
+ call btim(weight_tim)
+ call this%weighting_ens(VALL,HALL,km_all)
+ call etim(weight_tim)
+
+if(mg_filt_flag==-1) then
+ call btim(dnsend_tim)
+ call this%downsending_ens_nearest(HALL,VALL,km_all)
+ call etim(dnsend_tim)
+else
+!***
+!*** Apply Beta filter at all generations
+!***
+ call btim(boco_tim)
+ if(l_filt_g1) then
+ call this%boco_2d(VALL,km_all,im,jm,hx,hy)
+ endif
+ call this%boco_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(boco_tim)
+
+ call btim(hfilt_tim)
+ if(l_filt_g1) then
+ call this%rbeta(km_all,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:))
+ endif
+ if(l_hgen) then
+ call this%rbeta(km_all,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:))
+ endif
+ call etim(hfilt_tim)
+!***
+!*** Downsend, interpolate and add, then zero high generations
+!***
+ call btim(dnsend_tim)
+ if(lquart) then
+ call this%downsending2_ens(HALL,VALL,km_all)
+ else
+ call this%downsending_ens(HALL,VALL,km_all)
+ endif
+ call etim(dnsend_tim)
+!***
+!*** Apply beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfilt_tim)
+ call this%sup_vrbeta1_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfilt_tim)
+ endif
+endif
+!-----------------------------------------------------------------------
+endsubroutine filtering_rad2_ens
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filtering_lin2_ens(this,mg_filt_flag)
+!***********************************************************************
+! !
+! Multigrid filtering procedure for ensemble: !
+! !
+! - Vertical filter before and after horizontal !
+! - Line filters in horizontal !
+! - Version for localization of ensemble !
+! !
+!***********************************************************************
+implicit none
+class (mg_intstate_type),target::this
+integer(i_kind),intent(in):: mg_filt_flag
+integer(i_kind) L,i,j
+integer(i_kind) icol,iout,jout
+logical:: ff
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+if(mg_filt_flag==1) then
+ call btim(upsend_tim)
+ call this%upsending_ens_nearest(VALL,HALL,km_all)
+ call etim(upsend_tim)
+else
+!***
+!*** Adjoint of beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfiltT_tim)
+ call this%sup_vrbeta1T_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfiltT_tim)
+ endif
+!***
+!*** Adjoint interpolate and upsend
+!***
+ call btim(upsend_tim)
+ if(lquart) then
+ call this%upsending2_ens(VALL,HALL,km_all)
+ else
+ call this%upsending_ens(VALL,HALL,km_all)
+ endif
+ call etim(upsend_tim)
+!***
+!*** Apply adjoint of Beta filter at all generations
+!***
+ if(l_filt_g1) then
+ do icol=3,1,-1
+ call btim(hfiltT_tim)
+ call dibetat(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout)
+ call etim(hfiltT_tim)
+ call btim(bocoT_tim)
+ call this%bocoT_2d(VALL,km_all,im,jm,hx,hy)
+ call etim(bocoT_tim)
+ enddo
+ endif
+
+ do icol=3,1,-1
+ if(l_hgen) then
+ call btim(hfiltT_tim)
+ call dibetat(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout)
+ call etim(hfiltT_tim)
+ endif
+ call btim(bocoT_tim)
+ call this%bocoT_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(bocoT_tim)
+ enddo
+endif
+!***
+!*** Apply (a-b\nabla^2)
+!***
+ call btim(weight_tim)
+ call this%weighting_ens(VALL,HALL,km_all)
+ call etim(weight_tim)
+
+if(mg_filt_flag==-1) then
+ call btim(dnsend_tim)
+ call this%downsending_ens_nearest(HALL,VALL,km_all)
+ call etim(dnsend_tim)
+else
+!***
+!*** Apply Beta filter at all generations
+!***
+ if(l_filt_g1) then
+ do icol=1,3
+ call btim(boco_tim)
+ call this%boco_2d(VALL,km_all,im,jm,hx,hy)
+ call etim(boco_tim)
+ call btim(hfilt_tim)
+ call dibeta(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout)
+ call etim(hfilt_tim)
+ enddo
+ endif
+
+ do icol=1,3
+ call btim(boco_tim)
+ call this%boco_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(boco_tim)
+ if(l_hgen) then
+ call btim(hfilt_tim)
+ call dibeta(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, &
+ dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout)
+ call etim(hfilt_tim)
+ endif
+ enddo
+!***
+!*** Downsend, interpolate and add, then zero high generations
+!***
+ call btim(dnsend_tim)
+ if(lquart) then
+ call this%downsending2_ens(HALL,VALL,km_all)
+ else
+ call this%downsending_ens(HALL,VALL,km_all)
+ endif
+ call etim(dnsend_tim)
+!***
+!*** Apply beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfilt_tim)
+ call this%sup_vrbeta1_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfilt_tim)
+ endif
+endif
+!-----------------------------------------------------------------------
+endsubroutine filtering_lin2_ens
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filtering_fast_ens(this,mg_filt_flag)
+!***********************************************************************
+! !
+! Fast multigrid filtering procedure for ensemble: !
+! !
+! - Apply vertical filter before and after horizontal !
+! - 1d+1d horizontal filter + 1d vertical filter !
+! - Version for localizaiton of ensemble !
+! !
+!***********************************************************************
+implicit none
+class (mg_intstate_type),target::this
+integer(i_kind),intent(in):: mg_filt_flag
+integer(i_kind) L,i,j
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+if(mg_filt_flag==1) then
+ call btim(upsend_tim)
+ call this%upsending_ens_nearest(VALL,HALL,km_all)
+ call etim(upsend_tim)
+else
+!***
+!*** Adjoint of beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfiltT_tim)
+ call this%sup_vrbeta1T_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfiltT_tim)
+ endif
+!***
+!*** Adjoint interpolate and upsend
+!***
+ call btim(upsend_tim)
+ if(lquart) then
+ call this%upsending2_ens(VALL,HALL,km_all)
+ else
+ call this%upsending_ens(VALL,HALL,km_all)
+ endif
+ call etim(upsend_tim)
+!***
+!*** Apply adjoint of Beta filter at all generations
+!***
+ if(l_filt_g1) then
+ call btim(hfiltT_tim)
+ do i=im,1,-1
+ call this%rbetaT(km_all,hy,1,jm,paspy,ssy,VALL(:,i,:))
+ enddo
+ call etim(hfiltT_tim)
+ call btim(bocoT_tim)
+ call this%bocoTy(VALL,km_all,im,jm,hx,hy)
+ call etim(bocoT_tim)
+ call btim(hfiltT_tim)
+ do j=jm,1,-1
+ call this%rbetaT(km_all,hx,1,im,paspx,ssx,VALL(:,:,j))
+ enddo
+ call etim(hfiltT_tim)
+ call btim(bocoT_tim)
+ call this%bocoTx(VALL,km_all,im,jm,hx,hy)
+ call etim(bocoT_tim)
+ endif
+ if(l_hgen) then
+ call btim(hfiltT_tim)
+ do i=im,1,-1
+ call this%rbetaT(km_all,hy,1,jm,paspy,ssy,HALL(:,i,:))
+ enddo
+ call etim(hfiltT_tim)
+ endif
+ call btim(bocoT_tim)
+ call this%bocoTy(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(bocoT_tim)
+ if(l_hgen) then
+ call btim(hfiltT_tim)
+ do j=jm,1,-1
+ call this%rbetaT(km_all,hx,1,im,paspx,ssx,HALL(:,:,j))
+ enddo
+ call etim(hfiltT_tim)
+ endif
+ call btim(bocoT_tim)
+ call this%bocoTx(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(bocoT_tim)
+endif
+!***
+!*** Apply (a-b\nabla^2)
+!***
+ call btim(weight_tim)
+ call this%weighting_ens(VALL,HALL,km_all)
+ call etim(weight_tim)
+
+if(mg_filt_flag==-1) then
+ call btim(dnsend_tim)
+ call this%downsending_ens_nearest(HALL,VALL,km_all)
+ call etim(dnsend_tim)
+else
+!***
+!*** Apply Beta filter at all generations
+!***
+ if(l_filt_g1) then
+ call btim(boco_tim)
+ call this%bocox(VALL,km_all,im,jm,hx,hy)
+ call etim(boco_tim)
+ call btim(hfilt_tim)
+ do j=1,jm
+ call this%rbeta(km_all,hx,1,im,paspx,ssx,VALL(:,:,j))
+ enddo
+ call etim(hfilt_tim)
+ call btim(boco_tim)
+ call this%bocoy(VALL,km_all,im,jm,hx,hy)
+ call etim(boco_tim)
+ call btim(hfilt_tim)
+ do i=1,im
+ call this%rbeta(km_all,hy,1,jm,paspy,ssy,VALL(:,i,:))
+ enddo
+ call etim(hfilt_tim)
+ endif
+ call btim(boco_tim)
+ call this%bocox(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(boco_tim)
+ if(l_hgen) then
+ call btim(hfilt_tim)
+ do j=1,jm
+ call this%rbeta(km_all,hx,1,im,paspx,ssx,HALL(:,:,j))
+ enddo
+ call etim(hfilt_tim)
+ endif
+ call btim(boco_tim)
+ call this%bocoy(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm)
+ call etim(boco_tim)
+ if(l_hgen) then
+ call btim(hfilt_tim)
+ do i=1,im
+ call this%rbeta(km_all,hy,1,jm,paspy,ssy,HALL(:,i,:))
+ enddo
+ call etim(hfilt_tim)
+ endif
+!***
+!*** Downsend, interpolate and add, then zero high generations
+!***
+ call btim(dnsend_tim)
+ if(lquart) then
+ call this%downsending2_ens(HALL,VALL,km_all)
+ else
+ call this%downsending_ens(HALL,VALL,km_all)
+ endif
+ call etim(dnsend_tim)
+!***
+!*** Apply beta filter in vertical direction
+!***
+ if(l_vertical_filter) then
+ call btim(vfilt_tim)
+ call this%sup_vrbeta1_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL)
+ call etim(vfilt_tim)
+ endif
+endif
+!-----------------------------------------------------------------------
+endsubroutine filtering_fast_ens
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filtering_rad_highest(this)
+!***********************************************************************
+! !
+! Multigrid filtering procedure: !
+! !
+! - 2d radial filter only for the highest generation !
+! - Without horizontal parallelization !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target:: this
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!-----------------------------------------------------------------------
+
+!***
+!*** Adjoint interpolate and upsend
+!***
+ call btim(upsend_tim)
+ call this%upsending_highest(VALL,HALL)
+ call etim(upsend_tim)
+!***
+!*** Apply adjoint of Beta filter at all generations
+!***
+ call btim(hfiltT_tim)
+ call this%rbetaT(km,hx,1,imH,hy,1,jmH,&
+ &pasp2(:,:,1:imH,1:jmH),ss2(1:imH,1:jmH),HALL(:,1-hx:imH+hx,1-hy:jmH+hy))
+ call etim(hfiltT_tim)
+!***
+!*** Apply (a-b\nabla^2)
+!***
+ call btim(weight_tim)
+ call this%weighting_highest(HALL(:,1-hx:imH+hx,1-hy:jmH+hy))
+ call etim(weight_tim)
+!***
+!*** Apply Beta filter at all generations
+!***
+ call btim(hfilt_tim)
+ call this%rbeta(km,hx,1,imH,hy,1,jmH,&
+ &pasp2(:,:,1:imH,1:jmH),ss2(1:imH,1:jmH),HALL(:,1-hx:imH+hx,1-hy:jmH+hy))
+ call etim(hfilt_tim)
+!***
+!*** Downsend, interpolate and add, then zero high generations
+!***
+ call btim(dnsend_tim)
+ call this%downsending_highest(HALL,VALL)
+ call etim(dnsend_tim)
+
+!-----------------------------------------------------------------------
+endsubroutine filtering_rad_highest
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine sup_vrbeta1 &
+!**********************************************************************
+! *
+! conversion of vrbeta1 *
+! *
+!**********************************************************************
+(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm
+real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V
+real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+real(r_kind),dimension(1:lm), intent(in):: ss
+real(r_kind),dimension(1:kmax,1-hz:lm+hz):: W
+integer(i_kind):: i,j,L
+!----------------------------------------------------------------------
+
+ do j=1,jm
+ do i=1,im
+ do L=1,Lm
+ W(:,L)=V(:,i,j,L)
+ end do
+ do L=1,hz
+ W(:,1-L)=W(:,1+L)
+ W(:,LM+L)=W(:,LM-L)
+ end do
+ call this%rbeta(kmax,hz,1,lm, pasp,ss,W)
+ do l=1,Lm
+ V(:,i,j,L)=W(:,L)
+ end do
+ end do
+ end do
+
+!----------------------------------------------------------------------
+endsubroutine sup_vrbeta1
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine sup_vrbeta1T &
+!**********************************************************************
+! *
+! Adjoint of sup_vrbeta1 *
+! *
+!**********************************************************************
+(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm
+real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V
+real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+real(r_kind),dimension(1:lm), intent(in):: ss
+real(r_kind),dimension(1:kmax,1-hz:lm+hz):: W
+integer(i_kind):: i,j,L
+!----------------------------------------------------------------------
+
+ do j=1,jm
+ do i=1,im
+ do L=1,Lm
+ W(:,L)=V(:,i,j,L)
+ end do
+ do L=1,hz
+ W(:,1-L )=W(:,1+L )
+ W(:,LM+L)=W(:,LM-L)
+ end do
+ call this%rbetaT(kmax,hz,1,lm, pasp,ss,W)
+!
+! Apply adjoint at the edges of domain
+!
+ do L=1,hz
+ W(:,1+L)=W(:,1+L)+W(:,1-L)
+ W(:,LM-L)=W(:,LM-L)+W(:,LM+L)
+ enddo
+ do l=1,Lm
+ V(:,i,j,L)=W(:,L)
+ end do
+ end do
+ end do
+
+!----------------------------------------------------------------------
+endsubroutine sup_vrbeta1T
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine sup_vrbeta3 &
+!**********************************************************************
+! *
+! conversion of vrbeta3 *
+! *
+!**********************************************************************
+(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm
+real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V
+real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp
+real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss
+real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz):: W
+integer(i_kind):: i,j,L
+!----------------------------------------------------------------------
+
+ do L=1,Lm
+ do j=1-hy,jm+hy
+ do i=1-hx,im+hx
+ W(:,i,j,L)=V(:,i,j,L)
+ end do
+ end do
+ end do
+
+ do L=1,hz
+ do j=1-hy,jm+hy
+ do i=1-hx,im+hx
+ W(:,i,j,1-L )=W(:,i,j,1+L )
+ W(:,i,j,LM+L)=W(:,i,j,LM-L)
+ end do
+ end do
+ end do
+
+
+ call this%rbeta(kmax,hx,1,im, hy,1,jm, hz,1,lm, pasp,ss,W)
+
+
+ do l=1,Lm
+ do j=1,jm
+ do i=1,im
+ V(:,i,j,L)=W(:,i,j,L)
+ end do
+ end do
+ end do
+
+!----------------------------------------------------------------------
+endsubroutine sup_vrbeta3
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine sup_vrbeta3T &
+!**********************************************************************
+! *
+! Adjoint of sup_vrbeta3 *
+! *
+!**********************************************************************
+(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm
+real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V
+real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp
+real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss
+real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz):: W
+integer(i_kind):: i,j,l
+!----------------------------------------------------------------------
+
+ do L=1,Lm
+ do j=1-hy,jm+hy
+ do i=1-hx,im+hx
+ W(:,i,j,L)=V(:,i,j,L)
+ end do
+ end do
+ end do
+
+ do L=1,hz
+ do j=1-hy,jm+hy
+ do i=1-hx,im+hx
+ W(:,i,j,1-L )=W(:,i,j, 1+L)
+ W(:,i,j,LM+L)=W(:,i,j,LM-L)
+ end do
+ end do
+ end do
+
+
+ call this%rbetaT(kmax,hx,1,im, hy,1,jm, hz,1,lm, pasp,ss,W)
+
+!
+! Apply adjoint at the edges of domain
+!
+ do L=1,hz
+ do j=1-hy,jm+hy
+ do i=1-hx,im+hx
+ W(:,i,j,1+L )=W(:,i,j, 1+L)+W(:,i,j, 1-L)
+ W(:,i,j,LM-L)=W(:,i,j,LM-L)+W(:,i,j,LM+L)
+ end do
+ end do
+ end do
+
+ do l=1,lm
+ do j=1,jm
+ do i=1,im
+ V(:,i,j,l)=W(:,i,j,l)
+ end do
+ end do
+ end do
+
+!----------------------------------------------------------------------
+endsubroutine sup_vrbeta3T
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine sup_vrbeta1_ens &
+!**********************************************************************
+! *
+! conversion of vrbeta1 *
+! *
+!**********************************************************************
+(this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm
+real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL
+real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+real(r_kind),dimension(1:lm), intent(in):: ss
+real(r_kind),dimension(1:km_en,1-hz:lm+hz):: W
+integer(i_kind):: i,j,L,k,k_ind,kloc
+!----------------------------------------------------------------------
+
+ do j=1,jm
+ do i=1,im
+ do k=1,km_en
+ k_ind =(k-1)*Lm
+ do L=1,Lm
+ kloc=k_ind+L
+ W(k,L)=VALL(kloc,i,j)
+ end do
+ enddo
+ do L=1,hz
+ W(:,1-L )=W(:,1+L )
+ W(:,LM+L)=W(:,LM-L)
+ end do
+
+ call this%rbeta(km_en,hz,1,lm, pasp,ss,W)
+
+ do k=1,km_en
+ k_ind =(k-1)*Lm
+ do L=1,Lm
+ kloc=k_ind+L
+ VALL(kloc,i,j)= W(k,L)
+ end do
+ enddo
+ enddo
+ enddo
+
+!----------------------------------------------------------------------
+endsubroutine sup_vrbeta1_ens
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine sup_vrbeta1T_ens &
+!**********************************************************************
+! *
+! Adjoint of sup_vrbeta1_ens *
+! *
+!**********************************************************************
+(this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm
+real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL
+real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+real(r_kind),dimension(1:lm), intent(in):: ss
+real(r_kind),dimension(1:km_en,1-hz:lm+hz):: W
+integer(i_kind):: i,j,L,k,k_ind,kloc
+!----------------------------------------------------------------------
+
+ do j=1,jm
+ do i=1,im
+
+ do k=1,km_en
+ k_ind = (k-1)*Lm
+ do L=1,Lm
+ kloc=k_ind+L
+ W(k,L)=VALL(kloc,i,j)
+ end do
+ enddo
+ do L=1,hz
+ W(:,1-L )=W(:,1+L )
+ W(:,LM+L)=W(:,LM-L)
+ end do
+
+ call this%rbetaT(km_en,hz,1,lm, pasp,ss,W)
+!
+! Apply adjoint at the edges of domain
+!
+ do L=1,hz
+ W(:,1+L )=W(:,1+L )+W(:,1-L)
+ W(:,LM-L)=W(:,LM-L)+W(:,LM+L)
+ enddo
+
+ do k=1,km_en
+ k_ind = (k-1)*Lm
+ do l=1,Lm
+ kloc=k_ind+L
+ VALL(kloc,i,j)=W(k,L)
+ enddo
+ end do
+
+ end do
+ end do
+
+!----------------------------------------------------------------------
+endsubroutine sup_vrbeta1T_ens
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine sup_vrbeta1_bkg &
+!**********************************************************************
+! *
+! conversion of vrbeta1 *
+! *
+!**********************************************************************
+(this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm
+real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL
+real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+real(r_kind),dimension(1:lm), intent(in):: ss
+real(r_kind),dimension(1:km3,1-hz:lm+hz):: W
+integer(i_kind):: i,j,L,k,k_ind,kloc
+!----------------------------------------------------------------------
+
+ do j=1,jm
+ do i=1,im
+ do k=1,km3
+ k_ind =(k-1)*Lm
+ do L=1,Lm
+ kloc=k_ind+L
+ W(k,L)=VALL(kloc,i,j)
+ end do
+ enddo
+ do L=1,hz
+ W(:,1-L )=W(:,1+L )
+ W(:,LM+L)=W(:,LM-L)
+ end do
+
+ call this%rbeta(km3,hz,1,lm, pasp,ss,W)
+
+ do k=1,km3
+ k_ind =(k-1)*Lm
+ do L=1,Lm
+ kloc=k_ind+L
+ VALL(kloc,i,j)= W(k,L)
+ end do
+ enddo
+ enddo
+ enddo
+
+!----------------------------------------------------------------------
+endsubroutine sup_vrbeta1_bkg
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine sup_vrbeta1T_bkg &
+!**********************************************************************
+! *
+! Adjoint of sup_vrbeta1_bkg *
+! *
+!**********************************************************************
+(this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm
+real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL
+real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+real(r_kind),dimension(1:lm), intent(in):: ss
+real(r_kind),dimension(1:km3,1-hz:lm+hz):: W
+integer(i_kind):: i,j,L,k,k_ind,kloc
+!----------------------------------------------------------------------
+
+ do j=1,jm
+ do i=1,im
+
+ do k=1,km3
+ k_ind = (k-1)*Lm
+ do L=1,Lm
+ kloc=k_ind+L
+ W(k,L)=VALL(kloc,i,j)
+ end do
+ enddo
+ do L=1,hz
+ W(:,1-L )=W(:,1+L )
+ W(:,LM+L)=W(:,LM-L)
+ end do
+
+ call this%rbetaT(km3,hz,1,lm, pasp,ss,W)
+!
+! Apply adjoint at the edges of domain
+!
+ do L=1,hz
+ W(:,1+L )=W(:,1+L )+W(:,1-L)
+ W(:,LM-L)=W(:,LM-L)+W(:,LM+L)
+ enddo
+
+ do k=1,km3
+ k_ind = (k-1)*Lm
+ do l=1,Lm
+ kloc=k_ind+L
+ VALL(kloc,i,j)=W(k,L)
+ enddo
+ end do
+
+ end do
+ end do
+
+!----------------------------------------------------------------------
+endsubroutine sup_vrbeta1T_bkg
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+end submodule mg_filtering
diff --git a/src/mgbf/mg_generations.f90 b/src/mgbf/mg_generations.f90
new file mode 100644
index 0000000000..2008a75289
--- /dev/null
+++ b/src/mgbf/mg_generations.f90
@@ -0,0 +1,1756 @@
+submodule(mg_intstate) mg_generations
+!$$$ submodule documentation block
+! . . . .
+! module: mg_generations
+! prgmmr: rancic org: NCEP/EMC date: 2022
+!
+! abstract: Contains procedures that include differrent generations
+! (offset version)
+!
+! module history log:
+! 2023-04-19 lei - object-oriented coding
+! 2024-01-11 rancic - optimization for ensemble localization
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! upsending_all -
+! downsending_all -
+! weighting_all -
+! upsending -
+! downsending -
+! upsending_highest -
+! downsending_highest -
+! upsending2 -
+! downsending2 -
+! upsending_ens -
+! downsending_ens -
+! upsending_ens_nearest -
+! downsending_ens_nearest -
+! upsending2_ens -
+! downsending2_ens -
+! upsending_loc_g3 -
+! upsending_loc_g4 -
+! downsending_loc_g3 -
+! downsending_loc_g4 -
+! weighting_helm -
+! weighting -
+! weighting_highest -
+! weighting_ens -
+! weighting_loc_g3 -
+! weighting_loc_g4 -
+! adjoint -
+! direct1 -
+! adjoint2 -
+! direct2 -
+! adjoint_nearest -
+! direct_nearest -
+! adjoint_highest -
+! direct_highest -
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+!***********************************************************************
+! !
+! !
+! M. Rancic (2022) !
+!***********************************************************************
+use mpi
+use kinds, only: r_kind,i_kind
+use mg_timers
+!TEST
+use, intrinsic:: ieee_arithmetic
+!TEST
+
+interface weighting_loc
+ module procedure weighting_loc_g3
+ module procedure weighting_loc_g4
+endinterface
+
+interface upsending_loc
+ module procedure upsending_loc_g3
+ module procedure upsending_loc_g4
+endinterface
+
+interface downsending_loc
+ module procedure downsending_loc_g3
+ module procedure downsending_loc_g4
+endinterface
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+contains
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsending_all &
+!***********************************************************************
+! !
+! Adjoint interpolate and upsend: !
+! !
+!***********************************************************************
+(this,V,H,lquart)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+logical, intent(in):: lquart
+!-----------------------------------------------------------------------
+
+ if(lquart) then
+ call this%upsending2(V,H)
+ else
+ call this%upsending(V,H)
+ endif
+
+!-----------------------------------------------------------------------
+endsubroutine upsending_all
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsending_all &
+!***********************************************************************
+! !
+! Downsend, interpolate and add: !
+! First from gm->g3...->g2 !
+! Then from g2->g1 !
+! !
+!***********************************************************************
+(this,H,V,lquart)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+logical, intent(in):: lquart
+!-----------------------------------------------------------------------
+
+ if(lquart) then
+ call this%downsending2(H,V)
+ else
+ call this%downsending(H,V)
+ endif
+
+!-----------------------------------------------------------------------
+endsubroutine downsending_all
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine weighting_all &
+!***********************************************************************
+! !
+! Apply 2D differential operator to compound variable !
+! !
+!***********************************************************************
+(this,V,H,lhelm)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+logical, intent(in):: lhelm
+!-----------------------------------------------------------------------
+
+ if(lhelm) then
+ call this%weighting_helm(V,H)
+ else
+ call this%weighting(V,H)
+ endif
+
+!-----------------------------------------------------------------------
+endsubroutine weighting_all
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsending &
+!***********************************************************************
+! !
+! Adjoint interpolate and upsend: !
+! First from g1->g2 (V -> H) !
+! Then from g2->...->gn (H -> H) !
+! !
+!***********************************************************************
+(this,V,H)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: V_INT
+real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT
+integer(i_kind):: g,L
+!-----------------------------------------------------------------------
+!
+! From generation 1 to generation 2
+!
+
+ call this%adjoint(V(1:this%km,1:this%im,1:this%jm),V_INT,this%km,1)
+
+ call this%bocoT_2d(V_INT,this%km,this%imL,this%jmL,2,2)
+
+ call this%upsend_all(V_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km)
+!
+! From generation 2 sequentially to higher generations
+!
+ do g=2,this%gm-1
+
+ if(g==this%my_hgen) then
+ call this%adjoint(H(1:this%km,1:this%im,1:this%jm),H_INT,this%km,g)
+ endif
+
+ call this%bocoT_2d(H_INT,this%km,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g)
+
+ call this%upsend_all(H_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km,g,g+1)
+
+ end do
+
+!-----------------------------------------------------------------------
+endsubroutine upsending
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsending &
+!***********************************************************************
+! !
+! Downsend, interpolate and add: !
+! First from gm->g3...->g2 !
+! Then from g2->g1 !
+! !
+!***********************************************************************
+(this,H,V)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT
+real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: V_INT
+real(r_kind),dimension(this%km,1:this%im,1:this%jm):: H_PROX
+real(r_kind),dimension(this%km,1:this%im,1:this%jm):: V_PROX
+integer(i_kind):: g,l,k
+integer(i_kind):: iL,jL,i,j
+!-----------------------------------------------------------------------
+!
+! Upper generations
+!
+ do g=this%gm,3,-1
+
+ call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),H_INT(1:this%km,1:this%imL,1:this%jmL),this%km,g,g-1)
+ call this%boco_2d(H_INT,this%km,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g-1,g-1)
+
+ if(this%my_hgen==g-1) then
+ call this%direct1(H_INT,H_PROX,this%km,g-1)
+ H(1:this%km,1:this%im,1:this%jm)=H (1:this%km,1:this%im,1:this%jm) &
+ +H_PROX(1:this%km,1:this%im,1:this%jm)
+ endif
+
+ enddo
+
+!
+! From geneartion 2 to generation 1
+!
+
+ call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),V_INT(1:this%km,1:this%imL,1:this%jmL),this%km)
+ H(:,:,:)=0.
+
+ call this%boco_2d(V_INT,this%km,this%imL,this%jmL,2,2)
+
+ call this%direct1(V_INT,V_PROX,this%km,1)
+
+ V(1:this%km,1:this%im,1:this%jm)=V (1:this%km,1:this%im,1:this%jm) &
+ +V_PROX(1:this%km,1:this%im,1:this%jm)
+
+!-----------------------------------------------------------------------
+endsubroutine downsending
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsending_highest &
+!***********************************************************************
+! !
+! Adjoint interpolate and upsend: !
+! First from g1->g2 (V -> H) !
+! Then from g2->...->gn (H -> H) !
+! !
+!***********************************************************************
+(this,V,H)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT
+integer(i_kind):: g
+!-----------------------------------------------------------------------
+!
+! From generation 1 to higher generations
+!
+ H(:,:,:)=0.
+ H(1:this%km,1:this%im0(1),1:this%jm0(1))=V(1:this%km,1:this%im0(1),1:this%jm0(1))
+ do g=1,this%gm-1
+ call this%adjoint_highest(H(1:this%km,1:this%im0(g),1:this%jm0(g)),&
+ & H_INT(1:this%km,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2),this%km,g)
+ H(1:this%km,1:this%im0(g),1:this%jm0(g))=0.
+ H(1:this%km,1:this%im0(g+1),1:this%jm0(g+1))=H_INT(1:this%km,1:this%im0(g+1),1:this%jm0(g+1))
+ H_INT(1:this%km,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2)=0.
+ end do
+
+!-----------------------------------------------------------------------
+endsubroutine upsending_highest
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsending_highest &
+!***********************************************************************
+! !
+! Downsend, interpolate and add: !
+! First from gm->g3...->g2 !
+! Then from g2->g1 !
+! !
+!***********************************************************************
+(this,H,V)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT
+integer(i_kind):: g
+!-----------------------------------------------------------------------
+!
+! Upper generations
+!
+ do g=this%gm,2,-1
+ H_INT(1:this%km,-1:this%im0(g)+2,-1:this%jm0(g)+2)=0.
+ H_INT(1:this%km,1:this%im0(g),1:this%jm0(g))=H(1:this%km,1:this%im0(g),1:this%jm0(g))
+ H(1:this%km,1:this%im0(g-1),1:this%jm0(g-1))=0.
+ call this%direct_highest(H_INT(1:this%km,-1:this%im0(g)+2,-1:this%jm0(g)+2),&
+ & H(1:this%km,1:this%im0(g-1),1:this%jm0(g-1)),this%km,g-1)
+ enddo
+ V(:,:,:)=0.
+ V(1:this%km,1:this%im0(1),1:this%jm0(1))=H(1:this%km,1:this%im0(1),1:this%jm0(1))
+ H(:,:,:)=0.
+
+!-----------------------------------------------------------------------
+endsubroutine downsending_highest
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsending2 &
+!***********************************************************************
+! !
+! Adjoint interpolate and upsend: !
+! First from g1->g2 (V -> H) !
+! Then from g2->...->gn (H -> H) !
+! !
+!***********************************************************************
+(this,V,H)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: V_INT
+real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: H_INT
+integer(i_kind):: g,L
+!-----------------------------------------------------------------------
+!
+! From generation 1 to generation 2
+!
+
+ call this%adjoint2(V(1:this%km,1:this%im,1:this%jm),V_INT,this%km,1)
+
+ call this%bocoT_2d(V_INT,this%km,this%imL,this%jmL,1,1)
+
+ call this%upsend_all(V_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km)
+!
+! From generation 2 sequentially to higher generations
+!
+ do g=2,this%gm-1
+
+ if(g==this%my_hgen) then
+ call this%adjoint2(H(1:this%km,1:this%im,1:this%jm),H_INT,this%km,g)
+ endif
+
+ call this%bocoT_2d(H_INT,this%km,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g,g)
+
+ call this%upsend_all(H_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km,g,g+1)
+
+ end do
+
+!-----------------------------------------------------------------------
+endsubroutine upsending2
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsending2 &
+!***********************************************************************
+! !
+! Downsend, interpolate and add: !
+! First from gm->g3...->g2 !
+! Then from g2->g1 !
+! !
+!***********************************************************************
+(this,H,V)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: H_INT
+real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: V_INT
+real(r_kind),dimension(this%km,1:this%im,1:this%jm):: H_PROX
+real(r_kind),dimension(this%km,1:this%im,1:this%jm):: V_PROX
+integer(i_kind):: g,l,k
+integer(i_kind):: iL,jL,i,j
+!-----------------------------------------------------------------------
+!
+! Upper generations
+!
+ do g=this%gm,3,-1
+
+ call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),H_INT(1:this%km,1:this%imL,1:this%jmL),this%km,g,g-1)
+ call this%boco_2d(H_INT,this%km,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g-1,g-1)
+
+ if(this%my_hgen==g-1) then
+ call this%direct2(H_INT,H_PROX,this%km,g-1)
+ H(1:this%km,1:this%im,1:this%jm)=H (1:this%km,1:this%im,1:this%jm) &
+ +H_PROX(1:this%km,1:this%im,1:this%jm)
+ endif
+
+ enddo
+
+!
+! From generation 2 to generation 1
+!
+
+ call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),V_INT(1:this%km,1:this%imL,1:this%jmL),this%km)
+ H(:,:,:)=0.
+
+ call this%boco_2d(V_INT,this%km,this%imL,this%jmL,1,1)
+
+ call this%direct2(V_INT,V_PROX,this%km,1)
+
+ V(1:this%km,1:this%im,1:this%jm)=V (1:this%km,1:this%im,1:this%jm) &
+ +V_PROX(1:this%km,1:this%im,1:this%jm)
+
+!-----------------------------------------------------------------------
+endsubroutine downsending2
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsending_ens &
+!***********************************************************************
+! !
+! Adjoint interpolate and upsend: !
+! First from g1->g2 (V -> H) !
+! Then from g2->...->gn (H -> H) !
+! !
+!***********************************************************************
+(this,V,H,kmx)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind), intent(in):: kmx
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT
+real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT
+integer(i_kind):: g,L
+!-----------------------------------------------------------------------
+!
+! From generation 1 to generation 2
+!
+
+ call this%adjoint(V(1:kmx,1:this%im,1:this%jm),V_INT,kmx,1)
+
+ call this%bocoT_2d(V_INT,kmx,this%imL,this%jmL,2,2)
+
+ call this%upsend_all(V_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx)
+!
+! From generation 2 sequentially to higher generations
+!
+ do g=2,this%gm-1
+
+ if(g==this%my_hgen) then
+ call this%adjoint(H(1:kmx,1:this%im,1:this%jm),H_INT,kmx,g)
+ endif
+
+ call this%bocoT_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g)
+
+ call this%upsend_all(H_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx,g,g+1)
+
+ end do
+
+!-----------------------------------------------------------------------
+endsubroutine upsending_ens
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsending_ens &
+!***********************************************************************
+! !
+! Downsend, interpolate and add: !
+! First from gm->g3...->g2 !
+! Then from g2->g1 !
+! !
+!***********************************************************************
+(this,H,V,kmx)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind), intent(in):: kmx
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT
+real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT
+real(r_kind),dimension(kmx,1:this%im,1:this%jm):: H_PROX
+real(r_kind),dimension(kmx,1:this%im,1:this%jm):: V_PROX
+integer(i_kind):: g,l,k
+integer(i_kind):: iL,jL,i,j
+!-----------------------------------------------------------------------
+!
+! Upper generations
+!
+ do g=this%gm,3,-1
+
+ call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),H_INT(1:kmx,1:this%imL,1:this%jmL),kmx,g,g-1)
+
+ call this%boco_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g-1,g-1)
+
+ if(this%my_hgen==g-1) then
+ call this%direct1(H_INT,H_PROX,kmx,g-1)
+ H(1:kmx,1:this%im,1:this%jm)=H (1:kmx,1:this%im,1:this%jm) &
+ +H_PROX(1:kmx,1:this%im,1:this%jm)
+ endif
+
+ enddo
+
+!
+! From geneartion 2 to generation 1
+!
+
+ call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),V_INT(1:kmx,1:this%imL,1:this%jmL),kmx)
+ H(:,:,:)=0.
+
+ call this%boco_2d(V_INT,kmx,this%imL,this%jmL,2,2)
+
+ call this%direct1(V_INT,V_PROX,kmx,1)
+
+ V(1:kmx,1:this%im,1:this%jm)=V (1:kmx,1:this%im,1:this%jm) &
+ +V_PROX(1:kmx,1:this%im,1:this%jm)
+
+!-----------------------------------------------------------------------
+endsubroutine downsending_ens
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsending_ens_nearest &
+!***********************************************************************
+! !
+! Adjoint interpolate and upsend: !
+! First from g1->g2 (V -> H) !
+! Then from g2->...->gn (H -> H) !
+! !
+!***********************************************************************
+(this,V,H,kmx)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind), intent(in):: kmx
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT
+real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT
+integer(i_kind):: g,L
+!-----------------------------------------------------------------------
+!
+! From generation 1 to generation 2
+!
+
+ call this%adjoint_nearest(V(1:kmx,1:this%im,1:this%jm),V_INT,kmx,1)
+
+ call this%bocoT_2d(V_INT,kmx,this%imL,this%jmL,2,2)
+
+ call this%upsend_all(V_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx)
+!
+! From generation 2 sequentially to higher generations
+!
+ do g=2,this%gm-1
+
+ if(g==this%my_hgen) then
+ call this%adjoint_nearest(H(1:kmx,1:this%im,1:this%jm),H_INT,kmx,g)
+ endif
+
+ call this%bocoT_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g)
+
+ call this%upsend_all(H_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx,g,g+1)
+
+ end do
+
+!-----------------------------------------------------------------------
+endsubroutine upsending_ens_nearest
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsending_ens_nearest &
+!***********************************************************************
+! !
+! Downsend, interpolate and add: !
+! First from gm->g3...->g2 !
+! Then from g2->g1 !
+! !
+!***********************************************************************
+(this,H,V,kmx)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind), intent(in):: kmx
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT
+real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT
+real(r_kind),dimension(kmx,1:this%im,1:this%jm):: H_PROX
+real(r_kind),dimension(kmx,1:this%im,1:this%jm):: V_PROX
+integer(i_kind):: g,l,k
+integer(i_kind):: iL,jL,i,j
+!-----------------------------------------------------------------------
+!
+! Upper generations
+!
+ do g=this%gm,3,-1
+
+ call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),H_INT(1:kmx,1:this%imL,1:this%jmL),kmx,g,g-1)
+
+ call this%boco_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g-1,g-1)
+
+ if(this%my_hgen==g-1) then
+ call this%direct_nearest(H_INT,H_PROX,kmx,g-1)
+ H(1:kmx,1:this%im,1:this%jm)=H (1:kmx,1:this%im,1:this%jm) &
+ +H_PROX(1:kmx,1:this%im,1:this%jm)
+ endif
+
+ enddo
+
+!
+! From geneartion 2 to generation 1
+!
+
+ call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),V_INT(1:kmx,1:this%imL,1:this%jmL),kmx)
+ H(:,:,:)=0.
+
+ call this%boco_2d(V_INT,kmx,this%imL,this%jmL,2,2)
+
+ call this%direct_nearest(V_INT,V_PROX,kmx,1)
+
+ V(1:kmx,1:this%im,1:this%jm)=V (1:kmx,1:this%im,1:this%jm) &
+ +V_PROX(1:kmx,1:this%im,1:this%jm)
+
+!-----------------------------------------------------------------------
+endsubroutine downsending_ens_nearest
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsending2_ens &
+!***********************************************************************
+! !
+! Adjoint interpolate and upsend: !
+! First from g1->g2 (V -> H) !
+! Then from g2->...->gn (H -> H) !
+! !
+!***********************************************************************
+(this,V,H,kmx)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind), intent(in):: kmx
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: V_INT
+real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: H_INT
+integer(i_kind):: g,L
+!-----------------------------------------------------------------------
+!
+! From generation 1 to generation 2
+!
+
+ call this%adjoint2(V(1:kmx,1:this%im,1:this%jm),V_INT,kmx,1)
+
+ call this%bocoT_2d(V_INT,kmx,this%imL,this%jmL,1,1)
+
+ call this%upsend_all(V_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx)
+!
+! From generation 2 sequentially to higher generations
+!
+ do g=2,this%gm-1
+
+ if(g==this%my_hgen) then
+ call this%adjoint2(H(1:kmx,1:this%im,1:this%jm),H_INT,kmx,g)
+ endif
+
+ call this%bocoT_2d(H_INT,kmx,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g,g)
+
+ call this%upsend_all(H_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx,g,g+1)
+
+ end do
+
+!-----------------------------------------------------------------------
+endsubroutine upsending2_ens
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsending2_ens &
+!***********************************************************************
+! !
+! Downsend, interpolate and add: !
+! First from gm->g3...->g2 !
+! Then from g2->g1 !
+! !
+!***********************************************************************
+(this,H,V,kmx)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind), intent(in):: kmx
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: H_INT
+real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: V_INT
+real(r_kind),dimension(kmx,1:this%im,1:this%jm):: H_PROX
+real(r_kind),dimension(kmx,1:this%im,1:this%jm):: V_PROX
+integer(i_kind):: g,l,k
+integer(i_kind):: iL,jL,i,j
+!-----------------------------------------------------------------------
+!
+! Upper generations
+!
+ do g=this%gm,3,-1
+
+ call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),H_INT(1:kmx,1:this%imL,1:this%jmL),kmx,g,g-1)
+
+ call this%boco_2d(H_INT,kmx,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g-1,g-1)
+
+ if(this%my_hgen==g-1) then
+ call this%direct2(H_INT,H_PROX,kmx,g-1)
+ H(1:kmx,1:this%im,1:this%jm)=H (1:kmx,1:this%im,1:this%jm) &
+ +H_PROX(1:kmx,1:this%im,1:this%jm)
+ endif
+
+ enddo
+
+!
+! From geneartion 2 to generation 1
+!
+
+ call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),V_INT(1:kmx,1:this%imL,1:this%jmL),kmx)
+ H(:,:,:)=0.
+
+ call this%boco_2d(V_INT,kmx,this%imL,this%jmL,1,1)
+
+ call this%direct2(V_INT,V_PROX,kmx,1)
+
+ V(1:kmx,1:this%im,1:this%jm)=V (1:kmx,1:this%im,1:this%jm) &
+ +V_PROX(1:kmx,1:this%im,1:this%jm)
+
+!-----------------------------------------------------------------------
+endsubroutine downsending2_ens
+
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsending_loc_g3 &
+!***********************************************************************
+! !
+! Adjoint interpolate and upsend for localization: !
+! !
+! First from g1->g2: V(km ) -> H(km_4) !
+! Then from g2->g3: H(km_4 ) -> Z(km_16) !
+! !
+!***********************************************************************
+(this,V,H,Z,km_in,km_4_in,km_16_in)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: km_in,km_4_in,km_16_in
+real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z
+real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT
+real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT
+real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT
+integer(i_kind):: g,L,ind,k_low,k_hgh
+!-----------------------------------------------------------------------
+!
+! From generation 1 to generation 2
+!
+
+ call this%adjoint(V(1:km_in,1:this%im,1:this%jm),V_INT,km_in,1)
+ call this%bocoT_2d(V_INT,km_in,this%imL,this%jmL,2,2) !?????
+
+ do ind=1,1
+ k_low=km_4_in*(ind-1)+1
+ k_hgh=km_4_in*ind
+ call this%upsend_loc_g12(V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),H,km_4_in,ind)
+ enddo
+
+!
+! From generation 2 to generation 3
+!
+
+ call this%adjoint(H(1:km_4_in,1:this%im,1:this%jm),H_INT,km_4_in,2)
+ call this%bocoT_2d_loc(H_INT,km_4_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2)
+
+ do ind=1,4
+ k_low=km_16_in*(ind-1)+1
+ k_hgh=km_16_in*ind
+ call this%upsend_loc_g23(H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),Z,km_16_in,ind)
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine upsending_loc_g3
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine upsending_loc_g4 &
+!***********************************************************************
+! !
+! Adjoint interpolate and upsend for localization: !
+! !
+! First from g1->g2: V(km ) -> H(km_4) !
+! Then from g2->g3: H(km_4 ) -> Z(km_16) !
+! Then from g3->g4: Z(km_16) -> W(km_64) !
+! !
+!***********************************************************************
+(this,V,H,Z,W,km_in,km_4_in,km_16_in,km_64_in)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in
+real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z
+real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: W
+real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT
+real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT
+real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT
+real(r_kind),dimension(km_64_in,-1:this%imL+2,-1:this%jmL+2):: W_INT
+integer(i_kind):: g,L,ind,k_low,k_hgh
+!-----------------------------------------------------------------------
+!
+! From generation 1 to generation 2
+!
+
+ call this%adjoint(V(1:km_in,1:this%im,1:this%jm),V_INT,km_in,1)
+ call this%bocoT_2d(V_INT,km_in,this%imL,this%jmL,2,2) !?????
+
+ do ind=1,4
+ k_low=km_4_in*(ind-1)+1
+ k_hgh=km_4_in*ind
+ call this%upsend_loc_g12(V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),H,km_4_in,ind)
+ enddo
+
+!
+! From generation 2 to generation 3
+!
+
+ call this%adjoint(H(1:km_4_in,1:this%im,1:this%jm),H_INT,km_4_in,2)
+ call this%bocoT_2d_loc(H_INT,km_4_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2)
+
+ do ind=1,4
+ k_low=km_16_in*(ind-1)+1
+ k_hgh=km_16_in*ind
+ call this%upsend_loc_g23(H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),Z,km_16_in,ind)
+ enddo
+
+!
+! From generation 3 to generation 4
+!
+
+ call this%adjoint(Z(1:km_16_in,1:this%im,1:this%jm),Z_INT,km_16_in,3)
+ call this%bocoT_2d_loc(H_INT,km_4_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,3)
+
+ do ind=1,4
+ k_low=km_64_in*(ind-1)+1
+ k_hgh=km_64_in*ind
+ call this%upsend_loc_g34(Z_INT(k_low:k_hgh,1:this%imL,1:this%jmL),W,km_64_in,ind)
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine upsending_loc_g4
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsending_loc_g3 &
+!***********************************************************************
+! !
+! Downsend, interpolate and add for localization: !
+! !
+! Then from g3->g2: Z(km_16) -> H(km_4 ) !
+! Then from g2->g1: H(km_4 ) -> V(km ) !
+! !
+!***********************************************************************
+(this,Z,H,V,km_in,km_4_in,km_16_in)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: km_in,km_4_in,km_16_in
+real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z
+real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT
+real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT
+real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT
+real(r_kind),dimension(km_16_in,1:this%im,1:this%jm):: Z_PROX
+real(r_kind),dimension(km_4_in ,1:this%im,1:this%jm):: H_PROX
+real(r_kind),dimension(km_in ,1:this%im,1:this%jm):: V_PROX
+integer(i_kind):: g,l,k
+integer(i_kind):: iL,jL,i,j,ind,k_low,k_hgh
+!-----------------------------------------------------------------------
+!
+! From generation 3 to generation 2
+!
+ do ind=1,4
+ k_low=km_16_in*(ind-1)+1
+ k_hgh=km_16_in*ind
+ call this%downsend_loc_g32(Z(1:km_16_in,1:this%im,1:this%jm),H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_16_in,ind)
+ enddo
+ Z(:,:,:)=0.
+
+ call this%boco_2d_loc(H_INT,km_4_in ,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2)
+ call this%direct1(H_INT,H_PROX,km_4_in,2)
+
+ H(1:km_4_in ,1:this%im,1:this%jm)=H (1:km_4_in ,1:this%im,1:this%jm) &
+ +H_PROX(1:km_4_in ,1:this%im,1:this%jm)
+
+!
+! From geneartion 2 to generation 1
+!
+ do ind=1,4
+ k_low=km_4_in*(ind-1)+1
+ k_hgh=km_4_in*ind
+ call this%downsend_loc_g21(H(1:km_4_in,1:this%im,1:this%jm),V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_4_in,ind)
+ enddo
+ H(:,:,:)=0.
+
+ call this%boco_2d(V_INT,km_in,this%imL,this%jmL,2,2)
+ call this%direct1(V_INT,V_PROX,km_in,1)
+
+ V(1:km_in,1:this%im,1:this%jm)=V (1:km_in,1:this%im,1:this%jm) &
+ +V_PROX(1:km_in,1:this%im,1:this%jm)
+
+!-----------------------------------------------------------------------
+endsubroutine downsending_loc_g3
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine downsending_loc_g4 &
+!***********************************************************************
+! !
+! Downsend, interpolate and add for localization: !
+! !
+! First from g4->g3: W(km_16) -> Z(km_64) !
+! Then from g3->g2: Z(km_16) -> H(km_4 ) !
+! Then from g2->g1: H(km_4 ) -> V(km ) !
+! !
+!***********************************************************************
+(this,W,Z,H,V,km_in,km_4_in,km_16_in,km_64_in)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in
+real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: W
+real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z
+real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(km_64_in,-1:this%imL+2,-1:this%jmL+2):: W_INT
+real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT
+real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT
+real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT
+real(r_kind),dimension(km_16_in,1:this%im,1:this%jm):: Z_PROX
+real(r_kind),dimension(km_4_in ,1:this%im,1:this%jm):: H_PROX
+real(r_kind),dimension(km_in ,1:this%im,1:this%jm):: V_PROX
+integer(i_kind):: g,l,k
+integer(i_kind):: iL,jL,i,j,ind,k_low,k_hgh
+!-----------------------------------------------------------------------
+!
+! From generation 4 to generation 3
+!
+ do ind=1,4
+ k_low=km_64_in*(ind-1)+1
+ k_hgh=km_64_in*ind
+ call this%downsend_loc_g43(W(1:km_64_in,1:this%im,1:this%jm),Z_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_64_in,ind)
+ enddo
+ W(:,:,:)=0.
+
+ call this%boco_2d_loc(Z_INT,km_16_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,3)
+ call this%direct1(Z_INT,Z_PROX,km_16_in,3)
+
+ Z(1:km_16_in,1:this%im,1:this%jm)=Z (1:km_16_in,1:this%im,1:this%jm) &
+ +Z_PROX(1:km_16_in,1:this%im,1:this%jm)
+
+!
+! From generation 3 to generation 2
+!
+ do ind=1,4
+ k_low=km_16_in*(ind-1)+1
+ k_hgh=km_16_in*ind
+ call this%downsend_loc_g32(Z(1:km_16_in,1:this%im,1:this%jm),H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_16_in,ind)
+ enddo
+ Z(:,:,:)=0.
+
+ call this%boco_2d_loc(H_INT,km_4_in ,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2)
+ call this%direct1(H_INT,H_PROX,km_4_in,2)
+
+ H(1:km_4_in ,1:this%im,1:this%jm)=H (1:km_4_in ,1:this%im,1:this%jm) &
+ +H_PROX(1:km_4_in ,1:this%im,1:this%jm)
+
+!
+! From geneartion 2 to generation 1
+!
+ do ind=1,4
+ k_low=km_4_in*(ind-1)+1
+ k_hgh=km_4_in*ind
+ call this%downsend_loc_g21(H(1:km_4_in,1:this%im,1:this%jm),V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_4_in,ind)
+ enddo
+ H(:,:,:)=0.
+
+
+ call this%boco_2d(V_INT,km_in,this%imL,this%jmL,2,2)
+ call this%direct1(V_INT,V_PROX,km_in,1)
+
+ V(1:km_in,1:this%im,1:this%jm)=V (1:km_in,1:this%im,1:this%jm) &
+ +V_PROX(1:km_in,1:this%im,1:this%jm)
+
+!-----------------------------------------------------------------------
+endsubroutine downsending_loc_g4
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine weighting_helm &
+!***********************************************************************
+! !
+! Apply 2D differential operator to compound variable !
+! !
+!***********************************************************************
+(this,V,H)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+real(r_kind),dimension(this%km,0:this%im, 1:this%jm):: DIFX
+real(r_kind),dimension(this%km,1:this%im ,0:this%jm):: DIFY
+real(r_kind),dimension(this%km,0:this%im, 1:this%jm):: DIFXH
+real(r_kind),dimension(this%km,1:this%im ,0:this%jm):: DIFYH
+integer(i_kind):: i,j,l,k,imx,jmx
+!-----------------------------------------------------------------------
+
+ do j=1,this%jm
+ do i=0,this%im
+ DIFX(:,i,j)=V(:,i+1,j)-V(:,i,j)
+ enddo
+ enddo
+ do j=0,this%jm
+ do i=1,this%im
+ DIFY(:,i,j)=V(:,i,j+1)-V(:,i,j)
+ enddo
+ enddo
+
+ do j=1,this%jm
+ do i=1,this%im
+ V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j) &
+ -this%b_diff_f(:,i,j)*(DIFX(:,i,j)-DIFX(:,i-1,j) &
+ +DIFY(:,i,j)-DIFY(:,i,j-1))
+ enddo
+ enddo
+
+if(this%l_hgen) then
+
+! imx = Fimax(my_hgen)
+! jmx = Fjmax(my_hgen)
+
+ imx = this%im
+ jmx = this%jm
+
+ do j=1,jmx
+ do i=0,imx
+ DIFXH(:,i,j)=H(:,i+1,j)-H(:,i,j)
+ enddo
+ enddo
+ do j=0,jmx
+ do i=1,imx
+ DIFYH(:,i,j)=H(:,i,j+1)-H(:,i,j)
+ enddo
+ enddo
+
+ do j=1,jmx
+ do i=1,imx
+ H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) &
+ -this%b_diff_h(:,i,j)*(DIFXH(:,i,j)-DIFXH(:,i-1,j) &
+ +DIFYH(:,i,j)-DIFYH(:,i,j-1))
+ enddo
+ enddo
+
+endif
+
+!-----------------------------------------------------------------------
+endsubroutine weighting_helm
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine weighting &
+!***********************************************************************
+! !
+! Apply 2D differential operator to compound variable !
+! !
+!***********************************************************************
+(this,V,H)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+integer(i_kind):: i,j,l,k,imx,jmx
+!-----------------------------------------------------------------------
+
+ do j=1,this%jm
+ do i=1,this%im
+ V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j)
+ enddo
+ enddo
+
+if(this%l_hgen) then
+
+ imx = this%im
+ jmx = this%jm
+
+ do j=1,jmx
+ do i=1,imx
+ H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j)
+ enddo
+ enddo
+
+endif
+
+!-----------------------------------------------------------------------
+endsubroutine weighting
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine weighting_highest &
+!***********************************************************************
+! !
+! Apply 2D differential operator to compound variable !
+! !
+!***********************************************************************
+(this,H)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+real(r_kind),dimension(this%km,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy),intent(inout):: H
+integer(i_kind):: i,j,imx,jmx
+!-----------------------------------------------------------------------
+
+ imx = this%imH
+ jmx = this%jmH
+
+ do j=1,jmx
+ do i=1,imx
+ H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j)
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine weighting_highest
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine weighting_ens &
+!***********************************************************************
+! !
+! Apply 2D differential operator to compound variable for ensemble !
+! !
+!***********************************************************************
+(this,V,H,kmx)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: kmx
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+integer(i_kind):: i,j,l,k,imx,jmx
+!-----------------------------------------------------------------------
+
+if(this%l_filt_g1) then
+ do j=1,this%jm
+ do i=1,this%im
+ V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j)
+ enddo
+ enddo
+else
+ V(:,:,:)=0.
+endif
+
+if(this%l_hgen) then
+
+ imx = this%im
+ jmx = this%jm
+
+ do j=1,jmx
+ do i=1,imx
+ H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j)
+ enddo
+ enddo
+
+endif
+
+!-----------------------------------------------------------------------
+endsubroutine weighting_ens
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine weighting_loc_g3 &
+!***********************************************************************
+! !
+! Apply 2D differential operator to compound variable in the case !
+! of localization !
+! !
+!***********************************************************************
+(this,V,H04,H16,km_in,km_4_in,km_16_in)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind), intent(in):: km_in,km_4_in,km_16_in
+real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04
+real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16
+integer(i_kind):: i,j,l,k
+!-----------------------------------------------------------------------
+
+ do j=1,this%jm
+ do i=1,this%im
+ V (1:km_in ,i,j)=this%w1_loc(1:km_in ,i,j)*V (1:km_in ,i,j)
+ H04(1:km_4_in ,i,j)=this%w2_loc(1:km_4_in ,i,j)*H04(1:km_4_in ,i,j)
+ H16(1:km_16_in,i,j)=this%w3_loc(1:km_16_in,i,j)*H16(1:km_16_in,i,j)
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine weighting_loc_g3
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine weighting_loc_g4 &
+!***********************************************************************
+! !
+! Apply 2D differential operator to compound variable in the case !
+! of localization !
+! !
+!***********************************************************************
+(this,V,H04,H16,H64,km_in,km_4_in,km_16_in,km_64_in)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind), intent(in):: km_in,km_4_in,km_16_in,km_64_in
+real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04
+real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16
+real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H64
+integer(i_kind):: i,j,l,k
+!-----------------------------------------------------------------------
+
+ do j=1,this%jm
+ do i=1,this%im
+ V (1:km_in ,i,j)=this%w1_loc(1:km_in ,i,j)*V (1:km_in ,i,j)
+ H04(1:km_4_in ,i,j)=this%w2_loc(1:km_4_in ,i,j)*H04(1:km_4_in ,i,j)
+ H16(1:km_16_in,i,j)=this%w3_loc(1:km_16_in,i,j)*H16(1:km_16_in,i,j)
+ H64(1:km_64_in,i,j)=this%w4_loc(1:km_64_in,i,j)*H64(1:km_64_in,i,j)
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine weighting_loc_g4
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine adjoint &
+!***********************************************************************
+! !
+! Mapping from the high to low resolution grid !
+! using linearly squared interpolations !
+! - offset version - !
+! !
+!***********************************************************************
+(this,F,W,km_in,g)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: g
+integer(i_kind),intent(in):: km_in
+real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F
+real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W
+real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX
+integer(i_kind):: i,j,iL,jL
+!-----------------------------------------------------------------------
+!
+! 3)
+!
+ W_AUX(:,:,:)= 0.
+
+ do j=this%jm-mod(this%jm,2),2,-2
+ jL = j/2
+ do i=this%im,1,-1
+ W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%p_coef(4)*F(:,i,j)
+ W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%p_coef(3)*F(:,i,j)
+ W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%p_coef(2)*F(:,i,j)
+ W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%p_coef(1)*F(:,i,j)
+ enddo
+ enddo
+!
+! 2)
+!
+ do j=this%jm-1+mod(this%jm,2),1,-2
+ jL=j/2
+ do i=this%im,1,-1
+ W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%q_coef(4)*F(:,i,j)
+ W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%q_coef(3)*F(:,i,j)
+ W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%q_coef(2)*F(:,i,j)
+ W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%q_coef(1)*F(:,i,j)
+ enddo
+ enddo
+
+ W(:,:,:)=0.
+!
+! 1)
+!
+ do jL=this%jmL+2,-1,-1
+ do i=this%im-1+mod(this%im,2),1,-2
+ iL = i/2
+ W(:,iL+2,jL)=W(:,iL+2,jL)+this%q_coef(4)*W_AUX(:,i,jL)
+ W(:,iL+1,jL)=W(:,iL+1,jL)+this%q_coef(3)*W_AUX(:,i,jL)
+ W(:,iL ,jL)=W(:,iL ,jL)+this%q_coef(2)*W_AUX(:,i,jL)
+ W(:,iL-1,jL)=W(:,iL-1,jL)+this%q_coef(1)*W_AUX(:,i,jL)
+ enddo
+ do i=this%im-mod(this%im,2),2,-2
+ iL=i/2
+ W(:,iL+2,jL)=W(:,iL+2,jL)+this%p_coef(4)*W_AUX(:,i,jL)
+ W(:,iL+1,jL)=W(:,iL+1,jL)+this%p_coef(3)*W_AUX(:,i,jL)
+ W(:,iL ,jL)=W(:,iL ,jL)+this%p_coef(2)*W_AUX(:,i,jL)
+ W(:,iL-1,jL)=W(:,iL-1,jL)+this%p_coef(1)*W_AUX(:,i,jL)
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine adjoint
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine direct1 &
+!***********************************************************************
+! !
+! Mapping from the low to high resolution grid !
+! using linearly squared interpolations !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,F,km_in,g)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: g
+integer(i_kind),intent(in):: km_in
+real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W
+real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F
+real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX
+integer(i_kind):: i,j,iL,jL
+!-----------------------------------------------------------------------
+!
+! 1)
+!
+ do jL=-1,this%jmL+2
+ do i=1,this%im-1+mod(this%im,2),2
+ iL=i/2
+ W_AUX(:,i,jL)=this%q_coef(1)*W(:,iL-1,jL)+this%q_coef(2)*W(:,iL ,jL) &
+ +this%q_coef(3)*W(:,iL+1,jL)+this%q_coef(4)*W(:,iL+2,jL)
+ enddo
+ do i=2,this%im-mod(this%im,2),2
+ iL=i/2
+ W_AUX(:,i,jL)=this%p_coef(1)*W(:,iL-1,jL)+this%p_coef(2)*w(:,iL ,jL) &
+ +this%p_coef(3)*W(:,iL+1,jL)+this%p_coef(4)*W(:,iL+2,jL)
+ enddo
+ enddo
+!
+! 2)
+!
+ do j=1,this%jm-1+mod(this%jm,2),2
+ jL=j/2
+ do i=1,this%im
+ F(:,i,j)=this%q_coef(1)*W_AUX(:,i,jL-1)+this%q_coef(2)*W_AUX(:,i,jL ) &
+ +this%q_coef(3)*W_AUX(:,i,jL+1)+this%q_coef(4)*W_AUX(:,i,jL+2)
+ enddo
+ enddo
+!
+! 3)
+!
+ do j=2,this%jm-mod(this%jm,2),2
+ jL=j/2
+ do i=1,this%im
+ F(:,i,j)=this%p_coef(1)*W_AUX(:,i,jL-1)+this%p_coef(2)*W_AUX(:,i,jL ) &
+ +this%p_coef(3)*W_AUX(:,i,jL+1)+this%p_coef(4)*W_AUX(:,i,jL+2)
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine direct1
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine adjoint2 &
+!***********************************************************************
+! !
+! Mapping from the high to low resolution grid !
+! using quadratics interpolations !
+! - offset version - !
+! !
+!***********************************************************************
+(this,F,W,km_in,g)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: g
+integer(i_kind),intent(in):: km_in
+real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F
+real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(out):: W
+real(r_kind), dimension(km_in,1:this%im,0:this%jmL+1):: W_AUX
+integer(i_kind):: i,j,iL,jL
+!-----------------------------------------------------------------------
+!
+! 3)
+!
+ W_AUX(:,:,:)= 0.
+
+ do j=this%jm-mod(this%jm,2),2,-2
+ jL = j/2
+ do i=this%im,1,-1
+ W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%b_coef(3)*F(:,i,j)
+ W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%b_coef(2)*F(:,i,j)
+ W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%b_coef(1)*F(:,i,j)
+ enddo
+ enddo
+!
+! 2)
+!
+ do j=this%jm-1+mod(this%jm,2),1,-2
+ jL=(j+1)/2
+ do i=this%im,1,-1
+ W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%a_coef(3)*F(:,i,j)
+ W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%a_coef(2)*F(:,i,j)
+ W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%a_coef(1)*F(:,i,j)
+ enddo
+ enddo
+
+ W(:,:,:)=0.
+!
+! 1)
+!
+ do jL=this%jmL+1,0,-1
+ do i=this%im-1+mod(this%im,2),1,-2
+ iL = (i+1)/2
+ W(:,iL+1,jL)=W(:,iL+1,jL)+this%a_coef(3)*W_AUX(:,i,jL)
+ W(:,iL ,jL)=W(:,iL ,jL)+this%a_coef(2)*W_AUX(:,i,jL)
+ W(:,iL-1,jL)=W(:,iL-1,jL)+this%a_coef(1)*W_AUX(:,i,jL)
+ enddo
+ do i=this%im-mod(this%im,2),2,-2
+ iL=i/2
+ W(:,iL+1,jL)=W(:,iL+1,jL)+this%b_coef(3)*W_AUX(:,i,jL)
+ W(:,iL ,jL)=W(:,iL ,jL)+this%b_coef(2)*W_AUX(:,i,jL)
+ W(:,iL-1,jL)=W(:,iL-1,jL)+this%b_coef(1)*W_AUX(:,i,jL)
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine adjoint2
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine direct2 &
+!***********************************************************************
+! !
+! Mapping from the low to high resolution grid !
+! using quadratic interpolations !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,F,km_in,g)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: g
+integer(i_kind),intent(in):: km_in
+real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(in):: W
+real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F
+real(r_kind), dimension(km_in,1:this%im,0:this%jmL+1):: W_AUX
+integer(i_kind):: i,j,iL,jL
+!-----------------------------------------------------------------------
+!
+! 1)
+!
+ do jL=0,this%jmL+1
+ do i=1,this%im-1+mod(this%im,2),2
+ iL=(i+1)/2
+ W_AUX(:,i,jL)=this%a_coef(1)*W(:,iL-1,jL)+this%a_coef(2)*W(:,iL ,jL) &
+ +this%a_coef(3)*W(:,iL+1,jL)
+ enddo
+ do i=2,this%im-mod(this%im,2),2
+ iL=i/2
+ W_AUX(:,i,jL)=this%b_coef(1)*W(:,iL-1,jL)+this%b_coef(2)*w(:,iL ,jL) &
+ +this%b_coef(3)*W(:,iL+1,jL)
+ enddo
+ enddo
+!
+! 2)
+!
+ do j=1,this%jm-1+mod(this%jm,2),2
+ jL=(j+1)/2
+ do i=1,this%im
+ F(:,i,j)=this%a_coef(1)*W_AUX(:,i,jL-1)+this%a_coef(2)*W_AUX(:,i,jL ) &
+ +this%a_coef(3)*W_AUX(:,i,jL+1)
+ enddo
+ enddo
+!
+! 3)
+!
+ do j=2,this%jm-mod(this%jm,2),2
+ jL=j/2
+ do i=1,this%im
+ F(:,i,j)=this%b_coef(1)*W_AUX(:,i,jL-1)+this%b_coef(2)*W_AUX(:,i,jL ) &
+ +this%b_coef(3)*W_AUX(:,i,jL+1)
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine direct2
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine adjoint_nearest &
+!***********************************************************************
+! !
+! Mapping from the high to low resolution grid !
+! selecting the nearest point !
+! - offset version - !
+! !
+!***********************************************************************
+(this,F,W,km_in,g)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: g
+integer(i_kind),intent(in):: km_in
+real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F
+real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W
+real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX
+integer(i_kind):: i,j,iL,jL
+!-----------------------------------------------------------------------
+!
+! 3)
+!
+ W_AUX(:,:,:)= 0.
+
+ do j=this%jm-mod(this%jm,2),2,-2
+ jL = j/2
+ do i=this%im,1,-1
+ W_AUX(:,i,jL )=W_AUX(:,i,jL )+0.5**0.5*F(:,i,j)
+ enddo
+ enddo
+!
+! 2)
+!
+ do j=this%jm-1+mod(this%jm,2),1,-2
+ jL=j/2
+ do i=this%im,1,-1
+ W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+0.5**0.5*F(:,i,j)
+ enddo
+ enddo
+
+ W(:,:,:)=0.
+!
+! 1)
+!
+ do jL=this%jmL+2,-1,-1
+ do i=this%im-1+mod(this%im,2),1,-2
+ iL = i/2
+ W(:,iL+1,jL)=W(:,iL+1,jL)+0.5**0.5*W_AUX(:,i,jL)
+ enddo
+ do i=this%im-mod(this%im,2),2,-2
+ iL=i/2
+ W(:,iL ,jL)=W(:,iL ,jL)+0.5**0.5*W_AUX(:,i,jL)
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine adjoint_nearest
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine direct_nearest &
+!***********************************************************************
+! !
+! Mapping from the low to high resolution grid !
+! selecting the nearest point !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,F,km_in,g)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: g
+integer(i_kind),intent(in):: km_in
+real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W
+real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F
+real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX
+integer(i_kind):: i,j,iL,jL
+!-----------------------------------------------------------------------
+!
+! 1)
+!
+ do jL=-1,this%jmL+2
+ do i=1,this%im-1+mod(this%im,2),2
+ iL=i/2
+ W_AUX(:,i,jL)=0.5**0.5*W(:,iL+1,jL)
+ enddo
+ do i=2,this%im-mod(this%im,2),2
+ iL=i/2
+ W_AUX(:,i,jL)=0.5**0.5*w(:,iL ,jL)
+ enddo
+ enddo
+!
+! 2)
+!
+ do j=1,this%jm-1+mod(this%jm,2),2
+ jL=j/2
+ do i=1,this%im
+ F(:,i,j)=0.5**0.5*W_AUX(:,i,jL+1)
+ enddo
+ enddo
+!
+! 3)
+!
+ do j=2,this%jm-mod(this%jm,2),2
+ jL=j/2
+ do i=1,this%im
+ F(:,i,j)=0.5**0.5*W_AUX(:,i,jL )
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine direct_nearest
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine adjoint_highest &
+!***********************************************************************
+! !
+! Mapping from the high to low resolution grid !
+! using linearly squared interpolations !
+! - offset version - !
+! !
+!***********************************************************************
+(this,F,W,km_in,g)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: g
+integer(i_kind),intent(in):: km_in
+real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(in):: F
+real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(out):: W
+real(r_kind), dimension(km_in,1:this%im0(g),-1:this%jm0(g+1)+2):: W_AUX
+integer(i_kind):: i,j,iL,jL
+!-----------------------------------------------------------------------
+!
+! 3)
+!
+ W_AUX(:,:,:)= 0.
+
+ do j=this%jm0(g)-mod(this%jm0(g),2),2,-2
+ jL = j/2
+ do i=this%im0(g),1,-1
+ W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%p_coef(4)*F(:,i,j)
+ W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%p_coef(3)*F(:,i,j)
+ W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%p_coef(2)*F(:,i,j)
+ W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%p_coef(1)*F(:,i,j)
+ enddo
+ enddo
+!
+! 2)
+!
+ do j=this%jm0(g)-1+mod(this%jm0(g),2),1,-2
+ jL=j/2
+ do i=this%im0(g),1,-1
+ W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%q_coef(4)*F(:,i,j)
+ W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%q_coef(3)*F(:,i,j)
+ W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%q_coef(2)*F(:,i,j)
+ W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%q_coef(1)*F(:,i,j)
+ enddo
+ enddo
+
+ W(:,:,:)=0.
+!
+! 1)
+!
+ do jL=this%jm0(g+1)+2,-1,-1
+ do i=this%im0(g)-1+mod(this%im0(g),2),1,-2
+ iL = i/2
+ W(:,iL+2,jL)=W(:,iL+2,jL)+this%q_coef(4)*W_AUX(:,i,jL)
+ W(:,iL+1,jL)=W(:,iL+1,jL)+this%q_coef(3)*W_AUX(:,i,jL)
+ W(:,iL ,jL)=W(:,iL ,jL)+this%q_coef(2)*W_AUX(:,i,jL)
+ W(:,iL-1,jL)=W(:,iL-1,jL)+this%q_coef(1)*W_AUX(:,i,jL)
+ enddo
+ do i=this%im0(g)-mod(this%im0(g),2),2,-2
+ iL=i/2
+ W(:,iL+2,jL)=W(:,iL+2,jL)+this%p_coef(4)*W_AUX(:,i,jL)
+ W(:,iL+1,jL)=W(:,iL+1,jL)+this%p_coef(3)*W_AUX(:,i,jL)
+ W(:,iL ,jL)=W(:,iL ,jL)+this%p_coef(2)*W_AUX(:,i,jL)
+ W(:,iL-1,jL)=W(:,iL-1,jL)+this%p_coef(1)*W_AUX(:,i,jL)
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine adjoint_highest
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine direct_highest &
+!***********************************************************************
+! !
+! Mapping from the low to high resolution grid !
+! using linearly squared interpolations !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,F,km_in,g)
+!-----------------------------------------------------------------------
+implicit none
+class (mg_intstate_type),target:: this
+integer(i_kind),intent(in):: g
+integer(i_kind),intent(in):: km_in
+real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(in):: W
+real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(out):: F
+real(r_kind), dimension(km_in,1:this%im0(g),-1:this%jm0(g+1)+2):: W_AUX
+integer(i_kind):: i,j,iL,jL
+!-----------------------------------------------------------------------
+!
+! 1)
+!
+ do jL=-1,this%jm0(g+1)+2
+ do i=1,this%im0(g)-1+mod(this%im0(g),2),2
+ iL=i/2
+ W_AUX(:,i,jL)=this%q_coef(1)*W(:,iL-1,jL)+this%q_coef(2)*W(:,iL ,jL) &
+ +this%q_coef(3)*W(:,iL+1,jL)+this%q_coef(4)*W(:,iL+2,jL)
+ enddo
+ do i=2,this%im0(g)-mod(this%im0(g),2),2
+ iL=i/2
+ W_AUX(:,i,jL)=this%p_coef(1)*W(:,iL-1,jL)+this%p_coef(2)*w(:,iL ,jL) &
+ +this%p_coef(3)*W(:,iL+1,jL)+this%p_coef(4)*W(:,iL+2,jL)
+ enddo
+ enddo
+!
+! 2)
+!
+ do j=1,this%jm0(g)-1+mod(this%jm0(g),2),2
+ jL=j/2
+ do i=1,this%im0(g)
+ F(:,i,j)=this%q_coef(1)*W_AUX(:,i,jL-1)+this%q_coef(2)*W_AUX(:,i,jL ) &
+ +this%q_coef(3)*W_AUX(:,i,jL+1)+this%q_coef(4)*W_AUX(:,i,jL+2)
+ enddo
+ enddo
+!
+! 3)
+!
+ do j=2,this%jm0(g)-mod(this%jm0(g),2),2
+ jL=j/2
+ do i=1,this%im0(g)
+ F(:,i,j)=this%p_coef(1)*W_AUX(:,i,jL-1)+this%p_coef(2)*W_AUX(:,i,jL ) &
+ +this%p_coef(3)*W_AUX(:,i,jL+1)+this%p_coef(4)*W_AUX(:,i,jL+2)
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine direct_highest
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+end submodule mg_generations
diff --git a/src/mgbf/mg_input.f90 b/src/mgbf/mg_input.f90
new file mode 100644
index 0000000000..80b0772c12
--- /dev/null
+++ b/src/mgbf/mg_input.f90
@@ -0,0 +1,155 @@
+module mg_input
+!$$$ submodule documentation block
+! . . . .
+! module: mg_input
+! prgmmr: rancic org: NCEP/EMC date:
+!
+! abstract: Module for data input
+! (Here will be defined uniform decomposition and padding
+! with zeros of control variables, required by the filter)
+!
+! module history log:
+! 2023-04-19 lei - object-oriented coding
+! 2024-01-11 rancic - optimization for ensemble localization
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! input_2d -
+! input_spec1_2d -
+! input_3d -
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+
+use mg_intstate, only : mg_intstate_type
+public input_2d
+public input_spec1_2d
+public input_3d
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+contains
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+subroutine input_2d &
+!***********************************************************************
+! !
+! Define some function for testing redecomposition !
+! (for analysis grid) !
+! !
+!***********************************************************************
+(obj_intstate,V,imin,jmin,imax,jmax,imax0,ampl)
+!-----------------------------------------------------------------------
+use kinds, only: r_kind,i_kind
+implicit none
+class (mg_intstate_type):: obj_intstate
+integer(i_kind),intent(in):: imax,jmax
+integer(i_kind),intent(in):: imin,jmin
+integer(i_kind),intent(in):: imax0
+integer(i_kind),intent(in):: ampl
+real(r_kind),dimension(imin:imax,jmin:jmax),intent(out):: V
+real(i_kind):: ng,mg,L,m,n
+!-----------------------------------------------------------------------
+
+ do m=imin,jmax
+ mg = (obj_intstate%my-1)*jmax+m
+ do n=jmin,imax
+ ng = (obj_intstate%nx-1)*imax+n
+ V(n,m)=ampl*(mg*imax0+ng)
+! V(n,m)=0.
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine input_2d
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+subroutine input_spec1_2d &
+!***********************************************************************
+! !
+! Define some function for testing redecomposition !
+! (for analysis grid) !
+! !
+!***********************************************************************
+(obj_intstate,V,nx0,my0,flag)
+!-----------------------------------------------------------------------
+use kinds, only: r_kind,i_kind
+implicit none
+class (mg_intstate_type):: obj_intstate
+integer(i_kind),intent(in):: nx0,my0
+real(r_kind),dimension(1:obj_intstate%nm,1:obj_intstate%mm),intent(out):: V
+character(len=2), intent(in):: flag
+integer(r_kind):: v0=1.
+!-----------------------------------------------------------------------
+
+ V(:,:)=0.
+
+if(flag=='md') then
+ if(obj_intstate%nx==nx0.and.obj_intstate%my==my0) then
+ V(obj_intstate%nm/2,obj_intstate%mm/2)=v0
+ endif
+else &
+if(flag=='rt') then
+ if(obj_intstate%nx==nx0.and.obj_intstate%my==my0) then
+ V(obj_intstate%nm,obj_intstate%mm)=v0
+ endif
+ if(obj_intstate%nx==nx0+1.and.obj_intstate%my==my0) then
+ V(1,obj_intstate%mm)=v0
+ endif
+ if(obj_intstate%nx==nx0.and.obj_intstate%my==my0+1) then
+ V(obj_intstate%nm,1)=v0
+ endif
+ if(obj_intstate%nx==nx0+1.and.obj_intstate%my==my0+1) then
+ V(1,1)=v0
+ endif
+endif
+
+!-----------------------------------------------------------------------
+endsubroutine input_spec1_2d
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+subroutine input_3d &
+!***********************************************************************
+! !
+! Define some function for testing redecomposition !
+! (for analysis grid) !
+! !
+!***********************************************************************
+(obj_intstate,V,imin,jmin,lmin,imax,jmax,lmax,imax0,ampl,incrm)
+!-----------------------------------------------------------------------
+use kinds, only: r_kind,i_kind
+implicit none
+class (mg_intstate_type):: obj_intstate
+integer(i_kind),intent(in):: imin,jmin,lmin
+integer(i_kind),intent(in):: imax,jmax,lmax
+integer(i_kind),intent(in):: imax0
+integer(i_kind),intent(in):: ampl,incrm
+real(r_kind),dimension(lmin:lmax,imin:imax,jmin:jmax),intent(out):: V
+real(i_kind):: ng,mg,L,m,n
+!-----------------------------------------------------------------------
+
+ do l=lmin,lmax
+ do m=imin,jmax
+ mg = (obj_intstate%my-1)*jmax+m
+ do n=jmin,imax
+ ng = (obj_intstate%nx-1)*imax+n
+ V(l,n,m)=ampl*(mg*imax0+ng) +(l-1)*incrm
+! V(l,n,m)=0.
+ enddo
+ enddo
+ enddo
+
+!-----------------------------------------------------------------------
+endsubroutine input_3d
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+end module mg_input
diff --git a/src/mgbf/mg_interpolate.f90 b/src/mgbf/mg_interpolate.f90
new file mode 100644
index 0000000000..5346792581
--- /dev/null
+++ b/src/mgbf/mg_interpolate.f90
@@ -0,0 +1,972 @@
+submodule(mg_intstate) mg_interpolate
+!$$$ submodule documentation block
+! . . . .
+! module: mg_interpolate
+! prgmmr: rancic org: NCEP/EMC date: 2020
+!
+! abstract: General mapping between 2d arrays using linerly squared
+! interpolations
+!
+! module history log:
+! 2023-04-19 lei - object-oriented coding
+! 2024-01-11 rancic - optimization for ensemble localization
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! def_offset_coef -
+! lsqr_mg_coef -
+! lwq_vertical_coef -
+! lwq_vertical_adjoint -
+! lwq_vertical_direct -
+! lwq_vertical_adjoint_spec -
+! lwq_vertical_direct_spec -
+! l_vertical_adjoint_spec -
+! l_vertical_direct_spec -
+! lsqr_direct_offset -
+! lsqr_adjoint_offset -
+! quad_direct_offset -
+! quad_adjoint_offset -
+! lin_direct_offset -
+! lin_adjoint_offset -
+! l_vertical_adjoint_spec2 -
+! l_vertical_direct_spec2 -
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use kinds
+use jp_pkind2, only: fpi
+
+implicit none
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+contains
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine def_offset_coef (this)
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+
+real(r_kind):: r64,r32,r128
+!-----------------------------------------------------------------------
+ r64 = 1.0d0/64.0d0
+ r32 = 1.0d0/32.0d0
+ r128= 1.0d0/128.0d0
+
+! p_coef =(/-3.,51,29,-3/)
+! q_coef =(/-3.,19.0d0,51.0d0,-3.0d0/)
+! p_coef = p_coef*r64
+! q_coef = q_coef*r64
+
+ this%p_coef =(/-9.,111.,29.,-3./)
+ this%q_coef =(/-3.,29.,111.,-9./)
+ this%p_coef = this%p_coef*r128
+ this%q_coef = this%q_coef*r128
+
+ this%a_coef =(/5.,30.,-3./)
+ this%b_coef =(/-3.,30.,5./)
+ this%a_coef=this%a_coef*r32
+ this%b_coef=this%b_coef*r32
+!-----------------------------------------------------------------------
+endsubroutine def_offset_coef
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine lsqr_mg_coef (this)
+!***********************************************************************
+! !
+! Prepare coeficients for mapping between: !
+! filter grid on analysis decomposition: W(1-ib:im+ib,1-jb:jm+jb) !
+! and analysis grid: V(1:nm,1:mm) !
+! - offset version - !
+! !
+! ( im < nm and jm < mm ) !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+real(r_kind), dimension(1:this%nm):: xa
+real(r_kind), dimension(1-this%ib:this%im+this%ib):: xf
+real(r_kind), dimension(1:this%mm):: ya
+real(r_kind), dimension(1-this%jb:this%jm+this%jb):: yf
+integer(i_kind):: i,j,n,m
+real(r_kind) x1,x2,x3,x4,x
+real(r_kind) x1x,x2x,x3x,x4x
+real(r_kind) rx2x1,rx3x1,rx4x1,rx3x2,rx4x2,rx4x3
+real(r_kind) y1,y2,y3,y4,y
+real(r_kind) y1y,y2y,y3y,y4y
+real(r_kind) ry2y1,ry3y1,ry4y1,ry3y2,ry4y2,ry4y3
+real(r_kind) cfl1,cfl2,cfl3,cll
+real(r_kind) cfr1,cfr2,cfr3,crr
+real(r_kind) x1_x,x2_x,x3_x
+real(r_kind) y1_y,y2_y,y3_y
+!-----------------------------------------------------------------------
+!
+! Initialize
+!
+
+ do n=1,this%nm
+ xa(n)=this%xa0+this%dxa*(n-1)
+ enddo
+
+ do i=1-this%ib,this%im+this%ib
+ xf(i)=this%xf0+this%dxf*(i-1)
+ enddo
+
+ do m=1,this%mm
+ ya(m)=this%ya0+this%dya*(m-1)
+ enddo
+
+ do j=1-this%jb,this%jm+this%jb
+ yf(j)=this%yf0+this%dyf*(j-1)
+ enddo
+
+!
+! Find iref and jref
+!
+ do n=1,this%nm
+ do i=1-this%ib,this%im+this%ib-1
+ if( xa(n)< xf(i)) then
+ this%iref(n)=i-2
+ this%irefq(n)=i-1
+ this%irefL(n)=i-1
+ exit
+ endif
+ enddo
+ enddo
+
+ do m=1,this%mm
+ do j=1-this%jb,this%jm+this%jb-1
+ if(ya(m) < yf(j)) then
+ this%jref(m)=j-2
+ this%jrefq(m)=j-1
+ this%jrefL(m)=j-1
+ exit
+ endif
+ enddo
+ enddo
+
+ do n=1,this%nm
+ i=this%iref(n)
+ x1=xf(i)
+ x2=xf(i+1)
+ x3=xf(i+2)
+ x4=xf(i+3)
+ x = xa(n)
+ x1x = x1-x
+ x2x = x2-x
+ x3x = x3-x
+ x4x = x4-x
+ rx2x1 = 1./(x2-x1)
+ rx3x1 = 1./(x3-x1)
+ rx4x1 = 1./(x4-x1)
+ rx3x2 = 1./(x3-x2)
+ rx4x2 = 1./(x4-x2)
+ rx4x3 = 1./(x4-x3)
+ CFL1 = x2x*x3x*rx2x1*rx3x1
+ CFL2 =-x1x*x3x*rx2x1*rx3x2
+ CFL3 = x1x*x2x*rx3x1*rx3x2
+ CLL = x3x*rx3x2
+ CFR1 = x3x*x4x*rx3x2*rx4x2
+ CFR2 =-x2x*x4x*rx3x2*rx4x3
+ CFR3 = x2x*x3x*rx4x2*rx4x3
+ CRR =-x2x*rx3x2
+ this%cx0(n)=CFL1*CLL
+ this%cx1(n)=CFL2*CLL+CFR1*CRR
+ this%cx2(n)=CFL3*CLL+CFR2*CRR
+ this%cx3(n)=CFR3*CRR
+ enddo
+
+ do m=1,this%mm
+ j=this%jref(m)
+ y1=yf(j)
+ y2=yf(j+1)
+ y3=yf(j+2)
+ y4=yf(j+3)
+ y = ya(m)
+ y1y = y1-y
+ y2y = y2-y
+ y3y = y3-y
+ y4y = y4-y
+ ry2y1 = 1./(y2-y1)
+ ry3y1 = 1./(y3-y1)
+ ry4y1 = 1./(y4-y1)
+ ry3y2 = 1./(y3-y2)
+ ry4y2 = 1./(y4-y2)
+ ry4y3 = 1./(y4-y3)
+ CFL1 = y2y*y3y*ry2y1*ry3y1
+ CFL2 =-y1y*y3y*ry2y1*ry3y2
+ CFL3 = y1y*y2y*ry3y1*ry3y2
+ CLL = y3y*ry3y2
+ CFR1 = y3y*y4y*ry3y2*ry4y2
+ CFR2 =-y2y*y4y*ry3y2*ry4y3
+ CFR3 = y2y*y3y*ry4y2*ry4y3
+ CRR =-y2y*ry3y2
+ this%cy0(m)=CFL1*CLL
+ this%cy1(m)=CFL2*CLL+CFR1*CRR
+ this%cy2(m)=CFL3*CLL+CFR2*CRR
+ this%cy3(m)=CFR3*CRR
+ enddo
+
+!
+! Quadratic interpolations
+!
+ do n=1,this%nm
+ i=this%irefq(n)
+ x1=xf(i)
+ x2=xf(i+1)
+ x3=xf(i+2)
+ x = xa(n)
+ x1_x = x1-x
+ x2_x = x2-x
+ x3_x = x3-x
+ rx2x1 = 1./(x2-x1)
+ rx3x1 = 1./(x3-x1)
+ rx3x2 = 1./(x3-x2)
+ this%qx0(n) = x2_x*x3_x*rx2x1*rx3x1
+ this%qx1(n) =-x1_x*x3_x*rx2x1*rx3x2
+ this%qx2(n) = x1_x*x2_x*rx3x1*rx3x2
+ enddo
+
+ do m=1,this%mm
+ i=this%jrefq(m)
+ y1=yf(i)
+ y2=yf(i+1)
+ y3=yf(i+2)
+ y = ya(m)
+ y1_y = y1-y
+ y2_y = y2-y
+ y3_y = y3-y
+ ry2y1 = 1./(y2-y1)
+ ry3y1 = 1./(y3-y1)
+ ry3y2 = 1./(y3-y2)
+ this%qy0(m) = y2_y*y3_y*ry2y1*ry3y1
+ this%qy1(m) =-y1_y*y3_y*ry2y1*ry3y2
+ this%qy2(m) = y1_y*y2_y*ry3y1*ry3y2
+ enddo
+
+!
+! Linear interpolations
+!
+ do n=1,this%nm
+ i=this%irefL(n)
+ x1=xf(i)
+ x2=xf(i+1)
+ x = xa(n)
+ x1_x = x1-x
+ x2_x = x2-x
+ rx2x1 = 1./(x2-x1)
+ this%Lx0(n) = x2_x*rx2x1
+ this%Lx1(n) =-x1_x*rx2x1
+ enddo
+
+ do m=1,this%mm
+ j=this%jrefL(m)
+ y1=yf(j)
+ y2=yf(j+1)
+ y = ya(m)
+ y1_y = y1-y
+ y2_y = y2-y
+ ry2y1 = 1./(y2-y1)
+ this%Ly0(m) = y2_y*ry2y1
+ this%Ly1(m) =-y1_y*ry2y1
+ enddo
+!-----------------------------------------------------------------------
+endsubroutine lsqr_mg_coef
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine lwq_vertical_coef &
+!***********************************************************************
+! !
+! Prepare coeficients for vertical mapping between: !
+! analysis grid vertical resolution (nm) and !
+! generation one of filter grid vertical resoluition (im) !
+! !
+! ( im <= nm ) !
+! !
+!***********************************************************************
+(this,nm_in,im_in,c1,c2,c3,c4,iref_out)
+implicit none
+class(mg_intstate_type),target::this
+
+integer(i_kind), intent(in):: nm_in,im_in
+real(r_kind), dimension(1:nm_in), intent(out):: c1,c2,c3,c4
+integer(i_kind), dimension(1:nm_in), intent(out):: iref_out
+
+real(r_kind), dimension(1:nm_in):: y
+real(r_kind), dimension(0:im_in+1):: x
+real(r_kind):: dy,x1,x2,x3,x4,dx1,dx2,dx3,dx4
+real(r_kind):: dx13,dx23,dx24
+
+integer(i_kind):: i,n
+!-----------------------------------------------------------------------
+
+ do i=0,im_in+1
+ x(i)=(i-1)*1.
+ enddo
+
+ dy = 1.*(im_in-1)/(nm_in-1)
+ do n=1,nm_in
+ y(n)=(n-1)*dy
+ enddo
+ y(nm_in)=x(im_in)
+
+ do n=2,nm_in-1
+ i = y(n)+1
+ x1 = x(i-1)
+ x2 = x(i)
+ x3 = x(i+1)
+ x4 = x(i+2)
+ iref_out(n)=i
+ dx1 = y(n)-x1
+ dx2 = y(n)-x2
+ dx3 = y(n)-x3
+ dx4 = y(n)-x4
+ dx13 = dx1*dx3
+ dx23 = 0.5*dx2*dx3
+ dx24 = dx2*dx4
+ c1(n) = -dx23*dx3
+ c2(n) = ( dx13+0.5*dx24)*dx3
+ c3(n) = -(0.5*dx13+ dx24)*dx2
+ c4(n) = dx23*dx2
+
+ if(iref_out(n)==1) then
+ c3(n)=c3(n)+c1(n)
+ c1(n)=0.
+ endif
+ if(iref_out(n)==im_in-1) then
+ c2(n)=c2(n)+c4(n)
+ c4(n)=0.
+ endif
+ enddo
+ iref_out(1)=1; c1(1)=0.; c2(1)=1.; c3(1)=0.; c4(1)=0.
+ iref_out(nm_in)=im_in; c1(nm_in)=0.; c2(nm_in)=1.; c3(nm_in)=0.; c4(n)=0.
+
+!-----------------------------------------------------------------------
+endsubroutine lwq_vertical_coef
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine lwq_vertical_adjoint &
+!***********************************************************************
+! !
+! Direct linerly weighted quadratic adjoint interpolation in vertical !
+! from reslution nm to resolution km !
+! !
+! ( km <= nm ) !
+! !
+!***********************************************************************
+(this,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f)
+implicit none
+!-----------------------------------------------------------------------
+class(mg_intstate_type),target::this
+integer(i_kind), intent(in):: nm_in,km_in,imin,imax,jmin,jmax
+real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4
+integer(i_kind), dimension(1:nm_in), intent(in):: kref
+real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(in):: w
+real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(out):: f
+integer(i_kind):: k,n
+!-----------------------------------------------------------------------
+ f = 0.
+do n=2,nm_in-1
+ k = kref(n)
+ if( k==1 ) then
+ f(1,:,:) = f(1,:,:)+c2(n)*w(n,:,:)
+ f(2,:,:) = f(2,:,:)+c3(n)*w(n,:,:)
+ f(3,:,:) = f(3,:,:)+c4(n)*w(n,:,:)
+ elseif &
+ ( k==km_in-1) then
+ f(km_in-2,:,:) = f(km_in-2,:,:)+c1(n)*w(n,:,:)
+ f(km_in-1,:,:) = f(km_in-1,:,:)+c2(n)*w(n,:,:)
+ f(km_in ,:,:) = f(km_in ,:,:)+c3(n)*w(n,:,:)
+ elseif( k==km_in) then
+ f(k ,:,:) = f(k ,:,:)+c2(n)*w(n,:,:)
+ else
+ f(k-1,:,:) = f(k-1,:,:)+c1(n)*w(n,:,:)
+ f(k ,:,:) = f(k ,:,:)+c2(n)*w(n,:,:)
+ f(k+1,:,:) = f(k+1,:,:)+c3(n)*w(n,:,:)
+ f(k+2,:,:) = f(k+2,:,:)+c4(n)*w(n,:,:)
+ endif
+enddo
+ f(1,:,:)=f(1,:,:)+w(1,:,:)
+ f(km_in,:,:)=f(km_in,:,:)+w(nm_in,:,:)
+
+!-----------------------------------------------------------------------
+endsubroutine lwq_vertical_adjoint
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine lwq_vertical_direct &
+!***********************************************************************
+! !
+! Linerly weighted direct quadratic interpolation in vertical !
+! from reslouion km to resolution nm !
+! !
+! ( km <= nm ) !
+! !
+!***********************************************************************
+(this,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,f,w)
+implicit none
+!-----------------------------------------------------------------------
+class(mg_intstate_type),target::this
+integer(i_kind), intent(in):: km_in,nm_in,imin,imax,jmin,jmax
+real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4
+integer(i_kind), dimension(1:nm_in), intent(in):: kref
+real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(in):: f
+real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(out):: w
+integer(i_kind):: k,n
+!-----------------------------------------------------------------------
+do n=2,nm_in-1
+ k = kref(n)
+ if( k==1 ) then
+ w(n,:,:) = c2(n)*f(k,:,:)+c3(n)*f(k+1,:,:)+c4(n)*f(k+2,:,:)
+ elseif &
+ ( k==km_in-1) then
+ w(n,:,:) =c1(n)*f(k-1,:,:)+c2(n)*f(k,:,:)+c3(n)*f(k+1,:,:)
+ elseif &
+ ( k==km_in) then
+ w(n,:,:) = c2(n)*f(k,:,:)
+ else
+ w(n,:,:) =c1(n)*f(k-1,:,:)+c2(n)*f(k,:,: )+c3(n)*f(k+1,:,:)+c4(n)*f(k+2,:,:)
+ endif
+enddo
+ w(1,:,:)=f(1,:,:)
+ w(nm_in,:,:)=f(km_in,:,:)
+
+!-----------------------------------------------------------------------
+endsubroutine lwq_vertical_direct
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine lwq_vertical_adjoint_spec &
+!***********************************************************************
+! !
+! Direct linerly weighted quadratic adjoint interpolation in vertical !
+! from reslution nm to resolution km !
+! !
+! ( km <= nm ) !
+! !
+!***********************************************************************
+(this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,W,F)
+implicit none
+!-----------------------------------------------------------------------
+class(mg_intstate_type),target::this
+integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax
+real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4
+integer(i_kind), dimension(1:nm_in), intent(in):: kref
+real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W
+real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F
+integer(i_kind):: k,n
+!-----------------------------------------------------------------------
+ F = 0.
+do n=2,nm_in-1
+ k = kref(n)
+ if( k==1 ) then
+ F(:,:,:,1) = F(:,:,:,1)+c2(n)*W(:,:,:,n)
+ F(:,:,:,2) = F(:,:,:,2)+c3(n)*W(:,:,:,n)
+ F(:,:,:,3) = F(:,:,:,3)+c4(n)*W(:,:,:,n)
+ elseif &
+ ( k==km_in-1) then
+ F(:,:,:,km_in-2) = F(:,:,:,km_in-2)+c1(n)*W(:,:,:,n)
+ F(:,:,:,km_in-1) = F(:,:,:,km_in-1)+c2(n)*W(:,:,:,n)
+ F(:,:,:,km_in ) = F(:,:,:,km_in )+c3(n)*W(:,:,:,n)
+ elseif( k==km_in) then
+ F(:,:,:,k ) = F(:,:,:,k )+c2(n)*W(:,:,:,n)
+ else
+ F(:,:,:,k-1) = F(:,:,:,k-1)+c1(n)*W(:,:,:,n)
+ F(:,:,:,k ) = F(:,:,:,k )+c2(n)*W(:,:,:,n)
+ F(:,:,:,k+1) = F(:,:,:,k+1)+c3(n)*W(:,:,:,n)
+ F(:,:,:,k+2) = F(:,:,:,k+2)+c4(n)*W(:,:,:,n)
+ endif
+enddo
+ F(:,:,:,1 )=F(:,:,:,1 )+W(:,:,:,1 )
+ F(:,:,:,km_in)=F(:,:,:,km_in)+W(:,:,:,nm_in)
+!-----------------------------------------------------------------------
+endsubroutine lwq_vertical_adjoint_spec
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine lwq_vertical_direct_spec &
+!***********************************************************************
+! !
+! Linerly weighted direct quadratic interpolation in vertical !
+! from reslouion im to resolution nm !
+! !
+! ( km <= nm ) !
+! !
+!***********************************************************************
+(this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,F,W)
+implicit none
+!-----------------------------------------------------------------------
+class(mg_intstate_type),target::this
+integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax
+real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4
+integer(i_kind), dimension(1:nm_in), intent(in):: kref
+real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F
+real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W
+integer(i_kind):: k,n
+!-----------------------------------------------------------------------
+do n=2,nm_in-1
+ k = kref(n)
+ if( k==1 ) then
+ W(:,:,:,n) = c2(n)*F(:,:,:,k)+c3(n)*F(:,:,:,k+1)+c4(n)*F(:,:,:,k+2)
+ elseif &
+ ( k==km_in-1) then
+ W(:,:,:,n) =c1(n)*F(:,:,:,k-1)+c2(n)*F(:,:,:,k)+c3(n)*F(:,:,:,k+1)
+ elseif &
+ ( k==km_in) then
+ W(:,:,:,n) = c2(n)*F(:,:,:,k)
+ else
+ W(:,:,:,n) =c1(n)*F(:,:,:,k-1)+c2(n)*F(:,:,:,k)+c3(n)*F(:,:,:,k+1)+c4(n)*F(:,:,:,k+2)
+ endif
+enddo
+ W(:,:,:,1 )=F(:,:,:,1 )
+ W(:,:,:,nm_in)=F(:,:,:,km_in)
+!-----------------------------------------------------------------------
+endsubroutine lwq_vertical_direct_spec
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine l_vertical_adjoint_spec &
+!***********************************************************************
+! !
+! Adjoint of linear interpolations in vertical !
+! from reslution nm to resolution km !
+! !
+! ( nm = 2*km-1 ) !
+! !
+!***********************************************************************
+(this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,W,F)
+implicit none
+!-----------------------------------------------------------------------
+class(mg_intstate_type),target::this
+integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax
+real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W
+real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F
+integer(i_kind):: k,n
+!-----------------------------------------------------------------------
+ F = 0.
+
+ k=1
+ do n=2,nm_in-1,2
+ F(:,:,:,k ) = F(:,:,:,k )+0.5*W(:,:,:,n)
+ F(:,:,:,k+1) = F(:,:,:,k+1)+0.5*W(:,:,:,n)
+ k=k+1
+ enddo
+
+ k=1
+ do n=1,nm_in,2
+ F(:,:,:,k ) = F(:,:,:,k )+ W(:,:,:,n)
+ k=k+1
+ enddo
+!-----------------------------------------------------------------------
+endsubroutine l_vertical_adjoint_spec
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine l_vertical_direct_spec &
+!***********************************************************************
+! !
+! !
+! Direct linear interpolations in vertical !
+! from reslution nm to resolution km !
+! !
+! ( nm = 2*km-1 ) !
+! !
+!***********************************************************************
+(this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,F,W)
+implicit none
+!-----------------------------------------------------------------------
+class(mg_intstate_type),target::this
+integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax
+real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F
+real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W
+integer(i_kind):: k,n
+!-----------------------------------------------------------------------
+ k=1
+ do n=1,nm_in,2
+ W(:,:,:,n) =F (:,:,:,k)
+ k=k+1
+ enddo
+
+ k=1
+ do n=2,nm_in-1,2
+ W(:,:,:,n) = 0.5*(F(:,:,:,k)+F(:,:,:,k+1))
+ k=k+1
+ enddo
+!-----------------------------------------------------------------------
+endsubroutine l_vertical_direct_spec
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine lsqr_direct_offset &
+!***********************************************************************
+! !
+! Given a source array V(km,1-ib:im+ib,1-jb:jm+jb) perform !
+! direct interpolations to get target array W(km,1:nm,1:mm) !
+! using two passes of 1d interpolator !
+! !
+!***********************************************************************
+(this,V_in,W,km_in,ibm,jbm)
+!-----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: km_in,ibm,jbm
+real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in
+real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W
+
+real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX
+integer(i_kind):: i,j,n,m
+real(r_kind),dimension(km_in):: v0,v1,v2,v3
+!-----------------------------------------------------------------------
+ do j=1-jbm,this%jm+jbm
+ do n=1,this%nm
+ i = this%iref(n)
+ v0(:)=V_in(:,i ,j)
+ v1(:)=V_in(:,i+1,j)
+ v2(:)=V_in(:,i+2,j)
+ v3(:)=V_in(:,i+3,j)
+ VX(:,n,j) = this%cx0(n)*v0(:)+this%cx1(n)*v1(:)+this%cx2(n)*v2(:)+this%cx3(n)*v3(:)
+ enddo
+ enddo
+
+ do m=1,this%mm
+ j = this%jref(m)
+ do n=1,this%nm
+ v0(:)=VX(:,n,j )
+ v1(:)=VX(:,n,j+1)
+ v2(:)=VX(:,n,j+2)
+ v3(:)=VX(:,n,j+3)
+ W(:,n,m) = this%cy0(m)*v0(:)+this%cy1(m)*v1(:)+this%cy2(m)*v2(:)+this%cy3(m)*v3(:)
+ enddo
+ enddo
+!-----------------------------------------------------------------------
+endsubroutine lsqr_direct_offset
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine lsqr_adjoint_offset &
+!***********************************************************************
+! !
+! Given a target array W(km,1:nm,1:mm) perform adjoint !
+! interpolations to get source array V(km,1-ib:im+ib,1-jb:jm+jb) !
+! using two passes of 1d interpolator !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,V_out,km_in,ibm,jbm)
+!-----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind):: km_in,ibm,jbm
+real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W
+real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out
+real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX
+real(r_kind), dimension(km_in):: wk
+real(r_kind), dimension(km_in):: vxk
+integer(i_kind):: i,j,n,m,l,k
+real(r_kind):: c0,c1,c2,c3
+!-----------------------------------------------------------------------
+ V_out(:,:,:)=0.
+ VX(:,:,:)=0.
+
+ do m=1,this%mm
+ j = this%jref(m)
+ c0 = this%cy0(m)
+ c1 = this%cy1(m)
+ c2 = this%cy2(m)
+ c3 = this%cy3(m)
+ do n=1,this%nm
+ wk(:)=W(:,n,m)
+ VX(:,n,j ) = VX(:,n,j )+wk(:)*c0
+ VX(:,n,j+1) = VX(:,n,j+1)+wk(:)*c1
+ VX(:,n,j+2) = VX(:,n,j+2)+wk(:)*c2
+ VX(:,n,j+3) = VX(:,n,j+3)+wk(:)*c3
+ enddo
+ enddo
+
+ do n=1,this%nm
+ i = this%iref(n)
+ c0 = this%cx0(n)
+ c1 = this%cx1(n)
+ c2 = this%cx2(n)
+ c3 = this%cx3(n)
+ do j=1-jbm,this%jm+jbm
+ vxk(:)=VX(:,n,j)
+ V_out(:,i ,j) = V_out(:,i ,j)+vxk(:)*c0
+ V_out(:,i+1,j) = V_out(:,i+1,j)+vxk(:)*c1
+ V_out(:,i+2,j) = V_out(:,i+2,j)+vxk(:)*c2
+ V_out(:,i+3,j) = V_out(:,i+3,j)+vxk(:)*c3
+ enddo
+ enddo
+!-----------------------------------------------------------------------
+endsubroutine lsqr_adjoint_offset
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine quad_direct_offset &
+!***********************************************************************
+! !
+! Given a source array V(km,1-ib:im+ib,1-jb:jm+jb) perform !
+! direct interpolations to get target array W(km,1:nm,1:mm) !
+! using two passes of 1d interpolator !
+! !
+!***********************************************************************
+(this,V_in,W,km_in,ibm,jbm)
+!-----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: km_in,ibm,jbm
+real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in
+real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W
+real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX
+integer(i_kind):: i,j,n,m
+real(r_kind),dimension(km_in):: v0,v1,v2
+!-----------------------------------------------------------------------
+ do n=1,this%nm
+ i = this%irefq(n)
+ do j=1-jbm,this%jm+jbm
+ v0(:)=V_in(:,i ,j)
+ v1(:)=V_in(:,i+1,j)
+ v2(:)=V_in(:,i+2,j)
+ VX(:,n,j) = this%qx0(n)*v0(:)+this%qx1(n)*v1(:)+this%qx2(n)*v2(:)
+ enddo
+ enddo
+
+ do m=1,this%mm
+ j = this%jrefq(m)
+ do n=1,this%nm
+ v0(:)=VX(:,n,j )
+ v1(:)=VX(:,n,j+1)
+ v2(:)=VX(:,n,j+2)
+ W(:,n,m) = this%qy0(m)*v0(:)+this%qy1(m)*v1(:)+this%qy2(m)*v2(:)
+ enddo
+ enddo
+!-----------------------------------------------------------------------
+endsubroutine quad_direct_offset
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine quad_adjoint_offset &
+!***********************************************************************
+! !
+! Given a target array W(km,1:nm,1:mm) perform adjoint !
+! interpolations to get source array V(km,1-ib:im+ib,1-jb:jm+jb) !
+! using two passes of 1d interpolator !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,V_out,km_in,ibm,jbm)
+!-----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind):: km_in,ibm,jbm
+real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W
+real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out
+real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX
+real(r_kind), dimension(km_in):: wk
+real(r_kind), dimension(km_in):: vxk
+integer(i_kind):: i,j,n,m,l,k
+real(r_kind):: c0,c1,c2
+!-----------------------------------------------------------------------
+ V_out(:,:,:)=0.
+ VX(:,:,:)=0.
+
+ do m=1,this%mm
+ j = this%jrefq(m)
+ c0 = this%qy0(m)
+ c1 = this%qy1(m)
+ c2 = this%qy2(m)
+ do n=1,this%nm
+ wk(:)=W(:,n,m)
+ VX(:,n,j ) = VX(:,n,j )+wk(:)*c0
+ VX(:,n,j+1) = VX(:,n,j+1)+wk(:)*c1
+ VX(:,n,j+2) = VX(:,n,j+2)+wk(:)*c2
+ enddo
+ enddo
+
+
+ do n=1,this%nm
+ i = this%irefq(n)
+ c0 = this%qx0(n)
+ c1 = this%qx1(n)
+ c2 = this%qx2(n)
+ do j=1-jbm,this%jm+jbm
+ vxk(:)=VX(:,n,j)
+ V_out(:,i ,j) = V_out(:,i ,j)+vxk(:)*c0
+ V_out(:,i+1,j) = V_out(:,i+1,j)+vxk(:)*c1
+ V_out(:,i+2,j) = V_out(:,i+2,j)+vxk(:)*c2
+ enddo
+ enddo
+!-----------------------------------------------------------------------
+endsubroutine quad_adjoint_offset
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine lin_direct_offset &
+!***********************************************************************
+! !
+! Given a source array V(km,1-ib:im+ib,1-jb:jm+jb) perform !
+! direct interpolations to get target array W(km,1:nm,1:mm) !
+! using two passes of 1d linear interpolator !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,V_in,W,km_in,ibm,jbm)
+!-----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind),intent(in):: km_in,ibm,jbm
+real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in
+real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W
+real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX
+integer(i_kind):: i,j,n,m
+real(r_kind),dimension(km_in):: v0,v1
+!-----------------------------------------------------------------------
+ do n=1,this%nm
+ i = this%irefL(n)
+ do j=1-jbm,this%jm+jbm
+ v0(:)=V_in(:,i ,j)
+ v1(:)=V_in(:,i+1,j)
+ VX(:,n,j) = this%Lx0(n)*v0(:)+this%Lx1(n)*v1(:)
+ enddo
+ enddo
+
+ do m=1,this%mm
+ j = this%jrefL(m)
+ do n=1,this%nm
+ v0(:)=VX(:,n,j )
+ v1(:)=VX(:,n,j+1)
+ W(:,n,m) = this%Ly0(m)*v0(:)+this%Ly1(m)*v1(:)
+ enddo
+ enddo
+!-----------------------------------------------------------------------
+endsubroutine lin_direct_offset
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine lin_adjoint_offset &
+!***********************************************************************
+! !
+! Given a target array W(km,1:nm,1:mm) perform adjoint !
+! interpolations to get source array V(km,1-ib:im+ib,1-jb:jm+jb) !
+! using two passes of 1d linear interpolator !
+! !
+! - offset version - !
+! !
+!***********************************************************************
+(this,W,V_out,km_in,ibm,jbm)
+!-----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind):: km_in,ibm,jbm
+real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W
+real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out
+real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX
+real(r_kind), dimension(km_in):: wk
+real(r_kind), dimension(km_in):: vxk
+integer(i_kind):: i,j,n,m,l,k
+real(r_kind):: c0,c1
+!-----------------------------------------------------------------------
+ V_out(:,:,:)=0.
+ VX(:,:,:)=0.
+
+ do m=1,this%mm
+ j = this%jrefL(m)
+ c0 = this%Ly0(m)
+ c1 = this%Ly1(m)
+ do n=1,this%nm
+ wk(:)=W(:,n,m)
+ VX(:,n,j ) = VX(:,n,j )+wk(:)*c0
+ VX(:,n,j+1) = VX(:,n,j+1)+wk(:)*c1
+ enddo
+ enddo
+
+ do n=1,this%nm
+ i = this%irefL(n)
+ c0 = this%Lx0(n)
+ c1 = this%Lx1(n)
+ do j=1-jbm,this%jm+jbm
+ vxk(:)=VX(:,n,j)
+ V_out(:,i ,j) = V_out(:,i ,j)+vxk(:)*c0
+ V_out(:,i+1,j) = V_out(:,i+1,j)+vxk(:)*c1
+ enddo
+ enddo
+!-----------------------------------------------------------------------
+endsubroutine lin_adjoint_offset
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine l_vertical_adjoint_spec2 &
+!***********************************************************************
+! !
+! Adjoint of linear interpolations in vertical !
+! from reslution nm to resolution km !
+! !
+! ( nm = 2*km-1 ) !
+! !
+!***********************************************************************
+(this,en,nm_in,km_in,imin,imax,jmin,jmax,W,F)
+implicit none
+!-----------------------------------------------------------------------
+class(mg_intstate_type),target::this
+integer(i_kind), intent(in):: en,nm_in,km_in,imin,imax,jmin,jmax
+real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(in):: W
+real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(out):: F
+integer(i_kind):: k,n,e,enm,ekm
+!-----------------------------------------------------------------------
+ F = 0.
+
+do e=0,en-1
+ enm = e*nm_in
+ ekm = e*km_in
+ k=1
+ do n=2,nm_in-1,2
+ F(ekm+k ,:,:) = F(ekm+k ,:,:)+0.5*W(enm+n,:,:)
+ F(ekm+k+1,:,:) = F(ekm+k+1,:,:)+0.5*W(enm+n,:,:)
+ k=k+1
+ enddo
+
+ k=1
+ do n=1,nm_in,2
+ F(ekm+k,:,:) = F(ekm+k,:,:) + W(enm+n,:,:)
+ k=k+1
+ enddo
+enddo
+!-----------------------------------------------------------------------
+endsubroutine l_vertical_adjoint_spec2
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine l_vertical_direct_spec2 &
+!***********************************************************************
+! !
+! !
+! Direct linear interpolations in vertical !
+! from reslution nm to resolution km !
+! !
+! ( nmax = 2*kmax-1 ) !
+! !
+!***********************************************************************
+(this,en,km_in,nm_in,imin,imax,jmin,jmax,F,W)
+implicit none
+!-----------------------------------------------------------------------
+class(mg_intstate_type),target::this
+integer(i_kind), intent(in):: en,km_in,nm_in,imin,imax,jmin,jmax
+real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(in):: F
+real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(out):: W
+integer(i_kind):: k,n,e,enm,ekm
+!-----------------------------------------------------------------------
+do e=0,en-1
+ enm = e*nm_in
+ ekm = e*km_in
+ k=1
+ do n=1,nm_in,2
+ W(enm+n,:,:) =F (ekm+k,:,:)
+ k=k+1
+ enddo
+ k=1
+ do n=2,nm_in-1,2
+ W(enm+n,:,:) = 0.5*(F(ekm+k,:,:)+F(ekm+k+1,:,:))
+ k=k+1
+ enddo
+enddo
+!-----------------------------------------------------------------------
+endsubroutine l_vertical_direct_spec2
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+end submodule mg_interpolate
diff --git a/src/mgbf/mg_intstate.f90 b/src/mgbf/mg_intstate.f90
new file mode 100644
index 0000000000..932084c705
--- /dev/null
+++ b/src/mgbf/mg_intstate.f90
@@ -0,0 +1,1394 @@
+module mg_intstate
+!$$$ submodule documentation block
+! . . . .
+! module: mg_intstate
+! prgmmr: rancic org: NCEP/EMC date: 2020
+!
+! abstract: Contains declarations and allocations of internal
+! state variables use for filtering (offset version)
+!
+! module history log:
+! 2023-04-19 lei - object-oriented coding
+! 2024-01-11 rancic - optimization for ensemble localization
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! allocate_mg_intstate -
+! def_mg_weights -
+! init_mg_line -
+! deallocate_mg_intstate -
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+use kinds, only: r_kind,i_kind
+use jp_pkind2, only: fpi
+use jp_pbfil3, only: inimomtab,t22_to_3,tritform,t33_to_6,hextform
+use mg_parameter,only: mg_parameter_type
+implicit none
+type,extends( mg_parameter_type):: mg_intstate_type
+real(r_kind), allocatable,dimension(:,:,:):: V
+!
+! Composite control variable on first generation of filter grid
+!
+real(r_kind), allocatable,dimension(:,:,:):: VALL
+!
+! Composite control variable on high generations of filter grid
+!
+real(r_kind), allocatable,dimension(:,:,:):: HALL
+
+real(r_kind), allocatable,dimension(:,:,:):: a_diff_f
+real(r_kind), allocatable,dimension(:,:,:):: a_diff_h
+real(r_kind), allocatable,dimension(:,:,:):: b_diff_f
+real(r_kind), allocatable,dimension(:,:,:):: b_diff_h
+
+!
+! Localization weights
+!
+real(r_kind), allocatable,dimension(:,:,:):: w1_loc
+real(r_kind), allocatable,dimension(:,:,:):: w2_loc
+real(r_kind), allocatable,dimension(:,:,:):: w3_loc
+real(r_kind), allocatable,dimension(:,:,:):: w4_loc
+
+real(r_kind), allocatable,dimension(:,:):: p_eps
+real(r_kind), allocatable,dimension(:,:):: p_del
+real(r_kind), allocatable,dimension(:,:):: p_sig
+real(r_kind), allocatable,dimension(:,:):: p_rho
+
+real(r_kind), allocatable,dimension(:,:,:):: paspx
+real(r_kind), allocatable,dimension(:,:,:):: paspy
+real(r_kind), allocatable,dimension(:,:,:):: pasp1
+real(r_kind), allocatable,dimension(:,:,:,:):: pasp2
+real(r_kind), allocatable,dimension(:,:,:,:,:):: pasp3
+
+real(r_kind), allocatable,dimension(:,:,:):: vpasp2
+real(r_kind), allocatable,dimension(:,:,:):: hss2
+real(r_kind), allocatable,dimension(:,:,:,:):: vpasp3
+real(r_kind), allocatable,dimension(:,:,:,:):: hss3
+
+real(r_kind), allocatable,dimension(:):: ssx
+real(r_kind), allocatable,dimension(:):: ssy
+real(r_kind), allocatable,dimension(:):: ss1
+real(r_kind), allocatable,dimension(:,:):: ss2
+real(r_kind), allocatable,dimension(:,:,:):: ss3
+
+integer(fpi), allocatable,dimension(:,:,:):: dixs
+integer(fpi), allocatable,dimension(:,:,:):: diys
+integer(fpi), allocatable,dimension(:,:,:):: dizs
+
+integer(fpi), allocatable,dimension(:,:,:,:):: dixs3
+integer(fpi), allocatable,dimension(:,:,:,:):: diys3
+integer(fpi), allocatable,dimension(:,:,:,:):: dizs3
+
+integer(fpi), allocatable,dimension(:,:,:,:):: qcols
+
+integer(i_kind),allocatable,dimension(:):: iref,jref
+integer(i_kind),allocatable,dimension(:):: irefq,jrefq
+integer(i_kind),allocatable,dimension(:):: irefL,jrefL
+
+integer(i_kind),allocatable,dimension(:):: Lref,Lref_h
+real(r_kind),allocatable,dimension(:):: cvf1,cvf2,cvf3,cvf4
+real(r_kind),allocatable,dimension(:):: cvh1,cvh2,cvh3,cvh4
+
+real(r_kind),allocatable,dimension(:):: cx0,cx1,cx2,cx3
+real(r_kind),allocatable,dimension(:):: cy0,cy1,cy2,cy3
+
+real(r_kind),allocatable,dimension(:):: qx0,qx1,qx2
+real(r_kind),allocatable,dimension(:):: qy0,qy1,qy2
+
+real(r_kind),allocatable,dimension(:):: Lx0,Lx1
+real(r_kind),allocatable,dimension(:):: Ly0,Ly1
+
+real(r_kind),allocatable,dimension(:):: p_coef,q_coef
+real(r_kind),allocatable,dimension(:):: a_coef,b_coef
+
+real(r_kind),allocatable,dimension(:,:):: cf00,cf01,cf02,cf03 &
+ ,cf10,cf11,cf12,cf13 &
+ ,cf20,cf21,cf22,cf23 &
+ ,cf30,cf31,cf32,cf33
+contains
+ procedure :: allocate_mg_intstate,deallocate_mg_intstate
+ procedure :: def_mg_weights,init_mg_line
+!from mg_interpolate.f90
+ procedure :: def_offset_coef
+ procedure :: lsqr_mg_coef,lwq_vertical_coef
+ procedure :: lwq_vertical_direct,lwq_vertical_adjoint
+ procedure :: lwq_vertical_direct_spec,lwq_vertical_adjoint_spec
+ procedure :: l_vertical_direct_spec,l_vertical_adjoint_spec
+ procedure :: l_vertical_direct_spec2,l_vertical_adjoint_spec2
+ procedure :: lsqr_direct_offset,lsqr_adjoint_offset
+ procedure :: quad_direct_offset,quad_adjoint_offset
+ procedure :: lin_direct_offset,lin_adjoint_offset
+!from mg_bocos.f90
+ generic :: boco_2d => boco_2d_g1,boco_2d_gh
+ procedure :: boco_2d_g1,boco_2d_gh
+ generic :: boco_3d => boco_3d_g1,boco_3d_gh
+ procedure :: boco_3d_g1,boco_3d_gh
+ generic :: bocoT_2d => bocoT_2d_g1,bocoT_2d_gh
+ procedure :: bocoT_2d_g1,bocoT_2d_gh
+ generic :: bocoTx => bocoTx_2d_g1,bocoTx_2d_gh
+ procedure :: bocoTx_2d_g1,bocoTx_2d_gh
+ generic :: bocoTy => bocoTy_2d_g1,bocoTy_2d_gh
+ procedure :: bocoTy_2d_g1,bocoTy_2d_gh
+ generic :: bocoT_3d => bocoT_3d_g1,bocoT_3d_gh
+ procedure :: bocoT_3d_g1,bocoT_3d_gh
+ generic :: bocox => bocox_2d_g1,bocox_2d_gh
+ procedure :: bocox_2d_g1,bocox_2d_gh
+ generic :: bocoy => bocoy_2d_g1,bocoy_2d_gh
+ procedure :: bocoy_2d_g1,bocoy_2d_gh
+ generic :: upsend_all => upsend_all_g1,upsend_all_gh
+ procedure :: upsend_all_g1,upsend_all_gh
+ generic :: downsend_all => downsend_all_g2,downsend_all_gh
+ procedure :: downsend_all_g2,downsend_all_gh
+ procedure :: boco_2d_loc
+ procedure :: bocoT_2d_loc
+ procedure :: upsend_loc_g12
+ procedure :: upsend_loc_g23
+ procedure :: upsend_loc_g34
+ procedure :: downsend_loc_g43
+ procedure :: downsend_loc_g32
+ procedure :: downsend_loc_g21
+!from mg_generation.f90
+ procedure:: upsending_all,downsending_all,weighting_all
+ procedure:: upsending,downsending
+ procedure:: upsending_highest,downsending_highest
+ procedure:: upsending2,downsending2
+ procedure:: upsending_ens,downsending_ens
+ procedure:: upsending2_ens,downsending2_ens
+ procedure:: upsending_ens_nearest,downsending_ens_nearest
+ generic :: upsending_loc => upsending_loc_g3,upsending_loc_g4
+ procedure:: upsending_loc_g3,upsending_loc_g4
+ generic :: downsending_loc => downsending_loc_g3,downsending_loc_g4
+ procedure:: downsending_loc_g3,downsending_loc_g4
+ procedure:: weighting_helm,weighting,weighting_highest,weighting_ens
+ generic :: weighting_loc => weighting_loc_g3,weighting_loc_g4
+ procedure:: weighting_loc_g3,weighting_loc_g4
+ procedure:: adjoint,direct1
+ procedure:: adjoint2,direct2
+ procedure:: adjoint_nearest,direct_nearest
+ procedure:: adjoint_highest,direct_highest
+!from mg_filtering.f90
+ procedure :: filtering_procedure
+ procedure :: filtering_rad3,filtering_lin3
+ procedure :: filtering_rad2_bkg,filtering_lin2_bkg,filtering_fast_bkg
+ procedure :: filtering_rad2_ens,filtering_lin2_ens,filtering_fast_ens
+ procedure :: filtering_rad_highest
+ procedure :: sup_vrbeta1T,sup_vrbeta1,sup_vrbeta3T,sup_vrbeta3
+ procedure :: sup_vrbeta1_ens,sup_vrbeta1T_ens
+ procedure :: sup_vrbeta1_bkg,sup_vrbeta1T_bkg
+!from mg_transfer.f90
+ procedure :: anal_to_filt_allmap,filt_to_anal_allmap
+ procedure :: anal_to_filt_all,filt_to_anal_all
+ procedure :: anal_to_filt_all2,filt_to_anal_all2
+ procedure :: composite_to_stack,stack_to_composite
+ procedure :: C2S_ens,S2C_ens
+ procedure :: anal_to_filt,filt_to_anal
+!from mg_entrymod.f90
+ procedure :: mg_initialize
+ procedure :: mg_finalize
+end type mg_intstate_type
+interface
+!from mg_interpolate.f90
+ module subroutine def_offset_coef(this)
+ class(mg_intstate_type),target::this
+ end subroutine
+ module subroutine lsqr_mg_coef(this)
+ class(mg_intstate_type),target::this
+ end subroutine
+ module subroutine lwq_vertical_coef &
+ (this,nm_in,im_in,c1,c2,c3,c4,iref_out)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: nm_in,im_in
+ real(r_kind), dimension(1:nm_in), intent(out):: c1,c2,c3,c4
+ integer(i_kind), dimension(1:nm_in), intent(out):: iref_out
+ end subroutine
+ module subroutine lwq_vertical_direct &
+ (this,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,f,w)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,nm_in,imin,imax,jmin,jmax
+ real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4
+ integer(i_kind), dimension(1:nm_in), intent(in):: kref
+ real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(in):: f
+ real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(out):: w
+ end subroutine
+ module subroutine lwq_vertical_adjoint &
+ (this,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: nm_in,km_in,imin,imax,jmin,jmax
+ real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4
+ integer(i_kind), dimension(1:nm_in), intent(in):: kref
+ real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(in):: w
+ real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(out):: f
+ end subroutine
+ module subroutine lwq_vertical_direct_spec &
+ (this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,F,W)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax
+ real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4
+ integer(i_kind), dimension(1:nm_in), intent(in):: kref
+ real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F
+ real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W
+ end subroutine
+ module subroutine lwq_vertical_adjoint_spec &
+ (this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,W,F)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax
+ real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4
+ integer(i_kind), dimension(1:nm_in), intent(in):: kref
+ real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W
+ real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F
+ end subroutine
+ module subroutine l_vertical_direct_spec &
+ (this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,F,W)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax
+ real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F
+ real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W
+ end subroutine
+ module subroutine l_vertical_adjoint_spec &
+ (this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,W,F)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax
+ real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W
+ real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F
+ end subroutine
+ module subroutine l_vertical_direct_spec2 &
+ (this,en,km_in,nm_in,imin,imax,jmin,jmax,f,w)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: en,km_in,nm_in,imin,imax,jmin,jmax
+ real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(in):: F
+ real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(out):: W
+ end subroutine
+ module subroutine l_vertical_adjoint_spec2 &
+ (this,en,nm_in,km_in,imin,imax,jmin,jmax,w,f)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: en,nm_in,km_in,imin,imax,jmin,jmax
+ real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(in):: W
+ real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(out):: F
+ end subroutine
+ module subroutine lsqr_direct_offset &
+ (this,V_in,W,km_in,ibm,jbm)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: km_in,ibm,jbm
+ real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in
+ real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W
+ real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX
+ end subroutine
+ module subroutine lsqr_adjoint_offset &
+ (this,W,V_out,km_in,ibm,jbm)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind):: km_in,ibm,jbm
+ real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W
+ real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out
+ real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX
+ end subroutine
+ module subroutine quad_direct_offset &
+ (this,V_in,W,km_in,ibm,jbm)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: km_in,ibm,jbm
+ real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in
+ real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W
+ real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX
+ end subroutine
+ module subroutine quad_adjoint_offset &
+ (this,W,V_out,km_in,ibm,jbm)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind):: km_in,ibm,jbm
+ real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W
+ real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out
+ real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX
+ end subroutine
+ module subroutine lin_direct_offset &
+ (this,V_in,W,km_in,ibm,jbm)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: km_in,ibm,jbm
+ real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in
+ real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W
+ end subroutine
+ module subroutine lin_adjoint_offset &
+ (this,W,V_out,km_in,ibm,jbm)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind):: km_in,ibm,jbm
+ real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W
+ real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out
+ end subroutine
+!from mg_bocos.f90
+ module subroutine boco_2d_g1 &
+ (this,W,km_in,im_in,jm_in,nbx,nby)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby
+ real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ end subroutine
+ module subroutine boco_2d_gh &
+ (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+ real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine boco_3d_g1 &
+ (this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz
+ real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine boco_3d_gh &
+ (this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max
+ real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine bocoT_2d_g1 &
+ (this,W,km_in,im_in,jm_in,nbx,nby)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby
+ real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ end subroutine
+ module subroutine bocoT_2d_gh &
+ (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+ real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine bocoTx_2d_g1 &
+ (this,W,km_in,im_in,jm_in,nbx,nby)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby
+ real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ end subroutine
+ module subroutine bocoTx_2d_gh &
+ (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+ real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine bocoTy_2d_g1 &
+ (this,W,km_in,im_in,jm_in,nbx,nby)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby
+ real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ end subroutine
+ module subroutine bocoTy_2d_gh &
+ (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+ real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine bocoT_3d_g1 &
+ (this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz
+ real(r_kind), dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine bocoT_3d_gh &
+ (this,W,km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max
+ real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine bocox_2d_gh &
+ (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+ real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine bocox_2d_g1 &
+ (this,W,km_in,im_in,jm_in,nbx,nby)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby
+ real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ end subroutine
+ module subroutine bocoy_2d_g1 &
+ (this,W,km_in,im_in,jm_in,nbx,nby)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby
+ real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ end subroutine
+ module subroutine bocoy_2d_gh &
+ (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max
+ real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine upsend_all_g1 &
+ (this,Harray,Warray,km_in)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in
+ real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray
+ real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray
+ end subroutine
+ module subroutine upsend_all_gh &
+ (this,Harray,Warray,km_in,mygen_dn,mygen_up)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in
+ real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray
+ real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray
+ integer(i_kind),intent(in):: mygen_dn,mygen_up
+ end subroutine
+ module subroutine downsend_all_gh &
+ (this,Warray,Harray,km_in,mygen_up,mygen_dn)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in
+ real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray
+ real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray
+ integer, intent(in):: mygen_up,mygen_dn
+ end subroutine
+ module subroutine downsend_all_g2 &
+ (this,Warray,Harray,km_in)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in
+ real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray
+ real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray
+ end subroutine
+ module subroutine boco_2d_loc &
+ (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g
+ real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine bocoT_2d_loc &
+ (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g
+ real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W
+ integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in
+ end subroutine
+ module subroutine upsend_loc_g12 &
+ (this,V_in,H,km_4_in,flag)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_4_in,flag
+ real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(in):: V_in
+ real(r_kind), dimension(km_4_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ end subroutine
+ module subroutine upsend_loc_g23 &
+ (this,V_in,H,km_16_in,flag)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_16_in,flag
+ real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(in):: V_in
+ real(r_kind), dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ end subroutine
+ module subroutine upsend_loc_g34 &
+ (this,V_in,H,km_64_in,flag)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_64_in,flag
+ real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(in):: V_in
+ real(r_kind), dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ end subroutine
+ module subroutine downsend_loc_g43 &
+ (this,W,Z,km_64_in,flag)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_64_in,flag
+ real(r_kind), dimension(km_64_in,1:this%im,1:this%jm),intent(in):: W
+ real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(out):: Z
+ end subroutine
+ module subroutine downsend_loc_g32 &
+ (this,Z,H,km_16_in,flag)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_16_in,flag
+ real(r_kind), dimension(km_16_in,1:this%im,1:this%jm),intent(in):: Z
+ real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(out):: H
+ end subroutine
+ module subroutine downsend_loc_g21 &
+ (this,H,V_out,km_4_in,flag)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind), intent(in):: km_4_in,flag
+ real(r_kind), dimension(km_4_in,1:this%im,1:this%jm),intent(in):: H
+ real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(out):: V_out
+ end subroutine
+!from mg_generations.f90
+ module subroutine upsending_all &
+ (this,V,H,lquart)
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ logical, intent(in):: lquart
+ end subroutine
+ module subroutine downsending_all &
+ (this,H,V,lquart)
+ implicit none
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ logical, intent(in):: lquart
+ end subroutine
+ module subroutine weighting_all &
+ (this,V,H,lhelm)
+ implicit none
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ logical, intent(in):: lhelm
+ end subroutine
+ module subroutine upsending &
+ (this,V,H)
+ implicit none
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: V_INT
+ real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT
+ end subroutine
+ module subroutine downsending &
+ (this,H,V)
+ implicit none
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ end subroutine
+ module subroutine upsending2 &
+ (this,V,H)
+ implicit none
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ end subroutine
+ module subroutine downsending2 &
+ (this,H,V)
+ implicit none
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ end subroutine
+ module subroutine upsending_highest &
+ (this,V,H)
+ implicit none
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ end subroutine
+ module subroutine downsending_highest &
+ (this,H,V)
+ implicit none
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ end subroutine
+ module subroutine upsending_ens &
+ (this,V,H,kmx)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind), intent(in):: kmx
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ end subroutine
+ module subroutine downsending_ens &
+ (this,H,V,kmx)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind), intent(in):: kmx
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ end subroutine
+ module subroutine upsending2_ens &
+ (this,V,H,kmx)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind), intent(in):: kmx
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ end subroutine
+ module subroutine downsending2_ens &
+ (this,H,V,kmx)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind), intent(in):: kmx
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ end subroutine
+ module subroutine upsending_ens_nearest &
+ (this,V,H,kmx)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind), intent(in):: kmx
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ end subroutine
+ module subroutine downsending_ens_nearest &
+ (this,H,V,kmx)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind), intent(in):: kmx
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ end subroutine
+ module subroutine upsending_loc_g3 &
+ (this,V,H,Z,km_in,km_4_in,km_16_in)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: km_in,km_4_in,km_16_in
+ real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+ real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z
+ end subroutine
+ module subroutine upsending_loc_g4 &
+ (this,V,H,Z,W,km_in,km_4_in,km_16_in,km_64_in)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in
+ real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V
+ real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H
+ real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z
+ real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: W
+ end subroutine
+ module subroutine downsending_loc_g3 &
+ (this,Z,H,V,km_in,km_4_in,km_16_in)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: km_in,km_4_in,km_16_in
+ real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z
+ real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ end subroutine
+ module subroutine downsending_loc_g4 &
+ (this,W,Z,H,V,km_in,km_4_in,km_16_in,km_64_in)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in
+ real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: W
+ real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z
+ real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ end subroutine
+ module subroutine weighting_helm &
+ (this,V,H)
+ implicit none
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ end subroutine
+ module subroutine weighting &
+ (this,V,H)
+ implicit none
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ end subroutine
+ module subroutine weighting_highest &
+ (this,H)
+ implicit none
+ class (mg_intstate_type),target:: this
+ real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ end subroutine
+ module subroutine weighting_ens &
+ (this,V,H,kmx)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: kmx
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H
+ end subroutine
+ module subroutine weighting_loc_g3 &
+ (this,V,H04,H16,km_in,km_4_in,km_16_in)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: km_in,km_4_in,km_16_in
+ real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04
+ real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16
+ end subroutine
+ module subroutine weighting_loc_g4 &
+ (this,V,H04,H16,H64,km_in,km_4_in,km_16_in,km_64_in)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in
+ real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V
+ real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04
+ real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16
+ real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H64
+ end subroutine
+ module subroutine adjoint &
+ (this,F,W,km_in,g)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: g
+ integer(i_kind),intent(in):: km_in
+ real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F
+ real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W
+ end subroutine
+ module subroutine direct1 &
+ (this,W,F,km_in,g)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: g
+ integer(i_kind),intent(in):: km_in
+ real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W
+ real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F
+ end subroutine
+ module subroutine adjoint2 &
+ (this,F,W,km_in,g)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: g
+ integer(i_kind),intent(in):: km_in
+ real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F
+ real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(out):: W
+ end subroutine
+ module subroutine direct2 &
+ (this,W,F,km_in,g)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: g
+ integer(i_kind),intent(in):: km_in
+ real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(in):: W
+ real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F
+ end subroutine
+ module subroutine adjoint_nearest &
+ (this,F,W,km_in,g)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: g
+ integer(i_kind),intent(in):: km_in
+ real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F
+ real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W
+ end subroutine
+ module subroutine direct_nearest &
+ (this,W,F,km_in,g)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: g
+ integer(i_kind),intent(in):: km_in
+ real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W
+ real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F
+ end subroutine
+ module subroutine adjoint_highest &
+ (this,F,W,km_in,g)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: g
+ integer(i_kind),intent(in):: km_in
+ real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(in):: F
+ real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(out):: W
+ end subroutine
+ module subroutine direct_highest &
+ (this,W,F,km_in,g)
+ implicit none
+ class (mg_intstate_type),target:: this
+ integer(i_kind),intent(in):: g
+ integer(i_kind),intent(in):: km_in
+ real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(in):: W
+ real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(out):: F
+ end subroutine
+!from mg_filtering
+ module subroutine filtering_procedure(this,mg_filt,mg_filt_flag)
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: mg_filt
+ integer(i_kind),intent(in):: mg_filt_flag
+ end subroutine
+ module subroutine filtering_rad3(this)
+ class(mg_intstate_type),target::this
+ end subroutine
+ module subroutine filtering_lin3(this)
+ class(mg_intstate_type),target::this
+ end subroutine
+ module subroutine filtering_rad2_bkg(this)
+ class(mg_intstate_type),target::this
+ end subroutine
+ module subroutine filtering_lin2_bkg(this)
+ class(mg_intstate_type),target::this
+ end subroutine
+ module subroutine filtering_fast_bkg(this)
+ class(mg_intstate_type),target::this
+ end subroutine
+ module subroutine filtering_rad2_ens(this,mg_filt_flag)
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: mg_filt_flag
+ end subroutine
+ module subroutine filtering_lin2_ens(this,mg_filt_flag)
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: mg_filt_flag
+ end subroutine
+ module subroutine filtering_fast_ens(this,mg_filt_flag)
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: mg_filt_flag
+ end subroutine
+ module subroutine filtering_rad_highest(this)
+ class(mg_intstate_type),target::this
+ end subroutine
+ module subroutine sup_vrbeta1 &
+ (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm
+ real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V
+ real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+ real(r_kind),dimension(1:lm), intent(in):: ss
+ end subroutine
+ module subroutine sup_vrbeta1T &
+ (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V)
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm
+ real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V
+ real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+ real(r_kind),dimension(1:lm), intent(in):: ss
+ end subroutine
+ module subroutine sup_vrbeta3 &
+ (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V)
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm
+ real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V
+ real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp
+ real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss
+ end subroutine
+ module subroutine sup_vrbeta3T &
+ (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss,V)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm
+ real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V
+ real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp
+ real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss
+ end subroutine
+ module subroutine sup_vrbeta1_ens &
+ (this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm
+ real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL
+ real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+ real(r_kind),dimension(1:lm), intent(in):: ss
+ end subroutine
+ module subroutine sup_vrbeta1T_ens &
+ (this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm
+ real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL
+ real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+ real(r_kind),dimension(1:lm), intent(in):: ss
+ end subroutine
+ module subroutine sup_vrbeta1_bkg &
+ (this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm
+ real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL
+ real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+ real(r_kind),dimension(1:lm), intent(in):: ss
+ end subroutine
+ module subroutine sup_vrbeta1T_bkg &
+ (this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL)
+ implicit none
+ class(mg_intstate_type),target::this
+ integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm
+ real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL
+ real(r_kind),dimension(1,1,1:lm), intent(in):: pasp
+ real(r_kind),dimension(1:lm), intent(in):: ss
+ end subroutine
+!from mg_transfer.f90
+ module subroutine anal_to_filt_allmap(this,WORKA)
+ class(mg_intstate_type),target::this
+ real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+ end subroutine
+ module subroutine filt_to_anal_allmap(this,WORKA)
+ class(mg_intstate_type),target::this
+ real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+ end subroutine
+ module subroutine anal_to_filt_all(this,WORKA)
+ class(mg_intstate_type),target::this
+ real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+ end subroutine
+ module subroutine filt_to_anal_all(this,WORKA)
+ class(mg_intstate_type),target::this
+ real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+ end subroutine
+ module subroutine anal_to_filt_all2(this,WORKA)
+ class(mg_intstate_type),target::this
+ real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+ end subroutine
+ module subroutine filt_to_anal_all2(this,WORKA)
+ class(mg_intstate_type),target::this
+ real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+ end subroutine
+ module subroutine stack_to_composite(this,ARR_ALL,A2D,A3D)
+ class(mg_intstate_type),target::this
+ real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: ARR_ALL
+ real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(out):: A3D
+ real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy) ,intent(out):: A2D
+ end subroutine
+ module subroutine composite_to_stack(this,A2D,A3D,ARR_ALL)
+ class(mg_intstate_type),target::this
+ real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: A2D
+ real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(in):: A3D
+ real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(out):: ARR_ALL
+ end subroutine
+ module subroutine S2C_ens(this,ARR_ALL,A3D,imn,imx,jmn,jmx,lmx,kmx,kmx_all)
+ class(mg_intstate_type),target::this
+ integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all
+ real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(in):: ARR_ALL
+ real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(out):: A3D
+ end subroutine
+ module subroutine C2S_ens(this,A3D,ARR_ALL,imn,imx,jmn,jmx,lmx,kmx,kmx_all)
+ class(mg_intstate_type),target::this
+ integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all
+ real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(in):: A3D
+ real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(out):: ARR_ALL
+ end subroutine
+ module subroutine anal_to_filt(this,WORK)
+ class(mg_intstate_type),target::this
+ real (r_kind):: WORK(this%km_all,1:this%nm,1:this%mm)
+ end subroutine
+ module subroutine filt_to_anal(this,WORK)
+ class(mg_intstate_type),target::this
+ real (r_kind):: WORK(this%km_all,1:this%nm,1:this%mm)
+ end subroutine
+!from mg_entrymod.f90
+ module subroutine mg_initialize(this,inputfilename,obj_parameter)
+ class (mg_intstate_type):: this
+ character*(*),optional,intent(in) :: inputfilename
+ class(mg_parameter_type),optional,intent(in)::obj_parameter
+ end subroutine
+ module subroutine mg_finalize(this)
+ implicit none
+ class (mg_intstate_type)::this
+ end subroutine
+end interface
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+contains
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+subroutine allocate_mg_intstate(this)
+!***********************************************************************
+! !
+! Allocate internal state variables !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+
+if(this%l_loc) then
+ allocate(this%w1_loc(this%km_all ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w1_loc=0.
+ allocate(this%w2_loc(this%km_all/4 ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w2_loc=0.
+ allocate(this%w3_loc(this%km_all/16,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w3_loc=0.
+ allocate(this%w4_loc(this%km_all/64,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w4_loc=0.
+endif
+
+allocate(this%V(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm)) ; this%V=0.
+allocate(this%VALL(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%VALL=0.
+allocate(this%HALL(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%HALL=0.
+
+allocate(this%a_diff_f(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%a_diff_f=0.
+allocate(this%a_diff_h(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%a_diff_h=0.
+allocate(this%b_diff_f(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%b_diff_f=0.
+allocate(this%b_diff_h(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%b_diff_h=0.
+
+allocate(this%p_eps(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_eps=0.
+allocate(this%p_del(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_del=0.
+allocate(this%p_sig(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_sig=0.
+allocate(this%p_rho(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_rho=0.
+
+allocate(this%paspx(1,1,1:this%im)) ; this%paspx=0.
+allocate(this%paspy(1,1,1:this%jm)) ; this%paspy=0.
+
+allocate(this%pasp1(1,1,1:this%lm)) ; this%pasp1=0.
+allocate(this%pasp2(2,2,1:this%im,1:this%jm)) ; this%pasp2=0.
+allocate(this%pasp3(3,3,1:this%im,1:this%jm,1:this%lm)) ; this%pasp3=0.
+
+allocate(this%vpasp2(0:2,1:this%im,1:this%jm)) ; this%vpasp2=0.
+allocate(this%hss2(1:this%im,1:this%jm,1:3)) ; this%hss2=0.
+
+allocate(this%vpasp3(1:6,1:this%im,1:this%jm,1:this%lm)) ; this%vpasp3=0.
+allocate(this%hss3(1:this%im,1:this%jm,1:this%lm,1:6)) ; this%hss3=0.
+
+allocate(this%ssx(1:this%im)) ; this%ssx=0.
+allocate(this%ssy(1:this%jm)) ; this%ssy=0.
+allocate(this%ss1(1:this%lm)) ; this%ss1=0.
+allocate(this%ss2(1:this%im,1:this%jm)) ; this%ss2=0.
+allocate(this%ss3(1:this%im,1:this%jm,1:this%lm)) ; this%ss3=0.
+
+allocate(this%dixs(1:this%im,1:this%jm,3)) ; this%dixs=0
+allocate(this%diys(1:this%im,1:this%jm,3)) ; this%diys=0
+
+allocate(this%dixs3(1:this%im,1:this%jm,1:this%lm,6)) ; this%dixs3=0
+allocate(this%diys3(1:this%im,1:this%jm,1:this%lm,6)) ; this%diys3=0
+allocate(this%dizs3(1:this%im,1:this%jm,1:this%lm,6)) ; this%dizs3=0
+
+allocate(this%qcols(0:7,1:this%im,1:this%jm,1:this%lm)) ; this%qcols=0
+
+!
+! for re-decomposition
+!
+
+allocate(this%iref(1:this%nm)) ; this%iref=0
+allocate(this%jref(1:this%mm)) ; this%jref=0
+
+allocate(this%irefq(1:this%nm)) ; this%irefq=0
+allocate(this%jrefq(1:this%mm)) ; this%jrefq=0
+
+allocate(this%irefL(1:this%nm)) ; this%irefL=0
+allocate(this%jrefL(1:this%mm)) ; this%jrefL=0
+
+allocate(this%cx0(1:this%nm)) ; this%cx0=0.
+allocate(this%cx1(1:this%nm)) ; this%cx1=0.
+allocate(this%cx2(1:this%nm)) ; this%cx2=0.
+allocate(this%cx3(1:this%nm)) ; this%cx3=0.
+
+allocate(this%cy0(1:this%mm)) ; this%cy0=0.
+allocate(this%cy1(1:this%mm)) ; this%cy1=0.
+allocate(this%cy2(1:this%mm)) ; this%cy2=0.
+allocate(this%cy3(1:this%mm)) ; this%cy3=0.
+
+allocate(this%qx0(1:this%nm)) ; this%qx0=0.
+allocate(this%qx1(1:this%nm)) ; this%qx1=0.
+allocate(this%qx2(1:this%nm)) ; this%qx2=0.
+
+allocate(this%qy0(1:this%mm)) ; this%qy0=0.
+allocate(this%qy1(1:this%mm)) ; this%qy1=0.
+allocate(this%qy2(1:this%mm)) ; this%qy2=0.
+
+allocate(this%Lx0(1:this%nm)) ; this%Lx0=0.
+allocate(this%Lx1(1:this%nm)) ; this%Lx1=0.
+
+allocate(this%Ly0(1:this%mm)) ; this%Ly0=0.
+allocate(this%Ly1(1:this%mm)) ; this%Ly1=0.
+
+allocate(this%p_coef(4)) ; this%p_coef=0.
+allocate(this%q_coef(4)) ; this%q_coef=0.
+
+allocate(this%a_coef(3)) ; this%a_coef=0.
+allocate(this%b_coef(3)) ; this%b_coef=0.
+
+allocate(this%cf00(1:this%nm,1:this%mm)) ; this%cf00=0.
+allocate(this%cf01(1:this%nm,1:this%mm)) ; this%cf01=0.
+allocate(this%cf02(1:this%nm,1:this%mm)) ; this%cf02=0.
+allocate(this%cf03(1:this%nm,1:this%mm)) ; this%cf03=0.
+allocate(this%cf10(1:this%nm,1:this%mm)) ; this%cf10=0.
+allocate(this%cf11(1:this%nm,1:this%mm)) ; this%cf11=0.
+allocate(this%cf12(1:this%nm,1:this%mm)) ; this%cf12=0.
+allocate(this%cf13(1:this%nm,1:this%mm)) ; this%cf13=0.
+allocate(this%cf20(1:this%nm,1:this%mm)) ; this%cf20=0.
+allocate(this%cf21(1:this%nm,1:this%mm)) ; this%cf21=0.
+allocate(this%cf22(1:this%nm,1:this%mm)) ; this%cf22=0.
+allocate(this%cf23(1:this%nm,1:this%mm)) ; this%cf23=0.
+allocate(this%cf30(1:this%nm,1:this%mm)) ; this%cf30=0.
+allocate(this%cf31(1:this%nm,1:this%mm)) ; this%cf31=0.
+allocate(this%cf32(1:this%nm,1:this%mm)) ; this%cf32=0.
+allocate(this%cf33(1:this%nm,1:this%mm)) ; this%cf33=0.
+
+allocate(this%Lref(1:this%lm_a)) ; this%Lref=0
+allocate(this%Lref_h(1:this%lm)) ; this%Lref_h=0
+
+allocate(this%cvf1(1:this%lm_a)) ; this%cvf1=0.
+allocate(this%cvf2(1:this%lm_a)) ; this%cvf2=0.
+allocate(this%cvf3(1:this%lm_a)) ; this%cvf3=0.
+allocate(this%cvf4(1:this%lm_a)) ; this%cvf4=0.
+
+allocate(this%cvh1(1:this%lm)) ; this%cvh1=0.
+allocate(this%cvh2(1:this%lm)) ; this%cvh2=0.
+allocate(this%cvh3(1:this%lm)) ; this%cvh3=0.
+allocate(this%cvh4(1:this%lm)) ; this%cvh4=0.
+
+!-----------------------------------------------------------------------
+endsubroutine allocate_mg_intstate
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+subroutine def_mg_weights(this)
+!***********************************************************************
+! !
+! Define weights and scales !
+! !
+implicit none
+class (mg_intstate_type),target::this
+!***********************************************************************
+integer(i_kind):: i,j,L
+real(r_kind):: gen_fac
+!-----------------------------------------------------------------------
+
+this%p_eps(:,:)=0.0
+this%p_del(:,:)=0.0
+this%p_sig(:,:)=0.0
+this%p_rho(:,:)=0.0
+
+!--------------------------------------------------------
+!
+! For localization (for now)
+!
+if(this%l_loc) then
+ this%w1_loc(:,:,:)=this%mg_weig1
+ this%w2_loc(:,:,:)=this%mg_weig2
+ this%w3_loc(:,:,:)=this%mg_weig3
+ this%w4_loc(:,:,:)=this%mg_weig4
+endif
+!--------------------------------------------------------
+gen_fac=1.
+this%a_diff_f(:,:,:)=this%mg_weig1
+this%a_diff_h(:,:,:)=this%mg_weig1
+
+this%b_diff_f(:,:,:)=0.
+this%b_diff_h(:,:,:)=0.
+
+select case(this%my_hgen)
+case(2)
+ this%a_diff_h(:,:,:)=this%mg_weig2
+case(3)
+ this%a_diff_h(:,:,:)=this%mg_weig3
+case default
+ this%a_diff_h(:,:,:)=this%mg_weig4
+end select
+
+do L=1,this%lm
+ this%pasp1(1,1,L)=this%pasp01
+enddo
+
+do i=1,this%im
+ this%paspx(1,1,i)=this%pasp02
+enddo
+do j=1,this%jm
+ this%paspy(1,1,j)=this%pasp02
+enddo
+
+do j=1,this%jm
+do i=1,this%im
+ this%pasp2(1,1,i,j)=this%pasp02*(1.+this%p_del(i,j))
+ this%pasp2(2,2,i,j)=this%pasp02*(1.-this%p_del(i,j))
+ this%pasp2(1,2,i,j)=this%pasp02*this%p_eps(i,j)
+ this%pasp2(2,1,i,j)=this%pasp02*this%p_eps(i,j)
+end do
+end do
+
+do L=1,this%lm
+ do j=1,this%jm
+ do i=1,this%im
+ this%pasp3(1,1,i,j,l)=this%pasp03*(1+this%p_del(i,j))
+ this%pasp3(2,2,i,j,l)=this%pasp03
+ this%pasp3(3,3,i,j,l)=this%pasp03*(1-this%p_del(i,j))
+ this%pasp3(1,2,i,j,l)=this%pasp03*this%p_eps(i,j)
+ this%pasp3(2,1,i,j,l)=this%pasp03*this%p_eps(i,j)
+ this%pasp3(2,3,i,j,l)=this%pasp03*this%p_sig(i,j)
+ this%pasp3(3,2,i,j,l)=this%pasp03*this%p_sig(i,j)
+ this%pasp3(1,3,i,j,l)=this%pasp03*this%p_rho(i,j)
+ this%pasp3(3,1,i,j,l)=this%pasp03*this%p_rho(i,j)
+ end do
+ end do
+end do
+
+
+if(.not.this%mgbf_line) then
+ if(this%nxm*this%nym>1) then
+ if(this%l_loc) then
+ if(this%l_vertical_filter) then
+ call this%cholaspect(1,this%lm,this%pasp1)
+ call this%getlinesum(this%hz,1,this%lm,this%pasp1,this%ss1)
+ do L=1,this%lm
+ this%VALL(L,2,1)=1.
+ call this%sup_vrbeta1T_ens(1,0,0,this%hz,1,1,this%lm,this%pasp1,this%ss1,this%VALL(1:this%lm,2,1))
+ call this%sup_vrbeta1_ens(1,0,0,this%hz,1,1,this%lm,this%pasp1,this%ss1,this%VALL(1:this%lm,2,1))
+ this%VALL(L,1,1)=sqrt(this%VALL(L,2,1))
+ this%VALL(1:this%lm,2,1)=0.
+ enddo
+ this%ss1(1:this%lm)=this%ss1(1:this%lm)/this%VALL(1:this%lm,1,1)
+ this%VALL(1:this%lm,1,1)=0.
+ endif
+ call this%cholaspect(1,this%im,1,this%jm,this%pasp2)
+ call this%getlinesum(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2)
+ this%VALL(1,this%im/2,this%jm/2)=1.
+ call this%rbetaT(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2,this%VALL(1,:,:))
+ call this%rbeta(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2,this%VALL(1,:,:))
+ this%ss2=this%ss2/sqrt(this%VALL(1,this%im/2,this%jm/2))
+ this%VALL(1,:,:)=0.
+ call this%cholaspect(1,this%im,this%paspx)
+ call this%getlinesum(this%hx,1,this%im,this%paspx,this%ssx)
+ this%VALL(1,this%im/2,1)=1.
+ call this%rbetaT(this%hx,1,this%im,this%paspx,this%ssx,this%VALL(1,:,1))
+ call this%rbeta(this%hx,1,this%im,this%paspx(1,1,:),this%ssx,this%VALL(1,:,1))
+ this%ssx=this%ssx/sqrt(this%VALL(1,this%im/2,1))
+ this%VALL(1,:,1)=0.
+ call this%cholaspect(1,this%jm,this%paspy)
+ call this%getlinesum(this%hy,1,this%jm,this%paspy,this%ssy)
+ this%VALL(1,1,this%jm/2)=1.
+ call this%rbetaT(this%hy,1,this%jm,this%paspy,this%ssy,this%VALL(1,1,:))
+ call this%rbeta(this%hy,1,this%jm,this%paspy(1,1,:),this%ssy,this%VALL(1,1,:))
+ this%ssy=this%ssy/sqrt(this%VALL(1,1,this%jm/2))
+ this%VALL(1,1,:)=0.
+ else
+ call this%cholaspect(1,this%lm,this%pasp1)
+ call this%cholaspect(1,this%im,1,this%jm,this%pasp2)
+ call this%cholaspect(1,this%im,1,this%jm,1,this%lm,this%pasp3)
+ call this%getlinesum(this%hx,1,this%im,this%paspx,this%ssx)
+ call this%getlinesum(this%hy,1,this%jm,this%paspy,this%ssy)
+ call this%getlinesum(this%hz,1,this%lm,this%pasp1,this%ss1)
+ call this%getlinesum(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2)
+ call this%getlinesum(this%hx,1,this%im,this%hy,1,this%jm,this%hz,1,this%lm,this%pasp3,this%ss3)
+ end if
+ else
+ call this%cholaspect(1,this%imH,1,this%jmH,&
+ &this%pasp2(:,:,1:this%imH,1:this%jmH))
+ call this%getlinesum(this%hx,1,this%imH,this%hy,1,this%jmH,&
+ &this%pasp2(:,:,1:this%imH,1:this%jmH),this%ss2(1:this%imH,1:this%jmH))
+ this%VALL(1,this%imH/2,this%jmH/2)=1.
+ call this%rbetaT(this%hx,1,this%imH,this%hy,1,this%jmH,&
+ &this%pasp2(:,:,1:this%imH,1:this%jmH),this%ss2(1:this%imH,1:this%jmH),&
+ &this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy))
+ call this%rbeta(this%hx,1,this%imH,this%hy,1,this%jmH,&
+ &this%pasp2(:,:,1:this%imH,1:this%jmH),this%ss2(1:this%imH,1:this%jmH),&
+ &this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy))
+ this%ss2=this%ss2/sqrt(this%VALL(1,this%imH/2,this%jmH/2))
+ this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy)=0.
+ end if
+end if
+!-----------------------------------------------------------------------
+endsubroutine def_mg_weights
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+subroutine init_mg_line(this)
+implicit none
+class(mg_intstate_type),target::this
+integer(i_kind):: i,j,L,icol
+logical:: ff
+!***********************************************************************
+! !
+! Inititate line filters !
+! !
+!***********************************************************************
+!-----------------------------------------------------------------------
+
+do j=1,this%jm
+do i=1,this%im
+ call t22_to_3(this%pasp2(:,:,i,j),this%vpasp2(:,i,j))
+enddo
+enddo
+
+do l=1,this%lm
+do j=1,this%jm
+do i=1,this%im
+ call t33_to_6(this%pasp3(:,:,i,j,l),this%vpasp3(:,i,j,l))
+enddo
+enddo
+enddo
+
+call inimomtab(this%p,this%nh,ff)
+
+call tritform(1,this%im,1,this%jm,this%vpasp2, this%dixs,this%diys, ff)
+
+do icol=1,3
+ this%hss2(:,:,icol)=this%vpasp2(icol-1,:,:)
+enddo
+
+call hextform(1,this%im,1,this%jm,1,this%lm,this%vpasp3,this%qcols,this%dixs3,this%diys3,this%dizs3, ff)
+
+do icol=1,6
+ this%hss3(:,:,:,icol)=this%vpasp3(icol,:,:,:)
+enddo
+
+!-----------------------------------------------------------------------
+endsubroutine init_mg_line
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+subroutine deallocate_mg_intstate(this)
+implicit none
+class (mg_intstate_type),target:: this
+!***********************************************************************
+! !
+! Deallocate internal state variables !
+! !
+!***********************************************************************
+
+deallocate(this%V)
+
+deallocate(this%HALL,this%VALL)
+
+deallocate(this%a_diff_f,this%b_diff_f)
+deallocate(this%a_diff_h,this%b_diff_h)
+deallocate(this%p_eps,this%p_del,this%p_sig,this%p_rho,this%pasp1,this%pasp2,this%pasp3,this%ss1,this%ss2,this%ss3)
+deallocate(this%dixs,this%diys)
+deallocate(this%dixs3,this%diys3,this%dizs3)
+deallocate(this%qcols)
+
+!
+! for re-decomposition
+!
+deallocate(this%iref,this%jref)
+deallocate(this%irefq,this%jrefq)
+deallocate(this%irefL,this%jrefL)
+
+deallocate(this%cf00,this%cf01,this%cf02,this%cf03,this%cf10,this%cf11,this%cf12,this%cf13)
+deallocate(this%cf20,this%cf21,this%cf22,this%cf23,this%cf30,this%cf31,this%cf32,this%cf33)
+
+deallocate(this%Lref,this%Lref_h)
+
+deallocate(this%cvf1,this%cvf2,this%cvf3,this%cvf4)
+
+deallocate(this%cvh1,this%cvh2,this%cvh3,this%cvh4)
+
+deallocate(this%cx0,this%cx1,this%cx2,this%cx3)
+deallocate(this%cy0,this%cy1,this%cy2,this%cy3)
+
+deallocate(this%qx0,this%qx1,this%qx2)
+deallocate(this%qy0,this%qy1,this%qy2)
+
+deallocate(this%Lx0,this%Lx1)
+deallocate(this%Ly0,this%Ly1)
+
+deallocate(this%p_coef,this%q_coef)
+deallocate(this%a_coef,this%b_coef)
+
+if(this%l_loc) then
+ deallocate(this%w1_loc,this%w2_loc,this%w3_loc,this%w4_loc)
+endif
+
+end subroutine deallocate_mg_intstate
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+end module mg_intstate
diff --git a/src/mgbf/mg_mppstuff.f90 b/src/mgbf/mg_mppstuff.f90
new file mode 100644
index 0000000000..e1d24b180c
--- /dev/null
+++ b/src/mgbf/mg_mppstuff.f90
@@ -0,0 +1,190 @@
+submodule(mg_parameter) mg_mppstuff
+!$$$ submodule documentation block
+! . . . .
+! module: mg_mppstuff
+! prgmmr: rancic org: NCEP/EMC date: 2020
+!
+! abstract: Everything related to mpi communication
+!
+! module history log:
+! 2023-04-19 lei - object-oriented coding
+! 2024-01-11 rancic - optimization for ensemble localization
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! init_mg_MPI -
+! barrierMPI -
+! finishMPI -
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use kinds, only: i_kind
+implicit none
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+contains
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine init_mg_MPI(this)
+!***********************************************************************
+! !
+! Initialize mpi !
+! Create group for filter grid !
+! !
+!***********************************************************************
+use mpi
+
+implicit none
+class (mg_parameter_type),target:: this
+integer(i_kind):: g,m
+integer(i_kind), dimension(this%npes_filt):: out_ranks
+integer(i_kind):: nf
+integer(i_kind)::ierr
+integer(i_kind):: color
+include "type_parameter_locpointer.inc"
+include "type_parameter_point2this.inc"
+!-----------------------------------------------------------------------
+
+!***
+!*** Initial MPI calls
+!***
+ call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr)
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,npes,ierr)
+! call MPI_Barrier(MPI_COMM_WORLD, ierr)
+
+ ! Create a new communicator with MPI_Comm_split
+ color=1 ! just create an communicator now for the whole processes
+ call MPI_Comm_split(MPI_COMM_WORLD, color, mype, mpi_comm_comp, ierr)
+ call MPI_COMM_SIZE(mpi_comm_comp,npes,ierr)
+
+ rTYPE = MPI_REAL
+ dTYPE = MPI_DOUBLE
+ iTYPE = MPI_INTEGER
+
+!***
+!*** Analysis grid
+!***
+
+ nx = mod(mype,nxm)+1
+ my = (mype/nxm)+1
+
+!***
+!*** Define PEs that handle high generations
+!***
+
+ mype_hgen=-1
+ my_hgen=-1
+
+ if( mype < maxpe_filt-nxy(1)) then
+ mype_hgen=mype+nxy(1)
+ endif
+ do g=1,gm
+ if(maxpe_fgen(g-1)<= mype_hgen .and. mype_hgen< maxpe_fgen(g)) then
+ my_hgen=g
+ endif
+ enddo
+ l_hgen = mype_hgen >-1
+
+!***
+!*** Chars
+!***
+ write(c_mype,1000) mype
+ 1000 format(i5.5)
+
+!-----------------------------------------------------------------------
+!
+ call MPI_BARRIER(mpi_comm_comp,ierr)
+!
+!-----------------------------------------------------------------------
+!***
+!*** Define group communicator for higher generations
+!***
+!
+! Associate a group with communicator this@mpi_comm_comp
+!
+ call MPI_COMM_GROUP(mpi_comm_comp,group_world,ierr)
+!
+! Create a new group out of exising group
+!
+ do nf = 1,npes_filt
+ out_ranks(nf)=nf-1
+ enddo
+
+ call MPI_GROUP_INCL(group_world,npes_filt,out_ranks,group_work,ierr)
+!
+! Now create a new communicator associated with new group
+!
+ call MPI_COMM_CREATE(mpi_comm_comp, group_work, mpi_comm_work, ierr)
+
+ if( mype < npes_filt) then
+
+ call MPI_COMM_RANK(mpi_comm_work,mype_gr,ierr)
+ call MPI_COMM_SIZE(mpi_comm_work,npes_gr,ierr)
+
+ else
+
+ mype_gr= -1
+ npes_gr= npes_filt
+
+ endif
+
+!-----------------------------------------------------------------------
+!
+ call MPI_BARRIER(mpi_comm_comp,ierr)
+!
+!-----------------------------------------------------------------------
+endsubroutine init_mg_MPI
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine barrierMPI(this)
+!***********************************************************************
+! !
+! Call barrier for all !
+! !
+!***********************************************************************
+use mpi
+
+implicit none
+class(mg_parameter_type),target::this
+integer(i_kind):: ierr
+include "type_parameter_locpointer.inc"
+include "type_parameter_point2this.inc"
+!-----------------------------------------------------------------------
+
+ call MPI_BARRIER(mpi_comm_comp,ierr)
+
+!-----------------------------------------------------------------------
+endsubroutine barrierMPI
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine finishMPI(this)
+!***********************************************************************
+! !
+! Finalize MPI !
+! !
+!***********************************************************************
+use mpi
+
+implicit none
+class(mg_parameter_type),target::this
+!
+! don't need mpi_finalize if mgbf is a lib to be called from outside
+!
+ call MPI_FINALIZE(this%ierr)
+ stop
+!
+!-----------------------------------------------------------------------
+endsubroutine finishMPI
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+end submodule mg_mppstuff
+
diff --git a/src/mgbf/mg_parameter.f90 b/src/mgbf/mg_parameter.f90
new file mode 100644
index 0000000000..f08b87aab3
--- /dev/null
+++ b/src/mgbf/mg_parameter.f90
@@ -0,0 +1,936 @@
+module mg_parameter
+!$$$ submodule documentation block
+! . . . .
+! module: mg_parameter
+! prgmmr: rancic org: NCEP/EMC date: 2022
+!
+! abstract: Set resolution, grid and decomposition (offset version)
+!
+! module history log:
+! 2023-04-19 lei - object-oriented coding
+! 2024-01-11 rancic - optimization for ensemble localization
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! init_mg_parameter -
+! def_maxgen -
+! def_ngens -
+!
+! Functions Included:
+!
+! remarks:
+! ixm(1)=nxm, jym(1)=nym
+! If mod(nxm,2)=0 then mod(im0,2)=0
+! If mod(nxm,2)>0 then mod(im0,8)=0 (for 4 generations)
+! (This will keep the right boundary of all decompmisitions
+! at same physical location)
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use kinds, only: i_kind,r_kind
+use jp_pietc, only: u1
+
+implicit none
+type:: mg_parameter_type
+!-----------------------------------------------------------------------
+!***
+!*** Namelist parameters
+!***
+real(r_kind):: mg_ampl01,mg_ampl02,mg_ampl03
+real(r_kind):: mg_weig1,mg_weig2,mg_weig3,mg_weig4
+integer(i_kind):: mgbf_proc !1-2: 3D filter (1: radial, 2: line)
+ !3-5: 2D filter for static B (3: radial, 4: line, 5: isotropic line)
+ !6-8: 2D filter for localization (6: radial, 7: line, 8: isotropic line)
+logical:: mgbf_line
+integer(i_kind):: nxPE,nyPE,im_filt,jm_filt
+logical:: lquart,lhelm
+
+!***
+!*** Number of generations
+!***
+integer(i_kind):: gm
+integer(i_kind):: gm_max
+
+!***
+!*** Horizontal resolution
+!***
+
+!
+! Original number of data on GSI analysis grid
+!
+integer(i_kind):: nA_max0
+integer(i_kind):: mA_max0
+
+!
+! Global number of data on Analysis grid
+!
+integer(i_kind):: nm0
+integer(i_kind):: mm0
+
+!
+! Number of PEs on Analysis grid
+!
+integer(i_kind):: nxm
+integer(i_kind):: nym
+
+!
+! Number of data on local Analysis grid
+!
+integer(i_kind):: nm
+integer(i_kind):: mm
+
+!
+! Number of data on global Filter grid
+!
+integer(i_kind):: im00
+integer(i_kind):: jm00
+
+!
+! Number of data on local Filter grid
+!
+integer(i_kind):: im
+integer(i_kind):: jm
+
+!
+! Initial index on local Filter grid
+!
+integer(i_kind):: i0
+integer(i_kind):: j0
+!
+! Initial index on local analysis grid
+!
+integer(i_kind):: n0
+integer(i_kind):: m0
+
+!
+! Halo on local Filter grid
+!
+integer(i_kind):: ib
+integer(i_kind):: jb
+
+!
+! Halo on local Analysis grid
+!
+integer(i_kind):: nb
+integer(i_kind):: mb
+
+integer(i_kind):: hx,hy,hz
+integer(i_kind):: p
+integer(i_kind):: nh,nfil
+real(r_kind):: pasp01,pasp02,pasp03
+real(r_kind):: pee2,rmom2_1,rmom2_2,rmom2_3,rmom2_4
+
+integer, allocatable, dimension(:):: maxpe_fgen
+integer, allocatable, dimension(:):: ixm,jym,nxy
+integer, allocatable, dimension(:):: im0,jm0
+integer, allocatable, dimension(:):: Fimax,Fjmax
+integer, allocatable, dimension(:):: FimaxL,FjmaxL
+
+integer(i_kind):: npes_filt
+integer(i_kind):: maxpe_filt
+
+integer(i_kind):: imL,jmL
+integer(i_kind):: imH,jmH
+integer(i_kind):: lm_a ! number of vertical layers in analysis fields
+integer(i_kind):: lm ! number of vertical layers in filter grids
+integer(i_kind):: km2 ! number of 2d variables for filtering
+integer(i_kind):: km3 ! number of 3d variables for filtering
+integer(i_kind):: n_ens ! number of ensemble members
+integer(i_kind):: km_a ! total number of horizontal levels for analysis
+integer(i_kind):: km_all ! total number of k levels of ensemble for filtering
+integer(i_kind):: km_a_all ! total number of k levels of ensemble
+integer(i_kind):: km2_all ! total number of k horizontal levels of ensemble for filtering
+integer(i_kind):: km3_all ! total number of k vertical levels of ensemble
+logical :: l_loc ! logical flag for localization
+logical :: l_filt_g1 ! logical flag for filtering of generation one
+logical :: l_lin_vertical ! logical flag for linear interpolation in vertcial
+logical :: l_lin_horizontal ! logical flag for linear interpolation in horizontal
+logical :: l_quad_horizontal ! logical flag for quadratic interpolation in horizontal
+logical :: l_new_map ! logical flag for new mapping between analysis and filter grid
+logical :: l_vertical_filter ! logical flag for vertical filtering
+integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3)
+integer(i_kind):: km_4
+integer(i_kind):: km_16
+integer(i_kind):: km_64
+
+real(r_kind):: lengthx,lengthy,xa0,ya0,xf0,yf0
+real(r_kind):: dxf,dyf,dxa,dya
+
+integer(i_kind):: npadx ! x padding on analysis grid
+integer(i_kind):: mpady ! y padding on analysis grid
+
+integer(i_kind):: ipadx ! x padding on filter decomposition
+integer(i_kind):: jpady ! y padding on filter deocmposition
+
+!
+! Just for standalone test
+!
+logical:: ldelta
+
+!from mg_mppstuff.f90
+character(len=5):: c_mype
+integer(i_kind):: mype
+integer(i_kind):: npes,iTYPE,rTYPE,dTYPE,mpi_comm_comp,ierr,ierror
+integer(i_kind):: mpi_comm_work,group_world,group_work
+integer(i_kind):: mype_gr,npes_gr
+integer(i_kind):: my_hgen
+integer(i_kind):: mype_hgen
+logical:: l_hgen
+integer(i_kind):: nx,my
+!from mg_domain.f90
+logical,dimension(2):: Flwest,Fleast,Flnorth,Flsouth
+integer(i_kind),dimension(2):: Fitarg_n,Fitarg_e,Fitarg_s,Fitarg_w
+integer(i_kind),dimension(2):: Fitarg_sw,Fitarg_se,Fitarg_ne,Fitarg_nw
+logical,dimension(2):: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne
+integer(i_kind),dimension(2):: Fitarg_up
+integer(i_kind):: itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw
+integer(i_kind):: itarg_wA,itarg_eA,itarg_sA,itarg_nA
+logical:: lwestA,leastA,lsouthA,lnorthA
+integer(i_kind):: ix,jy
+integer(i_kind),dimension(2):: mype_filt
+!from mg_domain_loc.f90
+integer(i_kind):: nsq21,nsq32,nsq43
+logical,dimension(4):: Flsouth_loc,Flnorth_loc,Flwest_loc,Fleast_loc
+integer(i_kind),dimension(4):: Fitarg_s_loc,Fitarg_n_loc,Fitarg_w_loc,Fitarg_e_loc
+integer(i_kind),dimension(4):: Fitargup_loc12
+integer(i_kind),dimension(4):: Fitargup_loc23
+integer(i_kind),dimension(4):: Fitargup_loc34
+integer(i_kind):: itargdn_sw_loc21,itargdn_se_loc21,itargdn_nw_loc21,itargdn_ne_loc21
+integer(i_kind):: itargdn_sw_loc32,itargdn_se_loc32,itargdn_nw_loc32,itargdn_ne_loc32
+integer(i_kind):: itargdn_sw_loc43,itargdn_se_loc43,itargdn_nw_loc43,itargdn_ne_loc43
+logical:: lsendup_sw_loc,lsendup_se_loc,lsendup_nw_loc,lsendup_ne_loc
+
+contains
+ procedure :: init_mg_parameter
+!from mg_mppstuff.f90
+ procedure :: init_mg_MPI
+ procedure :: finishMPI
+ procedure :: barrierMPI
+!from mg_domain.f90
+ procedure :: init_mg_domain
+ procedure :: init_domain
+ procedure :: init_topology_2d
+ procedure :: real_itarg
+!from mg_domain_loc.f90
+ procedure :: init_domain_loc
+ procedure :: sidesend_loc
+ procedure :: targup_loc
+ procedure :: targdn21_loc
+ procedure :: targdn32_loc
+ procedure :: targdn43_loc
+!from jp_pbfil.f90
+ generic :: cholaspect => cholaspect1,cholaspect2,cholaspect3,cholaspect4
+ procedure,nopass :: cholaspect1,cholaspect2,cholaspect3,cholaspect4
+ generic :: getlinesum => getlinesum1,getlinesum2,getlinesum3
+ procedure :: getlinesum1,getlinesum2,getlinesum3
+ generic :: rbeta => rbeta1,rbeta2,rbeta3,rbeta4,vrbeta1,vrbeta2,vrbeta3,vrbeta4
+ procedure:: rbeta1,rbeta2,rbeta3,rbeta4,vrbeta1,vrbeta2,vrbeta3,vrbeta4
+ generic :: rbetaT => rbeta1t,rbeta2t,rbeta3t,rbeta4t,vrbeta1t,vrbeta2t,vrbeta3t,vrbeta4t
+ procedure:: rbeta1t,rbeta2t,rbeta3t,rbeta4t,vrbeta1t,vrbeta2t,vrbeta3t,vrbeta4t
+end type mg_parameter_type
+
+interface
+!from mg_mppstuff.f90
+ module subroutine init_mg_MPI(this)
+ class(mg_parameter_type),target :: this
+ end subroutine
+ module subroutine finishMPI(this)
+ class(mg_parameter_type),target :: this
+ end subroutine
+ module subroutine barrierMPI(this)
+ class(mg_parameter_type),target :: this
+ end subroutine
+!from mg_domain.f90
+ module subroutine init_mg_domain(this)
+ class(mg_parameter_type)::this
+ end subroutine
+ module subroutine init_domain(this)
+ class(mg_parameter_type),target::this
+ end subroutine
+ module subroutine init_topology_2d(this)
+ class(mg_parameter_type),target::this
+ end subroutine
+ module subroutine real_itarg (this,itarg)
+ class(mg_parameter_type),target::this
+ integer(i_kind), intent(inout):: itarg
+ end subroutine
+!from mg_domain_loc.f90
+ module subroutine init_domain_loc(this)
+ class(mg_parameter_type)::this
+ end subroutine
+ module subroutine sidesend_loc(this)
+ class(mg_parameter_type),target::this
+ end subroutine
+ module subroutine targup_loc(this)
+ class(mg_parameter_type),target::this
+ end subroutine
+ module subroutine targdn21_loc(this)
+ class(mg_parameter_type),target::this
+ end subroutine
+ module subroutine targdn32_loc(this)
+ class(mg_parameter_type),target::this
+ end subroutine
+ module subroutine targdn43_loc(this)
+ class(mg_parameter_type),target::this
+ end subroutine
+!from jp_pbfil.f90
+ module subroutine cholaspect1(lx,mx, el)
+ use kinds, only: dp=>r_kind
+ integer, intent(in ):: lx,mx
+ real(dp),dimension(1,1,lx:mx),intent(inout):: el
+ end subroutine
+ module subroutine cholaspect2(lx,mx, ly,my, el)
+ use kinds, only: dp=>r_kind
+ integer, intent(in ):: lx,mx, ly,my
+ real(dp),dimension(2,2,lx:mx,ly:my),intent(inout):: el
+ real(dp),dimension(2,2):: tel
+ end subroutine
+ module subroutine cholaspect3(lx,mx, ly,my, lz,mz, el)
+ use kinds, only: dp=>r_kind
+ integer, intent(in ):: lx,mx, ly,my, lz,mz
+ real(dp),dimension(3,3,lx:mx,ly:my,lz:mz),intent(inout):: el
+ real(dp),dimension(3,3):: tel
+ end subroutine
+ module subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el)
+ use kinds, only: dp=>r_kind
+ integer, intent(in ):: lx,mx, ly,my, lz,mz, lw,mw
+ real(dp),dimension(4,4,lx:mx,ly:my,lz:mz,lw:mw),intent(inout):: el
+ real(dp),dimension(4,4):: tel
+ end subroutine
+ module subroutine getlinesum1(this,hx,lx,mx, el, ss)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx
+ real(dp),dimension(1,1,Lx:Mx),intent(in ):: el
+ real(dp),dimension( lx:mx),intent( out):: ss
+ end subroutine
+ module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx, hy,ly,my
+ real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el
+ real(dp),dimension( lx:mx,ly:my),intent( out):: ss
+ end subroutine
+ module subroutine getlinesum3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz
+ real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el
+ real(dp),dimension( lx:mx,ly:my,lz:mz),intent( out):: ss
+ end subroutine
+ module subroutine getlinesum4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el, ss)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw
+ real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el
+ real(dp),dimension( lx:mx,ly:my,lz:mz,Lw:Mw),intent( out):: ss
+ end subroutine
+ module subroutine rbeta1(this,hx,lx,mx, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx
+ real(dp),dimension(Lx:Mx),intent(in ):: el
+ real(dp),dimension(Lx:Mx),intent(in ):: ss
+ real(dp),dimension(lx-hx:mx+hx),intent(inout):: a
+ end subroutine
+ module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx, hy,ly,my
+ real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss
+ real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a
+ end subroutine
+ module subroutine rbeta3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz
+ real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss
+ real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a
+ end subroutine
+ module subroutine rbeta4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw
+ real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss
+ real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a
+ end subroutine
+ module subroutine rbeta1T(this,hx,lx,mx, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx
+ real(dp),dimension(1,1,Lx:Mx),intent(in ):: el
+ real(dp),dimension( Lx:Mx),intent(in ):: ss
+ real(dp),dimension(lx-hx:mx+hx),intent(inout):: a
+ end subroutine
+ module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx, hy,ly,my
+ real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss
+ real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a
+ end subroutine
+ module subroutine rbeta3T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz
+ real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss
+ real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a
+ end subroutine
+ module subroutine rbeta4T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw
+ real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss
+ real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a
+ end subroutine
+ module subroutine vrbeta1(this,nv,hx,lx,mx, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: nv,hx,Lx,mx
+ real(dp),dimension(1,1,Lx:Mx),intent(in ):: el
+ real(dp),dimension( Lx:Mx),intent(in ):: ss
+ real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a
+ end subroutine
+ module subroutine vrbeta2(this,nv,hx,lx,mx, hy,ly,my, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my
+ real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss
+ real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a
+ end subroutine
+ module subroutine vrbeta3(this,nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz
+ real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss
+ real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a
+ end subroutine
+ module subroutine vrbeta4(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw
+ real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss
+ real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a
+ end subroutine
+ module subroutine vrbeta1T(this,nv, hx,lx,mx, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: nv,hx,Lx,mx
+ real(dp),dimension(1,1,Lx:Mx),intent(in ):: el
+ real(dp),dimension( Lx:Mx),intent(in ):: ss
+ real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a
+ end subroutine
+ module subroutine vrbeta2T(this,nv,hx,lx,mx, hy,ly,my, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my
+ real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss
+ real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a
+ end subroutine
+ module subroutine vrbeta3T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz
+ real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss
+ real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a
+ end subroutine
+ module subroutine vrbeta4T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss, a)
+ use kinds, only: dp=>r_kind
+ class(mg_parameter_type)::this
+ integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw
+ real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el
+ real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss
+ real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a
+ end subroutine
+end interface
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+contains
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+subroutine init_mg_parameter(this,inputfilename)
+!**********************************************************************!
+! !
+! Initialize .... !
+! !
+!**********************************************************************!
+implicit none
+class (mg_parameter_type),target:: this
+integer(i_kind):: g
+character(*):: inputfilename
+
+! Namelist parameters as local variable
+real(r_kind):: mg_ampl01,mg_ampl02,mg_ampl03
+real(r_kind):: mg_weig1,mg_weig2,mg_weig3,mg_weig4
+integer(i_kind):: mgbf_proc
+logical:: mgbf_line
+integer(i_kind):: nxPE,nyPE,im_filt,jm_filt
+logical:: lquart,lhelm
+logical:: ldelta
+
+integer(i_kind):: lm_a ! number of vertical layers in analysis fields
+integer(i_kind):: lm ! number of vertical layers in filter grids
+integer(i_kind):: km2 ! number of 2d variables for filtering
+integer(i_kind):: km3 ! number of 3d variables for filtering
+integer(i_kind):: n_ens ! number of ensemble members
+logical :: l_loc ! logical flag for localization
+logical :: l_filt_g1 ! logical flag for filtering of generation one
+logical :: l_lin_vertical ! logical flag for linear interpolation in vertcial
+logical :: l_lin_horizontal ! logical flag for linear interpolation in horizontal
+logical :: l_quad_horizontal ! logical flag for quadratic interpolation in horizontal
+logical :: l_new_map ! logical flag for new mapping between analysis and filter grid
+logical :: l_vertical_filter ! logical flag for vertical filtering
+integer(i_kind):: gm_max
+
+! Global number of data on Analysis grid
+integer(i_kind):: nm0
+integer(i_kind):: mm0
+
+integer(i_kind):: hx,hy,hz
+integer(i_kind):: p
+
+ namelist /parameters_mgbeta/ mg_ampl01,mg_ampl02,mg_ampl03 &
+ ,mg_weig1,mg_weig2,mg_weig3,mg_weig4 &
+ ,hx,hy,hz,p &
+ ,mgbf_line,mgbf_proc &
+ ,lm_a,lm &
+ ,km2,km3 &
+ ,n_ens &
+ ,l_loc &
+ ,l_filt_g1 &
+ ,l_lin_vertical &
+ ,l_lin_horizontal &
+ ,l_quad_horizontal &
+ ,l_new_map &
+ ,l_vertical_filter &
+ ,ldelta,lquart,lhelm &
+ ,gm_max &
+ ,nm0,mm0 &
+ ,nxPE,nyPE,im_filt,jm_filt
+!
+ open(unit=10,file=inputfilename,status='old',action='read')
+ read(10,nml=parameters_mgbeta)
+ close(unit=10)
+!
+!-----------------------------------------------------------------
+!for safety, copy all namelist loc vars to them of this object
+ this%mg_ampl01=mg_ampl01
+ this%mg_ampl02=mg_ampl02
+ this%mg_ampl03=mg_ampl03
+ this%mg_weig1=mg_weig1
+ this%mg_weig2=mg_weig2
+ this%mg_weig3=mg_weig3
+ this%mg_weig4=mg_weig4
+ this%hx=hx
+ this%hy=hy
+ this%hz=hz
+ this%p =p
+ this%mgbf_line=mgbf_line
+ this%mgbf_proc=mgbf_proc
+ this%lm_a=lm_a
+ this%lm=lm
+ this%km2=km2
+ this%km3=km3
+ this%n_ens=n_ens
+ this%l_loc=l_loc
+ this%l_filt_g1=l_filt_g1
+ this%l_lin_vertical=l_lin_vertical
+ this%l_lin_horizontal=l_lin_horizontal
+ this%l_quad_horizontal=l_quad_horizontal
+ this%l_new_map=l_new_map
+ this%l_vertical_filter=l_vertical_filter
+ this%ldelta=ldelta
+ this%lquart=lquart
+ this%lhelm=lhelm
+ this%nm0=nm0
+ this%mm0=mm0
+ this%nxPE=nxPE
+ this%nyPE=nyPE
+ this%im_filt=im_filt
+ this%jm_filt=jm_filt
+
+ this%nxm = nxPE
+ this%nym = nyPE
+
+ this%im = im_filt
+ this%jm = jm_filt
+
+!-----------------------------------------------------------------
+!
+!
+! For 168 PES
+!
+! nxm = 14
+! nym = 12
+!
+! For 256 PES
+!
+! nxm = 16
+! nym = 16
+!
+! For 336 PES
+!
+! nxm = 28
+! nym = 12
+!
+! For 448 PES
+!
+! nxm = 28
+! nym = 16
+!
+! For 512 PES
+!
+! nxm = 32
+! nym = 16
+!
+! For 704 PES
+!
+! nxm = 32
+! nym = 22
+!
+! For 768 PES
+!
+! nxm = 32
+! nym = 24
+!
+! For 924 PES
+!
+! nxm = 28
+! nym = 33
+!
+! For 1056 PES
+!
+! nxm = 32
+! nym = 33
+!
+! For 1408 PES
+!
+! nxm = 32
+! nym = 44
+!
+! For 1848 PES
+!
+! nxm = 56
+! nym = 33
+!
+! For 2464 PES
+!
+! nxm = 56
+! nym = 44
+
+!
+! Define total number of horizontal levels in the case of ensemble
+!
+
+ this%km_a = this%km2+this%lm_a*this%km3
+ this%km = this%km2+this%lm *this%km3
+
+ this%km_a_all = this%km_a * this%n_ens
+ this%km_all = this%km * this%n_ens
+
+ this%km2_all = this%km2 * this%n_ens
+ this%km3_all = this%km3 * this%n_ens
+
+ this%km_4 = this%km/4
+ this%km_16 = this%km/16
+ this%km_64 = this%km/64
+
+!
+! Define maximum number of generations 'gm'
+!
+
+ call def_maxgen(this%nxm,this%nym,this%gm)
+
+! Restrict to gm_max
+
+ if(this%gm>gm_max) then
+ this%gm=gm_max
+ endif
+ if(this%nxm*this%nym<=1) then
+ this%gm=gm_max
+ endif
+
+!***
+!*** Analysis grid
+!***
+
+!
+! Number of grid intervals on GSI grid for the reduced RTMA domain
+! before padding
+!
+ this%nA_max0 = 1792
+ this%mA_max0 = 1056
+
+!
+! Number of grid points on the analysis grid after padding
+!
+
+ this%nm = this%nm0/this%nxm
+ this%mm = this%mm0/this%nym
+
+!***
+!*** Filter grid
+!***
+
+! im = nm
+! jm = mm
+
+!
+! For 168 PES
+!
+! im = 120
+! jm = 80
+!
+! For 256 PES
+!
+! im = 96
+! jm = 64
+!
+! im = 88
+! jm = 56
+!
+! For 336 PES
+!
+! im = 56
+! jm = 80
+!
+! For 448 PES
+!
+! im = 56
+! jm = 64
+!
+! For 512 PES
+!
+! im = 48
+! jm = 64
+!
+! For 704 PES
+!
+! im = 48
+! jm = 40
+!
+! For 768 PES
+!
+! im = 48
+! jm = 40
+!
+! For 924 PES
+!
+! im = 56
+! jm = 24
+!
+! For 1056 PES
+!
+! im = 48
+! jm = 24
+!
+! For 1408 PES
+!
+! im = 48
+! jm = 20
+!
+! For 1848 PES
+!
+! im = 28
+! jm = 24
+!
+! For 2464 PES
+!
+! im = 28
+! jm = 20
+
+ this%im00 = this%nxm*this%im
+ this%jm00 = this%nym*this%jm
+
+ this%n0 = 1
+ this%m0 = 1
+
+ this%i0 = 1
+ this%j0 = 1
+
+!
+! Make sure that nm0 and mm0 and divisibvle with nxm and nym
+!
+ if(this%nm*this%nxm /= this%nm0 ) then
+ write(17,*) 'nm,nxm,nm0=',this%nm,this%nxm,this%nm0
+ stop 'nm0 is not divisible by nxm'
+ endif
+
+ if(this%mm*this%nym /= this%mm0 ) then
+ write(17,*) 'mm,nym,mm0=',this%mm,this%nym,this%mm0
+ stop 'mm0 is not divisible by nym'
+ endif
+
+!
+! Set number of processors at higher generations
+!
+
+ allocate(this%ixm(this%gm))
+ allocate(this%jym(this%gm))
+ allocate(this%nxy(this%gm))
+ allocate(this%maxpe_fgen(0:this%gm))
+ allocate(this%im0(this%gm))
+ allocate(this%jm0(this%gm))
+ allocate(this%Fimax(this%gm))
+ allocate(this%Fjmax(this%gm))
+ allocate(this%FimaxL(this%gm))
+ allocate(this%FjmaxL(this%gm))
+
+ call def_ngens(this%ixm,this%gm,this%nxm)
+ call def_ngens(this%jym,this%gm,this%nym)
+
+ do g=1,this%gm
+ this%nxy(g)=this%ixm(g)*this%jym(g)
+ enddo
+
+ this%maxpe_fgen(0)= 0
+ do g=1,this%gm
+ this%maxpe_fgen(g)=this%maxpe_fgen(g-1)+this%nxy(g)
+ enddo
+
+ this%maxpe_filt=this%maxpe_fgen(this%gm)
+ this%npes_filt=this%maxpe_filt-this%nxy(1)
+
+ this%im0(1)=this%im00
+ do g=2,this%gm
+ this%im0(g)=this%im0(g-1)/2
+ enddo
+
+ this%jm0(1)=this%jm00
+ do g=2,this%gm
+ this%jm0(g)=this%jm0(g-1)/2
+ enddo
+
+ do g=1,this%gm
+ this%Fimax(g)=this%im0(g)-this%im*(this%ixm(g)-1)
+ this%Fjmax(g)=this%jm0(g)-this%jm*(this%jym(g)-1)
+ enddo
+
+ do g=1,this%gm
+ this%FimaxL(g)=this%Fimax(g)/2
+ this%FjmaxL(g)=this%Fjmax(g)/2
+ enddo
+
+!***
+!*** Filter related parameters
+!**
+ this%lengthx = 1.*this%nm ! arbitrary chosen scale of the domain
+ this%lengthy = 1.*this%mm ! arbitrary chosen scale of the domain
+
+ this%ib=6
+ this%jb=6
+
+ this%dxa =this%lengthx/this%nm
+ this%dxf = this%lengthx/this%im
+ this%nb = 2*this%dxf/this%dxa
+
+ this%dya = this%lengthy/this%mm
+ this%dyf = this%lengthy/this%jm
+ this%mb = 2*this%dyf/this%dya
+
+ this%xa0 = this%dxa*0.5
+ this%ya0 = this%dya*0.5
+
+ this%xf0 = this%dxf*0.5
+ this%yf0 = this%dyf*0.5
+
+ this%imL=this%im/2
+ this%jmL=this%jm/2
+
+ this%imH=this%im0(this%gm)
+ this%jmH=this%jm0(this%gm)
+
+ this%pasp01 = mg_ampl01
+ this%pasp02 = mg_ampl02
+ this%pasp03 = mg_ampl03
+
+ this%nh= max(hx,hy,hz)
+ this%nfil = this%nh + 2
+
+ this%pee2=this%p*2
+ this%rmom2_1=u1/sqrt(this%pee2+3)
+ this%rmom2_2=u1/sqrt(this%pee2+4)
+ this%rmom2_3=u1/sqrt(this%pee2+5)
+ this%rmom2_4=u1/sqrt(this%pee2+6)
+
+!----------------------------------------------------------------------
+end subroutine init_mg_parameter
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+subroutine def_maxgen &
+!**********************************************************************
+! !
+! Given number of PEs in x and y direction decides what is the !
+! maximum number of generations that a multigrid scheme can support !
+! !
+! M. Rancic 2020 !
+!**********************************************************************
+(nxm,nym,gm)
+!----------------------------------------------------------------------
+implicit none
+integer, intent(in):: nxm,nym
+integer, intent(out):: gm
+integer:: npx,npy,gx,gy
+
+ npx = nxm; gx=1
+ Do
+ npx = (npx + 1)/2
+ gx = gx + 1
+ if(npx == 1) exit
+ end do
+
+ npy = nym; gy=1
+ Do
+ npy = (npy + 1)/2
+ gy = gy + 1
+ if(npy == 1) exit
+ end do
+
+ gm = Min(gx,gy)
+
+
+!----------------------------------------------------------------------
+endsubroutine def_maxgen
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+subroutine def_ngens &
+!*********************************************************************!
+! !
+! Given number of generations, find number of PEs is s direction !
+! !
+! M. Rancic 2020 !
+!*********************************************************************!
+(nsm,gm,nsm0)
+!----------------------------------------------------------------------
+implicit none
+integer, intent(in):: gm,nsm0
+integer, dimension(gm), intent(out):: nsm
+integer:: g
+!----------------------------------------------------------------------
+
+ nsm(1)=nsm0
+ Do g=2,gm
+ nsm(g) = (nsm(g-1) + 1)/2
+ end do
+
+!----------------------------------------------------------------------
+endsubroutine def_ngens
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+end module mg_parameter
diff --git a/src/mgbf/mg_timers.f90 b/src/mgbf/mg_timers.f90
new file mode 100644
index 0000000000..0905d4d867
--- /dev/null
+++ b/src/mgbf/mg_timers.f90
@@ -0,0 +1,218 @@
+module mg_timers
+!$$$ submodule documentation block
+! . . . .
+! module: mg_timers
+! prgmmr: jovic org: date: 2017
+!
+! abstract: Measure cpu and wallclock timing
+!
+! module history log:
+! 2020 rancic - adjusted
+! 2023-04-19 lei - object-oriented coding
+! 2024-01-11 rancic - optimization for ensemble localization
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! btim -
+! etim -
+! print_mg_timers -
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+ use mpi
+ use kinds, only: r_kind,i_kind
+ implicit none
+
+ private
+
+ public :: btim, etim, print_mg_timers
+
+ type timer
+ logical :: running = .false.
+ real(r_kind) :: start_clock = 0.0
+ real(r_kind) :: start_cpu = 0.0
+ real(r_kind) :: time_clock = 0.0
+ real(r_kind) :: time_cpu = 0.0
+ end type timer
+
+ type(timer),save,public :: total_tim
+ type(timer),save,public :: init_tim
+ type(timer),save,public :: output_tim
+ type(timer),save,public :: dynamics_tim
+ type(timer),save,public :: upsend_tim
+ type(timer),save,public :: upsend1_tim
+ type(timer),save,public :: upsend2_tim
+ type(timer),save,public :: upsend3_tim
+ type(timer),save,public :: an2filt_tim
+ type(timer),save,public :: filt2an_tim
+ type(timer),save,public :: weight_tim
+ type(timer),save,public :: hfiltT_tim
+ type(timer),save,public :: vfiltT_tim
+ type(timer),save,public :: vadv1_tim
+ type(timer),save,public :: hfilt_tim
+ type(timer),save,public :: vfilt_tim
+ type(timer),save,public :: adv2_tim
+ type(timer),save,public :: vtoa_tim
+ type(timer),save,public :: dnsend_tim
+ type(timer),save,public :: dnsend1_tim
+ type(timer),save,public :: dnsend2_tim
+ type(timer),save,public :: dnsend3_tim
+ type(timer),save,public :: update_tim
+ type(timer),save,public :: physics_tim
+ type(timer),save,public :: radiation_tim
+ type(timer),save,public :: convection_tim
+ type(timer),save,public :: turbulence_tim
+ type(timer),save,public :: microphys_tim
+ type(timer),save,public :: pack_tim
+ type(timer),save,public :: arrn_tim
+ type(timer),save,public :: aintp_tim
+ type(timer),save,public :: intp_tim
+ type(timer),save,public :: bocoT_tim
+ type(timer),save,public :: boco_tim
+
+ integer, parameter, public :: print_clock = 1, &
+ print_cpu = 2, &
+ print_clock_pct = 3, &
+ print_cpu_pct = 4
+
+contains
+
+!-----------------------------------------------------------------------
+ subroutine btim(t)
+ implicit none
+ type(timer), intent(inout) :: t
+
+ if (t%running) then
+ write(0,*)'btim: timer is already running'
+ STOP
+ end if
+ t%running = .true.
+
+ t%start_clock = wtime()
+ t%start_cpu = ctime()
+
+ endsubroutine btim
+!-----------------------------------------------------------------------
+ subroutine etim(t)
+ implicit none
+ type(timer), intent(inout) :: t
+ real(r_kind) :: wt, ct
+
+ wt = wtime()
+ ct = ctime()
+
+ if (.not.t%running) then
+ write(0,*)'etim: timer is not running'
+ STOP
+ end if
+ t%running = .false.
+
+ t%time_clock = t%time_clock + (wt - t%start_clock)
+ t%time_cpu = t%time_cpu + (ct - t%start_cpu)
+ t%start_clock = 0.0
+ t%start_cpu = 0.0
+
+ endsubroutine etim
+!-----------------------------------------------------------------------
+ subroutine print_mg_timers(filename, print_type,mype)
+ use mpi
+ implicit none
+ integer(i_kind),intent(in):: mype
+
+ character(len=*), intent(in) :: filename
+ integer, intent(in) :: print_type
+
+ integer :: fh
+ integer :: ierr
+ integer(kind=MPI_OFFSET_KIND) :: disp
+ integer, dimension(MPI_STATUS_SIZE) :: stat
+ character(len=1024) :: buffer, header
+ integer :: bufsize
+
+ call MPI_File_open(MPI_COMM_WORLD, filename, &
+ MPI_MODE_WRONLY + MPI_MODE_CREATE, &
+ MPI_INFO_NULL, fh, ierr)
+
+ buffer = ' '
+ if ( print_type == print_clock ) then
+ write(buffer,"(I6,12(',',F10.4))") mype, &
+ init_tim%time_clock, &
+ upsend_tim%time_clock, &
+ dnsend_tim%time_clock, &
+ weight_tim%time_clock, &
+ hfiltT_tim%time_clock, &
+ hfilt_tim%time_clock, &
+ filt2an_tim%time_clock, &
+ aintp_tim%time_clock, &
+ intp_tim%time_clock, &
+ an2filt_tim%time_clock, &
+ output_tim%time_clock, &
+ total_tim%time_clock
+ else if ( print_type == print_cpu ) then
+ write(buffer,"(I6,14(',',F10.4))") mype, &
+ init_tim%time_cpu, &
+ an2filt_tim%time_cpu, &
+ vfiltT_tim%time_cpu, &
+ upsend_tim%time_cpu, &
+ hfiltT_tim%time_cpu, &
+ bocoT_tim%time_cpu, &
+ weight_tim%time_cpu, &
+ boco_tim%time_cpu, &
+ hfilt_tim%time_cpu, &
+ dnsend_tim%time_cpu, &
+ vfilt_tim%time_cpu, &
+ filt2an_tim%time_cpu, &
+ output_tim%time_cpu, &
+ total_tim%time_cpu
+ end if
+
+ bufsize = LEN(TRIM(buffer)) + 1
+ buffer(bufsize:bufsize) = NEW_LINE(' ')
+
+ write(header,"(A6,14(',',A10))") "mype", &
+ "init", &
+ "an2filt", &
+ "vfiltT", &
+ "upsend", &
+ "hfiltT", &
+ "bocoT" , &
+ "weight", &
+ "boco", &
+ "hfilt", &
+ "dnsend", &
+ "vfilt", &
+ "filt2an", &
+ "output", &
+ "total"
+
+ header(bufsize:bufsize) = NEW_LINE(' ')
+ disp = 0
+ call MPI_File_write_at(fh, disp, header, bufsize, MPI_BYTE, stat, ierr)
+
+ disp = (mype+1)*bufsize
+ call MPI_File_write_at(fh, disp, buffer, bufsize, MPI_BYTE, stat, ierr)
+
+ call MPI_File_close(fh, ierr)
+
+ endsubroutine print_mg_timers
+!-----------------------------------------------------------------------
+ function wtime()
+ use mpi
+ real(r_kind) :: wtime
+ wtime = MPI_Wtime()
+ endfunction wtime
+!-----------------------------------------------------------------------
+ function ctime()
+ real(r_kind) :: ctime
+ call CPU_TIME(ctime)
+ endfunction ctime
+!-----------------------------------------------------------------------
+end module mg_timers
diff --git a/src/mgbf/mg_transfer.f90 b/src/mgbf/mg_transfer.f90
new file mode 100644
index 0000000000..5f929c0243
--- /dev/null
+++ b/src/mgbf/mg_transfer.f90
@@ -0,0 +1,499 @@
+submodule(mg_intstate) mg_transfer
+!$$$ submodule documentation block
+! . . . .
+! module: mg_transfer
+! prgmmr: rancic org: NOAA/EMC date: 2021
+!
+! abstract: Transfer data between analysis and filter grid
+!
+! module history log:
+! 2023-04-19 lei - object-oriented coding
+! 2024-01-11 rancic - optimization for ensemble localization
+! 2024-02-20 yokota - refactoring to apply for GSI
+!
+! Subroutines Included:
+! anal_to_filt_allmap -
+! filt_to_anal_allmap -
+! anal_to_filt_all -
+! filt_to_anal_all -
+! anal_to_filt_all2 -
+! filt_to_anal_all2 -
+! stack_to_composite -
+! composite_to_stack -
+! S2C_ens -
+! C2S_ens -
+! anal_to_filt -
+! filt_to_anal -
+!
+! Functions Included:
+!
+! remarks:
+!
+! attributes:
+! language: f90
+! machine:
+!
+!$$$ end documentation block
+
+use mpi
+use mg_timers
+use kinds, only: r_kind,i_kind
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+contains
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine anal_to_filt_allmap(this,WORKA)
+!***********************************************************************
+! !
+! Transfer data from analysis to first generaton of filter grid !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+if(km_a_all==km_all.and.nm==im.and.mm==jm) then
+ VALL=0.
+ VALL(1:km_all,1:im,1:jm)=WORKA
+elseif(l_new_map) then
+ call this%anal_to_filt_all2(WORKA)
+else
+ call this%anal_to_filt_all(WORKA)
+endif
+!----------------------------------------------------------------------
+endsubroutine anal_to_filt_allmap
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filt_to_anal_allmap(this,WORKA)
+!***********************************************************************
+! !
+! Transfer data from filter to analysis grid !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+if(km_a_all==km_all.and.nm==im.and.mm==jm) then
+ WORKA=VALL(1:km_all,1:im,1:jm)
+ VALL=0.
+elseif(l_new_map) then
+ call this%filt_to_anal_all2(WORKA)
+else
+ call this%filt_to_anal_all(WORKA)
+endif
+!----------------------------------------------------------------------
+endsubroutine filt_to_anal_allmap
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine anal_to_filt_all(this,WORKA)
+!***********************************************************************
+! !
+! Transfer data from analysis to first generaton of filter grid !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+real(r_kind),allocatable,dimension(:,:,:,:):: A3D
+real(r_kind),allocatable,dimension(:,:,:,:):: F3D
+real(r_kind),allocatable,dimension(:,:,:):: WORK
+integer(i_kind):: L
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+allocate(WORK(km_all,1:nm,1:mm))
+allocate(A3D(km3_all,1:nm,1:mm,lm_a))
+allocate(F3D(km3_all,1:nm,1:mm,lm))
+
+ call btim(an2filt_tim)
+ call this%S2C_ens(WORKA,A3D,1,nm,1,mm,lm_a,km_a,km_a_all)
+
+ if(lm_a>lm) then
+ if(l_lin_vertical) then
+ call this%l_vertical_adjoint_spec(km3_all,lm_a,lm,1,nm,1,mm,A3D,F3D)
+ else
+ call this%lwq_vertical_adjoint_spec(km3_all,lm_a,lm,1,nm,1,mm, &
+ cvf1,cvf2,cvf3,cvf4,lref,A3D,F3D)
+ endif
+ else
+
+ do L=1,lm
+ F3D(:,:,:,L)=A3D(:,:,:,L)
+ enddo
+
+ endif
+
+ call this%C2S_ens(F3D,WORK,1,nm,1,mm,lm,km,km_all)
+
+ call this%anal_to_filt(WORK)
+ call etim(an2filt_tim)
+
+deallocate(A3D,F3D,WORK)
+!----------------------------------------------------------------------
+endsubroutine anal_to_filt_all
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filt_to_anal_all(this,WORKA)
+!***********************************************************************
+! !
+! Transfer data from filter to analysis grid !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+real(r_kind),allocatable,dimension(:,:,:,:):: A3D
+real(r_kind),allocatable,dimension(:,:,:,:):: F3D
+real(r_kind),allocatable,dimension(:,:,:):: WORK
+integer(i_kind):: L
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+allocate(WORK(km_all,1:nm,1:mm))
+allocate(A3D(km3_all,1:nm,1:mm,lm_a))
+allocate(F3D(km3_all,1:nm,1:mm,lm))
+
+ call btim(filt2an_tim)
+ call this%filt_to_anal(WORK)
+
+ call this%S2C_ens(WORK,F3D,1,nm,1,mm,lm,km,km_all)
+
+ if(lm_a>lm) then
+ if(l_lin_vertical) then
+ call this%l_vertical_direct_spec(km3_all,lm,lm_a,1,nm,1,mm,F3D,A3D)
+ else
+ call this%lwq_vertical_direct_spec(km3_all,lm,lm_a,1,nm,1,mm, &
+ cvf1,cvf2,cvf3,cvf4,lref,F3D,A3D)
+ endif
+ else
+
+ do L=1,lm
+ A3D(:,:,:,L)=F3D(:,:,:,L)
+ enddo
+
+ endif
+
+ call this%C2S_ens(A3D,WORKA,1,nm,1,mm,lm_a,km_a,km_a_all)
+ call etim(filt2an_tim)
+
+deallocate(A3D,F3D,WORK)
+!----------------------------------------------------------------------
+endsubroutine filt_to_anal_all
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine anal_to_filt_all2(this,WORKA)
+!***********************************************************************
+! !
+! Transfer data from analysis to first generaton of filter grid !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+real(r_kind),allocatable,dimension(:,:,:):: WORK
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+allocate(WORK(km_all,1:nm,1:mm))
+
+ call btim(an2filt_tim)
+ if(lm_a>lm) then
+ call this%l_vertical_adjoint_spec2(km3*n_ens,lm_a,lm,1,nm,1,mm,WORKA,WORK)
+ else
+ WORK = WORKA
+ endif
+
+ call this%anal_to_filt(WORK)
+ call etim(an2filt_tim)
+
+deallocate(WORK)
+!----------------------------------------------------------------------
+endsubroutine anal_to_filt_all2
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filt_to_anal_all2(this,WORKA)
+!***********************************************************************
+! !
+! Transfer data from filter to analysis grid !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm)
+real(r_kind),allocatable,dimension(:,:,:):: WORK
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+allocate(WORK(km_all,1:nm,1:mm))
+
+ call btim(filt2an_tim)
+ call this%filt_to_anal(WORK)
+
+ if(lm_a>lm) then
+ call this%l_vertical_direct_spec2(km3*n_ens,lm,lm_a,1,nm,1,mm,WORK,WORKA)
+ else
+ WORKA = WORK
+ endif
+ call etim(filt2an_tim)
+
+deallocate(WORK)
+!----------------------------------------------------------------------
+endsubroutine filt_to_anal_all2
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine stack_to_composite &
+!***********************************************************************
+! !
+! Transfer data from stack to composite variables !
+! !
+!***********************************************************************
+(this,ARR_ALL,A2D,A3D)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: ARR_ALL
+real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(out):: A3D
+real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy) ,intent(out):: A2D
+integer(i_kind):: i,j,k,L
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+ do L=1,lm
+ do j=1-hy,jm+hy
+ do i=1-hx,im+hx
+ do k=1,km3
+ A3D(k,i,j,L)=ARR_ALL( (k-1)*lm+L,i,j )
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do k=1,km2
+ A2D(k,:,:)=ARR_ALL(km3*lm+k,:,:)
+ enddo
+
+!----------------------------------------------------------------------
+endsubroutine stack_to_composite
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine composite_to_stack &
+!***********************************************************************
+! !
+! Transfer data from composite to stack variables !
+! !
+!***********************************************************************
+(this,A2D,A3D,ARR_ALL)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: A2D
+real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(in):: A3D
+real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(out):: ARR_ALL
+integer(i_kind):: i,j,k,L
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+ do L=1,lm
+ do j=1-hy,jm+hy
+ do i=1-hx,im+hx
+ do k=1,km3
+ ARR_ALL( (k-1)*lm+L,i,j )=A3D(k,i,j,L)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do k=1,km2
+ ARR_ALL(km3*lm+k,:,:)=A2D(k,:,:)
+ enddo
+
+!----------------------------------------------------------------------
+endsubroutine composite_to_stack
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine S2C_ens &
+!***********************************************************************
+! !
+! General transfer data from stack to composite variables for ensemble !
+! !
+!***********************************************************************
+(this,ARR_ALL,A3D,imn,imx,jmn,jmx,lmx,kmx,kmx_all)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all
+real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(in):: ARR_ALL
+real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(out):: A3D
+integer(i_kind):: i,j,k,L
+integer(i_kind):: n,n_inc
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+ do n=1,n_ens
+ n_inc = kmx*(n-1)
+
+ do L=1,lmx
+ do j=jmn,jmx
+ do i=imn,imx
+ do k=1,km3
+ A3D(km3*(n-1)+k,i,j,L)=ARR_ALL(n_inc+(k-1)*lmx+L,i,j)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ enddo
+!----------------------------------------------------------------------
+endsubroutine S2C_ens
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine C2S_ens &
+!***********************************************************************
+! !
+! General transfer data from composite to stack variables for ensemble !
+! !
+!***********************************************************************
+(this,A3D,ARR_ALL,imn,imx,jmn,jmx,lmx,kmx,kmx_all)
+!----------------------------------------------------------------------
+implicit none
+class(mg_intstate_type),target::this
+integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all
+real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(in):: A3D
+real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(out):: ARR_ALL
+integer(i_kind):: i,j,k,L
+integer(i_kind):: n,n_inc
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+ do n=1,n_ens
+ n_inc = kmx*(n-1)
+
+ do L=1,lmx
+ do j=jmn,jmx
+ do i=imn,imx
+ do k=1,km3
+ ARR_ALL(n_inc+(k-1)*lmx+L,i,j )= A3D(km3*(n-1)+k,i,j,L)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ enddo
+!----------------------------------------------------------------------
+endsubroutine C2S_ens
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine anal_to_filt(this,WORK)
+!***********************************************************************
+! !
+! Transfer data from analysis to first generaton of filter grid !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+real(r_kind):: WORK(this%km_all,1:this%nm,1:this%mm)
+integer(i_kind):: ibm,jbm
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+ VALL=0.
+
+ if(l_lin_horizontal) then
+ ibm=1
+ jbm=1
+ call this%lin_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm)
+ elseif(l_quad_horizontal) then
+ ibm=2
+ jbm=2
+ call this%quad_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm)
+ else
+ ibm=3
+ jbm=3
+ call this%lsqr_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm)
+ endif
+
+!***
+!*** Apply adjoint lateral bc on PKF and WKF
+!***
+
+ call this%bocoT_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm)
+
+!----------------------------------------------------------------------
+endsubroutine anal_to_filt
+
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+module subroutine filt_to_anal(this,WORK)
+!***********************************************************************
+! !
+! Transfer data from filter to analysis grid !
+! !
+!***********************************************************************
+implicit none
+class(mg_intstate_type),target::this
+real(r_kind):: WORK(this%km_all,1:this%nm,1:this%mm)
+integer(i_kind):: ibm,jbm
+include "type_parameter_locpointer.inc"
+include "type_intstat_locpointer.inc"
+include "type_parameter_point2this.inc"
+include "type_intstat_point2this.inc"
+!----------------------------------------------------------------------
+
+ if(l_lin_horizontal) then
+ ibm=1
+ jbm=1
+ elseif(l_quad_horizontal) then
+ ibm=2
+ jbm=2
+ else
+ ibm=3
+ jbm=3
+ endif
+
+!***
+!*** Supply boundary conditions for VALL
+!***
+
+ call this%boco_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm)
+
+ if(l_lin_horizontal) then
+ call this%lin_direct_offset(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm)
+ elseif(l_quad_horizontal) then
+ call this%quad_direct_offset(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm)
+ else
+ call this%lsqr_direct_offset(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm)
+ endif
+
+!----------------------------------------------------------------------
+endsubroutine filt_to_anal
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+end submodule mg_transfer
diff --git a/src/mgbf/type_intstat_locpointer.inc b/src/mgbf/type_intstat_locpointer.inc
new file mode 100644
index 0000000000..52cdb687e8
--- /dev/null
+++ b/src/mgbf/type_intstat_locpointer.inc
@@ -0,0 +1,44 @@
+real(r_kind), dimension(:,:,:),pointer:: V
+real(r_kind), dimension(:,:,:),pointer:: VALL
+real(r_kind), dimension(:,:,:),pointer:: HALL
+real(r_kind), dimension(:,:,:),pointer:: a_diff_f
+real(r_kind), dimension(:,:,:),pointer:: a_diff_h
+real(r_kind), dimension(:,:,:),pointer:: b_diff_f
+real(r_kind), dimension(:,:,:),pointer:: b_diff_h
+real(r_kind), dimension(:,:),pointer:: p_eps
+real(r_kind), dimension(:,:),pointer:: p_del
+real(r_kind), dimension(:,:),pointer:: p_sig
+real(r_kind), dimension(:,:),pointer:: p_rho
+real(r_kind), dimension(:,:,:),pointer:: paspx
+real(r_kind), dimension(:,:,:),pointer:: paspy
+real(r_kind), dimension(:,:,:),pointer:: pasp1
+real(r_kind), dimension(:,:,:,:),pointer:: pasp2
+real(r_kind), dimension(:,:,:,:,:),pointer:: pasp3
+real(r_kind), dimension(:,:,:),pointer:: vpasp2
+real(r_kind), dimension(:,:,:),pointer:: hss2
+real(r_kind), dimension(:,:,:,:),pointer:: vpasp3
+real(r_kind), dimension(:,:,:,:),pointer:: hss3
+real(r_kind), dimension(:),pointer:: ssx
+real(r_kind), dimension(:),pointer:: ssy
+real(r_kind), dimension(:),pointer:: ss1
+real(r_kind), dimension(:,:),pointer:: ss2
+real(r_kind), dimension(:,:,:),pointer:: ss3
+integer(fpi), dimension(:,:,:),pointer:: dixs
+integer(fpi), dimension(:,:,:),pointer:: diys
+integer(fpi), dimension(:,:,:),pointer:: dizs
+integer(fpi), dimension(:,:,:,:),pointer:: dixs3
+integer(fpi), dimension(:,:,:,:),pointer:: diys3
+integer(fpi), dimension(:,:,:,:),pointer:: dizs3
+integer(fpi), dimension(:,:,:,:),pointer:: qcols
+integer(i_kind),dimension(:),pointer:: iref,jref
+integer(i_kind),dimension(:),pointer:: Lref,Lref_h
+real(r_kind),dimension(:),pointer:: cvf1,cvf2,cvf3,cvf4
+real(r_kind),dimension(:),pointer:: cvh1,cvh2,cvh3,cvh4
+real(r_kind),dimension(:),pointer:: cx0,cx1,cx2,cx3
+real(r_kind),dimension(:),pointer:: cy0,cy1,cy2,cy3
+real(r_kind),dimension(:),pointer:: p_coef,q_coef
+real(r_kind),dimension(:),pointer:: a_coef,b_coef
+real(r_kind),dimension(:,:),pointer:: cf00,cf01,cf02,cf03 &
+ ,cf10,cf11,cf12,cf13 &
+ ,cf20,cf21,cf22,cf23 &
+ ,cf30,cf31,cf32,cf33
diff --git a/src/mgbf/type_intstat_point2this.inc b/src/mgbf/type_intstat_point2this.inc
new file mode 100644
index 0000000000..ab8923f059
--- /dev/null
+++ b/src/mgbf/type_intstat_point2this.inc
@@ -0,0 +1,83 @@
+V=>this%V
+VALL=>this%VALL
+HALL=>this%HALL
+
+a_diff_f=>this%a_diff_f
+a_diff_h=>this%a_diff_h
+b_diff_f=>this%b_diff_f
+b_diff_h=>this%b_diff_h
+
+p_eps=>this%p_eps
+p_del=>this%p_del
+p_sig=>this%p_sig
+p_rho=>this%p_rho
+paspx=>this%paspx
+paspy=>this%paspy
+pasp1=>this%pasp1
+pasp2=>this%pasp2
+pasp3=>this%pasp3
+
+vpasp2=>this%vpasp2
+hss2=>this%hss2
+vpasp3=>this%vpasp3
+hss3=>this%hss3
+
+ssx=>this%ssx
+ssy=>this%ssy
+ss1=>this%ss1
+ss2=>this%ss2
+ss3=>this%ss3
+
+dixs=>this%dixs
+diys=>this%diys
+dizs=>this%dizs
+
+dixs3=>this%dixs3
+diys3=>this%diys3
+dizs3=>this%dizs3
+
+qcols=>this%qcols
+
+iref=>this%iref
+jref=>this%jref
+Lref=>this%Lref
+Lref_h=>this%Lref_h
+cvf1=>this%cvf1
+cvf2=>this%cvf2
+cvf3=>this%cvf3
+cvf4=>this%cvf4
+cvh1=>this%cvh1
+cvh2=>this%cvh2
+cvh3=>this%cvh3
+cvh4=>this%cvh4
+
+cx0=>this%cx0
+cx1=>this%cx1
+cx2=>this%cx2
+cx3=>this%cx3
+cy0=>this%cy0
+cy1=>this%cy1
+cy2=>this%cy2
+cy3=>this%cy3
+
+p_coef=>this%p_coef
+q_coef=>this%q_coef
+a_coef=>this%a_coef
+b_coef=>this%b_coef
+
+cf00=>this%cf00
+cf01=>this%cf01
+cf02=>this%cf02
+cf03=>this%cf03
+cf10=>this%cf10
+cf11=>this%cf11
+cf12=>this%cf12
+cf13=>this%cf13
+cf20=>this%cf20
+cf21=>this%cf21
+cf22=>this%cf22
+cf23=>this%cf23
+cf30=>this%cf30
+cf31=>this%cf31
+cf32=>this%cf32
+cf33=>this%cf33
diff --git a/src/mgbf/type_parameter_locpointer.inc b/src/mgbf/type_parameter_locpointer.inc
new file mode 100644
index 0000000000..7a8f587dd2
--- /dev/null
+++ b/src/mgbf/type_parameter_locpointer.inc
@@ -0,0 +1,105 @@
+real(r_kind),pointer :: mg_ampl01,mg_ampl02,mg_ampl03
+real(r_kind),pointer:: mg_weig1,mg_weig2,mg_weig3,mg_weig4
+integer(i_kind),pointer:: mgbf_proc
+logical,pointer:: mgbf_line
+integer(i_kind),pointer:: nxPE,nyPE,im_filt,jm_filt
+logical,pointer:: lquart,lhelm
+integer(i_kind),pointer:: gm
+integer(i_kind),pointer:: gm_max
+integer(i_kind),pointer:: nA_max0
+integer(i_kind),pointer:: mA_max0
+integer(i_kind),pointer:: nm0
+integer(i_kind),pointer:: mm0
+integer(i_kind),pointer:: nxm
+integer(i_kind),pointer:: nym
+integer(i_kind),pointer:: nm
+integer(i_kind),pointer:: mm
+integer(i_kind),pointer:: im00
+integer(i_kind),pointer:: jm00
+integer(i_kind),pointer:: im
+integer(i_kind),pointer:: jm
+integer(i_kind),pointer:: i0
+integer(i_kind),pointer:: j0
+integer(i_kind),pointer:: n0
+integer(i_kind),pointer:: m0
+integer(i_kind),pointer:: ib
+integer(i_kind),pointer:: jb
+integer(i_kind),pointer:: nb
+integer(i_kind),pointer:: mb
+integer(i_kind),pointer:: hx,hy,hz
+integer(i_kind),pointer:: p
+integer(i_kind),pointer:: nh,nfil
+real(r_kind),pointer:: pasp01,pasp02,pasp03
+real(r_kind),pointer:: pee2,rmom2_1,rmom2_2,rmom2_3,rmom2_4
+integer, pointer, dimension(:):: maxpe_fgen
+integer, pointer, dimension(:):: ixm,jym,nxy
+integer, pointer, dimension(:):: im0,jm0
+integer, pointer, dimension(:):: Fimax,Fjmax
+integer, pointer, dimension(:):: FimaxL,FjmaxL
+integer(i_kind),pointer:: npes_filt
+integer(i_kind),pointer:: maxpe_filt
+integer(i_kind),pointer:: imL,jmL
+integer(i_kind),pointer:: imH,jmH
+integer(i_kind),pointer:: lm_a ! number of vertical layers in analysis fields
+integer(i_kind),pointer:: lm ! number of vertical layers in filter grids
+integer(i_kind),pointer:: km2 ! number of 2d variables for filtering
+integer(i_kind),pointer:: km3 ! number of 3d variables for filtering
+integer(i_kind),pointer:: n_ens ! number of ensemble members
+integer(i_kind),pointer:: km_a ! total number of horizontal levels for analysis
+integer(i_kind),pointer:: km_all ! total number of k levels of ensemble for filtering
+integer(i_kind),pointer:: km_a_all ! total number of k levels of ensemble
+integer(i_kind),pointer:: km2_all ! total number of k horizontal levels of ensemble for filtering
+integer(i_kind),pointer:: km3_all ! total number of k vertical levels of ensemble
+logical,pointer :: l_loc ! logical flag for localization
+logical,pointer :: l_filt_g1 ! logical flag for filtering of generation one
+logical,pointer :: l_lin_vertical ! logical flag for linear interpolation in vertcial
+logical,pointer :: l_lin_horizontal ! logical flag for linear interpolation in horizontal
+logical,pointer :: l_quad_horizontal ! logical flag for quadratic interpolation in horizontal
+logical,pointer :: l_new_map ! logical flag for new mapping between analysis and filter grid
+logical,pointer :: l_vertical_filter ! logical flag for vertical filtering
+integer(i_kind),pointer:: km ! number of vertically stacked all variables (km=km2+lm*km3)
+integer(i_kind),pointer:: km_4
+integer(i_kind),pointer:: km_16
+integer(i_kind),pointer:: km_64
+real(r_kind),pointer:: lengthx,lengthy,xa0,ya0,xf0,yf0
+real(r_kind),pointer:: dxf,dyf,dxa,dya
+integer(i_kind),pointer:: npadx ! x padding on analysis grid
+integer(i_kind),pointer:: mpady ! y padding on analysis grid
+integer(i_kind),pointer:: ipadx ! x padding on filter decomposition
+integer(i_kind),pointer:: jpady ! y padding on filter deocmposition
+logical,pointer:: ldelta
+
+!from mg_mppstuff.f90
+character(len=5),pointer:: c_mype
+integer(i_kind),pointer:: mype
+integer(i_kind),pointer:: npes,iTYPE,rTYPE,dTYPE,mpi_comm_comp,ierror
+integer(i_kind),pointer:: mpi_comm_work,group_world,group_work
+integer(i_kind),pointer:: mype_gr,npes_gr
+integer(i_kind),pointer:: my_hgen
+integer(i_kind),pointer:: mype_hgen
+logical,pointer:: l_hgen
+integer(i_kind),pointer:: nx,my
+
+!from mg_domain.f90
+logical,dimension(:),pointer:: Flwest,Fleast,Flnorth,Flsouth
+integer(i_kind),dimension(:),pointer:: Fitarg_n,Fitarg_e,Fitarg_s,Fitarg_w
+integer(i_kind),dimension(:),pointer:: Fitarg_sw,Fitarg_se,Fitarg_ne,Fitarg_nw
+logical,dimension(:),pointer:: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne
+integer(i_kind),dimension(:),pointer:: Fitarg_up
+integer(i_kind),pointer:: itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw
+integer(i_kind),pointer:: itarg_wA,itarg_eA,itarg_sA,itarg_nA
+logical,pointer:: lwestA,leastA,lsouthA,lnorthA
+integer(i_kind),pointer:: ix,jy
+integer(i_kind),dimension(:),pointer:: mype_filt
+
+!from mg_domain_loc.f90
+integer(i_kind),pointer:: nsq21,nsq32,nsq43
+logical,dimension(:),pointer:: Flsouth_loc,Flnorth_loc,Flwest_loc,Fleast_loc
+integer(i_kind),dimension(:),pointer:: Fitarg_s_loc,Fitarg_n_loc,Fitarg_w_loc,Fitarg_e_loc
+integer(i_kind),dimension(:),pointer:: Fitargup_loc12
+integer(i_kind),dimension(:),pointer:: Fitargup_loc23
+integer(i_kind),dimension(:),pointer:: Fitargup_loc34
+integer(i_kind),pointer:: itargdn_sw_loc21,itargdn_se_loc21,itargdn_nw_loc21,itargdn_ne_loc21
+integer(i_kind),pointer:: itargdn_sw_loc32,itargdn_se_loc32,itargdn_nw_loc32,itargdn_ne_loc32
+integer(i_kind),pointer:: itargdn_sw_loc43,itargdn_se_loc43,itargdn_nw_loc43,itargdn_ne_loc43
+logical,pointer:: lsendup_sw_loc,lsendup_se_loc,lsendup_nw_loc,lsendup_ne_loc
diff --git a/src/mgbf/type_parameter_point2this.inc b/src/mgbf/type_parameter_point2this.inc
new file mode 100644
index 0000000000..310f183311
--- /dev/null
+++ b/src/mgbf/type_parameter_point2this.inc
@@ -0,0 +1,189 @@
+mg_ampl01=>this%mg_ampl01
+mg_ampl02=>this%mg_ampl02
+mg_ampl03=>this%mg_ampl03
+mg_weig1=>this%mg_weig1
+mg_weig2=>this%mg_weig2
+mg_weig3=>this%mg_weig3
+mg_weig4=>this%mg_weig4
+mgbf_proc=>this%mgbf_proc
+mgbf_line=>this%mgbf_line
+nxPE=>this%nxPE
+nyPE=>this%nyPE
+im_filt=>this%im_filt
+jm_filt=>this%jm_filt
+lquart=>this%lquart
+lhelm=>this%lhelm
+gm=>this%gm
+gm_max=>this%gm_max
+nA_max0=>this%nA_max0
+mA_max0=>this%mA_max0
+nm0=>this%nm0
+mm0=>this%mm0
+nxm=>this%nxm
+nym=>this%nym
+nm=>this%nm
+mm=>this%mm
+im00=>this%im00
+jm00=>this%jm00
+im=>this%im
+jm=>this%jm
+i0=>this%i0
+j0=>this%j0
+n0=>this%n0
+m0=>this%m0
+ib=>this%ib
+jb=>this%jb
+nb=>this%nb
+mb=>this%mb
+hx=>this%hx
+hy=>this%hy
+hz=>this%hz
+p=>this%p
+nh=>this%nh
+nfil=>this%nfil
+pasp01=>this%pasp01
+pasp02=>this%pasp02
+pasp03=>this%pasp03
+pee2=>this%pee2
+rmom2_1=>this%rmom2_1
+rmom2_2=>this%rmom2_2
+rmom2_3=>this%rmom2_3
+rmom2_4=>this%rmom2_4
+maxpe_fgen=>this%maxpe_fgen
+ixm=>this%ixm
+jym=>this%jym
+nxy=>this%nxy
+im0=>this%im0
+jm0=>this%jm0
+Fimax=>this%Fimax
+Fjmax=>this%Fjmax
+FimaxL=>this%FimaxL
+FjmaxL=>this%FjmaxL
+npes_filt=>this%npes_filt
+maxpe_filt=>this%maxpe_filt
+imL=>this%imL
+jmL=>this%jmL
+imH=>this%imH
+jmH=>this%jmH
+lm_a=>this%lm_a ! number of vertical layers in analysis fields
+lm=>this%lm ! number of vertical layers in filter grids
+km2=>this%km2 ! number of 2d variables for filtering
+km3=>this%km3 ! number of 3d variables for filtering
+n_ens=>this%n_ens ! number of ensemble members
+km_a=>this%km_a ! total number of horizontal levels for analysis
+km_all=>this%km_all ! total number of k levels of ensemble for filtering
+km_a_all=>this%km_a_all ! total number of k levels of ensemble
+km2_all=>this%km2_all ! total number of k horizontal levels of ensemble for filtering
+km3_all=>this%km3_all ! total number of k vertical levels of ensemble
+l_loc=>this%l_loc ! logical flag for localization
+l_filt_g1=>this%l_filt_g1 ! logical flag for filtering of generation one
+l_lin_vertical=>this%l_lin_vertical ! logical flag for linear interpolation in vertcial
+l_lin_horizontal=>this%l_lin_horizontal ! logical flag for linear interpolation in horizontal
+l_quad_horizontal=>this%l_quad_horizontal ! logical flag for quadratic interpolation in horizontal
+l_new_map=>this%l_new_map ! logical flag for new mapping between analysis and filter grid
+l_vertical_filter=>this%l_vertical_filter ! logical flag for vertical filtering
+km=>this%km ! number of vertically stacked all variables (km=km2+lm*km3)
+km_4=>this%km_4
+km_16=>this%km_16
+km_64=>this%km_64
+lengthx=>this%lengthx
+lengthy=>this%lengthy
+xa0=>this%xa0
+ya0=>this%ya0
+xf0=>this%xf0
+yf0=>this%yf0
+dxf=>this%dxf
+dyf=>this%dyf
+dxa=>this%dxa
+dya=>this%dya
+npadx=>this%npadx ! x padding on analysis grid
+mpady=>this%mpady ! y padding on analysis grid
+ipadx=>this%ipadx ! x padding on filter decomposition
+jpady=>this%jpady ! y padding on filter deocmposition
+ldelta=>this%ldelta
+
+!from mg_mppstuff.f90
+c_mype=>this%c_mype
+mype=>this%mype
+npes=>this%npes
+iTYPE=>this%iTYPE
+rTYPE=>this%rTYPE
+dTYPE=>this%dTYPE
+mpi_comm_comp=>this%mpi_comm_comp
+ierror=>this%ierror
+mpi_comm_work=>this%mpi_comm_work
+group_world=>this%group_world
+group_work=>this%group_work
+mype_gr=>this%mype_gr
+npes_gr=>this%npes_gr
+my_hgen=>this%my_hgen
+mype_hgen=>this%mype_hgen
+l_hgen=>this%l_hgen
+nx=>this%nx
+my=>this%my
+
+!from mg_domain.f90
+Flwest=>this%Flwest
+Fleast=>this%Fleast
+Flnorth=>this%Flnorth
+Flsouth=>this%Flsouth
+Fitarg_n=>this%Fitarg_n
+Fitarg_e=>this%Fitarg_e
+Fitarg_s=>this%Fitarg_s
+Fitarg_w=>this%Fitarg_w
+Fitarg_sw=>this%Fitarg_sw
+Fitarg_se=>this%Fitarg_se
+Fitarg_ne=>this%Fitarg_ne
+Fitarg_nw=>this%Fitarg_nw
+Flsendup_sw=>this%Flsendup_sw
+Flsendup_se=>this%Flsendup_se
+Flsendup_nw=>this%Flsendup_nw
+Flsendup_ne=>this%Flsendup_ne
+Fitarg_up=>this%Fitarg_up
+itargdn_sw=>this%itargdn_sw
+itargdn_se=>this%itargdn_se
+itargdn_ne=>this%itargdn_ne
+itargdn_nw=>this%itargdn_nw
+itarg_wA=>this%itarg_wA
+itarg_eA=>this%itarg_eA
+itarg_sA=>this%itarg_sA
+itarg_nA=>this%itarg_nA
+lwestA=>this%lwestA
+leastA=>this%leastA
+lsouthA=>this%lsouthA
+lnorthA=>this%lnorthA
+ix=>this%ix
+jy=>this%jy
+mype_filt=>this%mype_filt
+
+!from mg_domain_loc.f90
+nsq21=>this%nsq21
+nsq32=>this%nsq32
+nsq43=>this%nsq43
+Flsouth_loc=>this%Flsouth_loc
+Flnorth_loc=>this%Flnorth_loc
+Flwest_loc=>this%Flwest_loc
+Fleast_loc=>this%Fleast_loc
+Fitarg_s_loc=>this%Fitarg_s_loc
+Fitarg_n_loc=>this%Fitarg_n_loc
+Fitarg_w_loc=>this%Fitarg_w_loc
+Fitarg_e_loc=>this%Fitarg_e_loc
+Fitargup_loc12=>this%Fitargup_loc12
+Fitargup_loc23=>this%Fitargup_loc23
+Fitargup_loc34=>this%Fitargup_loc34
+itargdn_sw_loc21=>this%itargdn_sw_loc21
+itargdn_se_loc21=>this%itargdn_se_loc21
+itargdn_nw_loc21=>this%itargdn_nw_loc21
+itargdn_ne_loc21=>this%itargdn_ne_loc21
+itargdn_sw_loc32=>this%itargdn_sw_loc32
+itargdn_se_loc32=>this%itargdn_se_loc32
+itargdn_nw_loc32=>this%itargdn_nw_loc32
+itargdn_ne_loc32=>this%itargdn_ne_loc32
+itargdn_sw_loc43=>this%itargdn_sw_loc43
+itargdn_se_loc43=>this%itargdn_se_loc43
+itargdn_nw_loc43=>this%itargdn_nw_loc43
+itargdn_ne_loc43=>this%itargdn_ne_loc43
+lsendup_sw_loc=>this%lsendup_sw_loc
+lsendup_se_loc=>this%lsendup_se_loc
+lsendup_nw_loc=>this%lsendup_nw_loc
+lsendup_ne_loc=>this%lsendup_ne_loc
diff --git a/ush/build.sh b/ush/build.sh
index 71674c4f4c..a133889eac 100755
--- a/ush/build.sh
+++ b/ush/build.sh
@@ -24,13 +24,12 @@ source $DIR_ROOT/ush/detect_machine.sh
set +x
source $DIR_ROOT/ush/module-setup.sh
module use $DIR_ROOT/modulefiles
-module load gsi_$MACHINE_ID
+module load "gsi_${MACHINE_ID}.${COMPILER}"
module list
set -x
# Set CONTROLPATH variable to user develop installation
CONTROLPATH="$DIR_ROOT/../develop/install/bin"
-
# Collect BUILD Options
CMAKE_OPTS+=" -DCMAKE_BUILD_TYPE=$BUILD_TYPE"
diff --git a/ush/build_4nco_global.sh b/ush/build_4nco_global.sh
index 60382ce9b5..45d5eaf7a1 100755
--- a/ush/build_4nco_global.sh
+++ b/ush/build_4nco_global.sh
@@ -18,6 +18,9 @@ export GSI_MODE="GFS"
export ENKF_MODE="GFS"
export REGRESSION_TESTS="NO"
+# Optionally set compiler flags
+##export FFLAGS="-check all,noarg_temp_created"
+
# Prune the directory structure per NCO liking
if [[ "${PRUNE_4NCO:-}" =~ [yYtT] ]]; then
$DIR_ROOT/ush/prune_4nco_global.sh prune
diff --git a/ush/detect_machine.sh b/ush/detect_machine.sh
index ecd1ad536e..0beb937f7e 100755
--- a/ush/detect_machine.sh
+++ b/ush/detect_machine.sh
@@ -1,20 +1,30 @@
#!/bin/bash
+# The authoritative copy of this script lives in the ufs-weather-model at:
+# https://github.com/ufs-community/ufs-weather-model/blob/develop/tests/detect_machine.sh
+# If any local modifications are made or new platform support added,
+# please consider opening an issue and a PR to the ufs-weather-model
+# so that this copy remains in sync with its authoritative source
+#
+# Thank you for your contribution
+
+# If the MACHINE_ID variable is set, skip this script.
+[[ -n ${MACHINE_ID:-} ]] && return
+
+# First detect w/ hostname
case $(hostname -f) in
- adecflow0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn
- alogin0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn
+ adecflow0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=acorn ;; ### acorn
+ alogin0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=acorn ;; ### acorn
clogin0[1-9].cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus01-9
clogin10.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus10
dlogin0[1-9].dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dogwood01-9
dlogin10.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dogwood10
- gaea9) MACHINE_ID=gaea ;; ### gaea9
- gaea1[0-6]) MACHINE_ID=gaea ;; ### gaea10-16
- gaea9.ncrc.gov) MACHINE_ID=gaea ;; ### gaea9
- gaea1[0-6].ncrc.gov) MACHINE_ID=gaea ;; ### gaea10-16
+ gaea5[1-8]) MACHINE_ID=gaea ;; ### gaea51-58
+ gaea5[1-8].ncrc.gov) MACHINE_ID=gaea ;; ### gaea51-58
- hfe0[1-9]) MACHINE_ID=hera ;; ### hera01-9
+ hfe0[1-9]) MACHINE_ID=hera ;; ### hera01-09
hfe1[0-2]) MACHINE_ID=hera ;; ### hera10-12
hecflow01) MACHINE_ID=hera ;; ### heraecflow01
@@ -25,21 +35,58 @@ case $(hostname -f) in
Orion-login-[1-4].HPC.MsState.Edu) MACHINE_ID=orion ;; ### orion1-4
- cheyenne[1-6].cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6
- cheyenne[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6
- chadmin[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6
+ [Hh]ercules-login-[1-4].[Hh][Pp][Cc].[Mm]s[Ss]tate.[Ee]du) MACHINE_ID=hercules ;; ### hercules1-4
login[1-4].stampede2.tacc.utexas.edu) MACHINE_ID=stampede ;; ### stampede1-4
login0[1-2].expanse.sdsc.edu) MACHINE_ID=expanse ;; ### expanse1-2
discover3[1-5].prv.cube) MACHINE_ID=discover ;; ### discover31-35
+ *) MACHINE_ID=UNKNOWN ;; # Unknown platform
esac
+if [[ ${MACHINE_ID} == "UNKNOWN" ]]; then
+ case ${PW_CSP:-} in
+ "aws" | "google" | "azure") MACHINE_ID=noaacloud ;;
+ *) PW_CSP="UNKNOWN"
+ esac
+fi
+
# Overwrite auto-detect with MACHINE if set
MACHINE_ID=${MACHINE:-${MACHINE_ID}}
-# Append compiler (only on machines that have multiple compilers)
-if [ $MACHINE_ID = hera ] || [ $MACHINE_ID = cheyenne ]; then
- MACHINE_ID=${MACHINE_ID}.${COMPILER}
+# If MACHINE_ID is no longer UNKNNOWN, return it
+if [[ "${MACHINE_ID}" != "UNKNOWN" ]]; then
+ return
+fi
+
+# Try searching based on paths since hostname may not match on compute nodes
+if [[ -d /lfs/h3 ]]; then
+ # We are on NOAA Cactus or Dogwood
+ MACHINE_ID=wcoss2
+elif [[ -d /lfs/h1 && ! -d /lfs/h3 ]]; then
+ # We are on NOAA TDS Acorn
+ MACHINE_ID=acorn
+elif [[ -d /mnt/lfs5 ]]; then
+ # We are on NOAA Jet
+ MACHINE_ID=jet
+elif [[ -d /scratch1 ]]; then
+ # We are on NOAA Hera
+ MACHINE_ID=hera
+elif [[ -d /work ]]; then
+ # We are on MSU Orion or Hercules
+ mount=$(findmnt -n -o SOURCE /home)
+ if [[ ${mount} =~ "hercules" ]]; then
+ MACHINE_ID=hercules
+ else
+ MACHINE_ID=orion
+ fi
+elif [[ -d /gpfs && -d /ncrc ]]; then
+ # We are on GAEA.
+ MACHINE_ID=gaea
+elif [[ -d /data/prod ]]; then
+ # We are on SSEC's S4
+ MACHINE_ID=s4
+else
+ echo WARNING: UNKNOWN PLATFORM 1>&2
fi
diff --git a/ush/module-setup.sh b/ush/module-setup.sh
index 469fd4a3c5..299e13aa4e 100755
--- a/ush/module-setup.sh
+++ b/ush/module-setup.sh
@@ -15,10 +15,17 @@ elif [[ $MACHINE_ID = hera* ]] ; then
fi
module purge
+elif [[ $MACHINE_ID = hercules* ]] ; then
+ # We are on Hercules
+ if ( ! eval module help > /dev/null 2>&1 ) ; then
+ source /apps/other/lmod/lmod/init/bash
+ fi
+ module purge
+
elif [[ $MACHINE_ID = orion* ]] ; then
# We are on Orion
if ( ! eval module help > /dev/null 2>&1 ) ; then
- source /apps/lmod/init/bash
+ source /apps/lmod/lmod/init/bash
fi
module purge
@@ -33,13 +40,6 @@ elif [[ $MACHINE_ID = wcoss2 ]]; then
# We are on WCOSS2
module reset
-elif [[ $MACHINE_ID = cheyenne* ]] ; then
- # We are on NCAR Cheyenne
- if ( ! eval module help > /dev/null 2>&1 ) ; then
- source /glade/u/apps/ch/modulefiles/default/localinit/localinit.sh
- fi
- module purge
-
elif [[ $MACHINE_ID = stampede* ]] ; then
# We are on TACC Stampede
if ( ! eval module help > /dev/null 2>&1 ) ; then
@@ -56,33 +56,8 @@ elif [[ $MACHINE_ID = gaea* ]] ; then
# the module command fails. Hence we actually have to source
# /etc/profile here.
source /etc/profile
- __ms_source_etc_profile=yes
- else
- __ms_source_etc_profile=no
- fi
- module purge
- # clean up after purge
- unset _LMFILES_
- unset _LMFILES_000
- unset _LMFILES_001
- unset LOADEDMODULES
- module load modules
- if [[ -d /opt/cray/ari/modulefiles ]] ; then
- module use -a /opt/cray/ari/modulefiles
- fi
- if [[ -d /opt/cray/pe/ari/modulefiles ]] ; then
- module use -a /opt/cray/pe/ari/modulefiles
- fi
- if [[ -d /opt/cray/pe/craype/default/modulefiles ]] ; then
- module use -a /opt/cray/pe/craype/default/modulefiles
- fi
- if [[ -s /etc/opt/cray/pe/admin-pe/site-config ]] ; then
- source /etc/opt/cray/pe/admin-pe/site-config
- fi
- if [[ "$__ms_source_etc_profile" == yes ]] ; then
- source /etc/profile
- unset __ms_source_etc_profile
fi
+ module reset
elif [[ $MACHINE_ID = expanse* ]]; then
# We are on SDSC Expanse
@@ -98,6 +73,10 @@ elif [[ $MACHINE_ID = discover* ]]; then
export PATH=$PATH:$SPACK_ROOT/bin
. $SPACK_ROOT/share/spack/setup-env.sh
+elif [[ $MACHINE_ID = noaacloud* ]]; then
+ # We are on NOAA Cloud
+ module purge
+
else
echo WARNING: UNKNOWN PLATFORM 1>&2
fi
diff --git a/ush/prune_4nco_global.sh b/ush/prune_4nco_global.sh
index 0e1eba2ead..149d2bab50 100755
--- a/ush/prune_4nco_global.sh
+++ b/ush/prune_4nco_global.sh
@@ -15,6 +15,8 @@
# removed directories and files
#
+function version { echo "$@" | awk -F. '{ printf("%d%03d%03d%03d\n", $1,$2,$3,$4); }'; }
+
set -ex
mode=$1
@@ -23,7 +25,14 @@ mode=$1
if [[ "$mode" = "prune" ]]; then
string="rm -r"
elif [[ "$mode" = "restore" ]]; then
- string="reset HEAD"
+ git_ver=$(git version | cut -d" " -f3)
+ if [ $(version $git_ver) -lt $(version "2.23.0") ]; then
+ use_checkout="YES"
+ string="checkout"
+ else
+ use_checkout="NO"
+ string="restore"
+ fi
else
echo " "
echo "***ERROR*** invalid mode= $mode"
@@ -46,38 +55,58 @@ echo " "
cd $topdir
rlist="regression src/GSD unit-tests"
for type in $rlist; do
- git $string ${type}*
- rc=$?
- if [[ $rc -ne 0 ]]; then
- echo "***ERROR* git $string ${type}"
- exit
- fi
- if [[ "$mode" = "restore" ]]; then
- git checkout ${type}*
- rc=$?
- if [[ $rc -ne 0 ]]; then
- echo "***ERROR* git checkout ${type}"
+ if [[ "$mode" = "prune" ]]; then
+ if [ -e $type ]; then
+ git $string ${type}*
+ rc=$?
+ if [[ $rc -ne 0 ]]; then
+ echo "***ERROR*** git $string ${type}"
+ exit
+ fi
+ fi
+ elif [[ "$mode" = "restore" ]]; then
+ if [[ "$use_checkout" = "YES" ]]; then
+ git reset HEAD ${type}*
+ git checkout ${type}*
+ rc=$?
+ else
+ git restore --staged ${type}*
+ git restore ${type}*
+ rc=$?
+ fi
+ if [[ $rc -ne 0 ]]; then
+ echo "***ERROR*** restore failed for ${type}"
exit
- fi
+ fi
fi
done
# Process doc directories and files
cd $topdir/doc
-rlist="EnKF_user_guide GSI_user_guide README.discover"
+rlist="EnKF_user_guide GSI_user_guide README.discover Release_Notes.fv3gfs_da.v15.0.0.txt Release_Notes.gfsda.v16.0.0.txt"
for type in $rlist; do
- git $string ${type}*
- rc=$?
- if [[ $rc -ne 0 ]]; then
- echo "***ERROR* git $string ${type}"
- exit
- fi
- if [[ "$mode" = "restore" ]]; then
- git checkout ${type}*
- rc=$?
+ if [[ "$mode" = "prune" ]]; then
+ if [ -e $type ]; then
+ git $string ${type}*
+ rc=$?
+ if [[ $rc -ne 0 ]]; then
+ echo "***ERROR*** git $string ${type}"
+ exit
+ fi
+ fi
+ elif [[ "$mode" = "restore" ]]; then
+ if [[ "$use_checkout" = "YES" ]]; then
+ git reset HEAD ${type}*
+ git checkout ${type}*
+ rc=$?
+ else
+ git restore --staged ${type}*
+ git restore ${type}*
+ rc=$?
+ fi
if [[ $rc -ne 0 ]]; then
- echo "***ERROR* git checkout ${type}"
+ echo "***ERROR*** restore failed for ${type}"
exit
fi
fi
@@ -88,17 +117,27 @@ done
cd $topdir/ush
rlist="sub"
for type in $rlist; do
- git $string ${type}*
- rc=$?
- if [[ $rc -ne 0 ]]; then
- echo "***ERROR* git $string ${type}"
- exit
- fi
- if [[ "$mode" = "restore" ]]; then
- git checkout ${type}*
- rc=$?
+ if [[ "$mode" = "prune" ]]; then
+ if [ -e $type ]; then
+ git $string ${type}*
+ rc=$?
+ if [[ $rc -ne 0 ]]; then
+ echo "***ERROR*** git $string ${type}"
+ exit
+ fi
+ fi
+ elif [[ "$mode" = "restore" ]]; then
+ if [[ "$use_checkout" = "YES" ]]; then
+ git reset HEAD ${type}*
+ git checkout ${type}*
+ rc=$?
+ else
+ git restore --staged ${type}*
+ git restore ${type}*
+ rc=$?
+ fi
if [[ $rc -ne 0 ]]; then
- echo "***ERROR* git checkout ${type}"
+ echo "***ERROR*** restore failed for ${type}"
exit
fi
fi
diff --git a/ush/run_observer/README b/ush/run_observer/README
new file mode 100644
index 0000000000..5e68d63929
--- /dev/null
+++ b/ush/run_observer/README
@@ -0,0 +1,5 @@
+Main driver script is submit_gsi_observer.sh
+
+This calls gsi_observer.sh where the GSI observer is run producing GSI diag files in $workdir/diags ($workdir is defined in submit_gsi_observer.sh)
+
+This calls iodaconv.sh which runs the iodacoverters in $GDASApp and outputs to $workdir/ioda
diff --git a/ush/run_observer/gsi_observer.sh b/ush/run_observer/gsi_observer.sh
new file mode 100755
index 0000000000..7ba80320cf
--- /dev/null
+++ b/ush/run_observer/gsi_observer.sh
@@ -0,0 +1,516 @@
+#!/bin/bash
+#SBATCH -J GSIobserver
+#SBATCH -o GSIobserver.o%j
+#SBATCH -A da-cpu
+#SBATCH -q batch
+#SBATCH -p orion
+#SBATCH --nodes=25
+#SBATCH --ntasks-per-node=8
+#SBATCH --exclusive
+#SBATCH -t 30:00
+# run_gsi_observer.sh
+# run GSI observer for a specified
+# analysis cycle and subset of observations
+# cory.r.martin@noaa.gov
+set -x
+ulimit -s unlimited
+
+# source user configuration
+source $1
+# adate, GSIDIR, GSIFIX
+
+## resolution things for GSI
+export JCAP=1534
+export JCAP_B=1534
+export LEVS=127
+export LONA=3072
+export LATA=1536
+export DELTIM=120
+export NLON=3072
+export NLAT=1538
+
+## load modules for GSI
+#set +x
+MACHINE_ID=$MACHINE
+source $GSIDIR/ush/module-setup.sh
+module use $GSIDIR/modulefiles
+module load gsi_$MACHINE_ID.intel
+module list
+#set -x
+set +eu
+
+## load env vars as needed
+export APRUN_GSI='srun --export=ALL'
+
+## variables for executables
+CRMroot=/work2/noaa/da/cmartin/UFO_eval/geovals/
+gsiexec=$GSIDIR/install/bin/gsi.x
+nccat=$CRMroot/GSI-ncdiag/build/ncdiag/ncdiag_cat_serial.x
+NDATE=${NDATE:-`which ndate`}
+ncpc=/bin/cp
+ncpl="ln -fs"
+
+## get analysis/guess date
+PDYa=`echo $adate | cut -c1-8`
+cyca=`echo $adate | cut -c9-10`
+gdate=`$NDATE -06 $adate`
+PDYg=`echo $gdate | cut -c1-8`
+cycg=`echo $gdate | cut -c9-10`
+
+## variables for other useful paths
+fixgsi=$GSIFIX
+ushgsi=$GSIDIR/ush
+crtm_coeffs=./crtm_coeffs/
+datobs=$dumpdir/${dump}.$PDYa/$cyca/atmos
+datobsnr=$dumpdir/${dump}nr.$PDYa/$cyca/atmos
+datobsur=$dumpdir/${dump}ur.$PDYa/$cyca/atmos
+datges=$gesroot/${dump}.$PDYg/$cycg/model_data/atmos/history/
+datbias=$gesroot/${dump}.$PDYg/$cycg/analysis/atmos/
+prefix_obs=${dump}.t${cyca}z
+prefix_ges=${dump}.t${cycg}z
+suffix=tm00.bufr_d
+# gps DO-1 obs
+gpsobs=/work/noaa/da/Cory.R.Martin/noscrub/UFO_eval/GNSSRO_DO1/$PDYa$cyca/${dump}/gpsrobufr
+
+# forcing it to be gfsv16
+SUFFIX=".nc"
+use_gfs_nemsio=".false."
+use_gfs_ncio=".true."
+
+## paths of fix files
+anavinfo=$fixgsi/global_anavinfo.l${LEVS}.txt
+berror=$fixgsi/Big_Endian/global_berror.l${LEVS}y${NLAT}.f77
+locinfo=$fixgsi/global_hybens_info.l${LEVS}.txt
+satinfo=$fixgsi/global_satinfo.txt
+scaninfo=$fixgsi/global_scaninfo.txt
+satangl=$fixgsi/global_satangbias.txt
+pcpinfo=$fixgsi/global_pcpinfo.txt
+ozinfo=$fixgsi/global_ozinfo.txt
+convinfo=/work2/noaa/da/nesposito/GSI_fixdir/global_convinfo.txt
+vqcdat=$fixgsi/vqctp001.dat
+insituinfo=$fixgsi/global_insituinfo.txt
+errtable=$fixgsi/prepobs_errtable.global
+aeroinfo=$fixgsi/global_aeroinfo.txt
+atmsbeaminfo=$fixgsi/atms_beamwidth.txt
+cloudyinfo=$fixgsi/cloudy_radiance_info.txt
+
+emiscoef_IRwater=$CRTM_FIX/Nalli.IRwater.EmisCoeff.bin
+emiscoef_IRice=$CRTM_FIX/NPOESS.IRice.EmisCoeff.bin
+emiscoef_IRland=$CRTM_FIX/NPOESS.IRland.EmisCoeff.bin
+emiscoef_IRsnow=$CRTM_FIX/NPOESS.IRsnow.EmisCoeff.bin
+emiscoef_VISice=$CRTM_FIX/NPOESS.VISice.EmisCoeff.bin
+emiscoef_VISland=$CRTM_FIX/NPOESS.VISland.EmisCoeff.bin
+emiscoef_VISsnow=$CRTM_FIX/NPOESS.VISsnow.EmisCoeff.bin
+emiscoef_VISwater=$CRTM_FIX/NPOESS.VISwater.EmisCoeff.bin
+emiscoef_MWwater=$CRTM_FIX/FASTEM6.MWwater.EmisCoeff.bin
+aercoef=$CRTM_FIX/AerosolCoeff.bin
+cldcoef=$CRTM_FIX/CloudCoeff.bin
+
+## rm, make, and cd to working directory
+cd $workdir
+rm -rf $workdir/gsi
+mkdir -p $workdir/gsi
+cd $workdir/gsi
+
+## copy executable and fix files
+$ncpc $gsiexec ./gsi.x
+
+$ncpc $anavinfo ./anavinfo
+$ncpc $berror ./berror_stats
+$ncpc $locinfo ./hybens_info
+$ncpc $satinfo ./satinfo
+$ncpc $scaninfo ./scaninfo
+$ncpc $pcpinfo ./pcpinfo
+$ncpc $ozinfo ./ozinfo
+$ncpc $convinfo ./convinfo
+$ncpc $vqcdat ./vqctp001.dat
+$ncpc $insituinfo ./insituinfo
+$ncpc $errtable ./errtable
+$ncpc $aeroinfo ./aeroinfo
+$ncpc $atmsbeaminfo ./atms_beamwidth.txt
+$ncpc $cloudyinfo ./cloudy_radiance_info.txt
+
+## copy CRTM coefficient files based on entries in satinfo file
+mkdir -p ${crtm_coeffs}
+for file in `awk '{if($1!~"!"){print $1}}' satinfo | sort | uniq` ;do
+ $ncpc $CRTM_FIX/${file}.SpcCoeff.bin ${crtm_coeffs}
+ $ncpc $CRTM_FIX/${file}.TauCoeff.bin ${crtm_coeffs}
+done
+$ncpc $emiscoef_IRwater ${crtm_coeffs}Nalli.IRwater.EmisCoeff.bin
+$ncpc $emiscoef_IRice ${crtm_coeffs}NPOESS.IRice.EmisCoeff.bin
+$ncpc $emiscoef_IRsnow ${crtm_coeffs}NPOESS.IRsnow.EmisCoeff.bin
+$ncpc $emiscoef_IRland ${crtm_coeffs}NPOESS.IRland.EmisCoeff.bin
+$ncpc $emiscoef_VISice ${crtm_coeffs}NPOESS.VISice.EmisCoeff.bin
+$ncpc $emiscoef_VISland ${crtm_coeffs}NPOESS.VISland.EmisCoeff.bin
+$ncpc $emiscoef_VISsnow ${crtm_coeffs}NPOESS.VISsnow.EmisCoeff.bin
+$ncpc $emiscoef_VISwater ${crtm_coeffs}NPOESS.VISwater.EmisCoeff.bin
+$ncpc $emiscoef_MWwater ${crtm_coeffs}FASTEM6.MWwater.EmisCoeff.bin
+$ncpc $aercoef ${crtm_coeffs}AerosolCoeff.bin
+$ncpc $cldcoef ${crtm_coeffs}CloudCoeff.bin
+
+## copy observations
+if [[ "$rstprod" = "true" ]]; then
+ $ncpl $datobs/${prefix_obs}.prepbufr ./prepbufr
+ $ncpl $datobs/${prefix_obs}.saphir.${suffix} ./saphirbufr
+ $ncpl $datobs/${prefix_obs}.prepbufr.acft_profiles ./prepbufr_profl
+ $ncpl $datobs/${prefix_obs}.nsstbufr ./nsstbufr
+else
+ $ncpl $datobsur/${prefix_obs}.prepbufr ./prepbufr
+ $ncpl $datobsur/${prefix_obs}.saphir.${suffix} ./saphirbufr
+fi
+# use GNSSRO obs with DO-1 included from Kristen if available
+if [[ -f "$gpsobs" ]]; then
+ $ncpl $gpsobs ./gpsrobufr
+else
+ $ncpl $datobs/${prefix_obs}.gpsro.${suffix} ./gpsrobufr
+fi
+$ncpl $datobs/${prefix_obs}.satwnd.${suffix} ./satwndbufr
+$ncpl $datobs/${prefix_obs}.spssmi.${suffix} ./ssmirrbufr
+$ncpl $datobs/${prefix_obs}.sptrmm.${suffix} ./tmirrbufr
+$ncpl $datobs/${prefix_obs}.osbuv8.${suffix} ./sbuvbufr
+$ncpl $datobs/${prefix_obs}.goesfv.${suffix} ./gsnd1bufr
+$ncpl $datobs/${prefix_obs}.1bamua.${suffix} ./amsuabufr
+$ncpl $datobs/${prefix_obs}.1bamub.${suffix} ./amsubbufr
+$ncpl $datobs/${prefix_obs}.1bhrs2.${suffix} ./hirs2bufr
+$ncpl $datobs/${prefix_obs}.1bhrs3.${suffix} ./hirs3bufr
+$ncpl $datobs/${prefix_obs}.1bhrs4.${suffix} ./hirs4bufr
+$ncpl $datobs/${prefix_obs}.1bmhs.${suffix} ./mhsbufr
+$ncpl $datobs/${prefix_obs}.1bmsu.${suffix} ./msubufr
+$ncpl $datobs/${prefix_obs}.airsev.${suffix} ./airsbufr
+$ncpl $datobs/${prefix_obs}.sevcsr.${suffix} ./seviribufr
+$ncpl $datobs/${prefix_obs}.mtiasi.${suffix} ./iasibufr
+$ncpl $datobs/${prefix_obs}.ssmit.${suffix} ./ssmitbufr
+$ncpl $datobs/${prefix_obs}.ssmisu.${suffix} ./ssmisbufr
+$ncpl $datobs/${prefix_obs}.gome.${suffix} ./gomebufr
+$ncpl $datobs/${prefix_obs}.omi.${suffix} ./omibufr
+$ncpl $datobs/${prefix_obs}.mls.${suffix} ./mlsbufr
+$ncpl $datobs/${prefix_obs}.ompsn8.${suffix} ./ompsnpbufr
+$ncpl $datobs/${prefix_obs}.ompst8.${suffix} ./ompstcbufr
+$ncpl $datobs/${prefix_obs}.eshrs3.${suffix} ./hirs3bufrears
+$ncpl $datobs/${prefix_obs}.esamua.${suffix} ./amsuabufrears
+$ncpl $datobs/${prefix_obs}.esamub.${suffix} ./amsubbufrears
+$ncpl $datobs/${prefix_obs}.atms.${suffix} ./atmsbufr
+$ncpl $datobs/${prefix_obs}.cris.${suffix} ./crisbufr
+$ncpl $datobs/${prefix_obs}.crisf4.${suffix} ./crisfsbufr
+$ncpl $datobs/${prefix_obs}.syndata.tcvitals.tm00 ./tcvitl
+$ncpl $datobs/${prefix_obs}.avcsam.${suffix} ./avhambufr
+$ncpl $datobs/${prefix_obs}.avcspm.${suffix} ./avhpmbufr
+$ncpl $datobs/${prefix_obs}.gmi1cr.${suffix} ./gmibufr
+$ncpl $datobs/${prefix_obs}.esiasi.${suffix} ./iasibufrears
+$ncpl $datobs/${prefix_obs}.hrs3db.${suffix} ./hirs3bufr_db
+$ncpl $datobs/${prefix_obs}.amuadb.${suffix} ./amsuabufr_db
+$ncpl $datobs/${prefix_obs}.amubdb.${suffix} ./amsubbufr_db
+$ncpl $datobs/${prefix_obs}.iasidb.${suffix} ./iasibufr_db
+$ncpl $datobs/${prefix_obs}.crisdb.${suffix} ./crisbufr_db
+$ncpl $datobs/${prefix_obs}.atmsdb.${suffix} ./atmsbufr_db
+$ncpl $datobs/${prefix_obs}.escris.${suffix} ./crisbufrears
+$ncpl $datobs/${prefix_obs}.esatms.${suffix} ./atmsbufrears
+$ncpl $datobs/${prefix_obs}.gsrcsr.${suffix} ./abibufr
+$ncpl $datobs/${prefix_obs}.ahicsr.${suffix} ./ahibufr
+
+## copy gsistats
+$ncpl $datges/${prefix_obs}.gsistat ./gsistat
+
+## copy bias correction, atmospheric and surface files
+$ncpl $datbias/${prefix_ges}.abias ./satbias_in
+$ncpl $datbias/${prefix_ges}.abias_pc ./satbias_pc
+$ncpl $datbias/${prefix_ges}.abias_air ./aircftbias_in
+
+nhr_obsbin=$GSI_background_nhr
+if [[ "$GSI_background_nhr" = "1" ]]; then
+ $ncpl $datges/${prefix_ges}.sfcf003$SUFFIX ./sfcf03
+ $ncpl $datges/${prefix_ges}.sfcf004$SUFFIX ./sfcf04
+ $ncpl $datges/${prefix_ges}.sfcf005$SUFFIX ./sfcf05
+ $ncpl $datges/${prefix_ges}.sfcf006$SUFFIX ./sfcf06
+ $ncpl $datges/${prefix_ges}.sfcf007$SUFFIX ./sfcf07
+ $ncpl $datges/${prefix_ges}.sfcf008$SUFFIX ./sfcf08
+ $ncpl $datges/${prefix_ges}.sfcf009$SUFFIX ./sfcf09
+ $ncpl $datges/${prefix_ges}.atmf003$SUFFIX ./sigf03
+ $ncpl $datges/${prefix_ges}.atmf004$SUFFIX ./sigf04
+ $ncpl $datges/${prefix_ges}.atmf005$SUFFIX ./sigf05
+ $ncpl $datges/${prefix_ges}.atmf006$SUFFIX ./sigf06
+ $ncpl $datges/${prefix_ges}.atmf007$SUFFIX ./sigf07
+ $ncpl $datges/${prefix_ges}.atmf008$SUFFIX ./sigf08
+ $ncpl $datges/${prefix_ges}.atmf009$SUFFIX ./sigf09
+elif [[ "$GSI_background_nhr" = "3" ]]; then
+ $ncpl $datges/${prefix_ges}.sfcf003$SUFFIX ./sfcf03
+ $ncpl $datges/${prefix_ges}.atmf003$SUFFIX ./sigf03
+ $ncpl $datges/${prefix_ges}.sfcf006$SUFFIX ./sfcf06
+ $ncpl $datges/${prefix_ges}.atmf006$SUFFIX ./sigf06
+ $ncpl $datges/${prefix_ges}.sfcf009$SUFFIX ./sfcf09
+ $ncpl $datges/${prefix_ges}.atmf009$SUFFIX ./sigf09
+else
+ $ncpl $datges/${prefix_ges}.sfcf006$SUFFIX ./sfcf06
+ $ncpl $datges/${prefix_ges}.atmf006$SUFFIX ./sigf06
+ nhr_obsbin=6
+fi
+
+## create GSI namelist
+cat > gsiparm.anl << EOF
+&SETUP
+ miter=0,
+ niter(1)=1,niter(2)=1,
+ niter_no_qc(1)=50,niter_no_qc(2)=0,
+ write_diag(1)=.true.,write_diag(2)=.false.,
+ qoption=2,
+ gencode=0,deltim=94.,
+ factqmin=0.5,factqmax=0.0002,
+ iguess=-1,
+ tzr_qc=1,
+ oneobtest=.false.,retrieval=.false.,l_foto=.false.,
+ use_pbl=.false.,use_compress=.true.,nsig_ext=56,gpstop=55.,commgpstop=45.,
+ thin4d=.true.,
+ use_gfs_nemsio=${use_gfs_nemsio},use_gfs_ncio=${use_gfs_ncio},sfcnst_comb=.true.,
+ use_readin_anl_sfcmask=.false.,
+ lrun_subdirs=.true.,
+ crtm_coeffs_path='./crtm_coeffs/',
+ newpc4pred=.true.,adp_anglebc=.true.,angord=4,passive_bc=.true.,use_edges=.false.,
+ diag_precon=.true.,step_start=1.e-3,emiss_bc=.true.,nhr_obsbin=${nhr_obsbin:-3},
+ cwoption=3,imp_physics=11,lupp=.true.,cnvw_option=.false., ta2tb=.false.,
+ netcdf_diag=.true.,binary_diag=.false.,
+ lobsdiag_forenkf=.false.,
+ write_fv3_incr=.true.,
+ $SETUP
+/
+&GRIDOPTS
+ JCAP_B=$JCAP_B,JCAP=$JCAP,NLAT=$NLAT,NLON=$NLON,nsig=$LEVS,
+ regional=.false.,nlayers(63)=1,nlayers(64)=1,
+ $GRIDOPTS
+/
+&BKGERR
+ vs=0.7,
+ hzscl=1.7,0.8,0.5,
+ hswgt=0.45,0.3,0.25,
+ bw=0.0,norsp=4,
+ bkgv_flowdep=.true.,bkgv_rewgtfct=1.5,
+ bkgv_write=.false.,
+ cwcoveqqcov=.false.,
+ $BKGVERR
+/
+&ANBKGERR
+ anisotropic=.false.,
+ $ANBKGERR
+/
+&JCOPTS
+ ljcdfi=.false.,alphajc=0.0,ljcpdry=.true.,bamp_jcpdry=5.0e7,
+ $JCOPTS
+/
+&STRONGOPTS
+ tlnmc_option=2,nstrong=1,nvmodes_keep=8,period_max=6.,period_width=1.5,
+ $STRONGOPTS
+/
+&OBSQC
+ dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.04,
+ use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.false.,nvqc=.true.,
+ aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true.,
+ tcp_width=70.0,tcp_ermax=7.35,
+ $OBSQC
+/
+&OBS_INPUT
+ dmesh(1)=145.0,dmesh(2)=150.0,dmesh(3)=100.0,dmesh(4)=580,time_window_max=3.0,
+ $OBSINPUT
+/
+OBS_INPUT::
+! dfile dtype dplat dsis dval dthin dsfcalc
+ prepbufr ps null ps 0.0 0 0
+ prepbufr t null t 0.0 0 0
+ prepbufr_profl t null t 0.0 0 0
+ prepbufr q null q 0.0 0 0
+ prepbufr_profl q null q 0.0 0 0
+ prepbufr pw null pw 0.0 0 0
+ prepbufr uv null uv 0.0 0 0
+ prepbufr_profl uv null uv 0.0 0 0
+ satwndbufr uv null uv 0.0 0 0
+# prepbufr spd null spd 0.0 0 0
+# prepbufr dw null dw 0.0 0 0
+# radarbufr rw null rw 0.0 0 0
+# nsstbufr sst nsst sst 0.0 0 0
+ gpsrobufr gps_bnd null gps 0.0 0 0
+# ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0
+# tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0
+# sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0
+# sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0
+# sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0
+# hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0
+# hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 1 0
+# gimgrbufr goes_img g11 imgr_g11 0.0 1 0
+# gimgrbufr goes_img g12 imgr_g12 0.0 1 0
+# airsbufr airs aqua airs_aqua 0.0 1 0
+ amsuabufr amsua n15 amsua_n15 0.0 1 0
+ amsuabufr amsua n18 amsua_n18 0.0 1 0
+ amsuabufr amsua metop-a amsua_metop-a 0.0 1 0
+ airsbufr amsua aqua amsua_aqua 0.0 1 0
+ amsubbufr amsub n17 amsub_n17 0.0 1 0
+ mhsbufr mhs n18 mhs_n18 0.0 1 0
+ mhsbufr mhs metop-a mhs_metop-a 0.0 1 0
+ ssmitbufr ssmi f15 ssmi_f15 0.0 1 0
+# amsrebufr amsre_low aqua amsre_aqua 0.0 1 0
+# amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0
+# amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0
+ ssmisbufr ssmis f16 ssmis_f16 0.0 1 0
+ ssmisbufr ssmis f17 ssmis_f17 0.0 1 0
+ ssmisbufr ssmis f18 ssmis_f18 0.0 1 0
+ gsnd1bufr sndrd1 g12 sndrD1_g12 0.0 1 0
+ gsnd1bufr sndrd2 g12 sndrD2_g12 0.0 1 0
+ gsnd1bufr sndrd3 g12 sndrD3_g12 0.0 1 0
+ gsnd1bufr sndrd4 g12 sndrD4_g12 0.0 1 0
+ gsnd1bufr sndrd1 g11 sndrD1_g11 0.0 1 0
+ gsnd1bufr sndrd2 g11 sndrD2_g11 0.0 1 0
+ gsnd1bufr sndrd3 g11 sndrD3_g11 0.0 1 0
+ gsnd1bufr sndrd4 g11 sndrD4_g11 0.0 1 0
+ gsnd1bufr sndrd1 g13 sndrD1_g13 0.0 1 0
+ gsnd1bufr sndrd2 g13 sndrD2_g13 0.0 1 0
+ gsnd1bufr sndrd3 g13 sndrD3_g13 0.0 1 0
+ gsnd1bufr sndrd4 g13 sndrD4_g13 0.0 1 0
+ iasibufr iasi metop-a iasi_metop-a 0.0 4 0
+ gomebufr gome metop-a gome_metop-a 0.0 2 0
+ omibufr omi aura omi_aura 0.0 2 0
+ sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0
+# hirs4bufr hirs4 n19 hirs4_n19 0.0 1 0
+ amsuabufr amsua n19 amsua_n19 0.0 1 0
+ mhsbufr mhs n19 mhs_n19 0.0 1 0
+ tcvitl tcp null tcp 0.0 0 0
+ seviribufr seviri m08 seviri_m08 0.0 1 0
+ seviribufr seviri m09 seviri_m09 0.0 1 0
+ seviribufr seviri m10 seviri_m10 0.0 1 0
+ seviribufr seviri m11 seviri_m11 0.0 1 0
+# hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 1 0
+ amsuabufr amsua metop-b amsua_metop-b 0.0 1 0
+ mhsbufr mhs metop-b mhs_metop-b 0.0 1 0
+ iasibufr iasi metop-b iasi_metop-b 0.0 4 0
+# gomebufr gome metop-b gome_metop-b 0.0 2 0
+ atmsbufr atms npp atms_npp 0.0 1 0
+ atmsbufr atms n20 atms_n20 0.0 1 0
+ atmsbufr atms n21 atms_n21 0.0 1 0
+# crisbufr cris npp cris_npp 0.0 4 0
+# crisfsbufr cris-fsr npp cris-fsr_npp 0.0 4 0
+ crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 4 0
+ crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 4 0
+# gsnd1bufr sndrd1 g14 sndrD1_g14 0.0 1 0
+# gsnd1bufr sndrd2 g14 sndrD2_g14 0.0 1 0
+# gsnd1bufr sndrd3 g14 sndrD3_g14 0.0 1 0
+# gsnd1bufr sndrd4 g14 sndrD4_g14 0.0 1 0
+# gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0
+# gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0
+# gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0
+# gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0
+# oscatbufr uv null uv 0.0 0 0
+# mlsbufr mls30 aura mls30_aura 0.0 0 0
+ avhambufr avhrr metop-a avhrr3_metop-a 0.0 1 0
+ avhpmbufr avhrr n18 avhrr3_n18 0.0 1 0
+ avhambufr avhrr metop-b avhrr3_metop-b 0.0 1 0
+ avhpmbufr avhrr n19 avhrr3_n19 0.0 1 0
+ amsr2bufr amsr2 gcom-w1 amsr2_gcom-w1 0.0 3 0
+ gmibufr gmi gpm gmi_gpm 0.0 3 0
+ saphirbufr saphir meghat saphir_meghat 0.0 3 0
+ ahibufr ahi himawari8 ahi_himawari8 0.0 1 0
+ abibufr abi g16 abi_g16 0.0 1 0
+ abibufr abi g17 abi_g17 0.0 1 0
+ abibufr abi g18 abi_g18 0.0 1 0
+# rapidscatbufr uv null uv 0.0 0 0
+ ompsnpbufr ompsnp npp ompsnp_npp 0.0 0 0
+ ompstcbufr ompstc8 npp ompstc8_npp 0.0 2 0
+ amsuabufr amsua metop-c amsua_metop-c 0.0 1 0
+ mhsbufr mhs metop-c mhs_metop-c 0.0 1 0
+ iasibufr iasi metop-c iasi_metop-c 0.0 4 0
+::
+&SUPEROB_RADAR
+ $SUPERRAD
+/
+&LAG_DATA
+ $LAGDATA
+/
+&HYBRID_ENSEMBLE
+ l_hyb_ens=.false.,
+ generate_ens=.false.,
+ beta_s0=0.125,readin_beta=.false.,
+ s_ens_h=800.,s_ens_v=-0.8,readin_localization=.true.,
+ aniso_a_en=.false.,oz_univ_static=.false.,uv_hyb_ens=.true.,
+ ensemble_path='./ensemble_data/',
+ ens_fast_read=.true.,
+ $HYBRID_ENSEMBLE
+/
+&RAPIDREFRESH_CLDSURF
+ dfi_radar_latent_heat_time_period=30.0,
+ $RAPIDREFRESH_CLDSURF
+/
+&CHEM
+ $CHEM
+/
+&SINGLEOB_TEST
+ maginnov=0.1,magoberr=0.1,oneob_type='t',
+ oblat=45.,oblon=180.,obpres=1000.,obdattim=${adate},
+ obhourset=0.,
+ $SINGLEOB
+/
+&NST
+ nst_gsi=0,
+ nstinfo=4,fac_dtl=1,fac_tsl=1,zsea1=0,zsea2=0,
+ $NSST
+/
+EOF
+cat gsiparm.anl
+
+## run GSI observer
+export OMP_NUM_THREADS=1
+$APRUN_GSI ./gsi.x > gsi.stdout || exit 1
+
+## cat diags
+ntype=3
+numfile[0]=0
+numfile[1]=0
+numfile[2]=0
+numfile[3]=0
+diagtype[0]="conv conv_gps conv_ps conv_q conv_sst conv_t conv_uv"
+diagtype[1]="pcp_ssmi_dmsp pcp_tmi_trmm"
+diagtype[2]="sbuv2_n16 sbuv2_n17 sbuv2_n18 sbuv2_n19 gome_metop-a gome_metop-b omi_aura mls30_aura ompsnp_npp
+ompstc8_npp"
+diagtype[3]="msu_n14 sndr_g08 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g12 sndrd2_g12 sndrd3_g12 sndrd4_g12 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 sndrd1_g14 sndrd2_g14 sndrd3_g14 sndrd4_g14 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 amsua_n15 amsua_n16 amsua_n17 amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 imgr_g14 imgr_g15 ssmi_f13 ssmi_f15 amsua_n18 amsua_metop-a mhs_n18 mhs_metop-a amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_f16 ssmis_f17 ssmis_f18 ssmis_f19 ssmis_f20 iasi_metop-a amsua_n19 mhs_n19 seviri_m08 seviri_m09 seviri_m10 seviri_m11 cris_npp cris-fsr_npp cris-fsr_n20 atms_npp atms_n20 amsua_metop-b mhs_metop-b iasi_metop-b avhrr_metop-b avhrr_n18 avhrr_n19 avhrr_metop-a amsr2_gcom-w1 gmi_gpm saphir_meghat ahi_himawari8 abi_g16 abi_g17 amsua_metop-c mhs_metop-c iasi_metop-c avhrr_metop-c viirs-m_npp viirs-m_j1 abi_g18 ahi_himawari9 viirs-m_j2 cris-fsr_n21 atms_n21"
+
+prefix=" dir.*/"
+loops="01"
+for loop in $loops; do
+ case $loop in
+ 01) string=ges;;
+ 03) string=anl;;
+ *) string=$loop;;
+ esac
+ echo $(date) START loop $string >&2
+ n=-1
+ while [ $((n+=1)) -le $ntype ] ;do
+ for type in $(echo ${diagtype[n]}); do
+ count=$(ls ${prefix}${type}_${loop}* | wc -l)
+ if [ $count -gt 0 ]; then
+ file=diag_${type}_${string}.${adate}.nc4
+ # note if the GSI utility is not working correctly, use the python version
+ # same syntax is used to call it, just change what $nccat is
+ $nccat -o $file ${prefix}${type}_${loop}.nc4 &
+ sleep 5
+ echo "diag_${type}_${string}.${adate}*" >> ${diaglist[n]}
+ numfile[n]=$(expr ${numfile[n]} + 1)
+ fi
+ done
+ done
+ echo $(date) END loop $string >&2
+done
+wait
+
+cat `echo fort.*` > gsistat.out
+
+mkdir -p $workdir/diags
+mv diag_* $workdir/diags
+
+## cannot let rstprod data become readable by all
+if [[ "$rstprod" = "true" ]]; then
+ chgrp rstprod $workdir/diags/diag_*
+ chmod 640 $workdir/diags/diag_*
+fi
+
+date
+set +x
+module purge
+set -x
+echo "GSI observer script completed"
+cd $workdir
+echo "Submitting IODA converters script"
+sbatch $GSIDIR/ush/run_observer/iodaconv.sh $GDASApp $workdir $adate
diff --git a/ush/run_observer/iodaconv.sh b/ush/run_observer/iodaconv.sh
new file mode 100755
index 0000000000..94a6db9e07
--- /dev/null
+++ b/ush/run_observer/iodaconv.sh
@@ -0,0 +1,67 @@
+#!/bin/bash
+#SBATCH -J iodaconv
+#SBATCH -o iodaconv.o%j
+#SBATCH -A da-cpu
+#SBATCH -q batch
+#SBATCH -p orion
+#SBATCH --nodes=1
+#SBATCH --exclusive
+#SBATCH -t 1:30:00
+# run python ioda-iodaconverters
+# on GSI netCDF diag files to generate
+# IODA formatted observations for UFO H(x)
+# cory.r.martin@noaa.gov
+set -x
+
+GDASApp=$1
+workdir=$2
+adate=$3
+
+# source modulefile to get proper python on environment
+module purge
+module use $GDASApp/modulefiles
+module load GDAS/$MACHINE
+module list
+
+# executable paths
+IODA_iodaconv_iodaconvbin=$GDASApp/build/bin/proc_gsi_ncdiag.py
+IODA_iodaconv_iodacombinebin=$GDASApp/build/bin/combine_obsspace.py
+#IODA_iodaconv_iodaconvgnssrobin=$GDASApp/build/bin/gnssro_gsidiag2ioda
+
+# make working directory
+IODA_data_iodaworkdir=$workdir/iodawork
+rm -rf $IODA_data_iodaworkdir
+mkdir -p $IODA_data_iodaworkdir
+cd $IODA_data_iodaworkdir
+
+# make output directory
+IODA_data_iodaoutdir=$workdir/ioda
+rm -rf $IODA_data_iodaoutdir/obs
+mkdir -p $IODA_data_iodaoutdir/obs
+rm -rf $IODA_data_iodaoutdir/geovals
+mkdir -p $IODA_data_iodaoutdir/geovals
+
+#export PYTHONPATH=$GDASApp/build/lib/python3.7/pyioda:$PYTHONPATH
+#export PYTHONPATH=$GDASApp/build/lib/pyiodaconv:$PYTHONPATH
+export PYTHONPATH=$GDASApp/build/lib/python3.7:$PYTHONPATH
+export PYTHONPATH=$GDASApp/build/lib/python3.7/pyiodaconv:$PYTHONPATH
+#export PYTHONPATH=$GDASApp/iodaconv/src:$PYTHONPATH
+#export PYTHONPATH=$PYTHONPATH:$GDASApp/iodaconv/src
+
+#
+# run script to generate IODA obs files
+$IODA_iodaconv_iodaconvbin -o $IODA_data_iodaoutdir/obs -g $IODA_data_iodaoutdir/geovals $workdir/diags
+#
+# concatenate these files together
+python $IODA_iodaconv_iodacombinebin -i $IODA_data_iodaoutdir/obs/sfc_*.nc4 -o $IODA_data_iodaoutdir/obs/sfc_obs_"$adate".nc4 -g $IODA_data_iodaoutdir/geovals
+python $IODA_iodaconv_iodacombinebin -i $IODA_data_iodaoutdir/obs/sfcship_*.nc4 -o $IODA_data_iodaoutdir/obs/sfcship_obs_"$adate".nc4 -g $IODA_data_iodaoutdir/geovals
+python $IODA_iodaconv_iodacombinebin -i $IODA_data_iodaoutdir/obs/aircraft_*.nc4 -o $IODA_data_iodaoutdir/obs/aircraft_obs_"$adate".nc4 -g $IODA_data_iodaoutdir/geovals
+python $IODA_iodaconv_iodacombinebin -i $IODA_data_iodaoutdir/obs/sondes_ps*.nc4 $IODA_data_iodaoutdir/obs/sondes_q*.nc4 $IODA_data_iodaoutdir/obs/sondes_tsen*.nc4 $IODA_data_iodaoutdir/obs/sondes_tv*.nc4 $IODA_data_iodaoutdir/obs/sondes_uv*.nc4 -o $IODA_data_iodaoutdir/obs/sondes_obs_"$adate".nc4 -g $IODA_data_iodaoutdir/geovals
+python $IODA_iodaconv_iodacombinebin -i $IODA_data_iodaoutdir/obs/sondes_ps*.nc4 $IODA_data_iodaoutdir/obs/sondes_q*.nc4 $IODA_data_iodaoutdir/obs/sondes_tv*.nc4 $IODA_data_iodaoutdir/obs/sondes_uv*.nc4 -o $IODA_data_iodaoutdir/obs/sondes_tvirt_obs_"$adate".nc4 -g $IODA_data_iodaoutdir/geovals
+
+# gnssro converter
+#ln -sf $IODA_data_iodaoutdir/obs/gnssro_obs_${adate}.nc4 ./gnssro_obs_${adate}.nc4
+#$IODA_iodaconv_iodaconvgnssrobin $adate $IODA_data_gsiindir/diag_conv_gps_* 1
+
+date
+echo "GSI ncdiag ioda converter script completed"
diff --git a/ush/run_observer/submit_gsi_observer.sh b/ush/run_observer/submit_gsi_observer.sh
new file mode 100755
index 0000000000..2d9dfcecbd
--- /dev/null
+++ b/ush/run_observer/submit_gsi_observer.sh
@@ -0,0 +1,57 @@
+#!/bin/bash
+# submit_gsi_observer.sh
+# script to define configuration,
+# prepare, and submit GSI observer job
+# cory.r.martin@noaa.gov
+
+set -x
+
+#---- user modified variables
+# valid time
+cycle=2024021900
+# path to your GSI clone
+THISDIR=`pwd`
+GSIDIR=$THISDIR/../..
+# top level working directory
+workdir=/work2/noaa/da/$LOGNAME/ufoeval/GSIobserver/orion/$cycle/
+# GDASApp clone
+#GDASApp=/work2/noaa/da/$LOGNAME/git/GDASApp
+GDASApp=/work2/noaa/da/$LOGNAME/git/orion/GDASApp
+MACHINE=orion
+
+# gfs or gdas
+dump=gdas
+# restricted data inclusion
+rstprod="true"
+# 6 for 3d, 1 or 3 for 4d
+nhr_bkg=6
+
+# should NOT touch below this line
+CRTM_FIX=/work/noaa/da/eliu/ORION/CRTM-fix/crtm_v2.4.1-jedi.1-fix_gdasapp
+# many people cannot clone this without gerrit permissions
+# plus, I have the C768 berror file here
+# so that GSI observer can run at full background res
+GSIFIX=/work2/noaa/da/cmartin/UFO_eval/geovals/GSI/fix
+dumpdir=/work/noaa/rstprod/dump
+gesroot=/work2/noaa/da/acollard/UFO_eval/data/para/output_ufo_eval_feb2024_9Aug
+
+mkdir -p $workdir
+cd $workdir
+cat > $workdir/config.sh << EOF
+export adate=$cycle
+export GSIDIR=$GSIDIR
+export workdir=$workdir
+export GSIFIX=$GSIFIX
+export dump=$dump
+export dumpdir=$dumpdir
+export gesroot=$gesroot
+export CRTM_FIX=$CRTM_FIX
+export rstprod=$rstprod
+export GSI_background_nhr=$nhr_bkg
+export GDASApp=$GDASApp
+export MACHINE=$MACHINE
+export LD_LIBRARY_PATH=/work/noaa/da/eliu/${MACHINE^^}/CRTM/crtm_v2.4.1-jedi.1/build/lib:${LD_LIBRARY_PATH}
+EOF
+
+#sbatch $GSIDIR/ush/run_observer/gsi_observer.sh $workdir/config.sh
+sbatch $GSIDIR/ush/run_observer/gsi_observer.sh $workdir/config.sh
diff --git a/ush/sub_discover b/ush/sub_discover
index 835cd37ace..5d6364be97 100755
--- a/ush/sub_discover
+++ b/ush/sub_discover
@@ -129,8 +129,8 @@ echo "export OMP_NUM_THREADS=$threads" >> $cfile
echo "" >>$cfile
echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile
echo "" >>$cfile
-echo "module use -a $gsisrc/modulefiles" >> $cfile
-echo "module load gsi_discover" >> $cfile
+echo "module use -a $modulefiles" >> $cfile
+echo "module load gsi_discover.intel" >> $cfile
echo "" >>$cfile
echo "jobname=$jobname" >>$cfile
echo "" >>$cfile
diff --git a/ush/sub_gaea b/ush/sub_gaea
new file mode 100755
index 0000000000..9c4e253c93
--- /dev/null
+++ b/ush/sub_gaea
@@ -0,0 +1,170 @@
+#!/bin/sh --login
+set -x
+usage="\
+Usage: $0 [options] executable [args]
+ where the options are:
+ -a account account (default: none)
+ -b binding run smt binding or not (default:NO)
+ -d dirin initial directory (default: cwd)
+ -e envars copy comma-separated environment variables
+ -g group group name
+ -i append standard input to command file
+ -j jobname specify jobname (default: executable basename)
+ -m machine machine on which to run (default: current)
+ -n write command file to stdout rather than submitting it
+ -o output specify output file (default: jobname.out)
+ -p procs[/nodes[/ppreq]
+ number of MPI tasks and optional nodes or Bblocking and
+ ppreq option (N or S) (defaults: serial, Bunlimited, S)
+ -q queue[/qpreq] queue name and optional requirement, e.g. dev/P
+ (defaults: 1 if serial or dev if parallel and none)
+ (queue 3 or 4 is dev or prod with twice tasks over ip)
+ (options: P=parallel, B=bigmem, b=batch)
+ -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1)
+ -t timew wall time limit in [[hh:]mm:]ss format (default: 900)
+ -u userid userid to run under (default: self)
+ -v verbose mode
+ -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or
+ Thh[mm] (full, incremental, today or tomorrow) format
+ (default: now)
+Function: This command submits a job to the batch queue."
+subcmd="$*"
+stdin=NO
+nosub=NO
+account=""
+binding="NO"
+dirin=""
+envars=""
+group=""
+jobname=""
+machine=""
+output=""
+procs=0
+nodes=""
+ppreq=""
+queue=""
+qpreq=""
+rmem="1024"
+rcpu="1"
+timew="900"
+userid=""
+verbose=NO
+when=""
+while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do
+ case $opt in
+ a) account="$OPTARG";;
+ b) binding="$OPTARG";;
+ d) dirin="$OPTARG";;
+ e) envars="$OPTARG";;
+ g) group="$OPTARG";;
+ i) stdin=YES;;
+ j) jobname=$OPTARG;;
+ m) machine="$OPTARG";;
+ n) nosub=YES;;
+ o) output=$OPTARG;;
+ p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);;
+ q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);;
+ r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);;
+ t) timew=$OPTARG;;
+ u) userid=$OPTARG;;
+ v) verbose=YES;;
+ w) when=$OPTARG;;
+ \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;;
+ esac
+done
+shift $(($OPTIND-1))
+if [[ $# -eq 0 ]];then
+ echo $0: missing executable name >&2;echo "$usage" >&2;exit 1
+fi
+exec=$1
+if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then
+ exec=$(which $exec)
+fi
+shift
+args="$*"
+bn=$(basename $exec)
+export jobname=${jobname:-$bn}
+output=${output:-$jobname.out}
+myuser=$LOGNAME
+myhost=$(hostname)
+
+if [ -d /gpfs/f5/epic/scratch/${USER}/$LOGNAME ]; then
+ DATA=/gpfs/f5/epic/scratch/${USER}/$LOGNAME/tmp
+fi
+DATA=${DATA:-$ptmp/tmp}
+
+mkdir -p $DATA
+
+queue=${queue:-batch}
+timew=${timew:-01:20:00}
+task_node=${task_node:-$procs}
+size=$((nodes*task_node))
+envars=$envars
+threads=${rcpu:-1}
+
+export TZ=GMT
+cfile=$DATA/sub$$
+> $cfile
+echo "#!/bin/bash -l" >> $cfile
+echo "" >> $cfile
+echo "#SBATCH --output=$output" >> $cfile
+echo "#SBATCH --job-name=$jobname" >> $cfile
+echo "#SBATCH --qos=$queue" >> $cfile
+echo "#SBATCH --clusters=c5" >> $cfile
+echo "#SBATCH --time=$timew" >> $cfile
+echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile
+echo "#SBATCH --account=$accnt" >> $cfile
+echo "#SBATCH --mem=0" >> $cfile
+
+echo "" >>$cfile
+echo "export ntasks=$(( $nodes * $procs ))" >> $cfile
+echo "export ppn=$procs" >> $cfile
+echo "export threads=$threads" >> $cfile
+echo "export OMP_NUM_THREADS=$threads" >> $cfile
+echo "ulimit -s unlimited" >> $cfile
+
+echo "" >>$cfile
+echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile
+echo "" >>$cfile
+
+echo "module reset" >> $cfile
+echo "module use $modulefiles" >> $cfile
+echo "module load gsi_gaea.intel" >> $cfile
+echo "module list" >> $cfile
+echo "" >>$cfile
+
+cat $exec >> $cfile
+
+if [[ $nosub = YES ]];then
+ cat $cfile
+ exit
+elif [[ $verbose = YES ]];then
+ set -x
+ cat $cfile
+fi
+
+if [[ $stdin = YES ]];then
+ cat
+fi >>$cfile
+if [[ $nosub = YES ]];then
+ cat $cfile
+ exit
+elif [[ $verbose = YES ]];then
+ set -x
+ cat $cfile
+fi
+sbatch=${sbatch:-sbatch}
+
+ofile=$DATA/subout$$
+>$ofile
+chmod 777 $ofile
+$sbatch $cfile >$ofile
+rc=$?
+cat $ofile
+if [[ -w $SUBLOG ]];then
+ jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2)
+ date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG
+fi
+rm $cfile $ofile
+[[ $MKDATA = YES ]] && rmdir $DATA
+exit $rc
diff --git a/ush/sub_hera b/ush/sub_hera
index d904417190..c94b734596 100755
--- a/ush/sub_hera
+++ b/ush/sub_hera
@@ -120,10 +120,10 @@ echo "#SBATCH --output=$output"
echo "#SBATCH --job-name=$jobname" >> $cfile
echo "#SBATCH --qos=$queue" >> $cfile
echo "#SBATCH --time=$timew" >> $cfile
-echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile
+echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile
#echo "#SBATCH -j oe" >> $cfile
echo "#SBATCH --account=$accnt" >> $cfile
-echo "#SBATCH --mem=0" >> $cfile
+#cltorg echo "#SBATCH --mem=0" >> $cfile
#echo "#SBATCH -V" >> $cfile
#echo "#PBS -d" >> $cfile
#. $exec >> $cfile
@@ -137,13 +137,12 @@ echo "" >>$cfile
echo ". /apps/lmod/lmod/init/sh" >> $cfile
echo "module purge" >> $cfile
-echo "module use $gsisrc/modulefiles" >> $cfile
+echo "module use $modulefiles" >> $cfile
echo "module load gsi_hera.intel" >> $cfile
echo "module list" >> $cfile
echo "" >>$cfile
cat $exec >> $cfile
-
if [[ $nosub = YES ]];then
cat $cfile
exit
diff --git a/ush/sub_hercules b/ush/sub_hercules
new file mode 100755
index 0000000000..78a0f5daee
--- /dev/null
+++ b/ush/sub_hercules
@@ -0,0 +1,170 @@
+#!/bin/sh --login
+set -x
+usage="\
+Usage: $0 [options] executable [args]
+ where the options are:
+ -a account account (default: none)
+ -b binding run smt binding or not (default:NO)
+ -d dirin initial directory (default: cwd)
+ -e envars copy comma-separated environment variables
+ -g group group name
+ -i append standard input to command file
+ -j jobname specify jobname (default: executable basename)
+ -m machine machine on which to run (default: current)
+ -n write command file to stdout rather than submitting it
+ -o output specify output file (default: jobname.out)
+ -p procs[/nodes[/ppreq]
+ number of MPI tasks and optional nodes or Bblocking and
+ ppreq option (N or S) (defaults: serial, Bunlimited, S)
+ -q queue[/qpreq] queue name and optional requirement, e.g. dev/P
+ (defaults: 1 if serial or dev if parallel and none)
+ (queue 3 or 4 is dev or prod with twice tasks over ip)
+ (options: P=parallel, B=bigmem, b=batch)
+ -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1)
+ -t timew wall time limit in [[hh:]mm:]ss format (default: 900)
+ -u userid userid to run under (default: self)
+ -v verbose mode
+ -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or
+ Thh[mm] (full, incremental, today or tomorrow) format
+ (default: now)
+Function: This command submits a job to the batch queue."
+subcmd="$*"
+stdin=NO
+nosub=NO
+account=""
+binding="NO"
+dirin=""
+envars=""
+group=""
+jobname=""
+machine=""
+output=""
+procs=0
+nodes=""
+ppreq=""
+queue=""
+qpreq=""
+rmem="1024"
+rcpu="1"
+timew="900"
+userid=""
+verbose=NO
+when=""
+while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do
+ case $opt in
+ a) account="$OPTARG";;
+ b) binding="$OPTARG";;
+ d) dirin="$OPTARG";;
+ e) envars="$OPTARG";;
+ g) group="$OPTARG";;
+ i) stdin=YES;;
+ j) jobname=$OPTARG;;
+ m) machine="$OPTARG";;
+ n) nosub=YES;;
+ o) output=$OPTARG;;
+ p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);;
+ q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);;
+ r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);;
+ t) timew=$OPTARG;;
+ u) userid=$OPTARG;;
+ v) verbose=YES;;
+ w) when=$OPTARG;;
+ \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;;
+ esac
+done
+shift $(($OPTIND-1))
+if [[ $# -eq 0 ]];then
+ echo $0: missing executable name >&2;echo "$usage" >&2;exit 1
+fi
+exec=$1
+if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then
+ exec=$(which $exec)
+fi
+shift
+args="$*"
+bn=$(basename $exec)
+export jobname=${jobname:-$bn}
+output=${output:-$jobname.out}
+myuser=$LOGNAME
+myhost=$(hostname)
+exp=${jobname}
+
+DATA=${ptmp:-/work/noaa/da/stmp/$LOGNAME/tmp}
+mkdir -p $DATA
+
+#partition=${partition:-c1ms}
+queue=${queue:-batch}
+timew=${timew:-01:20:00}
+task_node=${task_node:-$procs}
+size=$((nodes*task_node))
+envars=$envars
+threads=${rcpu:-1}
+
+export TZ=GMT
+cfile=$DATA/sub$$
+> $cfile
+#echo "#PBS -S /bin/sh" >> $cfile
+echo "#!/bin/sh --login" >> $cfile
+echo "" >> $cfile
+echo "#SBATCH --output=$output" >> $cfile
+echo "#SBATCH --job-name=$jobname" >> $cfile
+echo "#SBATCH --qos=$queue" >> $cfile
+echo "#SBATCH --partition=$partition" >> $cfile
+echo "#SBATCH --time=$timew" >> $cfile
+echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile
+echo "#SBATCH --account=$accnt" >> $cfile
+
+echo "" >>$cfile
+echo "export ntasks=$(( $nodes * $procs ))" >> $cfile
+echo "export ppn=$procs" >> $cfile
+echo "export threads=$threads" >> $cfile
+echo "export OMP_NUM_THREADS=$threads" >> $cfile
+echo "ulimit -s unlimited" >> $cfile
+
+echo "" >>$cfile
+echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile
+echo "" >>$cfile
+
+echo ". /apps/other/lmod/lmod/init/sh" >> $cfile
+echo "module purge" >> $cfile
+echo "module use $modulefiles" >> $cfile
+echo "module load gsi_hercules.intel" >> $cfile
+#TODO reenable I_MPI_EXTRA_FILESYSTEM once regional ctests can properly handle parallel I/O on Hercules
+echo "unset I_MPI_EXTRA_FILESYSTEM" >> $cfile
+
+cat $exec >> $cfile
+
+if [[ $nosub = YES ]];then
+ cat $cfile
+ exit
+elif [[ $verbose = YES ]];then
+ set -x
+ cat $cfile
+fi
+
+
+if [[ $stdin = YES ]];then
+ cat
+fi >>$cfile
+if [[ $nosub = YES ]];then
+ cat $cfile
+ exit
+elif [[ $verbose = YES ]];then
+ set -x
+ cat $cfile
+fi
+sbatch=${sbatch:-sbatch}
+
+ofile=$DATA/subout$$
+>$ofile
+chmod 777 $ofile
+$sbatch --export=ALL $cfile >$ofile
+rc=$?
+cat $ofile
+if [[ -w $SUBLOG ]];then
+ jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2)
+ date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG
+fi
+rm $cfile $ofile
+[[ $MKDATA = YES ]] && rmdir $DATA
+exit $rc
diff --git a/ush/sub_jet b/ush/sub_jet
index 5bd9a6d68c..96f3eae9b2 100755
--- a/ush/sub_jet
+++ b/ush/sub_jet
@@ -88,7 +88,7 @@ output=${output:-$jobname.out}
myuser=$LOGNAME
myhost=$(hostname)
-DATA=$regdir/regtests/data
+DATA=${DATA:-$ptmp/tmp}
mkdir -p $DATA
@@ -98,41 +98,36 @@ task_node=${task_node:-$procs}
size=$((nodes*task_node))
envars=$envars
threads=${rcpu:-1}
-#envars=$envars,mpi_tasks=$procs
-#Options
-###PBS -l partition=c1ms,size=0528,walltime=01:20:00
-##PBS -l partition=$queue,size=$size,walltime=$timew
-##PBS -S /bin/sh
export TZ=GMT
cfile=$DATA/sub$$
> $cfile
-#echo "#PBS -S /bin/sh" >> $cfile
echo "#!/bin/sh --login" >> $cfile
echo "" >> $cfile
echo "#SBATCH --output=$output" >> $cfile
echo "#SBATCH --job-name=$jobname" >> $cfile
echo "#SBATCH --qos=$queue" >> $cfile
echo "#SBATCH --time=$timew" >> $cfile
-echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile
-#echo "#SBATCH -j oe" >> $cfile
+echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile
echo "#SBATCH --account=$accnt" >> $cfile
+echo "#SBATCH --mem=0" >> $cfile
echo "#SBATCH --partition=kjet" >> $cfile
-#echo "#SBATCH -V" >> $cfile
-#echo "#PBS -d" >> $cfile
-#. $exec >> $cfile
-#echo "/bin/sh -x $exec" >> $cfile
echo "" >>$cfile
+echo "export ntasks=$(( $nodes * $procs ))" >> $cfile
+echo "export ppn=$procs" >> $cfile
+echo "export threads=$threads" >> $cfile
echo "export OMP_NUM_THREADS=$threads" >> $cfile
+echo "ulimit -s unlimited" >> $cfile
+
echo "" >>$cfile
echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile
echo "" >>$cfile
echo ". /apps/lmod/lmod/init/sh" >> $cfile
echo "module purge" >> $cfile
-echo "module use $gsisrc/modulefiles" >> $cfile
-echo "module load gsi_jet" >> $cfile
+echo "module use $modulefiles" >> $cfile
+echo "module load gsi_jet.intel" >> $cfile
echo "module list" >> $cfile
echo "" >>$cfile
@@ -145,40 +140,6 @@ elif [[ $verbose = YES ]];then
set -x
cat $cfile
fi
-#msub -I partition=$partition,size=$procs,walltime=$walltime $cfile
-
-#if [[ -n $when ]];then
-# whena=$when
-# if [[ $when = +* ]];then
-# hr=$(echo $when|cut -c2-3)
-# mn=$(echo $when|cut -c4-5)
-# [[ -n $mn ]] || mn=00
-# now=$(date -u +"%Y%m%d%H%M")
-# ((mn+=$(echo $now|cut -c11-12)))
-# [[ $mn -ge 60 ]] && ((hr+=1)) && ((mn-=60))
-# [[ $mn -lt 10 ]] && mn=0$mn
-# whena=$(/nwprod/util/exec/ndate +$hr $(echo $now|cut -c1-10))$mn
-# elif [[ $when = t* ]];then
-# hr=$(echo $when|cut -c2-3)
-# mn=$(echo $when|cut -c4-5)
-# [[ -n $mn ]] || mn=00
-# now=$(date -u +"%Y%m%d")
-# whena=$now$hr$mn
-# elif [[ $when = T* ]];then
-# hr=$(echo $when|cut -c2-3)
-# mn=$(echo $when|cut -c4-5)
-# [[ -n $mn ]] || mn=00
-# now=$(date -u +"%Y%m%d%H")
-# whena=$(/nwprod/util/exec/ndate +24 $now|cut -c1-8)$hr$mn
-# fi
-# yr=$(echo $whena|cut -c1-4)
-# mo=$(echo $whena|cut -c5-6)
-# dy=$(echo $whena|cut -c7-8)
-# hr=$(echo $whena|cut -c9-10)
-# mn=$(echo $whena|cut -c11-12)
-# [[ -n $mn ]] || mn=00
-# echo "#@ startdate = $mo/$dy/$yr $hr:$mn"
-#fi >>$cfile
if [[ $stdin = YES ]];then
diff --git a/ush/sub_orion b/ush/sub_orion
index 065e7c8ab0..371c30e321 100755
--- a/ush/sub_orion
+++ b/ush/sub_orion
@@ -87,6 +87,7 @@ export jobname=${jobname:-$bn}
output=${output:-$jobname.out}
myuser=$LOGNAME
myhost=$(hostname)
+exp=${jobname}
DATA=${ptmp:-/work/noaa/da/stmp/$LOGNAME/tmp}
mkdir -p $DATA
@@ -108,28 +109,31 @@ echo ""
echo "#SBATCH --output=$output" >> $cfile
echo "#SBATCH --job-name=$jobname" >> $cfile
echo "#SBATCH --qos=$queue" >> $cfile
+echo "#SBATCH --partition=$partition" >> $cfile
echo "#SBATCH --time=$timew" >> $cfile
-echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile
+echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile
echo "#SBATCH --account=$accnt" >> $cfile
echo "" >>$cfile
+echo "set -x" >> $cfile
echo "export ntasks=$(( $nodes * $procs ))" >> $cfile
echo "export ppn=$procs" >> $cfile
echo "export threads=$threads" >> $cfile
echo "export OMP_NUM_THREADS=$threads" >> $cfile
-##echo "export OMP_STACKSIZE=2048M" >> $cfile
echo "ulimit -s unlimited" >> $cfile
echo "" >>$cfile
echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile
echo "" >>$cfile
-echo ". /apps/lmod/lmod/init/sh" >> $cfile
+echo ". /apps/other/lmod/lmod/init/sh" >> $cfile
echo "module purge" >> $cfile
-echo "module use $gsisrc/modulefiles" >> $cfile
-echo "module load gsi_orion" >> $cfile
+echo "module use $modulefiles" >> $cfile
+echo "module load gsi_orion.intel" >> $cfile
echo "module list" >> $cfile
-echo "" >> $cfile
+#TODO reenable I_MPI_EXTRA_FILESYSTEM once regional ctests can properly handle parallel I/O on Orion
+echo "unset I_MPI_EXTRA_FILESYSTEM" >> $cfile
+
cat $exec >> $cfile
if [[ $nosub = YES ]];then
diff --git a/ush/sub_wcoss2 b/ush/sub_wcoss2
index 57115ef7c6..cd21e932f8 100755
--- a/ush/sub_wcoss2
+++ b/ush/sub_wcoss2
@@ -123,19 +123,14 @@ echo "" >> $cfile
echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile
echo "" >> $cfile
-echo "module purge" >> $cfile
-echo "module load envvar/1.0" >> $cfile
-echo "module load PrgEnv-intel/8.2.0" >> $cfile
-echo "module load intel/19.1.3.304" >> $cfile
-echo "module load craype/2.7.13" >> $cfile
-echo "module load cray-mpich/8.1.12" >> $cfile
-echo "module load cray-pals/1.1.3" >> $cfile
-echo "module load prod_util/2.0.14" >> $cfile
-echo "module load prod_envir/2.0.6" >> $cfile
-echo "module load crtm/2.4.0" >> $cfile
-echo "module load cfp/2.0.4" >> $cfile
-echo "module load netcdf/4.7.4" >> $cfile
-echo "module list" >> $cfile
+echo "module reset" >> $cfile
+echo "module use $modulefiles" >> $cfile
+echo "module load gsi_wcoss2.intel" >> $cfile
+echo "module load envvar/1.0" >> $cfile
+echo "module load cray-pals/1.2.2" >> $cfile
+echo "module -t list 2>&1 | while read line;do module show $line 2>&1 | sed -n -e '2p';done | sort" >> $cfile
+echo "module avail" >> $cfile
+
echo "" >> $cfile
cat $exec >> $cfile