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 deacdff0b5..647904108e 100644
--- a/ci/spack.yaml
+++ b/ci/spack.yaml
@@ -7,19 +7,19 @@ spack:
- gcc@10:10
specs:
- netcdf-c@4.9.2
- - netcdf-fortran@4.6.0
+ - 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.4
- wrf-io@1.2.0
- ncio@1.1.2
- - crtm@2.4.0
- - gsi-ncdiag@1.1.1
+ - crtm@2.4.0.1
+ - gsi-ncdiag@1.1.2
view: true
concretizer:
unify: true
diff --git a/modulefiles/gsi_cheyenne.gnu.lua b/modulefiles/gsi_cheyenne.gnu.lua
deleted file mode 100644
index 1d903082a8..0000000000
--- a/modulefiles/gsi_cheyenne.gnu.lua
+++ /dev/null
@@ -1,32 +0,0 @@
-help([[
-]])
-
-
-unload("ncarenv/1.3")
-unload("intel/19.1.1")
-unload("ncarcompilers/0.5.0")
-unload("mpt/2.25")
-unload("netcdf/4.8.1")
-
-prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/spack-stack/cheyenne/spack-stack-1.4.1/envs/unified-env/install/modulefiles/Core")
-prepend_path("MODULEPATH", "/glade/work/jedipara/cheyenne/spack-stack/modulefiles/misc")
-
-local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12"
-local stack_gnu_ver=os.getenv("stack_gnu_ver") or "10.1.0"
-local stack_openmpi_ver=os.getenv("stack_openmpi_ver") or "4.1.1"
-local cmake_ver=os.getenv("cmake_ver") or "3.22.0"
-
-load(pathJoin("stack-gcc", stack_gnu_ver))
-load(pathJoin("stack-openmpi", stack_openmpi_ver))
-load(pathJoin("stack-python", stack_python_ver))
-load(pathJoin("cmake", cmake_ver))
-load(pathJoin("prod_util", os.getenv("prod_util_ver") or "1.2.2"))
-load(pathJoin("openblas", os.getenv("openblas_ver") or "0.3.23"))
-
-load("gsi_common")
-
-pushenv("CFLAGS", "-xHOST")
-pushenv("FFLAGS", "-xHOST")
-pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601")
-
-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 8c328e2b34..0000000000
--- a/modulefiles/gsi_cheyenne.intel.lua
+++ /dev/null
@@ -1,32 +0,0 @@
-help([[
-]])
-
-unload("ncarenv/1.3")
-unload("intel/19.1.1")
-unload("ncarcompilers/0.5.0")
-unload("mpt/2.25")
-unload("netcdf/4.8.1")
-
-prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/spack-stack/cheyenne/spack-stack-1.4.1/envs/unified-env/install/modulefiles/Core")
-prepend_path("MODULEPATH", "/glade/work/jedipara/cheyenne/spack-stack/modulefiles/misc")
-
-local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12"
-local stack_intel_ver=os.getenv("stack_intel_ver") or "19.1.1.217"
-local stack_mpi_ver=os.getenv("stack_mpi_ver") or "2019.7.217"
-local cmake_ver=os.getenv("cmake_ver") or "3.22.0"
-
-load(pathJoin("stack-intel", stack_intel_ver))
-load(pathJoin("stack-intel-mpi", stack_mpi_ver))
-load(pathJoin("stack-python", stack_python_ver))
-load(pathJoin("cmake", cmake_ver))
-
-load("gsi_common")
-load(pathJoin("prod-util", os.getenv("prod_util_ver") or "1.2.2"))
-pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230911")
-
-pushenv("CFLAGS", "-xHOST")
-pushenv("FFLAGS", "-xHOST")
-
-pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601")
-
-whatis("Description: GSI environment on Cheyenne with Intel Compilers")
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.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_gaea.lua b/modulefiles/gsi_gaea.lua
deleted file mode 100644
index ef6b9ddba7..0000000000
--- a/modulefiles/gsi_gaea.lua
+++ /dev/null
@@ -1,42 +0,0 @@
-help([[
-]])
-
-unload("intel")
-unload("cray-mpich")
-unload("cray-python")
-unload("darshan")
-
-prepend_path("MODULEPATH", "/lustre/f2/dev/wpo/role.epic/contrib/spack-stack/spack-stack-1.4.1-c4/envs/unified-env/install/modulefiles/Core")
-prepend_path("MODULEPATH", "/lustre/f2/pdata/esrl/gsd/spack-stack/modulefiles")
-
-local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12"
-local stack_intel_ver=os.getenv("stack_intel_ver") or "2022.0.2"
-local stack_cray_mpich_ver=os.getenv("stack_cray_mpich_ver") or "7.7.20"
-local cmake_ver=os.getenv("cmake_ver") or "3.23.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")
-
-local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2"
-load(pathJoin("prod-util", prod_util_ver))
-
--- Needed at runtime:
-load("alps")
-
-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", "/lustre/f2/dev/role.epic/contrib/GSI_data/fix/20230911")
-
-setenv("CC","cc")
-setenv("FC","ftn")
-setenv("CXX","CC")
-pushenv("CRAYPE_LINK_TYPE","dynamic")
-
-whatis("Description: GSI environment on Gaea with Intel Compilers")
-
diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua
index 550b01ee7b..eab352553f 100644
--- a/modulefiles/gsi_hera.gnu.lua
+++ b/modulefiles/gsi_hera.gnu.lua
@@ -1,16 +1,16 @@
help([[
]])
-prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core")
+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.10.8"
+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 "1.2.2"
-local openblas_ver=os.getenv("openblas_ver") or "0.3.19"
+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))
@@ -22,6 +22,6 @@ load("gsi_common")
load(pathJoin("prod_util", prod_util_ver))
load(pathJoin("openblas", openblas_ver))
-pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230911")
+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 39d2fd22b4..d21b9195c3 100644
--- a/modulefiles/gsi_hera.intel.lua
+++ b/modulefiles/gsi_hera.intel.lua
@@ -1,59 +1,25 @@
help([[
]])
-prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon-env-rocky8/install/modulefiles/Core")
+prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/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.10.13"
+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 "1.2.2"
+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))
-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.0"
-
-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.10.0"
-local sp_ver=os.getenv("sp_ver") or "2.3.3"
-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.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"
-local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.2"
-
-load(pathJoin("netcdf-c", netcdf_c_ver))
-load(pathJoin("netcdf-fortran", netcdf_fortran_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("gsi-ncdiag",ncdiag_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/20230911")
+pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20240208")
whatis("Description: GSI environment on Hera with Intel Compilers")
-help([[
-Load common modules to build GSI on all machines
-]])
diff --git a/modulefiles/gsi_hercules.intel.lua b/modulefiles/gsi_hercules.intel.lua
new file mode 100644
index 0000000000..66ec9b03e1
--- /dev/null
+++ b/modulefiles/gsi_hercules.intel.lua
@@ -0,0 +1,26 @@
+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")
+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_hercules.lua b/modulefiles/gsi_hercules.lua
deleted file mode 100644
index b9e0af3161..0000000000
--- a/modulefiles/gsi_hercules.lua
+++ /dev/null
@@ -1,60 +0,0 @@
-help([[
-]])
-
-prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/hercules/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core")
-
-local stack_python_ver=os.getenv("stack_python_ver") or "3.10.8"
-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 "1.2.2"
-
-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))
-
-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.0"
-
-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.10.0"
-local sp_ver=os.getenv("sp_ver") or "2.3.3"
-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.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"
-local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.2"
-
-load(pathJoin("netcdf-c", netcdf_c_ver))
-load(pathJoin("netcdf-fortran", netcdf_fortran_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("gsi-ncdiag",ncdiag_ver))
-
-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/20230911")
-
-whatis("Description: GSI environment on Hercules with Intel Compilers")
-help([[
-Load common modules to build GSI on all machines
-]])
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 1aaa6e6a42..0000000000
--- a/modulefiles/gsi_jet.lua
+++ /dev/null
@@ -1,54 +0,0 @@
-help([[
-]])
-
-prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon-rocky8/install/modulefiles/Core")
-
-local python_ver=os.getenv("python_ver") or "3.10.8"
-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 "1.2.2"
-
-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(pathJoin("prod_util", prod_util_ver))
-
-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.0"
-
-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.10.0"
-local sp_ver=os.getenv("sp_ver") or "2.3.3"
-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.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"
-local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.2"
-
-load(pathJoin("netcdf-c", netcdf_c_ver))
-load(pathJoin("netcdf-fortran", netcdf_fortran_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("gsi-ncdiag",ncdiag_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/20230911")
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..d05bda5b2e
--- /dev/null
+++ b/modulefiles/gsi_orion.intel.lua
@@ -0,0 +1,26 @@
+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")
+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 6cd10de95e..0000000000
--- a/modulefiles/gsi_orion.lua
+++ /dev/null
@@ -1,58 +0,0 @@
-help([[
-]])
-
-prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.6.0/envs/unified-env-rocky9/install/modulefiles/Core")
-
-local stack_python_ver=os.getenv("stack_python_ver") or "3.10.13"
-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(pathJoin("prod_util", prod_util_ver))
-
-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 "12.0.1"
-local bacio_ver=os.getenv("bacio_ver") or "2.4.1"
-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.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"
-local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.2"
-
-load(pathJoin("netcdf-c", netcdf_c_ver))
-load(pathJoin("netcdf-fortran", netcdf_fortran_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("gsi-ncdiag",ncdiag_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")
-help([[
-Load common modules to build GSI on all machines
-]])
-
diff --git a/modulefiles/gsi_s4.lua b/modulefiles/gsi_s4.intel.lua
similarity index 80%
rename from modulefiles/gsi_s4.lua
rename to modulefiles/gsi_s4.intel.lua
index a60ea3c16e..04945eef3e 100644
--- a/modulefiles/gsi_s4.lua
+++ b/modulefiles/gsi_s4.intel.lua
@@ -1,13 +1,13 @@
help([[
]])
-prepend_path("MODULEPATH", "/data/prod/jedi/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core")
+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.10.8"
+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 "1.2.2"
+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))
@@ -20,6 +20,6 @@ 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/20230911")
+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_wcoss2.lua b/modulefiles/gsi_wcoss2.intel.lua
similarity index 89%
rename from modulefiles/gsi_wcoss2.lua
rename to modulefiles/gsi_wcoss2.intel.lua
index b24059b0e0..f664a542b4 100644
--- a/modulefiles/gsi_wcoss2.lua
+++ b/modulefiles/gsi_wcoss2.intel.lua
@@ -17,14 +17,12 @@ local sp_ver=os.getenv("sp_ver") or "2.3.3"
local ip_ver=os.getenv("ip_ver") or "4.0.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.4.0"
+local crtm_ver=os.getenv("crtm_ver") or "2.4.0.1"
local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.2"
-prepend_path("MODULEPATH", "/apps/ops/para/libs/modulefiles/mpi/intel/19.1.3.304/cray-mpich/8.1.9")
-
load(pathJoin("PrgEnv-intel", PrgEnv_intel_ver))
load(pathJoin("intel", intel_ver))
load(pathJoin("craype", craype_ver))
@@ -48,6 +46,6 @@ load(pathJoin("ncio-A", ncio_ver))
load(pathJoin("crtm", crtm_ver))
load(pathJoin("ncdiag-A",ncdiag_ver))
-pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20230911")
+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/regression/CMakeLists.txt b/regression/CMakeLists.txt
index 598317827f..5486d0c257 100644
--- a/regression/CMakeLists.txt
+++ b/regression/CMakeLists.txt
@@ -40,14 +40,20 @@ endif()
list(APPEND GSI_REG_TEST_NAMES
global_4denvar
rtma
- rrfs_3denvar_glbens netcdf_fv3_regional
+ 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_4denvar.sh b/regression/global_4denvar.sh
index 08a62f5eb0..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
@@ -265,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}
@@ -296,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_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/multi_regression.sh b/regression/multi_regression.sh
index 4df5581097..d01492aa44 100755
--- a/regression/multi_regression.sh
+++ b/regression/multi_regression.sh
@@ -1,16 +1,16 @@
#!/bin/sh --login
regtests_all="global_4denvar
- netcdf_fv3_regional
- rrfs_3denvar_glbens
+ rrfs_3denvar_rdasens
hafs_4denvar_glbens
hafs_3denvar_hybens
rtma
global_enkf"
+# rrfs_enkf_conv : comment out RRFS enkf case for now
+# need to update EnKF code
regtests_debug="global_4denvar
- netcdf_fv3_regional
- rrfs_3denvar_glbens
+ rrfs_3denvar_rdasens
hafs_4denvar_glbens
hafs_3denvar_hybens
rtma
diff --git a/regression/netcdf_fv3_regional.sh b/regression/netcdf_fv3_regional.sh
deleted file mode 100755
index e6188f51c6..0000000000
--- a/regression/netcdf_fv3_regional.sh
+++ /dev/null
@@ -1,207 +0,0 @@
-
-set -x
-
-# Set analysis date
-#adate=2015061000
-
-# Set experiment name
-exp=$jobname
-
-# 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.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 821cc7cedb..805a9dd1fb 100755
--- a/regression/regression_driver.sh
+++ b/regression/regression_driver.sh
@@ -36,10 +36,12 @@ for jn in `seq ${RSTART} ${REND}`; do
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
@@ -57,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 552bc1ba59..a4f283f92b 100755
--- a/regression/regression_namelists.sh
+++ b/regression/regression_namelists.sh
@@ -68,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
@@ -195,10 +195,12 @@ OBS_INPUT::
/
&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,
+ 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.,readin_localization=.true.,
+ 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
@@ -317,7 +319,7 @@ OBS_INPUT::
/
"
;;
- rrfs_3denvar_glbens)
+ rrfs_3denvar_rdasens)
# Define namelist for rrfs 3d hybrid envar run with global ensembles
@@ -326,13 +328,14 @@ export gsi_namelist="
&SETUP
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.,
@@ -341,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,
@@ -370,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
@@ -387,6 +394,12 @@ 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 n16 hirs3_n16 0.0 1 0
+ hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0
+ hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0
+ hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0
+ hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0
+ hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 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 2 0
@@ -395,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
@@ -429,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
@@ -442,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.,
@@ -454,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,
@@ -504,6 +545,8 @@ OBS_INPUT::
i_gsdqc=2,
/
&CHEM
+ laeroana_fv3smoke=.false.,
+ berror_fv3_cmaq_regional=.false.,
/
&NST
/
@@ -514,6 +557,7 @@ OBS_INPUT::
/
"
;;
+
hafs_envar)
# Define namelist for hafs 3denvar run with global ensembles
export gsi_namelist="
@@ -775,130 +819,128 @@ SUPEROB_RADAR::
/
"
;;
- netcdf_fv3_regional)
+ rrfs_enkf_conv)
-# Define namelist for netcdf fv3 run
+# Define namelist for rrfs EnKF run
export gsi_namelist="
- &SETUP
- miter=2,niter(1)=5,niter(2)=5,niter_no_qc(1)=2,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
- 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.,
- 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
- 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
- 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
- /
+ &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)
diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh
index e03917e888..b96c208070 100755
--- a/regression/regression_namelists_db.sh
+++ b/regression/regression_namelists_db.sh
@@ -174,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
@@ -298,7 +301,7 @@ OBS_INPUT::
"
;;
- rrfs_3denvar_glbens)
+ rrfs_3denvar_rdasens)
# Define namelist for rrfs 3d hybrid envar run with global ensembles
@@ -307,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.,
@@ -322,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,
@@ -351,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
@@ -368,6 +376,12 @@ 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 n16 hirs3_n16 0.0 1 0
+ hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0
+ hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0
+ hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0
+ hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0
+ hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 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 2 0
@@ -376,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
@@ -410,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
@@ -423,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.,
@@ -435,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,
@@ -485,6 +527,8 @@ OBS_INPUT::
i_gsdqc=2,
/
&CHEM
+ laeroana_fv3smoke=.false.,
+ berror_fv3_cmaq_regional=.false.,
/
&NST
/
@@ -758,133 +802,6 @@ SUPEROB_RADAR::
obhourset=0.,
/
"
-;;
-
- netcdf_fv3_regional)
-
-# Define namelist for netcdf fv3 run
-
-export gsi_namelist="
-
- &SETUP
- miter=2,niter(1)=2,niter(2)=1,niter_no_qc(1)=1,
- write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true.,
- qoption=2,
- factqmin=0.0,factqmax=0.0,deltim=$DELTIM,
- 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.,
- 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
- 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
- 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
- /
-"
;;
*)
diff --git a/regression/regression_param.sh b/regression/regression_param.sh
index 46d2647ac0..bfc6f042fc 100755
--- a/regression/regression_param.sh
+++ b/regression/regression_param.sh
@@ -26,8 +26,8 @@ case $machine in
;;
Gaea)
sub_cmd="sub_gaea"
- memnode=64
- numcore=36
+ memnode=251
+ numcore=128
;;
wcoss2)
sub_cmd="sub_wcoss2"
@@ -36,11 +36,6 @@ case $machine in
;;
Discover)
sub_cmd="sub_discover"
- ;;
- Cheyenne)
- sub_cmd="sub_cheyenne"
- memnode=128
- numcore=36
;;
*) # EXIT out for unresolved machine
echo "unknown $machine"
@@ -73,12 +68,9 @@ case $regtest in
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
+ 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" = "Gaea" ]]; then
- topts[1]="0:10:00" ; popts[1]="18/8/" ; ropts[1]="/1"
- topts[2]="0:10:00" ; popts[2]="18/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"
@@ -92,26 +84,23 @@ case $regtest in
;;
- rrfs_3denvar_glbens)
+ rrfs_3denvar_rdasens)
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: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]="20/1/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="20/2/" ; 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]="20/2/" ; 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]="/2"
elif [[ "$machine" = "Jet" ]]; 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"
- elif [[ "$machine" = "Cheyenne" ]]; then
- topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="20/2/" ; 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]="18/1/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1"
+ 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"
@@ -128,23 +117,20 @@ case $regtest in
hafs_3denvar_hybens)
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]="20/1/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="20/2/" ; 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]="20/2/" ; ropts[2]="/2"
+ topts[2]="0:15:00" ; popts[2]="5/8/" ; ropts[2]="/2"
elif [[ "$machine" = "Jet" ]]; 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"
- elif [[ "$machine" = "Cheyenne" ]]; then
- topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="20/2/" ; 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]="18/1/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1"
+ 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"
@@ -160,23 +146,20 @@ case $regtest in
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:20:00" ; popts[1]="20/1/" ; ropts[1]="/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]="20/1/" ; ropts[1]="/1"
- topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1"
+ 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]="20/1/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1"
- elif [[ "$machine" = "Cheyenne" ]]; then
- topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="20/2/" ; 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]="18/1/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1"
+ 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"
@@ -190,29 +173,26 @@ case $regtest in
;;
- 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"
elif [[ "$machine" = "Hercules" ]]; 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" = "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"
- elif [[ "$machine" = "Cheyenne" ]]; then
- topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1"
- topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/2"
elif [[ "$machine" = "Gaea" ]]; 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]="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
@@ -237,12 +217,9 @@ case $regtest in
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: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]="8/6/" ; ropts[1]="/1"
- topts[2]="0:30:00" ; popts[2]="8/8/" ; ropts[2]="/1"
+ 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"
@@ -270,12 +247,9 @@ case $regtest in
elif [[ "$machine" = "Jet" ]]; 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" = "Cheyenne" ]]; 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" = "Gaea" ]]; 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]="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"
@@ -326,10 +300,10 @@ if [[ "$machine" = "Hera" ]]; then
export APRUN="srun"
elif [[ "$machine" = "Orion" ]]; then
export OMP_STACKSIZE=2048M
- export APRUN="srun -n \$ntasks --cpus-per-task=\$threads"
+ export APRUN="srun -n \$ntasks --mem=0 --cpus-per-task=\$threads"
elif [[ "$machine" = "Hercules" ]]; then
export OMP_STACKSIZE=2048M
- export APRUN="srun -n \$ntasks --cpus-per-task=\$threads"
+ 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
@@ -341,13 +315,7 @@ elif [[ "$machine" = "Gaea" ]]; then
export MPI_BUFS_PER_PROC=256
export MPI_BUFS_PER_HOST=256
export MPI_GROUP_MAX=256
- export APRUN="srun --export=ALL --mpi=pmi2 -n \$ntasks"
-elif [[ "$machine" = "Cheyenne" ]]; 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 \$ntasks"
+ 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_enkf.sh b/regression/regression_test_enkf.sh
index 38ee20ce99..ac839631c2 100755
--- a/regression/regression_test_enkf.sh
+++ b/regression/regression_test_enkf.sh
@@ -35,16 +35,30 @@ maxtime=1200
# 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/incr_${global_adate}_fhr06$member $tmpdir/incr$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"
@@ -223,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
@@ -321,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
diff --git a/regression/regression_var.sh b/regression/regression_var.sh
index 02ffb24b12..4a2bc85874 100755
--- a/regression/regression_var.sh
+++ b/regression/regression_var.sh
@@ -30,22 +30,23 @@ 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 /mnt/lfs4 || -d /jetmon || -d /mnt/lfs1 ]]; 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 && $(hostname) =~ "Orion" ]]; then # Orion
- export machine="Orion"
-elif [[ -d /work && $(hostname) =~ "hercules" ]]; then # Hercules
- export machine="Hercules"
+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
@@ -54,31 +55,13 @@ echo "Running Regression Tests on '$machine'";
case $machine in
Gaea)
export queue="normal"
- export noscrub="/lustre/f2/scratch/$LOGNAME/gsi_tmp/noscrub"
- export ptmp="/lustre/f2/scratch/$LOGNAME/gsi_tmp/ptmp"
- export casesdir="/lustre/f2/dev/role.epic/contrib/GSI_data/CASES/regtest"
-
- export group="global"
- if [[ "$cmaketest" = "false" ]]; then
- export basedir="/lustre/f2/dev/$LOGNAME/sandbox/GSI"
- fi
-
- export check_resource="no"
- export accnt="nggps_emc"
- ;;
- Cheyenne)
- export queue="regular"
- export noscrub="/glade/scratch/$LOGNAME/noscrub"
- export group="global"
- if [[ "$cmaketest" = "false" ]]; then
- export basedir="/glade/scratch/$LOGNAME"
- fi
- export ptmp="/glade/scratch/$LOGNAME/$ptmpName"
-
- export casesdir="/glade/work/epicufsrt/contrib/GSI_data/CASES/regtest"
+ 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="NRAL0032"
+ export accnt="ufs-ard"
;;
wcoss2)
export local_or_default="${local_or_default:-/lfs/h2/emc/da/noscrub/$LOGNAME}"
@@ -157,16 +140,16 @@ case $machine in
;;
Jet)
- export noscrub=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/noscrub
- export ptmp=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/ptmp
- export casesdir="/lfs1/NESDIS/nesdis-rdo2/David.Huber/save/CASES/regtest"
+ 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/save/git/gsi"
+ export basedir="/lfs5/NESDIS/nesdis-rdo2/$LOGNAME/save/git/gsi"
fi
# On Jet, there are no scrubbers to remove old contents from stmp* directories.
@@ -206,21 +189,21 @@ export savdir="$ptmp"
export JCAP="62"
# Case Study analysis dates
-export global_adate="2022110900"
+export global_adate="2024022300"
export rtma_adate="2020022420"
-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 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"
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 808eae2e28..0961549634 100644
--- a/src/enkf/controlvec.f90
+++ b/src/enkf/controlvec.f90
@@ -191,7 +191,7 @@ subroutine read_control()
! read ensemble members on IO tasks
implicit none
real(r_double) :: t1,t2
-integer(i_kind) :: nb,ne
+integer(i_kind) :: nb,nlev,ne
integer(i_kind) :: q_ind
integer(i_kind) :: ierr
@@ -218,19 +218,23 @@ subroutine read_control()
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)
q_ind = getindex(cvars3d, 'q')
- if (nproc == 0) then
- t2 = mpi_wtime()
- print *,'time in readgridata on root',t2-t1,'secs'
- end if
if (pseudo_rh .and. q_ind > 0) then
do ne=1,nanals_per_iotask
do nb=1,nbackgrounds
@@ -357,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
diff --git a/src/enkf/gridinfo_fv3reg.f90 b/src/enkf/gridinfo_fv3reg.f90
index 778a73d89a..b9446ec8e9 100644
--- a/src/enkf/gridinfo_fv3reg.f90
+++ b/src/enkf/gridinfo_fv3reg.f90
@@ -47,7 +47,8 @@ module gridinfo
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
@@ -65,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
@@ -79,6 +81,8 @@ module gridinfo
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
@@ -131,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
@@ -162,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
@@ -461,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
@@ -471,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)
@@ -487,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 317ca2221c..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
@@ -67,6 +68,7 @@ module gridinfo
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(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_gfs.f90 b/src/enkf/gridio_gfs.f90
index e4631f4e2d..35a0c3fbe4 100644
--- a/src/enkf/gridio_gfs.f90
+++ b/src/enkf/gridio_gfs.f90
@@ -89,15 +89,21 @@ 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
@@ -111,12 +117,6 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, &
call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, read_sfc_file, read_atm_file)
- if (read_sfc_file) then
- print *,'paranc not supported for reading surface files'
- call mpi_barrier(mpi_comm_world,ierr)
- call mpi_finalize(ierr)
- endif
-
! figure out what member to read and do MPI sub-communicator things
allocate(mem_pe(0:numproc-1))
allocate(iocomms(nanals))
@@ -152,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
@@ -159,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
@@ -496,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)
@@ -926,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'
@@ -1203,36 +1339,36 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes,
call copytogrdin(ug,grdin(:,levels(n3d) + soilt4_ind,nb,ne))
endif
if (slc1_ind > 0) then
- call read_vardata(dset_sfc, 'slc1', values_2d, errcode=iret)
+ call read_vardata(dset_sfc, 'soill1', values_2d, errcode=iret)
if (iret /= 0) then
- print *,'error reading slc1'
+ 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, 'slc2', values_2d, errcode=iret)
+ call read_vardata(dset_sfc, 'soill2', values_2d, errcode=iret)
if (iret /= 0) then
- print *,'error reading slc2'
+ 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, 'slc3', values_2d, errcode=iret)
+ call read_vardata(dset_sfc, 'soill3', values_2d, errcode=iret)
if (iret /= 0) then
- print *,'error reading slc3'
+ 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, 'slc4', values_2d, errcode=iret)
+ call read_vardata(dset_sfc, 'soill4', values_2d, errcode=iret)
if (iret /= 0) then
- print *,'error reading slc2'
+ print *,'error reading soill4'
call stop2(22)
endif
ug = reshape(values_2d,(/nlons*nlats/))
@@ -1321,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.
@@ -2122,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
@@ -2143,10 +2294,12 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n
call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file)
- if (write_sfc_file .and. nproc==0 ) then
+ if (write_sfc_file ) then
! adding the sfc increments requires adjusting several other variables. This is done is a separate
! program.
- write(6,*)'gridio/writegriddata: not coded to write sfc analysis, use separate add_incr program instead'
+ 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.
@@ -3584,7 +3737,7 @@ 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, &
@@ -3612,10 +3765,10 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,
! 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)
- if ( write_atm_file) then
use_full_hydro = .false.
clip = tiny_r_kind
read(datestring,*) iadateout
@@ -3623,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
@@ -3950,10 +4105,15 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,
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
@@ -3978,20 +4138,21 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,
! 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, dimids3(1:2), tmp2mvarid))
- call nccheck_incr(nf90_def_var(ncid_out, "spfh2m_inc", nf90_real, dimids3(1:2), spfh2mvarid))
- call nccheck_incr(nf90_def_var(ncid_out, "soilt1_inc", nf90_real, dimids3(1:2), soilt1varid))
- call nccheck_incr(nf90_def_var(ncid_out, "soilt2_inc", nf90_real, dimids3(1:2), soilt2varid))
- call nccheck_incr(nf90_def_var(ncid_out, "soilt3_inc", nf90_real, dimids3(1:2), soilt3varid))
- call nccheck_incr(nf90_def_var(ncid_out, "soilt4_inc", nf90_real, dimids3(1:2), soilt4varid))
- call nccheck_incr(nf90_def_var(ncid_out, "slc1_inc", nf90_real, dimids3(1:2), slc1varid))
- call nccheck_incr(nf90_def_var(ncid_out, "slc2_inc", nf90_real, dimids3(1:2), slc2varid))
- call nccheck_incr(nf90_def_var(ncid_out, "slc3_inc", nf90_real, dimids3(1:2), slc3varid))
- call nccheck_incr(nf90_def_var(ncid_out, "slc4_inc", nf90_real, dimids3(1:2), slc4varid))
- call nccheck_incr(nf90_def_var(ncid_out, "soilsnow_mask", nf90_int, dimids3(1:2), maskvarid))
+ 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", &
@@ -4036,7 +4197,7 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,
! note: same logic/threshold used in global_cycle to produce
! mask on model grid.
- call read_vardata(dsfg, 'slc1', values_2d, errcode=iret)
+ call read_vardata(dsfg, 'soill1', values_2d, errcode=iret)
mask = 0
do j=1,nlats
@@ -4194,6 +4355,10 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,
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
@@ -4220,7 +4385,8 @@ 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
+ datestring,nhr_anal, &
+ incsfcfileprefixes,fgsfcfileprefixes
use constants, only: grav,qcmin
use mpi
use module_ncio, only: Dataset, Variable, Dimension, open_dataset,&
@@ -4252,12 +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, &
- rwmrvarid, snmrvarid, grlevarid
+ 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
@@ -4269,11 +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
@@ -4312,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
@@ -4767,8 +4950,261 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate
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)
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/params.f90 b/src/enkf/params.f90
index 667cdc2f01..ba87e9daa7 100644
--- a/src/enkf/params.f90
+++ b/src/enkf/params.f90
@@ -257,6 +257,11 @@ 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,&
@@ -289,7 +294,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
diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90
index a5383069a1..65db770b6d 100644
--- a/src/enkf/readconvobs.f90
+++ b/src/enkf/readconvobs.f90
@@ -24,7 +24,6 @@ module readconvobs
! reflectivity and radial velocity assimilation. POC: xuguang.wang@ou.edu
! 2017-12-13 shlyaeva - added netcdf diag read/write capability
! 2019-03-21 CAPS(C. Tong) - added direct reflectivity DA capability
-! 2022-03-23 draper - added option to not scale qobs by forecast qsat.
!
! attributes:
! language: f95
diff --git a/src/enkf/statevec.f90 b/src/enkf/statevec.f90
index 5ad70346aa..44ad5df9b4 100644
--- a/src/enkf/statevec.f90
+++ b/src/enkf/statevec.f90
@@ -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 603a0b5f4e..0d0f2b79ea 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)
@@ -158,6 +167,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/calc_fov_crosstrk.f90 b/src/gsi/calc_fov_crosstrk.f90
index dc9767e850..6cb817b56b 100644
--- a/src/gsi/calc_fov_crosstrk.f90
+++ b/src/gsi/calc_fov_crosstrk.f90
@@ -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/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/correlated_obsmod.F90 b/src/gsi/correlated_obsmod.F90
index 7a14cd3226..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
diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90
index 512560f278..9b841f012c 100644
--- a/src/gsi/cplr_get_fv3_regional_ensperts.f90
+++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90
@@ -430,7 +430,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar)
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. .not.if_model_fed) i_caseflag=3
+ 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
diff --git a/src/gsi/deter_sfc_mod.f90 b/src/gsi/deter_sfc_mod.f90
index 300d36cffb..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
@@ -1331,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
@@ -1354,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
@@ -1370,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)
@@ -1407,90 +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))
-
- 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
diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90
index 7f0f00ac84..8e1c3ab98f 100644
--- a/src/gsi/gsi_rfv3io_mod.f90
+++ b/src/gsi/gsi_rfv3io_mod.f90
@@ -25,6 +25,7 @@ module gsi_rfv3io_mod
! 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
@@ -60,7 +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
+ use rapidrefresh_cldsurf_mod, only: i_howv_3dda, i_gust_3dda
implicit none
public type_fv3regfilenameg
@@ -146,7 +147,7 @@ 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,k_howv
+ 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
@@ -157,7 +158,7 @@ module gsi_rfv3io_mod
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,k_howv
+ 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
@@ -173,7 +174,8 @@ module gsi_rfv3io_mod
k_q2m =12, & ! 2 m Q
k_orog =13, & !terrain
k_howv =14, & ! significant wave height (aka howv in GSI)
- n2d=14 )
+ 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
@@ -546,7 +548,7 @@ subroutine gsi_rfv3io_get_ens_grid_specs(grid_spec,ierr)
!
!$$$ end documentation block
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 mpimod, only: mype
use mod_fv3_lola, only: definecoef_regular_grids
@@ -995,6 +997,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
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()
@@ -1237,7 +1240,6 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
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
@@ -1252,7 +1254,6 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
endif
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
@@ -1275,6 +1276,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
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)
@@ -1295,7 +1297,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
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") &
- .or.(trim(vartem)=="howv"))) then ! z is treated separately
+ .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)
@@ -1360,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
@@ -1559,6 +1560,12 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
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))
@@ -1597,7 +1604,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
if( fv3sar_bg_opt == 0) then
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),.false.)
+ call gsi_fv3ncdf_readuv_v1(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.)
endif
if( fv3sar_bg_opt == 0) then
@@ -1741,7 +1748,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin)
endif
- call gsi_fv3ncdf2d_read(fv3filenamegin(it),it,ges_z,ges_t2m,ges_q2m,ges_howv)
+ 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
@@ -1977,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,ges_howv)
+subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m, &
+ ges_howv,ges_gust)
!$$$ subprogram documentation block
! . . . .
! subprogram: gsi_fv3ncdf2d_read
@@ -2024,6 +2033,7 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv)
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
@@ -2038,8 +2048,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv)
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 in firstguess file
- integer(i_kind) id_howv
+! 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
@@ -2048,6 +2058,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv)
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
@@ -2056,8 +2069,12 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv)
allocate(work(itotsub*n2d))
allocate( sfcn2d(lat2,lon2,n2d))
-!-- initialisation of the array for howv
+!-- 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))
@@ -2103,36 +2120,67 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv)
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
@@ -2219,6 +2267,7 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv)
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(fv3_io_layout_y > 1) then
do nio=0,fv3_io_layout_y-1
@@ -2265,8 +2314,12 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv)
if(allocated(sfc_fulldomain)) deallocate (sfc_fulldomain)
endif ! mype
-!-- broadcast the updated i_howv_3dda to all tasks (!!!!)
+!-- 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,&
@@ -2274,23 +2327,26 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv)
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
- ges_howv(:,:)=sfcn2d(:,:,k_howv)
+ 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
@@ -2425,7 +2481,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens
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,fv3_h_to_ll_ens
@@ -2445,9 +2501,9 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens
character(len=max_varname_length) :: name
character(len=max_filename_length) :: filenamein2
real(r_kind),allocatable,dimension(:,:):: uu2d_tmp
- integer(i_kind) :: countloc_tmp(3),startloc_tmp(3)
+ 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,len
logical :: phy_smaller_domain
@@ -2504,18 +2560,16 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens
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) !clt
+ 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 flush(6)
call stop2(333)
endif
enddo
else
- iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt
+ 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 flush(6)
call stop2(333)
endif
endif
@@ -2530,15 +2584,14 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens
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/)
+ 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
@@ -2546,23 +2599,23 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens
if(trim(name)=='xaxis_1') nx_phy=len
if( nx_phy == nxcase )then
allocate(uu2d_tmp(nxcase,nycase))
- countloc_tmp=(/nxcase,nycase,1/)
+ 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/)
+ countloc_tmp=(/nxcase-6,nycase-6,1,1/)
phy_smaller_domain = .true.
end if
- startloc_tmp=(/1,1,ilev/)
+ 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/)
+ 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/)
+ 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)
@@ -2647,10 +2700,10 @@ 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,fv3_h_to_ll_ens
@@ -2670,12 +2723,18 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,
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
@@ -2688,13 +2747,34 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,
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
@@ -2704,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
@@ -2728,8 +2807,9 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,
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)
@@ -2761,7 +2841,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
use kinds, only: r_kind,i_kind
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,fv3_h_to_ll_ens,fv3uv2earthens
@@ -2784,7 +2864,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
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
@@ -2849,15 +2929,13 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
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 flush(6)
call stop2(333)
endif
enddo
else
- iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt
+ 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 flush(6)
call stop2(333)
endif
endif
@@ -2867,24 +2945,23 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
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/)
+ 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/)
+ 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/)
+ 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) )
@@ -2893,13 +2970,13 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
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/)
+ 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/)
+ 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) )
@@ -2995,9 +3072,10 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
!$$$ 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,fv3_h_to_ll_ens
@@ -3027,6 +3105,9 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
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
@@ -3043,11 +3124,33 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
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
@@ -3056,7 +3159,6 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
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)
@@ -3075,9 +3177,9 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
! 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)
+ 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
@@ -3099,10 +3201,11 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid)
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,:,:,:)
- iret=nf90_close(gfile_loc)
deallocate (us2d,vw2d,worksub)
end subroutine gsi_fv3ncdf_readuv_v1
@@ -3136,7 +3239,7 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, &
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_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 gridmod, only: nsig,nlon,nlat
@@ -3155,7 +3258,7 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, &
character(len=max_varname_length) :: name
character(len=max_filename_length), allocatable,dimension(:) :: varname_files
- integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3),countloc_tmp(3),startloc_tmp(3)
+ 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
@@ -3214,15 +3317,13 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, &
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 flush(6)
call stop2(333)
endif
enddo
else
- iret=nf90_open(filenamein,nf90_nowrite,gfile_loc)
+ 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 flush(6)
call stop2(333)
endif
endif
@@ -3232,8 +3333,8 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, &
nz=nsig
nzp1=nz+1
inative=nzp1-ilev
- startloc=(/1,1,inative/)
- countloc=(/nxcase,nycase,1/)
+ 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
@@ -3242,19 +3343,19 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, &
if(trim(name)=='xaxis_1') nx_phy=len
if( nx_phy == nxcase )then
allocate(uu2d_tmp(nxcase,nycase))
- countloc_tmp=(/nxcase,nycase,1/)
+ 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/)
+ countloc_tmp=(/nxcase-6,nycase-6,1,1/)
phy_smaller_domain = .true.
end if
- startloc_tmp=(/1,1,ilev/)
+ 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/)
+ 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)
@@ -3384,7 +3485,7 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i
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
@@ -3418,7 +3519,6 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i
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 flush(6)
call stop2(333)
endif
enddo
@@ -3426,7 +3526,6 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i
iret=nf90_open(filenamein,nf90_nowrite,gfile_loc)
if(iret/=nf90_noerr) then
write(6,*)' problem opening ',trim(filenamein),', Status = ',iret
- call flush(6)
call stop2(333)
endif
endif
@@ -3435,14 +3534,14 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i
nz=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/)
+ 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/)
+ 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)
@@ -3450,7 +3549,7 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i
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/)
+ 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)
@@ -3564,6 +3663,7 @@ subroutine wrfv3_netcdf(fv3filenamegin)
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
@@ -3686,6 +3786,9 @@ subroutine wrfv3_netcdf(fv3filenamegin)
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
@@ -3900,6 +4003,10 @@ subroutine wrfv3_netcdf(fv3filenamegin)
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)
@@ -3941,7 +4048,7 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
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
@@ -3960,11 +4067,11 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
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
@@ -3973,10 +4080,12 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
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
@@ -3988,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
@@ -4030,59 +4137,70 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
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_read,info=MPI_INFO_NULL) )
+ 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,nf90_write,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) )
+ 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,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
+ 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
+
+
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/)
work_au=hwork(1,:,:,ilevtot)
work_av=hwork(2,:,:,ilevtot)
- call check( nf90_inq_varid(gfile_loc,'u',ugrd_VarId) )
- call check( nf90_inq_varid(gfile_loc,'v',vgrd_VarId) )
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
- 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)
- enddo
- else
- 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
+
+!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,nlon_regional,nlat_regional+1,1)
- call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1)
+ 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,work_bv,nlon_regional,nlat_regional,u2d,v2d)
+ 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 !!!!!!!!!!!!!!!!
@@ -4092,38 +4210,38 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
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(:,:)
+ 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(:,:),work_bv(:,:))
+ 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,nlon_regional,nlat_regional+1,1)
- call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1)
+ 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
+ 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)
+ 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)))
- v_countloc=(/nxcase+1,ny_layout_len(nio),1/)
- v2d_layout=work_bv(:,ny_layout_b(nio):ny_layout_e(nio))
+ 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
+ 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
+ endif
if(fv3_io_layout_y > 1) then
do nio=0,fv3_io_layout_y-1
@@ -4133,11 +4251,12 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin)
else
call check( nf90_close(gfile_loc) )
endif
+ deallocate(work_bu,work_bv)
endif
call mpi_barrier(mpi_comm_world,ierror)
- deallocate(work_bu,work_bv,u2d,v2d)
+ deallocate(u2d,v2d)
deallocate(work_au,work_av)
end subroutine gsi_fv3ncdf_writeuv
@@ -4169,12 +4288,12 @@ 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
@@ -4196,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
@@ -4225,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
+
+
+ call check( nf90_open(filenamein,ior(nf90_write, nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) )
- 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_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)
@@ -4309,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
@@ -4517,8 +4679,8 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file
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
@@ -4534,8 +4696,8 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file
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) countloc_tmp(3),startloc_tmp(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
@@ -4597,11 +4759,11 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file
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_read,info=MPI_INFO_NULL) )
+ 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
gfile_loc=gfile_loc_layout(0)
else
- call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) )
+ 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
@@ -4613,15 +4775,14 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file
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/)
+ countloc=(/nxcase,nycase,1,1/)
+ startloc=(/1,1,inative,1/)
work_a=hwork(1,:,:,ilevtot)
@@ -4630,23 +4791,24 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file
if(trim(name)=='xaxis_1') nx_phy=len
if( nx_phy == nxcase )then
allocate(work_b_tmp(nxcase,nycase))
- countloc_tmp=(/nxcase,nycase,1/)
+ 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/)
+ countloc_tmp=(/nxcase-6,nycase-6,1,1/)
phy_smaller_domain = .true.
end if
- startloc_tmp=(/1,1,ilev/)
+ 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/)
+ 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
@@ -4661,7 +4823,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file
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/)
+ 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
@@ -4697,7 +4859,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file
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)))
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) )
@@ -4771,12 +4933,13 @@ 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
@@ -4800,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
@@ -4814,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
@@ -4824,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)
@@ -4838,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'
@@ -4861,6 +5051,7 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f
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)
@@ -5396,7 +5587,7 @@ subroutine gsi_copy_bundle(bundi,bundo)
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
diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90
index 45d88887a3..d7f5667252 100644
--- a/src/gsi/gsimod.F90
+++ b/src/gsi/gsimod.F90
@@ -161,7 +161,7 @@ module gsimod
ntotensgrp,nsclgrp,naensgrp,ngvarloc,ntlevs_ens,naensloc, &
r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl,l_timloc_opt,&
vdl_scale,vloc_varlist,&
- global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers
+ 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,&
@@ -184,7 +184,7 @@ module gsimod
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, &
- corp_howv, hwllp_howv
+ 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
@@ -529,6 +529,7 @@ module gsimod
! - 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
!-------------------------------------------------------------------------
@@ -1452,6 +1453,7 @@ module gsimod
! ^ ^ ^ ^ ^
! 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,&
@@ -1462,7 +1464,7 @@ module gsimod
i_en_perts_io,l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB,limqens, &
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
+ 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 ):
@@ -1602,6 +1604,9 @@ module gsimod
! = 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, &
@@ -1623,7 +1628,7 @@ module gsimod
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, &
- corp_howv, hwllp_howv
+ 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
@@ -1985,6 +1990,18 @@ subroutine gsimain_initialize
regional=wrf_nmm_regional.or.wrf_mass_regional.or.twodvar_regional.or.nems_nmmb_regional .or. cmaq_regional
regional=regional.or.fv3_regional.or.fv3_cmaq_regional
+! Force turn off MGBF-based localization except for regional application
+ if(.not.regional.and.l_mgbf_loc) then
+ l_mgbf_loc=.false.
+ if(mype==0) write(6,*)'GSIMOD: for global app, l_mgbf_loc is not applicable, reset l_mgbf_loc=',l_mgbf_loc
+ end if
+
+! Force turn off MGBF-based localization for lsqrtb=.true.
+ if(lsqrtb.and.l_mgbf_loc) then
+ l_mgbf_loc=.false.
+ if(mype==0) write(6,*)'GSIMOD: for lsqrtb=.true., l_mgbf_loc is not applicable, reset l_mgbf_loc=',l_mgbf_loc
+ end if
+
! Currently only able to have use_gfs_stratosphere=.true. for nems_nmmb_regional=.true.
use_gfs_stratosphere=use_gfs_stratosphere.and.(nems_nmmb_regional.or.wrf_nmm_regional)
if(mype==0) write(6,*) 'in gsimod: use_gfs_stratosphere,nems_nmmb_regional,wrf_nmm_regional= ', &
diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90
index 05b3845627..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)
@@ -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
@@ -3608,7 +3620,6 @@ subroutine bkerror_a_en(grady)
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
@@ -3639,8 +3650,8 @@ subroutine bkerror_a_en(grady)
call bkgcov_a_en_new_factorization(1,grady%aens(ii,1,1:n_ens))
end do
else
- allocate(z(nval_lenz_en,naensgrp))
- allocate(z2(nval_lenz_en))
+ 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(1,ig),grady%aens(ii,ig,1:n_ens))
@@ -3648,7 +3659,7 @@ subroutine bkerror_a_en(grady)
do ig=1,naensgrp
z2=zero
do ig2=1,naensgrp
- do k=1,nval_lenz_en
+ do k=1,nval_loc_en
z2(k) = z2(k) + z(k,ig2) * alphacvarsclgrpmat(ig,ig2)
enddo
enddo
@@ -3699,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
@@ -3717,54 +3730,101 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en)
ipnt=1
+! 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
+ 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
+ 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
+ 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)
+ 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
@@ -3796,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
@@ -3806,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)
@@ -3825,54 +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
- iadvance=2 ; iback=1
+ iadvance=2 ; iback=1
!$omp parallel do schedule(static,1) private(k)
- do k=1,n_ens
+ do k=1,n_ens
- call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
+ call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
- enddo
+ enddo
+
+ endif
return
end subroutine ckgcov_a_en_new_factorization
@@ -3909,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
@@ -3919,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)
@@ -3938,53 +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
- iadvance=1 ; iback=2
+ 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
!$omp parallel do schedule(static,1) private(k)
- do k=1,n_ens
+ do k=1,n_ens
- call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig)
-
- enddo
+ 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
+
! ------------------------------------------------------------------------------
! ------------------------------------------------------------------------------
@@ -4202,6 +4416,7 @@ subroutine hybens_localization_setup
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
@@ -4221,6 +4436,7 @@ subroutine hybens_localization_setup
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
@@ -4322,30 +4538,41 @@ 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
- 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
+ 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
- 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)
+ ! 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
@@ -4537,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
diff --git a/src/gsi/hybrid_ensemble_parameters.f90 b/src/gsi/hybrid_ensemble_parameters.f90
index 23065ebb5b..d31eccb7e4 100644
--- a/src/gsi/hybrid_ensemble_parameters.f90
+++ b/src/gsi/hybrid_ensemble_parameters.f90
@@ -149,6 +149,7 @@ module hybrid_ensemble_parameters
! =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
!=====================================================================================================
!
!
@@ -183,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:
@@ -333,6 +335,7 @@ module hybrid_ensemble_parameters
public :: alphacvarsclgrpmat
public :: l_timloc_opt
public :: r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl
+ public :: l_mgbf_loc
public :: idaen3d,idaen2d
public :: ens_fast_read
public :: parallelization_over_ensmembers
@@ -348,6 +351,7 @@ module hybrid_ensemble_parameters
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
@@ -462,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.
diff --git a/src/gsi/intjcmod.f90 b/src/gsi/intjcmod.f90
index 4b149da6b9..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
diff --git a/src/gsi/m_berror_stats_reg.f90 b/src/gsi/m_berror_stats_reg.f90
index 8730e56c3b..d7a30808e6 100644
--- a/src/gsi/m_berror_stats_reg.f90
+++ b/src/gsi/m_berror_stats_reg.f90
@@ -313,6 +313,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt
use mpeu_util,only: getindex
use radiance_mod, only: icloud_cv,n_clouds_fwd,cloud_names_fwd
use chemmod, only: berror_fv3_cmaq_regional,berror_fv3_sd_regional
+ use rapidrefresh_cldsurf_mod, only: corp_gust, hwllp_gust, l_rtma3d
implicit none
@@ -825,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
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/rapidrefresh_cldsurf_mod.f90 b/src/gsi/rapidrefresh_cldsurf_mod.f90
index 122d2872d0..475f44a9d3 100644
--- a/src/gsi/rapidrefresh_cldsurf_mod.f90
+++ b/src/gsi/rapidrefresh_cldsurf_mod.f90
@@ -197,6 +197,30 @@ module rapidrefresh_cldsurf_mod
! 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
@@ -270,6 +294,8 @@ module rapidrefresh_cldsurf_mod
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
@@ -330,6 +356,8 @@ module rapidrefresh_cldsurf_mod
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
@@ -447,6 +475,22 @@ subroutine init_rapidrefresh_cldsurf
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
@@ -456,6 +500,12 @@ subroutine init_rapidrefresh_cldsurf
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
diff --git a/src/gsi/read_atms.f90 b/src/gsi/read_atms.f90
index c6ed159068..424843a7c1 100644
--- a/src/gsi/read_atms.f90
+++ b/src/gsi/read_atms.f90
@@ -544,11 +544,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)
diff --git a/src/gsi/read_cris.f90 b/src/gsi/read_cris.f90
index b8bf4ff92b..d5668f8864 100644
--- a/src/gsi/read_cris.f90
+++ b/src/gsi/read_cris.f90
@@ -334,14 +334,18 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,&
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 ) spc_filename = trim(crtm_coeffs_path)//'viirs-m_j1.SpcCoeff.bin'
- sensorlist_imager = 'viirs-m_j1'
+ 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 ) spc_filename = trim(crtm_coeffs_path)//'viirs-m_j2.SpcCoeff.bin'
- sensorlist_imager = 'viirs-m_j2'
+ 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
diff --git a/src/gsi/read_gmi.f90 b/src/gsi/read_gmi.f90
index f54263b129..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
@@ -696,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
diff --git a/src/gsi/read_nsstbufr.f90 b/src/gsi/read_nsstbufr.f90
index f287dbd0b8..97096f3760 100644
--- a/src/gsi/read_nsstbufr.f90
+++ b/src/gsi/read_nsstbufr.f90
@@ -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
diff --git a/src/gsi/read_ozone.f90 b/src/gsi/read_ozone.f90
index 2ad95a858e..e6d3411d97 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
diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90
index 87d5aa4bd8..bed3b31db2 100644
--- a/src/gsi/read_prepbufr.f90
+++ b/src/gsi/read_prepbufr.f90
@@ -149,8 +149,10 @@ 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
+! 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
@@ -225,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
@@ -390,6 +393,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
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)
@@ -876,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
@@ -1503,6 +1513,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
@@ -1669,13 +1680,15 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
pmq(k)=nint(qcmark(8,k))
end do
-! 181, 183, 187, and 188 are the screen-level obs over land
- global_2m_land = ( (kx==181 .or. kx==183 .or. kx==188 .or. kx==188 ) .and. hofx_2m_sfcfile )
+! 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
! 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
@@ -1711,6 +1724,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
@@ -1793,6 +1825,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
@@ -1979,18 +2012,17 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,&
pqm(k)=2 ! otherwise, type 183 will be discarded.
qm=2
tqm(k)=2
- if (kx==187) obserr(3,k)=2.2
- if (kx==181) obserr(3,k)=1.5
- if (kx==183) obserr(3,k)=2.6
+ 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
- if (kx==181) obserr(2,k)=1.0
- if (kx==183) obserr(2,k)=1.0
+ 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
@@ -2397,7 +2429,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
@@ -2536,6 +2579,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
diff --git a/src/gsi/read_radar.f90 b/src/gsi/read_radar.f90
index a824bbbe4e..84a4f4fbcf 100644
--- a/src/gsi/read_radar.f90
+++ b/src/gsi/read_radar.f90
@@ -907,6 +907,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu
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'
@@ -2176,7 +2177,6 @@ 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
@@ -2522,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
diff --git a/src/gsi/satthin.F90 b/src/gsi/satthin.F90
index 93f193014f..c093c4b1d5 100644
--- a/src/gsi/satthin.F90
+++ b/src/gsi/satthin.F90
@@ -350,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
@@ -386,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
@@ -402,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
diff --git a/src/gsi/setupq.f90 b/src/gsi/setupq.f90
index ad6d727ce9..f7f0be7735 100644
--- a/src/gsi/setupq.f90
+++ b/src/gsi/setupq.f90
@@ -113,6 +113,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
! for 3D-RTMA (if l_obsprvdiag is true).
! 2023-03-09 Draper added option to interpolate screen-level q from model 2m output.
! (hofx_2m_sfcfile)
+! 2024-01-11 zhao - added tdry/tvflg in obs diagnostic files for (2D/3D)RTMA
!
!
! input argument list:
@@ -172,6 +173,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
use rapidrefresh_cldsurf_mod, only: l_sfcobserror_ramp_q
use rapidrefresh_cldsurf_mod, only: l_pbl_pseudo_surfobsq,pblh_ration,pps_press_incr, &
i_use_2mq4b,l_closeobs,i_coastline
+ use rapidrefresh_cldsurf_mod, only: l_rtma3d
use gsi_bundlemod, only : gsi_bundlegetpointer
use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle
use sparsearr, only: sparr2, new, size, writearray, fullarray
@@ -245,6 +247,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
integer(i_kind) ier,ilon,ilat,ipres,iqob,id,itime,ikx,iqmax,iqc
integer(i_kind) ier2,iuse,ilate,ilone,istnelv,iobshgt,izz,iprvd,isprvd
integer(i_kind) idomsfc,iderivative
+ integer(i_kind) iqt
integer(i_kind) ibb,ikk,idddd
real(r_kind) :: delz
type(sparr2) :: dhx_dx
@@ -335,6 +338,9 @@ 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 .and. nint(data(iqc,i)) < 8
@@ -376,7 +382,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
do k=1,nobs
ikx=nint(data(ikxx,k))
itype=ictype(ikx)
- landsfctype =( itype==181 .or. itype==183 .or. itype==187 .or. itype==188 )
+ landsfctype =( itype==181 .or. itype==183 .or. itype==187 )
do l=k+1,nobs
if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then
duplogic=data(ilat,k) == data(ilat,l) .and. &
@@ -416,6 +422,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
@@ -1232,6 +1239,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
@@ -1309,6 +1321,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
@@ -1387,6 +1404,10 @@ subroutine contents_netcdf_diag_(odiag)
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
@@ -1451,6 +1472,10 @@ subroutine contents_netcdf_diagp_(odiag)
call nc_diag_metadata_to_single("Obs_Minus_Forecast_adjusted",ddiff )
call nc_diag_metadata_to_single("Obs_Minus_Forecast_unadjusted",ddiff )
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
diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90
index 935366650c..136568d1f3 100644
--- a/src/gsi/setuprad.f90
+++ b/src/gsi/setuprad.f90
@@ -376,7 +376,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
logical in_curbin, in_anybin, save_jacobian
logical account_for_corr_obs
logical,dimension(nobs):: zero_irjaco3_pole
- logical abi2km ! use 2km abi data (not CSR/ASR)
! Declare local arrays
@@ -410,7 +409,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
real(r_kind) :: clw_guess,clw_guess_retrieval,ciw_guess,rain_guess,snow_guess,clw_avg
real(r_kind),dimension(:), allocatable :: rsqrtinv
real(r_kind),dimension(:), allocatable :: rinvdiag
- real(r_kind),dimension(nchanl) :: abi2km_bc
!for GMI (dual scan angles)
real(r_kind),dimension(nchanl):: emissivity2,ts2, emissivity_k2,tsim2
@@ -529,7 +527,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
atms = obstype == 'atms'
saphir = obstype == 'saphir'
abi = obstype == 'abi'
- abi2km = .false.
ssmis=ssmis_las.or.ssmis_uas.or.ssmis_img.or.ssmis_env.or.ssmis
@@ -1102,12 +1099,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
endif
predbias=zero
- 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
- end if
!$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias)
do i=1,nchanl
@@ -1187,18 +1178,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
end do
end if
- if (abi2km .and. regional) then
- 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
@@ -1284,8 +1263,8 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,&
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_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)
+ 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, &
@@ -1319,11 +1298,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
diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90
index 8d1c308d7f..2f1f57f583 100644
--- a/src/gsi/setupt.f90
+++ b/src/gsi/setupt.f90
@@ -448,7 +448,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
do k=1,nobs
ikx=nint(data(ikxx,k))
itype=ictype(ikx)
- landsfctype =( itype==181 .or. itype==183 .or. itype==187 .or. itype==188 )
+ landsfctype =( itype==181 .or. itype==183 .or. itype==187 )
do l=k+1,nobs
if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then
duplogic=data(ilat,k) == data(ilat,l) .and. &
@@ -483,9 +483,6 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav
! Run a buddy-check
! Note: buddy check crashes for hofx_2m_sfcfile option.
-! Ccurrent params have buddy radius of 108 km, max diff of 8 K.
-! The gross error check removes O-F > 7., so this is probably removing
-! most obs that fail the buddy check already
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
diff --git a/src/gsi/ssmis_spatial_average_mod.f90 b/src/gsi/ssmis_spatial_average_mod.f90
index 64dd5c6cf7..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
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 9a280c4e55..a133889eac 100755
--- a/ush/build.sh
+++ b/ush/build.sh
@@ -24,7 +24,7 @@ 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
diff --git a/ush/detect_machine.sh b/ush/detect_machine.sh
index ac6c7f58d1..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[1-3].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,24 +35,58 @@ case $(hostname -f) in
Orion-login-[1-4].HPC.MsState.Edu) MACHINE_ID=orion ;; ### orion1-4
- Hercules-login-[1-4].HPC.MsState.Edu) MACHINE_ID=hercules ;; ### hercules1-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
- chadmin[1-6].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 d13da1efa3..299e13aa4e 100755
--- a/ush/module-setup.sh
+++ b/ush/module-setup.sh
@@ -40,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
@@ -63,10 +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
fi
-
- source /lustre/f2/dev/role.epic/contrib/Lmod_init.sh
+ module reset
elif [[ $MACHINE_ID = expanse* ]]; then
# We are on SDSC Expanse
@@ -82,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/sub_cheyenne b/ush/sub_cheyenne
deleted file mode 100644
index 7389bfeb24..0000000000
--- a/ush/sub_cheyenne
+++ /dev/null
@@ -1,169 +0,0 @@
-#!/bin/sh --login
-set -x
-echo "starting sub_cheyenne"
-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)
-
-DATA=/glade/scratch/$LOGNAME/tmp
-mkdir -p $DATA
-
-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/sh --login" >> $cfile
-echo "" >> $cfile
-echo "#PBS -o $output" >> $cfile
-echo "#PBS -N $jobname" >> $cfile
-echo "#PBS -q $queue" >> $cfile
-echo "#PBS -l walltime=$timew" >> $cfile
-echo "#PBS -l select=$nodes:ncpus=$procs:mpiprocs=$procs" >> $cfile
-echo "#PBS -j oe" >> $cfile
-echo "#PBS -A $accnt" >> $cfile
-echo "#PBS -V" >> $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 "cfile = $cfile"
-echo "source /glade/u/apps/ch/modulefiles/default/localinit/localinit.sh >> $cfile"
-echo "module purge" >> $cfile
-echo "module use $modulefiles" >> $cfile
-echo "module load gsi_cheyenne.intel" >> $cfile
-echo "module list" >> $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
-qsub=${qsub:-qsub}
-
-ofile=$DATA/subout$$
->$ofile
-chmod 777 $ofile
-$qsub $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
-echo "ending sub_cheyenne"
-exit $rc
-
diff --git a/ush/sub_discover b/ush/sub_discover
index 583ffbef86..5d6364be97 100755
--- a/ush/sub_discover
+++ b/ush/sub_discover
@@ -130,7 +130,7 @@ 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 $modulefiles" >> $cfile
-echo "module load gsi_discover" >> $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
index 6fed1b3c10..9c4e253c93 100755
--- a/ush/sub_gaea
+++ b/ush/sub_gaea
@@ -88,8 +88,8 @@ output=${output:-$jobname.out}
myuser=$LOGNAME
myhost=$(hostname)
-if [ -d /lustre/f2/scratch/$LOGNAME ]; then
- DATA=/lustre/f2/scratch/$LOGNAME/tmp
+if [ -d /gpfs/f5/epic/scratch/${USER}/$LOGNAME ]; then
+ DATA=/gpfs/f5/epic/scratch/${USER}/$LOGNAME/tmp
fi
DATA=${DATA:-$ptmp/tmp}
@@ -110,7 +110,7 @@ echo ""
echo "#SBATCH --output=$output" >> $cfile
echo "#SBATCH --job-name=$jobname" >> $cfile
echo "#SBATCH --qos=$queue" >> $cfile
-echo "#SBATCH --clusters=c4" >> $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
@@ -121,15 +121,15 @@ 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 "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 "source /lustre/f2/dev/role.epic/contrib/Lmod_init.sh" >> $cfile
+echo "module reset" >> $cfile
echo "module use $modulefiles" >> $cfile
-echo "module load gsi_gaea" >> $cfile
+echo "module load gsi_gaea.intel" >> $cfile
echo "module list" >> $cfile
echo "" >>$cfile
@@ -158,7 +158,7 @@ sbatch=${sbatch:-sbatch}
ofile=$DATA/subout$$
>$ofile
chmod 777 $ofile
-$sbatch --export=ALL $cfile >$ofile
+$sbatch $cfile >$ofile
rc=$?
cat $ofile
if [[ -w $SUBLOG ]];then
diff --git a/ush/sub_hera b/ush/sub_hera
index 610756af00..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
@@ -143,7 +143,6 @@ 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
index 573378fdb6..78a0f5daee 100755
--- a/ush/sub_hercules
+++ b/ush/sub_hercules
@@ -111,7 +111,7 @@ echo "#SBATCH --job-name=$jobname"
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
@@ -119,7 +119,6 @@ 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
@@ -129,9 +128,10 @@ echo "" >>$cfile
echo ". /apps/other/lmod/lmod/init/sh" >> $cfile
echo "module purge" >> $cfile
echo "module use $modulefiles" >> $cfile
-echo "module load gsi_hercules" >> $cfile
-echo "module list" >> $cfile
-echo "" >> $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
diff --git a/ush/sub_jet b/ush/sub_jet
index d30c566ce3..96f3eae9b2 100755
--- a/ush/sub_jet
+++ b/ush/sub_jet
@@ -108,7 +108,7 @@ 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 --account=$accnt" >> $cfile
echo "#SBATCH --mem=0" >> $cfile
echo "#SBATCH --partition=kjet" >> $cfile
@@ -127,7 +127,7 @@ echo "" >>$cfile
echo ". /apps/lmod/lmod/init/sh" >> $cfile
echo "module purge" >> $cfile
echo "module use $modulefiles" >> $cfile
-echo "module load gsi_jet" >> $cfile
+echo "module load gsi_jet.intel" >> $cfile
echo "module list" >> $cfile
echo "" >>$cfile
diff --git a/ush/sub_orion b/ush/sub_orion
index e5844474db..371c30e321 100755
--- a/ush/sub_orion
+++ b/ush/sub_orion
@@ -111,27 +111,29 @@ echo "#SBATCH --job-name=$jobname"
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 $modulefiles" >> $cfile
-echo "module load gsi_orion" >> $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 f2df099f23..cd21e932f8 100755
--- a/ush/sub_wcoss2
+++ b/ush/sub_wcoss2
@@ -125,7 +125,7 @@ echo "" >> $cfile
echo "module reset" >> $cfile
echo "module use $modulefiles" >> $cfile
-echo "module load gsi_wcoss2" >> $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