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/2] 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/2] 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)