From 1cc934edaaa77bd3eee51744f1cf81810d52e2c0 Mon Sep 17 00:00:00 2001
From: shoyokota <103961291+shoyokota@users.noreply.github.com>
Date: Tue, 26 Mar 2024 07:07:28 -0400
Subject: [PATCH 1/3] Add the Multigrid Beta Filter (MGBF) for ensemble
localization (#699) (#700)
**DUE DATE for merger of this PR into `develop` is 3/29/2024 (six weeks
after PR creation).**
**Description**
Resolves #699
This PR is to add the option to apply Multigrid Beta Filter (MGBF;
[Purser et al. 2022](https://doi.org/10.1175/MWR-D-20-0405.1)) for
ensemble localization instead of Recursive Filter (RF). This work
includes to add an initial version of the MGBF as a subdirectory in GSI.
To apply the MGBF, set "l_mgbf_loc=true" in the namelist and
additionally input "mgbf_loc01.nml". (In Scale/Variable-Dependent
Localization, input also "mgbf_locXX.nml" (XX=02,03,...) with the same
number of grid points.)
**How to set MGBF parameters in mgbf_locXX.nml
**
An example of mgbf_locXX.nml is as follows:
```
&PARAMETERS_MGBETA
mg_ampl01=1.125, ! length of vertical beta filter (standard deviation; filter grid unit)
mg_ampl02=2.4, ! length of horizontal beta filter (standard deviation; filter grid unit)
mg_ampl03=0.85, ! length of 3D beta filter (standard deviation; filter grid unit)
mg_weig1=0., ! weight of generation 1
mg_weig2=0., ! weight of generation 2
mg_weig3=0., ! weight of generation 3
mg_weig4=1., ! weight of generation 4
hx=5, ! number of halo grid points in x-direction
hy=5, ! number of halo grid points in y-direction
hz=3, ! number of halo grid points in z-direction
p=2, ! beta filter exponent
mgbf_line=.false., ! set false except for mgbf_proc=2,4,7
mgbf_proc=8, ! 1-2: 3D filter; 3-5: 2D filter for static B; 6-8: 2D filter for localization (1,3,6: radial filter; 2,4,7: line filter; 5,8: isotropic line filter)
lm_a=65, ! number of vertical layers in analysis grid
lm=33, ! number of vertical layers in filter grid
km2=0, ! number of 2D variables (set 0 for localization)
km3=1, ! number of 3D variables (set 1 for localization)
n_ens=30, ! ensemble size
l_loc=.true., ! set true in localization
l_filt_g1=.false., ! set false in skipping generation 1
l_lin_vertical=.true., ! set true in applying linear vertical interpolation for analysis-filter mapping
l_lin_horizontal=.true., ! set true in applying linear horizontal interpolation for analysis-filter mapping
l_quad_horizontal=.false., ! set true in applying quadratic horizontal interpolation for analysis-filter mapping
l_new_map=.true., ! set true in applying efficient vertical interpolation for analysis-filter mapping
l_vertical_filter=.true., ! set true in applying vertical beta filter outside 2D filter
ldelta=.false., ! (not used)
lquart=.false., ! set true in applying quadratic horizontal interpolation for up/down-sending
lhelm=.false., ! set true in applying Helmholtz differential operator for weighting
nm0=1975, ! number of analysis grid points in x-direction
mm0=1350, ! number of analysis grid points in y-direction
gm_max=4, ! highest generation (max: 4)
nxPE=79, ! number of MPI processors in x-direction
nyPE=54, ! number of MPI processors in y-direction
im_filt=8, ! number of filter grid points in each MPI processor in x-direction
jm_filt=8, ! number of filter grid points in each MPI processor in y-direction
/
```
Here, to make the result of MGBF-based localization similar to RF-based
one, we can set the beta filter length ( mg_ampl0[12] ) from the
recursive filter length in the GSI namelist ( s_ens_[vh] ) as:
- $\text{mg\\_ampl01} = \left[\text{s\\_ens\\_v (grid unit)} *
\frac{1}{\sqrt{2}} * \frac{\text{lm}-1}{\text{lm\\_a}-1} \right]^2$
- $\text{mg\\_ampl02} = \left[\frac{\text{s\\_ens\\_h
(km)}}{\text{analysis grid interval (km)}} * \frac{1}{\sqrt{2}} *
\frac{\text{im\\_filt} * \text{nxPE}}{\text{nm0}} * \frac{1}{2} *
\frac{1}{2} * \frac{1}{2} \right]^2$ (in case mg_weig[1-4]=[0,0,0,1])
Please note there are some limitations for the other MGBF parameters
such as:
- The number of MPI processors input in GSI should be nxPE x nyPE
- (nm0, mm0, lm_a) should be the same as the GSI analysis grid
- nm0 should be divisible by nxPE
- mm0 should be divisible by nyPE
- nm0 / nxPE = mm0 / nyPE
**How to run RRFS regression tests with MGBF-based
localization
**
Change settings in regression/ as follows, and run Test#3
(rrfs_3denvar_glbens)
```diff
diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh
index 7ca183ef3..671d028ff 100755
--- a/regression/regression_namelists.sh
+++ b/regression/regression_namelists.sh
@@ -457,7 +457,7 @@ OBS_INPUT::
beta_s0=0.15,s_ens_h=110,s_ens_v=3,
regional_ensemble_option=1,
pseudo_hybens = .false.,
- grid_ratio_ens = 3,
+ grid_ratio_ens = 5.1,
l_ens_in_diff_time=.true.,
ensemble_path='',
i_en_perts_io=1,
@@ -465,6 +465,7 @@ OBS_INPUT::
fv3sar_bg_opt=0,
readin_localization=.true.,
ens_fast_read=.false.,
+ l_mgbf_loc=.true.,
/
&RAPIDREFRESH_CLDSURF
dfi_radar_latent_heat_time_period=20.0,
```
```diff
diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh
index e03917e88..36b8b6a22 100755
--- a/regression/regression_namelists_db.sh
+++ b/regression/regression_namelists_db.sh
@@ -438,7 +438,7 @@ OBS_INPUT::
beta_s0=0.15,s_ens_h=110,s_ens_v=3,
regional_ensemble_option=1,
pseudo_hybens = .false.,
- grid_ratio_ens = 3,
+ grid_ratio_ens = 5.1,
l_ens_in_diff_time=.true.,
ensemble_path='',
i_en_perts_io=1,
@@ -446,6 +446,7 @@ OBS_INPUT::
fv3sar_bg_opt=0,
readin_localization=.true.,
ens_fast_read=.false.,
+ l_mgbf_loc=.true.,
/
&RAPIDREFRESH_CLDSURF
dfi_radar_latent_heat_time_period=20.0,
```
```diff
diff --git a/regression/regression_param.sh b/regression/regression_param.sh
index 2ac615fc4..6186acdbb 100755
--- a/regression/regression_param.sh
+++ b/regression/regression_param.sh
@@ -87,23 +87,23 @@ case $regtest in
rrfs_3denvar_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]="30/2/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="15/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]="30/2/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="15/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:15:00" ; popts[1]="30/2/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="15/4/" ; 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"
+ topts[1]="0:15:00" ; popts[1]="15/4/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="10/6/" ; 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]="15/4/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="10/6/" ; 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"
+ topts[1]="0:15:00" ; popts[1]="60/1/" ; ropts[1]="/1"
+ topts[2]="0:15:00" ; popts[2]="30/2/" ; ropts[2]="/1"
fi
if [ "$debug" = ".true." ] ; then
```
```diff
diff --git a/regression/rrfs_3denvar_glbens.sh b/regression/rrfs_3denvar_glbens.sh
index af5da5117..04fd73d57 100755
--- a/regression/rrfs_3denvar_glbens.sh
+++ b/regression/rrfs_3denvar_glbens.sh
@@ -272,6 +272,46 @@ $gsi_namelist
EOF
+cat << EOF > mgbf_loc01.nml
+&PARAMETERS_MGBETA
+ mg_ampl01=1.125, ! length of vertical beta filter (standard deviation; filter grid unit)
+ mg_ampl02=1.615, ! length of horizontal beta filter (standard deviation; filter grid unit)
+ mg_ampl03=0.85, ! length of 3D beta filter (standard deviation; filter grid unit)
+ mg_weig1=0., ! weight of generation 1
+ mg_weig2=1., ! weight of generation 2
+ mg_weig3=0., ! weight of generation 3
+ mg_weig4=0., ! weight of generation 4
+ hx=4, ! number of halo grid points in x-direction
+ hy=4, ! number of halo grid points in y-direction
+ hz=3, ! number of halo grid points in z-direction
+ p=2, ! beta filter exponent
+ mgbf_line=.false., ! set false except for mgbf_proc=2,4,7
+ mgbf_proc=8, ! 1-2: 3D filter; 3-5: 2D filter for static B; 6-8: 2D filter for localization (1,3,6: radial filter; 2,4,7: line filter; 5,8: isotropic line filter)
+ lm_a=65, ! number of vertical layers in analysis grid
+ lm=33, ! number of vertical layers in filter grid
+ km2=0, ! number of 2D variables (set 0 for localization)
+ km3=1, ! number of 3D variables (set 1 for localization)
+ n_ens=10, ! ensemble size
+ l_loc=.true., ! set true in localization
+ l_filt_g1=.false., ! set false in skipping generation 1
+ l_lin_vertical=.true., ! set true in applying linear vertical interpolation for analysis-filter mapping
+ l_lin_horizontal=.true., ! set true in applying linear horizontal interpolation for analysis-filter mapping
+ l_quad_horizontal=.false., ! set true in applying quadratic horizontal interpolation for analysis-filter mapping
+ l_new_map=.true., ! set true in applying efficient vertical interpolation for analysis-filter mapping
+ l_vertical_filter=.true., ! set true in applying vertical beta filter outside 2D filter
+ ldelta=.false., ! (not used)
+ lquart=.false., ! set true in applying quadratic horizontal interpolation for up/down-sending
+ lhelm=.false., ! set true in applying Helmholtz differential operator for weighting
+ nm0=40, ! number of analysis grid points in x-direction
+ mm0=24, ! number of analysis grid points in y-direction
+ gm_max=2, ! highest generation (max: 4)
+ nxPE=10, ! number of MPI processors in x-direction
+ nyPE=6, ! number of MPI processors in y-direction
+ im_filt=4, ! number of filter grid points in each MPI processor in x-direction
+ jm_filt=4, ! number of filter grid points in each MPI processor in y-direction
+ /
+EOF
+
# Copy executable and fixed files to $tmpdir
if [[ $exp == *"updat"* ]]; then
$ncp $gsiexec_updat ./gsi.x
```
**Type of change**
Please delete options that are not relevant.
- [ ] Bug fix (non-breaking change which fixes an issue)
- [x] New feature (non-breaking change which adds functionality)
- [ ] Breaking change (fix or feature that would cause existing
functionality to not work as expected)
- [ ] This change requires a documentation update
**How Has This Been Tested?**
EnVar for NA-domain RRFS was tested with "mgbf_locXX.nml" (XX=01) shown
above on Orion. The resulting analysis increment was similar to the
original and the computation time for localization became short.
**Checklist**
- [x] My code follows the style guidelines of this project
- [x] I have performed a self-review of my own code
- [x] I have commented my code, particularly in hard-to-understand areas
- [x] New and existing tests pass with my changes
- [x] Any dependent changes have been merged and published
Co-authored-by: Sho Yokota
---
CMakeLists.txt | 2 +
INSTALL.md | 1 +
src/CMakeLists.txt | 5 +
src/gsi/CMakeLists.txt | 15 +
src/gsi/gsimod.F90 | 18 +-
src/gsi/hybrid_ensemble_isotropic.F90 | 515 +-
src/gsi/hybrid_ensemble_parameters.f90 | 5 +
src/mgbf/CMakeLists.txt | 98 +
src/mgbf/cmake/PackageConfig.cmake.in | 19 +
src/mgbf/jp_pbfil.f90 | 1119 ++++
src/mgbf/jp_pbfil2.f90 | 1173 ++++
src/mgbf/jp_pbfil3.f90 | 2620 ++++++++
src/mgbf/jp_pietc.f90 | 111 +
src/mgbf/jp_pietc_s.f90 | 113 +
src/mgbf/jp_pkind.f90 | 34 +
src/mgbf/jp_pkind2.f90 | 25 +
src/mgbf/jp_pmat.f90 | 1096 ++++
src/mgbf/jp_pmat4.f90 | 2086 ++++++
src/mgbf/kinds.f90 | 118 +
src/mgbf/mg_bocos.f90 | 8016 ++++++++++++++++++++++++
src/mgbf/mg_domain.f90 | 644 ++
src/mgbf/mg_domain_loc.f90 | 796 +++
src/mgbf/mg_entrymod.f90 | 158 +
src/mgbf/mg_filtering.f90 | 1629 +++++
src/mgbf/mg_generations.f90 | 1756 ++++++
src/mgbf/mg_input.f90 | 155 +
src/mgbf/mg_interpolate.f90 | 972 +++
src/mgbf/mg_intstate.f90 | 1394 ++++
src/mgbf/mg_mppstuff.f90 | 190 +
src/mgbf/mg_parameter.f90 | 936 +++
src/mgbf/mg_timers.f90 | 218 +
src/mgbf/mg_transfer.f90 | 499 ++
src/mgbf/type_intstat_locpointer.inc | 44 +
src/mgbf/type_intstat_point2this.inc | 83 +
src/mgbf/type_parameter_locpointer.inc | 105 +
src/mgbf/type_parameter_point2this.inc | 189 +
36 files changed, 26816 insertions(+), 141 deletions(-)
create mode 100644 src/mgbf/CMakeLists.txt
create mode 100644 src/mgbf/cmake/PackageConfig.cmake.in
create mode 100644 src/mgbf/jp_pbfil.f90
create mode 100644 src/mgbf/jp_pbfil2.f90
create mode 100644 src/mgbf/jp_pbfil3.f90
create mode 100644 src/mgbf/jp_pietc.f90
create mode 100644 src/mgbf/jp_pietc_s.f90
create mode 100644 src/mgbf/jp_pkind.f90
create mode 100644 src/mgbf/jp_pkind2.f90
create mode 100644 src/mgbf/jp_pmat.f90
create mode 100644 src/mgbf/jp_pmat4.f90
create mode 100644 src/mgbf/kinds.f90
create mode 100644 src/mgbf/mg_bocos.f90
create mode 100644 src/mgbf/mg_domain.f90
create mode 100644 src/mgbf/mg_domain_loc.f90
create mode 100644 src/mgbf/mg_entrymod.f90
create mode 100644 src/mgbf/mg_filtering.f90
create mode 100644 src/mgbf/mg_generations.f90
create mode 100644 src/mgbf/mg_input.f90
create mode 100644 src/mgbf/mg_interpolate.f90
create mode 100644 src/mgbf/mg_intstate.f90
create mode 100644 src/mgbf/mg_mppstuff.f90
create mode 100644 src/mgbf/mg_parameter.f90
create mode 100644 src/mgbf/mg_timers.f90
create mode 100644 src/mgbf/mg_transfer.f90
create mode 100644 src/mgbf/type_intstat_locpointer.inc
create mode 100644 src/mgbf/type_intstat_point2this.inc
create mode 100644 src/mgbf/type_parameter_locpointer.inc
create mode 100644 src/mgbf/type_parameter_point2this.inc
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/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/gsi/CMakeLists.txt b/src/gsi/CMakeLists.txt
index af94224c05..f894b0a8a8 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/gsimod.F90 b/src/gsi/gsimod.F90
index 45d88887a3..8a1ce896bb 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,&
@@ -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 ):
@@ -1985,6 +1987,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/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
From 6d9ebbb7896b92a93959ce63c7a1ad9e9a0aab4f Mon Sep 17 00:00:00 2001
From: Andrew Collard <40322596+ADCollard@users.noreply.github.com>
Date: Tue, 26 Mar 2024 15:41:59 -0400
Subject: [PATCH 2/3] Dsfcalc fix (#727)
Tiny fix to allow modelling of sub-fov variability for NOAA-21 ATMS.
---
regression/regression_namelists.sh | 2 +-
src/gsi/calc_fov_crosstrk.f90 | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh
index 7ca183ef3e..552bc1ba59 100755
--- a/regression/regression_namelists.sh
+++ b/regression/regression_namelists.sh
@@ -181,7 +181,7 @@ OBS_INPUT::
sstviirs viirs-m j1 viirs-m_j1 0.0 4 0
abibufr abi g18 abi_g18 0.0 1 0
ahibufr ahi himawari9 ahi_himawari9 0.0 1 0
- atmsbufr atms n21 atms_n21 0.0 1 0
+ atmsbufr atms n21 atms_n21 0.0 1 1
crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0
sstviirs viirs-m j2 viirs-m_j2 0.0 4 0
ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0
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)
From b53740a7bd1cc416f634589075b8c8b89f0ef761 Mon Sep 17 00:00:00 2001
From: Xu Lu
Date: Tue, 26 Mar 2024 21:46:08 -0400
Subject: [PATCH 3/3] Fix HAFS GSI debug build and run issues (#679)
**DUE DATE for merger of this PR into `develop` is 2/19/2024 (six weeks
after PR creation).**
**DUE DATE for this PR is extended to 3/19/2024 because @XuLu-NOAA is on
leave.**
**Description**
Xu Lu (xu.lu@noaa.gov) and Biju Thomas (biju.thomas@noaa.gov) fixed bugs
regarding HAFS GSI debug build and run issues. This is in corresponding
to issue #661
Fixes #661
1. In read_radar.f90, uninitialized toff is making all the ground-based
radar observations be placed at -3h instead of 0h, which creates wrong
increments for FGAT and 4DEnVar.
2. In read_radar.f90, uninitialized zsges will crash the debug mode.
3. In read_radar.f90, t4dvo should be used instead of t4dv in the
read_radar_l2rw_novadqc subroutine.
4. In radinfo.90, maxscan should be increased to at least 252 to allow
more scans, or it will crash the debug mode.
5. In read_fl_hdob.f90, dlnpsob is replaced with 1000. since the SFMR
does not sample surface pressure, and the uninitialized dlnpsob creates
issues later in setupspd.f90 in the debug mode.
6. In mod_fv3_lola.f90, (i,j+1) should be used instead of (i+1,j) in
searching for V edges.
7. In stpcalc.f90, when tried to find the best stepsize from outpen
around L838-864, the minimum outstp(i) is stored in stp(ii), but the
istp_use is asigned with i instead of ii. Create inconsistency when
assigning stp(istp_use) to stpinout at L872. Should use istp_use=ii
instead.
**Type of change**
- [Yes] Bug fix (non-breaking change which fixes an issue)
**How Has This Been Tested?**
Regression test on Orion:
```
Test project /work/noaa/hwrf/save/xulu/mergeversions/GSI/build
CMake Warning (dev) at CTestTestfile.cmake:9 (subdirs): Syntax Warning in cmake code at /work/noaa/hwrf/save/xulu/mergeversions/GSI/build/regression/CTestTestfile.cmake:7:10
1/7 Test #4: [=[netcdf_fv3_regional]=] ........ Passed 365.11 sec
2/7 Test #7: [=[global_enkf]=] ................ Passed 430.29 sec
3/7 Test #3: [=[rrfs_3denvar_glbens]=] ........ Passed 605.35 sec
4/7 Test #2: [=[rtma]=] ....................... Passed 969.78 sec
5/7 Test #6: [=[hafs_3denvar_hybens]=] ........***Failed 1455.47 sec
6/7 Test #1: [=[global_4denvar]=] ............. Passed 1682.40 sec
7/7 Test #5: [=[hafs_4denvar_glbens]=] ........***Failed 1758.90 sec
```
The failed hafs_3denvar and 4denvar are within expectation due to the
fix for toff. As demonstrated in the single observation tests in the
following figure, the uninitialized toff can result in increment
degradations due to wrongly assigned observation times:
---
src/gsi/mod_fv3_lola.f90 | 8 +++-----
src/gsi/radinfo.f90 | 2 +-
src/gsi/read_fl_hdob.f90 | 4 ++--
src/gsi/read_radar.f90 | 24 +++++++++++++-----------
src/gsi/stpcalc.f90 | 4 ++--
5 files changed, 21 insertions(+), 21 deletions(-)
diff --git a/src/gsi/mod_fv3_lola.f90 b/src/gsi/mod_fv3_lola.f90
index e8df85068e..11bb3b6e37 100644
--- a/src/gsi/mod_fv3_lola.f90
+++ b/src/gsi/mod_fv3_lola.f90
@@ -951,7 +951,6 @@ subroutine definecoef_regular_grids(nxen,nyen,grid_lon,grid_lont,grid_lat,grid_l
do i=1,nxen
! center lat/lon of the edge
rlat=half*(grid_lat(i,j)+grid_lat(i+1,j))
-! rlon=half*(grid_lon(i,j)+grid_lon(i+1,j))
diff=(grid_lon(i,j)-grid_lon(i+1,j))**2
if(diff < sq180)then
rlon=half*(grid_lon(i,j)+grid_lon(i+1,j))
@@ -979,12 +978,11 @@ subroutine definecoef_regular_grids(nxen,nyen,grid_lon,grid_lont,grid_lat,grid_l
do j=1,nyen
do i=1,nxen+1
rlat=half*(grid_lat(i,j)+grid_lat(i,j+1))
-! rlon=half*(grid_lon(i,j)+grid_lon(i,j+1))
- diff=(grid_lon(i,j)-grid_lon(i+1,j))**2
+ diff=(grid_lon(i,j)-grid_lon(i,j+1))**2
if(diff < sq180)then
- rlon=half*(grid_lon(i,j)+grid_lon(i+1,j))
+ rlon=half*(grid_lon(i,j)+grid_lon(i,j+1))
else
- rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)-360._r_kind)
+ rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)-360._r_kind)
endif
xr=cos(rlat*deg2rad)*cos(rlon*deg2rad)
yr=cos(rlat*deg2rad)*sin(rlon*deg2rad)
diff --git a/src/gsi/radinfo.f90 b/src/gsi/radinfo.f90
index ede58b9bca..4ad17626e6 100644
--- a/src/gsi/radinfo.f90
+++ b/src/gsi/radinfo.f90
@@ -897,7 +897,7 @@ subroutine radinfo_read
! Allocate arrays to receive angle dependent bias information.
! Open file to bias file (satang=satbias_angle). Read data.
- maxscan=250
+ maxscan=252
if (.not.adp_anglebc) maxscan = 90 ! default value for old files
if (adp_anglebc) then
diff --git a/src/gsi/read_fl_hdob.f90 b/src/gsi/read_fl_hdob.f90
index 1ef3d8617f..4041740d52 100644
--- a/src/gsi/read_fl_hdob.f90
+++ b/src/gsi/read_fl_hdob.f90
@@ -48,7 +48,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
use kinds, only: r_single,r_kind,r_double,i_kind
use constants, only: zero,one_tenth,one,two,ten,deg2rad,t0c,half,&
three,four,rad2deg,tiny_r_kind,huge_r_kind,r0_01,&
- r60inv,r10,r100,r2000,hvap,eps,omeps,rv,grav
+ r60inv,r10,r100,r2000,hvap,eps,omeps,rv,grav,r_missing
use gridmod, only: diagnostic_reg,regional,nlon,nlat,nsig,&
tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,&
rlats,rlons,twodvar_regional,fv3_regional
@@ -1133,7 +1133,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si
cdata_all( 1,iout)=woe ! wind error
cdata_all( 2,iout)=dlon ! grid relative longitude
cdata_all( 3,iout)=dlat ! grid relative latitude
- cdata_all( 4,iout)=dlnpsob ! ln(surface pressure in cb)
+ cdata_all( 4,iout)=r_missing ! ln(surface pressure in cb) !Since dlnpsob is not provided by SFMR, force it to be r_missing. Not used in setupspd.f90
cdata_all( 5,iout)=spdob*sqrt(two)*half ! u obs
cdata_all( 6,iout)=spdob*sqrt(two)*half ! v obs
cdata_all( 7,iout)=rstation_id ! station id
diff --git a/src/gsi/read_radar.f90 b/src/gsi/read_radar.f90
index 5b1cffbf0c..a824bbbe4e 100644
--- a/src/gsi/read_radar.f90
+++ b/src/gsi/read_radar.f90
@@ -3282,7 +3282,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
use convinfo, only: nconvtype,ncmiter,ncgroup,ncnumgrp,icuse,ioctype,pmot_conv
use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model
use mpimod, only: npe
- use obsmod, only: reduce_diag
+ use obsmod, only: reduce_diag,time_offset
implicit none
@@ -3323,7 +3323,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
integer(i_kind) iret,kx0
integer(i_kind) nreal,nchanl,ilat,ilon,ikx
integer(i_kind) idomsfc
- real(r_kind) usage,ff10,sfcr,skint,t4dv,t4dvo,toff
+ real(r_kind) usage,ff10,sfcr,skint,t4dvo
real(r_kind) eradkm,dlat_earth,dlon_earth
real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat
real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist
@@ -3467,7 +3467,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
staheight=this_stahgt !station elevation
tiltangle=corrected_tilt*deg2rad
- t4dvo=toff+thistime
+ t4dvo=thistime+time_offset
timemax=max(timemax,t4dvo)
timemin=min(timemin,t4dvo)
@@ -3586,7 +3586,8 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
end if
if(usage >= 100._r_kind)rusage(ndata)=.true.
- call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr)
+ call deter_sfc2(dlat_earth,dlon_earth,t4dvo,idomsfc,skint,ff10,sfcr)
+ call deter_zsfc_model(dlat,dlon,zsges)
cdata(1) = error ! wind obs error (m/s)
cdata(2) = dlon ! grid relative longitude
@@ -3594,7 +3595,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs)
cdata(4) = height ! obs absolute height (m)
cdata(5) = rwnd ! wind obs (m/s)
cdata(6) = azm*deg2rad ! azimuth angle (radians)
- cdata(7) = t4dv ! obs time (hour)
+ cdata(7) = t4dvo ! obs time (hour)
cdata(8) = ikx ! type
cdata(9) = tiltangle ! tilt angle (radians)
cdata(10)= staheight ! station elevation (m)
@@ -3699,6 +3700,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
use obsmod, only: doradaroneob,oneobradid,time_offset,reduce_diag
use mpeu_util, only: gettablesize,gettable
use convinfo, only: nconvtype,icuse,ioctype
+ use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model
use mpimod, only: npe
use read_l2bufr_mod, only: radar_sites,radar_rmesh,radar_zmesh,elev_angle_max,del_time,range_max,radar_pmot
use constants, only: eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening,grav_equator
@@ -3744,7 +3746,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
integer(i_kind) iret,kx0
integer(i_kind) nreal,nchanl,ilat,ilon,ikx
integer(i_kind) idomsfc
- real(r_kind) usage,ff10,sfcr,skint,t4dv,t4dvo,toff
+ real(r_kind) usage,ff10,sfcr,skint,t4dvo
real(r_kind) eradkm,dlat_earth,dlon_earth
real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat
real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist
@@ -4071,7 +4073,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
slat=sin(dlat_earth)
staheight=this_stahgt !station elevation
tiltangle=corrected_tilt*deg2rad
- t4dvo=toff+thistime
+ t4dvo=time_offset+thistime
timemax=max(timemax,t4dvo)
timemin=min(timemin,t4dvo)
! Exclude data if it does not fall within time window
@@ -4166,7 +4168,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
if (l4dvar) then
timedif = zero
else
- timedif=abs(t4dvo-toff)
+ timedif=abs(t4dvo-time_offset)
endif
crit1 = timedif/r6+half
call map3grids_m(1,save_all,zflag,zl_thin,nlevz, &
@@ -4233,8 +4235,8 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
end if
! Get information from surface file necessary for conventional data here
-! call deter_zsfc_model(dlat,dlon,zsges)
-! call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr)
+ call deter_zsfc_model(dlat,dlon,zsges)
+ call deter_sfc2(dlat_earth,dlon_earth,t4dvo,idomsfc,skint,ff10,sfcr)
nsuper2_kept=nsuper2_kept+1
cdata(1) = error ! wind obs error (m/s)
@@ -4243,7 +4245,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full)
cdata(4) = height ! obs absolute height (m)
cdata(5) = rwnd ! wind obs (m/s)
cdata(6) = azm*deg2rad ! azimuth angle (radians)
- cdata(7) = t4dvo+time_offset ! obs time (hour)
+ cdata(7) = t4dvo ! obs time (hour)
cdata(8) = ikx ! type
cdata(9) = tiltangle ! tilt angle (radians)
cdata(10)= staheight ! station elevation (m)
diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90
index c66bb58291..34030763db 100644
--- a/src/gsi/stpcalc.f90
+++ b/src/gsi/stpcalc.f90
@@ -844,10 +844,10 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, &
if(outpen(i) < outpensave)then
stp(ii)=outstp(i)
outpensave=outpen(i)
- istp_use=i
+ istp_use=ii
end if
end do
- if(istp_use /= istp_iter) then
+ if(istp_use /= nsteptot) then
final_ii=ii
exit stepsize
end if