From 970fe2e68eb3f3febc3fdd9a99e020e48a4ade9d Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 6 Feb 2024 02:31:42 +0000 Subject: [PATCH 001/199] begin working on upgraded mgbf --- CMakeLists.txt | 3 +- cmake/compiler_flags_Intel_Fortran.cmake | 6 +- src/saber/CMakeLists.txt | 3 +- src/saber/mgbf/covariance/1 | 12 + src/saber/mgbf/covariance/Convariance.h.org | 199 + src/saber/mgbf/covariance/MGBF_Covariance.cc | 36 + src/saber/mgbf/covariance/MGBF_Covariance.h | 228 + .../covariance/MGBF_Covariance.interface.F90 | 201 + .../covariance/MGBF_Covariance.interface.h | 38 + src/saber/mgbf/covariance/dd | 7 + src/saber/mgbf/covariance/dd.h | 245 + .../mgbf/covariance/mgbf_covariance_mod.f90 | 222 + .../tlei_tools_linkedlist_implementation.fypp | 263 + .../tlei_tools_linkedlist_interface.fypp | 32 + src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 | 94 + src/saber/mgbf/mgbf_lib/bak_type_bump.F90 | 2920 +++++++++ src/saber/mgbf/mgbf_lib/jp_pbfil.f90 | 1103 ++++ src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 | 1165 ++++ src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 | 2588 ++++++++ src/saber/mgbf/mgbf_lib/jp_pietc.f90 | 96 + src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 | 101 + src/saber/mgbf/mgbf_lib/jp_pkind.f90 | 14 + src/saber/mgbf/mgbf_lib/jp_pkind2.f90 | 7 + src/saber/mgbf/mgbf_lib/jp_pmat.f90 | 1083 ++++ src/saber/mgbf/mgbf_lib/jp_pmat4.f90 | 2060 ++++++ src/saber/mgbf/mgbf_lib/k.f90 | 206 + src/saber/mgbf/mgbf_lib/kinds.f90 | 115 + src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 5709 +++++++++++++++++ src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 1404 ++++ src/saber/mgbf/mgbf_lib/mg_generations.f90 | 577 ++ src/saber/mgbf/mgbf_lib/type_mg_domain.f90 | 737 +++ src/saber/mgbf/mgbf_lib/type_mg_entrymod.f90 | 180 + .../mgbf/mgbf_lib/type_mg_interpolate.f90 | 472 ++ src/saber/mgbf/mgbf_lib/type_mg_intstate.f90 | 437 ++ src/saber/mgbf/mgbf_lib/type_mg_mppstuff.f90 | 218 + src/saber/mgbf/mgbf_lib/type_mg_parameter.f90 | 610 ++ src/saber/mgbf/mgbf_lib/type_mg_transfer.f90 | 212 + src/saber/mgbf/mgbf_lib/type_mgbf.f90 | 119 + 38 files changed, 23718 insertions(+), 4 deletions(-) create mode 100644 src/saber/mgbf/covariance/1 create mode 100644 src/saber/mgbf/covariance/Convariance.h.org create mode 100644 src/saber/mgbf/covariance/MGBF_Covariance.cc create mode 100644 src/saber/mgbf/covariance/MGBF_Covariance.h create mode 100644 src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 create mode 100644 src/saber/mgbf/covariance/MGBF_Covariance.interface.h create mode 100644 src/saber/mgbf/covariance/dd create mode 100644 src/saber/mgbf/covariance/dd.h create mode 100644 src/saber/mgbf/covariance/mgbf_covariance_mod.f90 create mode 100644 src/saber/mgbf/covariance/tlei_tools_linkedlist_implementation.fypp create mode 100644 src/saber/mgbf/covariance/tlei_tools_linkedlist_interface.fypp create mode 100755 src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 create mode 100644 src/saber/mgbf/mgbf_lib/bak_type_bump.F90 create mode 100644 src/saber/mgbf/mgbf_lib/jp_pbfil.f90 create mode 100644 src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 create mode 100644 src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 create mode 100755 src/saber/mgbf/mgbf_lib/jp_pietc.f90 create mode 100644 src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 create mode 100755 src/saber/mgbf/mgbf_lib/jp_pkind.f90 create mode 100644 src/saber/mgbf/mgbf_lib/jp_pkind2.f90 create mode 100755 src/saber/mgbf/mgbf_lib/jp_pmat.f90 create mode 100644 src/saber/mgbf/mgbf_lib/jp_pmat4.f90 create mode 100644 src/saber/mgbf/mgbf_lib/k.f90 create mode 100755 src/saber/mgbf/mgbf_lib/kinds.f90 create mode 100755 src/saber/mgbf/mgbf_lib/mg_bocos.f90 create mode 100644 src/saber/mgbf/mgbf_lib/mg_filtering.f90 create mode 100644 src/saber/mgbf/mgbf_lib/mg_generations.f90 create mode 100755 src/saber/mgbf/mgbf_lib/type_mg_domain.f90 create mode 100644 src/saber/mgbf/mgbf_lib/type_mg_entrymod.f90 create mode 100644 src/saber/mgbf/mgbf_lib/type_mg_interpolate.f90 create mode 100755 src/saber/mgbf/mgbf_lib/type_mg_intstate.f90 create mode 100755 src/saber/mgbf/mgbf_lib/type_mg_mppstuff.f90 create mode 100755 src/saber/mgbf/mgbf_lib/type_mg_parameter.f90 create mode 100644 src/saber/mgbf/mgbf_lib/type_mg_transfer.f90 create mode 100755 src/saber/mgbf/mgbf_lib/type_mgbf.f90 diff --git a/CMakeLists.txt b/CMakeLists.txt index cffabb01b..5d4ae3c4f 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -37,7 +37,8 @@ find_package( MPI REQUIRED COMPONENTS Fortran ) find_package( NetCDF REQUIRED COMPONENTS C Fortran ) find_package( eckit 1.24.4 REQUIRED COMPONENTS MPI ) find_package( fckit 0.11.0 REQUIRED ) -find_package( atlas 0.35.0 REQUIRED COMPONENTS OMP_Fortran TESSELATION) +#cltorg find_package( atlas 0.35.0 REQUIRED COMPONENTS OMP_Fortran TESSELATION) +find_package( atlas 0.35.0 REQUIRED COMPONENTS OMP_Fortran ) if( ENABLE_MKL ) find_package( MKL ) diff --git a/cmake/compiler_flags_Intel_Fortran.cmake b/cmake/compiler_flags_Intel_Fortran.cmake index 39e231e37..58120321c 100644 --- a/cmake/compiler_flags_Intel_Fortran.cmake +++ b/cmake/compiler_flags_Intel_Fortran.cmake @@ -11,13 +11,15 @@ # RELEASE FLAGS #################################################################### -set( CMAKE_Fortran_FLAGS_RELEASE "-O3 -ip -unroll -inline -no-heap-arrays" ) +#cltorg set( CMAKE_Fortran_FLAGS_RELEASE "-O3 -ip -unroll -inline -no-heap-arrays" ) +set( CMAKE_Fortran_FLAGS_RELEASE "-O3 -ip -unroll -inline -no-heap-arrays -fpp" ) #################################################################### # DEBUG FLAGS #################################################################### -set( CMAKE_Fortran_FLAGS_DEBUG "-O0 -g -check bounds -traceback -warn -heap-arrays -fpe-all=0 -fpe:0 -check all" ) +#cltorg set( CMAKE_Fortran_FLAGS_DEBUG "-O0 -g -check bounds -traceback -warn -heap-arrays -fpe-all=0 -fpe:0 -check all" ) +set( CMAKE_Fortran_FLAGS_DEBUG "-O0 -g -check bounds -traceback -warn -heap-arrays -fpe-all=0 -fpe:0 -check all -fpp" ) #################################################################### # BIT REPRODUCIBLE FLAGS diff --git a/src/saber/CMakeLists.txt b/src/saber/CMakeLists.txt index 2c3b0d9dc..b65a9ee35 100644 --- a/src/saber/CMakeLists.txt +++ b/src/saber/CMakeLists.txt @@ -4,7 +4,8 @@ # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # Build list of subdirs with files to add -set( _subdirs blocks bump fastlam generic gsi interpolation oops spectralb util vader ) +set( _subdirs blocks bump fastlam generic interpolation oops spectralb util vader mgbf) +#clt set( _subdirs blocks bump fastlam generic interpolation oops spectralb util vader mgbf) foreach( _subdir IN LISTS _subdirs ) add_subdirectory( ${_subdir} ) list( TRANSFORM ${_subdir}_src_files PREPEND ${_subdir}/ ) diff --git a/src/saber/mgbf/covariance/1 b/src/saber/mgbf/covariance/1 new file mode 100644 index 000000000..d4b3ec8f9 --- /dev/null +++ b/src/saber/mgbf/covariance/1 @@ -0,0 +1,12 @@ +1 +MGBF_Covariance.h +dd +dd.h +mgbf_covariance_mod.f90 +MGBF_Covariance.cc +MGBF_Covariance.interface.h +Convariance.h.org +MGBF_Covariance.interface.F90 +dr-bak/ +tlei_tools_linkedlist_implementation.fypp +tlei_tools_linkedlist_interface.fypp diff --git a/src/saber/mgbf/covariance/Convariance.h.org b/src/saber/mgbf/covariance/Convariance.h.org new file mode 100644 index 000000000..e94731ad4 --- /dev/null +++ b/src/saber/mgbf/covariance/Convariance.h.org @@ -0,0 +1,199 @@ +/* + * (C) Copyright 2022 United States Government as represented by the Administrator of the National + * Aeronautics and Space Administration + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ + +#pragma once + +#include +#include +#include + +#include "atlas/field.h" + +#include "oops/base/GeometryData.h" +#include "oops/base/Variables.h" + + +#include "atlas/grid.h" +#include "atlas/library.h" +#include "atlas/runtime/Log.h" + +#include "oops/base/Geometry.h" +#include "oops/base/State.h" +#include "oops/base/Variables.h" +#include "oops/util/abor1_cpp.h" + +#include "saber/mgbf/covariance/MGBF_Covariance.interface.h" +//clt #include "saber/mgbf/grid/MGBF_Grid.h" +#include "saber/oops/SaberCentralBlockBase.h" +#include "saber/oops/SaberBlockParametersBase.h" + + +using atlas::option::levels; +using atlas::option::name; + +namespace oops { + class Variables; +} + +namespace saber { +namespace mgbf { + +// ------------------------------------------------------------------------------------------------- +template +class CovarianceParameters: public SaberBlockParametersBase { + OOPS_CONCRETE_PARAMETERS(CovarianceParameters,SaberBlockParametersBase) +}; + +// ------------------------------------------------------------------------------------------------- + +template +class Covariance : public SaberCentralBlockBase { + typedef CovarianceParameters Parameters_; + typedef oops::Geometry Geometry_; +//clt typedef oops::Increment Increment_; + typedef oops::State State_; + + public: + static const std::string classname() {return "saber::mgbf::Covariance";} + + + Covariance(const Geometry_ &, const Parameters_ &, const State_ &, const State_ &); + virtual ~Covariance(); + + void randomize(atlas::FieldSet &) const override; + void multiply(atlas::FieldSet &) const override; + void inverseMultiply(atlas::FieldSet &) const override; + void multiplyAD(atlas::FieldSet &) const override; + void inverseMultiplyAD(atlas::FieldSet &) const override; + + private: + void print(std::ostream &) const override; + // Fortran LinkedList key + CovarianceKey keySelf_; + // Variables + std::vector variables_; + // Function space + atlas::FunctionSpace mgbfGridFuncSpace_; + // Grid +//clt Grid grid_; +}; + +// ------------------------------------------------------------------------------------------------- +template +Covariance::Covariance(const Geometry_ & geom, const Parameters_ & params, + const State_ & xbg, const State_ & xfg) + : SaberCentralBlockBase(params), variables_() +//clt : SaberCentralBlockBase(params), variables_(), grid_(geom.getComm(), params) +{ + oops::Log::trace() << classname() << "::Covariance starting" << std::endl; + util::Timer timer(classname(), "Covariance"); + + // Assert that there is no variable change in this block + ASSERT(params.inputVars.value() == params.outputVars.value()); + variables_ = params.inputVars.value().variables(); + + // Function space + + // Need to convert background and first guess to Atlas and MGBF grid. + + // Create covariance module + mgbf_covariance_create_f90(keySelf_, geom.getComm(), params.toConfiguration(), + xbg.fieldSet().get(), xfg.fieldSet().get()); + + oops::Log::trace() << classname() << "::Covariance done" << std::endl; +} + +// ------------------------------------------------------------------------------------------------- + +template +Covariance::~Covariance() { + oops::Log::trace() << classname() << "::~Covariance starting" << std::endl; + util::Timer timer(classname(), "~Covariance"); + mgbf_covariance_delete_f90(keySelf_); + oops::Log::trace() << classname() << "::~Covariance done" << std::endl; +} + +// ------------------------------------------------------------------------------------------------- + +template +void Covariance::randomize(atlas::FieldSet & fset) const { + oops::Log::trace() << classname() << "::randomize starting" << std::endl; + util::Timer timer(classname(), "randomize"); + + // Ignore incoming fields and create new ones based on the block function space + // ---------------------------------------------------------------------------- + atlas::FieldSet newFields = atlas::FieldSet(); + + // Loop over saber (model) fields and create corresponding fields on mgbf grid + for (auto sabField : fset) { + // Get the name + const auto fieldName = name(sabField.name()); + + // Ensure that the field name is in the input/output list + const std::string fieldNameStr = fieldName.getString("name"); + if (std::find(variables_.begin(), variables_.end(), fieldNameStr) == variables_.end()) { + ABORT("Field " + fieldNameStr + " not found in the " + classname() + " variables."); + } + + // Create the mgbf grid field and add to Fieldset +//clt newFields.add(mgbfGridFuncSpace_.createField(fieldName | levels(sabField.levels()))); + } + + // Replace whatever fields are coming in with the mgbf grid fields + fset = newFields; + + // Call implementation + mgbf_covariance_randomize_f90(keySelf_, fset.get()); + oops::Log::trace() << classname() << "::randomize done" << std::endl; +} + +// ------------------------------------------------------------------------------------------------- + +template +void Covariance::multiply(atlas::FieldSet & fset) const { + oops::Log::trace() << classname() << "::multiply starting" << std::endl; + util::Timer timer(classname(), "multiply"); + mgbf_covariance_multiply_f90(keySelf_, fset.get()); + oops::Log::trace() << classname() << "::multiply done" << std::endl; +} + +// ------------------------------------------------------------------------------------------------- + +template +void Covariance::inverseMultiply(atlas::FieldSet & fset) const { + ABORT(classname() + "inverseMultiply: not implemented"); +} + +// ------------------------------------------------------------------------------------------------- + +template +void Covariance::multiplyAD(atlas::FieldSet & fset) const { + oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; + util::Timer timer(classname(), "multiplyAD"); + mgbf_covariance_multiply_ad_f90(keySelf_, fset.get()); + oops::Log::trace() << classname() << "::multiplyAD done" << std::endl; +} + +// ------------------------------------------------------------------------------------------------- + +template +void Covariance::inverseMultiplyAD(atlas::FieldSet & fset) const { + ABORT(classname() + "inverseMultiplyAD: not implemented"); +} + +// ------------------------------------------------------------------------------------------------- + +template +void Covariance::print(std::ostream & os) const { + os << classname(); +} + +// ------------------------------------------------------------------------------------------------- + +} // namespace mgbf +} // namespace saber diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.cc b/src/saber/mgbf/covariance/MGBF_Covariance.cc new file mode 100644 index 000000000..6f82f812d --- /dev/null +++ b/src/saber/mgbf/covariance/MGBF_Covariance.cc @@ -0,0 +1,36 @@ +/* + * (C) Copyright 2022 United States Government as represented by the Administrator of the National + * Aeronautics and Space Administration + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ + +#include "saber/mgbf/covariance/MGBF_Covariance.h" + +#include +#include +#include + +#include "atlas/field.h" +#include "atlas/functionspace.h" +#include "atlas/grid.h" +#include "atlas/library.h" +#include "atlas/runtime/Log.h" + +#include "oops/base/Variables.h" +#include "oops/util/abor1_cpp.h" +#include "oops/util/Logger.h" +#include "oops/util/Timer.h" + +#include "saber/mgbf/covariance/MGBF_Covariance.interface.h" + +namespace saber { +namespace mgbf { + +// ------------------------------------------------------------------------------------------------- + +static SaberCentralBlockMaker makerCovariance_("MGBF_covariance"); + +} // namespace MGBF +} // namespace saber diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h new file mode 100644 index 000000000..8e1ffa50b --- /dev/null +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -0,0 +1,228 @@ +/* + * (C) Copyright 2022 United States Government as represented by the Administrator of the National + * Aeronautics and Space Administration + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ + +#pragma once + +#include +#include +#include + +#include "atlas/field.h" +#include "oops/base/FieldSet3D.h" +#include "oops/base/GeometryData.h" +#include "oops/base/Variables.h" + + + +#include "saber/mgbf/covariance/MGBF_Covariance.interface.h" +//clt #include "saber/mgbf/grid/MGBF_Grid.h" +#include "saber/blocks/SaberCentralBlockBase.h" +#include "saber/blocks/SaberBlockParametersBase.h" +#include + + +using atlas::option::levels; +using atlas::option::name; + +namespace oops { + class Variables; +} + +namespace saber { +namespace mgbf { + +// ------------------------------------------------------------------------------------------------- +class CovarianceParameters: public SaberBlockParametersBase { + OOPS_CONCRETE_PARAMETERS(CovarianceParameters,SaberBlockParametersBase) + public: + // Mandatory active variables + oops::Variables mandatoryActiveVars() const override {return oops::Variables();} +}; + +// ------------------------------------------------------------------------------------------------- + +//clt template +class Covariance : public SaberCentralBlockBase { +//clt typedef oops::Increment Increment_; + + public: + static const std::string classname() {return "saber::mgbf::Covariance";} + typedef CovarianceParameters Parameters_; + + +//cltorg Covariance(const Geometry_ &, const Parameters_ &, const State_ &, const State_ &); +Covariance(const oops::GeometryData & geometryData, + const oops::Variables & centralVars, + const eckit::Configuration & covarConf, + const Parameters_ & params, + const oops::FieldSet3D & xb, + const oops::FieldSet3D & fg + ); + + virtual ~Covariance(); + + void randomize(oops::FieldSet3D &) const override; + void multiply(oops::FieldSet3D &) const override; + std::vector> getReadConfs() const override; + void setReadFields(const std::vector &) override; + + void read() override; + + void directCalibration(const oops::FieldSets &) override; + + void iterativeCalibrationInit() override; + void iterativeCalibrationUpdate(const oops::FieldSet3D &) override; + void iterativeCalibrationFinal() override; + + void dualResolutionSetup(const oops::GeometryData &) override; + + void write() const override; + std::vector> fieldsToWrite() const + override; + + size_t ctlVecSize() const override {return static_cast(99999) ;} + void multiplySqrt(const atlas::Field &, oops::FieldSet3D &, const size_t &) const override; + void multiplySqrtAD(const oops::FieldSet3D &, atlas::Field &, const size_t &) const override; + + + private: + void print(std::ostream &) const override; + // Fortran LinkedList key + CovarianceKey keySelf_; + // Variables + std::vector variables_; + // Function space + atlas::FunctionSpace mgbfGridFuncSpace_; + // Grid +//clt Grid grid_; +}; + +// ------------------------------------------------------------------------------------------------- + + +Covariance::Covariance(const oops::GeometryData & geometryData, + const oops::Variables & centralVars, + const eckit::Configuration & covarConf, + const Parameters_ & params, + const oops::FieldSet3D & xb, + const oops::FieldSet3D & fg) + : SaberCentralBlockBase(params, xb.validTime()) +{ + oops::Log::trace() << classname() << "MGBF::Covariance starting" << std::endl; +//clt util::Timer timer(classname(), "Covariance"); + std::cout<<"thinkdebconfig0 ifhas -1 "<(fieldName | levels(sabField.levels()))); + } + + // Replace whatever fields are coming in with the mgbf grid fields + fset = newFields; + + // Call implementation +//clt MGBF_covariance_randomize_f90(keySelf_, fset.get()); + mgbf_covariance_randomize_f90(keySelf_, fset.get()); + oops::Log::trace() << classname() << "::randomize done" << std::endl; +} + +// ------------------------------------------------------------------------------------------------- + +void Covariance::multiply(atlas::FieldSet & fset) const { + oops::Log::trace() << classname() << "::multiply starting" << std::endl; + util::Timer timer(classname(), "multiply"); + mgbf_covariance_multiply_f90(keySelf_, fset.get()); + oops::Log::trace() << classname() << "::multiply done" << std::endl; +} + +// ------------------------------------------------------------------------------------------------- + + +// ------------------------------------------------------------------------------------------------- + +// ----------------------------------------------------------------------------- +// +// +// ------------------------------------------------------------------------------------------------- + +void Covariance::iterativeCalibration(const atlas::FieldSet & fset, const size_t & ie) { + oops::Log::trace() << classname() << "::iterativeCalibration starting" << std::endl; +//clt bump_->iterativeUpdate(fset, ie); + oops::Log::trace() << classname() << "::iterativeCalibration done" << std::endl; +} +void Covariance::getOutputFields(const eckit::LocalConfiguration & config , atlas::FieldSet & fset) const { + oops::Log::trace() << classname() << "dummy getOutFields" << std::endl; + }; + +// ------------------------------------------------------------------------------------------------- +void Covariance::finalSetup() { + oops::Log::trace() << classname() << "::calibration starting" << std::endl; +//clttothink dump + oops::Log::trace() << classname() << "::calibration done" << std::endl; +} + +void Covariance::print(std::ostream & os) const { + os << classname(); +} + + + +} // namespace mgbf +} // namespace saber diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 new file mode 100644 index 000000000..71f262c39 --- /dev/null +++ b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 @@ -0,0 +1,201 @@ +! (C) Copyright 2022 United States Government as represented by the Administrator of the National +! Aeronautics and Space Administration +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + +module mgbf_covariance_interface_mod + +! iso +use iso_c_binding + +! atlas +use atlas_module, only: atlas_functionspace, atlas_fieldset + +! fckit +use fckit_mpi_module, only: fckit_mpi_comm +use fckit_configuration_module, only: fckit_configuration + +! saber +use mgbf_covariance_mod, only: mgbf_covariance + + +implicit none +private +public mgbf_covariance_registry + + +! -------------------------------------------------------------------------------------------------- +#define LIST_KEY_TYPE c_int +#define LISTED_TYPE mgbf_covariance + +!> Linked list interface - defines registry_t type +!clt #include "saber/external/tools_linkedlist_interface.fypp" +#include "tlei_tools_linkedlist_interface.fypp" + +!> Global registry + +type(registry_type) :: mgbf_covariance_registry + +! -------------------------------------------------------------------------------------------------- + +contains + +! -------------------------------------------------------------------------------------------------- + +!> Linked list implementation +!clt #include "saber/external/tools_linkedlist_implementation.fypp" +#include "tlei_tools_linkedlist_implementation.fypp" + +! -------------------------------------------------------------------------------------------------- + +subroutine mgbf_covariance_create_cpp(c_self, c_comm, c_conf, c_bg, c_fg) & + bind(c, name='mgbf_covariance_create_f90') + +! Arguments +integer(c_int), intent(inout) :: c_self +type(c_ptr), value, intent(in) :: c_conf +type(c_ptr), value, intent(in) :: c_comm +type(c_ptr), value, intent(in) :: c_bg +type(c_ptr), value, intent(in) :: c_fg + +! Locals +type(mgbf_covariance), pointer :: f_self +type(fckit_mpi_comm) :: f_comm +type(fckit_configuration) :: f_conf +type(atlas_fieldset) :: f_bg +type(atlas_fieldset) :: f_fg + +! LinkedList +! ---------- +f_comm=fckit_mpi_comm(c_comm) +call mgbf_covariance_registry%init(f_comm) +call mgbf_covariance_registry%add(c_self) +call mgbf_covariance_registry%get(c_self, f_self) + +! Fortran APIs +! ------------ +f_conf = fckit_configuration(c_conf) +f_comm = fckit_mpi_comm(c_comm) +f_bg = atlas_fieldset(c_bg) +f_fg = atlas_fieldset(c_fg) + +! Call implementation +! ------------------- +call f_self%create(f_comm, f_conf, f_bg, f_fg) + +end subroutine mgbf_covariance_create_cpp + +! -------------------------------------------------------------------------------------------------- + +subroutine mgbf_covariance_delete_cpp(c_self) & + bind(c, name='mgbf_covariance_delete_f90') + +! Arguments +integer(c_int), intent(inout) :: c_self + +! Locals +type(mgbf_covariance), pointer :: f_self + +! LinkedList +! ---------- +call mgbf_covariance_registry%get(c_self, f_self) + +! Call implementation +! ------------------- +call f_self%delete() + +! LinkedList +! ---------- +call mgbf_covariance_registry%remove(c_self) + +end subroutine mgbf_covariance_delete_cpp + +! -------------------------------------------------------------------------------------------------- + +subroutine mgbf_covariance_randomize_cpp(c_self, c_inc) & + bind(c,name='mgbf_covariance_randomize_f90') + +implicit none + +!Arguments +integer(c_int), intent(in) :: c_self +type(c_ptr), value, intent(in) :: c_inc + +type(mgbf_covariance), pointer :: f_self +type(atlas_fieldset) :: f_inc + +! LinkedList +! ---------- +call mgbf_covariance_registry%get(c_self, f_self) + +! Fortran APIs +! ------------ +f_inc = atlas_fieldset(c_inc) + +! Call implementation +! ------------------- +call f_self%randomize(f_inc) + +end subroutine mgbf_covariance_randomize_cpp + +! -------------------------------------------------------------------------------------------------- + +subroutine mgbf_covariance_multiply_cpp(c_self, c_afieldset) & + bind(c,name='mgbf_covariance_multiply_f90') + +implicit none + +!Arguments +integer(c_int), intent(in) :: c_self +type(c_ptr), value, intent(in) :: c_afieldset + +type(mgbf_covariance), pointer :: f_self +type(atlas_fieldset) :: f_fieldset +!cltthink type(fieldset_type) :: f_fieldset + +! LinkedList +! ---------- +call mgbf_covariance_registry%get(c_self, f_self) + +! Fortran APIs +! ------------ +f_fieldset = atlas_fieldset(c_afieldset) + +! Call implementation +! ------------------- +call f_self%multiply(f_fieldset) + +end subroutine mgbf_covariance_multiply_cpp + +! -------------------------------------------------------------------------------------------------- + +subroutine mgbf_covariance_multiply_ad_cpp(c_self, c_afieldset) & + bind(c,name='mgbf_covariance_multiply_ad_f90') + +implicit none + +!Arguments +integer(c_int), intent(in) :: c_self +type(c_ptr), value, intent(in) :: c_afieldset + +type(mgbf_covariance), pointer :: f_self +type(atlas_fieldset) :: f_fieldset + +! LinkedList +! ---------- +call mgbf_covariance_registry%get(c_self, f_self) + +! Fortran APIs +! ------------ +f_fieldset = atlas_fieldset(c_afieldset) + +! Call implementation +! ------------------- +call f_self%multiply_ad(f_fieldset) + +end subroutine mgbf_covariance_multiply_ad_cpp + +! -------------------------------------------------------------------------------------------------- + +end module mgbf_covariance_interface_mod diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.h b/src/saber/mgbf/covariance/MGBF_Covariance.interface.h new file mode 100644 index 000000000..a944393d7 --- /dev/null +++ b/src/saber/mgbf/covariance/MGBF_Covariance.interface.h @@ -0,0 +1,38 @@ +/* + * (C) Copyright 2022 United States Government as represented by the Administrator of the National + * Aeronautics and Space Administration + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ + +#pragma once + +#include "atlas/field/FieldSet.h" + +#include "eckit/config/Configuration.h" +#include "eckit/mpi/Comm.h" + +// Forward declarations +namespace eckit { + class LocalConfiguration; +} + +namespace saber { + namespace mgbf { + typedef int CovarianceKey; + extern "C" { + void mgbf_covariance_create_f90(CovarianceKey &, const eckit::mpi::Comm &, + const eckit::Configuration &, + const atlas::field::FieldSetImpl *, + const atlas::field::FieldSetImpl *); + + void mgbf_covariance_delete_f90(CovarianceKey &); + void mgbf_covariance_randomize_f90(const CovarianceKey &, + const atlas::field::FieldSetImpl *); + void mgbf_covariance_multiply_f90(const CovarianceKey &, const atlas::field::FieldSetImpl *); + void mgbf_covariance_multiply_ad_f90(const CovarianceKey &, + const atlas::FieldSet *); + } + } // namespace gsi +} // namespace saber diff --git a/src/saber/mgbf/covariance/dd b/src/saber/mgbf/covariance/dd new file mode 100644 index 000000000..42a9e11fa --- /dev/null +++ b/src/saber/mgbf/covariance/dd @@ -0,0 +1,7 @@ +Covariance(const oops::GeometryData & geometryData, + const oops::Variables & centralVars, + const eckit::Configuration & covarConf, + const Parameters_ & params, + const oops::FieldSet3D & xb, + const oops::FieldSet3D & fg, + ); diff --git a/src/saber/mgbf/covariance/dd.h b/src/saber/mgbf/covariance/dd.h new file mode 100644 index 000000000..d97c0fb7f --- /dev/null +++ b/src/saber/mgbf/covariance/dd.h @@ -0,0 +1,245 @@ +/* + * (C) Copyright 2022 United States Government as represented by the Administrator of the National + * Aeronautics and Space Administration + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ + +#pragma once + +#include +#include +#include + +#include "atlas/field.h" + +#include "oops/base/GeometryData.h" +#include "oops/base/Variables.h" + + +#include "atlas/grid.h" +#include "atlas/library.h" +#include "atlas/runtime/Log.h" + +#include "oops/base/Geometry.h" +#include "oops/base/State.h" +#include "oops/base/Variables.h" +#include "oops/util/abor1_cpp.h" + +#include "saber/mgbf/covariance/MGBF_Covariance.interface.h" +//clt #include "saber/mgbf/grid/MGBF_Grid.h" +#include "saber/blocks/SaberCentralBlockBase.h" +#include "saber/blocks/SaberBlockParametersBase.h" +#include + + +using atlas::option::levels; +using atlas::option::name; + +namespace oops { + class Variables; +} + +namespace saber { +namespace mgbf { + +// ------------------------------------------------------------------------------------------------- +class CovarianceParameters: public SaberBlockParametersBase { + OOPS_CONCRETE_PARAMETERS(CovarianceParameters,SaberBlockParametersBase) + public: + // Mandatory active variables + oops::Variables mandatoryActiveVars() const override {return oops::Variables();} +}; + +// ------------------------------------------------------------------------------------------------- + +//clt template +class Covariance : public SaberCentralBlockBase { +//clt typedef oops::Increment Increment_; + + public: + static const std::string classname() {return "saber::mgbf::Covariance";} + typedef CovarianceParameters Parameters_; + + +//cltorg Covariance(const Geometry_ &, const Parameters_ &, const State_ &, const State_ &); +Covariance(const oops::GeometryData &, + const std::vector &, + const oops::Variables &, + const Parameters_ &, + const atlas::FieldSet &, + const atlas::FieldSet &, + const std::vector &, + const size_t &); + + virtual ~Covariance(); + + void randomize(oops::FieldSet3D &) const override; + void multiply(oops::FieldSet3D &) const override; + std::vector> getReadConfs() const override; + void setReadFields(const std::vector &) override; + + void read() override; + + void directCalibration(const oops::FieldSets &) override; + + void iterativeCalibrationInit() override; + void iterativeCalibrationUpdate(const oops::FieldSet3D &) override; + void iterativeCalibrationFinal() override; + + void dualResolutionSetup(const oops::GeometryData &) override; + + void write() const override; + std::vector> fieldsToWrite() const + override; + +//clttodo size_t ctlVecSize() const override {return bump_->getCvSize();} + void multiplySqrt(const atlas::Field &, oops::FieldSet3D &, const size_t &) const override; + void multiplySqrtAD(const oops::FieldSet3D &, atlas::Field &, const size_t &) const override; + + + private: + void print(std::ostream &) const override; + // Fortran LinkedList key + CovarianceKey keySelf_; + // Variables + std::vector variables_; + // Function space + atlas::FunctionSpace mgbfGridFuncSpace_; + // Grid +//clt Grid grid_; +}; + +// ------------------------------------------------------------------------------------------------- + + +Covariance::Covariance(const oops::GeometryData & geometryData, + const std::vector & activeVariableSizes, + const oops::Variables & centralVars, + const Parameters_ & params, + const atlas::FieldSet & xbg, + const atlas::FieldSet & xfg, + const std::vector & fsetVec, + const size_t & timeRank) + : variables_() + + +//clt Covariance::Covariance(const Geometry_ & geom, const Parameters_ & params, + //clt const State_ & xbg, const State_ & xfg) +//clt : SaberCentralBlockBase(params), variables_() +//clt : SaberCentralBlockBase(params), variables_(), grid_(geom.getComm(), params) +{ + oops::Log::trace() << classname() << "MGBF::Covariance starting" << std::endl; + util::Timer timer(classname(), "Covariance"); + std::cout<<"thinkdebconfig0 ifhas -1 "<(fieldName | levels(sabField.levels()))); + } + + // Replace whatever fields are coming in with the mgbf grid fields + fset = newFields; + + // Call implementation +//clt MGBF_covariance_randomize_f90(keySelf_, fset.get()); + mgbf_covariance_randomize_f90(keySelf_, fset.get()); + oops::Log::trace() << classname() << "::randomize done" << std::endl; +} + +// ------------------------------------------------------------------------------------------------- + +void Covariance::multiply(atlas::FieldSet & fset) const { + oops::Log::trace() << classname() << "::multiply starting" << std::endl; + util::Timer timer(classname(), "multiply"); + mgbf_covariance_multiply_f90(keySelf_, fset.get()); + oops::Log::trace() << classname() << "::multiply done" << std::endl; +} + +// ------------------------------------------------------------------------------------------------- + + +// ------------------------------------------------------------------------------------------------- + +// ----------------------------------------------------------------------------- +// +// +// ------------------------------------------------------------------------------------------------- + +void Covariance::iterativeCalibration(const atlas::FieldSet & fset, const size_t & ie) { + oops::Log::trace() << classname() << "::iterativeCalibration starting" << std::endl; +//clt bump_->iterativeUpdate(fset, ie); + oops::Log::trace() << classname() << "::iterativeCalibration done" << std::endl; +} +void Covariance::getOutputFields(const eckit::LocalConfiguration & config , atlas::FieldSet & fset) const { + oops::Log::trace() << classname() << "dummy getOutFields" << std::endl; + }; + +// ------------------------------------------------------------------------------------------------- +void Covariance::finalSetup() { + oops::Log::trace() << classname() << "::calibration starting" << std::endl; +//clttothink dump + oops::Log::trace() << classname() << "::calibration done" << std::endl; +} + +void Covariance::print(std::ostream & os) const { + os << classname(); +} + + + +} // namespace mgbf +} // namespace saber diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 new file mode 100644 index 000000000..a2ee9e34b --- /dev/null +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -0,0 +1,222 @@ +! (C) Copyright 2022 United States Government as represented by the Administrator of the National +! Aeronautics and Space Administration +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + +module mgbf_covariance_mod + +! atlas +use atlas_module, only: atlas_fieldset, atlas_field +use atlas_module, only: atlas_functionspace + +! fckit +use fckit_mpi_module, only: fckit_mpi_comm +use fckit_configuration_module, only: fckit_configuration + +! oops +use kinds, only: r_kind +use random_mod + +! saber +!clt use mgbf_grid_mod, only: mgbf_grid +use type_mgbf_mod, only: mgbf_type + +implicit none +private +public mgbf_covariance + + +! Fortran class header +type :: mgbf_covariance + type(mgbf_type) :: mgbf_driver + logical :: noMGBF + logical :: bypassMGBFbe + logical :: cv ! cv=.true.; sv=.false. + integer :: mp_comm_world + integer :: rank +!clt integer :: lat2,lon2 ! these belog to mgbf_grid + contains + procedure, public :: create + procedure, public :: delete + procedure, public :: randomize + procedure, public :: multiply + procedure, public :: multiply_ad +end type mgbf_covariance + +character(len=*), parameter :: myname='mgbf_covariance_mod' + +! -------------------------------------------------------------------------------------------------- + +contains + +! -------------------------------------------------------------------------------------------------- + +subroutine create(self, comm, config, background, firstguess) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(fckit_mpi_comm), intent(in) :: comm +type(fckit_configuration), intent(in) :: config +type(atlas_fieldset), intent(in) :: background +type(atlas_fieldset), intent(in) :: firstguess + +! Locals +character(len=*), parameter :: myname_=myname//'*create' +character(len=:), allocatable :: nml,bef +logical :: central +integer :: layout(2) + +type(atlas_field) :: afield +real(kind=r_kind), pointer :: t(:,:) + +! Hold communicator +! ----------------- +!self%mp_comm_world=comm%communicator() + +! Create the grid +! --------------- +!clt call self%grid%create(config, comm) +self%rank = comm%rank() + +call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) +#if 0 +if (.not. self%noMGBF) then + call config%get_or_die("saber central block", central) + if (.not. central) then + call abor1_ftn(myname_//": not ready to handle sqrt(B) case") + endif + call config%get_or_die("debugging deep bypass mgbf B error", self%bypassMGBFbe) + +! Get required name of resources for MGBF B error +! ---------------------------------------------- + call config%get_or_die("mgbf berror namelist file", nml) + call config%get_or_die("mgbf error covariance file", bef) + +! Initialize MGBF-Berror components +! -------------------------------- + layout=self%grid%layout +! layout=-1 + call mgbfbclim_init(self%cv) +endif +#endif +call self%mgbf_driver%mgbf_init() +! Get background (temporary test of the functionality) +!cltafield = background%field('air_temperature') +!clt call afield%data(t) + +end subroutine create + +! -------------------------------------------------------------------------------------------------- + +subroutine delete(self) + +! Arguments +class(mgbf_covariance) :: self + +! Locals + +#if 0 +if (.not. self%noMGBF) then + call mgbfbclim_final(.false.) +endif +#endif + +! Delete the grid +! --------------- +!clt call self%grid%delete() + +end subroutine delete + +! -------------------------------------------------------------------------------------------------- + +subroutine randomize(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: psi(:,:), chi(:,:), t(:,:), q(:,:), qi(:,:), ql(:,:), o3(:,:) +real(kind=r_kind), pointer :: ps(:) + +integer, parameter :: rseed = 3 + +! Get Atlas field +afield = fields%field('stream_function') +call afield%data(psi) + +afield = fields%field('velocity_potential') +call afield%data(chi) + +afield = fields%field('air_temperature') +call afield%data(t) + +afield = fields%field('surface_pressure') +call afield%data(ps) + +afield = fields%field('specific_humidity') +call afield%data(q) + +afield = fields%field('cloud_liquid_ice') +call afield%data(qi) + +afield = fields%field('cloud_liquid_water') +call afield%data(ql) + +afield = fields%field('ozone_mass_mixing_ratio') +call afield%data(o3) + + +! Set fields to random numbers +call normal_distribution(psi, 0.0_r_kind, 1.0_r_kind, rseed) + + +end subroutine randomize + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply(self, fields) +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields +type(atlas_functionspace) :: afunctionspace + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: t(:,:) + +!clt now noly consider t +! afield = fields%field('air_temperature') +! call afield%data(t) + call self%mgbf_driver%mgbf_apply(fields) +! Halo exchange +!afunctionspace = afield%functionspace() +!call afunctionspace%halo_exchange(afield) + + +end subroutine multiply + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply_ad(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! This routine only needed when B = G^T G (sqrt-factored) + +! To do list for this method +! 1. Convert fields (Atlas fieldsets) to MGBF bundle +! 2. Call MGBF covariance operator adjoint (sqrt version) +! afield = fields%field('stream_function') +! call afield%data(var3d) +! var3d=0.0_r_kind + +end subroutine multiply_ad + +! -------------------------------------------------------------------------------------------------- + +end module mgbf_covariance_mod diff --git a/src/saber/mgbf/covariance/tlei_tools_linkedlist_implementation.fypp b/src/saber/mgbf/covariance/tlei_tools_linkedlist_implementation.fypp new file mode 100644 index 000000000..64e3dc6a3 --- /dev/null +++ b/src/saber/mgbf/covariance/tlei_tools_linkedlist_implementation.fypp @@ -0,0 +1,263 @@ +!---------------------------------------------------------------------- +! Module: tools_linkedlist_implementation +!> Linked list implementation +! Source: ECMWF +! Original licensing: Apache Licence Version 2.0 +! Modified by Benjamin Menetrier for SABER +! Licensing: this code is distributed under the CeCILL-C license +! Copyright © 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT +!---------------------------------------------------------------------- + +!---------------------------------------------------------------------- +! Subroutine: tools_linkedlist_implementation_init +!> Initialize the linked list +!---------------------------------------------------------------------- +subroutine tools_linkedlist_implementation_init(self,f_comm) + +implicit none + +! Passed variable +class(registry_type),intent(inout) :: self !< Registry +type(fckit_mpi_comm),intent(in),target :: f_comm !< FCKIT MPI communicator wrapper + +! Get own FCKIT MPI communicator wrapper +self%f_comm = f_comm + +! Set count to zero and allocate the head of the list +if ((.not.self%l_init).or.(.not.associated(self%head))) then + self%count = 0 + allocate(self%head) + nullify(self%head%next) + self%l_init = .true. +end if + +end subroutine tools_linkedlist_implementation_init + +!---------------------------------------------------------------------- +! Subroutine: tools_linkedlist_implementation_add +!> Add element to the linked list +!---------------------------------------------------------------------- +subroutine tools_linkedlist_implementation_add(self,key,use_key) + +implicit none + +! Passed variables +class(registry_type),intent(inout) :: self !< Registry +integer(LIST_KEY_TYPE),intent(inout) :: key !< Key +logical,intent(in),optional :: use_key !< Use input key + +! Local variable +logical :: luse_key +type(node_type),pointer :: next + +! Local flag +luse_key = .false. +if (present(use_key)) luse_key = use_key + +! Increase global counter +self%count = self%count+1 + +! Assign key +if (.not.luse_key) key = self%count + +! Allocate next element and assign key +allocate(next) +next%key = key + +! Move the head to the front of the list +next%next => self%head%next +self%head%next => next + +end subroutine tools_linkedlist_implementation_add + +!---------------------------------------------------------------------- +! Function: tools_linkedlist_implementation_has +!> Check if an element exists in the list +!---------------------------------------------------------------------- +function tools_linkedlist_implementation_has(self,key) result(exists) + +implicit none + +! Passed variables +class(registry_type),intent(in) :: self !< Registry +integer(LIST_KEY_TYPE),intent(in) :: key !< Key + +! Returned variable +logical :: exists + +! Local variable +integer :: i +type(node_type),pointer :: next + +! Initialization +exists = .false. +i = 1 + +! Note that the list starts from self%head%next +next => self%head + +! Sweep the linked list to find matching key +do while(associated(next).and.(i<=self%count)) + next => next%next + if (key==next%key) then + exists = .true. + exit + end if + i = i+1 +end do + +end function tools_linkedlist_implementation_has + +!---------------------------------------------------------------------- +! Function: tools_linkedlist_implementation_get_key +!> Get key from index +!---------------------------------------------------------------------- +function tools_linkedlist_implementation_get_key(self,index) result(key) + +use iso_fortran_env, only: output_unit + +implicit none + +! Passed variables +class(registry_type),intent(in) :: self !< Registry +integer,intent(in) :: index !< Index + +! Returned variable +integer(LIST_KEY_TYPE) :: key + +! Local variable +integer :: i +type(node_type),pointer :: next + +! Check required index +if ((index<1).or.(index>self%count)) then + write(output_unit,'(a)') '!!! ABORT in tools_linkedlist_implementation_get_key: index out of bounds' + call flush(output_unit) + call self%f_comm%abort(1) +end if + +! Note that the list starts from self%head%next +next => self%head + +! Sweep the linked list to find matching key +i = 0 +do while(associated(next)) + next => next%next + i = i+1 + if (i==index) then + key = next%key + exit + end if +end do + +end function tools_linkedlist_implementation_get_key + +!---------------------------------------------------------------------- +! Subroutine: tools_linkedlist_implementation_get +!> Fetch element of the linked list by key +!---------------------------------------------------------------------- +subroutine tools_linkedlist_implementation_get(self,key,ptr) + +use iso_fortran_env, only: output_unit + +implicit none + +! Passed variables +class(registry_type),intent(in) :: self !< Registry +integer(LIST_KEY_TYPE),intent(in) :: key !< Key +type(LISTED_TYPE),intent(inout),pointer :: ptr !< Listed type pointer + +! Local variable +type(node_type),pointer :: next + +! Note that the list starts from self%head%next +next => self%head +ptr => NULL() + +! Sweep the linked list to find matching key +do while(associated(next)) + next => next%next + if (key==next%key) then + ptr => next%element + exit + end if +end do + +! Abort if pointer is not found +if (.not.associated(ptr)) then + write(output_unit,'(a)') '!!! ABORT in tools_linkedlist_implementation_get: pointer not found' + call flush(output_unit) + call self%f_comm%abort(1) +end if + +end subroutine tools_linkedlist_implementation_get + +!---------------------------------------------------------------------- +! Subroutine: tools_linkedlist_implementation_remove +!> Remove element of the linked list +!---------------------------------------------------------------------- +subroutine tools_linkedlist_implementation_remove(self,key) + +implicit none + +! Passed variables +class(registry_type),intent(inout) :: self !< Registry +integer(LIST_KEY_TYPE),intent(inout) :: key !< Key + +! Local variables +type(node_type),pointer :: prev +type(node_type),pointer :: next + +! Note that the list starts from self%head%next +next => self%head%next +prev => NULL() + +! Sweep the linked list to find matching key +do while(associated(next)) + if (key==next%key) exit + prev => next + next => next%next +end do + +! Reconnect the list +if (associated(next%next)) then + if (associated(prev)) then + prev%next => next%next + else + self%head%next=>next%next + end if +end if + +! Remove the node and set key to 0 +if (associated(next)) deallocate(next) +key = 0 + +! Decrease global counter +self%count = self%count-1 + +end subroutine tools_linkedlist_implementation_remove + +!---------------------------------------------------------------------- +! Subroutine: tools_linkedlist_implementation_finalize +!> Finalize the linked list, deallocate all nodes +!---------------------------------------------------------------------- +subroutine tools_linkedlist_implementation_finalize(self) + +implicit none + +! Passed variables +class(registry_type),intent(inout) :: self !< Registry + +! Local variable +type(node_type),pointer :: current +type(node_type),pointer :: next + +! Sweep the linked list and deallocate all nodes +next => self%head +do while(associated(next)) + current => next + next => next%next + deallocate(current) +end do + +end subroutine tools_linkedlist_implementation_finalize diff --git a/src/saber/mgbf/covariance/tlei_tools_linkedlist_interface.fypp b/src/saber/mgbf/covariance/tlei_tools_linkedlist_interface.fypp new file mode 100644 index 000000000..41cb2d7bc --- /dev/null +++ b/src/saber/mgbf/covariance/tlei_tools_linkedlist_interface.fypp @@ -0,0 +1,32 @@ +!---------------------------------------------------------------------- +! Module: tools_linkedlist_interface +!> Linked list interface +! Source: ECMWF +! Original licensing: Apache Licence Version 2.0 +! Modified by Benjamin Menetrier for SABER +! Licensing: this code is distributed under the CeCILL-C license +! Copyright © 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT +!---------------------------------------------------------------------- + +! Node type +type node_type + integer(LIST_KEY_TYPE) :: key !< Key + type(LISTED_TYPE) :: element !< Listed element + type(node_type),pointer :: next => NULL() !< Next node pointer +end type node_type + +! Registry type +type :: registry_type + logical :: l_init = .false. !< Initialization flag + integer(LIST_KEY_TYPE) :: count = 0 !< Counter + type(node_type),pointer :: head => NULL() !< Node pointer + type(fckit_mpi_comm) :: f_comm !< MPI communicator (fckit wrapper) +contains + procedure :: init => tools_linkedlist_implementation_init + procedure :: add => tools_linkedlist_implementation_add + procedure :: has => tools_linkedlist_implementation_has + procedure :: get_key => tools_linkedlist_implementation_get_key + procedure :: get => tools_linkedlist_implementation_get + procedure :: remove => tools_linkedlist_implementation_remove + procedure :: finalize => tools_linkedlist_implementation_finalize +end type registry_type diff --git a/src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 b/src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 new file mode 100755 index 000000000..b5772f461 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 @@ -0,0 +1,94 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + program RBETA_TEST +!*********************************************************************** +! ! +! Multigrid Beta filter for modeling background error covariance ! +! ! +! M. Rancic (2020) ! +!*********************************************************************** +use mpi +use kinds, only: r_kind,i_kind +use mg_entrymod, only: mg_initialize,mg_finalize +use mg_mppstuff, only: finishMPI,mype +use mg_filtering, only: mg_filtering_procedure +use mg_transfer, only: anal_to_filt_all,filt_to_anal_all +use mg_parameter, only: mgbf_proc +use mg_timers + +implicit none + +!----------------------------------------------------------------------- + + call btim( total_tim) + call btim( init_tim) +!*** +!*** Initialzie multigrid Beta filter +!*** + call mg_initialize + + call etim( init_tim) +!*** +!*** From the analysis to first generation of filter grid +!*** + call btim( an2filt_tim) + + call anal_to_filt_all + call etim( an2filt_tim) + + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +!*** +!*** Adjoint test if needed +!*** + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + +!*** +!*** Filtering +!*** +!====================================================================== + + call mg_filtering_procedure(mgbf_proc) + +!====================================================================== + +!*** +!*** From first generation of filter grid to analysis grid (x-directoin) +!*** + + call btim( filt2an_tim) + call filt_to_anal_all + + call etim( filt2an_tim) + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +!*** +!*** Adjoint test if needed +!*** + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + + +!==================== Forward (Smoothing step) ======================== +!*** +!*** DONE! Deallocate variables +!*** + call btim( output_tim) + call mg_finalize + + call etim( output_tim) + call etim( total_tim) + + +!*** +!*** Print wall clock and cpu timing +!*** + call print_mg_timers("timing_cpu.csv", print_cpu) + + + + call finishMPI + + +!----------------------------------------------------------------------- + endprogram RBETA_TEST diff --git a/src/saber/mgbf/mgbf_lib/bak_type_bump.F90 b/src/saber/mgbf/mgbf_lib/bak_type_bump.F90 new file mode 100644 index 000000000..f80d1adca --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/bak_type_bump.F90 @@ -0,0 +1,2920 @@ +# 1 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" +# 1 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/../instrumentation.fypp" 1 +# 1 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/../subr_list.fypp" 1 +!---------------------------------------------------------------------- +! Header: subr_list +!> Subroutines/functions list +! Author: Benjamin Menetrier +! Licensing: this code is distributed under the CeCILL-C license +! Copyright 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT +!---------------------------------------------------------------------- + +# 963 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/../subr_list.fypp" +# 2 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/../instrumentation.fypp" 2 +!---------------------------------------------------------------------- +! Header: instrumentation +!> Instrumentation functions +! Author: Benjamin Menetrier +! Licensing: this code is distributed under the CeCILL-C license +! Copyright 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT +!---------------------------------------------------------------------- + +# 112 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/../instrumentation.fypp" +# 2 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" 2 +!---------------------------------------------------------------------- +! Module: type_bump +!> BUMP derived type +! Author: Benjamin Menetrier +! Licensing: this code is distributed under the CeCILL-C license +! Copyright 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT +!---------------------------------------------------------------------- +module type_bump + +use atlas_module, only: atlas_field,atlas_fieldset,atlas_integer,atlas_real,atlas_functionspace +use fckit_configuration_module, only: fckit_configuration +use fckit_mpi_module, only: fckit_mpi_comm,fckit_mpi_sum,fckit_mpi_min,fckit_mpi_max +use tools_const, only: zero,half,one,thousand,req,reqkm,deg2rad,rad2deg +use tools_func, only: fletcher32,sphere_dist,zss_maxval,zss_minval,zss_sum +use tools_kinds,only: kind_real +use tools_netcdf, only: registry +use tools_repro,only: repro,rth +use type_bpar, only: bpar_type +use type_cmat, only: cmat_type +use type_cv, only: cv_type +use type_ens, only: ens_type +use type_fieldset, only: fieldset_type +use type_geom, only: geom_type +use type_hdiag, only: hdiag_type +use type_mom, only: mom_type +use type_mpl, only: mpl_type +use type_nam, only: nam_type +use type_nicas, only: nicas_type + +use type_rng, only: rng_type +use type_samp, only: samp_type +use type_var, only: var_type +use type_vbal, only: vbal_type +use type_wind, only: wind_type + +implicit none + +integer,parameter :: dmsvali = -999 !< Default missing value for integers +real(kind_real),parameter :: dmsvalr = -999.0_kind_real !< Default missing value for reals +logical :: copy_ensemble = .false. !< Deep copy of ensemble members +real(kind_real),parameter :: loc_scaling_factor = one !< Scaling factor to get optimal localization +!real(kind_real),parameter :: loc_scaling_factor = 1.4_kind_real !< scaling factor to get optimal localization (TODO: check this and reset it) +integer,parameter :: nfac_opt = 4 !< Number of length-scale factors for optimization +integer,parameter :: ntest = 50 !< Number of test vectors + +! BUMP derived type +type bump_type + ! Derived types + type(bpar_type) :: bpar !< Block parameters + type(cmat_type),allocatable :: cmat(:) !< C matrix + type(ens_type),allocatable :: ens(:) !< Ensembles + type(geom_type),allocatable :: geom(:) !< Geometry + type(hdiag_type) :: hdiag !< Hybrid diagnostics + type(mom_type),allocatable :: mom(:) !< Moments + type(mpl_type) :: mpl !< MPI data + type(nam_type) :: nam !< Namelist + type(nicas_type),allocatable :: nicas(:) !< NICAS data + type(rng_type) :: rng !< Random number generator + type(samp_type),allocatable :: samp(:) !< Sampling + type(var_type) :: var !< Variance + type(vbal_type) :: vbal !< Vertical balance + type(wind_type) :: wind !< Wind + + ! Dummy variable + logical :: dummy_logical !< Dummy variable +contains + procedure :: create => bump_create + procedure :: setup => bump_setup + procedure :: second_geometry => bump_second_geometry + procedure :: add_member => bump_add_member + procedure :: update_vbal_cov => bump_update_vbal_cov + procedure :: update_var => bump_update_var + procedure :: update_mom => bump_update_mom + procedure :: run_drivers => bump_run_drivers + procedure :: check_consistency => bump_check_consistency + procedure :: check_optimality => bump_check_optimality + procedure :: apply_vbal => bump_apply_vbal + procedure :: apply_vbal_inv => bump_apply_vbal_inv + procedure :: apply_vbal_ad => bump_apply_vbal_ad + procedure :: apply_vbal_inv_ad => bump_apply_vbal_inv_ad + procedure :: apply_stddev => bump_apply_stddev + procedure :: apply_stddev_inv => bump_apply_stddev_inv + procedure :: apply_nicas => bump_apply_nicas + procedure :: get_cv_size => bump_get_cv_size + procedure :: apply_nicas_sqrt => bump_apply_nicas_sqrt + procedure :: apply_nicas_sqrt_ad => bump_apply_nicas_sqrt_ad + procedure :: randomize => bump_randomize + procedure :: psichi_to_uv => bump_psichi_to_uv + procedure :: psichi_to_uv_ad => bump_psichi_to_uv_ad + procedure :: get_ncmp => bump_get_ncmp + procedure :: get_parameter => bump_get_parameter + procedure :: test_get_parameter => bump_test_get_parameter + procedure :: set_ncmp => bump_set_ncmp + procedure :: set_parameter => bump_set_parameter + procedure :: test_set_parameter => bump_test_set_parameter + procedure :: test_apply_interfaces => bump_test_apply_interfaces + procedure :: partial_dealloc => bump_partial_dealloc + procedure :: dealloc => bump_dealloc + final :: bump_dummy_final +end type bump_type + +private +public :: bump_type + +contains + +!---------------------------------------------------------------------- +! Subroutine: bump_create +!> Create +!---------------------------------------------------------------------- +subroutine bump_create(bump,comm,afunctionspace,fieldset,conf,grid,universe_rad) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fckit_mpi_comm),intent(in) :: comm !< FCKIT MPI communicator wrapper +type(atlas_functionspace),intent(in) :: afunctionspace !< Function space +type(fieldset_type),intent(in) :: fieldset !< SABER geometry fields +type(fckit_configuration),intent(in) :: conf !< FCKIT configuration +type(fckit_configuration),intent(in) :: grid !< FCKIT grid configuration +type(fieldset_type),intent(in),optional :: universe_rad !< Fieldset optionally containing universe radius + +! Local variables +integer :: lmsvali, llunit +real(kind_real) :: lmsvalr + +! Set name + + +! Get instance + + +! Probe in + + +! Initialize namelist +call bump%nam%init(comm%size()) + +! Read grid configuration +call bump%nam%from_conf(comm,grid) + +! Read configuration +call bump%nam%from_conf(comm,conf) + +! Set missing values +lmsvali = dmsvali +lmsvalr = dmsvalr +if (conf%has('msvali')) call conf%get_or_die('msvali',lmsvali) +if (conf%has('msvalr')) call conf%get_or_die('msvalr',lmsvalr) + +! Set log unit +llunit = lmsvali +if (conf%has('lunit')) call conf%get_or_die('lunit',llunit) + +! Setup BUMP +if (present(universe_rad)) then + call bump%setup(comm,afunctionspace,fieldset,lunit=llunit,msvali=lmsvali,msvalr=lmsvalr,universe_rad=universe_rad) +else + call bump%setup(comm,afunctionspace,fieldset,lunit=llunit,msvali=lmsvali,msvalr=lmsvalr) +end if + +! Probe out + + +end subroutine bump_create + +!---------------------------------------------------------------------- +! Subroutine: bump_setup +!> Setup +!---------------------------------------------------------------------- +subroutine bump_setup(bump,f_comm,afunctionspace,fieldset,lunit,msvali,msvalr,universe_rad) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fckit_mpi_comm),intent(in) :: f_comm !< FCKIT MPI communicator wrapper +type(atlas_functionspace),intent(in) :: afunctionspace !< Functionspace +type(fieldset_type),intent(in),optional :: fieldset !< SABER geometry fields +integer,intent(in),optional :: lunit !< Listing unit +integer,intent(in),optional :: msvali !< Missing value for integers +real(kind_real),intent(in),optional :: msvalr !< Missing value for reals +type(fieldset_type),intent(in),optional :: universe_rad !< Fieldset optionally containing universe radius + +! Local variables +integer :: iv,il0,color,sc +real(kind_real),pointer :: ptr_1(:),ptr_2(:,:) +character(len=1024) :: cname +type(atlas_field) :: afield + +! Set name + + +! Get instance + + +! Probe in + + +! Initialize MPL +call bump%mpl%init(f_comm) + +! Set missing values +bump%mpl%msv%vali = dmsvali +bump%mpl%msv%valr = dmsvalr +if (present(msvali)) bump%mpl%msv%vali = msvali +if (present(msvalr)) bump%mpl%msv%valr = msvalr + +! Initialize listing +bump%mpl%lunit = bump%mpl%msv%vali +if (present(lunit)) bump%mpl%lunit = lunit +if ((.not.bump%mpl%main).and.bump%mpl%msv%is(bump%mpl%lunit)) bump%mpl%lunit = 10+bump%mpl%myproc +bump%mpl%verbosity = bump%nam%verbosity +if (bump%nam%colorlog) then + bump%mpl%black = char(27)//'[0;0m' + bump%mpl%green = char(27)//'[0;32m' + bump%mpl%peach = char(27)//'[1;91m' + bump%mpl%aqua = char(27)//'[1;36m' + bump%mpl%purple = char(27)//'[1;35m' + bump%mpl%err_color = char(27)//'[0;37;41;1m' + bump%mpl%wng_color = char(27)//'[0;37;42;1m' +else + bump%mpl%black = ' ' + bump%mpl%green = ' ' + bump%mpl%peach = ' ' + bump%mpl%aqua = ' ' + bump%mpl%purple = ' ' + bump%mpl%err_color = ' ' + bump%mpl%wng_color = ' ' +end if + +! Header +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a)') '--- You are running the BUMP library ------------------------------' +call bump%mpl%flush + + +! Write parallel setup +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a,i3,a,i2,a)') '--- Parallelization with ',bump%mpl%nproc,' MPI tasks and ', & + & bump%mpl%nthread,' OpenMP threads' +call bump%mpl%flush + +if (present(universe_rad)) then + if (universe_rad%size()>0) then + ! Set universe radius + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Set universe radius' + call bump%mpl%flush + + ! Initialization + bump%nam%universe_rad = zero + + do iv=1,bump%nam%nv + ! Get field + afield = universe_rad%field(bump%nam%variables(iv)) + + ! Get data maximum + if (afield%rank()==1) then + call afield%data(ptr_1) + bump%nam%universe_rad = max(bump%nam%universe_rad,zss_maxval(ptr_1,mask=bump%mpl%msv%isnot(ptr_1))) + elseif (afield%rank()==2) then + call afield%data(ptr_2) + do il0=1,size(ptr_2,1) + if ((bump%nam%min_lev(iv)<=il0).and.(il0<=bump%nam%max_lev(iv))) & + & bump%nam%universe_rad = max(bump%nam%universe_rad,zss_maxval(ptr_2(il0,:),mask=bump%mpl%msv%isnot(ptr_2(il0,:)))) + end do + else + call bump%mpl%abort('bump_setup','cannot get universe radius for this field rank') + end if + end do + + ! Get global maximum + call bump%mpl%f_comm%allreduce(bump%nam%universe_rad,fckit_mpi_max()) + write(bump%mpl%info,'(a7,a,f10.2,a)') '','Universe radius: ',bump%nam%universe_rad/thousand,' km' + call bump%mpl%flush + end if +end if + +! Check namelist parameters +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a)') '--- Check namelist parameters' +call bump%mpl%flush +call bump%nam%check(bump%mpl) +call bump%nam%write(bump%mpl) + +! Set I/O parameters +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a)') '--- Set I/O parameters' +call bump%mpl%flush + +! Allocation +allocate(bump%mpl%pioproc(bump%mpl%nproc)) +allocate(bump%cmat(2)) +allocate(bump%ens(2)) +allocate(bump%geom(2)) +allocate(bump%mom(2)) +allocate(bump%nicas(2)) +allocate(bump%samp(2)) + +! Set I/O parameters +bump%mpl%datadir = bump%nam%datadir +bump%mpl%parallel_io = bump%nam%parallel_io +bump%mpl%nprocio = bump%nam%nprocio +bump%mpl%pioproc = .false. +if (bump%mpl%parallel_io) then + bump%mpl%pioproc(1:min(bump%mpl%nprocio,bump%mpl%nproc)) = .true. +else + bump%mpl%pioproc(bump%mpl%rootproc) = .true. +end if +if (bump%mpl%main) call system_clock(sc) +call bump%mpl%f_comm%broadcast(sc,bump%mpl%rootproc-1) +if (bump%mpl%pioproc(bump%mpl%myproc)) then + color = 1 + write(cname,'(a,i12.12)') trim(bump%mpl%f_comm%name())//'_'//trim(bump%nam%prefix)//'_io_',sc +else + color = 0 + write(cname,'(a,i12.12)') trim(bump%mpl%f_comm%name())//'_'//trim(bump%nam%prefix)//'_no_io_',sc +endif +bump%mpl%f_comm_io = bump%mpl%f_comm%split(color,cname) + +! Set reproducibility parameters +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a)') '--- Set reproducibility parameters' +call bump%mpl%flush +repro = bump%nam%repro +rth = bump%nam%rth + +! Initialize random number generator +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a)') '--- Initialize random number generator' +call bump%mpl%flush +call bump%rng%init(bump%mpl,bump%nam) + +! Initialize allocation flags +bump%geom(1)%allocated = .false. +bump%geom(2)%allocated = .false. +bump%cmat(1)%allocated = .false. +bump%cmat(2)%allocated = .false. +bump%nicas(1)%allocated = .false. +bump%nicas(2)%allocated = .false. + +! Initialize geometry +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a)') '--- Initialize geometry' +call bump%mpl%flush +if (present(fieldset)) then + call bump%geom(1)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace,fieldset) +else + call bump%geom(1)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace) +end if +if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + +! Initialize block parameters +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a)') '--- Initialize block parameters' +call bump%mpl%flush +call bump%bpar%alloc(bump%nam,bump%geom(1)) +call bump%bpar%init(bump%mpl,bump%nam,bump%geom(1)) + +if (bump%nam%ens1_ne>0) then + ! Initialize ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Initialize ensemble 1' + call bump%mpl%flush + call bump%ens(1)%set_att(bump%nam%ens1_ne,bump%nam%ens1_nsub) +end if + +if (bump%nam%ens2_ne>0) then + ! Initialize ensemble 2 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Initialize ensemble 2' + call bump%mpl%flush + call bump%ens(2)%set_att(bump%nam%ens2_ne,bump%nam%ens2_nsub) +end if + +! Probe out + + +end subroutine bump_setup + +!---------------------------------------------------------------------- +! Subroutine: bump_second_geometry +!> Initialize second geometry +!---------------------------------------------------------------------- +subroutine bump_second_geometry(bump,afunctionspace,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(atlas_functionspace),intent(in) :: afunctionspace !< ATLAS functionspace +type(fieldset_type),intent(in),optional :: fieldset !< Fieldset containing geometry elements + +! Set name + + +! Get instance + + +! Probe in + + +! Initialize second geometry +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a)') '--- Initialize second geometry' +call bump%mpl%flush +if (present(fieldset)) then + call bump%geom(2)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace,fieldset) +else + call bump%geom(2)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace) +end if +if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + +! Check consistency between geometries +if (bump%geom(1)%nl0/=bump%geom(2)%nl0) call bump%mpl%abort('${subr}','both geometries should have the same number of levels') + +! Probe out + + +end subroutine bump_second_geometry + +!---------------------------------------------------------------------- +! Subroutine: bump_add_member +!> Add member into bump%ens[1,2] +!---------------------------------------------------------------------- +subroutine bump_add_member(bump,fieldset,ie,iens) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(in) :: fieldset !< Fieldset +integer,intent(in) :: ie !< Member index +integer,intent(in) :: iens !< Ensemble number + +! Local variables +integer :: ne,nsub + +! Set name + + +! Get instance + + +! Probe in + + +! Check ensemble number +if (iens==1) then + ne = bump%nam%ens1_ne + nsub = bump%nam%ens1_nsub +elseif (iens==2) then + ne = bump%nam%ens2_ne + nsub = bump%nam%ens2_nsub +else + call bump%mpl%abort('bump_add_member','wrong ensemble number') +end if + +! Allocation +if (.not.bump%ens(iens)%loaded) call bump%ens(iens)%alloc(ne,nsub) +bump%ens(iens)%loaded = .true. + +if (copy_ensemble) then + ! Copy fields + call bump%ens(iens)%mem(ie)%init(bump%mpl,fieldset,bump%geom(iens)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d, & + & copy=.true.) +else + ! Pass fields + call bump%ens(iens)%mem(ie)%init(bump%mpl,fieldset,bump%geom(iens)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d, & + & pass=.true.) +end if + +! Print norm +!write(bump%mpl%info,'(a,i6,a)') 'Ensemble 1 member ',ie,': ' +!call bump%mpl%flush +!call bump%ens(iens)%mem(ie)%print(bump%mpl) + +! Probe out + + +end subroutine bump_add_member + +!---------------------------------------------------------------------- +! Subroutine: bump_update_vbal_cov +!> Update vertical covariances, one member at a time +!---------------------------------------------------------------------- +subroutine bump_update_vbal_cov(bump,fieldset,ie) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset +integer,intent(in) :: ie !< Member index + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) + +! Set name + + +! Get instance index + + +! Probe in + + +if (ie==1) then + ! Setup sampling + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Setup sampling' + call bump%mpl%flush + call bump%samp(1)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(1)) + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) +end if + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Update vertical covariances +call bump%vbal%cov_update(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),fld_c0a,ie) + +! Probe out + + +end subroutine bump_update_vbal_cov + +!---------------------------------------------------------------------- +! Subroutine: bump_update_var +!> Update variance, one member at a time +!---------------------------------------------------------------------- +subroutine bump_update_var(bump,fieldset,ie) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset +integer,intent(in) :: ie !< Member index + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) + +! Set name + + +! Get instance index + + +! Probe in + + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Update variance +call bump%var%update(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,fld_c0a,ie) +if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + +! Probe out + + +end subroutine bump_update_var + +!---------------------------------------------------------------------- +! Subroutine: bump_update_mom +!> Update moments, one member at a time +!---------------------------------------------------------------------- +subroutine bump_update_mom(bump,fieldset,ie,iens) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset +integer,intent(in) :: ie !< Member index +integer,intent(in) :: iens !< Ensemble number + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(iens)%nc0a,bump%geom(iens)%nl0,bump%nam%nv) +character(len=4) :: momname + +! Set name + + +! Get instance index + + +! Probe in + + +! Check ensemble number +if ((iens/=1).and.(iens/=2)) call bump%mpl%abort('bump_update_mom','wrong ensemble number') + +if (ie==1) then + ! Setup sampling + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a,i1)') '--- Setup sampling for ensemble ',iens + call bump%mpl%flush + if (iens==1) then + call bump%samp(iens)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(iens)) + elseif (iens==2) then + call bump%samp(iens)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(iens),other=bump%samp(1)) + end if + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) +end if + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(iens)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(iens)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Update moments +write(momname,'(a,i1)') 'mom',iens +call bump%mom(iens)%update(bump%mpl,bump%nam,bump%geom(iens),bump%bpar,bump%samp(iens),momname,fld_c0a,ie,iens) + +! Probe out + + +end subroutine bump_update_mom + +!---------------------------------------------------------------------- +! Subroutine: bump_run_drivers +!> Run drivers +!---------------------------------------------------------------------- +subroutine bump_run_drivers(bump) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP + +! Set name + + +! Get instance + + +! Probe in + + +if (bump%nam%check_consistency.or.bump%nam%check_optimality) then + ! Copy namelist support radii into C matrix, ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Copy namelist support radii into C matrix, ensemble 1' + call bump%mpl%flush + call bump%cmat(1)%from_nam(bump%mpl,bump%nam,bump%geom(1),bump%bpar) + + ! Setup C matrix sampling, ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Setup C matrix sampling, ensemble 1' + call bump%mpl%flush + call bump%cmat(1)%setup_sampling(bump%mpl,bump%nam,bump%geom(1),bump%bpar) + + ! Run NICAS driver, ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run NICAS driver, ensemble 1' + call bump%mpl%flush + call bump%nicas(1)%run_nicas(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,bump%cmat(1)) + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + + ! Randomize ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a,i6,a)') '--- Randomize ensemble 1 (',bump%nam%ens1_ne,' members)' + call bump%mpl%flush + call bump%nicas(1)%gen_ens_pert(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,bump%nam%ens1_ne,bump%ens(1)) + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + + ! Release memory + call bump%cmat(1)%dealloc +end if + +if (bump%nam%ens1_ne>0.and.bump%ens(1)%loaded) then + ! Compute mean for ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Compute mean for ensemble 1' + call bump%mpl%flush + call bump%ens(1)%compute_mean(bump%mpl,bump%nam,bump%geom(1)) +end if + +if (bump%nam%ens2_ne>0.and.bump%ens(2)%loaded) then + ! Compute mean for ensemble 2 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Compute mean for ensemble 2' + call bump%mpl%flush + call bump%ens(2)%compute_mean(bump%mpl,bump%nam,bump%geom(2)) +end if + +if (bump%nam%new_normality) then + ! Run normality tests + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run normality tests' + call bump%mpl%flush + call bump%ens(1)%normality(bump%mpl,bump%nam,bump%geom(1)) +end if + +if (bump%nam%new_vbal_cov.or.bump%nam%load_vbal_cov.or.(bump%nam%new_vbal.and.(.not.bump%nam%update_vbal_cov)) & + & .or.bump%nam%load_vbal.or.bump%nam%new_mom.or.bump%nam%load_mom) then + ! Setup sampling for ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Setup sampling for ensemble 1' + call bump%mpl%flush + call bump%samp(1)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%ens(1)) + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + + if (bump%geom(2)%allocated) then + ! Setup sampling for ensemble 2 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Setup sampling for ensemble 2' + call bump%mpl%flush + call bump%samp(2)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(2),bump%ens(2),bump%samp(1)) + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + end if +end if + +if (bump%nam%new_vbal_cov) then + ! Run vertical covariance driver + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run vertical covariances driver' + call bump%mpl%flush + call bump%vbal%cov_run(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%ens(1)) +elseif (bump%nam%load_vbal_cov) then + ! Read vertical balance + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Read vertical covariances' + call bump%mpl%flush + if (bump%nam%load_samp_local) then + call bump%vbal%cov_read_local(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%nam%ens1_nsub) + elseif (bump%nam%load_samp_global) then + call bump%vbal%cov_read_global(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%nam%ens1_nsub) + end if +end if + +if (bump%nam%new_vbal) then + ! Run vertical balance driver + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run vertical balance driver' + call bump%mpl%flush + call bump%vbal%run_vbal(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%ens(1)) +elseif (bump%nam%load_vbal) then + ! Read vertical balance + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Read vertical balance' + call bump%mpl%flush + if (bump%nam%load_samp_local) then + call bump%vbal%read_local(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1)) + elseif (bump%nam%load_samp_global) then + call bump%vbal%read_global(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1)) + end if +end if + +if (bump%nam%new_vbal.or.bump%nam%load_vbal) then + ! Run vertical balance tests driver + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run vertical balance tests driver' + call bump%mpl%flush + call bump%vbal%run_vbal_tests(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar) + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) +end if + +if (bump%nam%new_var.or.bump%nam%load_var.or.(bump%var%bump_m2_counter>0)) then + ! Run variance driver + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run variance driver' + call bump%mpl%flush + call bump%var%run_var(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,bump%ens(1)) + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) +end if + +if (bump%nam%new_mom) then + ! Compute sample moments + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Compute sample moments' + call bump%mpl%flush + + ! Compute ensemble 1 sample moments + write(bump%mpl%info,'(a7,a)') '','Ensemble 1:' + call bump%mpl%flush + call bump%mom(1)%compute(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%ens(1),'mom1') + + select case(trim(bump%nam%method)) + case ('hyb-rnd','hyb-ens') + ! Compute ensemble 2 sample moments + write(bump%mpl%info,'(a7,a)') '','Ensemble 2:' + call bump%mpl%flush + call bump%mom(2)%compute(bump%mpl,bump%nam,bump%geom(2),bump%bpar,bump%samp(2),bump%ens(2),'mom2') + end select +elseif (bump%nam%load_mom) then + ! Load sample moments + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Load sample moments' + call bump%mpl%flush + + ! Load ensemble 1 sample moments + write(bump%mpl%info,'(a7,a)') '','Ensemble 1' + call bump%mpl%flush + call bump%mom(1)%read(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%ens(1),'mom1') + + select case(trim(bump%nam%method)) + case ('hyb-rnd','hyb-ens') + ! Load ensemble 2 sample moments + write(bump%mpl%info,'(a7,a)') '','Ensemble 2' + call bump%mpl%flush + call bump%mom(2)%read(bump%mpl,bump%nam,bump%geom(2),bump%bpar,bump%samp(2),bump%ens(2),'mom2') + end select +end if + +if (bump%nam%new_hdiag) then + ! Run HDIAG driver + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run HDIAG driver' + call bump%mpl%flush + call bump%hdiag%run_hdiag(bump%mpl,bump%nam,bump%geom,bump%bpar,bump%samp,bump%mom) +end if + +if (bump%nam%check_consistency) then + ! Check HDIAG/NICAS consistency + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Check HDIAG/NICAS consistency' + call bump%mpl%flush + call bump%check_consistency +end if + +if (bump%nam%check_set_param) then + ! Test set_parameter interfaces + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Test set_parameter interfaces' + call bump%mpl%flush() + call bump%test_set_parameter + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) +end if + +if (allocated(bump%cmat(1)%blk)) then + ! Get C matrix from BUMP interface, ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Get C matrix from BUMP interface, ensemble 1' + call bump%mpl%flush + call bump%cmat(1)%from_bump(bump%mpl,bump%geom(1),bump%bpar) +end if + +if (.not.bump%nam%check_optimality) then + ! Copy namelist support radii into C matrix, ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Copy namelist support radii into C matrix, ensemble 1' + call bump%mpl%flush + call bump%cmat(1)%from_nam(bump%mpl,bump%nam,bump%geom(1),bump%bpar) +end if + +if (bump%nam%new_hdiag) then + ! Copy HDIAG into C matrix, ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Copy HDIAG into C matrix, ensemble 1' + call bump%mpl%flush + select case(trim(bump%nam%method)) + case ('cor') + call bump%cmat(1)%from_hdiag(bump%mpl,bump%geom(1),bump%bpar,bump%hdiag%cor(1)) + case ('loc','hyb-avg','hyb-rnd','hyb-ens') + call bump%cmat(1)%from_hdiag(bump%mpl,bump%geom(1),bump%bpar,bump%hdiag%loc(1),loc_scaling_factor) + end select + + select case(trim(bump%nam%method)) + case ('hyb-ens') + ! Copy HDIAG into C matrix, ensemble 2 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Copy HDIAG into C matrix, ensemble 2' + call bump%mpl%flush + call bump%cmat(2)%from_hdiag(bump%mpl,bump%geom(2),bump%bpar,bump%hdiag%loc(2),loc_scaling_factor) + end select +end if + +if (bump%cmat(1)%allocated) then + ! Setup C matrix sampling, ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Setup C matrix sampling, ensemble 1' + call bump%mpl%flush + call bump%cmat(1)%setup_sampling(bump%mpl,bump%nam,bump%geom(1),bump%bpar) +end if + +if (bump%cmat(2)%allocated) then + ! Setup C matrix sampling, ensemble 2 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Setup C matrix sampling, ensemble 2' + call bump%mpl%flush + call bump%cmat(2)%setup_sampling(bump%mpl,bump%nam,bump%geom(2),bump%bpar) +end if + +if (bump%nam%new_nicas.or.bump%nam%load_nicas_global) then + ! Run NICAS driver, ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run NICAS driver, ensemble 1' + call bump%mpl%flush + call bump%nicas(1)%run_nicas(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,bump%cmat(1)) + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + + if (bump%nam%new_nicas.and.(trim(bump%nam%method)=='hyb-ens')) then + ! Run NICAS driver, ensemble 2 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run NICAS driver, ensemble 2' + call bump%mpl%flush + call bump%nicas(2)%run_nicas(bump%mpl,bump%rng,bump%nam,bump%geom(2),bump%bpar,bump%cmat(2)) + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + end if +elseif (bump%nam%load_nicas_local) then + ! Read local NICAS parameters, ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Read local NICAS parameters, ensemble 1' + call bump%mpl%flush + call bump%nicas(1)%read_local(bump%mpl,bump%nam,bump%geom(1),bump%bpar) +end if + +if (bump%nam%check_optimality) then + ! Check HDIAG/NICAS optimality + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Check HDIAG/NICAS optimality' + call bump%mpl%flush + call bump%check_optimality +end if + +! Release memory (partial) +call bump%cmat(1)%partial_dealloc +call bump%cmat(2)%partial_dealloc + +if (bump%nam%new_nicas.or.bump%nam%load_nicas_local.or.bump%nam%load_nicas_global) then + ! Run NICAS tests driver, ensemble 1 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run NICAS tests driver, ensemble 1' + call bump%mpl%flush + call bump%nicas(1)%run_nicas_tests(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,bump%ens(1)) + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + + if (bump%nam%new_nicas.and.(trim(bump%nam%method)=='hyb-ens')) then + ! Run NICAS tests driver, ensemble 2 + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run NICAS tests driver, ensemble 2' + call bump%mpl%flush + call bump%nicas(2)%run_nicas_tests(bump%mpl,bump%rng,bump%nam,bump%geom(2),bump%bpar,bump%ens(2)) + if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + end if +end if + +if (bump%nam%new_wind.or.bump%nam%load_wind_local) then + ! Run psi/chi to u/v driver + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Run psi/chi to u/v driver' + call bump%mpl%flush + call bump%wind%setup(bump%mpl,bump%rng,bump%nam,bump%geom(1)) +end if + +! Probe out + + +end subroutine bump_run_drivers + +!---------------------------------------------------------------------- +! Subroutine: bump_check_consistency +!> Check HDIAG/NICAS consistency +!---------------------------------------------------------------------- +subroutine bump_check_consistency(bump) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP + +! Local variables +integer :: ib,il0,iv +real(kind_real) :: rh_diag,rv_diag + +! Set name + + +! Get instance + + +! Probe in + + +do ib=1,bump%bpar%nbe + if (bump%bpar%nicas_block(ib)) then + write(bump%mpl%info,'(a7,a)') '','Block: '//trim(bump%bpar%blockname(ib)) + call bump%mpl%flush + iv = bump%bpar%b_to_v1(ib) + do il0=1,bump%geom(1)%nl0 + rh_diag = -one + rv_diag = -one + if (bump%nam%rh(il0,iv)>zero) rh_diag = bump%hdiag%cor(1)%blk(0,ib)%rh_l0(il0,1)/bump%nam%rh(il0,iv) + if (bump%nam%rv(il0,iv)>zero) rv_diag = bump%hdiag%cor(1)%blk(0,ib)%rv_l0(il0,1)/bump%nam%rv(il0,iv) + write(bump%mpl%info,'(a10,a,i3,a,f6.3,a,f6.3)') '','Level ',bump%nam%levs(il0),' ~> ',rh_diag,' / ',rv_diag + call bump%mpl%flush + end do + end if +end do + +! Probe out + + +end subroutine bump_check_consistency + +!---------------------------------------------------------------------- +! Subroutine: bump_check_optimality +!> Check HDIAG/NICAS localization optimality +!---------------------------------------------------------------------- +subroutine bump_check_optimality(bump) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP + +! Local variables +integer :: ib,ifac,ifac_best,itest +real(kind_real) :: fac(-nfac_opt:nfac_opt),mse(ntest,-nfac_opt:nfac_opt),mse_avg(-nfac_opt:nfac_opt) +real(kind_real) :: fld_ref(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv,ntest) +real(kind_real) :: fld_save(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv,ntest) +real(kind_real) :: fld(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +type(nicas_type) :: nicas_test + +! Set name + + +! Get instance + + +! Probe in + + +! Define test vectors +write(bump%mpl%info,'(a4,a)') '','Define test vectors' +call bump%mpl%flush +call bump%geom(1)%define_test_vectors(bump%mpl,bump%rng,bump%nam,ntest,fld_save) +if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) + +! Apply correlation operator to test vectors +write(bump%mpl%info,'(a4,a)') '','Apply correlation operator to test vectors' +call bump%mpl%flush +fld_ref = fld_save +do itest=1,ntest + call bump%nicas(1)%apply(bump%mpl,bump%nam,bump%geom(1),bump%bpar,fld_ref(:,:,:,itest)) +end do + +! Reduce ensemble size +bump%ens(1)%ne = bump%nam%ne + +! Compute mean for ensemble 1 +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a)') '--- Compute mean for ensemble 1' +call bump%mpl%flush +call bump%ens(1)%compute_mean(bump%mpl,bump%nam,bump%geom(1)) + +do ifac=-nfac_opt,nfac_opt + ! Multiplication factor + fac(ifac) = one+0.05_kind_real*real(ifac,kind_real) + + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a,f4.2,a)') '--- Generate NICAS with a multiplicative factor ',fac(ifac),' to length-scales' + call bump%mpl%flush + + ! Allocation + call nicas_test%alloc(bump%bpar) + + do ib=1,bump%bpar%nbe + if (bump%bpar%nicas_block(ib)) then + write(bump%mpl%info,'(a)') '--- Block: '//trim(bump%bpar%blockname(ib)) + call bump%mpl%flush + + ! Length-scales scaling + bump%cmat(1)%blk(ib)%rhs = bump%cmat(1)%blk(ib)%rhs*fac(ifac) + bump%cmat(1)%blk(ib)%rvs = bump%cmat(1)%blk(ib)%rvs*fac(ifac) + bump%cmat(1)%blk(ib)%rh = bump%cmat(1)%blk(ib)%rh*fac(ifac) + bump%cmat(1)%blk(ib)%rv = bump%cmat(1)%blk(ib)%rv*fac(ifac) + + ! Copy length-scales + call nicas_test%blk(ib)%copy_cmat(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%cmat(1)%blk(ib)) + + ! Compute NICAS parameters + call nicas_test%blk(ib)%compute_parameters(bump%mpl,bump%rng,bump%nam,bump%geom(1)) + + ! Length-scales inverse scaling + bump%cmat(1)%blk(ib)%rhs = bump%cmat(1)%blk(ib)%rhs/fac(ifac) + bump%cmat(1)%blk(ib)%rvs = bump%cmat(1)%blk(ib)%rvs/fac(ifac) + bump%cmat(1)%blk(ib)%rh = bump%cmat(1)%blk(ib)%rh/fac(ifac) + bump%cmat(1)%blk(ib)%rv = bump%cmat(1)%blk(ib)%rv/fac(ifac) + end if + end do + + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a)') '--- Apply small ensemble with localization to test vectors' + call bump%mpl%flush + + do itest=1,ntest + ! Apply localized ensemble + fld = fld_save(:,:,:,itest) + call nicas_test%apply_bens(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%ens(1),fld) + + ! RMSE + mse(itest,ifac) = zss_sum((fld-fld_ref(:,:,:,itest))**2,mask=bump%mpl%msv%isnot(fld_ref(:,:,:,itest))) + call bump%mpl%f_comm%allreduce(mse(itest,ifac),fckit_mpi_sum()) + end do + mse_avg(ifac) = sum(mse(:,ifac))/real(ntest,kind_real) + + ! Print scores + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + call bump%mpl%flush + write(bump%mpl%info,'(a,f4.2,a,e15.8)') '--- Optimality results for a factor ',fac(ifac),', MSE: ',mse_avg(ifac) + call bump%mpl%flush + + ! Release memory + call nicas_test%dealloc +end do + +! Print scores summary +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a)') '--- Optimality results summary' +call bump%mpl%flush +ifac_best = minloc(mse_avg,dim=1)-(nfac_opt+1) +do ifac=-nfac_opt,nfac_opt + write(bump%mpl%info,'(a7,a,f4.2,a,e15.8)') '','Factor ',fac(ifac),', MSE: ',mse_avg(ifac) + call bump%mpl%flush(.false.) + if (ifac==ifac_best) then + write(bump%mpl%info,'(a)') ' <~ best localization' + else + write(bump%mpl%info,'(a)') '' + end if + call bump%mpl%flush() +end do + +! Probe out + + +end subroutine bump_check_optimality + +!---------------------------------------------------------------------- +! Subroutine: bump_apply_vbal +!> Vertical balance application +!---------------------------------------------------------------------- +subroutine bump_apply_vbal(bump,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) + +! Set name + + +! Get instance + + +! Probe in + + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Apply vertical balance +call bump%vbal%apply(bump%nam,bump%geom(1),bump%bpar,fld_c0a) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out + + +end subroutine bump_apply_vbal + +!---------------------------------------------------------------------- +! Subroutine: bump_apply_vbal_inv +!> Vertical balance application, inverse +!---------------------------------------------------------------------- +subroutine bump_apply_vbal_inv(bump,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) + +! Set name + + +! Get instance + + +! Probe in + + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Apply vertical balance, inverse +call bump%vbal%apply_inv(bump%nam,bump%geom(1),bump%bpar,fld_c0a) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out + + +end subroutine bump_apply_vbal_inv + +!---------------------------------------------------------------------- +! Subroutine: bump_apply_vbal_ad +!> Vertical balance application, adjoint +!---------------------------------------------------------------------- +subroutine bump_apply_vbal_ad(bump,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) + +! Set name + + +! Get instance + + +! Probe in + + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Apply vertical balance, adjoint +call bump%vbal%apply_ad(bump%nam,bump%geom(1),bump%bpar,fld_c0a) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out + + +end subroutine bump_apply_vbal_ad + +!---------------------------------------------------------------------- +! Subroutine: bump_apply_vbal_inv_ad +!> Vertical balance application, inverse adjoint +!---------------------------------------------------------------------- +subroutine bump_apply_vbal_inv_ad(bump,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) + +! Set name + + +! Get instance + + +! Probe in + + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Apply vertical balance, inverse adjoint +call bump%vbal%apply_inv_ad(bump%nam,bump%geom(1),bump%bpar,fld_c0a) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out + + +end subroutine bump_apply_vbal_inv_ad + +!---------------------------------------------------------------------- +! Subroutine: bump_apply_stddev +!> Standard-deviation application +!---------------------------------------------------------------------- +subroutine bump_apply_stddev(bump,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) + +! Set name + + +! Get instance + + +! Probe in + + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Apply standard-deviation +call bump%var%apply_sqrt(bump%mpl,bump%nam,bump%geom(1),fld_c0a) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out + + +end subroutine bump_apply_stddev + +!---------------------------------------------------------------------- +! Subroutine: bump_apply_stddev_inv +!> Standard-deviation application, inverse +!---------------------------------------------------------------------- +subroutine bump_apply_stddev_inv(bump,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) + +! Set name + + +! Get instance + + +! Probe in + + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Apply standard-deviation +call bump%var%apply_sqrt_inv(bump%mpl,bump%nam,bump%geom(1),fld_c0a) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out + + +end subroutine bump_apply_stddev_inv + +!---------------------------------------------------------------------- +! Subroutine: bump_apply_nicas +!> NICAS application +!---------------------------------------------------------------------- +subroutine bump_apply_nicas(bump,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) + +! Set name + + +! Get instance + + +! Probe in + + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Apply NICAS +call bump%nicas(1)%apply(bump%mpl,bump%nam,bump%geom(1),bump%bpar,fld_c0a) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out + + +end subroutine bump_apply_nicas + +!---------------------------------------------------------------------- +! Subroutine: bump_get_cv_size +!> Get control variable size +!---------------------------------------------------------------------- +subroutine bump_get_cv_size(bump,n) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +integer,intent(out) :: n !< Control variable size + +! Local variables +type(cv_type) :: cv + +! Set name + + +! Get instance + + +! Probe in + + +! Allocate control variable +call bump%nicas(1)%alloc_cv(bump%mpl,bump%bpar,cv,getsizeonly=.true.) + +! Copy size +n = cv%n + +! Probe out + + +end subroutine bump_get_cv_size + +!---------------------------------------------------------------------- +! Subroutine: bump_apply_nicas_sqrt +!> NICAS square-root application +!---------------------------------------------------------------------- +subroutine bump_apply_nicas_sqrt(bump,pcv,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +real(kind_real),intent(in) :: pcv(:) !< Packed control variable +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +integer :: ic0a,il0,iv +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +type(cv_type) :: cv + +! Set name + + +! Get instance + + +! Probe in + + +! Allocation +call bump%nicas(1)%alloc_cv(bump%mpl,bump%bpar,cv) + +! Check dimension +if (size(pcv)==cv%n) then + ! Unpack control variable + call cv%unpack(pcv) +else + call bump%mpl%abort('bump_apply_nicas_sqrt','wrong control variable size') +end if + +! Apply NICAS square-root +call bump%nicas(1)%apply_sqrt(bump%mpl,bump%nam,bump%geom(1),bump%bpar,cv,fld_c0a) + +! Set missing unmasked values to zero +do iv=1,bump%nam%nv + do il0=1,bump%geom(1)%nl0 + do ic0a=1,bump%geom(1)%nc0a + if (bump%mpl%msv%is(fld_c0a(ic0a,il0,iv)).and.(.not.bump%geom(1)%gmask_c0a(ic0a,il0))) fld_c0a(ic0a,il0,iv) = zero + end do + end do +end do + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out + + +end subroutine bump_apply_nicas_sqrt + +!---------------------------------------------------------------------- +! Subroutine: bump_apply_nicas_sqrt_ad +!> NICAS square-root adjoint application +!---------------------------------------------------------------------- +subroutine bump_apply_nicas_sqrt_ad(bump,fieldset,pcv) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset +real(kind_real),intent(inout) :: pcv(:) !< Packed control variable + +! Local variables +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +type(cv_type) :: cv + +! Set name + + +! Get instance + + +! Probe in + + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Apply NICAS square-root adjoint +call bump%nicas(1)%apply_sqrt_ad(bump%mpl,bump%nam,bump%geom(1),bump%bpar,fld_c0a,cv) + +! Check dimension +if (size(pcv)==cv%n) then + ! Pack control variable + call cv%pack(pcv) +else + call bump%mpl%abort('bump_apply_nicas_sqrt_ad','wrong control variable size') +end if + +! Probe out + + +end subroutine bump_apply_nicas_sqrt_ad + +!---------------------------------------------------------------------- +! Subroutine: bump_randomize +!> NICAS randomization +!---------------------------------------------------------------------- +subroutine bump_randomize(bump,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +type(cv_type) :: cv + +! Set name + + +! Get instance + + +! Probe in + + +! Generate random control vector +call bump%nicas(1)%random_cv(bump%mpl,bump%rng,bump%bpar,cv) + +! Apply NICAS square-root +call bump%nicas(1)%apply_sqrt(bump%mpl,bump%nam,bump%geom(1),bump%bpar,cv,fld_c0a) + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out + + +end subroutine bump_randomize + +!---------------------------------------------------------------------- +! Subroutine: bump_psichi_to_uv +!> psi/chi to u/v transform +!---------------------------------------------------------------------- +subroutine bump_psichi_to_uv(bump,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +integer :: iv,iv_psi,iv_chi,iv_ua,iv_va +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +type(atlas_field) :: afield + +! Set name + + +! Get instance + + +! Probe in + + +! Get u/v variables in fieldset or create and add them +if (fieldset%has_field(bump%nam%wind_zonal)) then + afield = fieldset%field(bump%nam%wind_zonal) +else + afield = bump%geom(1)%afunctionspace_mg%create_field(name=bump%nam%wind_zonal,kind=atlas_real(kind_real), & + & levels=bump%geom(1)%nl0) + call fieldset%add(afield) +end if +if (fieldset%has_field(bump%nam%wind_meridional)) then + afield = fieldset%field(bump%nam%wind_meridional) +else + afield = bump%geom(1)%afunctionspace_mg%create_field(name=bump%nam%wind_meridional,kind=atlas_real(kind_real), & + & levels=bump%geom(1)%nl0) + call fieldset%add(afield) +end if + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Get psi/chi/ua/va indices +do iv=1,bump%nam%nv + if (bump%nam%variables(iv)==bump%nam%wind_streamfunction) iv_psi = iv + if (bump%nam%variables(iv)==bump%nam%wind_velocity_potential) iv_chi = iv + if (bump%nam%variables(iv)==bump%nam%wind_zonal) iv_ua = iv + if (bump%nam%variables(iv)==bump%nam%wind_meridional) iv_va = iv +end do + +! Transform psi/chi to u/v +call bump%wind%psichi_to_uv(bump%mpl,bump%geom(1),fld_c0a(:,:,iv_psi),fld_c0a(:,:,iv_chi), & + & fld_c0a(:,:,iv_ua),fld_c0a(:,:,iv_va)) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out + + +end subroutine bump_psichi_to_uv + +!---------------------------------------------------------------------- +! Subroutine: bump_psichi_to_uv_ad +!> psi/chi to u/v transform, adjoint +!---------------------------------------------------------------------- +subroutine bump_psichi_to_uv_ad(bump,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +integer :: iv,iv_psi,iv_chi,iv_ua,iv_va +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +type(atlas_field) :: afield + +! Set name + + +! Get instance + + +! Probe in + + +! Get psi/chi variables in fieldset or create and add them +if (fieldset%has_field(bump%nam%wind_streamfunction)) then + afield = fieldset%field(bump%nam%wind_streamfunction) +else + afield = bump%geom(1)%afunctionspace_mg%create_field(name=bump%nam%wind_streamfunction,kind=atlas_real(kind_real), & + & levels=bump%geom(1)%nl0) + call fieldset%add(afield) +end if +if (fieldset%has_field(bump%nam%wind_velocity_potential)) then + afield = fieldset%field(bump%nam%wind_velocity_potential) +else + afield = bump%geom(1)%afunctionspace_mg%create_field(name=bump%nam%wind_velocity_potential,kind=atlas_real(kind_real), & + & levels=bump%geom(1)%nl0) + call fieldset%add(afield) +end if + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Get psi/chi/ua/va indices +do iv=1,bump%nam%nv + if (bump%nam%variables(iv)==bump%nam%wind_zonal) iv_ua = iv + if (bump%nam%variables(iv)==bump%nam%wind_meridional) iv_va = iv + if (bump%nam%variables(iv)==bump%nam%wind_streamfunction) iv_psi = iv + if (bump%nam%variables(iv)==bump%nam%wind_velocity_potential) iv_chi = iv +end do + +! Transform psi/chi to u/v adjoint +call bump%wind%psichi_to_uv_ad(bump%mpl,bump%geom(1),fld_c0a(:,:,iv_ua),fld_c0a(:,:,iv_va), & + & fld_c0a(:,:,iv_psi),fld_c0a(:,:,iv_chi)) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out + + +end subroutine bump_psichi_to_uv_ad + + +!---------------------------------------------------------------------- +! Subroutine: bump_get_ncmp +!> Get number of components +!---------------------------------------------------------------------- +subroutine bump_get_ncmp(bump,iv,ncmp) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +integer,intent(in) :: iv !< Variable index +integer,intent(inout) :: ncmp !< Number of components + +! Set name + + +! Get instance + + +! Probe in + + +write(bump%mpl%info,'(a7,a)') '','Get number of components' +call bump%mpl%flush + +! Check variable index +if ((iv<1).or.(iv>bump%nam%nv)) call bump%mpl%abort('bump_get_ncmp','variable index out of bounds') + +! Copy +if (bump%nam%forced_radii) then + ncmp = one +else + ncmp = bump%nam%fit_ncmp(iv) +end if + +! Probe out + + +end subroutine bump_get_ncmp + +!---------------------------------------------------------------------- +! Subroutine: bump_get_parameter +!> Get parameter +!---------------------------------------------------------------------- +subroutine bump_get_parameter(bump,param,icmp,igeom,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +character(len=*),intent(in) :: param !< Parameter +integer,intent(in) :: icmp !< Component index +integer,intent(in) :: igeom !< Geometry index +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variables +integer :: ib,iv,ic0a,il0 +real(kind_real) :: fld_c0a(bump%geom(igeom)%nc0a,bump%geom(igeom)%nl0) +real(kind_real) :: fld_mga(bump%geom(igeom)%nmga,bump%geom(igeom)%nl0,bump%nam%nv) +logical :: found + +! Set name + + +! Get instance + + +! Probe in + + +write(bump%mpl%info,'(a7,a,a)') '','Get ',trim(param) +call bump%mpl%flush + +! Initialization +fld_mga = bump%mpl%msv%valr + +! Copy to field +do iv=1,bump%nam%nv + ! Initialization + found = .false. + + ! Block index + select case (trim(bump%nam%strategy)) + case ('specific_univariate','specific_multivariate') + ib = bump%bpar%v_to_b(iv) + case ('common','common_weighted') + ib = bump%bpar%nbe + end select + + ! Select parameter from geom + select case (trim(param)) + case ('lon') + if (.not.allocated(bump%geom(igeom)%lon_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + do il0=1,bump%geom(igeom)%nl0 + fld_c0a(:,il0) = bump%geom(igeom)%lon_c0a*rad2deg + end do + found = .true. + case ('lat') + if (.not.allocated(bump%geom(igeom)%lat_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + do il0=1,bump%geom(igeom)%nl0 + fld_c0a(:,il0) = bump%geom(igeom)%lat_c0a*rad2deg + end do + found = .true. + case ('area') + if (.not.allocated(bump%geom(igeom)%area_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + do il0=1,bump%geom(igeom)%nl0 + fld_c0a(:,il0) = bump%geom(igeom)%area_c0a*req**2 + end do + found = .true. + case ('vunit') + if (.not.allocated(bump%geom(igeom)%vunit_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%geom(igeom)%vunit_c0a + found = .true. + end select + + ! Select parameter from ens + select case (trim(param)) + case ('norm_m2') + if (.not.allocated(bump%ens(1)%norm_m2)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%ens(1)%norm_m2(:,:,iv) + found = .true. + case ('norm_m4') + if (.not.allocated(bump%ens(1)%norm_m4)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%ens(1)%norm_m4(:,:,iv) + found = .true. + case ('norm_kurt') + if (.not.allocated(bump%ens(1)%norm_kurt)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%ens(1)%norm_kurt(:,:,iv) + found = .true. + end select + + ! Select parameter from vbal + select case (trim(param)) + case ('dirac_vbal') + if (.not.allocated(bump%vbal%dirac)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%vbal%dirac(:,:,iv) + found = .true. + end select + + ! Select parameter from var + select case (trim(param)) + case ('stddev') + if (.not.allocated(bump%var%m2sqrt)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%var%m2sqrt(:,:,iv) + found = .true. + case ('var') + if (.not.allocated(bump%var%m2)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%var%m2(:,:,iv) + found = .true. + case ('m4') + if (.not.allocated(bump%var%m4)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%var%m4(:,:,iv) + found = .true. + end select + + ! Select parameter from mom + select case (trim(param)) + case ('dirac_mom') + if (.not.allocated(bump%mom(1)%dirac)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%mom(1)%dirac(:,:,iv) + found = .true. + end select + + ! Select parameter from hdiag + select case (trim(param)) + case ('cor_a','cor_a_lr') + if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%a_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& +# 1970 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & allocated') + if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%a_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component is& +# 1971 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & too large') + fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%a_c0a(:,:,icmp) + found = .true. + case ('cor_rh','cor_rh_lr') + if (bump%nam%forced_radii) then + do il0=1,bump%geom(igeom)%nl0 + fld_c0a(:,il0) = bump%nam%rh(il0,iv)*req + end do + else + if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%rh_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is& +# 1981 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & not allocated') + if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%rh_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//'& +# 1982 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & component is too large') + fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%rh_c0a(:,:,icmp) + do il0=1,bump%geom(igeom)%nl0 + do ic0a=1,bump%geom(igeom)%nc0a + if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = fld_c0a(ic0a,il0)*req + end do + end do + end if + found = .true. + case ('cor_rh1','cor_rh1_lr') + if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%D11_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& +# 1993 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & allocated') + if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%D11_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& +# 1994 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & is too large') + fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%D11_c0a(:,:,icmp) + do il0=1,bump%geom(igeom)%nl0 + do ic0a=1,bump%geom(igeom)%nc0a + if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req + end do + end do + found = .true. + case ('cor_rh2','cor_rh2_lr') + if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%D22_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& +# 2004 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & allocated') + if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%D22_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& +# 2005 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & is too large') + fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%D22_c0a(:,:,icmp) + do il0=1,bump%geom(igeom)%nl0 + do ic0a=1,bump%geom(igeom)%nc0a + if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req + end do + end do + found = .true. + case ('cor_rhc','cor_rhc_lr') + if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%D12_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& +# 2015 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & allocated') + if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%D12_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& +# 2016 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & is too large') + fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%D12_c0a(:,:,icmp) + found = .true. + case ('cor_rv','cor_rv_lr') + if (bump%nam%forced_radii) then + do il0=1,bump%geom(igeom)%nl0 + fld_c0a(:,il0) = bump%nam%rv(il0,iv) + end do + else + if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%rv_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is& +# 2026 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & not allocated') + if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%rv_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//'& +# 2027 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & component is too large') + fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%rv_c0a(:,:,icmp) + end if + found = .true. + case ('dirac_diag_cor','dirac_diag_cor_lr') + if (.not.allocated(bump%hdiag%cor(igeom)%dirac)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%hdiag%cor(igeom)%dirac(:,:,iv) + found = .true. + case ('loc_a','loc_a_lr') + if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%a_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& +# 2037 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & allocated') + if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%a_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component is& +# 2038 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & too large') + fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%a_c0a(:,:,icmp) + found = .true. + case ('loc_rh','loc_rh_lr') + if (bump%nam%forced_radii) then + do il0=1,bump%geom(igeom)%nl0 + fld_c0a(:,il0) = bump%nam%rh(il0,iv)*req + end do + else + if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%rh_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is& +# 2048 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & not allocated') + if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%rh_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//'& +# 2049 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & component is too large') + fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%rh_c0a(:,:,icmp) + do il0=1,bump%geom(igeom)%nl0 + do ic0a=1,bump%geom(igeom)%nc0a + if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = fld_c0a(ic0a,il0)*req + end do + end do + end if + found = .true. + case ('loc_rh1','loc_rh1_lr') + if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%D11_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& +# 2060 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & allocated') + if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%D11_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& +# 2061 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & is too large') + fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%D11_c0a(:,:,icmp) + do il0=1,bump%geom(igeom)%nl0 + do ic0a=1,bump%geom(igeom)%nc0a + if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req + end do + end do + found = .true. + case ('loc_rh2','loc_rh2_lr') + if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%D22_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& +# 2071 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & allocated') + if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%D22_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& +# 2072 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & is too large') + fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%D22_c0a(:,:,icmp) + do il0=1,bump%geom(igeom)%nl0 + do ic0a=1,bump%geom(igeom)%nc0a + if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req + end do + end do + found = .true. + case ('loc_rhc','loc_rhc_lr') + if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%D12_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& +# 2082 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & allocated') + if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%D12_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& +# 2083 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & is too large') + fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%D12_c0a(:,:,icmp) + found = .true. + case ('loc_rv','loc_rv_lr') + if (bump%nam%forced_radii) then + do il0=1,bump%geom(igeom)%nl0 + fld_c0a(:,il0) = bump%nam%rv(il0,iv) + end do + else + if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%rv_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is& +# 2093 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & not allocated') + if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%rv_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//'& +# 2094 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & component is too large') + fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%rv_c0a(:,:,icmp) + end if + found = .true. + case ('dirac_diag_loc','dirac_diag_loc_lr') + if (.not.allocated(bump%hdiag%loc(igeom)%dirac)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%hdiag%loc(igeom)%dirac(:,:,iv) + found = .true. + case ('hyb_coef_ens') + if (.not.allocated(bump%hdiag%loc(1)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc(1)%blk(0,ib)%hyb_coef_c0a)) call bump%mpl%abort('bump_get_parameter', & + & trim(param)//' is not allocated') + fld_c0a = bump%hdiag%loc(1)%blk(0,ib)%hyb_coef_c0a + found = .true. + case ('hyb_coef_sta','hyb_coef_ens_lr') + if (.not.allocated(bump%hdiag%loc(2)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc(2)%blk(0,ib)%hyb_coef_c0a)) call bump%mpl%abort('bump_get_parameter', & + & trim(param)//' is not allocated') + fld_c0a = bump%hdiag%loc(2)%blk(0,ib)%hyb_coef_c0a + found = .true. + end select + + ! Select parameter from nicas + select case (trim(param)) + case ('nicas_norm','nicas_norm_lr') + if (.not.allocated(bump%nicas(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' block is not allocated') + if (.not.allocated(bump%nicas(igeom)%blk(ib)%cmp)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component is not& +# 2120 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & allocated') + if (icmp>size(bump%nicas(igeom)%blk(ib)%cmp)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component is too large') + if (.not.allocated(bump%nicas(igeom)%blk(ib)%cmp(icmp)%norm)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& +# 2122 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & allocated') + fld_c0a = bump%nicas(igeom)%blk(ib)%cmp(icmp)%norm + found = .true. + case ('dirac_nicas','dirac_nicas_lr') + if (.not.allocated(bump%nicas(igeom)%dirac)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%nicas(igeom)%dirac(:,:,iv) + found = .true. + case ('dirac_nicas_bens','dirac_nicas_bens_lr') + if (.not.allocated(bump%nicas(igeom)%dirac_bens)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') + fld_c0a = bump%nicas(igeom)%dirac_bens(:,:,iv) + found = .true. + end select + + ! Copy to model grid + call bump%geom(igeom)%copy_c0a_to_mga(bump%mpl,fld_c0a,fld_mga(:,:,iv)) + + ! Check that parameters was found + if (.not.found) call bump%mpl%abort('bump_get_parameter','parameter '//trim(param)//' not found') +end do + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(igeom)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fortran array to fieldset +call fieldset%from_array(bump%mpl,fld_mga) + +! Probe out + + +end subroutine bump_get_parameter + +!---------------------------------------------------------------------- +! Subroutine: bump_test_get_parameter +!> Test get_parameter +!---------------------------------------------------------------------- +subroutine bump_test_get_parameter(bump) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP + +! Local variables +type(fieldset_type) :: fieldset + +! Set name + + +! Get instance + + +! Probe in + + +! Create fieldset +call fieldset%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Get parameter +call bump%get_parameter('norm_m2',1,1,fieldset) +call bump%get_parameter('norm_m4',1,1,fieldset) +call bump%get_parameter('norm_kurt',1,1,fieldset) +if ((bump%nam%new_var.or.bump%nam%update_var).and.(trim(bump%nam%strategy)=='specific_multivariate')) then + call bump%get_parameter('stddev',1,1,fieldset) + call bump%get_parameter('var',1,1,fieldset) + call bump%get_parameter('m4',1,1,fieldset) +end if +call bump%get_parameter('cor_a',1,1,fieldset) +if (bump%nam%nc4==1) then + call bump%get_parameter('cor_rh',1,1,fieldset) +else + call bump%get_parameter('cor_rh1',1,1,fieldset) + call bump%get_parameter('cor_rh2',1,1,fieldset) + call bump%get_parameter('cor_rhc',1,1,fieldset) +end if +call bump%get_parameter('cor_rv',1,1,fieldset) +call bump%get_parameter('dirac_diag_cor',1,1,fieldset) +call bump%get_parameter('loc_a',1,1,fieldset) +if (bump%nam%nc4==1) then + call bump%get_parameter('loc_rh',1,1,fieldset) +else + call bump%get_parameter('loc_rh1',1,1,fieldset) + call bump%get_parameter('loc_rh2',1,1,fieldset) + call bump%get_parameter('loc_rhc',1,1,fieldset) +end if +call bump%get_parameter('loc_rv',1,1,fieldset) +call bump%get_parameter('dirac_diag_loc',1,1,fieldset) +call bump%get_parameter('hyb_coef_ens',1,1,fieldset) +call bump%get_parameter('hyb_coef_sta',1,1,fieldset) +call bump%get_parameter('hyb_coef_ens_lr',1,1,fieldset) +call bump%get_parameter('loc_a_lr',1,1,fieldset) +if (bump%nam%nc4==1) then + call bump%get_parameter('loc_rh_lr',1,1,fieldset) +else + call bump%get_parameter('loc_rh1_lr',1,1,fieldset) + call bump%get_parameter('loc_rh2_lr',1,1,fieldset) + call bump%get_parameter('loc_rhc_lr',1,1,fieldset) +end if +call bump%get_parameter('loc_rv_lr',1,1,fieldset) +call bump%get_parameter('dirac_diag_loc_lr',1,1,fieldset) +call bump%get_parameter('dirac_vbal',1,1,fieldset) +call bump%get_parameter('dirac_mom',1,1,fieldset) +call bump%get_parameter('nicas_norm',1,1,fieldset) +call bump%get_parameter('dirac_nicas',1,1,fieldset) +call bump%get_parameter('dirac_nicas_bens',1,1,fieldset) +call bump%get_parameter('nicas_norm_lr',1,1,fieldset) +call bump%get_parameter('dirac_nicas_lr',1,1,fieldset) +call bump%get_parameter('dirac_nicas_bens_lr',1,1,fieldset) + +! Release memory +call fieldset%final() + +! Probe out + + +end subroutine bump_test_get_parameter + +!---------------------------------------------------------------------- +! Subroutine: bump_set_ncmp +!> Set number of components +!---------------------------------------------------------------------- +subroutine bump_set_ncmp(bump,iv,ncmp) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +integer,intent(in) :: iv !< Variable index +integer,intent(in) :: ncmp !< Number of components + +! Local variables +integer :: ib + +! Set name + + +! Get instance + + +! Probe in + + +write(bump%mpl%info,'(a7,a)') '','Set number of components' +call bump%mpl%flush + +! Check variable index +if ((iv<1).or.(iv>bump%nam%nv)) call bump%mpl%abort('bump_set_ncmp','variable index out of bounds') + +! Check allocation +if (.not.allocated(bump%cmat(1)%blk)) allocate(bump%cmat(1)%blk(bump%bpar%nbe)) +if (.not.allocated(bump%nicas(1)%blk)) allocate(bump%nicas(1)%blk(bump%bpar%nbe)) + +! Set block index +select case (trim(bump%nam%strategy)) +case ('specific_univariate','specific_multivariate') + ib = bump%bpar%v_to_b(iv) +case ('common','common_weighted') + ib = bump%bpar%nbe +end select + +! Copy +bump%cmat(1)%blk(ib)%ncmp = ncmp +bump%nicas(1)%blk(ib)%ncmp = ncmp + +! Probe out + + +end subroutine bump_set_ncmp + +!---------------------------------------------------------------------- +! Subroutine: bump_set_parameter +!> Set parameter +!---------------------------------------------------------------------- +subroutine bump_set_parameter(bump,param,icmp,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +character(len=*),intent(in) :: param !< Parameter +integer,intent(in) :: icmp !< Component index +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variables +integer :: ic0a,il0,iv,ib,jb +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0) +real(kind_real) :: fld_mga(bump%geom(1)%nmga,bump%geom(1)%nl0,bump%nam%nv) +logical :: found + +! Set name + + +! Get instance + + +! Probe in + + +write(bump%mpl%info,'(a7,a,a)') '','Set ',trim(param) +call bump%mpl%flush + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) + +! Fieldset to Fortran array +call fieldset%to_array(bump%mpl,fld_mga) + +! Counter +select case (trim(param)) +case ('var') + bump%var%bump_m2_counter = bump%var%bump_m2_counter+1 +case ('m4') + bump%var%bump_m4_counter = bump%var%bump_m4_counter+1 +end select + +do iv=1,bump%nam%nv + ! Initialization + found = .false. + + ! Block index + select case (trim(bump%nam%strategy)) + case ('specific_univariate','specific_multivariate') + ib = bump%bpar%v_to_b(iv) + case ('common','common_weighted') + ib = bump%bpar%nbe + end select + + ! Check allocation / parameter existence + select case (trim(param)) + case ('stddev','var','m4','sampling_mask_field') + case ('a','rh','rh1','rh2','rhc','rv') + if (.not.allocated(bump%cmat(1)%blk)) allocate(bump%cmat(1)%blk(bump%bpar%nbe)) + case ('nicas_a','nicas_norm') + if (.not.allocated(bump%nicas(1)%blk)) then + ! Not allocated yet: allocate and set the number of components to one + allocate(bump%nicas(1)%blk(bump%bpar%nbe)) + do jb=1,bump%bpar%nbe + if (bump%bpar%nicas_block(ib)) bump%nicas(1)%blk(jb)%ncmp = 1 + end do + end if + if (bump%bpar%nicas_block(ib).and.(.not.allocated(bump%nicas(1)%blk(ib)%cmp))) & + & allocate(bump%nicas(1)%blk(ib)%cmp(bump%nicas(1)%blk(ib)%ncmp)) + case default + call bump%mpl%abort('bump_set_parameter','parameter '//trim(param)//' not yet implemented, available input parameters& +# 2364 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" + & are:'// & + & 'stddev, var, m4, sampling_mask_field, a, rh, rh1, rh2, rhc, rv, nicas_norm') + end select + + ! Copy to model grid + call bump%geom(1)%copy_mga_to_c0a(bump%mpl,fld_mga(:,:,iv),fld_c0a) + + ! Select parameter from var + select case (trim(param)) + case ('sampling_mask_field') + if (.not.allocated(bump%samp(1)%smask_input_c0a)) allocate(bump%samp(1)%smask_input_c0a(bump%geom(1)%nc0a, & + & bump%geom(1)%nl0,bump%nam%nv)) + bump%samp(1)%smask_input_c0a(:,:,iv) = fld_c0a + found = .true. + end select + + ! Select parameter from var + select case (trim(param)) + case ('stddev') + if (.not.allocated(bump%var%m2sqrt)) allocate(bump%var%m2sqrt(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) + bump%var%m2sqrt(:,:,iv) = fld_c0a + found = .true. + case ('var') + if (.not.allocated(bump%var%bump_m2)) then + allocate(bump%var%bump_m2(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) + bump%var%bump_m2 = zero + end if + bump%var%bump_m2(:,:,iv) = bump%var%bump_m2(:,:,iv)+fld_c0a + found = .true. + case ('m4') + if (.not.allocated(bump%var%bump_m4)) then + allocate(bump%var%bump_m4(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) + bump%var%bump_m4 = zero + end if + bump%var%bump_m4(:,:,iv) = bump%var%bump_m4(:,:,iv)+fld_c0a + found = .true. + end select + + ! Select parameter from cmat + select case (trim(param)) + case ('a') + if (.not.allocated(bump%cmat(1)%blk(ib)%bump_a)) allocate(bump%cmat(1)%blk(ib)%bump_a(bump%geom(1)%nc0a,bump%geom(1)%nl0, & + & bump%cmat(1)%blk(ib)%ncmp)) + bump%cmat(1)%blk(ib)%bump_a(:,:,icmp) = fld_c0a + found = .true. + case ('rh') + if (.not.allocated(bump%cmat(1)%blk(ib)%bump_rh)) allocate(bump%cmat(1)%blk(ib)%bump_rh(bump%geom(1)%nc0a,bump%geom(1)%nl0, & + & bump%cmat(1)%blk(ib)%ncmp)) + bump%cmat(1)%blk(ib)%bump_rh(:,:,icmp) = fld_c0a + do il0=1,bump%geom(1)%nl0 + do ic0a=1,bump%geom(1)%nc0a + if (bump%mpl%msv%isnot(bump%cmat(1)%blk(ib)%bump_rh(ic0a,il0,icmp))) & + & bump%cmat(1)%blk(ib)%bump_rh(ic0a,il0,icmp) = bump%cmat(1)%blk(ib)%bump_rh(ic0a,il0,icmp)/req + end do + end do + found = .true. + case ('rh1') + if (.not.allocated(bump%cmat(1)%blk(ib)%bump_D11)) allocate(bump%cmat(1)%blk(ib)%bump_D11(bump%geom(1)%nc0a, & + & bump%geom(1)%nl0,bump%cmat(1)%blk(ib)%ncmp)) + bump%cmat(1)%blk(ib)%bump_D11(:,:,icmp) = fld_c0a + do il0=1,bump%geom(1)%nl0 + do ic0a=1,bump%geom(1)%nc0a + if (bump%mpl%msv%isnot(bump%cmat(1)%blk(ib)%bump_D11(ic0a,il0,icmp))) & + & bump%cmat(1)%blk(ib)%bump_D11(ic0a,il0,icmp) = (bump%cmat(1)%blk(ib)%bump_D11(ic0a,il0,icmp)/req)**2 + end do + end do + found = .true. + case ('rh2') + if (.not.allocated(bump%cmat(1)%blk(ib)%bump_D22)) allocate(bump%cmat(1)%blk(ib)%bump_D22(bump%geom(1)%nc0a, & + & bump%geom(1)%nl0,bump%cmat(1)%blk(ib)%ncmp)) + bump%cmat(1)%blk(ib)%bump_D22(:,:,icmp) = fld_c0a + do il0=1,bump%geom(1)%nl0 + do ic0a=1,bump%geom(1)%nc0a + if (bump%mpl%msv%isnot(bump%cmat(1)%blk(ib)%bump_D22(ic0a,il0,icmp))) & + & bump%cmat(1)%blk(ib)%bump_D22(ic0a,il0,icmp) = (bump%cmat(1)%blk(ib)%bump_D22(ic0a,il0,icmp)/req)**2 + end do + end do + found = .true. + case ('rhc') + if (.not.allocated(bump%cmat(1)%blk(ib)%bump_D12)) allocate(bump%cmat(1)%blk(ib)%bump_D12(bump%geom(1)%nc0a, & + & bump%geom(1)%nl0,bump%cmat(1)%blk(ib)%ncmp)) + bump%cmat(1)%blk(ib)%bump_D12(:,:,icmp) = fld_c0a + found = .true. + case ('rv') + if (.not.allocated(bump%cmat(1)%blk(ib)%bump_rv)) allocate(bump%cmat(1)%blk(ib)%bump_rv(bump%geom(1)%nc0a,bump%geom(1)%nl0, & + & bump%cmat(1)%blk(ib)%ncmp)) + bump%cmat(1)%blk(ib)%bump_rv(:,:,icmp) = fld_c0a + found = .true. + end select + + ! Select parameter from nicas + select case (trim(param)) + case ('nicas_a') + if (icmp>size(bump%nicas(1)%blk(ib)%cmp)) call bump%mpl%abort('bump_set_parameter','component index is too large') + if (.not.allocated(bump%nicas(1)%blk(ib)%cmp(icmp)%a)) allocate(bump%nicas(1)%blk(ib)%cmp(icmp)%a(bump%geom(1)%nc0a, & + & bump%geom(1)%nl0)) + bump%nicas(1)%blk(ib)%cmp(icmp)%a = fld_c0a + found = .true. + case ('nicas_norm') + if (icmp>size(bump%nicas(1)%blk(ib)%cmp)) call bump%mpl%abort('bump_set_parameter','component index is too large') + if (.not.allocated(bump%nicas(1)%blk(ib)%cmp(icmp)%norm)) allocate(bump%nicas(1)%blk(ib)%cmp(icmp)%norm(bump%geom(1)%nc0a, & + & bump%geom(1)%nl0)) + bump%nicas(1)%blk(ib)%cmp(icmp)%norm = fld_c0a + found = .true. + end select + + ! Check that parameters was found + if (.not.found) call bump%mpl%abort('bump_set_parameter','parameter '//trim(param)//' not found') +end do + +! Probe out + + +end subroutine bump_set_parameter + +!---------------------------------------------------------------------- +! Subroutine: bump_test_set_parameter +!> Test set_parameter +!---------------------------------------------------------------------- +subroutine bump_test_set_parameter(bump) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP + +! Local variables +integer :: ic0a,il0,iv +real(kind_real) :: fld_min,fld_max +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a_sym(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a_req(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a_vert(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +type(fieldset_type) :: fieldset,fieldset_sym,fieldset_req,fieldset_vert + +! Set name + + +! Get instance + + +! Probe in + + +! Initialization +do iv=1,bump%nam%nv + do il0=1,bump%geom(1)%nl0 + do ic0a=1,bump%geom(1)%nc0a + fld_c0a(ic0a,il0,iv) = abs(real(fletcher32((/bump%geom(1)%lon_c0a(ic0a),bump%geom(1)%lat_c0a(ic0a),real(iv,kind_real), & + & real(il0,kind_real)/)),kind_real)) + end do + end do +end do +fld_min = zss_minval(fld_c0a) +fld_max = zss_maxval(fld_c0a) +call bump%mpl%f_comm%allreduce(fld_min,fckit_mpi_min()) +call bump%mpl%f_comm%allreduce(fld_max,fckit_mpi_max()) +fld_c0a = fld_c0a/abs(fld_max-fld_min) +fld_c0a_sym = fld_c0a-half +fld_c0a_req = fld_c0a*req +fld_c0a_vert = (one+fld_c0a)*(maxval(bump%geom(1)%vunitavg)-minval(bump%geom(1)%vunitavg)) + +! Create fieldset +call fieldset%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) +call fieldset_sym%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & + & bump%nam%lev2d) +call fieldset_req%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & + & bump%nam%lev2d) +call fieldset_vert%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & + & bump%nam%lev2d) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a_sym,fieldset_sym) +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a_req,fieldset_req) +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a_vert,fieldset_vert) + +! Set parameters +do iv=1,bump%nam%nv + call bump%set_ncmp(iv,1) +end do +if (trim(bump%nam%strategy)=='specific_univariate') then + call bump%set_parameter('stddev',1,fieldset) + call bump%set_parameter('var',1,fieldset) + call bump%set_parameter('m4',1,fieldset) +end if +if (bump%nam%nc4==1) then + call bump%set_parameter('rh',1,fieldset_req) +else + call bump%set_parameter('rh1',1,fieldset_req) + call bump%set_parameter('rh2',1,fieldset_req) + call bump%set_parameter('rhc',1,fieldset) +end if +call bump%set_parameter('rv',1,fieldset_vert) +call bump%set_parameter('nicas_norm',1,fieldset) + +! Release memory +call fieldset%final() +call fieldset_sym%final() +call fieldset_req%final() +call fieldset_vert%final() + +! Probe out + + +end subroutine bump_test_set_parameter + +!---------------------------------------------------------------------- +! Subroutine: bump_test_apply_interfaces +!> Test BUMP apply interfaces +!---------------------------------------------------------------------- +subroutine bump_test_apply_interfaces(bump) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP + +! Local variables +integer :: n +real(kind_real),allocatable :: fld_c0a(:,:,:),pcv(:) +type(fieldset_type) :: fieldset + +! Set name + + +! Get instance + + +! Probe in + + +! Test apply_vbal +if (bump%nam%check_apply_vbal) then + write(bump%mpl%info,'(a7,a)') '','Test apply_vbal' + call bump%mpl%flush + + ! Allocation + allocate(fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) + + ! Initialization + call bump%rng%rand(zero,one,fld_c0a) + + ! Create fieldset + call fieldset%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & + & bump%nam%lev2d) + + ! Fortran array on subset Sc0 to fieldset + call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + + ! Calls + call bump%apply_vbal(fieldset) + call bump%apply_vbal_inv(fieldset) + call bump%apply_vbal_ad(fieldset) + call bump%apply_vbal_inv_ad(fieldset) + + ! Release memory + deallocate(fld_c0a) + call fieldset%final() +end if + +! Test apply_stddev +if (bump%nam%check_apply_stddev) then + write(bump%mpl%info,'(a7,a)') '','Test apply_stddev' + call bump%mpl%flush + + ! Allocation + allocate(fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) + + ! Initialization + call bump%rng%rand(zero,one,fld_c0a) + + ! Create fieldset + call fieldset%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & + & bump%nam%lev2d) + + ! Fortran array on subset Sc0 to fieldset + call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + + ! Calls + call bump%apply_stddev(fieldset) + call bump%apply_stddev_inv(fieldset) + + ! Release memory + deallocate(fld_c0a) + call fieldset%final() +end if + +! Test apply_nicas +if (bump%nam%check_apply_nicas) then + write(bump%mpl%info,'(a7,a)') '','Test apply_nicas' + call bump%mpl%flush + + ! Get control variable size + call bump%get_cv_size(n) + + ! Allocation + allocate(fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) + allocate(pcv(n)) + + ! Initialization + call bump%rng%rand(zero,one,fld_c0a) + + ! Create fieldset + call fieldset%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & + & bump%nam%lev2d) + + ! Fortran array on subset Sc0 to fieldset + call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + + ! Calls + call bump%apply_nicas(fieldset) + call bump%apply_nicas_sqrt(pcv,fieldset) + call bump%apply_nicas_sqrt_ad(fieldset,pcv) + call bump%randomize(fieldset) + + ! Release memory + deallocate(fld_c0a) + deallocate(pcv) + call fieldset%final() +end if + +! Probe out + + +end subroutine bump_test_apply_interfaces + +!---------------------------------------------------------------------- +! Subroutine: bump_partial_dealloc +!> Release memory (partial) +!---------------------------------------------------------------------- +subroutine bump_partial_dealloc(bump) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP + +! Set name + + +! Get instance + + +! Probe in + + +! Release memory +if (allocated(bump%cmat)) then + call bump%cmat(1)%partial_dealloc + call bump%cmat(2)%partial_dealloc +end if +if (allocated(bump%ens)) then + call bump%ens(1)%partial_dealloc + call bump%ens(2)%partial_dealloc +end if +if (allocated(bump%geom)) then + call bump%geom(1)%partial_dealloc + call bump%geom(2)%partial_dealloc +end if +call bump%hdiag%partial_dealloc +if (allocated(bump%mom)) then + call bump%mom(1)%partial_dealloc + call bump%mom(2)%partial_dealloc +end if +if (allocated(bump%nicas)) then + call bump%nicas(1)%partial_dealloc + call bump%nicas(2)%partial_dealloc +end if +if (allocated(bump%samp)) then + call bump%samp(1)%dealloc + call bump%samp(2)%dealloc +end if +call bump%var%partial_dealloc +call bump%vbal%partial_dealloc + +! Probe out + + +end subroutine bump_partial_dealloc + +!---------------------------------------------------------------------- +! Subroutine: bump_dealloc +!> Release memory (full) +!---------------------------------------------------------------------- +subroutine bump_dealloc(bump) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP + +! Set name + + +! Get instance + + +! Execution stats + + +! Number of open NetCDF files +write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' +call bump%mpl%flush +write(bump%mpl%info,'(a)') '--- NetCDF I/O report' +call bump%mpl%flush +call registry%report(bump%mpl) + +! Release memory +call bump%bpar%dealloc +if (allocated(bump%cmat)) then + call bump%cmat(1)%dealloc + call bump%cmat(2)%dealloc + deallocate(bump%cmat) +end if +if (allocated(bump%ens)) then + call bump%ens(1)%dealloc + call bump%ens(2)%dealloc + deallocate(bump%ens) +end if +if (allocated(bump%geom)) then + call bump%geom(1)%dealloc + call bump%geom(2)%dealloc + deallocate(bump%geom) +end if +call bump%hdiag%dealloc +if (allocated(bump%mom)) then + call bump%mom(1)%dealloc + call bump%mom(2)%dealloc + deallocate(bump%mom) +end if +if (allocated(bump%nicas)) then + call bump%nicas(1)%dealloc + call bump%nicas(2)%dealloc + deallocate(bump%nicas) +end if +if (allocated(bump%samp)) then + call bump%samp(1)%dealloc + call bump%samp(2)%dealloc + deallocate(bump%samp) +end if +call bump%var%dealloc +call bump%vbal%dealloc + +! Execution stats + + +! Release probe instance + + +end subroutine bump_dealloc + +!---------------------------------------------------------------------- +! Subroutine: bump_dummy_final +!> Dummy finalization +!---------------------------------------------------------------------- +subroutine bump_dummy_final(bump) + +implicit none + +! Passed variables +type(bump_type),intent(inout) :: bump !< BUMP + +! Set name + + +! Get instance + + +! Probe in + + +! Dummy action to avoid compiler warning +bump%dummy_logical = .false. + +! Probe out + + +end subroutine bump_dummy_final + +end module type_bump diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 new file mode 100644 index 000000000..17ebe789c --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 @@ -0,0 +1,1103 @@ +! ********************************* +! * module pbfil +! * +! * R. J. Purser +! * +! * NOAA/NCEP/EMC +! * +! * March 2019 +! * +! * +! * +! ********************************* +! +! Codes for the beta filters. +! 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. +! +! Direct dependencies: +! Libraries: jp_pmat +! Modules: jp_pkind, jp_pietc, jp_pmat +! mg_parameter +! +!============================================================================= +module jp_pbfil +!============================================================================= +use mpi +use kinds, only: dp=>r_kind +!!!use jp_pkind, only: dp +use jp_pietc, only: u1 +use mg_parameter, only: p, rmom2_1,rmom2_2,rmom2_3,rmom2_4 +implicit none + +private + +public cholaspect +interface cholaspect + module procedure cholaspect1,cholaspect2,cholaspect3,cholaspect4 +end interface + +public getlinesum +interface getlinesum + module procedure getlinesum1,getlinesum2,getlinesum3 +end interface + +public rbeta +interface rbeta + module procedure rbeta1, rbeta2, rbeta3, rbeta4, & + vrbeta1,vrbeta2,vrbeta3,vrbeta4 +end interface + +public rbetaT +interface rbetaT + module procedure rbeta1t, rbeta2t, rbeta3t, rbeta4t, & + vrbeta1t,vrbeta2t,vrbeta3t,vrbeta4t +end interface + + +contains + +!============================================================================= +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 +!============================================================================= +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 +!============================================================================= +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 +!============================================================================= +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 + +!============================================================================= +subroutine getlinesum1(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. +!============================================================================= +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)*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**p + enddo + ss(ix)=u1/s +enddo +end subroutine getlinesum1 +!============================================================================= +subroutine getlinesum2(hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum] +!============================================================================= +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)*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**p + enddo! gx + enddo! gy + ss(ix,iy)=u1/s +enddo; enddo! ix, iy +end subroutine getlinesum2 +!============================================================================= +subroutine getlinesum3(hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss)! [getlinesum] +!============================================================================= +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)*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**p + enddo! gx + enddo! gy + enddo! gz + ss(ix,iy,iz)=u1/s +enddo; enddo; enddo! ix, iy, iz +end subroutine getlinesum3 +!============================================================================= +subroutine getlinesum4(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & + el, ss) ! [getlinesum] +!============================================================================= +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)*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**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 + +!============================================================================= +subroutine rbeta1(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. +!============================================================================= +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)*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**p + tb=tb+frow*a(jx) + enddo + b(ix)=tb +enddo +a=b +end subroutine rbeta1 +!============================================================================= +subroutine rbeta2(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. +!============================================================================= +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)*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**p + tb=tb+frow*a(jx,jy) + enddo! gx + enddo! gy + b(ix,iy)=tb +enddo; enddo! ix, iy +a=b +end subroutine rbeta2 +!============================================================================= +subroutine rbeta3(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. +!============================================================================= +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)*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**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 +!============================================================================= +subroutine rbeta4(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. +!============================================================================= +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)*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**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: +!============================================================================= +subroutine vrbeta4(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. +!============================================================================= +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)*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**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 + +!============================================================================= +subroutine rbeta1T(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. +!============================================================================= +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)*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**p + b(jx)=b(jx)+frow*ta + enddo +enddo +a=b +end subroutine rbeta1t +!============================================================================= +subroutine rbeta2T(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 +!============================================================================= +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)*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**p + b(jx,jy)=b(jx,jy)+frow*ta + enddo! gx + enddo! gy +enddo; enddo! ix, iy +a=b +end subroutine rbeta2t +!============================================================================= +subroutine rbeta3T(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. +!============================================================================= +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)*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**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 +!============================================================================= +subroutine rbeta4T(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. +!============================================================================= +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)*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**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 + + +!============================================================================= +subroutine vrbeta4t(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. +!============================================================================= +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)*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**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: +!============================================================================= +subroutine vrbeta1(nv,hx,lx,mx, el,ss, a) ! [rbeta] +!============================================================================= +! Vector version of rbeta1 filtering nv fields at once. +!============================================================================= +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)*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**p + tb=tb+frow*a(:,jx) + enddo + b(:,ix)=tb +enddo +a=b +end subroutine vrbeta1 + +!============================================================================= +subroutine vrbeta2(nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] +!============================================================================= +! Vector version of rbeta2 filtering nv fields at once. +!============================================================================= +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)*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**p + tb=tb+frow*a(:,jx,jy) + enddo! gx + enddo! gy + b(:,ix,iy)=tb +enddo; enddo! ix, iy +a=b +end subroutine vrbeta2 + +subroutine vrbeta3(nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] +!============================================================================= +! Vector version of rbeta3 filtering nv fields at once. +!============================================================================= +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)*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**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: +!============================================================================= +subroutine vrbeta1T(nv, hx,lx,mx, el,ss, a) ! [rbetat] +!============================================================================= +! Vector version of rbeta1t filtering nv fields at once. +!============================================================================= +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)*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**p + b(:,jx)=b(:,jx)+frow*ta + enddo +enddo +a=b +end subroutine vrbeta1t +!============================================================================= +subroutine vrbeta2T(nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] +!============================================================================= +! Vector version of rbeta2t filtering nv fields at once. +!============================================================================= +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)*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**p + b(:,jx,jy)=b(:,jx,jy)+frow*ta + enddo! gx + enddo! gy +enddo; enddo ! ix, iy +a=b +end subroutine vrbeta2t + +!============================================================================= +subroutine vrbeta3T(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] +!============================================================================= +! Vector version of rbeta3t filtering nv fields at once. +!============================================================================= +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)*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**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 module jp_pbfil + diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 new file mode 100644 index 000000000..1724ce48c --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 @@ -0,0 +1,1165 @@ +!# +! ********************************** +! * module pbfil2 * +! * R. J. Purser * +! * NOAA/NCEP/EMC * +! * August 2019 * +! ********************************** +! Direct dependencies: +! Module: jp_pkind +! +!============================================================================= +module jp_pbfil2 +!============================================================================= +! Module of data defining the exact transition rules of the decad algorithm +! based on the PG(3,2) reference geometry. An overview of this topic is given +! NOAA/NCEP Office Note 500. +!============================================================================= +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/saber/mgbf/mgbf_lib/jp_pbfil3.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 new file mode 100644 index 000000000..047638f50 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 @@ -0,0 +1,2588 @@ +!# +! ********************************* +! * module jp_pbfil3 * +! * R. J. Purser * +! * NOAA/NCEP/EMC * +! * August 2021 * +! * jim.purser@noaa.gov * +! ********************************* +! +! Codes for the beta line filters. +! +! +! Direct dependencies: +! Libraries: jp_pmat +! Modules: jp_pkind, jp_pkind2, jp_pietc, jp_pmat4, jp_pbfil2 +! +! +!============================================================================= +module jp_pbfil3 +!============================================================================= +! 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 +!# +!============================================================================= +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/saber/mgbf/mgbf_lib/jp_pietc.f90 b/src/saber/mgbf/mgbf_lib/jp_pietc.f90 new file mode 100755 index 000000000..51ad5ae09 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/jp_pietc.f90 @@ -0,0 +1,96 @@ +! +!============================================================================= +module jp_pietc +!============================================================================= +! R. J. Purser (jim.purser@noaa.gov) 2014 +! Some of the commonly used constants (pi etc) mainly for double-precision +! subroutines. +! 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. +!============================================================================= +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/saber/mgbf/mgbf_lib/jp_pietc_s.f90 b/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 new file mode 100644 index 000000000..d445eafd0 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 @@ -0,0 +1,101 @@ +! +!============================================================================= +module jp_pietc_s +!============================================================================= +! R. J. Purser (jim.purser@noaa.gov) +! 2014 +! Some of the commonly used constants (pi etc) +! 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. +!============================================================================= +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/saber/mgbf/mgbf_lib/jp_pkind.f90 b/src/saber/mgbf/mgbf_lib/jp_pkind.f90 new file mode 100755 index 000000000..7e602c17a --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/jp_pkind.f90 @@ -0,0 +1,14 @@ +module jp_pkind +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/saber/mgbf/mgbf_lib/jp_pkind2.f90 b/src/saber/mgbf/mgbf_lib/jp_pkind2.f90 new file mode 100644 index 000000000..e35545a1a --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/jp_pkind2.f90 @@ -0,0 +1,7 @@ +!=================================================================== +module jp_pkind2 ! Integer kinds for helf- and fourth-precision integers +!=================================================================== +use mpi +integer,parameter:: hpi=selected_int_kind(3),& + fpi=selected_int_kind(2) +end module jp_pkind2 diff --git a/src/saber/mgbf/mgbf_lib/jp_pmat.f90 b/src/saber/mgbf/mgbf_lib/jp_pmat.f90 new file mode 100755 index 000000000..504cab0da --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/jp_pmat.f90 @@ -0,0 +1,1083 @@ +! +! ********************************************** +! * MODULE jp_pmat * +! * R. J. Purser, NOAA/NCEP/EMC 1993 * +! * and Tsukasa Fujita, visiting scientist * +! * from JMA. * +! * Major modifications: 2002, 2009, 2012 * +! * jim.purser@noaa.gov * +! * * +! ********************************************** +! +! Utility routines for various linear inversions and Cholesky. +! Dependency: modules jp_pkind, jp_pietc +! 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. +! +! DIRECT DEPENDENCIES: +! Modules: jp_pkind, jp_pietc +! +!============================================================================= +module jp_pmat +!============================================================================= +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/saber/mgbf/mgbf_lib/jp_pmat4.f90 b/src/saber/mgbf/mgbf_lib/jp_pmat4.f90 new file mode 100644 index 000000000..713ca6108 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/jp_pmat4.f90 @@ -0,0 +1,2060 @@ +! +! ********************************************** +! * MODULE jp_pmat4 * +! * R. J. Purser, NOAA/NCEP/EMC Oct 2005 * +! * 18th May 2012 * +! * jim.purser@noaa.gov * +! * * +! ********************************************** +! +! Euclidean geometry, geometric (stereographic) projections, +! related transformations (Mobius). +! 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. +! +! May 2017: 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. +! +! FUNCTION: +! 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 +! SUBROUTINE: +! 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. +! +! DIRECT DEPENDENCIES +! Libraries[their Modules]: jp_pmat[pmat] +! Additional Modules : pkind, jp_pietc, jp_pietc_s +! +!============================================================================ +module jp_pmat4 +!============================================================================ +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,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,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,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,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,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,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,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,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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!**********************************************************************! +(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mg_domain, only: Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e & + ,Flwest,Fleast,Flsouth,Flnorth + +!cltuse mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max +real(r_kind),dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +!----------------------------------------------------------------------- + +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 +!----------------------------------------------------------------------- +! +! 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(g) + else + imax = im ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax(g) + else + jmax = jm + endif + + +!----------------------------------------------------------------------- + ndatay = km*imax*nby + ndatax = km*(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,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,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,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,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,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,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,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,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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!*********************************************************************** +(W,km,im,jm,nbx,nby) +!----------------------------------------------------------------------- +use mg_domain, only: Flwest,Fleast,Flsouth,Flnorth & + ,Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,nbx,nby +real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+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 +!----------------------------------------------------------------------- +! +! 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 =km*(jmax+2*nby)*nbx + ndatay =km*imax*nby + +! +! SEND extended halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km,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_world, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km,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_world, 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,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_world, 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,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_world, 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,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_world, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km,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_world, 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,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_world, 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,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_world, 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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!*********************************************************************** +(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mg_domain, only: Flwest,Fleast,Flsouth,Flnorth & + ,Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max +real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +!----------------------------------------------------------------------- + +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 +!----------------------------------------------------------------------- +! +! 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(g) + else + imax = im ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax(g) + else + jmax = jm + endif + + +!---------------------------------------------------------------------- + ndatax =km*(jmax+2*nby)*nbx + ndatay =km*imax*nby + +! +! SEND extended halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km,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,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,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,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,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,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,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,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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!**********************************************************************! +(W,km3,im,jm,Lm,nbx,nby,nbz,Fimax,Fjmax) +!----------------------------------------------------------------------- +use mg_domain, only: Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e & + ,Flwest,Fleast,Flsouth,Flnorth + +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km3,im,jm,Lm,nbx,nby,nbz +real(r_kind),dimension(km3,1-nbx:im+nbx,1-nby:jm+nby,1-nbz:Lm+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +!----------------------------------------------------------------------- + +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 +!----------------------------------------------------------------------- +! +! 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 + jmax = jm + +!----------------------------------------------------------------------- + ndatay = km3*imax*nby*Lm + ndatax = km3*(jmax+2*nby)*nbx*Lm + + +! +! SEND boundaries toward SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km3,1:imax,nby,1:Lm), stat = iaerr ) + + do L=1,Lm + 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,1:imax,nby,1:Lm), stat = iaerr ) + + do L=1,Lm + 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,1:imax,nby,1:Lm), 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,1:imax,nby,1:Lm), 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 + 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 + 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 + 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 + 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,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + + do L=1,Lm + 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,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + + do L=1,Lm + 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,nbx,1-nby:jmax+nby,1:Lm), 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,nbx,1-nby:jmax+nby,1:Lm), 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 + 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 + 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 + 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 + 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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!**********************************************************************! +(W,km3,im,jm,Lm,nbx,nby,nbz,Fimax,Fjmax,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mg_domain, only: Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e & + ,Flwest,Fleast,Flsouth,Flnorth + +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km3,im,jm,Lm,nbx,nby,nbz,mygen_min,mygen_max +real(r_kind),dimension(km3,1-nbx:im+nbx,1-nby:jm+nby,1-nbz:Lm+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +!----------------------------------------------------------------------- + +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 +!----------------------------------------------------------------------- +! +! 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(g) + else + imax = im ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax(g) + else + jmax = jm + endif + + +!----------------------------------------------------------------------- + ndatay = km3*imax*nby*Lm + ndatax = km3*(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,1:imax,nby,1:Lm), stat = iaerr ) + + do L=1,Lm + 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,1:imax,nby,1:Lm), stat = iaerr ) + + do L=1,Lm + 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,1:imax,nby,1:Lm), 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,1:imax,nby,1:Lm), 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 + 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 + 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 + 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 + 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,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + + do L=1,Lm + 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,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + + do L=1,Lm + 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,nbx,1-nby:jmax+nby,1:Lm), 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,nbx,1-nby:jmax+nby,1:Lm), 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 + 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 + 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 + 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 + 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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! * +!*********************************************************************** +(W,km3,im,jm,Lm,nbx,nby,nbz,Fimax,Fjmax) +!----------------------------------------------------------------------- +use mg_domain, only: Flwest,Fleast,Flsouth,Flnorth & + ,Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km3,im,jm,Lm,nbx,nby,nbz +real(r_kind), dimension(km3,1-nbx:im+nbx,1-nby:jm+nby,1-nbz:Lm+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +!----------------------------------------------------------------------- + +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 +!----------------------------------------------------------------------- +! +! 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*(jmax+2*nby)*nbx *Lm + ndatay =km3*imax*nby *Lm + +! +! SEND extended halos toward WEST and EAST +! +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km3,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + + do L=Lm,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_world, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km3,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + + do L=Lm,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_world, 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,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_world, 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,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_world, 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 + 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 + 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 + 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 + 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,1:imax,1:nby,1:Lm), stat = iaerr ) + + do L=Lm,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_world, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km3,1:imax,1:nby,1:Lm), stat = iaerr ) + + do L=Lm,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_world, 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,1:imax,1:nby,1:Lm), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_world, 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,1:imax,1:nby,1:Lm), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_world, 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 + 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 + 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 + 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 + 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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! * +!*********************************************************************** +(W,km,im,jm,Lm,nbx,nby,nbz,Fimax,Fjmax,mygen_min,mygen_max) + +!----------------------------------------------------------------------- +use mg_domain, only: Flwest,Fleast,Flsouth,Flnorth & + ,Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e +!cl use mpi +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,Lm,nbx,nby,nbz,mygen_min,mygen_max +real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+nby,1-nbz:Lm+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +!----------------------------------------------------------------------- + +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 +!----------------------------------------------------------------------- +! +! 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(g) + else + imax = im ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax(g) + else + jmax = jm + endif + + +!---------------------------------------------------------------------- + ndatax =km*(jmax+2*nby)*nbx *Lm + ndatay =km*imax*nby *Lm + +! +! SEND extended halos toward WEST and EAST +! +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + + do L=Lm,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,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + + do L=Lm,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,1:nbx,1-nby:jmax+nby,1:Lm), 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,1:nbx,1-nby:jmax+nby,1:Lm), 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 + 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 + 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 + 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 + 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,1:imax,1:nby,1:Lm), stat = iaerr ) + + do L=Lm,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,1:imax,1:nby,1:Lm), stat = iaerr ) + + do L=Lm,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,1:imax,1:nby,1:Lm), 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,1:imax,1:nby,1:Lm), 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 + 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 + 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 + 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 + 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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine upsend_all_g1 & +!*********************************************************************** +! ! +! Upsend data from generation one to generation two ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(Harray,Warray,Lm_all) +!----------------------------------------------------------------------- +use mg_parameter, only: im,jm,imL,jmL,hx,hy +use mg_domain, only: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne & + ,Fitarg_up & + ,itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- + +integer(i_kind), intent(in):: Lm_all +real(r_kind), dimension(lm_all,1:imL,1:jmL),intent(in):: Harray +real(r_kind), dimension(lm_all,1-hx:im+hx,1-hy:jm+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:lm_all,1:imL,1:jmL):: dBuf_SW +real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_SE +real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_NW +real(r_kind),dimension(1:lm_all,1:imL,1: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 + +!----------------------------------------------------------------------- + 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 =lm_all*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:lm_all,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:lm_all,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:lm_all,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:lm_all,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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine upsend_all_gh & +!*********************************************************************** +! * +! Upsend data from one grid generation to another * +! (Just for high grid generations) * +! ! +! - offset version - ! +! * +!*********************************************************************** +(Harray,Warray,Lm_all,mygen_dn,mygen_up) +!----------------------------------------------------------------------- +use mg_parameter, only: im,jm,imL,jmL,hx,hy +use mg_domain, only: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne & + ,Fitarg_up & + ,itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- + +integer(i_kind), intent(in):: Lm_all +real(r_kind), dimension(lm_all,1:imL,1:jmL),intent(in):: Harray +real(r_kind), dimension(lm_all,1-hx:im+hx,1-hy:jm+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:lm_all,1:imL,1:jmL):: dBuf_SW +real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_SE +real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_NW +real(r_kind),dimension(1:lm_all,1:imL,1: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 + +!----------------------------------------------------------------------- +! +! 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 =lm_all*imL*jmL +!TEST +! if(mype==0) then +! write(0,*) 'From upsend_all_gh.f90: ndata=',ndata +! endif +!TEST + + + if( lsendup_sw ) then + + nebpe = itarg_up + + + allocate( sBuf_SW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = Harray(:,i,j) + enddo + enddo +!TEST +! write(0,*) 'UPSEND_ALL_GH SW: ndata,mype,nepbe=',ndata,mype,nebpe +!TEST + + 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:lm_all,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 +!TEST +! call finishMPI +!TEST + + +! +! --- Send data to SE portion of processors at higher generation +! + + if( lsendup_se ) then + nebpe = itarg_up + + + allocate( sBuf_SE(1:lm_all,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:lm_all,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:lm_all,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:lm_all,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:lm_all,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = Harray(:,i,j) + enddo + enddo +!TEST +! write(0,*) 'UPSEND_ALL_GH NE: ndata,mype,nepbe,mygen_up',ndata,mype,nebpe,mygen_up +!TEST + + 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:lm_all,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 + +!TEST +! call finishMPI +!TEST + +!----------------------------------------------------------------------- + endsubroutine upsend_all_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! * +!*********************************************************************** +(Warray,Harray,lm_all,mygen_up,mygen_dn) +!----------------------------------------------------------------------- +use mg_parameter, only: im,jm,imL,jmL,hx,hy +use mg_domain, only: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne & + ,Fitarg_up & + ,itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw +!clt use mpi + +implicit none +!----------------------------------------------------------------------- + +integer(i_kind), intent(in):: lm_all +real(r_kind), dimension(lm_all,1:im,1:jm),intent(in):: Warray +real(r_kind), dimension(lm_all,1:imL,1: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:lm_all,1:imL,1:jmL):: dBuf_SW +real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_SE +real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_NW +real(r_kind),dimension(1:lm_all,1:imL,1: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 +!----------------------------------------------------------------------- + + 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 =lm_all*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:lm_all,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:lm_all,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:lm_all,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:lm_all,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:lm_all,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:lm_all,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:lm_all,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:lm_all,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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - * +! * +!*********************************************************************** +(Warray,Harray,lm_all) +!----------------------------------------------------------------------- +use mg_parameter, only: im,jm,imL,jmL,hx,hy +use mg_domain, only: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne & + ,Fitarg_up & + ,itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw +!clt use mpi + +implicit none +!----------------------------------------------------------------------- + +integer(i_kind), intent(in):: lm_all +real(r_kind), dimension(lm_all,1:im,1:jm),intent(in):: Warray +real(r_kind), dimension(lm_all,1:imL,1:jmL),intent(out):: Harray +!----------------------------------------------------------------------- + +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE + +real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_SW +real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_SE +real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_NW +real(r_kind),dimension(1:lm_all,1:imL,1: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 +!----------------------------------------------------------------------- +! +! 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 =lm_all*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:lm_all,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:lm_all,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:lm_all,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:lm_all,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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!**********************************************************************! +(W,km,im,jm,nbx,nby) +!----------------------------------------------------------------------- +use mg_domain, only: Fitarg_w,Fitarg_e,Flwest,Fleast + +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,nbx,nby +real(r_kind),dimension(km,1-nbx:im+nbx,1-nby:jm+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 +!----------------------------------------------------------------------- +! +! 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 + jmax = jm + + +!----------------------------------------------------------------------- + ndatax = km*jmax*nbx + +!---------------------------------------------------------------------- +! +! SEND extended boundaries toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km,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,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,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,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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!**********************************************************************! +(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mg_domain, only: Fitarg_w,Fitarg_e,Flwest,Fleast,Flsouth,Flnorth + +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max +real(r_kind),dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +!----------------------------------------------------------------------- + +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 +!----------------------------------------------------------------------- +! +! 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(g) + else + imax = im ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax(g) + else + jmax = jm + endif + + +!----------------------------------------------------------------------- + ndatax = km*jmax*nbx + +! +! SEND halos to WEST and EASTH +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km,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,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,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,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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!**********************************************************************! +(W,km,im,jm,nbx,nby) +!----------------------------------------------------------------------- +use mg_domain, only: Fitarg_n,Fitarg_s,Flsouth,Flnorth + +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,nbx,nby +real(r_kind),dimension(km,1-nbx:im+nbx,1-nby:jm+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 +!----------------------------------------------------------------------- +! +! 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 + jmax = jm + + +!----------------------------------------------------------------------- + ndatay = km*imax*nby + + +! +! SEND boundaries toward SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km,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,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,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,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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!**********************************************************************! +(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mg_domain, only: Fitarg_n,Fitarg_s,Flwest,Fleast,Flsouth,Flnorth + +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max +real(r_kind),dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +!----------------------------------------------------------------------- + +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 +!----------------------------------------------------------------------- +! +! 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(g) + else + imax = im ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax(g) + else + jmax = jm + endif + + +!----------------------------------------------------------------------- + ndatay = km*imax*nby + +! +! SEND boundaries to SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km,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,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,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,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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!*********************************************************************** +(W,km,im,jm,nbx,nby) +!----------------------------------------------------------------------- +use mg_domain, only: Flwest,Fleast,Fitarg_w,Fitarg_e +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,nbx,nby +real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+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 +!----------------------------------------------------------------------- +! +! 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 + jmax = jm + + +!---------------------------------------------------------------------- + ndatax =km*jmax*nbx + +! +! SEND halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km,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_world, sHandle(1), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km,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_world, 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,1:nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_world, 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,1:nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_world, 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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!*********************************************************************** +(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mg_domain, only: Flwest,Fleast,Flnorth,Fitarg_w,Fitarg_e +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max +real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +!----------------------------------------------------------------------- + +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 +!----------------------------------------------------------------------- +! +! 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(g) + else + imax = im ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax(g) + else + jmax = jm + endif + + +!---------------------------------------------------------------------- + ndatax =km*jmax*nbx +! +! SEND halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km,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,0:nbx,0: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,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,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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!*********************************************************************** +(W,km,im,jm,nbx,nby) +!----------------------------------------------------------------------- +use mg_domain, only: Flsouth,Flnorth,Fitarg_n,Fitarg_s +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,nbx,nby +real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+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 +!----------------------------------------------------------------------- +! +! 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 + jmax = jm + + +!---------------------------------------------------------------------- + ndatay =km*imax*nby + +! +! SEND SOUTH and NORTH halos +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km,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_world, sHandle(1), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km,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_world, 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,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_world, 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,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_world, 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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 - ! +! ! +!*********************************************************************** +(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mg_domain, only: Fleast,Flsouth,Flnorth & + ,Fitarg_n,Fitarg_s +!clt use mpi + +implicit none + +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max +real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +!----------------------------------------------------------------------- + +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 +!----------------------------------------------------------------------- +! +! 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(g) + else + imax = im ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax(g) + else + jmax = jm + endif + + +!---------------------------------------------------------------------- + + ndatay =km*imax*nby +! +! SEND halos toward SOUTH and NORTH +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km,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,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,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,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 + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + endmodule mg_bocos diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 new file mode 100644 index 000000000..68f9e169b --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -0,0 +1,1404 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_filtering +!*********************************************************************** +! ! +! Contains all multigrid filtering prodecures ! +! ! +! M. Rancic (2020) ! +!*********************************************************************** +use mpi +use kinds, only: r_kind,i_kind +use mg_parameter, only: im,jm,hx,hy,hz,km2,km3,lm,gm,Fimax,Fjmax +use mg_parameter, only: i0,j0,km +use mg_parameter, only: mgbf_line,lquart +!use mpimod, only: mype,ierror +use mg_mppstuff, only: mype,ierror +use mg_mppstuff, only: l_hgen,my_hgen,finishMPI,barrierMPI +use mg_generations, only: upsending_all,downsending_all,differencing_all +use mg_generations, only: upsending2_all,downsending2_all +use mg_transfer, only: stack_to_composite,composite_to_stack +use mg_bocos, only: boco_2d,bocoT_2d +use mg_bocos, only: boco_3d, bocoT_3d +use mg_bocos, only: bocox,bocoy +use mg_bocos, only: bocoTx,bocoTy +use jp_pbfil, only: rbeta,rbetaT +use jp_pbfil3, only: dibetat,dibeta +#if 0 +use mg_output +#endif + + +public mg_filtering_procedure + +private mg_filtering_rad1 +private mg_filtering_rad2 +private mg_filtering_rad3 +private mg_filtering_lin1 +private mg_filtering_lin2 +private mg_filtering_lin3 +private mg_filtering_fast + +private sup_vrbeta1 +private sup_vrbeta1T +private sup_vrbeta3 +private sup_vrbeta3T + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine mg_filtering_procedure(mg_filt) +!*********************************************************************** +! ! +! Driver for Multigrid filtering procedures with Helmholtz operator ! +! ! +! 1, 2, 3: Radial filter ! +! 1: 2d radial filter for all variables ! +! -> 2: 2d radial filter with 1d in vertical for 3d variables ! +! 3: 3d radial filter for 3d variables ! +! ! +! 4, 5, 6: Line filter ! +! 4: 2d line filter for all variables ! +! 5: 2d line filter with 1d in vertical for 3d variables ! +! 6: 3d line filter for 3d variables ! +! ! +! ! +!*********************************************************************** +implicit none + +integer(i_kind),intent(in):: mg_filt +!----------------------------------------------------------------------- + if(mgbf_line) then + if(mg_filt<4) then + print*,'("Line filters have options 4-6")' + stop + endif + else + if(mg_filt>3) then + print*,'("Radial filters have options 1-3")' + stop + endif + endif + select case(mg_filt) + case(1) + call mg_filtering_rad1 + case(2) + call mg_filtering_rad2 + case(3) + call mg_filtering_rad3 + case(4) + call mg_filtering_lin1 + case(5) + call mg_filtering_lin2 + case(6) + call mg_filtering_lin3 + case default + call mg_filtering_fast + end select + +!----------------------------------------------------------------------- + endsubroutine mg_filtering_procedure + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine mg_filtering_rad1 +!*********************************************************************** +! ! +! Multigrid filtering procedure 1: ! +! ! +! - Multiple of 2D and 3D variables ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 2d radial filter only for all variables ! +! ! +!*********************************************************************** +use mg_intstate, only: pasp2,ss2 +use mg_intstate, only: VALL,HALL +implicit none + +integer(i_kind) L,i,j,g +!----------------------------------------------------------------------- + + +!==================== Adjoint (Conservative step) ====================== + +!*** +!*** Adjoint interpolate and upsend (Step 1) +!*** + +! call upsending2_all(VALL,HALL) + call upsending_all(VALL,HALL) +!---------------------------------------------------------------------- + + +!---------------------------------------------------------------------- + +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + call rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) + if(l_hgen) then + call rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + + call bocoT_2d(VALL,km,im,jm,hx,hy) + call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + + +!*** +!*** Apply (a-b\nabla^2) +!*** + + + call differencing_all(VALL,HALL) + + + + +!*** +!*** Apply Beta filter at all generations +!*** + + + call boco_2d(VALL,km,im,jm,hx,hy) + call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Filtering +! + + call rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) + if(l_hgen) then + call rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + +! call downsending2_all(HALL,VALL) + call downsending_all(HALL,VALL) + + + +!----------------------------------------------------------------------- + endsubroutine mg_filtering_rad1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine mg_filtering_rad2 +!*********************************************************************** +! ! +! Multigrid filtering procedure 2: ! +! ! +! - Multiple of 2D and 3D variables ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 2d radial filter + 1d vertical filter ! +! ! +!*********************************************************************** +use mg_intstate, only: pasp1,pasp2,ss1,ss2 +use mg_intstate, only: VALL,HALL +implicit none + +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 +!----------------------------------------------------------------------- + +allocate(VM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. +allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. +allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. +allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. + + + +!==================== Adjoint (Conservative step) ====================== + +!*** +!*** Adjoint interpolate and upsend +!*** + + if(lquart) then + call upsending2_all(VALL,HALL) + else + call upsending_all(VALL,HALL) + endif +!---------------------------------------------------------------------- + + +!---------------------------------------------------------------------- + +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + call rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) + call stack_to_composite(VALL,VM2D,VM3D) + + if(l_hgen) then + call rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + call stack_to_composite(HALL,HM2D,HM3D) + endif + + call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call composite_to_stack(HM2D,HM3D,HALL) + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + + call bocoT_2d(VALL,km,im,jm,hx,hy) + call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + + +!*** +!*** Apply (a-b\nabla^2) +!*** + + + call differencing_all(VALL,HALL) + + + + +!*** +!*** Apply Beta filter at all generations (Step 7) +!*** + + call boco_2d(VALL,km,im,jm,hx,hy) + call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Filtering +! + + call rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) + call stack_to_composite(VALL,VM2D,VM3D) + if(l_hgen) then + call rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + call stack_to_composite(HALL,HM2D,HM3D) + endif + + call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call composite_to_stack(HM2D,HM3D,HALL) + endif + call barrierMPI + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + +!*** +!*** Downsend, interpolate and add (Step 4) +!*** Then zero high generations (Step 5) +!*** + + if(lquart) then + call downsending2_all(HALL,VALL) + else + call downsending_all(HALL,VALL) + endif + + +deallocate(VM3D) +deallocate(VM2D) +deallocate(HM3D) +deallocate(HM2D) + +!----------------------------------------------------------------------- + endsubroutine mg_filtering_rad2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine mg_filtering_rad3 +!*********************************************************************** +! ! +! Multigrid filtering procedure 2: ! +! ! +! - Multiple of 2D and 3D variables ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 3d radial filter +! ! +!*********************************************************************** +!----------------------------------------------------------------------- +use mg_intstate, only: pasp2,pasp3,ss2,ss3 +use mg_intstate, only: VALL,HALL +implicit none + + +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 + +!---------------------------------------------------------------------- +allocate(VM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. +allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. +allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. +allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. + +!==================== Adjoint (Conservative step) ====================== + +!*** +!*** Adjoint interpolate and upsend +!*** + +! call upsending2_all(VALL,HALL) + call upsending_all(VALL,HALL) + + +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Adjoint filtering +! + call stack_to_composite(VALL,VM2D,VM3D) + call rbetaT(km2,hx,i0,im,hy,j0,jm,pasp2,ss2,VM2D) + call sup_vrbeta3T(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,VM3D) + call composite_to_stack(VM2D,VM3D,VALL) + + if(l_hgen) then + call stack_to_composite(HALL,HM2D,HM3D) + call rbetaT(km2,hx,i0,im,hy,j0,jm,pasp2,ss2,HM2D) + call sup_vrbeta3T(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,HM3D) + call composite_to_stack(HM2D,HM3D,HALL) + endif + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + call bocoT_2d(VALL,km,im,jm,hx,hy) + call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + + +!*** +!*** Apply (a-b\nabla^2) +!*** + + + call differencing_all(VALL,HALL) + + + +!*** +!*** Apply Beta filter at all generations +!*** + + + call boco_2d(VALL,km,im,jm,hx,hy) + call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Filtering +! + call stack_to_composite(VALL,VM2D,VM3D) + call rbeta(km2,hx,i0,im,hy,j0,jm,pasp2,ss2,VM2D(:,:,:)) + call sup_vrbeta3(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,VM3D) + call composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + call stack_to_composite(HALL,HM2D,HM3D) + call rbeta(km2,hx,i0,im,hy,j0,jm,pasp2,ss2,HM2D(:,:,:)) + call sup_vrbeta3(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,HM3D) + call composite_to_stack(HM2D,HM3D,HALL) + endif + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + +!*** +!*** Downsend, interpolate and add +!*** Then zero high generations +!*** + + +! call downsending2_all(HALL,VALL) + call downsending_all(HALL,VALL) + +deallocate(VM3D) +deallocate(VM2D) +deallocate(HM3D) +deallocate(HM2D) + + +!----------------------------------------------------------------------- + endsubroutine mg_filtering_rad3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine mg_filtering_lin1 +!*********************************************************************** +! ! +! Multigrid filtering procedure 4: ! +! ! +! - Multiple of 2D line filter ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 2d line filter only for all variables ! +! ! +!*********************************************************************** +use mg_parameter, only: nfil +use mg_intstate, only: dixs,diys,hss2 +use mg_intstate, only: VALL,HALL +implicit none + +integer(i_kind) L,i,j +integer(i_kind) icol,iout,jout +logical:: ff +!----------------------------------------------------------------------- + + +!==================== Adjoint (Conservative step) ====================== + +!*** +!*** Adjoint interpolate and upsend (Step 1) +!*** + +! call upsending2_all(VALL,HALL) + call upsending_all(VALL,HALL) +!---------------------------------------------------------------------- + + +!---------------------------------------------------------------------- + +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + do icol=3,1,-1 + call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) + + call bocoT_2d(VALL,km,im,jm,hx,hy) + enddo + + do icol=3,1,-1 + if(l_hgen) then + call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) + endif + + + call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + enddo + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!*** +!*** Apply (a-b\nabla^2) +!*** + + + call differencing_all(VALL,HALL) + + + + +!*** +!*** Apply Beta filter at all generations +!*** + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Filtering +! + do icol=1,3 + call boco_2d(VALL,km,im,jm,hx,hy) + call dibeta(km,i0-hx,0,im,im+hx, j0-hy,0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) + enddo + + do icol=1,3 + call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + if(l_hgen) then + call dibeta(km,i0-hx,0,im,im+hx, j0-hy,0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) + endif + enddo + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + +! call downsending2_all(HALL,VALL) + call downsending_all(HALL,VALL) + + + +!----------------------------------------------------------------------- + endsubroutine mg_filtering_lin1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine mg_filtering_lin2 +!*********************************************************************** +! ! +! Multigrid filtering procedure 5: ! +! ! +! - Multiple of 2D line filter ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 2d radial filter + 1d vertical filter +! ! +!*********************************************************************** +use mg_parameter, only: nfil +use mg_intstate, only: dixs,diys,hss2 +use mg_intstate, only: VALL,HALL +use mg_intstate, only: pasp1,ss1 +implicit none + +integer(i_kind) L,i,j +integer(i_kind) icol,iout,jout +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 + +!---------------------------------------------------------------------- + +allocate(VM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. +allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. +allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. +allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. + + +!----------------------------------------------------------------------- + + +!==================== Adjoint (Conservative step) ====================== + +!*** +!*** Adjoint interpolate and upsend (Step 1) +!*** + +! call upsending2_all(VALL,HALL) + call upsending_all(VALL,HALL) +!---------------------------------------------------------------------- + + +!---------------------------------------------------------------------- + +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Horizontal +! + + do icol=3,1,-1 + call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) + call bocoT_2d(VALL,km,im,jm,hx,hy) + enddo + + do icol=3,1,-1 + if(l_hgen) then + call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) + endif + call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + enddo +! +! Vertical +! + + call stack_to_composite(VALL,VM2D,VM3D) + call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call composite_to_stack(VM2D,VM3D,VALL) + + if(l_hgen) then + call stack_to_composite(HALL,HM2D,HM3D) + call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call composite_to_stack(HM2D,HM3D,HALL) + endif + + call bocoT_2d(VALL,km,im,jm,hx,hy) + call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!*** +!*** Apply (a-b\nabla^2) +!*** + + + call differencing_all(VALL,HALL) + + + + +!*** +!*** Apply Beta filter at all generations +!*** + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Horizontal +! + do icol=1,3 + call boco_2d(VALL,km,im,jm,hx,hy) + call dibeta(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) + enddo + + do icol=1,3 + call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + if(l_hgen) then + call dibeta(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) + endif + enddo +! +! Vertical +! + + call boco_2d(VALL,km,im,jm,hx,hy) + call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + + + call stack_to_composite(VALL,VM2D,VM3D) + call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call composite_to_stack(VM2D,VM3D,VALL) + + if(l_hgen) then + call stack_to_composite(HALL,HM2D,HM3D) + call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call composite_to_stack(HM2D,HM3D,HALL) + endif + + + call barrierMPI +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + + +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + +! call downsending2_all(HALL,VALL) + call downsending_all(HALL,VALL) + + + +deallocate(VM3D) +deallocate(VM2D) +deallocate(HM3D) +deallocate(HM2D) + + +!----------------------------------------------------------------------- + endsubroutine mg_filtering_lin2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine mg_filtering_lin3 +!*********************************************************************** +! ! +! Multigrid filtering procedure 6: ! +! ! +! - Multiple of 2D line filter ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 3d line filter +! ! +!*********************************************************************** +!TEST +use, intrinsic :: ieee_arithmetic +!TEST +use mg_parameter, only: nfil +use mg_intstate, only: dixs,diys,dizs,hss2,vpasp3 +use mg_intstate, only: qcols,dixs3,diys3,dizs3 +use mg_intstate, only: VALL,HALL +use jp_pkind2, only: fpi +implicit none + +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 + + +allocate(VM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. +allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. +allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. +allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. + +allocate(W(km3,i0-hx:im+hx,j0-hy:jm+hy,1-hz:lm+hz)) ; W=0. +allocate(H(km3,i0-hx:im+hx,j0-hy:jm+hy,1-hz:lm+hz)) ; H=0. + +allocate(JCOL(0:im,0:jm,1:Lm)) ; JCOL=0 + +!----------------------------------------------------------------------- + + +!==================== Adjoint (Conservative step) ====================== + +!*** +!*** Adjoint interpolate and upsend +!*** + +! call upsending2_all(VALL,HALL) + call upsending_all(VALL,HALL) +!---------------------------------------------------------------------- + + +!---------------------------------------------------------------------- + +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + +! +! From single stack to composite variables +! + + call stack_to_composite(VALL,VM2D,VM3D) + if(l_hgen) then + call stack_to_composite(HALL,HM2D,HM3D) + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Apply adjoint filter to 2D variables first +! + + do icol=3,1,-1 + call dibetat(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout) + call bocoT_2d(VM2D,km2,im,jm,hx,hy) + enddo + + do icol=3,1,-1 + if(l_hgen) then + call dibetat(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout) + endif + call bocoT_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) + enddo + +! +! Create and apply adjoint filter to extended 3D variables +! + + W(:,:,:,1:lm)=VM3D(:,:,:,1:lm) + + do icol=7,1,-1 + do L=1,hz + W(:,:,:,1-L )=0. + W(:,:,:,LM+L)=0. + end do + call dibetat(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout) + call bocoT_3d(W,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax) + enddo + + if(l_hgen) then + H(:,:,:,1:lm)=HM3D(:,:,:,1:lm) + endif + + do icol=7,1,-1 + if(l_hgen) then + do L=1,hz + H(:,:,:,1-L )=0. + H(:,:,:,LM+L)=0. + end do + + call dibetat(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout) + endif + call bocoT_3d(H,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax,2,gm) + enddo + + +! +! Go back from extended 3D variables and combine them with 2D variables in one stacked variable +! + + VM3D(:,:,:,1:lm)= W(:,:,:,1:lm) + call composite_to_stack(VM2D,VM3D,VALL) + + if(l_hgen) then + HM3D(:,:,:,1:lm)=H(:,:,:,1:lm) + call composite_to_stack(HM2D,HM3D,HALL) + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!*** +!*** Apply (a-b\nabla^2) +!*** + + + call differencing_all(VALL,HALL) + + + + +!*** +!*** Apply Beta filter at all generations +!*** +! +! From single stacked to composite variables +! + + call stack_to_composite(VALL,VM2D,VM3D) + if(l_hgen) then + call stack_to_composite(HALL,HM2D,HM3D) + endif + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Apply filter to 2D variables first +! + do icol=1,3 + call boco_2d(VM2D,km2,im,jm,hx,hy) + call dibeta(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout) + enddo + + do icol=1,3 + call boco_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) + if(l_hgen) then + call dibeta(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout) + endif + enddo + +! +! Create and apply filter to extended 3D variables +! + + W(:,:,:,1:lm)=VM3D(:,:,:,1:lm) + do L=1,hz + do j=j0-hy,jm+hy + do i=i0-hx,im+hx + W(:,i,j,1-L )=VM3D(:,i,j, 1+L) + W(:,i,j,LM+L)=VM3D(:,i,j,LM-L) + end do + end do + end do + + do icol=1,7 + call boco_3d(W,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax) + call dibeta(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout) + enddo + + if(l_hgen) then + H(:,:,:,1:lm)=HM3D(:,:,:,1:lm) + do L=1,hz + do j=j0-hy,jm+hy + do i=i0-hx,im+hx + H(:,i,j,1-L )=HM3D(:,i,j, 1+L) + H(:,i,j,LM+L)=HM3D(:,i,j,LM-L) + end do + end do + end do + endif + do icol=1,7 + call boco_3d(H,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax,2,gm) + if(l_hgen) then + call dibeta(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout) + endif + enddo + +! +! Go back from extended 3D variables and combine them with 2D variables in one stacked variable +! + + VM3D(:,:,:,1:lm)= W(:,:,:,1:lm) + call composite_to_stack(VM2D,VM3D,VALL) + + if(l_hgen) then + HM3D(:,:,:,1:lm)=H(:,:,:,1:lm) + call composite_to_stack(HM2D,HM3D,HALL) + endif + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + +! call downsending2_all(HALL,VALL) + call downsending_all(HALL,VALL) + + + +!----------------------------------------------------------------------- + +deallocate(VM3D) +deallocate(VM2D) +deallocate(HM3D) +deallocate(HM2D) + +deallocate(W) +deallocate(H) + +deallocate(JCOL) + +!----------------------------------------------------------------------- + endsubroutine mg_filtering_lin3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine mg_filtering_fast +!*********************************************************************** +! ! +! Fast multigrid filtering procedure: ! +! ! +! - Multiple of 2D and 3D variables ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 1d+1d horizontal filter + 1d vertical filter ! +! ! +!*********************************************************************** +use mg_intstate, only: pasp1,paspx,paspy,ss1,ssx,ssy +use mg_intstate, only: VALL,HALL +implicit none + +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 +!----------------------------------------------------------------------- + +allocate(VM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. +allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. +allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. +allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. + + + +!==================== Adjoint (Conservative step) ====================== + +!*** +!*** Adjoint interpolate and upsend +!*** + +! call upsending2_all(VALL,HALL) + call upsending_all(VALL,HALL) +!---------------------------------------------------------------------- + + +!---------------------------------------------------------------------- + +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Horizontally +! + + do j=0,jm + call rbetaT(km,hx,1,im,paspx,ssx,VALL(:,:,j)) + enddo + call bocoTx(VALL,km,im,jm,hx,hy) + + do i=0,im + call rbetaT(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) + enddo + call bocoTy(VALL,km,im,jm,hx,hy) + + call stack_to_composite(VALL,VM2D,VM3D) + + if(l_hgen) then + do j=0,jm + call rbetaT(km,hx,i0,im,paspx,ssx,HALL(:,:,j)) + enddo + endif + call bocoTx(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + + if(l_hgen) then + do i=0,im + call rbetaT(km,hy,j0,jm,paspy,ssy,HALL(:,i,:)) + enddo + endif + call bocoTy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + +! +! Vertically +! + call stack_to_composite(HALL,HM2D,HM3D) + call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call composite_to_stack(HM2D,HM3D,HALL) + endif + + + call barrierMPI +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + +!*** +!*** Apply (a-b\nabla^2) +!*** + + + call differencing_all(VALL,HALL) + + + + +!*** +!*** Apply Beta filter at all generations (Step 7) +!*** + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Filtering +! +! Horizonatally + + call bocox(VALL,km,im,jm,hx,hy) + do j=0,jm + call rbeta(km,hx,i0,im,paspx,ssx,VALL(:,:,j)) + enddo + + call bocoy(VALL,km,im,jm,hx,hy) + do i=0,im + call rbeta(km,hy,j0,jm,paspy,ssy,VALL(:,i,:)) + enddo + + call stack_to_composite(VALL,VM2D,VM3D) + + call bocox(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + if(l_hgen) then + do j=0,jm + call rbeta(km,hx,i0,im,paspx,ssx,HALL(:,:,j)) + enddo + endif + call bocoy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + if(l_hgen) then + do i=0,im + call rbeta(km,hy,j0,jm,paspy,ssy,HALL(:,i,:)) + enddo + endif + if(l_hgen) then + call stack_to_composite(HALL,HM2D,HM3D) + endif + +! +! Vertically +! + + call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call composite_to_stack(HM2D,HM3D,HALL) + endif + + call barrierMPI +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + +!*** +!*** Downsend, interpolate and add (Step 4) +!*** Then zero high generations (Step 5) +!*** + +! call downsending2_all(HALL,VALL) + call downsending_all(HALL,VALL) + + +deallocate(VM3D) +deallocate(VM2D) +deallocate(HM3D) +deallocate(HM2D) + +!----------------------------------------------------------------------- + endsubroutine mg_filtering_fast + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine sup_vrbeta1 & +!********************************************************************** +! * +! conversion of vrbeta1 * +! * +!********************************************************************** +(kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) +!---------------------------------------------------------------------- +implicit none + +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,i0-hx:im+hx,j0-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=j0,jm + do i=i0,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 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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine sup_vrbeta1T & +!********************************************************************** +! * +! conversion of vrbeta1T * +! * +!********************************************************************** +(kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) +!---------------------------------------------------------------------- +implicit none + +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,i0-hx:im+hx,j0-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=j0,jm + do i=i0,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 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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine sup_vrbeta3 & +!********************************************************************** +! * +! conversion of vrbeta3 * +! * +!********************************************************************** +(kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) +!---------------------------------------------------------------------- +implicit none + +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,i0-hx:im+hx,j0-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(3,3,i0:im,j0:jm,1:lm), intent(in):: pasp +real(r_kind),dimension(i0:im,j0:jm,1:lm), intent(in):: ss + +real(r_kind),dimension(1:kmax,i0-hx:im+hx,j0-hy:jm+hy,1-hz:lm+hz):: W + +integer(i_kind):: i,j,L + +!---------------------------------------------------------------------- + + do L=1,Lm + do j=j0-hy,jm+hy + do i=i0-hx,im+hx + W(:,i,j,L)=V(:,i,j,L) + end do + end do + end do + + do L=1,hz + do j=j0-hy,jm+hy + do i=i0-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 rbeta(kmax,hx,i0,im, hy,j0,jm, hz,1,lm, pasp,ss,W) + + + do l=1,Lm + do j=j0,jm + do i=i0,im + V(:,i,j,L)=W(:,i,j,L) + end do + end do + end do + +!---------------------------------------------------------------------- + endsubroutine sup_vrbeta3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine sup_vrbeta3T & +!********************************************************************** +! * +! conversion of vrbeta3 * +! * +!********************************************************************** +(kmax,hx,hy,hz,im,jm,lm, pasp,ss,V) +!---------------------------------------------------------------------- +implicit none + +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,i0-hx:im+hx,j0-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(3,3,i0:im,j0:jm,1:lm), intent(in):: pasp +real(r_kind),dimension(i0:im,j0:jm,1:lm), intent(in):: ss + +real(r_kind),dimension(1:kmax,i0-hx:im+hx,j0-hy:jm+hy,1-hz:lm+hz):: W + +integer(i_kind):: i,j,l + +!---------------------------------------------------------------------- + + do L=1,Lm + do j=j0-hy,jm+hy + do i=i0-hx,im+hx + W(:,i,j,L)=V(:,i,j,L) + end do + end do + end do + + do L=1,hz + do j=j0-hy,jm+hy + do i=i0-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 rbetaT(kmax,hx,i0,im, hy,j0,jm, hz,1,lm, pasp,ss,W) + +! +! Apply adjoint at the edges of domain +! + do L=1,hz + do j=j0-hy,jm+hy + do i=i0-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=j0,jm + do i=i0,im + V(:,i,j,l)=W(:,i,j,l) + end do + end do + end do + +!---------------------------------------------------------------------- + endsubroutine sup_vrbeta3T + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + endmodule mg_filtering diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 new file mode 100644 index 000000000..df8265041 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -0,0 +1,577 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_generations +!*********************************************************************** +! ! +! Contains procedures that include differrent generations ! +! - offset version - +! ! +! M. Rancic (2022) ! +!*********************************************************************** +use mpi +use kinds, only: r_kind,i_kind +use mg_parameter, only: i0,j0,im,jm,imL,jmL,hx,hy,gm +use mg_parameter, only: km,kmh,kmf,Fimax,Fjmax,FimaxL,FjmaxL +!use mpimod, only: mype ! << for GSI >> +use mg_mppstuff, only: mype +use mg_mppstuff, only: my_hgen,l_hgen,barrierMPI,finishMPI,Fimax,Fjmax +use mg_bocos, only: boco_2d,bocoT_2d +use mg_bocos, only: upsend_all,downsend_all +use mg_intstate, only: a_diff_h,b_diff_h +use mg_intstate, only: a_diff_f,b_diff_f +use mg_intstate, only: p_coef,q_coef +use mg_intstate, only: a_coef,b_coef +!TEST +use, intrinsic:: ieee_arithmetic +!TEST + +public upsending_all +public downsending_all + +public upsending2_all +public downsending2_all + +public differencing_all + +private adjoint_all +private direct_all + +private adjoint2_all +private direct2_all + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + contains + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine upsending_all & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(V,H) +!----------------------------------------------------------------------- +implicit none + +real(r_kind),dimension(km,1-hx:im+hx,1-hy:jm+hy),intent(in):: V +real(r_kind),dimension(km,1-hx:im+hx,1-hy:jm+hy),intent(out):: H + +real(r_kind),dimension(km,i0-2:imL+2,j0-2:jmL+2):: V_INT +real(r_kind),dimension(km,i0-2:imL+2,j0-2:jmL+2):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call adjoint_all(V(1:km,1:im,1:jm),V_INT,km,1) + + call bocoT_2d(V_INT,km,imL,jmL,2,2) + + call upsend_all(V_INT(1:km,1:imL,1:jmL),H,km) +! +! From generation 2 sequentially to higher generations +! + do g=2,gm-1 + + if(g==my_hgen) then + call adjoint_all(H(1:km,1:im,1:jm),H_INT,km,g) + endif + + call bocoT_2d(H_INT,km,imL,jmL,2,2,FimaxL,FjmaxL,g,g) + + call upsend_all(H_INT(1:km,1:imL,1:jmL),H,km,g,g+1) + + end do + + +!----------------------------------------------------------------------- + endsubroutine upsending_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine downsending_all & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(H,V) +!----------------------------------------------------------------------- +implicit none + +real(r_kind),dimension(km,i0-hx:im+hx,j0-hy:jm+hy),intent(inout):: H +real(r_kind),dimension(km,i0-hx:im+hx,j0-hy:jm+hy),intent(inout):: V +real(r_kind),dimension(km,i0-2:imL+2,j0-2:jmL+2):: H_INT +real(r_kind),dimension(km,i0-2:imL+2,j0-2:jmL+2):: V_INT +real(r_kind),dimension(km,i0:im,j0:jm):: H_PROX +real(r_kind),dimension(km,i0:im,j0:jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=gm,3,-1 + + call downsend_all(H(1:km,i0:im,j0:jm),H_INT(1:km,1:imL,1:jmL),km,g,g-1) + call boco_2d(H_INT,km,imL,jmL,2,2,FimaxL,FjmaxL,g-1,g-1) + + if(my_hgen==g-1) then + call direct_all(H_INT,H_PROX,km,g-1) + H(1:km,1:im,1:jm)=H (1:km,i0:im,j0:jm) & + +H_PROX(1:km,i0:im,j0:jm) + endif + + enddo + +! +! From geneartion 2 to generation 1 +! + + call downsend_all(H(1:km,i0:im,j0:jm),V_INT(1:km,1:imL,1:jmL),km) + H(:,:,:)=0. + + call boco_2d(V_INT,km,imL,jmL,2,2) + + call direct_all(V_INT,V_PROX,km,1) + + V(1:km,i0:im,j0:jm)=V (1:km,i0:im,j0:jm) & + +V_PROX(1:km,i0:im,j0:jm) + +!----------------------------------------------------------------------- + endsubroutine downsending_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine upsending2_all & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(V,H) +!----------------------------------------------------------------------- +implicit none + +real(r_kind),dimension(km,1-hx:im+hx,1-hy:jm+hy),intent(in):: V +real(r_kind),dimension(km,1-hx:im+hx,1-hy:jm+hy),intent(out):: H + +real(r_kind),dimension(km,0:imL+1,0:jmL+1):: V_INT +real(r_kind),dimension(km,0:imL+1,0:jmL+1):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call adjoint2_all(V(1:km,1:im,1:jm),V_INT,km,1) + + call bocoT_2d(V_INT,km,imL,jmL,1,1) + + call upsend_all(V_INT(1:km,1:imL,1:jmL),H,km) +! +! From generation 2 sequentially to higher generations +! + do g=2,gm-1 + + if(g==my_hgen) then + call adjoint2_all(H(1:km,1:im,1:jm),H_INT,km,g) + endif + + call bocoT_2d(H_INT,km,imL,jmL,1,1,FimaxL,FjmaxL,g,g) + + call upsend_all(H_INT(1:km,1:imL,1:jmL),H,km,g,g+1) + + end do + + +!----------------------------------------------------------------------- + endsubroutine upsending2_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine downsending2_all & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(H,V) +!----------------------------------------------------------------------- +implicit none + +real(r_kind),dimension(km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: H +real(r_kind),dimension(km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: V +real(r_kind),dimension(km,0:imL+1,0:jmL+1):: H_INT +real(r_kind),dimension(km,0:imL+1,0:jmL+1):: V_INT +real(r_kind),dimension(km,1:im,1:jm):: H_PROX +real(r_kind),dimension(km,1:im,1:jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=gm,3,-1 + + call downsend_all(H(1:km,1:im,1:jm),H_INT(1:km,1:imL,1:jmL),km,g,g-1) + call boco_2d(H_INT,km,imL,jmL,1,1,FimaxL,FjmaxL,g-1,g-1) + + if(my_hgen==g-1) then + call direct2_all(H_INT,H_PROX,km,g-1) + H(1:km,1:im,1:jm)=H (1:km,1:im,1:jm) & + +H_PROX(1:km,1:im,1:jm) + endif + + enddo + +! +! From generation 2 to generation 1 +! + + call downsend_all(H(1:km,1:im,1:jm),V_INT(1:km,1:imL,1:jmL),km) + H(:,:,:)=0. + + call boco_2d(V_INT,km,imL,jmL,1,1) + + call direct2_all(V_INT,V_PROX,km,1) + + V(1:km,1:im,1:jm)=V (1:km,1:im,1:jm) & + +V_PROX(1:km,1:im,1:jm) + +!----------------------------------------------------------------------- + endsubroutine downsending2_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine differencing_all & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(V,H) +!----------------------------------------------------------------------- +implicit none + +real(r_kind),dimension(kmf,i0-hx:im+hx,j0-hy:jm+hy),intent(inout):: V +real(r_kind),dimension(kmh,i0-hx:im+hx,j0-hy:jm+hy),intent(inout):: H +real(r_kind),dimension(kmf,i0-1:im, j0 :jm):: DIFX +real(r_kind),dimension(kmf,i0 :im ,j0-1:jm):: DIFY +real(r_kind),dimension(kmh,i0-1:im, 0 :jm):: DIFXH +real(r_kind),dimension(kmh,i0 :im ,j0-1:jm):: DIFYH +integer(i_kind):: i,j,l,k,imx,jmx +!----------------------------------------------------------------------- + + do j=j0,jm + do i=i0-1,im + DIFX(:,i,j)=V(:,i+1,j)-V(:,i,j) + enddo + enddo + do j=j0-1,jm + do i=i0,im + DIFY(:,i,j)=V(:,i,j+1)-V(:,i,j) + enddo + enddo + + + do j=j0,jm + do i=i0,im + V(:,i,j)=a_diff_f(:,i,j)*V(:,i,j) & + -b_diff_f(:,i,j)*(DIFX(:,i,j)-DIFX(:,i-1,j) & + +DIFY(:,i,j)-DIFY(:,i,j-1)) + enddo + enddo + +if(l_hgen) then + +! imx = Fimax(my_hgen) +! jmx = Fjmax(my_hgen) + + imx = im + jmx = jm + + do j=j0,jmx + do i=i0-1,imx + DIFXH(:,i,j)=H(:,i+1,j)-H(:,i,j) + enddo + enddo + do j=j0-1,jmx + do i=i0,imx + DIFYH(:,i,j)=H(:,i,j+1)-H(:,i,j) + enddo + enddo + + do j=j0,jmx + do i=i0,imx + H(:,i,j)=a_diff_h(:,i,j)*H(:,i,j) & + -b_diff_h(:,i,j)*(DIFXH(:,i,j)-DIFXH(:,i-1,j) & + +DIFYH(:,i,j)-DIFYH(:,i,j-1)) + enddo + enddo + +endif + +!----------------------------------------------------------------------- + endsubroutine differencing_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine adjoint_all & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(F,W,km,g) +!----------------------------------------------------------------------- +implicit none +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km +real(r_kind), dimension(km,i0:im,j0:jm), intent(in):: F +real(r_kind), dimension(km,i0-2:imL+2,j0-2:jmL+2), intent(out):: W +real(r_kind), dimension(km,i0:im,j0-2:jmL+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 3) +! + W_AUX(:,:,:)= 0. + + do j=jm,2,-2 + jL = j/2 + do i=im,1,-1 + W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+p_coef(4)*F(:,i,j) + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+p_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+p_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+p_coef(1)*F(:,i,j) + enddo + enddo +! +! 2) +! + do j=jm-1,1,-2 + jL=j/2 + do i=im,1,-1 + W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+q_coef(4)*F(:,i,j) + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+q_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+q_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+q_coef(1)*F(:,i,j) + enddo + enddo + + W(:,:,:)=0. +! +! 1) +! + do jL=jmL+2,-1,-1 + do i=im-1,1,-2 + iL = i/2 + W(:,iL+2,jL)=W(:,iL+2,jL)+q_coef(4)*W_AUX(:,i,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)+q_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+q_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+q_coef(1)*W_AUX(:,i,jL) + enddo + do i=im,2,-2 + iL=i/2 + W(:,iL+2,jL)=W(:,iL+2,jL)+p_coef(4)*W_AUX(:,i,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)+p_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+p_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+p_coef(1)*W_AUX(:,i,jL) + enddo + enddo + +!----------------------------------------------------------------------- + endsubroutine adjoint_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine direct_all & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(W,F,km,g) +!----------------------------------------------------------------------- +implicit none +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km +real(r_kind), dimension(km,i0-2:imL+2,j0-2:jmL+2), intent(in):: W +real(r_kind), dimension(km,i0:im,j0:jm), intent(out):: F +real(r_kind), dimension(km,i0:im,j0-2:jmL+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- + +! +! 1) +! + do jL=-1,jmL+2 + do i=1,im-1,2 + iL=i/2 + W_AUX(:,i,jL)=q_coef(1)*W(:,iL-1,jL)+q_coef(2)*W(:,iL ,jL) & + +q_coef(3)*W(:,iL+1,jL)+q_coef(4)*W(:,iL+2,jL) + enddo + do i=2,im,2 + iL=i/2 + W_AUX(:,i,jL)=p_coef(1)*W(:,iL-1,jL)+p_coef(2)*w(:,iL ,jL) & + +p_coef(3)*W(:,iL+1,jL)+p_coef(4)*W(:,iL+2,jL) + enddo + enddo +! +! 2) +! + do j=1,jm-1,2 + jL=j/2 + do i=1,im + F(:,i,j)=q_coef(1)*W_AUX(:,i,jL-1)+q_coef(2)*W_AUX(:,i,jL ) & + +q_coef(3)*W_AUX(:,i,jL+1)+q_coef(4)*W_AUX(:,i,jL+2) + enddo + enddo +! +! 3) +! + do j=2,jm,2 + jL=j/2 + do i=1,im + F(:,i,j)=p_coef(1)*W_AUX(:,i,jL-1)+p_coef(2)*W_AUX(:,i,jL ) & + +p_coef(3)*W_AUX(:,i,jL+1)+p_coef(4)*W_AUX(:,i,jL+2) + enddo + enddo + +!----------------------------------------------------------------------- + endsubroutine direct_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine adjoint2_all & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! using quadratics interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(F,W,km,g) +!----------------------------------------------------------------------- +implicit none +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km +real(r_kind), dimension(km,1:im,1:jm), intent(in):: F +real(r_kind), dimension(km,0:imL+1,0:jmL+1), intent(out):: W +real(r_kind), dimension(km,1:im,0:jmL+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 3) +! + W_AUX(:,:,:)= 0. + + do j=jm,2,-2 + jL = j/2 + do i=im,1,-1 + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+b_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+b_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+b_coef(1)*F(:,i,j) + enddo + enddo +! +! 2) +! + do j=jm-1,1,-2 + jL=(j+1)/2 + do i=im,1,-1 + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+a_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+a_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+a_coef(1)*F(:,i,j) + enddo + enddo + + W(:,:,:)=0. +! +! 1) +! + do jL=jmL+1,0,-1 + do i=im-1,1,-2 + iL = (i+1)/2 + W(:,iL+1,jL)=W(:,iL+1,jL)+a_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+a_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+a_coef(1)*W_AUX(:,i,jL) + enddo + do i=im,2,-2 + iL=i/2 + W(:,iL+1,jL)=W(:,iL+1,jL)+b_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+b_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+b_coef(1)*W_AUX(:,i,jL) + enddo + enddo + +!----------------------------------------------------------------------- + endsubroutine adjoint2_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine direct2_all & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! using quadratic interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(W,F,km,g) +!----------------------------------------------------------------------- +implicit none +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km +real(r_kind), dimension(km,0:imL+1,0:jmL+1), intent(in):: W +real(r_kind), dimension(km,1:im,1:jm), intent(out):: F +real(r_kind), dimension(km,1:im,0:jmL+1):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 1) +! + do jL=0,jmL+1 + do i=1,im-1,2 + iL=(i+1)/2 + W_AUX(:,i,jL)=a_coef(1)*W(:,iL-1,jL)+a_coef(2)*W(:,iL ,jL) & + +a_coef(3)*W(:,iL+1,jL) + enddo + do i=2,im,2 + iL=i/2 + W_AUX(:,i,jL)=b_coef(1)*W(:,iL-1,jL)+b_coef(2)*w(:,iL ,jL) & + +b_coef(3)*W(:,iL+1,jL) + enddo + enddo +! +! 2) +! + do j=1,jm-1,2 + jL=(j+1)/2 + do i=1,im + F(:,i,j)=a_coef(1)*W_AUX(:,i,jL-1)+a_coef(2)*W_AUX(:,i,jL ) & + +a_coef(3)*W_AUX(:,i,jL+1) + enddo + enddo +! +! 3) +! + do j=2,jm,2 + jL=j/2 + do i=1,im + F(:,i,j)=b_coef(1)*W_AUX(:,i,jL-1)+b_coef(2)*W_AUX(:,i,jL ) & + +b_coef(3)*W_AUX(:,i,jL+1) + enddo + enddo + +!----------------------------------------------------------------------- + endsubroutine direct2_all + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + endmodule mg_generations diff --git a/src/saber/mgbf/mgbf_lib/type_mg_domain.f90 b/src/saber/mgbf/mgbf_lib/type_mg_domain.f90 new file mode 100755 index 000000000..be78ec471 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_mg_domain.f90 @@ -0,0 +1,737 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_domain +!**********************************************************************! +! ! +! Definition of a squared integration domain ! +! ! +! Modules: kinds, mg_mppstuff, mg_parameter ! +! M. Rancic (2020) ! +!**********************************************************************! +use mpi +use kinds, only: i_kind +!use mpimod, only: mype +use mg_mppstuff + +implicit none + +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 +type mg_domain_type +contains +procedure,nopass :: init_mg_domain +end type mg_domain_type + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + contains +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine init_mg_domain +!*********************************************************************** +! * +! Initialize square domain * +! * +!*********************************************************************** +implicit none + + + call init_domain + call init_topology_2d + + +!----------------------------------------------------------------------- + endsubroutine init_mg_domain + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine init_domain +!*********************************************************************** +! * +! Definition of constants that control filtering domain * +! * +!*********************************************************************** + +use mg_parameter +implicit none + + +integer(i_kind) n,nstrd,i,j +logical:: F=.false., T=.true. + +integer(i_kind):: loc_pe,g +!----------------------------------------------------------------------- +!TEST +! if(mype==0) then +! print *,'FROM INIT_DOMAIN: nxm,mym=',nxm,mym +! endif +!TEST + + Flwest(1)=nx.eq.1 + Fleast(1)=nx.eq.nxm + Flsouth(1)=my.eq.1 + Flnorth(1)=my.eq.mym + + 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==mym) 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.mym + + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! 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 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine init_topology_2d +!*********************************************************************** +! * +! Define topology of filter grid * +! - Four generations - * +! * +!*********************************************************************** +use mg_parameter, only: ixm,jym,nxy,maxpe_fgen,gm,imL,jmL + +implicit none + +!----------------------------------------------------------------------- +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 +!----------------------------------------------------------------------- +! +! 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 + +!TEST +! if(mype_hgen>-1.and.my_hgen 1) then +! if(mype_hgen> 2) then +! write(200+mype_hgen,'(a,3i5)') 'mype_hgen,mype,my_hgen=',mype_hgen,mype,my_hgen +! write(200+mype_hgen,'(a,i5)') 'itargdn_sw=',itargdn_sw +! write(200+mype_hgen,'(a,i5)') 'itargdn_se=',itargdn_se +! write(200+mype_hgen,'(a,i5)') 'itargdn_nw=',itargdn_nw +! write(200+mype_hgen,'(a,i5)') 'itargdn_ne=',itargdn_ne +! write(200+mype_hgen,'(a)') ' ' +! endif +! call finishMPI +!TEST + +!TEST +! write(100+mype,'(a,2i5)') 'mype=',mype +! write(100+mype,'(a,i5)') 'Fitarg_up=',Fitarg_up(1) +! if(Flsendup_sw(1)) then +! write(100+mype,'(a,l5)') 'Flsendup_sw=',Flsendup_sw(1) +! endif +! if(Flsendup_se(1)) then +! write(100+mype,'(a,l5)') 'Flsendup_se=',Flsendup_se(1) +! endif +! if(Flsendup_nw(1)) then +! write(100+mype,'(a,l5)') 'Flsendup_nw=',Flsendup_nw(1) +! endif +! if(Flsendup_ne(1)) then +! write(100+mype,'(a,l5)') 'Flsendup_ne=',Flsendup_ne(1) +! endif +! write(100+mype,'(a)') ' ' +! +! if(mype_hgen>-1.and.my_hgen>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! 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)')' ' +!TEST +! if(my_hgen == 2) then +! write(100+mype,'(a,2i5)')'mype,itargdn_se=',mype,itargdn_se +! endif +! call finishMPI +!TEST +! 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 +!---------------------------------------------------------------------- +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine real_itarg & +!*********************************************************************** +! * +! Definite real targets for high generations * +! * +!*********************************************************************** +(itarg) +!----------------------------------------------------------------------- +implicit none +integer(i_kind), intent(inout):: itarg +!----------------------------------------------------------------------- + if(itarg>-1) then + itarg = itarg-nxy(1) + endif + +!----------------------------------------------------------------------- + endsubroutine real_itarg + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + endmodule mg_domain diff --git a/src/saber/mgbf/mgbf_lib/type_mg_entrymod.f90 b/src/saber/mgbf/mgbf_lib/type_mg_entrymod.f90 new file mode 100644 index 000000000..7ec145628 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_mg_entrymod.f90 @@ -0,0 +1,180 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_entrymod +!*********************************************************************** +! ! +! Initialize and finialize multigrid Beta filter for modeling of ! +! background error covariance ! +! M. Rancic (2020) ! +!*********************************************************************** +use mpi +use kinds, only: r_kind,i_kind +use mg_parameter +!use mpimod, only: mype +use mg_mppstuff, only: mype +use mg_mppstuff, only: init_mg_MPI,finishMPI,barrierMPI +use mg_domain, only: init_mg_domain +use mg_intstate, only: allocate_mg_intstate,def_mg_weights & + ,init_mg_line & + ,deallocate_mg_intstate & + ,cvf1,cvf2,cvf3,cvf4,lref & + ,cvh1,cvh2,cvh3,cvh4,lref_h & + ,WORKA +use mg_interpolate,only: lsqr_mg_coef,lwq_vertical_coef,def_offset_coef +#if 0 +use mg_input, only: input_2d,input_3d,input_spec1_2d +use mg_output, only: output_spec1_2d,output_vertical_2d +#endif +implicit none +public +type mg_entrymod_type +contains + procedure,nopass :: mg_initialize + procedure,nopass :: mg_finalize +end type mg_entrymod_type + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine mg_initialize +!**********************************************************************! +! ! +! Initialization subroutine ! +! M. Rancic (2020) ! +!*********************************************************************** +!use mg_parameter, only: nm,mm + +real(r_kind), allocatable, dimension(:,:):: PA + +!**** +!**** Initialize run multigrid Beta filter parameters +!**** +#if 0 + call mg_parameter_type%init_mg_parameter +#endif + +!**** +!**** Initialize MPI +!**** + + call init_mg_MPI + +!*** +!*** Initialize integration domain +!*** + + call init_mg_domain + +!*** +!*** Allocate variables, define weights, prepare mapping +!*** between analysis and filter grid +!*** + + call allocate_mg_intstate + + call def_mg_weights + + if(mgbf_line) then + call init_mg_line + endif + + call lsqr_mg_coef + call def_offset_coef + call lwq_vertical_coef(lm ,lmf,cvf1,cvf2,cvf3,cvf4,lref) + call lwq_vertical_coef(lmf,lmh,cvh1,cvh2,cvh3,cvh4,lref_h) + +!*** +!*** Just for testing of standalone version. In GSI WORKA will be given +!*** through a separate subroutine +!*** +!clt +#if 0 + 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) + +if(ldelta) then + +allocate(PA(0:nm,0:mm)) + + PA = 0. + call input_spec1_2d(PA,nxm/2,mym/2,'md') + + WORKA(3*lm+1:4*lm,:,:)=0. + WORKA(3*lm+lm/2,:,:)=PA(:,:) + + +deallocate(PA) + +endif +#endif + +!----------------------------------------------------------------------- + endsubroutine mg_initialize + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine mg_finalize +!**********************************************************************! +! ! +! Finalize multigrid Beta Function ! +! M. Rancic (2020) ! +!*********************************************************************** +use mg_parameter, only: nm,mm + +real(r_kind), allocatable, dimension(:,:):: PA, VA +integer(i_kind):: n,m,L +!----------------------------------------------------------------------- + +if(ldelta) then + +! +! Horizontal cross-section +! + +allocate(PA(0:nm,0:mm)) + + PA(:,:)=WORKA(3*lm+lm/2,:,:) +#if 0 + call output_spec1_2d(PA) +#endif + +deallocate(PA) + +! +! Vertical cross-section +! + +allocate(VA(0:nm,1:lm)) + + + do l=1,lm + do n=0,nm + VA(n,l)=WORKA(3*lm+l,n,mm/2) + enddo + enddo +#if 0 + call output_vertical_2d(VA,4) +#endif + +deallocate(VA) + +endif + + call barrierMPI + + + call deallocate_mg_intstate + +!----------------------------------------------------------------------- + endsubroutine mg_finalize +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + endmodule mg_entrymod diff --git a/src/saber/mgbf/mgbf_lib/type_mg_interpolate.f90 b/src/saber/mgbf/mgbf_lib/type_mg_interpolate.f90 new file mode 100644 index 000000000..92506f46f --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_mg_interpolate.f90 @@ -0,0 +1,472 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_interpolate +!*********************************************************************** +! ! +! general mapping between 2d arrays using linerly squared ! +! interpolations ! +! ! +! M. Rancic (2020) ! +!*********************************************************************** +use mpi +use kinds +use mg_parameter, only: xa0,ya0,xf0,yf0,dxa,dxf,dya,dyf & + ,nm,mm,km,km2,km3,lm,lm_all & + ,i0,j0,n0,m0 & + ,im,jm,ib,jb +use mg_intstate, only: iref,jref & + ,cx0,cx1,cx2,cx3 & + ,cy0,cy1,cy2,cy3 +use mg_intstate, only: p_coef,q_coef +use mg_intstate, only: a_coef,b_coef + +!use mpimod, only: mype +use mg_mppstuff, only: mype +use mg_mppstuff, only: finishMPI +implicit none + +type interpolate_type +contains +procedure,nopass :: lsqr_mg_coef + +procedure,nopass :: lwq_vertical_coef +procedure,nopass :: lwq_vertical_direct +procedure,nopass :: lwq_vertical_adjoint + +procedure,nopass :: def_offset_coef + +procedure,nopass :: lsqr_direct_offset +procedure,nopass :: lsqr_adjoint_offset +end type interpolate_type +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine def_offset_coef +!*********************************************************************** +implicit none + +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 +1 q_coef = q_coef*r64 + + p_coef =(/-9.,111.,29.,-3./) + q_coef =(/-3.,29.,111.,-9./) + p_coef = p_coef*r128 + q_coef = q_coef*r128 + + a_coef =(/5.0d0,30.0d0,-3.0d0/) + b_coef =(/-3.0d0,30.0d0,5.0d0/) + a_coef=a_coef*r32 + b_coef=b_coef*r32 +!----------------------------------------------------------------------- + endsubroutine def_offset_coef + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine lsqr_mg_coef +!*********************************************************************** +! ! +! Prepare coeficients for mapping between: ! +! filter grid on analysis decomposition: W(i0-ib:im+ib,j0-jb:jm+jb) ! +! and analysis grid: V(0:nm,0:mm) ! +! - offset version - ! +! ! +! ( im < nm and jm < mm ) ! +! ! +!*********************************************************************** +implicit none +real(r_kind), dimension(0:nm):: xa +real(r_kind), dimension(1-ib:im+ib):: xf +real(r_kind), dimension(0:mm):: ya +real(r_kind), dimension(1-jb:jm+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 +!----------------------------------------------------------------------- +! +! Initialize +! + + do n=0,nm + xa(n)=xa0+n*dxa + enddo + + do i=1-ib,im+ib + xf(i)=xf0+i*dxf + enddo + + do m=0,mm + ya(m)=ya0+m*dya + enddo + + do j=1-jb,jm+jb + yf(j)=yf0+j*dyf + enddo + +! +! Find iref and jref +! + do n=0,nm + do i=1-ib,im+ib-1 + if( xa(n)< xf(i)) then + iref(n)=i-2 + exit + endif + enddo + enddo + + do m=0,mm + do j=1-jb,jm+jb-1 + if(ya(m) < yf(j)) then + jref(m)=j-2 + exit + endif + enddo + enddo + + + do n=0,nm + i=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 + cx0(n)=CFL1*CLL + cx1(n)=CFL2*CLL+CFR1*CRR + cx2(n)=CFL3*CLL+CFR2*CRR + cx3(n)=CFR3*CRR + enddo + + do m=0,mm + j=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 + cy0(m)=CFL1*CLL + cy1(m)=CFL2*CLL+CFR1*CRR + cy2(m)=CFL3*CLL+CFR2*CRR + cy3(m)=CFR3*CRR + enddo + + +!----------------------------------------------------------------------- + endsubroutine lsqr_mg_coef + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine lwq_vertical_coef & +!*********************************************************************** +! ! +! Prepare coeficients for vetical mapping between: ! +! analysis grid vertical resolution (nm) and ! +! generation one of filter grid vertical resoluition (im) ! +! ! +! ( im <= nm ) ! +! ! +!*********************************************************************** +(nm,im,c1,c2,c3,c4,iref) +use mg_mppstuff, only: mype +implicit none + +integer(i_kind), intent(in):: nm,im +real(r_kind), dimension(1:nm), intent(out):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm), intent(out):: iref + +real(r_kind), dimension(1:nm):: y +real(r_kind), dimension(0:im+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+1 + x(i)=(i-1)*1. + enddo + + dy = 1.*(im-1)/(nm-1) + do n=1,nm + y(n)=(n-1)*dy + enddo + y(nm)=x(im) + + do n=2,nm-1 + i = y(n)+1 + x1 = x(i-1) + x2 = x(i) + x3 = x(i+1) + x4 = x(i+2) + iref(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(n)==1) then + c3(n)=c3(n)+c1(n) + c1(n)=0. + endif + if(iref(n)==im-1) then + c2(n)=c2(n)+c4(n) + c4(n)=0. + endif + enddo + iref(1)=1; c1(1)=0.; c2(1)=1.; c3(1)=0.; c4(1)=0. + iref(nm)=im; c1(nm)=0.; c2(nm)=1.; c3(nm)=0.; c4(n)=0. + + +!----------------------------------------------------------------------- + endsubroutine lwq_vertical_coef + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine lwq_vertical_adjoint & +!*********************************************************************** +! ! +! Direct linerly weighted quadratic adjoint interpolation in vertical ! +! from reslution nm to resolution im ! +! ! +! ( im <= nm ) ! +! ! +!*********************************************************************** +(nm,km,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) +implicit none +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: nm,km,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm), intent(in):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm), intent(in):: kref +real(r_kind), dimension(1:nm,imin:imax,jmin:jmax), intent(in):: w +real(r_kind), dimension(1:km,imin:imax,jmin:jmax), intent(out):: f +integer(i_kind):: k,n +!----------------------------------------------------------------------- + f = 0. +do n=2,nm-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-1) then + f(km-2,:,:) = f(km-2,:,:)+c1(n)*w(n,:,:) + f(km-1,:,:) = f(km-1,:,:)+c2(n)*w(n,:,:) + f(km ,:,:) = f(km ,:,:)+c3(n)*w(n,:,:) + elseif( k==km) 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,:,:)=f(km,:,:)+w(nm,:,:) + +!----------------------------------------------------------------------- + endsubroutine lwq_vertical_adjoint + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine lwq_vertical_direct & +!*********************************************************************** +! ! +! Linerly weighted direct quadratic interpolation in vertical ! +! from reslouion im to resolution nm ! +! ! +! ( im <= nm ) ! +! ! +!*********************************************************************** +(km,nm,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,f,w) +implicit none +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km,nm,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm), intent(in):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm), intent(in):: kref +real(r_kind), dimension(1:km,imin:imax,jmin:jmax), intent(in):: f +real(r_kind), dimension(1:nm,imin:imax,jmin:jmax), intent(out):: w +integer(i_kind):: k,n +!----------------------------------------------------------------------- +do n=2,nm-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-1) then + w(n,:,:) =c1(n)*f(k-1,:,:)+c2(n)*f(k,:,:)+c3(n)*f(k+1,:,:) + elseif & + ( k==km) 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,:,:)=f(km,:,:) + + +!----------------------------------------------------------------------- + endsubroutine lwq_vertical_direct + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine lsqr_direct_offset & +!*********************************************************************** +! ! +! Given a source array V(km,i0-ib:im+ib,j0-jb:jm+jb) perform ! +! direct interpolations to get target array W(km,0:nm,0:mm) ! +! using two passes of 1d interpolator ! +! ! +!*********************************************************************** +(V,W,km) +!----------------------------------------------------------------------- +implicit none +integer(i_kind),intent(in):: km +real(r_kind), dimension(km,i0-ib:im+ib,j0-jb:jm+jb), intent(in):: V +real(r_kind), dimension(km,0:nm,0:mm),intent(out):: W + +real(r_kind), dimension(km,0:nm,j0-jb:jm+jb):: VX +integer(i_kind):: i,j,n,m +real(r_kind),dimension(km):: v0,v1,v2,v3 +!----------------------------------------------------------------------- + + + do j=j0-jb,jm+jb + do n=0,nm + i = iref(n) + v0(:)=V(:,i ,j) + v1(:)=V(:,i+1,j) + v2(:)=V(:,i+2,j) + v3(:)=V(:,i+3,j) + VX(:,n,j) = cx0(n)*v0(:)+cx1(n)*v1(:)+cx2(n)*v2(:)+cx3(n)*v3(:) + enddo + enddo + + do m=0,mm + j = jref(m) + do n=0,nm + v0(:)=VX(:,n,j ) + v1(:)=VX(:,n,j+1) + v2(:)=VX(:,n,j+2) + v3(:)=VX(:,n,j+3) + W(:,n,m) = cy0(m)*v0(:)+cy1(m)*v1(:)+cy2(m)*v2(:)+cy3(m)*v3(:) + enddo + enddo + +!----------------------------------------------------------------------- + endsubroutine lsqr_direct_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine lsqr_adjoint_offset & +!*********************************************************************** +! ! +! Given a target array W(km,0:nm,0:mm) perform adjoint ! +! interpolations to get source array V(km,i0-ib:im+ib,j0-jb:jm+jb) ! +! using two passes of 1d interpolator ! +! - offset version - ! +! ! +!*********************************************************************** +(W,V,km) +!----------------------------------------------------------------------- +implicit none +integer(i_kind):: km +real(r_kind), dimension(km,0:nm,0:mm),intent(in):: W +real(r_kind), dimension(km,i0-ib:im+ib,j0-jb:jm+jb), intent(out):: V +real(r_kind), dimension(km,0:nm,j0-jb:jm+jb):: VX +integer(i_kind):: i,j,n,m,l,k +integer(i_kind):: ip1,ip2,ip3 +integer(i_kind):: jp1,jp2,jp3 +!----------------------------------------------------------------------- + + V(:,:,:) = 0. + + VX(:,:,:)=0. + + do m=0,mm + j = jref(m) + jp1=j+1 + jp2=j+2 + jp3=j+3 + do n=0,nm + VX(:,n,j ) = VX(:,n,j )+W(:,n,m)*cy0(m) + VX(:,n,jp1) = VX(:,n,jp1)+W(:,n,m)*cy1(m) + VX(:,n,jp2) = VX(:,n,jp2)+W(:,n,m)*cy2(m) + VX(:,n,jp3) = VX(:,n,jp3)+W(:,n,m)*cy3(m) + enddo + enddo + + + do j=j0-jb,jm+jb + do n=0,nm + i = iref(n) + ip1=i+1 + ip2=i+2 + ip3=i+3 + + V(:,i ,j) = V(:,i ,j)+VX(:,n,j)*cx0(n) + V(:,ip1,j) = V(:,ip1,j)+VX(:,n,j)*cx1(n) + V(:,ip2,j) = V(:,ip2,j)+VX(:,n,j)*cx2(n) + V(:,ip3,j) = V(:,ip3,j)+VX(:,n,j)*cx3(n) + enddo + enddo + +!----------------------------------------------------------------------- + endsubroutine lsqr_adjoint_offset + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + endmodule mg_interpolate diff --git a/src/saber/mgbf/mgbf_lib/type_mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/type_mg_intstate.f90 new file mode 100755 index 000000000..f5b6b1c40 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_mg_intstate.f90 @@ -0,0 +1,437 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_intstate +!*********************************************************************** +! ! +! Contains declarations and allocations of internal state variables ! +! use for filtering ! +! - offset version - ! +! ! +! M. Rancic (2020) ! +!*********************************************************************** +use mpi +use kinds, only: r_kind,i_kind +use jp_pkind2, only: fpi +!GSI use mpimod, only: mype +use mg_mppstuff, only: mype +use mg_parameter, only: n0,m0,i0,j0 +use mg_parameter, only: im,jm,nh,hx,hy,pasp01,pasp02,pasp03 +use mg_parameter, only: lm,hz,p,km,km2,km3,km,nm,mm,ib,jb,nb,mb +use mg_parameter, only: lmf,lmh,kmf,kmh +!GSI use berror, only: mg_weig1,mg_weig2,mg_weig3,mg_weig4 +use mg_parameter, only: mg_weig1,mg_weig2,mg_weig3,mg_weig4 +use mg_mppstuff, only: my_hgen,finishMPI,barrierMPI +use jp_pbfil,only: cholaspect +use jp_pbfil,only: getlinesum +use jp_pbfil3, only: inimomtab,t22_to_3,tritform,t33_to_6,hextform +!TEST +!use gridmod, only: lat1,lon1 +!TEST +implicit none +public WORKA +type mg_intstate_type +contains +procedure,nopass :: allocate_mg_intstate, def_mg_weights , init_mg_line, deallocate_mg_intstate +end type mg_intstate_type + + +real(r_kind), allocatable,dimension(:,:,:):: V +! +! Composite control variable on first generation o filter grid +! +real(r_kind), allocatable,dimension(:,:,:):: VALL +real(r_kind), allocatable,dimension(:,:,:):: HALL +! +! Composite control variable on high generations of filter grid +! +! +!FOR ADJOINT TEST +! +!real(r_kind), allocatable,dimension(:,:):: A +!real(r_kind), allocatable,dimension(:,:):: B +!real(r_kind), allocatable,dimension(:,:):: A0 +!real(r_kind), allocatable,dimension(:,:):: B0 +! +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 + +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 + +!real(r_kind), allocatable,dimension(:,:,:,:):: r_vol +! +! +! Composite stacked variable +! + +real(r_kind), allocatable,dimension(:,:,:):: WORKA + + +integer(i_kind),allocatable,dimension(:):: iref,jref +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(:):: 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 +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine allocate_mg_intstate +!*********************************************************************** +implicit none +! ! +! Allocate internal state variables ! +! ! +!*********************************************************************** + +allocate(V(i0-hx:im+hx,j0-hy:jm+hy,lm)) ; V=0. +allocate(VALL(kmf,i0-hx:im+hx,j0-hy:jm+hy)) ; VALL=0. +allocate(HALL(kmh,i0-hx:im+hx,j0-hy:jm+hy)) ; HALL=0. + + +allocate(a_diff_f(kmf,i0-hx:im+hx,j0-hy:jm+hy)) ; a_diff_f=0. +allocate(a_diff_h(kmh,i0-hx:im+hx,j0-hy:jm+hy)) ; a_diff_h=0. +allocate(b_diff_f(kmf,i0-hx:im+hx,j0-hy:jm+hy)) ; b_diff_f=0. +allocate(b_diff_h(kmf,i0-hx:im+hx,j0-hy:jm+hy)) ; b_diff_h=0. + +allocate(p_eps(i0-hx:im+hx,j0-hy:jm+hy)) ; p_eps=0. +allocate(p_del(i0-hx:im+hx,j0-hy:jm+hy)) ; p_del=0. +allocate(p_sig(i0-hx:im+hx,j0-hy:jm+hy)) ; p_sig=0. +allocate(p_rho(i0-hx:im+hx,j0-hy:jm+hy)) ; p_rho=0. + +allocate(paspx(1,1,i0:im)) ; paspx=0. +allocate(paspy(1,1,j0:jm)) ; paspy=0. + +allocate(pasp1(1,1,1:lm)) ; pasp1=0. +allocate(pasp2(2,2,i0:im,j0:jm)) ; pasp2=0. +allocate(pasp3(3,3,i0:im,j0:jm,1:lm)) ; pasp3=0. + +allocate(vpasp2(0:2,i0:im,j0:jm)) ; vpasp2=0. +allocate(hss2(i0:im,j0:jm,1:3)) ; hss2= 0. + +allocate(vpasp3(1:6,i0:im,j0:jm,1:lm)) ; vpasp3= 0. +allocate(hss3(i0:im,j0:jm,1:lm,1:6)) ; hss3= 0. + +allocate(ssx(i0:im)) ; ssx=0. +allocate(ssy(j0:jm)) ; ssy=0. +allocate(ss1(1:lm)) ; ss1=0. +allocate(ss2(i0:im,j0:jm)) ; ss2=0. +allocate(ss3(i0:im,j0:jm,1:lm)) ; ss3=0. + +allocate(dixs(i0:im,j0:jm,3)) ; dixs=0 +allocate(diys(i0:im,j0:jm,3)) ; diys=0 + +allocate(dixs3(i0:im,j0:jm,1:lm,6)) ; dixs3=0 +allocate(diys3(i0:im,j0:jm,1:lm,6)) ; diys3=0 +allocate(dizs3(i0:im,j0:jm,1:lm,6)) ; dizs3=0 + +allocate(qcols(0:7,i0:im,j0:jm,1:lm)) ; qcols=0 + +! +! In stnadalone version +! +!allocate(r_vol(km,0:nm,0:mm,2)) ; r_vol=0. +! +! ... but in global version there will be +! r_vol2 and r_vol3 for 2d and 3d variables +! and r_vol3 will need to be given vertical structure +! + +! +allocate(WORKA(km,n0:nm,m0:mm)) ; WORKA=0. + +! +! for re-decomposition +! + +allocate(iref(n0:nm)) ; iref=0 +allocate(jref(m0:mm)) ; jref=0 + +allocate(cx0(n0:nm)) ; cx0=0. +allocate(cx1(n0:nm)) ; cx1=0. +allocate(cx2(n0:nm)) ; cx2=0. +allocate(cx3(n0:nm)) ; cx3=0. + +allocate(cy0(m0:mm)) ; cy0=0. +allocate(cy1(m0:mm)) ; cy1=0. +allocate(cy2(m0:mm)) ; cy2=0. +allocate(cy3(m0:mm)) ; cy3=0. + +allocate(p_coef(4)) ; p_coef=0. +allocate(q_coef(4)) ; q_coef=0. + +allocate(a_coef(3)) ; a_coef=0. +allocate(b_coef(3)) ; b_coef=0. + + +allocate(cf00(n0:nm,m0:mm)) ; cf00=0. +allocate(cf01(n0:nm,m0:mm)) ; cf01=0. +allocate(cf02(n0:nm,m0:mm)) ; cf02=0. +allocate(cf03(n0:nm,m0:mm)) ; cf03=0. +allocate(cf10(n0:nm,m0:mm)) ; cf10=0. +allocate(cf11(n0:nm,m0:mm)) ; cf11=0. +allocate(cf12(n0:nm,m0:mm)) ; cf12=0. +allocate(cf13(n0:nm,m0:mm)) ; cf13=0. +allocate(cf20(n0:nm,m0:mm)) ; cf20=0. +allocate(cf21(n0:nm,m0:mm)) ; cf21=0. +allocate(cf22(n0:nm,m0:mm)) ; cf22=0. +allocate(cf23(n0:nm,m0:mm)) ; cf23=0. +allocate(cf30(n0:nm,m0:mm)) ; cf30=0. +allocate(cf31(n0:nm,m0:mm)) ; cf31=0. +allocate(cf32(n0:nm,m0:mm)) ; cf32=0. +allocate(cf33(n0:nm,m0:mm)) ; cf33=0. + +allocate(Lref(1:lm)) ; Lref=0 +allocate(Lref_h(1:lmf)) ; Lref_h=0 + +allocate(cvf1(1:lm)) ; cvf1=0. +allocate(cvf2(1:lm)) ; cvf2=0. +allocate(cvf3(1:lm)) ; cvf3=0. +allocate(cvf4(1:lm)) ; cvf4=0. + +allocate(cvh1(1:lmf)) ; cvh1=0. +allocate(cvh2(1:lmf)) ; cvh2=0. +allocate(cvh3(1:lmf)) ; cvh3=0. +allocate(cvh4(1:lmf)) ; cvh4=0. + + +!----------------------------------------------------------------------- + endsubroutine allocate_mg_intstate + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine def_mg_weights +!*********************************************************************** +! ! +! Define weights and scales ! +! ! +!*********************************************************************** +implicit none +integer(i_kind):: i,j,L +real(r_kind):: gen_fac +!----------------------------------------------------------------------- + + p_eps(:,:)=0.0 + p_del(:,:)=0.0 + p_sig(:,:)=0.0 + p_rho(:,:)=0.0 + +!-------------------------------------------------------- + gen_fac=1. + a_diff_f(:,:,:)=mg_weig1 + a_diff_h(:,:,:)=mg_weig1 + + b_diff_f(:,:,:)=0. + b_diff_h(:,:,:)=0. + +! r_vol(:,:,:,1)=1. + + + select case(my_hgen) + case(2) +! r_vol(:,:,:,2)=0.25 ! In standalone case +! gen_fac=0.25 + a_diff_h(:,:,:)=mg_weig2 + b_diff_h(:,:,:)=0. + case(3) +! r_vol(:,:,:,2)=0.0625 ! In standalone case +! gen_fac=0.0625 + a_diff_h(:,:,:)=mg_weig3 + b_diff_h(:,:,:)=0. + case default +! r_vol(:,:,:,2)=0.015625 ! In standalone case +! gen_fac=0.015625 + a_diff_h(:,:,:)=mg_weig4 + b_diff_h(:,:,:)=0. + end select + + + do L=1,lm + pasp1(1,1,L)=pasp01 + enddo + + do i=i0,im + paspx(1,1,i)=pasp02 + enddo + do j=j0,jm + paspy(1,1,j)=pasp02 + enddo + + do j=i0,jm + do i=j0,im + pasp2(1,1,i,j)=pasp02*(1.+p_del(i,j)) + pasp2(2,2,i,j)=pasp02*(1.-p_del(i,j)) + pasp2(1,2,i,j)=pasp02*p_eps(i,j) + pasp2(2,1,i,j)=pasp02*p_eps(i,j) + end do + end do + + do L=1,lm + do j=i0,jm + do i=j0,im + pasp3(1,1,i,j,l)=pasp03*(1+p_del(i,j)) + pasp3(2,2,i,j,l)=pasp03 + pasp3(3,3,i,j,l)=pasp03*(1-p_del(i,j)) + pasp3(1,2,i,j,l)=pasp03*p_eps(i,j) + pasp3(2,1,i,j,l)=pasp03*p_eps(i,j) + pasp3(2,3,i,j,l)=pasp03*p_sig(i,j) + pasp3(3,2,i,j,l)=pasp03*p_sig(i,j) + pasp3(1,3,i,j,l)=pasp03*p_rho(i,j) + pasp3(3,1,i,j,l)=pasp03*p_rho(i,j) + end do + end do + end do + + + call cholaspect(1,lm,pasp1) + call cholaspect(i0,im,j0,jm,pasp2) + call cholaspect(i0,im,j0,jm,1,lm,pasp3) + + + call getlinesum(hx,i0,im,paspx,ssx) + call getlinesum(hy,j0,jm,paspy,ssy) + call getlinesum(hz,1,lm,pasp1,ss1) + call getlinesum(hx,i0,im,hy,j0,jm,pasp2,ss2) + call getlinesum(hx,i0,im,hy,j0,jm,hz,1,lm,pasp3,ss3) +!----------------------------------------------------------------------- + endsubroutine def_mg_weights + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine init_mg_line +!*********************************************************************** +! ! +! Inititate line filters ! +implicit none +! ! +!*********************************************************************** +integer(i_kind):: i,j,L,icol +logical:: ff +!----------------------------------------------------------------------- + + do j=j0,jm + do i=i0,im + call t22_to_3(pasp2(:,:,i,j),vpasp2(:,i,j)) + enddo + enddo + + do l=1,lm + do j=j0,jm + do i=i0,im + call t33_to_6(pasp3(:,:,i,j,l),vpasp3(:,i,j,l)) + enddo + enddo + enddo + + + + call inimomtab(p,nh,ff) + + call tritform(i0,im,i0,jm,vpasp2, dixs,diys, ff) + + do icol=1,3 + hss2(:,:,icol)=vpasp2(icol-1,:,:) + enddo + + + call hextform(i0,im,j0,jm,1,lm,vpasp3,qcols,dixs3,diys3,dizs3, ff) + + + do icol=1,6 + hss3(:,:,:,icol)=vpasp3(icol,:,:,:) + enddo + + +!----------------------------------------------------------------------- + endsubroutine init_mg_line + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine deallocate_mg_intstate +!*********************************************************************** +! ! +! Deallocate internal state variables ! +! ! +!*********************************************************************** + +implicit none +deallocate(V) + +deallocate(HALL,VALL) + +deallocate(a_diff_f,b_diff_f) +deallocate(a_diff_h,b_diff_h) +deallocate(p_eps,p_del,p_sig,p_rho,pasp1,pasp2,pasp3,ss1,ss2,ss3) +deallocate(dixs,diys) +deallocate(dixs3,diys3,dizs3) +deallocate(qcols) +! +! for testing +! +deallocate(WORKA) + +! +! for re-decomposition +! +deallocate(iref,jref) + +deallocate(cf00,cf01,cf02,cf03,cf10,cf11,cf12,cf13) +deallocate(cf20,cf21,cf22,cf23,cf30,cf31,cf32,cf33) + +deallocate(Lref,Lref_h) + +deallocate(cvf1,cvf2,cvf3,cvf4) + +deallocate(cvh1,cvh2,cvh3,cvh4) + +deallocate(cx0,cx1,cx2,cx3) +deallocate(cy0,cy1,cy2,cy3) + +deallocate(p_coef,q_coef) +deallocate(a_coef,b_coef) + + + + endsubroutine deallocate_mg_intstate + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + endmodule mg_intstate diff --git a/src/saber/mgbf/mgbf_lib/type_mg_mppstuff.f90 b/src/saber/mgbf/mgbf_lib/type_mg_mppstuff.f90 new file mode 100755 index 000000000..4d7ec37d5 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_mg_mppstuff.f90 @@ -0,0 +1,218 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_mppstuff +!*********************************************************************** +! ! +! Everything related to mpi communication ! +! ! +! Library: mpi ! +! Modules: kinds, mg_parameter ! +! M. Rancic (2020) ! +!*********************************************************************** +use mpi +use kinds, only: i_kind +use mg_parameter +implicit none + +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 +!keep_for_now integer(i_kind):: ns,ms,ninc,minc,ninc2,minc2 + +type mppstuff_type +contains +procedure,nopass :: init_mg_MPI,finishMPI,barrierMPI +end type mppstuff_type + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine init_mg_MPI +!*********************************************************************** +! ! +! Initialize mpi ! +! Create group for filter grid ! +! ! +!*********************************************************************** +use mpi + + +implicit none +integer(i_kind):: g,m +integer(i_kind), dimension(npes_filt):: out_ranks +integer(i_kind):: nf +!----------------------------------------------------------------------- +!clt mgbf4jedi + mpi_comm_comp=MPI_COMM_WORLD +!*** +!*** Initial MPI calls +!*** + call MPI_INIT(ierr) + call MPI_COMM_RANK(mpi_comm_comp,mype,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 + +! if(nx==1) then +! ns=0 +! ninc=1 +! ninc2=2 +! else +! ns=1 +! ninc=0 +! ninc2=1 +! endif +! +! if(my==1) then +! ms=0 +! minc=1 +! minc2=2 +! else +! ms=1 +! minc=0 +! minc2=1 +! endif + + +!*** +!*** 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 + +!TEST +! write(300+mype,*)'mype,my_hgen,l_gen,mype_hgen=',mype,my_hgen,l_hgen,mype_hgen +!TEST + +!*** +!*** 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 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 + +!TEST +! write(mype+100,*) 'mype, mype_gr=',mype, mype_gr +! print *, 'mype, mype_gr=',mype, mype_gr +! call MPI_FINALIZE(mpi_comm_comp) +! stop +!TEST + + + +!----------------------------------------------------------------------- +! + call MPI_BARRIER(mpi_comm_comp,ierr) +! +!----------------------------------------------------------------------- + endsubroutine init_mg_MPI + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine barrierMPI +!*********************************************************************** +! ! +! Call barrier for all ! +! ! +!*********************************************************************** +use mpi + +implicit none +integer:: ierr +!----------------------------------------------------------------------- + + call MPI_BARRIER(mpi_comm_comp,ierr) + +!----------------------------------------------------------------------- + endsubroutine barrierMPI + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine finishMPI +!*********************************************************************** +! ! +! Finalize MPI ! +! ! +!*********************************************************************** +use mpi + +implicit none +integer:: ierr + +!----------------------------------------------------------------------- +! + call MPI_FINALIZE(ierr) + stop +! +!----------------------------------------------------------------------- + endsubroutine finishMPI + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + endmodule mg_mppstuff + diff --git a/src/saber/mgbf/mgbf_lib/type_mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/type_mg_parameter.f90 new file mode 100755 index 000000000..b967a45e1 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_mg_parameter.f90 @@ -0,0 +1,610 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_parameter +!*********************************************************************** +! ! +! Set resolution, grid and decomposition ! +! - offset version - ! +! ! +! Note: ixm(1)=nxm, jym(1)=mym ! +! ! +! If mod(nxm,2)=0 then mod(im0,4)=0 ! +! If mod(mym,2)>0 then mod(im0,8)=0 ! +! ! +! Modules: kinds, jp_pietc ! +! M. Rancic (2022) ! +!*********************************************************************** +use mpi +use kinds, only: i_kind,r_kind +use jp_pietc, only: u1 +!use berror, only: mg_ampl0,im_filt,jm_filt +!TEST +!use mpimod, only: nxpe,nype +!TEST + +implicit none +#if 0 +xxx +type mg_parameter_type +#endif +!----------------------------------------------------------------------- +!*** +!*** 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 +logical:: mgbf_line +integer(i_kind):: nxPE,nyPE,im_filt,jm_filt +logical:: lquart + +!*** +!*** Number of generations +!*** +integer(i_kind):: gm + +!*** +!*** 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):: mym + +! +! 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):: lm ! number of vertical layers +integer(i_kind):: lm05 ! half of vertical levels +integer(i_kind):: km3 ! number of 3d variables +integer(i_kind):: km2 ! number of 2d variables +integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) +integer(i_kind):: lm_all ! vertically stacked all variables (lm_all=km - for now) + +integer(i_kind):: lmf ! number of vertical levels for filtering (generation one) +integer(i_kind):: lmh ! number of vertical levels for filtering (high generations) +integer(i_kind):: lmf_all ! number of vertically stacked variables (generation one) +integer(i_kind):: lmh_all ! number of vertically stacked high generations variabes +integer(i_kind):: kmf ! number of vertically stacked variables (generation one) +integer(i_kind):: kmh ! number of vertically stacked high generations variabes + + +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 +#if 1 +type mg_parameter_type +#endif +contains +procedure,nopass :: init =>init_mg_parameter +end type mg_parameter_type +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine init_mg_parameter() +!**********************************************************************! +! ! +! Initialize .... ! +! ! +!**********************************************************************! +integer(i_kind):: g + +! +! Set number of PEs in x and y directions +! + 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 & + ,nxPE,nyPE,im_filt,jm_filt & + ,nm0,mm0 & + ,lm,lmf,lmh & + ,ldelta,lquart +! + open(unit=10,file='mgbeta.nml',status='old',action='read') + read(10,nml=parameters_mgbeta) + close(unit=10) +! +!----------------------------------------------------------------- + + nxm = nxPE + mym = nyPE +! + im = im_filt + jm = jm_filt + +!----------------------------------------------------------------- +! +! +! For 168 PES +! +! nxm = 14 +! mym = 12 +! +! For 256 PES +! +! +! nxm = 16 +! mym = 16 +! +! For 336 PES +! +! nxm = 28 +! mym = 12 +! +! For 448 PES +! +! nxm = 28 +! mym = 16 +! +! +! For 512 PES +! +! nxm = 32 +! mym = 16 +! +! For 704 PES +! +! nxm = 32 +! mym = 22 +! +! For 768 PES +! +! nxm = 32 +! mym = 24 +! +! +! For 924 PES +! +! nxm = 28 +! mym = 33 +! +! For 1056 PES +! +! nxm = 32 +! mym = 33 +! +! For 1408 PES +! +! nxm = 32 +! mym = 44 +! +! For 1848 PES +! +! nxm = 56 +! mym = 33 +! +! For 2464 PES +! +! nxm = 56 +! mym = 44 + + +! +! Define maximum number of generations 'gm' +! + + call def_maxgen(nxm,mym,gm) + +! Restrict to 4 + + if(gm>4) then + gm=4 + endif +! + +!*** +!*** Analysis grid +!*** + +! +! Number of grid intervals on GSI grid for the reduced RTMA domain +! before padding +! +!clt needed jedi input + nA_max0 = 1792 + mA_max0 = 1056 + + +! +! Number of grid points on the analysis grid after padding +! + +!SMALL DOMAIN +! nm0 = 1792 +! mm0 = 1056 +!SMALL DOMAIN + +!TEST +! nm0 = 384 +! mm0 = 384 +!TEST + + nm = nm0/nxm + mm = mm0/mym + +!*** +!*** 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 + + im00 = nxm*im + jm00 = mym*jm + + n0 = 0 ! For now + m0 = 0 ! For now + + i0 = 1 + j0 = 1 + +! +! Make sure that nm0 and mm0 and divisibvle with nxm and mym +! + if(nm*nxm /= nm0 ) then + write(17,*) 'nm,nxm,nm0=',nm,nxm,nm0 + stop 'nm0 is not divisible by nxm' + endif + + if(mm*mym /= mm0 ) then + write(17,*) 'mm,mym,mm0=',mm,mym,mm0 + stop 'mm0 is not divisible by mym' + endif + +! +! Set number of processors at higher generations +! + + allocate(ixm(gm)) + allocate(jym(gm)) + allocate(nxy(gm)) + allocate(maxpe_fgen(0:gm)) + allocate(im0(gm)) + allocate(jm0(gm)) + allocate(Fimax(gm)) + allocate(Fjmax(gm)) + allocate(FimaxL(gm)) + allocate(FjmaxL(gm)) + + call def_ngens(ixm,gm,nxm) + call def_ngens(jym,gm,mym) + + + do g=1,gm + nxy(g)=ixm(g)*jym(g) + enddo + + maxpe_fgen(0)= 0 + do g=1,gm + maxpe_fgen(g)=maxpe_fgen(g-1)+nxy(g) + enddo + + maxpe_filt=maxpe_fgen(gm) + npes_filt=maxpe_filt-nxy(1) + + im0(1)=im00 + do g=2,gm + im0(g)=im0(g-1)/2 + enddo + + jm0(1)=jm00 + do g=2,gm + jm0(g)=jm0(g-1)/2 + enddo + + do g=1,gm + Fimax(g)=im0(g)-im*(ixm(g)-1) + Fjmax(g)=jm0(g)-jm*(jym(g)-1) +!TEST +! write(15,*)'Fimax(',g,')=',Fimax(g) +! write(15,*)'Fjmax(',g,')=',Fjmax(g) +!TEST + enddo + + do g=1,gm + FimaxL(g)=Fimax(g)/2 + FjmaxL(g)=Fjmax(g)/2 + enddo + +!*** +!*** Number of variables +!*** +!cltmgbf4jedi + + km3 = 6 + km2 = 4 + +!*** +!*** Vertical distribution +!*** + +! lm = 1 +! lm = 50 +! lm05 = lm/2 + km = km3*lm+km2 + lm_all = km3*lm+km2 ! to be deleted + +! lmf = 48 +! lmh = lmf/2 +!TEST +! lmf = lm +! lmh = lmf +!TEST + lmf_all = km3*lmf+km2 ! to be deleted + lmh_all = km3*lmh+km2 ! to be deleted + kmf = km3*lmf+km2 + kmh = km3*lmh+km2 + + + +!*** +!*** Filter related parameters +!** +!clt mgbf4jedi to be put into namelist? + lengthx = 6. ! arbitrary chosen scale of the domain + lengthy = 6. ! arbitrary chosen scale of the domain + + + ib=4 + jb=4 + + dxa = lengthx/nm + dxf = lengthx/im + nb = 2*dxf/dxa + + dya = lengthy/mm + dyf = lengthy/jm + mb = 2*dyf/dya + + xa0 =0. + ya0 =0. + + xf0=-dxf*0.5 + yf0=-dyf*0.5 + + imL=im/2 + jmL=jm/2 + +! pasp0=1 +! pasp0 = 5 ! Main +!! pasp0 = 2. + pasp01 = mg_ampl01 + pasp02 = mg_ampl02 + pasp03 = mg_ampl03 + + +!TEST hx=8 +!TEST hz=8 +!TEST hz=4 +!TEST hz=5 +! hx=6 +! hy=hx +! hz=6 +!clt mgbf4jedi + nh= 6 + nfil = nh + 2 + +! p = 4 ! Exponent of Beta function +! p = 2 ! Exponent of Beta function + + pee2=p*2 + rmom2_1=u1/sqrt(pee2+3) + rmom2_2=u1/sqrt(pee2+4) + rmom2_3=u1/sqrt(pee2+5) + rmom2_4=u1/sqrt(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,mym,gm) +!---------------------------------------------------------------------- +implicit none +integer, intent(in):: nxm,mym +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 = mym; 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/saber/mgbf/mgbf_lib/type_mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/type_mg_transfer.f90 new file mode 100644 index 000000000..910126130 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_mg_transfer.f90 @@ -0,0 +1,212 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_transfer +!*********************************************************************** +! ! +! Transfer data between analysis and filter grid ! +! ! +! Modules: kinds, mg_parameter, mg_intstate, mg_bocos, mg_interpolate, ! +! mg_timers, mg_mppstuff ! +! M. Rancic (2021) ! +!*********************************************************************** +use mpi +use kinds, only: r_kind,i_kind +use mg_parameter +use mg_intstate, only: VALL,WORKA +use mg_mppstuff, only: mype,ierror,mpi_comm_world +use mg_mppstuff, only: nx,my,mpi_comm_comp + +implicit none + +integer(i_kind):: n,m,l,k,i,j + +public anal_to_filt_all +public filt_to_anal_all + +public stack_to_composite +public composite_to_stack +public +type mg_transfer_type + contains + procedure,nopass :: anal_to_filt_all + procedure,nopass :: filt_to_anal_all +end type mg_transfer_type + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine anal_to_filt_all +!*********************************************************************** +! ! +! Transfer data from analysis to first generaton of filter grid ! +! ! +!*********************************************************************** +use mg_interpolate, only: lsqr_adjoint_offset +use mg_bocos, only: bocoT_2d +implicit none + +real(r_kind),allocatable,dimension(:,:,:):: VLOC + +!---------------------------------------------------------------------- + + allocate(VLOC(km,i0-ib:im+ib,j0-jb:jm+jb)) + + +!T call btim( aintp_tim) + + VLOC=0. + call lsqr_adjoint_offset(WORKA,VLOC,km) + + +!T call etim( aintp_tim) + + +!*** +!*** Apply adjoint lateral bc on PKF and WKF +!*** + + + call bocoT_2d(VLOC,km,im,jm,ib,jb) + + VALL=0. + VALL(1:km,i0:im,j0:jm)=VLOC(1:km,i0:im,j0:jm) + + + deallocate(VLOC) + +! call etim( btrns1_tim) + +!---------------------------------------------------------------------- + endsubroutine anal_to_filt_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine filt_to_anal_all +!*********************************************************************** +! ! +! Transfer data from filter to analysis grid ! +! ! +!*********************************************************************** +use mg_interpolate, only: lsqr_direct_offset +use mg_bocos, only: boco_2d +implicit none + + +real(r_kind),allocatable,dimension(:,:,:):: VLOC + + +!---------------------------------------------------------------------- + +!T call btim( btrns2_tim) + +!*** +!*** Define VLOC +!*** + + allocate(VLOC(1:km,i0-ib:im+ib,j0-jb:jm+jb)) + + VLOC=0. + VLOC(1:km,i0:im,j0:jm)=VALL(1:km,i0:im,j0:jm) + + +!*** +!*** Supply boundary conditions for VLOC +!*** + call boco_2d(VLOC,km,im,jm,ib,jb) + + +!*** +!*** Interpolate to analysis grid composite variables +!*** + + +!T call btim( intp_tim) + + call lsqr_direct_offset(VLOC,WORKA,km) + +!T call etim( intp_tim) + deallocate(VLOC) + + +!T call etim( btrns2_tim) + +!---------------------------------------------------------------------- + endsubroutine filt_to_anal_all + + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine stack_to_composite & +!*********************************************************************** +! ! +! Transfer data from stack to composite variables ! +! ! +!*********************************************************************** +(ARR_ALL,A2D,A3D) +!---------------------------------------------------------------------- +implicit none +real(r_kind),dimension(km ,i0-hx:im+hx,j0-hy:jm+hy), intent(in):: ARR_ALL +real(r_kind),dimension(km3,i0-hx:im+hx,j0-hy:jm+hy,lm),intent(out):: A3D +real(r_kind),dimension(km2,i0-hx:im+hx,j0-hy:jm+hy) ,intent(out):: A2D +!---------------------------------------------------------------------- + do L=1,lm + do j=j0-hy,jm+hy + do i=i0-hx,im+hx + A3D(1,i,j,L)=ARR_ALL( L,i,j) + A3D(2,i,j,L)=ARR_ALL( lm+L,i,j) + A3D(3,i,j,L)=ARR_ALL(2*lm+L,i,j) + A3D(4,i,j,L)=ARR_ALL(3*lm+L,i,j) + A3D(5,i,j,L)=ARR_ALL(4*lm+L,i,j) + A3D(6,i,j,L)=ARR_ALL(5*lm+L,i,j) + enddo + enddo + enddo + + + A2D(1,:,:)=ARR_ALL(6*lm+1,:,:) + A2D(2,:,:)=ARR_ALL(6*lm+2,:,:) + A2D(3,:,:)=ARR_ALL(6*lm+3,:,:) + A2D(4,:,:)=ARR_ALL(6*lm+4,:,:) + +!---------------------------------------------------------------------- + endsubroutine stack_to_composite + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine composite_to_stack & +!*********************************************************************** +! ! +! Transfer data from composite to stack variables ! +! ! +!*********************************************************************** +(A2D,A3D,ARR_ALL) +!---------------------------------------------------------------------- +implicit none +real(r_kind),dimension(km2,i0-hx:im+hx,j0-hy:jm+hy), intent(in):: A2D +real(r_kind),dimension(km3,i0-hx:im+hx,j0-hy:jm+hy,lm),intent(in):: A3D +real(r_kind),dimension(km ,i0-hx:im+hx,j0-hy:jm+hy), intent(out):: ARR_ALL +integer(i_kind):: i,j,L +!---------------------------------------------------------------------- + do L=1,lm + do j=j0-hy,jm+hy + do i=i0-hx,im+hx + ARR_ALL( L,i,j)= A3D(1,i,j,L) + ARR_ALL( lm+L,i,j)= A3D(2,i,j,L) + ARR_ALL(2*lm+L,i,j)= A3D(3,i,j,L) + ARR_ALL(3*lm+L,i,j)= A3D(4,i,j,L) + ARR_ALL(4*lm+L,i,j)= A3D(5,i,j,L) + ARR_ALL(5*lm+L,i,j)= A3D(6,i,j,L) + enddo + enddo + enddo + + + ARR_ALL(6*lm+1,:,:)= A2D(1,:,:) + ARR_ALL(6*lm+2,:,:)= A2D(2,:,:) + ARR_ALL(6*lm+3,:,:)= A2D(3,:,:) + ARR_ALL(6*lm+4,:,:)= A2D(4,:,:) + +!---------------------------------------------------------------------- + endsubroutine composite_to_stack + + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + endmodule mg_transfer diff --git a/src/saber/mgbf/mgbf_lib/type_mgbf.f90 b/src/saber/mgbf/mgbf_lib/type_mgbf.f90 new file mode 100755 index 000000000..4bbbd769b --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_mgbf.f90 @@ -0,0 +1,119 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module type_mgbf_mod +!*********************************************************************** +! ! +! Multigrid Beta filter for modeling background error covariance ! +! ! +! M. Rancic (2020) ! +!*********************************************************************** +use mpi +use kinds, only: r_kind,i_kind +use mg_entrymod, only:mg_entrymod_type, mg_initialize,mg_finalize +use mg_mppstuff, only: finishMPI,mype +use mg_filtering, only: mg_filtering_procedure +use mg_transfer, only: mg_transfer_type,anal_to_filt_all,filt_to_anal_all +use mg_parameter, only: mgbf_proc +use type_fieldset, only: fieldset_type +implicit none +type mgbf_type + type(mg_entrymod_type):: mg_entrymod + type(mg_transfer_type):: mg_transfer + contains + procedure,pass:: mgbf_init + procedure,pass:: mgbf_apply + procedure,nopass:: mgbf_finalize +end type mgbf_type +!----------------------------------------------------------------------- +contains + +subroutine mgbf_init(this) + class (mgbf_type),intent(in)::this +!*** +!*** Initialzie multigrid Beta filter +!*** + call this%mg_entrymod%mg_initialize + +end subroutine mgbf_init + +!*** +!*** From the analysis to first generation of filter grid +!*** + subroutine mgbf_apply(this,fieldset) + use mg_intstate,only: worka + use atlas_module, only: atlas_fieldset,atlas_field,atlas_functionspace + use mg_parameter, only: km,n0,nm,m0,mm + type(atlas_functionspace) :: afunctionspace + class (mgbf_type),intent(in):: this + type(atlas_field) :: afield + type(atlas_fieldset),intent(inout) :: fieldset !< Fieldset + real(kind=r_kind), pointer :: t(:,:) + integer(i_kind)::i,j,k,ij,ii,jj,nx,ny + nx=nm-n0+1 + ny=mm-m0+1 + afield = fieldset%field('air_temperature') + call afield%data(t) + do k=1,km + ij=1 + do jj=1,ny + do ii=1,nx + i=ii-n0+1 + j=jj-m0+1 + worka(k,i,j)=t(ij,k) + enddo + enddo + enddo + + + call this%mg_transfer%anal_to_filt_all !cltthink (fieldset) + + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +!*** +!*** Adjoint test if needed +!*** + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + +!*** +!*** Filtering +!*** +!====================================================================== + +!clt call mgbf_obj_in%mg_transfer%mg_filtering_procedure(mgbf_proc,fieldset) + call mg_filtering_procedure(mgbf_proc) !cltthink ,fieldset) + +!====================================================================== + +!*** +!*** From first generation of filter grid to analysis grid (x-directoin) +!*** + + call this%mg_transfer%filt_to_anal_all !cltthink (fieldset) + + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +!*** +!*** Adjoint test if needed +!*** + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +! Halo exchange + +afunctionspace = afield%functionspace() +call afunctionspace%halo_exchange(afield) + + + +!==================== Forward (Smoothing step) ======================== +!*** +!*** DONE! Deallocate variables +end subroutine mgbf_apply +!*** +subroutine mgbf_finalize(this) + class (mgbf_type),intent(in)::this + call this%mg_entrymod%mg_finalize +end subroutine mgbf_finalize + + +!----------------------------------------------------------------------- +end module type_mgbf_mod From 91197650e6b3f911b346081838f2d05c60e24e8d Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 6 Feb 2024 14:41:18 -0600 Subject: [PATCH 002/199] working on mgbf --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 41 +- src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 | 166 +- src/saber/mgbf/mgbf_lib/bak_type_bump.F90 | 2920 ----------------- src/saber/mgbf/mgbf_lib/jp_pbfil.f90 | 177 +- src/saber/mgbf/mgbf_lib/k.f90 | 206 -- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 956 +++--- .../{type_mg_domain.f90 => mg_domain.f90} | 80 +- src/saber/mgbf/mgbf_lib/mg_entrymod.f90 | 168 + src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 594 ++-- src/saber/mgbf/mgbf_lib/mg_generations.f90 | 561 ++-- ..._mg_interpolate.f90 => mg_interpolate.f90} | 296 +- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 1193 +++++++ .../{type_mg_mppstuff.f90 => mg_mppstuff.f90} | 68 +- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 996 ++++++ src/saber/mgbf/mgbf_lib/mg_timers.f90 | 186 ++ .../{type_mg_transfer.f90 => mg_transfer.f90} | 134 +- .../mgbf/mgbf_lib/type_intstat_locpointer.inc | 79 + .../mgbf/mgbf_lib/type_intstat_point2this.inc | 87 + src/saber/mgbf/mgbf_lib/type_mg_entrymod.f90 | 180 - src/saber/mgbf/mgbf_lib/type_mg_intstate.f90 | 437 --- src/saber/mgbf/mgbf_lib/type_mg_parameter.f90 | 610 ---- src/saber/mgbf/mgbf_lib/type_mgbf.f90 | 119 - .../mgbf_lib/type_parameter_locpointer.inc | 92 + .../mgbf_lib/type_parameter_point2this.inc | 230 ++ 24 files changed, 4741 insertions(+), 5835 deletions(-) delete mode 100644 src/saber/mgbf/mgbf_lib/bak_type_bump.F90 delete mode 100644 src/saber/mgbf/mgbf_lib/k.f90 rename src/saber/mgbf/mgbf_lib/{type_mg_domain.f90 => mg_domain.f90} (93%) create mode 100644 src/saber/mgbf/mgbf_lib/mg_entrymod.f90 rename src/saber/mgbf/mgbf_lib/{type_mg_interpolate.f90 => mg_interpolate.f90} (64%) create mode 100644 src/saber/mgbf/mgbf_lib/mg_intstate.f90 rename src/saber/mgbf/mgbf_lib/{type_mg_mppstuff.f90 => mg_mppstuff.f90} (78%) mode change 100755 => 100644 create mode 100644 src/saber/mgbf/mgbf_lib/mg_parameter.f90 create mode 100755 src/saber/mgbf/mgbf_lib/mg_timers.f90 rename src/saber/mgbf/mgbf_lib/{type_mg_transfer.f90 => mg_transfer.f90} (63%) create mode 100644 src/saber/mgbf/mgbf_lib/type_intstat_locpointer.inc create mode 100644 src/saber/mgbf/mgbf_lib/type_intstat_point2this.inc delete mode 100644 src/saber/mgbf/mgbf_lib/type_mg_entrymod.f90 delete mode 100755 src/saber/mgbf/mgbf_lib/type_mg_intstate.f90 delete mode 100755 src/saber/mgbf/mgbf_lib/type_mg_parameter.f90 delete mode 100755 src/saber/mgbf/mgbf_lib/type_mgbf.f90 create mode 100644 src/saber/mgbf/mgbf_lib/type_parameter_locpointer.inc create mode 100644 src/saber/mgbf/mgbf_lib/type_parameter_point2this.inc diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index a2ee9e34b..1667ac07f 100644 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -20,7 +20,7 @@ module mgbf_covariance_mod ! saber !clt use mgbf_grid_mod, only: mgbf_grid -use type_mgbf_mod, only: mgbf_type +use mg_intstate , only: mgbf_instate_type implicit none private @@ -29,7 +29,7 @@ module mgbf_covariance_mod ! Fortran class header type :: mgbf_covariance - type(mgbf_type) :: mgbf_driver + type(mgbf_instate_type) :: mgbf_instate logical :: noMGBF logical :: bypassMGBFbe logical :: cv ! cv=.true.; sv=.false. @@ -92,15 +92,14 @@ subroutine create(self, comm, config, background, firstguess) ! ---------------------------------------------- call config%get_or_die("mgbf berror namelist file", nml) call config%get_or_die("mgbf error covariance file", bef) + call self%mg_initialize("mgbeta.nml") ! Initialize MGBF-Berror components ! -------------------------------- - layout=self%grid%layout ! layout=-1 - call mgbfbclim_init(self%cv) endif #endif -call self%mgbf_driver%mgbf_init() +call self%mgbf_intstate%mg_initialize() ! Get background (temporary test of the functionality) !cltafield = background%field('air_temperature') !clt call afield%data(t) @@ -185,12 +184,40 @@ subroutine multiply(self, fields) ! Locals type(atlas_field) :: afield -real(kind=r_kind), pointer :: t(:,:) +real(kind=r_kind), pointer :: ttodo(:,:) !clt now noly consider t ! afield = fields%field('air_temperature') ! call afield%data(t) - call self%mgbf_driver%mgbf_apply(fields) +!*** From the analysis to first generation of filter grid +!*** + call btim( an2filt_tim) + + call self%anal_to_filt_all(ttodo) + call etim( an2filt_tim) + + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +!*** +!*** Adjoint test if needed +!*** + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + +!*** +!*** Filtering +!*** +!====================================================================== + + call self%mg_filtering_procedure(self%mgbf_proc) !clt to be changed +!*** From first generation of filter grid to analysis grid (x-directoin) +!*** + + call btim( filt2an_tim) + call obj_mgbf%filt_to_anal_all(ttodo) + + + ! Halo exchange !afunctionspace = afield%functionspace() !call afunctionspace%halo_exchange(afield) diff --git a/src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 b/src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 index b5772f461..68a8811a8 100755 --- a/src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 +++ b/src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 @@ -8,31 +8,60 @@ program RBETA_TEST !*********************************************************************** use mpi use kinds, only: r_kind,i_kind -use mg_entrymod, only: mg_initialize,mg_finalize -use mg_mppstuff, only: finishMPI,mype -use mg_filtering, only: mg_filtering_procedure -use mg_transfer, only: anal_to_filt_all,filt_to_anal_all -use mg_parameter, only: mgbf_proc +!clt use mg_entrymod, only: mg_initialize,mg_finalize +!clt use mg_mppstuff, only: finishMPI,mype +!clt use mg_filtering, only: mg_filtering_procedure +!clt use mg_transfer, only: anal_to_filt_all,filt_to_anal_all +!clt use mg_parameter, only: mgbf_proc +use mg_intstate use mg_timers +use mg_input implicit none +type (mg_intstate_type):: obj_mgbf +type (mg_intstate_type):: obj2_mgbf +real(r_kind), allocatable, dimension(:,:):: PA +real(r_kind), allocatable,dimension(:,:,:):: WORKA + integer :: mype,unitnum + character*4 :: file_str + integer(i_kind):: ierr !----------------------------------------------------------------------- call btim( total_tim) call btim( init_tim) + + call MPI_INIT(ierr) + !*** !*** Initialzie multigrid Beta filter +if(1.gt.0) then !*** - call mg_initialize + call obj_mgbf%mg_initialize("mgbeta.nml") + + call etim( init_tim) +!clt write(6,*)"worka dim ",obj_mgbf%km,obj_mgbf%n0,obj_mgbf%nm,obj_mgbf%m0,obj_mgbf%mm + allocate(WORKA(obj_mgbf%km,obj_mgbf%n0:obj_mgbf%nm,obj_mgbf%m0:obj_mgbf%mm)) ; WORKA=0. +if(obj_mgbf%ldelta) then + + allocate(PA(1:obj_mgbf%nm,1:obj_mgbf%mm)) + + PA = 0. + call input_spec1_2d(obj_mgbf, PA,obj_mgbf%nxm/2,obj_mgbf%mym/2,'md') - call etim( init_tim) +! WORKA(3*lm+1:4*lm,:,:)=0. + WORKA(3*obj_mgbf%lm+obj_mgbf%lm/2,:,:)=PA(:,:) + + +deallocate(PA) + +endif !*** !*** From the analysis to first generation of filter grid !*** call btim( an2filt_tim) - call anal_to_filt_all + call obj_mgbf%anal_to_filt_all(WORKA) call etim( an2filt_tim) @@ -48,7 +77,7 @@ program RBETA_TEST !*** !====================================================================== - call mg_filtering_procedure(mgbf_proc) + call obj_mgbf%mg_filtering_procedure(obj_mgbf%mgbf_proc) !clt to be changed !====================================================================== @@ -57,9 +86,24 @@ program RBETA_TEST !*** call btim( filt2an_tim) - call filt_to_anal_all + call obj_mgbf%filt_to_anal_all(WORKA) call etim( filt2an_tim) + mype=obj_mgbf%mype + unitnum=25+mype + write(6,*)WORKA(1,1,1) + write(file_str,"(I4.4)") mype + + open(unit=unitnum,file='mpi'//file_str//'version-worka.bin',access="sequential",form='unformatted',STATUS='replace') + write(unitnum)WORKA +!clt if(any(WORKA .gt.0.01)) then + if(mype==35) then + write(6,*)'thinkdebworka ',size(WORKA) + write(6,*)WORKA + call flush(6) + endif + + close (unitnum) !\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ !*** @@ -74,20 +118,116 @@ program RBETA_TEST !*** DONE! Deallocate variables !*** call btim( output_tim) - call mg_finalize + call obj_mgbf%mg_finalize call etim( output_tim) call etim( total_tim) + deallocate(WORKA) !*** !*** Print wall clock and cpu timing !*** - call print_mg_timers("timing_cpu.csv", print_cpu) +!clt for another obj2_mgbf +endif !1 gt 2 + + + +!clt call obj_mgbf%finishMPI + write(6,*)'thinkdeb to run for obj_2' + call MPI_BARRIER(MPI_COMM_WORLD,ierr) + call obj2_mgbf%mg_initialize("mgbeta.nml") + + write(6,*)"worka dim2 ",obj2_mgbf%km,obj2_mgbf%n0,obj2_mgbf%nm,obj2_mgbf%m0,obj2_mgbf%mm + allocate(WORKA(obj2_mgbf%km,obj2_mgbf%n0:obj2_mgbf%nm,obj2_mgbf%m0:obj2_mgbf%mm)) ; WORKA=0. +if(obj2_mgbf%ldelta) then + + allocate(PA(1:obj2_mgbf%nm,1:obj2_mgbf%mm)) + + PA = 0. + call input_spec1_2d(obj2_mgbf, PA,obj2_mgbf%nxm/2,obj2_mgbf%mym/2,'md') + +! WORKA(3*lm+1:4*lm,:,:)=0. + WORKA(3*obj2_mgbf%lm+obj2_mgbf%lm/2,:,:)=PA(:,:) + + +deallocate(PA) + +endif +!*** +!*** From the analysis to first generation of filter grid +!*** +! call btim( an2filt_tim) + + call obj2_mgbf%anal_to_filt_all(WORKA) + !call etim( an2filt_tim) + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +!*** +!*** Adjoint test if needed +!*** +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - call finishMPI +!*** +!*** Filtering +!*** +!====================================================================== + + call obj2_mgbf%mg_filtering_procedure(obj2_mgbf%mgbf_proc) !clt to be changed + +!====================================================================== + +!*** +!*** From first generation of filter grid to analysis grid (x-directoin) +!*** + +! call btim( filt2an_tim) + call obj2_mgbf%filt_to_anal_all(WORKA) + +! call etim( filt2an_tim) + mype=obj2_mgbf%mype + unitnum=25+mype + write(6,*)WORKA(1,1,1) + write(file_str,"(I4.4)") mype + + open(unit=unitnum,file='mpi'//file_str//'version-worka.bin',access="sequential",form='unformatted',STATUS='replace') + write(unitnum)WORKA +!clt if(any(WORKA .gt.0.01)) then + if(mype==35) then + write(6,*)'thinkdebworka2 ',size(WORKA) + write(6,*)WORKA + call flush(6) + endif + + close (unitnum) + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +!*** +!*** Adjoint test if needed +!*** + +!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + + +!==================== Forward (Smoothing step) ======================== +!*** +!*** DONE! Deallocate variables +!*** +! call btim( output_tim) + call obj2_mgbf%mg_finalize + +! call etim( output_tim) +! call etim( total_tim) + + +!*** +!*** Print wall clock and cpu timing +!*** + call print_mg_timers("version0-timing_cpu.csv", print_cpu, obj2_mgbf%mype) + + call MPI_FINALIZE(ierr) !----------------------------------------------------------------------- diff --git a/src/saber/mgbf/mgbf_lib/bak_type_bump.F90 b/src/saber/mgbf/mgbf_lib/bak_type_bump.F90 deleted file mode 100644 index f80d1adca..000000000 --- a/src/saber/mgbf/mgbf_lib/bak_type_bump.F90 +++ /dev/null @@ -1,2920 +0,0 @@ -# 1 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" -# 1 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/../instrumentation.fypp" 1 -# 1 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/../subr_list.fypp" 1 -!---------------------------------------------------------------------- -! Header: subr_list -!> Subroutines/functions list -! Author: Benjamin Menetrier -! Licensing: this code is distributed under the CeCILL-C license -! Copyright 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT -!---------------------------------------------------------------------- - -# 963 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/../subr_list.fypp" -# 2 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/../instrumentation.fypp" 2 -!---------------------------------------------------------------------- -! Header: instrumentation -!> Instrumentation functions -! Author: Benjamin Menetrier -! Licensing: this code is distributed under the CeCILL-C license -! Copyright 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT -!---------------------------------------------------------------------- - -# 112 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/../instrumentation.fypp" -# 2 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" 2 -!---------------------------------------------------------------------- -! Module: type_bump -!> BUMP derived type -! Author: Benjamin Menetrier -! Licensing: this code is distributed under the CeCILL-C license -! Copyright 2015-... UCAR, CERFACS, METEO-FRANCE and IRIT -!---------------------------------------------------------------------- -module type_bump - -use atlas_module, only: atlas_field,atlas_fieldset,atlas_integer,atlas_real,atlas_functionspace -use fckit_configuration_module, only: fckit_configuration -use fckit_mpi_module, only: fckit_mpi_comm,fckit_mpi_sum,fckit_mpi_min,fckit_mpi_max -use tools_const, only: zero,half,one,thousand,req,reqkm,deg2rad,rad2deg -use tools_func, only: fletcher32,sphere_dist,zss_maxval,zss_minval,zss_sum -use tools_kinds,only: kind_real -use tools_netcdf, only: registry -use tools_repro,only: repro,rth -use type_bpar, only: bpar_type -use type_cmat, only: cmat_type -use type_cv, only: cv_type -use type_ens, only: ens_type -use type_fieldset, only: fieldset_type -use type_geom, only: geom_type -use type_hdiag, only: hdiag_type -use type_mom, only: mom_type -use type_mpl, only: mpl_type -use type_nam, only: nam_type -use type_nicas, only: nicas_type - -use type_rng, only: rng_type -use type_samp, only: samp_type -use type_var, only: var_type -use type_vbal, only: vbal_type -use type_wind, only: wind_type - -implicit none - -integer,parameter :: dmsvali = -999 !< Default missing value for integers -real(kind_real),parameter :: dmsvalr = -999.0_kind_real !< Default missing value for reals -logical :: copy_ensemble = .false. !< Deep copy of ensemble members -real(kind_real),parameter :: loc_scaling_factor = one !< Scaling factor to get optimal localization -!real(kind_real),parameter :: loc_scaling_factor = 1.4_kind_real !< scaling factor to get optimal localization (TODO: check this and reset it) -integer,parameter :: nfac_opt = 4 !< Number of length-scale factors for optimization -integer,parameter :: ntest = 50 !< Number of test vectors - -! BUMP derived type -type bump_type - ! Derived types - type(bpar_type) :: bpar !< Block parameters - type(cmat_type),allocatable :: cmat(:) !< C matrix - type(ens_type),allocatable :: ens(:) !< Ensembles - type(geom_type),allocatable :: geom(:) !< Geometry - type(hdiag_type) :: hdiag !< Hybrid diagnostics - type(mom_type),allocatable :: mom(:) !< Moments - type(mpl_type) :: mpl !< MPI data - type(nam_type) :: nam !< Namelist - type(nicas_type),allocatable :: nicas(:) !< NICAS data - type(rng_type) :: rng !< Random number generator - type(samp_type),allocatable :: samp(:) !< Sampling - type(var_type) :: var !< Variance - type(vbal_type) :: vbal !< Vertical balance - type(wind_type) :: wind !< Wind - - ! Dummy variable - logical :: dummy_logical !< Dummy variable -contains - procedure :: create => bump_create - procedure :: setup => bump_setup - procedure :: second_geometry => bump_second_geometry - procedure :: add_member => bump_add_member - procedure :: update_vbal_cov => bump_update_vbal_cov - procedure :: update_var => bump_update_var - procedure :: update_mom => bump_update_mom - procedure :: run_drivers => bump_run_drivers - procedure :: check_consistency => bump_check_consistency - procedure :: check_optimality => bump_check_optimality - procedure :: apply_vbal => bump_apply_vbal - procedure :: apply_vbal_inv => bump_apply_vbal_inv - procedure :: apply_vbal_ad => bump_apply_vbal_ad - procedure :: apply_vbal_inv_ad => bump_apply_vbal_inv_ad - procedure :: apply_stddev => bump_apply_stddev - procedure :: apply_stddev_inv => bump_apply_stddev_inv - procedure :: apply_nicas => bump_apply_nicas - procedure :: get_cv_size => bump_get_cv_size - procedure :: apply_nicas_sqrt => bump_apply_nicas_sqrt - procedure :: apply_nicas_sqrt_ad => bump_apply_nicas_sqrt_ad - procedure :: randomize => bump_randomize - procedure :: psichi_to_uv => bump_psichi_to_uv - procedure :: psichi_to_uv_ad => bump_psichi_to_uv_ad - procedure :: get_ncmp => bump_get_ncmp - procedure :: get_parameter => bump_get_parameter - procedure :: test_get_parameter => bump_test_get_parameter - procedure :: set_ncmp => bump_set_ncmp - procedure :: set_parameter => bump_set_parameter - procedure :: test_set_parameter => bump_test_set_parameter - procedure :: test_apply_interfaces => bump_test_apply_interfaces - procedure :: partial_dealloc => bump_partial_dealloc - procedure :: dealloc => bump_dealloc - final :: bump_dummy_final -end type bump_type - -private -public :: bump_type - -contains - -!---------------------------------------------------------------------- -! Subroutine: bump_create -!> Create -!---------------------------------------------------------------------- -subroutine bump_create(bump,comm,afunctionspace,fieldset,conf,grid,universe_rad) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fckit_mpi_comm),intent(in) :: comm !< FCKIT MPI communicator wrapper -type(atlas_functionspace),intent(in) :: afunctionspace !< Function space -type(fieldset_type),intent(in) :: fieldset !< SABER geometry fields -type(fckit_configuration),intent(in) :: conf !< FCKIT configuration -type(fckit_configuration),intent(in) :: grid !< FCKIT grid configuration -type(fieldset_type),intent(in),optional :: universe_rad !< Fieldset optionally containing universe radius - -! Local variables -integer :: lmsvali, llunit -real(kind_real) :: lmsvalr - -! Set name - - -! Get instance - - -! Probe in - - -! Initialize namelist -call bump%nam%init(comm%size()) - -! Read grid configuration -call bump%nam%from_conf(comm,grid) - -! Read configuration -call bump%nam%from_conf(comm,conf) - -! Set missing values -lmsvali = dmsvali -lmsvalr = dmsvalr -if (conf%has('msvali')) call conf%get_or_die('msvali',lmsvali) -if (conf%has('msvalr')) call conf%get_or_die('msvalr',lmsvalr) - -! Set log unit -llunit = lmsvali -if (conf%has('lunit')) call conf%get_or_die('lunit',llunit) - -! Setup BUMP -if (present(universe_rad)) then - call bump%setup(comm,afunctionspace,fieldset,lunit=llunit,msvali=lmsvali,msvalr=lmsvalr,universe_rad=universe_rad) -else - call bump%setup(comm,afunctionspace,fieldset,lunit=llunit,msvali=lmsvali,msvalr=lmsvalr) -end if - -! Probe out - - -end subroutine bump_create - -!---------------------------------------------------------------------- -! Subroutine: bump_setup -!> Setup -!---------------------------------------------------------------------- -subroutine bump_setup(bump,f_comm,afunctionspace,fieldset,lunit,msvali,msvalr,universe_rad) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fckit_mpi_comm),intent(in) :: f_comm !< FCKIT MPI communicator wrapper -type(atlas_functionspace),intent(in) :: afunctionspace !< Functionspace -type(fieldset_type),intent(in),optional :: fieldset !< SABER geometry fields -integer,intent(in),optional :: lunit !< Listing unit -integer,intent(in),optional :: msvali !< Missing value for integers -real(kind_real),intent(in),optional :: msvalr !< Missing value for reals -type(fieldset_type),intent(in),optional :: universe_rad !< Fieldset optionally containing universe radius - -! Local variables -integer :: iv,il0,color,sc -real(kind_real),pointer :: ptr_1(:),ptr_2(:,:) -character(len=1024) :: cname -type(atlas_field) :: afield - -! Set name - - -! Get instance - - -! Probe in - - -! Initialize MPL -call bump%mpl%init(f_comm) - -! Set missing values -bump%mpl%msv%vali = dmsvali -bump%mpl%msv%valr = dmsvalr -if (present(msvali)) bump%mpl%msv%vali = msvali -if (present(msvalr)) bump%mpl%msv%valr = msvalr - -! Initialize listing -bump%mpl%lunit = bump%mpl%msv%vali -if (present(lunit)) bump%mpl%lunit = lunit -if ((.not.bump%mpl%main).and.bump%mpl%msv%is(bump%mpl%lunit)) bump%mpl%lunit = 10+bump%mpl%myproc -bump%mpl%verbosity = bump%nam%verbosity -if (bump%nam%colorlog) then - bump%mpl%black = char(27)//'[0;0m' - bump%mpl%green = char(27)//'[0;32m' - bump%mpl%peach = char(27)//'[1;91m' - bump%mpl%aqua = char(27)//'[1;36m' - bump%mpl%purple = char(27)//'[1;35m' - bump%mpl%err_color = char(27)//'[0;37;41;1m' - bump%mpl%wng_color = char(27)//'[0;37;42;1m' -else - bump%mpl%black = ' ' - bump%mpl%green = ' ' - bump%mpl%peach = ' ' - bump%mpl%aqua = ' ' - bump%mpl%purple = ' ' - bump%mpl%err_color = ' ' - bump%mpl%wng_color = ' ' -end if - -! Header -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- You are running the BUMP library ------------------------------' -call bump%mpl%flush - - -! Write parallel setup -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a,i3,a,i2,a)') '--- Parallelization with ',bump%mpl%nproc,' MPI tasks and ', & - & bump%mpl%nthread,' OpenMP threads' -call bump%mpl%flush - -if (present(universe_rad)) then - if (universe_rad%size()>0) then - ! Set universe radius - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Set universe radius' - call bump%mpl%flush - - ! Initialization - bump%nam%universe_rad = zero - - do iv=1,bump%nam%nv - ! Get field - afield = universe_rad%field(bump%nam%variables(iv)) - - ! Get data maximum - if (afield%rank()==1) then - call afield%data(ptr_1) - bump%nam%universe_rad = max(bump%nam%universe_rad,zss_maxval(ptr_1,mask=bump%mpl%msv%isnot(ptr_1))) - elseif (afield%rank()==2) then - call afield%data(ptr_2) - do il0=1,size(ptr_2,1) - if ((bump%nam%min_lev(iv)<=il0).and.(il0<=bump%nam%max_lev(iv))) & - & bump%nam%universe_rad = max(bump%nam%universe_rad,zss_maxval(ptr_2(il0,:),mask=bump%mpl%msv%isnot(ptr_2(il0,:)))) - end do - else - call bump%mpl%abort('bump_setup','cannot get universe radius for this field rank') - end if - end do - - ! Get global maximum - call bump%mpl%f_comm%allreduce(bump%nam%universe_rad,fckit_mpi_max()) - write(bump%mpl%info,'(a7,a,f10.2,a)') '','Universe radius: ',bump%nam%universe_rad/thousand,' km' - call bump%mpl%flush - end if -end if - -! Check namelist parameters -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- Check namelist parameters' -call bump%mpl%flush -call bump%nam%check(bump%mpl) -call bump%nam%write(bump%mpl) - -! Set I/O parameters -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- Set I/O parameters' -call bump%mpl%flush - -! Allocation -allocate(bump%mpl%pioproc(bump%mpl%nproc)) -allocate(bump%cmat(2)) -allocate(bump%ens(2)) -allocate(bump%geom(2)) -allocate(bump%mom(2)) -allocate(bump%nicas(2)) -allocate(bump%samp(2)) - -! Set I/O parameters -bump%mpl%datadir = bump%nam%datadir -bump%mpl%parallel_io = bump%nam%parallel_io -bump%mpl%nprocio = bump%nam%nprocio -bump%mpl%pioproc = .false. -if (bump%mpl%parallel_io) then - bump%mpl%pioproc(1:min(bump%mpl%nprocio,bump%mpl%nproc)) = .true. -else - bump%mpl%pioproc(bump%mpl%rootproc) = .true. -end if -if (bump%mpl%main) call system_clock(sc) -call bump%mpl%f_comm%broadcast(sc,bump%mpl%rootproc-1) -if (bump%mpl%pioproc(bump%mpl%myproc)) then - color = 1 - write(cname,'(a,i12.12)') trim(bump%mpl%f_comm%name())//'_'//trim(bump%nam%prefix)//'_io_',sc -else - color = 0 - write(cname,'(a,i12.12)') trim(bump%mpl%f_comm%name())//'_'//trim(bump%nam%prefix)//'_no_io_',sc -endif -bump%mpl%f_comm_io = bump%mpl%f_comm%split(color,cname) - -! Set reproducibility parameters -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- Set reproducibility parameters' -call bump%mpl%flush -repro = bump%nam%repro -rth = bump%nam%rth - -! Initialize random number generator -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- Initialize random number generator' -call bump%mpl%flush -call bump%rng%init(bump%mpl,bump%nam) - -! Initialize allocation flags -bump%geom(1)%allocated = .false. -bump%geom(2)%allocated = .false. -bump%cmat(1)%allocated = .false. -bump%cmat(2)%allocated = .false. -bump%nicas(1)%allocated = .false. -bump%nicas(2)%allocated = .false. - -! Initialize geometry -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- Initialize geometry' -call bump%mpl%flush -if (present(fieldset)) then - call bump%geom(1)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace,fieldset) -else - call bump%geom(1)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace) -end if -if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - -! Initialize block parameters -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- Initialize block parameters' -call bump%mpl%flush -call bump%bpar%alloc(bump%nam,bump%geom(1)) -call bump%bpar%init(bump%mpl,bump%nam,bump%geom(1)) - -if (bump%nam%ens1_ne>0) then - ! Initialize ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Initialize ensemble 1' - call bump%mpl%flush - call bump%ens(1)%set_att(bump%nam%ens1_ne,bump%nam%ens1_nsub) -end if - -if (bump%nam%ens2_ne>0) then - ! Initialize ensemble 2 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Initialize ensemble 2' - call bump%mpl%flush - call bump%ens(2)%set_att(bump%nam%ens2_ne,bump%nam%ens2_nsub) -end if - -! Probe out - - -end subroutine bump_setup - -!---------------------------------------------------------------------- -! Subroutine: bump_second_geometry -!> Initialize second geometry -!---------------------------------------------------------------------- -subroutine bump_second_geometry(bump,afunctionspace,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(atlas_functionspace),intent(in) :: afunctionspace !< ATLAS functionspace -type(fieldset_type),intent(in),optional :: fieldset !< Fieldset containing geometry elements - -! Set name - - -! Get instance - - -! Probe in - - -! Initialize second geometry -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- Initialize second geometry' -call bump%mpl%flush -if (present(fieldset)) then - call bump%geom(2)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace,fieldset) -else - call bump%geom(2)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace) -end if -if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - -! Check consistency between geometries -if (bump%geom(1)%nl0/=bump%geom(2)%nl0) call bump%mpl%abort('${subr}','both geometries should have the same number of levels') - -! Probe out - - -end subroutine bump_second_geometry - -!---------------------------------------------------------------------- -! Subroutine: bump_add_member -!> Add member into bump%ens[1,2] -!---------------------------------------------------------------------- -subroutine bump_add_member(bump,fieldset,ie,iens) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(in) :: fieldset !< Fieldset -integer,intent(in) :: ie !< Member index -integer,intent(in) :: iens !< Ensemble number - -! Local variables -integer :: ne,nsub - -! Set name - - -! Get instance - - -! Probe in - - -! Check ensemble number -if (iens==1) then - ne = bump%nam%ens1_ne - nsub = bump%nam%ens1_nsub -elseif (iens==2) then - ne = bump%nam%ens2_ne - nsub = bump%nam%ens2_nsub -else - call bump%mpl%abort('bump_add_member','wrong ensemble number') -end if - -! Allocation -if (.not.bump%ens(iens)%loaded) call bump%ens(iens)%alloc(ne,nsub) -bump%ens(iens)%loaded = .true. - -if (copy_ensemble) then - ! Copy fields - call bump%ens(iens)%mem(ie)%init(bump%mpl,fieldset,bump%geom(iens)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d, & - & copy=.true.) -else - ! Pass fields - call bump%ens(iens)%mem(ie)%init(bump%mpl,fieldset,bump%geom(iens)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d, & - & pass=.true.) -end if - -! Print norm -!write(bump%mpl%info,'(a,i6,a)') 'Ensemble 1 member ',ie,': ' -!call bump%mpl%flush -!call bump%ens(iens)%mem(ie)%print(bump%mpl) - -! Probe out - - -end subroutine bump_add_member - -!---------------------------------------------------------------------- -! Subroutine: bump_update_vbal_cov -!> Update vertical covariances, one member at a time -!---------------------------------------------------------------------- -subroutine bump_update_vbal_cov(bump,fieldset,ie) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset -integer,intent(in) :: ie !< Member index - -! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) - -! Set name - - -! Get instance index - - -! Probe in - - -if (ie==1) then - ! Setup sampling - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Setup sampling' - call bump%mpl%flush - call bump%samp(1)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(1)) - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) -end if - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Update vertical covariances -call bump%vbal%cov_update(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),fld_c0a,ie) - -! Probe out - - -end subroutine bump_update_vbal_cov - -!---------------------------------------------------------------------- -! Subroutine: bump_update_var -!> Update variance, one member at a time -!---------------------------------------------------------------------- -subroutine bump_update_var(bump,fieldset,ie) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset -integer,intent(in) :: ie !< Member index - -! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) - -! Set name - - -! Get instance index - - -! Probe in - - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Update variance -call bump%var%update(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,fld_c0a,ie) -if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - -! Probe out - - -end subroutine bump_update_var - -!---------------------------------------------------------------------- -! Subroutine: bump_update_mom -!> Update moments, one member at a time -!---------------------------------------------------------------------- -subroutine bump_update_mom(bump,fieldset,ie,iens) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset -integer,intent(in) :: ie !< Member index -integer,intent(in) :: iens !< Ensemble number - -! Local variable -real(kind_real) :: fld_c0a(bump%geom(iens)%nc0a,bump%geom(iens)%nl0,bump%nam%nv) -character(len=4) :: momname - -! Set name - - -! Get instance index - - -! Probe in - - -! Check ensemble number -if ((iens/=1).and.(iens/=2)) call bump%mpl%abort('bump_update_mom','wrong ensemble number') - -if (ie==1) then - ! Setup sampling - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a,i1)') '--- Setup sampling for ensemble ',iens - call bump%mpl%flush - if (iens==1) then - call bump%samp(iens)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(iens)) - elseif (iens==2) then - call bump%samp(iens)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(iens),other=bump%samp(1)) - end if - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) -end if - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(iens)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(iens)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Update moments -write(momname,'(a,i1)') 'mom',iens -call bump%mom(iens)%update(bump%mpl,bump%nam,bump%geom(iens),bump%bpar,bump%samp(iens),momname,fld_c0a,ie,iens) - -! Probe out - - -end subroutine bump_update_mom - -!---------------------------------------------------------------------- -! Subroutine: bump_run_drivers -!> Run drivers -!---------------------------------------------------------------------- -subroutine bump_run_drivers(bump) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP - -! Set name - - -! Get instance - - -! Probe in - - -if (bump%nam%check_consistency.or.bump%nam%check_optimality) then - ! Copy namelist support radii into C matrix, ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Copy namelist support radii into C matrix, ensemble 1' - call bump%mpl%flush - call bump%cmat(1)%from_nam(bump%mpl,bump%nam,bump%geom(1),bump%bpar) - - ! Setup C matrix sampling, ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Setup C matrix sampling, ensemble 1' - call bump%mpl%flush - call bump%cmat(1)%setup_sampling(bump%mpl,bump%nam,bump%geom(1),bump%bpar) - - ! Run NICAS driver, ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run NICAS driver, ensemble 1' - call bump%mpl%flush - call bump%nicas(1)%run_nicas(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,bump%cmat(1)) - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - - ! Randomize ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a,i6,a)') '--- Randomize ensemble 1 (',bump%nam%ens1_ne,' members)' - call bump%mpl%flush - call bump%nicas(1)%gen_ens_pert(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,bump%nam%ens1_ne,bump%ens(1)) - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - - ! Release memory - call bump%cmat(1)%dealloc -end if - -if (bump%nam%ens1_ne>0.and.bump%ens(1)%loaded) then - ! Compute mean for ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Compute mean for ensemble 1' - call bump%mpl%flush - call bump%ens(1)%compute_mean(bump%mpl,bump%nam,bump%geom(1)) -end if - -if (bump%nam%ens2_ne>0.and.bump%ens(2)%loaded) then - ! Compute mean for ensemble 2 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Compute mean for ensemble 2' - call bump%mpl%flush - call bump%ens(2)%compute_mean(bump%mpl,bump%nam,bump%geom(2)) -end if - -if (bump%nam%new_normality) then - ! Run normality tests - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run normality tests' - call bump%mpl%flush - call bump%ens(1)%normality(bump%mpl,bump%nam,bump%geom(1)) -end if - -if (bump%nam%new_vbal_cov.or.bump%nam%load_vbal_cov.or.(bump%nam%new_vbal.and.(.not.bump%nam%update_vbal_cov)) & - & .or.bump%nam%load_vbal.or.bump%nam%new_mom.or.bump%nam%load_mom) then - ! Setup sampling for ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Setup sampling for ensemble 1' - call bump%mpl%flush - call bump%samp(1)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%ens(1)) - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - - if (bump%geom(2)%allocated) then - ! Setup sampling for ensemble 2 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Setup sampling for ensemble 2' - call bump%mpl%flush - call bump%samp(2)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(2),bump%ens(2),bump%samp(1)) - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - end if -end if - -if (bump%nam%new_vbal_cov) then - ! Run vertical covariance driver - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run vertical covariances driver' - call bump%mpl%flush - call bump%vbal%cov_run(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%ens(1)) -elseif (bump%nam%load_vbal_cov) then - ! Read vertical balance - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Read vertical covariances' - call bump%mpl%flush - if (bump%nam%load_samp_local) then - call bump%vbal%cov_read_local(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%nam%ens1_nsub) - elseif (bump%nam%load_samp_global) then - call bump%vbal%cov_read_global(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%nam%ens1_nsub) - end if -end if - -if (bump%nam%new_vbal) then - ! Run vertical balance driver - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run vertical balance driver' - call bump%mpl%flush - call bump%vbal%run_vbal(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%ens(1)) -elseif (bump%nam%load_vbal) then - ! Read vertical balance - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Read vertical balance' - call bump%mpl%flush - if (bump%nam%load_samp_local) then - call bump%vbal%read_local(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1)) - elseif (bump%nam%load_samp_global) then - call bump%vbal%read_global(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1)) - end if -end if - -if (bump%nam%new_vbal.or.bump%nam%load_vbal) then - ! Run vertical balance tests driver - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run vertical balance tests driver' - call bump%mpl%flush - call bump%vbal%run_vbal_tests(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar) - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) -end if - -if (bump%nam%new_var.or.bump%nam%load_var.or.(bump%var%bump_m2_counter>0)) then - ! Run variance driver - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run variance driver' - call bump%mpl%flush - call bump%var%run_var(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,bump%ens(1)) - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) -end if - -if (bump%nam%new_mom) then - ! Compute sample moments - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Compute sample moments' - call bump%mpl%flush - - ! Compute ensemble 1 sample moments - write(bump%mpl%info,'(a7,a)') '','Ensemble 1:' - call bump%mpl%flush - call bump%mom(1)%compute(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%ens(1),'mom1') - - select case(trim(bump%nam%method)) - case ('hyb-rnd','hyb-ens') - ! Compute ensemble 2 sample moments - write(bump%mpl%info,'(a7,a)') '','Ensemble 2:' - call bump%mpl%flush - call bump%mom(2)%compute(bump%mpl,bump%nam,bump%geom(2),bump%bpar,bump%samp(2),bump%ens(2),'mom2') - end select -elseif (bump%nam%load_mom) then - ! Load sample moments - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Load sample moments' - call bump%mpl%flush - - ! Load ensemble 1 sample moments - write(bump%mpl%info,'(a7,a)') '','Ensemble 1' - call bump%mpl%flush - call bump%mom(1)%read(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%samp(1),bump%ens(1),'mom1') - - select case(trim(bump%nam%method)) - case ('hyb-rnd','hyb-ens') - ! Load ensemble 2 sample moments - write(bump%mpl%info,'(a7,a)') '','Ensemble 2' - call bump%mpl%flush - call bump%mom(2)%read(bump%mpl,bump%nam,bump%geom(2),bump%bpar,bump%samp(2),bump%ens(2),'mom2') - end select -end if - -if (bump%nam%new_hdiag) then - ! Run HDIAG driver - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run HDIAG driver' - call bump%mpl%flush - call bump%hdiag%run_hdiag(bump%mpl,bump%nam,bump%geom,bump%bpar,bump%samp,bump%mom) -end if - -if (bump%nam%check_consistency) then - ! Check HDIAG/NICAS consistency - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Check HDIAG/NICAS consistency' - call bump%mpl%flush - call bump%check_consistency -end if - -if (bump%nam%check_set_param) then - ! Test set_parameter interfaces - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Test set_parameter interfaces' - call bump%mpl%flush() - call bump%test_set_parameter - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) -end if - -if (allocated(bump%cmat(1)%blk)) then - ! Get C matrix from BUMP interface, ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Get C matrix from BUMP interface, ensemble 1' - call bump%mpl%flush - call bump%cmat(1)%from_bump(bump%mpl,bump%geom(1),bump%bpar) -end if - -if (.not.bump%nam%check_optimality) then - ! Copy namelist support radii into C matrix, ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Copy namelist support radii into C matrix, ensemble 1' - call bump%mpl%flush - call bump%cmat(1)%from_nam(bump%mpl,bump%nam,bump%geom(1),bump%bpar) -end if - -if (bump%nam%new_hdiag) then - ! Copy HDIAG into C matrix, ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Copy HDIAG into C matrix, ensemble 1' - call bump%mpl%flush - select case(trim(bump%nam%method)) - case ('cor') - call bump%cmat(1)%from_hdiag(bump%mpl,bump%geom(1),bump%bpar,bump%hdiag%cor(1)) - case ('loc','hyb-avg','hyb-rnd','hyb-ens') - call bump%cmat(1)%from_hdiag(bump%mpl,bump%geom(1),bump%bpar,bump%hdiag%loc(1),loc_scaling_factor) - end select - - select case(trim(bump%nam%method)) - case ('hyb-ens') - ! Copy HDIAG into C matrix, ensemble 2 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Copy HDIAG into C matrix, ensemble 2' - call bump%mpl%flush - call bump%cmat(2)%from_hdiag(bump%mpl,bump%geom(2),bump%bpar,bump%hdiag%loc(2),loc_scaling_factor) - end select -end if - -if (bump%cmat(1)%allocated) then - ! Setup C matrix sampling, ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Setup C matrix sampling, ensemble 1' - call bump%mpl%flush - call bump%cmat(1)%setup_sampling(bump%mpl,bump%nam,bump%geom(1),bump%bpar) -end if - -if (bump%cmat(2)%allocated) then - ! Setup C matrix sampling, ensemble 2 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Setup C matrix sampling, ensemble 2' - call bump%mpl%flush - call bump%cmat(2)%setup_sampling(bump%mpl,bump%nam,bump%geom(2),bump%bpar) -end if - -if (bump%nam%new_nicas.or.bump%nam%load_nicas_global) then - ! Run NICAS driver, ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run NICAS driver, ensemble 1' - call bump%mpl%flush - call bump%nicas(1)%run_nicas(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,bump%cmat(1)) - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - - if (bump%nam%new_nicas.and.(trim(bump%nam%method)=='hyb-ens')) then - ! Run NICAS driver, ensemble 2 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run NICAS driver, ensemble 2' - call bump%mpl%flush - call bump%nicas(2)%run_nicas(bump%mpl,bump%rng,bump%nam,bump%geom(2),bump%bpar,bump%cmat(2)) - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - end if -elseif (bump%nam%load_nicas_local) then - ! Read local NICAS parameters, ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Read local NICAS parameters, ensemble 1' - call bump%mpl%flush - call bump%nicas(1)%read_local(bump%mpl,bump%nam,bump%geom(1),bump%bpar) -end if - -if (bump%nam%check_optimality) then - ! Check HDIAG/NICAS optimality - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Check HDIAG/NICAS optimality' - call bump%mpl%flush - call bump%check_optimality -end if - -! Release memory (partial) -call bump%cmat(1)%partial_dealloc -call bump%cmat(2)%partial_dealloc - -if (bump%nam%new_nicas.or.bump%nam%load_nicas_local.or.bump%nam%load_nicas_global) then - ! Run NICAS tests driver, ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run NICAS tests driver, ensemble 1' - call bump%mpl%flush - call bump%nicas(1)%run_nicas_tests(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%bpar,bump%ens(1)) - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - - if (bump%nam%new_nicas.and.(trim(bump%nam%method)=='hyb-ens')) then - ! Run NICAS tests driver, ensemble 2 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run NICAS tests driver, ensemble 2' - call bump%mpl%flush - call bump%nicas(2)%run_nicas_tests(bump%mpl,bump%rng,bump%nam,bump%geom(2),bump%bpar,bump%ens(2)) - if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - end if -end if - -if (bump%nam%new_wind.or.bump%nam%load_wind_local) then - ! Run psi/chi to u/v driver - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run psi/chi to u/v driver' - call bump%mpl%flush - call bump%wind%setup(bump%mpl,bump%rng,bump%nam,bump%geom(1)) -end if - -! Probe out - - -end subroutine bump_run_drivers - -!---------------------------------------------------------------------- -! Subroutine: bump_check_consistency -!> Check HDIAG/NICAS consistency -!---------------------------------------------------------------------- -subroutine bump_check_consistency(bump) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP - -! Local variables -integer :: ib,il0,iv -real(kind_real) :: rh_diag,rv_diag - -! Set name - - -! Get instance - - -! Probe in - - -do ib=1,bump%bpar%nbe - if (bump%bpar%nicas_block(ib)) then - write(bump%mpl%info,'(a7,a)') '','Block: '//trim(bump%bpar%blockname(ib)) - call bump%mpl%flush - iv = bump%bpar%b_to_v1(ib) - do il0=1,bump%geom(1)%nl0 - rh_diag = -one - rv_diag = -one - if (bump%nam%rh(il0,iv)>zero) rh_diag = bump%hdiag%cor(1)%blk(0,ib)%rh_l0(il0,1)/bump%nam%rh(il0,iv) - if (bump%nam%rv(il0,iv)>zero) rv_diag = bump%hdiag%cor(1)%blk(0,ib)%rv_l0(il0,1)/bump%nam%rv(il0,iv) - write(bump%mpl%info,'(a10,a,i3,a,f6.3,a,f6.3)') '','Level ',bump%nam%levs(il0),' ~> ',rh_diag,' / ',rv_diag - call bump%mpl%flush - end do - end if -end do - -! Probe out - - -end subroutine bump_check_consistency - -!---------------------------------------------------------------------- -! Subroutine: bump_check_optimality -!> Check HDIAG/NICAS localization optimality -!---------------------------------------------------------------------- -subroutine bump_check_optimality(bump) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP - -! Local variables -integer :: ib,ifac,ifac_best,itest -real(kind_real) :: fac(-nfac_opt:nfac_opt),mse(ntest,-nfac_opt:nfac_opt),mse_avg(-nfac_opt:nfac_opt) -real(kind_real) :: fld_ref(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv,ntest) -real(kind_real) :: fld_save(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv,ntest) -real(kind_real) :: fld(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) -type(nicas_type) :: nicas_test - -! Set name - - -! Get instance - - -! Probe in - - -! Define test vectors -write(bump%mpl%info,'(a4,a)') '','Define test vectors' -call bump%mpl%flush -call bump%geom(1)%define_test_vectors(bump%mpl,bump%rng,bump%nam,ntest,fld_save) -if (bump%nam%default_seed) call bump%rng%reseed(bump%mpl) - -! Apply correlation operator to test vectors -write(bump%mpl%info,'(a4,a)') '','Apply correlation operator to test vectors' -call bump%mpl%flush -fld_ref = fld_save -do itest=1,ntest - call bump%nicas(1)%apply(bump%mpl,bump%nam,bump%geom(1),bump%bpar,fld_ref(:,:,:,itest)) -end do - -! Reduce ensemble size -bump%ens(1)%ne = bump%nam%ne - -! Compute mean for ensemble 1 -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- Compute mean for ensemble 1' -call bump%mpl%flush -call bump%ens(1)%compute_mean(bump%mpl,bump%nam,bump%geom(1)) - -do ifac=-nfac_opt,nfac_opt - ! Multiplication factor - fac(ifac) = one+0.05_kind_real*real(ifac,kind_real) - - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a,f4.2,a)') '--- Generate NICAS with a multiplicative factor ',fac(ifac),' to length-scales' - call bump%mpl%flush - - ! Allocation - call nicas_test%alloc(bump%bpar) - - do ib=1,bump%bpar%nbe - if (bump%bpar%nicas_block(ib)) then - write(bump%mpl%info,'(a)') '--- Block: '//trim(bump%bpar%blockname(ib)) - call bump%mpl%flush - - ! Length-scales scaling - bump%cmat(1)%blk(ib)%rhs = bump%cmat(1)%blk(ib)%rhs*fac(ifac) - bump%cmat(1)%blk(ib)%rvs = bump%cmat(1)%blk(ib)%rvs*fac(ifac) - bump%cmat(1)%blk(ib)%rh = bump%cmat(1)%blk(ib)%rh*fac(ifac) - bump%cmat(1)%blk(ib)%rv = bump%cmat(1)%blk(ib)%rv*fac(ifac) - - ! Copy length-scales - call nicas_test%blk(ib)%copy_cmat(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%cmat(1)%blk(ib)) - - ! Compute NICAS parameters - call nicas_test%blk(ib)%compute_parameters(bump%mpl,bump%rng,bump%nam,bump%geom(1)) - - ! Length-scales inverse scaling - bump%cmat(1)%blk(ib)%rhs = bump%cmat(1)%blk(ib)%rhs/fac(ifac) - bump%cmat(1)%blk(ib)%rvs = bump%cmat(1)%blk(ib)%rvs/fac(ifac) - bump%cmat(1)%blk(ib)%rh = bump%cmat(1)%blk(ib)%rh/fac(ifac) - bump%cmat(1)%blk(ib)%rv = bump%cmat(1)%blk(ib)%rv/fac(ifac) - end if - end do - - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Apply small ensemble with localization to test vectors' - call bump%mpl%flush - - do itest=1,ntest - ! Apply localized ensemble - fld = fld_save(:,:,:,itest) - call nicas_test%apply_bens(bump%mpl,bump%nam,bump%geom(1),bump%bpar,bump%ens(1),fld) - - ! RMSE - mse(itest,ifac) = zss_sum((fld-fld_ref(:,:,:,itest))**2,mask=bump%mpl%msv%isnot(fld_ref(:,:,:,itest))) - call bump%mpl%f_comm%allreduce(mse(itest,ifac),fckit_mpi_sum()) - end do - mse_avg(ifac) = sum(mse(:,ifac))/real(ntest,kind_real) - - ! Print scores - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a,f4.2,a,e15.8)') '--- Optimality results for a factor ',fac(ifac),', MSE: ',mse_avg(ifac) - call bump%mpl%flush - - ! Release memory - call nicas_test%dealloc -end do - -! Print scores summary -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- Optimality results summary' -call bump%mpl%flush -ifac_best = minloc(mse_avg,dim=1)-(nfac_opt+1) -do ifac=-nfac_opt,nfac_opt - write(bump%mpl%info,'(a7,a,f4.2,a,e15.8)') '','Factor ',fac(ifac),', MSE: ',mse_avg(ifac) - call bump%mpl%flush(.false.) - if (ifac==ifac_best) then - write(bump%mpl%info,'(a)') ' <~ best localization' - else - write(bump%mpl%info,'(a)') '' - end if - call bump%mpl%flush() -end do - -! Probe out - - -end subroutine bump_check_optimality - -!---------------------------------------------------------------------- -! Subroutine: bump_apply_vbal -!> Vertical balance application -!---------------------------------------------------------------------- -subroutine bump_apply_vbal(bump,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) - -! Set name - - -! Get instance - - -! Probe in - - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Apply vertical balance -call bump%vbal%apply(bump%nam,bump%geom(1),bump%bpar,fld_c0a) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - -! Probe out - - -end subroutine bump_apply_vbal - -!---------------------------------------------------------------------- -! Subroutine: bump_apply_vbal_inv -!> Vertical balance application, inverse -!---------------------------------------------------------------------- -subroutine bump_apply_vbal_inv(bump,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) - -! Set name - - -! Get instance - - -! Probe in - - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Apply vertical balance, inverse -call bump%vbal%apply_inv(bump%nam,bump%geom(1),bump%bpar,fld_c0a) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - -! Probe out - - -end subroutine bump_apply_vbal_inv - -!---------------------------------------------------------------------- -! Subroutine: bump_apply_vbal_ad -!> Vertical balance application, adjoint -!---------------------------------------------------------------------- -subroutine bump_apply_vbal_ad(bump,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) - -! Set name - - -! Get instance - - -! Probe in - - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Apply vertical balance, adjoint -call bump%vbal%apply_ad(bump%nam,bump%geom(1),bump%bpar,fld_c0a) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - -! Probe out - - -end subroutine bump_apply_vbal_ad - -!---------------------------------------------------------------------- -! Subroutine: bump_apply_vbal_inv_ad -!> Vertical balance application, inverse adjoint -!---------------------------------------------------------------------- -subroutine bump_apply_vbal_inv_ad(bump,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) - -! Set name - - -! Get instance - - -! Probe in - - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Apply vertical balance, inverse adjoint -call bump%vbal%apply_inv_ad(bump%nam,bump%geom(1),bump%bpar,fld_c0a) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - -! Probe out - - -end subroutine bump_apply_vbal_inv_ad - -!---------------------------------------------------------------------- -! Subroutine: bump_apply_stddev -!> Standard-deviation application -!---------------------------------------------------------------------- -subroutine bump_apply_stddev(bump,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) - -! Set name - - -! Get instance - - -! Probe in - - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Apply standard-deviation -call bump%var%apply_sqrt(bump%mpl,bump%nam,bump%geom(1),fld_c0a) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - -! Probe out - - -end subroutine bump_apply_stddev - -!---------------------------------------------------------------------- -! Subroutine: bump_apply_stddev_inv -!> Standard-deviation application, inverse -!---------------------------------------------------------------------- -subroutine bump_apply_stddev_inv(bump,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) - -! Set name - - -! Get instance - - -! Probe in - - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Apply standard-deviation -call bump%var%apply_sqrt_inv(bump%mpl,bump%nam,bump%geom(1),fld_c0a) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - -! Probe out - - -end subroutine bump_apply_stddev_inv - -!---------------------------------------------------------------------- -! Subroutine: bump_apply_nicas -!> NICAS application -!---------------------------------------------------------------------- -subroutine bump_apply_nicas(bump,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) - -! Set name - - -! Get instance - - -! Probe in - - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Apply NICAS -call bump%nicas(1)%apply(bump%mpl,bump%nam,bump%geom(1),bump%bpar,fld_c0a) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - -! Probe out - - -end subroutine bump_apply_nicas - -!---------------------------------------------------------------------- -! Subroutine: bump_get_cv_size -!> Get control variable size -!---------------------------------------------------------------------- -subroutine bump_get_cv_size(bump,n) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -integer,intent(out) :: n !< Control variable size - -! Local variables -type(cv_type) :: cv - -! Set name - - -! Get instance - - -! Probe in - - -! Allocate control variable -call bump%nicas(1)%alloc_cv(bump%mpl,bump%bpar,cv,getsizeonly=.true.) - -! Copy size -n = cv%n - -! Probe out - - -end subroutine bump_get_cv_size - -!---------------------------------------------------------------------- -! Subroutine: bump_apply_nicas_sqrt -!> NICAS square-root application -!---------------------------------------------------------------------- -subroutine bump_apply_nicas_sqrt(bump,pcv,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -real(kind_real),intent(in) :: pcv(:) !< Packed control variable -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variable -integer :: ic0a,il0,iv -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) -type(cv_type) :: cv - -! Set name - - -! Get instance - - -! Probe in - - -! Allocation -call bump%nicas(1)%alloc_cv(bump%mpl,bump%bpar,cv) - -! Check dimension -if (size(pcv)==cv%n) then - ! Unpack control variable - call cv%unpack(pcv) -else - call bump%mpl%abort('bump_apply_nicas_sqrt','wrong control variable size') -end if - -! Apply NICAS square-root -call bump%nicas(1)%apply_sqrt(bump%mpl,bump%nam,bump%geom(1),bump%bpar,cv,fld_c0a) - -! Set missing unmasked values to zero -do iv=1,bump%nam%nv - do il0=1,bump%geom(1)%nl0 - do ic0a=1,bump%geom(1)%nc0a - if (bump%mpl%msv%is(fld_c0a(ic0a,il0,iv)).and.(.not.bump%geom(1)%gmask_c0a(ic0a,il0))) fld_c0a(ic0a,il0,iv) = zero - end do - end do -end do - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - -! Probe out - - -end subroutine bump_apply_nicas_sqrt - -!---------------------------------------------------------------------- -! Subroutine: bump_apply_nicas_sqrt_ad -!> NICAS square-root adjoint application -!---------------------------------------------------------------------- -subroutine bump_apply_nicas_sqrt_ad(bump,fieldset,pcv) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset -real(kind_real),intent(inout) :: pcv(:) !< Packed control variable - -! Local variables -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) -type(cv_type) :: cv - -! Set name - - -! Get instance - - -! Probe in - - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Apply NICAS square-root adjoint -call bump%nicas(1)%apply_sqrt_ad(bump%mpl,bump%nam,bump%geom(1),bump%bpar,fld_c0a,cv) - -! Check dimension -if (size(pcv)==cv%n) then - ! Pack control variable - call cv%pack(pcv) -else - call bump%mpl%abort('bump_apply_nicas_sqrt_ad','wrong control variable size') -end if - -! Probe out - - -end subroutine bump_apply_nicas_sqrt_ad - -!---------------------------------------------------------------------- -! Subroutine: bump_randomize -!> NICAS randomization -!---------------------------------------------------------------------- -subroutine bump_randomize(bump,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) -type(cv_type) :: cv - -! Set name - - -! Get instance - - -! Probe in - - -! Generate random control vector -call bump%nicas(1)%random_cv(bump%mpl,bump%rng,bump%bpar,cv) - -! Apply NICAS square-root -call bump%nicas(1)%apply_sqrt(bump%mpl,bump%nam,bump%geom(1),bump%bpar,cv,fld_c0a) - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - -! Probe out - - -end subroutine bump_randomize - -!---------------------------------------------------------------------- -! Subroutine: bump_psichi_to_uv -!> psi/chi to u/v transform -!---------------------------------------------------------------------- -subroutine bump_psichi_to_uv(bump,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variable -integer :: iv,iv_psi,iv_chi,iv_ua,iv_va -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) -type(atlas_field) :: afield - -! Set name - - -! Get instance - - -! Probe in - - -! Get u/v variables in fieldset or create and add them -if (fieldset%has_field(bump%nam%wind_zonal)) then - afield = fieldset%field(bump%nam%wind_zonal) -else - afield = bump%geom(1)%afunctionspace_mg%create_field(name=bump%nam%wind_zonal,kind=atlas_real(kind_real), & - & levels=bump%geom(1)%nl0) - call fieldset%add(afield) -end if -if (fieldset%has_field(bump%nam%wind_meridional)) then - afield = fieldset%field(bump%nam%wind_meridional) -else - afield = bump%geom(1)%afunctionspace_mg%create_field(name=bump%nam%wind_meridional,kind=atlas_real(kind_real), & - & levels=bump%geom(1)%nl0) - call fieldset%add(afield) -end if - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Get psi/chi/ua/va indices -do iv=1,bump%nam%nv - if (bump%nam%variables(iv)==bump%nam%wind_streamfunction) iv_psi = iv - if (bump%nam%variables(iv)==bump%nam%wind_velocity_potential) iv_chi = iv - if (bump%nam%variables(iv)==bump%nam%wind_zonal) iv_ua = iv - if (bump%nam%variables(iv)==bump%nam%wind_meridional) iv_va = iv -end do - -! Transform psi/chi to u/v -call bump%wind%psichi_to_uv(bump%mpl,bump%geom(1),fld_c0a(:,:,iv_psi),fld_c0a(:,:,iv_chi), & - & fld_c0a(:,:,iv_ua),fld_c0a(:,:,iv_va)) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - -! Probe out - - -end subroutine bump_psichi_to_uv - -!---------------------------------------------------------------------- -! Subroutine: bump_psichi_to_uv_ad -!> psi/chi to u/v transform, adjoint -!---------------------------------------------------------------------- -subroutine bump_psichi_to_uv_ad(bump,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variable -integer :: iv,iv_psi,iv_chi,iv_ua,iv_va -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) -type(atlas_field) :: afield - -! Set name - - -! Get instance - - -! Probe in - - -! Get psi/chi variables in fieldset or create and add them -if (fieldset%has_field(bump%nam%wind_streamfunction)) then - afield = fieldset%field(bump%nam%wind_streamfunction) -else - afield = bump%geom(1)%afunctionspace_mg%create_field(name=bump%nam%wind_streamfunction,kind=atlas_real(kind_real), & - & levels=bump%geom(1)%nl0) - call fieldset%add(afield) -end if -if (fieldset%has_field(bump%nam%wind_velocity_potential)) then - afield = fieldset%field(bump%nam%wind_velocity_potential) -else - afield = bump%geom(1)%afunctionspace_mg%create_field(name=bump%nam%wind_velocity_potential,kind=atlas_real(kind_real), & - & levels=bump%geom(1)%nl0) - call fieldset%add(afield) -end if - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) - -! Get psi/chi/ua/va indices -do iv=1,bump%nam%nv - if (bump%nam%variables(iv)==bump%nam%wind_zonal) iv_ua = iv - if (bump%nam%variables(iv)==bump%nam%wind_meridional) iv_va = iv - if (bump%nam%variables(iv)==bump%nam%wind_streamfunction) iv_psi = iv - if (bump%nam%variables(iv)==bump%nam%wind_velocity_potential) iv_chi = iv -end do - -! Transform psi/chi to u/v adjoint -call bump%wind%psichi_to_uv_ad(bump%mpl,bump%geom(1),fld_c0a(:,:,iv_ua),fld_c0a(:,:,iv_va), & - & fld_c0a(:,:,iv_psi),fld_c0a(:,:,iv_chi)) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - -! Probe out - - -end subroutine bump_psichi_to_uv_ad - - -!---------------------------------------------------------------------- -! Subroutine: bump_get_ncmp -!> Get number of components -!---------------------------------------------------------------------- -subroutine bump_get_ncmp(bump,iv,ncmp) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -integer,intent(in) :: iv !< Variable index -integer,intent(inout) :: ncmp !< Number of components - -! Set name - - -! Get instance - - -! Probe in - - -write(bump%mpl%info,'(a7,a)') '','Get number of components' -call bump%mpl%flush - -! Check variable index -if ((iv<1).or.(iv>bump%nam%nv)) call bump%mpl%abort('bump_get_ncmp','variable index out of bounds') - -! Copy -if (bump%nam%forced_radii) then - ncmp = one -else - ncmp = bump%nam%fit_ncmp(iv) -end if - -! Probe out - - -end subroutine bump_get_ncmp - -!---------------------------------------------------------------------- -! Subroutine: bump_get_parameter -!> Get parameter -!---------------------------------------------------------------------- -subroutine bump_get_parameter(bump,param,icmp,igeom,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -character(len=*),intent(in) :: param !< Parameter -integer,intent(in) :: icmp !< Component index -integer,intent(in) :: igeom !< Geometry index -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variables -integer :: ib,iv,ic0a,il0 -real(kind_real) :: fld_c0a(bump%geom(igeom)%nc0a,bump%geom(igeom)%nl0) -real(kind_real) :: fld_mga(bump%geom(igeom)%nmga,bump%geom(igeom)%nl0,bump%nam%nv) -logical :: found - -! Set name - - -! Get instance - - -! Probe in - - -write(bump%mpl%info,'(a7,a,a)') '','Get ',trim(param) -call bump%mpl%flush - -! Initialization -fld_mga = bump%mpl%msv%valr - -! Copy to field -do iv=1,bump%nam%nv - ! Initialization - found = .false. - - ! Block index - select case (trim(bump%nam%strategy)) - case ('specific_univariate','specific_multivariate') - ib = bump%bpar%v_to_b(iv) - case ('common','common_weighted') - ib = bump%bpar%nbe - end select - - ! Select parameter from geom - select case (trim(param)) - case ('lon') - if (.not.allocated(bump%geom(igeom)%lon_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - do il0=1,bump%geom(igeom)%nl0 - fld_c0a(:,il0) = bump%geom(igeom)%lon_c0a*rad2deg - end do - found = .true. - case ('lat') - if (.not.allocated(bump%geom(igeom)%lat_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - do il0=1,bump%geom(igeom)%nl0 - fld_c0a(:,il0) = bump%geom(igeom)%lat_c0a*rad2deg - end do - found = .true. - case ('area') - if (.not.allocated(bump%geom(igeom)%area_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - do il0=1,bump%geom(igeom)%nl0 - fld_c0a(:,il0) = bump%geom(igeom)%area_c0a*req**2 - end do - found = .true. - case ('vunit') - if (.not.allocated(bump%geom(igeom)%vunit_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%geom(igeom)%vunit_c0a - found = .true. - end select - - ! Select parameter from ens - select case (trim(param)) - case ('norm_m2') - if (.not.allocated(bump%ens(1)%norm_m2)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%ens(1)%norm_m2(:,:,iv) - found = .true. - case ('norm_m4') - if (.not.allocated(bump%ens(1)%norm_m4)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%ens(1)%norm_m4(:,:,iv) - found = .true. - case ('norm_kurt') - if (.not.allocated(bump%ens(1)%norm_kurt)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%ens(1)%norm_kurt(:,:,iv) - found = .true. - end select - - ! Select parameter from vbal - select case (trim(param)) - case ('dirac_vbal') - if (.not.allocated(bump%vbal%dirac)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%vbal%dirac(:,:,iv) - found = .true. - end select - - ! Select parameter from var - select case (trim(param)) - case ('stddev') - if (.not.allocated(bump%var%m2sqrt)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%var%m2sqrt(:,:,iv) - found = .true. - case ('var') - if (.not.allocated(bump%var%m2)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%var%m2(:,:,iv) - found = .true. - case ('m4') - if (.not.allocated(bump%var%m4)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%var%m4(:,:,iv) - found = .true. - end select - - ! Select parameter from mom - select case (trim(param)) - case ('dirac_mom') - if (.not.allocated(bump%mom(1)%dirac)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%mom(1)%dirac(:,:,iv) - found = .true. - end select - - ! Select parameter from hdiag - select case (trim(param)) - case ('cor_a','cor_a_lr') - if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%a_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& -# 1970 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & allocated') - if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%a_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component is& -# 1971 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & too large') - fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%a_c0a(:,:,icmp) - found = .true. - case ('cor_rh','cor_rh_lr') - if (bump%nam%forced_radii) then - do il0=1,bump%geom(igeom)%nl0 - fld_c0a(:,il0) = bump%nam%rh(il0,iv)*req - end do - else - if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%rh_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is& -# 1981 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & not allocated') - if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%rh_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//'& -# 1982 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & component is too large') - fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%rh_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = fld_c0a(ic0a,il0)*req - end do - end do - end if - found = .true. - case ('cor_rh1','cor_rh1_lr') - if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%D11_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& -# 1993 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & allocated') - if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%D11_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& -# 1994 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & is too large') - fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%D11_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req - end do - end do - found = .true. - case ('cor_rh2','cor_rh2_lr') - if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%D22_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& -# 2004 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & allocated') - if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%D22_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& -# 2005 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & is too large') - fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%D22_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req - end do - end do - found = .true. - case ('cor_rhc','cor_rhc_lr') - if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%D12_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& -# 2015 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & allocated') - if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%D12_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& -# 2016 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & is too large') - fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%D12_c0a(:,:,icmp) - found = .true. - case ('cor_rv','cor_rv_lr') - if (bump%nam%forced_radii) then - do il0=1,bump%geom(igeom)%nl0 - fld_c0a(:,il0) = bump%nam%rv(il0,iv) - end do - else - if (.not.allocated(bump%hdiag%cor(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(igeom)%blk(0,ib)%rv_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is& -# 2026 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & not allocated') - if (icmp>size(bump%hdiag%cor(igeom)%blk(0,ib)%rv_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//'& -# 2027 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & component is too large') - fld_c0a = bump%hdiag%cor(igeom)%blk(0,ib)%rv_c0a(:,:,icmp) - end if - found = .true. - case ('dirac_diag_cor','dirac_diag_cor_lr') - if (.not.allocated(bump%hdiag%cor(igeom)%dirac)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%hdiag%cor(igeom)%dirac(:,:,iv) - found = .true. - case ('loc_a','loc_a_lr') - if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%a_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& -# 2037 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & allocated') - if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%a_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component is& -# 2038 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & too large') - fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%a_c0a(:,:,icmp) - found = .true. - case ('loc_rh','loc_rh_lr') - if (bump%nam%forced_radii) then - do il0=1,bump%geom(igeom)%nl0 - fld_c0a(:,il0) = bump%nam%rh(il0,iv)*req - end do - else - if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%rh_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is& -# 2048 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & not allocated') - if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%rh_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//'& -# 2049 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & component is too large') - fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%rh_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = fld_c0a(ic0a,il0)*req - end do - end do - end if - found = .true. - case ('loc_rh1','loc_rh1_lr') - if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%D11_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& -# 2060 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & allocated') - if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%D11_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& -# 2061 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & is too large') - fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%D11_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req - end do - end do - found = .true. - case ('loc_rh2','loc_rh2_lr') - if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%D22_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& -# 2071 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & allocated') - if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%D22_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& -# 2072 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & is too large') - fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%D22_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req - end do - end do - found = .true. - case ('loc_rhc','loc_rhc_lr') - if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%D12_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& -# 2082 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & allocated') - if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%D12_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component& -# 2083 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & is too large') - fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%D12_c0a(:,:,icmp) - found = .true. - case ('loc_rv','loc_rv_lr') - if (bump%nam%forced_radii) then - do il0=1,bump%geom(igeom)%nl0 - fld_c0a(:,il0) = bump%nam%rv(il0,iv) - end do - else - if (.not.allocated(bump%hdiag%loc(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(igeom)%blk(0,ib)%rv_c0a)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is& -# 2093 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & not allocated') - if (icmp>size(bump%hdiag%loc(igeom)%blk(0,ib)%rv_c0a,3)) call bump%mpl%abort('bump_get_parameter',trim(param)//'& -# 2094 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & component is too large') - fld_c0a = bump%hdiag%loc(igeom)%blk(0,ib)%rv_c0a(:,:,icmp) - end if - found = .true. - case ('dirac_diag_loc','dirac_diag_loc_lr') - if (.not.allocated(bump%hdiag%loc(igeom)%dirac)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%hdiag%loc(igeom)%dirac(:,:,iv) - found = .true. - case ('hyb_coef_ens') - if (.not.allocated(bump%hdiag%loc(1)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(1)%blk(0,ib)%hyb_coef_c0a)) call bump%mpl%abort('bump_get_parameter', & - & trim(param)//' is not allocated') - fld_c0a = bump%hdiag%loc(1)%blk(0,ib)%hyb_coef_c0a - found = .true. - case ('hyb_coef_sta','hyb_coef_ens_lr') - if (.not.allocated(bump%hdiag%loc(2)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(2)%blk(0,ib)%hyb_coef_c0a)) call bump%mpl%abort('bump_get_parameter', & - & trim(param)//' is not allocated') - fld_c0a = bump%hdiag%loc(2)%blk(0,ib)%hyb_coef_c0a - found = .true. - end select - - ! Select parameter from nicas - select case (trim(param)) - case ('nicas_norm','nicas_norm_lr') - if (.not.allocated(bump%nicas(igeom)%blk)) call bump%mpl%abort('bump_get_parameter',trim(param)//' block is not allocated') - if (.not.allocated(bump%nicas(igeom)%blk(ib)%cmp)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component is not& -# 2120 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & allocated') - if (icmp>size(bump%nicas(igeom)%blk(ib)%cmp)) call bump%mpl%abort('bump_get_parameter',trim(param)//' component is too large') - if (.not.allocated(bump%nicas(igeom)%blk(ib)%cmp(icmp)%norm)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not& -# 2122 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & allocated') - fld_c0a = bump%nicas(igeom)%blk(ib)%cmp(icmp)%norm - found = .true. - case ('dirac_nicas','dirac_nicas_lr') - if (.not.allocated(bump%nicas(igeom)%dirac)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%nicas(igeom)%dirac(:,:,iv) - found = .true. - case ('dirac_nicas_bens','dirac_nicas_bens_lr') - if (.not.allocated(bump%nicas(igeom)%dirac_bens)) call bump%mpl%abort('bump_get_parameter',trim(param)//' is not allocated') - fld_c0a = bump%nicas(igeom)%dirac_bens(:,:,iv) - found = .true. - end select - - ! Copy to model grid - call bump%geom(igeom)%copy_c0a_to_mga(bump%mpl,fld_c0a,fld_mga(:,:,iv)) - - ! Check that parameters was found - if (.not.found) call bump%mpl%abort('bump_get_parameter','parameter '//trim(param)//' not found') -end do - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(igeom)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fortran array to fieldset -call fieldset%from_array(bump%mpl,fld_mga) - -! Probe out - - -end subroutine bump_get_parameter - -!---------------------------------------------------------------------- -! Subroutine: bump_test_get_parameter -!> Test get_parameter -!---------------------------------------------------------------------- -subroutine bump_test_get_parameter(bump) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP - -! Local variables -type(fieldset_type) :: fieldset - -! Set name - - -! Get instance - - -! Probe in - - -! Create fieldset -call fieldset%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Get parameter -call bump%get_parameter('norm_m2',1,1,fieldset) -call bump%get_parameter('norm_m4',1,1,fieldset) -call bump%get_parameter('norm_kurt',1,1,fieldset) -if ((bump%nam%new_var.or.bump%nam%update_var).and.(trim(bump%nam%strategy)=='specific_multivariate')) then - call bump%get_parameter('stddev',1,1,fieldset) - call bump%get_parameter('var',1,1,fieldset) - call bump%get_parameter('m4',1,1,fieldset) -end if -call bump%get_parameter('cor_a',1,1,fieldset) -if (bump%nam%nc4==1) then - call bump%get_parameter('cor_rh',1,1,fieldset) -else - call bump%get_parameter('cor_rh1',1,1,fieldset) - call bump%get_parameter('cor_rh2',1,1,fieldset) - call bump%get_parameter('cor_rhc',1,1,fieldset) -end if -call bump%get_parameter('cor_rv',1,1,fieldset) -call bump%get_parameter('dirac_diag_cor',1,1,fieldset) -call bump%get_parameter('loc_a',1,1,fieldset) -if (bump%nam%nc4==1) then - call bump%get_parameter('loc_rh',1,1,fieldset) -else - call bump%get_parameter('loc_rh1',1,1,fieldset) - call bump%get_parameter('loc_rh2',1,1,fieldset) - call bump%get_parameter('loc_rhc',1,1,fieldset) -end if -call bump%get_parameter('loc_rv',1,1,fieldset) -call bump%get_parameter('dirac_diag_loc',1,1,fieldset) -call bump%get_parameter('hyb_coef_ens',1,1,fieldset) -call bump%get_parameter('hyb_coef_sta',1,1,fieldset) -call bump%get_parameter('hyb_coef_ens_lr',1,1,fieldset) -call bump%get_parameter('loc_a_lr',1,1,fieldset) -if (bump%nam%nc4==1) then - call bump%get_parameter('loc_rh_lr',1,1,fieldset) -else - call bump%get_parameter('loc_rh1_lr',1,1,fieldset) - call bump%get_parameter('loc_rh2_lr',1,1,fieldset) - call bump%get_parameter('loc_rhc_lr',1,1,fieldset) -end if -call bump%get_parameter('loc_rv_lr',1,1,fieldset) -call bump%get_parameter('dirac_diag_loc_lr',1,1,fieldset) -call bump%get_parameter('dirac_vbal',1,1,fieldset) -call bump%get_parameter('dirac_mom',1,1,fieldset) -call bump%get_parameter('nicas_norm',1,1,fieldset) -call bump%get_parameter('dirac_nicas',1,1,fieldset) -call bump%get_parameter('dirac_nicas_bens',1,1,fieldset) -call bump%get_parameter('nicas_norm_lr',1,1,fieldset) -call bump%get_parameter('dirac_nicas_lr',1,1,fieldset) -call bump%get_parameter('dirac_nicas_bens_lr',1,1,fieldset) - -! Release memory -call fieldset%final() - -! Probe out - - -end subroutine bump_test_get_parameter - -!---------------------------------------------------------------------- -! Subroutine: bump_set_ncmp -!> Set number of components -!---------------------------------------------------------------------- -subroutine bump_set_ncmp(bump,iv,ncmp) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -integer,intent(in) :: iv !< Variable index -integer,intent(in) :: ncmp !< Number of components - -! Local variables -integer :: ib - -! Set name - - -! Get instance - - -! Probe in - - -write(bump%mpl%info,'(a7,a)') '','Set number of components' -call bump%mpl%flush - -! Check variable index -if ((iv<1).or.(iv>bump%nam%nv)) call bump%mpl%abort('bump_set_ncmp','variable index out of bounds') - -! Check allocation -if (.not.allocated(bump%cmat(1)%blk)) allocate(bump%cmat(1)%blk(bump%bpar%nbe)) -if (.not.allocated(bump%nicas(1)%blk)) allocate(bump%nicas(1)%blk(bump%bpar%nbe)) - -! Set block index -select case (trim(bump%nam%strategy)) -case ('specific_univariate','specific_multivariate') - ib = bump%bpar%v_to_b(iv) -case ('common','common_weighted') - ib = bump%bpar%nbe -end select - -! Copy -bump%cmat(1)%blk(ib)%ncmp = ncmp -bump%nicas(1)%blk(ib)%ncmp = ncmp - -! Probe out - - -end subroutine bump_set_ncmp - -!---------------------------------------------------------------------- -! Subroutine: bump_set_parameter -!> Set parameter -!---------------------------------------------------------------------- -subroutine bump_set_parameter(bump,param,icmp,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -character(len=*),intent(in) :: param !< Parameter -integer,intent(in) :: icmp !< Component index -type(fieldset_type),intent(inout) :: fieldset !< Fieldset - -! Local variables -integer :: ic0a,il0,iv,ib,jb -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0) -real(kind_real) :: fld_mga(bump%geom(1)%nmga,bump%geom(1)%nl0,bump%nam%nv) -logical :: found - -! Set name - - -! Get instance - - -! Probe in - - -write(bump%mpl%info,'(a7,a,a)') '','Set ',trim(param) -call bump%mpl%flush - -! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) - -! Fieldset to Fortran array -call fieldset%to_array(bump%mpl,fld_mga) - -! Counter -select case (trim(param)) -case ('var') - bump%var%bump_m2_counter = bump%var%bump_m2_counter+1 -case ('m4') - bump%var%bump_m4_counter = bump%var%bump_m4_counter+1 -end select - -do iv=1,bump%nam%nv - ! Initialization - found = .false. - - ! Block index - select case (trim(bump%nam%strategy)) - case ('specific_univariate','specific_multivariate') - ib = bump%bpar%v_to_b(iv) - case ('common','common_weighted') - ib = bump%bpar%nbe - end select - - ! Check allocation / parameter existence - select case (trim(param)) - case ('stddev','var','m4','sampling_mask_field') - case ('a','rh','rh1','rh2','rhc','rv') - if (.not.allocated(bump%cmat(1)%blk)) allocate(bump%cmat(1)%blk(bump%bpar%nbe)) - case ('nicas_a','nicas_norm') - if (.not.allocated(bump%nicas(1)%blk)) then - ! Not allocated yet: allocate and set the number of components to one - allocate(bump%nicas(1)%blk(bump%bpar%nbe)) - do jb=1,bump%bpar%nbe - if (bump%bpar%nicas_block(ib)) bump%nicas(1)%blk(jb)%ncmp = 1 - end do - end if - if (bump%bpar%nicas_block(ib).and.(.not.allocated(bump%nicas(1)%blk(ib)%cmp))) & - & allocate(bump%nicas(1)%blk(ib)%cmp(bump%nicas(1)%blk(ib)%ncmp)) - case default - call bump%mpl%abort('bump_set_parameter','parameter '//trim(param)//' not yet implemented, available input parameters& -# 2364 "/scratch2/NCEPDEV/fv3-cam/Ting.Lei/dr-jedi-MGBF/fv3-bundle/saber/src/saber/bump/type_bump.fypp" - & are:'// & - & 'stddev, var, m4, sampling_mask_field, a, rh, rh1, rh2, rhc, rv, nicas_norm') - end select - - ! Copy to model grid - call bump%geom(1)%copy_mga_to_c0a(bump%mpl,fld_mga(:,:,iv),fld_c0a) - - ! Select parameter from var - select case (trim(param)) - case ('sampling_mask_field') - if (.not.allocated(bump%samp(1)%smask_input_c0a)) allocate(bump%samp(1)%smask_input_c0a(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0,bump%nam%nv)) - bump%samp(1)%smask_input_c0a(:,:,iv) = fld_c0a - found = .true. - end select - - ! Select parameter from var - select case (trim(param)) - case ('stddev') - if (.not.allocated(bump%var%m2sqrt)) allocate(bump%var%m2sqrt(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) - bump%var%m2sqrt(:,:,iv) = fld_c0a - found = .true. - case ('var') - if (.not.allocated(bump%var%bump_m2)) then - allocate(bump%var%bump_m2(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) - bump%var%bump_m2 = zero - end if - bump%var%bump_m2(:,:,iv) = bump%var%bump_m2(:,:,iv)+fld_c0a - found = .true. - case ('m4') - if (.not.allocated(bump%var%bump_m4)) then - allocate(bump%var%bump_m4(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) - bump%var%bump_m4 = zero - end if - bump%var%bump_m4(:,:,iv) = bump%var%bump_m4(:,:,iv)+fld_c0a - found = .true. - end select - - ! Select parameter from cmat - select case (trim(param)) - case ('a') - if (.not.allocated(bump%cmat(1)%blk(ib)%bump_a)) allocate(bump%cmat(1)%blk(ib)%bump_a(bump%geom(1)%nc0a,bump%geom(1)%nl0, & - & bump%cmat(1)%blk(ib)%ncmp)) - bump%cmat(1)%blk(ib)%bump_a(:,:,icmp) = fld_c0a - found = .true. - case ('rh') - if (.not.allocated(bump%cmat(1)%blk(ib)%bump_rh)) allocate(bump%cmat(1)%blk(ib)%bump_rh(bump%geom(1)%nc0a,bump%geom(1)%nl0, & - & bump%cmat(1)%blk(ib)%ncmp)) - bump%cmat(1)%blk(ib)%bump_rh(:,:,icmp) = fld_c0a - do il0=1,bump%geom(1)%nl0 - do ic0a=1,bump%geom(1)%nc0a - if (bump%mpl%msv%isnot(bump%cmat(1)%blk(ib)%bump_rh(ic0a,il0,icmp))) & - & bump%cmat(1)%blk(ib)%bump_rh(ic0a,il0,icmp) = bump%cmat(1)%blk(ib)%bump_rh(ic0a,il0,icmp)/req - end do - end do - found = .true. - case ('rh1') - if (.not.allocated(bump%cmat(1)%blk(ib)%bump_D11)) allocate(bump%cmat(1)%blk(ib)%bump_D11(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0,bump%cmat(1)%blk(ib)%ncmp)) - bump%cmat(1)%blk(ib)%bump_D11(:,:,icmp) = fld_c0a - do il0=1,bump%geom(1)%nl0 - do ic0a=1,bump%geom(1)%nc0a - if (bump%mpl%msv%isnot(bump%cmat(1)%blk(ib)%bump_D11(ic0a,il0,icmp))) & - & bump%cmat(1)%blk(ib)%bump_D11(ic0a,il0,icmp) = (bump%cmat(1)%blk(ib)%bump_D11(ic0a,il0,icmp)/req)**2 - end do - end do - found = .true. - case ('rh2') - if (.not.allocated(bump%cmat(1)%blk(ib)%bump_D22)) allocate(bump%cmat(1)%blk(ib)%bump_D22(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0,bump%cmat(1)%blk(ib)%ncmp)) - bump%cmat(1)%blk(ib)%bump_D22(:,:,icmp) = fld_c0a - do il0=1,bump%geom(1)%nl0 - do ic0a=1,bump%geom(1)%nc0a - if (bump%mpl%msv%isnot(bump%cmat(1)%blk(ib)%bump_D22(ic0a,il0,icmp))) & - & bump%cmat(1)%blk(ib)%bump_D22(ic0a,il0,icmp) = (bump%cmat(1)%blk(ib)%bump_D22(ic0a,il0,icmp)/req)**2 - end do - end do - found = .true. - case ('rhc') - if (.not.allocated(bump%cmat(1)%blk(ib)%bump_D12)) allocate(bump%cmat(1)%blk(ib)%bump_D12(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0,bump%cmat(1)%blk(ib)%ncmp)) - bump%cmat(1)%blk(ib)%bump_D12(:,:,icmp) = fld_c0a - found = .true. - case ('rv') - if (.not.allocated(bump%cmat(1)%blk(ib)%bump_rv)) allocate(bump%cmat(1)%blk(ib)%bump_rv(bump%geom(1)%nc0a,bump%geom(1)%nl0, & - & bump%cmat(1)%blk(ib)%ncmp)) - bump%cmat(1)%blk(ib)%bump_rv(:,:,icmp) = fld_c0a - found = .true. - end select - - ! Select parameter from nicas - select case (trim(param)) - case ('nicas_a') - if (icmp>size(bump%nicas(1)%blk(ib)%cmp)) call bump%mpl%abort('bump_set_parameter','component index is too large') - if (.not.allocated(bump%nicas(1)%blk(ib)%cmp(icmp)%a)) allocate(bump%nicas(1)%blk(ib)%cmp(icmp)%a(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0)) - bump%nicas(1)%blk(ib)%cmp(icmp)%a = fld_c0a - found = .true. - case ('nicas_norm') - if (icmp>size(bump%nicas(1)%blk(ib)%cmp)) call bump%mpl%abort('bump_set_parameter','component index is too large') - if (.not.allocated(bump%nicas(1)%blk(ib)%cmp(icmp)%norm)) allocate(bump%nicas(1)%blk(ib)%cmp(icmp)%norm(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0)) - bump%nicas(1)%blk(ib)%cmp(icmp)%norm = fld_c0a - found = .true. - end select - - ! Check that parameters was found - if (.not.found) call bump%mpl%abort('bump_set_parameter','parameter '//trim(param)//' not found') -end do - -! Probe out - - -end subroutine bump_set_parameter - -!---------------------------------------------------------------------- -! Subroutine: bump_test_set_parameter -!> Test set_parameter -!---------------------------------------------------------------------- -subroutine bump_test_set_parameter(bump) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP - -! Local variables -integer :: ic0a,il0,iv -real(kind_real) :: fld_min,fld_max -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) -real(kind_real) :: fld_c0a_sym(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) -real(kind_real) :: fld_c0a_req(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) -real(kind_real) :: fld_c0a_vert(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) -type(fieldset_type) :: fieldset,fieldset_sym,fieldset_req,fieldset_vert - -! Set name - - -! Get instance - - -! Probe in - - -! Initialization -do iv=1,bump%nam%nv - do il0=1,bump%geom(1)%nl0 - do ic0a=1,bump%geom(1)%nc0a - fld_c0a(ic0a,il0,iv) = abs(real(fletcher32((/bump%geom(1)%lon_c0a(ic0a),bump%geom(1)%lat_c0a(ic0a),real(iv,kind_real), & - & real(il0,kind_real)/)),kind_real)) - end do - end do -end do -fld_min = zss_minval(fld_c0a) -fld_max = zss_maxval(fld_c0a) -call bump%mpl%f_comm%allreduce(fld_min,fckit_mpi_min()) -call bump%mpl%f_comm%allreduce(fld_max,fckit_mpi_max()) -fld_c0a = fld_c0a/abs(fld_max-fld_min) -fld_c0a_sym = fld_c0a-half -fld_c0a_req = fld_c0a*req -fld_c0a_vert = (one+fld_c0a)*(maxval(bump%geom(1)%vunitavg)-minval(bump%geom(1)%vunitavg)) - -! Create fieldset -call fieldset%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d) -call fieldset_sym%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & - & bump%nam%lev2d) -call fieldset_req%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & - & bump%nam%lev2d) -call fieldset_vert%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & - & bump%nam%lev2d) - -! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a_sym,fieldset_sym) -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a_req,fieldset_req) -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a_vert,fieldset_vert) - -! Set parameters -do iv=1,bump%nam%nv - call bump%set_ncmp(iv,1) -end do -if (trim(bump%nam%strategy)=='specific_univariate') then - call bump%set_parameter('stddev',1,fieldset) - call bump%set_parameter('var',1,fieldset) - call bump%set_parameter('m4',1,fieldset) -end if -if (bump%nam%nc4==1) then - call bump%set_parameter('rh',1,fieldset_req) -else - call bump%set_parameter('rh1',1,fieldset_req) - call bump%set_parameter('rh2',1,fieldset_req) - call bump%set_parameter('rhc',1,fieldset) -end if -call bump%set_parameter('rv',1,fieldset_vert) -call bump%set_parameter('nicas_norm',1,fieldset) - -! Release memory -call fieldset%final() -call fieldset_sym%final() -call fieldset_req%final() -call fieldset_vert%final() - -! Probe out - - -end subroutine bump_test_set_parameter - -!---------------------------------------------------------------------- -! Subroutine: bump_test_apply_interfaces -!> Test BUMP apply interfaces -!---------------------------------------------------------------------- -subroutine bump_test_apply_interfaces(bump) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP - -! Local variables -integer :: n -real(kind_real),allocatable :: fld_c0a(:,:,:),pcv(:) -type(fieldset_type) :: fieldset - -! Set name - - -! Get instance - - -! Probe in - - -! Test apply_vbal -if (bump%nam%check_apply_vbal) then - write(bump%mpl%info,'(a7,a)') '','Test apply_vbal' - call bump%mpl%flush - - ! Allocation - allocate(fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) - - ! Initialization - call bump%rng%rand(zero,one,fld_c0a) - - ! Create fieldset - call fieldset%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & - & bump%nam%lev2d) - - ! Fortran array on subset Sc0 to fieldset - call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - - ! Calls - call bump%apply_vbal(fieldset) - call bump%apply_vbal_inv(fieldset) - call bump%apply_vbal_ad(fieldset) - call bump%apply_vbal_inv_ad(fieldset) - - ! Release memory - deallocate(fld_c0a) - call fieldset%final() -end if - -! Test apply_stddev -if (bump%nam%check_apply_stddev) then - write(bump%mpl%info,'(a7,a)') '','Test apply_stddev' - call bump%mpl%flush - - ! Allocation - allocate(fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) - - ! Initialization - call bump%rng%rand(zero,one,fld_c0a) - - ! Create fieldset - call fieldset%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & - & bump%nam%lev2d) - - ! Fortran array on subset Sc0 to fieldset - call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - - ! Calls - call bump%apply_stddev(fieldset) - call bump%apply_stddev_inv(fieldset) - - ! Release memory - deallocate(fld_c0a) - call fieldset%final() -end if - -! Test apply_nicas -if (bump%nam%check_apply_nicas) then - write(bump%mpl%info,'(a7,a)') '','Test apply_nicas' - call bump%mpl%flush - - ! Get control variable size - call bump%get_cv_size(n) - - ! Allocation - allocate(fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) - allocate(pcv(n)) - - ! Initialization - call bump%rng%rand(zero,one,fld_c0a) - - ! Create fieldset - call fieldset%init(bump%mpl,bump%geom(1)%afunctionspace_mg,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & - & bump%nam%lev2d) - - ! Fortran array on subset Sc0 to fieldset - call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) - - ! Calls - call bump%apply_nicas(fieldset) - call bump%apply_nicas_sqrt(pcv,fieldset) - call bump%apply_nicas_sqrt_ad(fieldset,pcv) - call bump%randomize(fieldset) - - ! Release memory - deallocate(fld_c0a) - deallocate(pcv) - call fieldset%final() -end if - -! Probe out - - -end subroutine bump_test_apply_interfaces - -!---------------------------------------------------------------------- -! Subroutine: bump_partial_dealloc -!> Release memory (partial) -!---------------------------------------------------------------------- -subroutine bump_partial_dealloc(bump) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP - -! Set name - - -! Get instance - - -! Probe in - - -! Release memory -if (allocated(bump%cmat)) then - call bump%cmat(1)%partial_dealloc - call bump%cmat(2)%partial_dealloc -end if -if (allocated(bump%ens)) then - call bump%ens(1)%partial_dealloc - call bump%ens(2)%partial_dealloc -end if -if (allocated(bump%geom)) then - call bump%geom(1)%partial_dealloc - call bump%geom(2)%partial_dealloc -end if -call bump%hdiag%partial_dealloc -if (allocated(bump%mom)) then - call bump%mom(1)%partial_dealloc - call bump%mom(2)%partial_dealloc -end if -if (allocated(bump%nicas)) then - call bump%nicas(1)%partial_dealloc - call bump%nicas(2)%partial_dealloc -end if -if (allocated(bump%samp)) then - call bump%samp(1)%dealloc - call bump%samp(2)%dealloc -end if -call bump%var%partial_dealloc -call bump%vbal%partial_dealloc - -! Probe out - - -end subroutine bump_partial_dealloc - -!---------------------------------------------------------------------- -! Subroutine: bump_dealloc -!> Release memory (full) -!---------------------------------------------------------------------- -subroutine bump_dealloc(bump) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP - -! Set name - - -! Get instance - - -! Execution stats - - -! Number of open NetCDF files -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- NetCDF I/O report' -call bump%mpl%flush -call registry%report(bump%mpl) - -! Release memory -call bump%bpar%dealloc -if (allocated(bump%cmat)) then - call bump%cmat(1)%dealloc - call bump%cmat(2)%dealloc - deallocate(bump%cmat) -end if -if (allocated(bump%ens)) then - call bump%ens(1)%dealloc - call bump%ens(2)%dealloc - deallocate(bump%ens) -end if -if (allocated(bump%geom)) then - call bump%geom(1)%dealloc - call bump%geom(2)%dealloc - deallocate(bump%geom) -end if -call bump%hdiag%dealloc -if (allocated(bump%mom)) then - call bump%mom(1)%dealloc - call bump%mom(2)%dealloc - deallocate(bump%mom) -end if -if (allocated(bump%nicas)) then - call bump%nicas(1)%dealloc - call bump%nicas(2)%dealloc - deallocate(bump%nicas) -end if -if (allocated(bump%samp)) then - call bump%samp(1)%dealloc - call bump%samp(2)%dealloc - deallocate(bump%samp) -end if -call bump%var%dealloc -call bump%vbal%dealloc - -! Execution stats - - -! Release probe instance - - -end subroutine bump_dealloc - -!---------------------------------------------------------------------- -! Subroutine: bump_dummy_final -!> Dummy finalization -!---------------------------------------------------------------------- -subroutine bump_dummy_final(bump) - -implicit none - -! Passed variables -type(bump_type),intent(inout) :: bump !< BUMP - -! Set name - - -! Get instance - - -! Probe in - - -! Dummy action to avoid compiler warning -bump%dummy_logical = .false. - -! Probe out - - -end subroutine bump_dummy_final - -end module type_bump diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 index 17ebe789c..4d28dfa3d 100644 --- a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 @@ -34,44 +34,19 @@ ! mg_parameter ! !============================================================================= -module jp_pbfil +submodule(mg_parameter) jp_pbfil !============================================================================= use mpi use kinds, only: dp=>r_kind !!!use jp_pkind, only: dp use jp_pietc, only: u1 -use mg_parameter, only: p, rmom2_1,rmom2_2,rmom2_3,rmom2_4 implicit none -private - -public cholaspect -interface cholaspect - module procedure cholaspect1,cholaspect2,cholaspect3,cholaspect4 -end interface - -public getlinesum -interface getlinesum - module procedure getlinesum1,getlinesum2,getlinesum3 -end interface - -public rbeta -interface rbeta - module procedure rbeta1, rbeta2, rbeta3, rbeta4, & - vrbeta1,vrbeta2,vrbeta3,vrbeta4 -end interface - -public rbetaT -interface rbetaT - module procedure rbeta1t, rbeta2t, rbeta3t, rbeta4t, & - vrbeta1t,vrbeta2t,vrbeta3t,vrbeta4t -end interface - contains !============================================================================= -subroutine cholaspect1(lx,mx, el) ! [cholaspect] +module subroutine cholaspect1(lx,mx, el) ! [cholaspect] !============================================================================= ! Convert the given field, el, of aspect tensors into the equivalent ! field @@ -87,7 +62,7 @@ subroutine cholaspect1(lx,mx, el) ! [cholaspect] do ix=lx,mx; el(1,1,ix)=u1/sqrt(el(1,1,ix)); enddo end subroutine cholaspect1 !============================================================================= -subroutine cholaspect2(lx,mx, ly,my, el) ! [cholaspect] +module subroutine cholaspect2(lx,mx, ly,my, el) ! [cholaspect] !============================================================================= ! Convert the given field, el, of aspect tensors into the equivalent ! field @@ -106,7 +81,7 @@ subroutine cholaspect2(lx,mx, ly,my, el) ! [cholaspect] enddo; enddo end subroutine cholaspect2 !============================================================================= -subroutine cholaspect3(lx,mx, ly,my, lz,mz, el) ! [cholaspect] +module subroutine cholaspect3(lx,mx, ly,my, lz,mz, el) ! [cholaspect] !============================================================================= ! Convert the given field, el, of aspect tensors into the equivalent ! field @@ -125,7 +100,7 @@ subroutine cholaspect3(lx,mx, ly,my, lz,mz, el) ! [cholaspect] enddo; enddo; enddo end subroutine cholaspect3 !============================================================================= -subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el) ! [cholaspect] +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 @@ -146,7 +121,7 @@ subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el) ! [cholaspect] end subroutine cholaspect4 !============================================================================= -subroutine getlinesum1(hx,lx,mx, el, ss) ! [getlinesum] +module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [getlinesum] !============================================================================= ! Get inverse of the line-sum of the matrix representing the ! unnormalized @@ -155,6 +130,7 @@ subroutine getlinesum1(hx,lx,mx, el, ss) ! [getlinesum] ! 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 @@ -165,7 +141,7 @@ subroutine getlinesum1(hx,lx,mx, el, ss) ! [getlinesum] !============================================================================= do ix=Lx,Mx s=0 - exx=el(1,1,ix)*rmom2_1 + 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)& @@ -173,14 +149,15 @@ subroutine getlinesum1(hx,lx,mx, el, ss) ! [getlinesum] do gx=gxl,gxm x=gx rr=(x*exx)**2; rrc=u1-rr - s=s+rrc**p + s=s+rrc**this%p enddo ss(ix)=u1/s enddo end subroutine getlinesum1 !============================================================================= -subroutine getlinesum2(hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum] +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 @@ -194,7 +171,7 @@ subroutine getlinesum2(hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum] !============================================================================= do iy=Ly,My; do ix=Lx,Mx s=0 - tel=el(:,:,ix,iy)*rmom2_2 ! This el, rescaled + 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 @@ -210,15 +187,16 @@ subroutine getlinesum2(hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum] do gx=gxl,gxm x=gx rr=rrx+(x*exx-xc)**2; rrc=u1-rr - s=s+rrc**p + s=s+rrc**this%p enddo! gx enddo! gy ss(ix,iy)=u1/s enddo; enddo! ix, iy end subroutine getlinesum2 !============================================================================= -subroutine getlinesum3(hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss)! [getlinesum] +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 @@ -236,7 +214,7 @@ subroutine getlinesum3(hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss)! [getlinesum] ss=0 do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx s=0 - tel=el(:,:,ix,iy,iz)*rmom2_3 + 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) @@ -259,7 +237,7 @@ subroutine getlinesum3(hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss)! [getlinesum] do gx=gxl,gxm x=gx rr=rrx+(x*exx-xc)**2; rrc=u1-rr - s=s+rrc**p + s=s+rrc**this%p enddo! gx enddo! gy enddo! gz @@ -267,9 +245,10 @@ subroutine getlinesum3(hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss)! [getlinesum] enddo; enddo; enddo! ix, iy, iz end subroutine getlinesum3 !============================================================================= -subroutine getlinesum4(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & +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, & @@ -290,7 +269,7 @@ subroutine getlinesum4(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & 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)*rmom2_4 + 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) @@ -320,7 +299,7 @@ subroutine getlinesum4(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & do gx=gxl,gxm x=gx rr=rrx+(x*exx-xc)**2; rrc=u1-rr - s=s+rrc**p + s=s+rrc**this%p enddo! gx enddo! gy enddo! gz @@ -330,7 +309,7 @@ subroutine getlinesum4(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & end subroutine getlinesum4 !============================================================================= -subroutine rbeta1(hx,lx,mx, el,ss, a) ! [rbeta] +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 @@ -341,6 +320,7 @@ subroutine rbeta1(hx,lx,mx, el,ss, a) ! [rbeta] ! 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 @@ -354,12 +334,12 @@ subroutine rbeta1(hx,lx,mx, el,ss, a) ! [rbeta] b=0 do ix=Lx,Mx tb=0; s=ss(ix) - exx=el(ix)*rmom2_1 + 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**p + frow=s*rrc**this%p tb=tb+frow*a(jx) enddo b(ix)=tb @@ -367,7 +347,7 @@ subroutine rbeta1(hx,lx,mx, el,ss, a) ! [rbeta] a=b end subroutine rbeta1 !============================================================================= -subroutine rbeta2(hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] +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 @@ -378,6 +358,7 @@ subroutine rbeta2(hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] ! 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 @@ -395,7 +376,7 @@ subroutine rbeta2(hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] b=0 do iy=Ly,My; do ix=Lx,Mx tb=0; s=ss(ix,iy) - tel=el(:,:,ix,iy)*rmom2_2 ! This el, rescaled + 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 @@ -405,7 +386,7 @@ subroutine rbeta2(hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] 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**p + frow=s*rrc**this%p tb=tb+frow*a(jx,jy) enddo! gx enddo! gy @@ -414,7 +395,7 @@ subroutine rbeta2(hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] a=b end subroutine rbeta2 !============================================================================= -subroutine rbeta3(hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] +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 @@ -425,6 +406,7 @@ subroutine rbeta3(hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] ! 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 @@ -445,7 +427,7 @@ subroutine rbeta3(hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] 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)*rmom2_3 + 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 @@ -458,7 +440,7 @@ subroutine rbeta3(hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] 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**p + frow=s*rrc**this%p tb=tb+frow*a(jx,jy,jz) enddo! gx enddo! gy @@ -468,7 +450,7 @@ subroutine rbeta3(hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] a=b end subroutine rbeta3 !============================================================================= -subroutine rbeta4(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a)! [rbeta] +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 @@ -480,6 +462,7 @@ subroutine rbeta4(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a)! [rbeta] ! 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,& @@ -503,7 +486,7 @@ subroutine rbeta4(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a)! [rbeta] 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)*rmom2_4 + 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) @@ -521,7 +504,7 @@ subroutine rbeta4(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a)! [rbeta] 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**p + frow=s*rrc**this%p tb=tb+frow*a(jx,jy,jz,jw) enddo! gx enddo! gy @@ -535,11 +518,12 @@ end subroutine rbeta4 !============================================================================= ! Vector versions of the above routines: !============================================================================= -subroutine vrbeta4(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & +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,& @@ -566,7 +550,7 @@ subroutine vrbeta4(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & 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)*rmom2_4 + 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) @@ -584,7 +568,7 @@ subroutine vrbeta4(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & 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**p + frow=s*rrc**this%p tb=tb+frow*a(:,jx,jy,jz,jw) enddo! gx enddo! gy @@ -596,7 +580,7 @@ subroutine vrbeta4(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & end subroutine vrbeta4 !============================================================================= -subroutine rbeta1T(hx,lx,mx, el,ss, a) ! [rbetat] +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 @@ -606,6 +590,7 @@ subroutine rbeta1T(hx,lx,mx, el,ss, a) ! [rbetat] ! 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 @@ -619,19 +604,19 @@ subroutine rbeta1T(hx,lx,mx, el,ss, a) ! [rbetat] b=0 do ix=Lx,Mx ta=a(ix); s=ss(ix) - exx=el(1,1,ix)*rmom2_1 + 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**p + frow=s*rrc**this%p b(jx)=b(jx)+frow*ta enddo enddo a=b end subroutine rbeta1t !============================================================================= -subroutine rbeta2T(hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] +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 @@ -641,6 +626,7 @@ subroutine rbeta2T(hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] ! 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 @@ -658,7 +644,7 @@ subroutine rbeta2T(hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] b=0 do iy=Ly,My; do ix=Lx,Mx ta=a(ix,iy); s=ss(ix,iy) - tel=el(:,:,ix,iy)*rmom2_2 ! This el, rescaled + 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 @@ -668,7 +654,7 @@ subroutine rbeta2T(hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] 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**p + frow=s*rrc**this%p b(jx,jy)=b(jx,jy)+frow*ta enddo! gx enddo! gy @@ -676,7 +662,7 @@ subroutine rbeta2T(hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] a=b end subroutine rbeta2t !============================================================================= -subroutine rbeta3T(hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] +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 @@ -686,6 +672,7 @@ subroutine rbeta3T(hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] ! 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 @@ -706,7 +693,7 @@ subroutine rbeta3T(hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] 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)*rmom2_3 + 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 @@ -719,7 +706,7 @@ subroutine rbeta3T(hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] 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**p + frow=s*rrc**this%p b(jx,jy,jz)=b(jx,jy,jz)+frow*ta enddo! gx enddo! gy @@ -728,7 +715,7 @@ subroutine rbeta3T(hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] a=b end subroutine rbeta3t !============================================================================= -subroutine rbeta4T(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & +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. @@ -740,6 +727,7 @@ subroutine rbeta4T(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & ! 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,& @@ -763,7 +751,7 @@ subroutine rbeta4T(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & 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)*rmom2_4 + 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) @@ -781,7 +769,7 @@ subroutine rbeta4T(hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & 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**p + frow=s*rrc**this%p b(jx,jy,jz,jw)=b(jx,jy,jz,jw)+frow*ta enddo! gx enddo! gy @@ -793,11 +781,12 @@ end subroutine rbeta4t !============================================================================= -subroutine vrbeta4t(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, & +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,& @@ -823,7 +812,7 @@ subroutine vrbeta4t(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, & 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)*rmom2_4 + 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) @@ -841,7 +830,7 @@ subroutine vrbeta4t(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, & 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**p + frow=s*rrc**this%p b(:,jx,jy,jz,jw)=b(:,jx,jy,jz,jw)+frow*ta enddo! gx enddo! gy @@ -853,10 +842,11 @@ end subroutine vrbeta4t ! Vector versions of the above routines: !============================================================================= -subroutine vrbeta1(nv,hx,lx,mx, el,ss, a) ! [rbeta] +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 @@ -871,12 +861,12 @@ subroutine vrbeta1(nv,hx,lx,mx, el,ss, a) ! [rbeta] b=0 do ix=Lx,Mx tb=0; s=ss(ix) - exx=el(1,1,ix)*rmom2_1 + 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**p + frow=s*rrc**this%p tb=tb+frow*a(:,jx) enddo b(:,ix)=tb @@ -885,10 +875,11 @@ subroutine vrbeta1(nv,hx,lx,mx, el,ss, a) ! [rbeta] end subroutine vrbeta1 !============================================================================= -subroutine vrbeta2(nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] +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 @@ -908,7 +899,7 @@ subroutine vrbeta2(nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] b=0 do iy=Ly,My; do ix=Lx,Mx tb=0; s=ss(ix,iy) - tel=el(:,:,ix,iy)*rmom2_2 ! This el, rescaled + 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 @@ -918,7 +909,7 @@ subroutine vrbeta2(nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] 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**p + frow=s*rrc**this%p tb=tb+frow*a(:,jx,jy) enddo! gx enddo! gy @@ -927,10 +918,11 @@ subroutine vrbeta2(nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] a=b end subroutine vrbeta2 -subroutine vrbeta3(nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] +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,& @@ -953,7 +945,7 @@ subroutine vrbeta3(nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] 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)*rmom2_3 + 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 @@ -966,7 +958,7 @@ subroutine vrbeta3(nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] 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**p + frow=s*rrc**this%p tb=tb+frow*a(:,jx,jy,jz) enddo! gx enddo! gy @@ -978,10 +970,11 @@ end subroutine vrbeta3 ! Vector versions of the above routines: !============================================================================= -subroutine vrbeta1T(nv, hx,lx,mx, el,ss, a) ! [rbetat] +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 @@ -996,22 +989,23 @@ subroutine vrbeta1T(nv, hx,lx,mx, el,ss, a) ! [rbetat] b=0 do ix=Lx,Mx ta=a(:,ix); s=ss(ix) - exx=el(1,1,ix)*rmom2_1 + 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**p + frow=s*rrc**this%p b(:,jx)=b(:,jx)+frow*ta enddo enddo a=b end subroutine vrbeta1t !============================================================================= -subroutine vrbeta2T(nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] +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 @@ -1031,7 +1025,7 @@ subroutine vrbeta2T(nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] b=0 do iy=Ly,My; do ix=Lx,Mx ta=a(:,ix,iy); s=ss(ix,iy) - tel=el(:,:,ix,iy)*rmom2_2 ! This el, rescaled + 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 @@ -1041,7 +1035,7 @@ subroutine vrbeta2T(nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] 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**p + frow=s*rrc**this%p b(:,jx,jy)=b(:,jx,jy)+frow*ta enddo! gx enddo! gy @@ -1050,10 +1044,11 @@ subroutine vrbeta2T(nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] end subroutine vrbeta2t !============================================================================= -subroutine vrbeta3T(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] +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,& @@ -1077,7 +1072,7 @@ subroutine vrbeta3T(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] 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)*rmom2_3 + 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 @@ -1090,7 +1085,7 @@ subroutine vrbeta3T(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] 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**p + frow=s*rrc**this%p b(:,jx,jy,jz)=b(:,jx,jy,jz)+frow*ta enddo! gx enddo! gy @@ -1099,5 +1094,5 @@ subroutine vrbeta3T(nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] a=b end subroutine vrbeta3t -end module jp_pbfil +end submodule jp_pbfil diff --git a/src/saber/mgbf/mgbf_lib/k.f90 b/src/saber/mgbf/mgbf_lib/k.f90 deleted file mode 100644 index c24e1d7fa..000000000 --- a/src/saber/mgbf/mgbf_lib/k.f90 +++ /dev/null @@ -1,206 +0,0 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -module type_mgbf_mod -!*********************************************************************** -! ! -! Multigrid Beta filter for modeling background error covariance ! -! ! -! M. Rancic (2020) ! -!*********************************************************************** -use mpi -use kinds, only: r_kind,i_kind -use mg_entrymod, only:mg_entrymod_type, mg_initialize,mg_finalize -use mg_mppstuff, only: finishMPI,mype -use mg_filtering, only: mg_filtering_procedure -use mg_transfer, only: mg_transfer_type,anal_to_filt_all,filt_to_anal_all -use mg_parameter, only: mgbf_proc -use type_fieldset, only: fieldset_type -implicit none -type mgbf_type - type(mg_entrymod_type):: mg_entrymod - type(mg_transfer_type):: mg_transfer - contains - procedure,pass:: mgbf_init - procedure,pass:: mgbf_apply - procedure,nopass:: mgbf_finalize -end type mgbf_type -!----------------------------------------------------------------------- -contains - -subroutine mgbf_init(this) - class (mgbf_type),intent(in)::this -!*** -!*** Initialzie multigrid Beta filter -!*** - write(6,*)'thinkdeb in type_mgbf before mg_initialize in mgbf_init' - call flush(6) - call this%mg_entrymod%mg_initialize - write(6,*)'thinkdeb in type_mgbf after mg_initialize in mgbf_init' - call flush(6) - -end subroutine mgbf_init - -!*** -!*** From the analysis to first generation of filter grid -!*** - subroutine mgbf_apply(this,fieldset) - use mg_intstate,only: worka - use atlas_module, only: atlas_fieldset,atlas_field,atlas_functionspace - use mg_parameter, only: km,n0,nm,m0,mm - type(atlas_functionspace) :: afunctionspace - class (mgbf_type),intent(in):: this - type(atlas_field) :: afield - type(atlas_fieldset),intent(inout) :: fieldset !< Fieldset - real(kind=r_kind), pointer :: t(:,:) - real(kind=r_kind), allocatable :: trev(:,:,:) - integer(i_kind)::i,j,k,ij,ii,jj,nx,ny - integer(i_kind)::jedi_nx,jedi_ny,istart,jstart - if(mype == 0) then - jedi_nx=51 - jedi_ny=27 ! they include halo points - else - jedi_nx=50 - jedi_ny=26 - endif - nx=nm-n0 !clt i#+1 - ny=mm-m0 !clt#+1 - istart=(jedi_nx-nx)/2 - jstart=(jedi_ny-ny)/2 - istart=0;jstart=0 - allocate(trev(jedi_nx,jedi_ny,km)) - write(6,*)'thinkdeb in type_mgbf.f90 apply begin ' - write(6,*)'thinkdebtype_mgbf.f90applybe nx..',nx,ny,jedi_nx,jedi_ny,istart,jstart - call flush(6) - afield = fieldset%field('air_temperature') - call afield%data(t) - write(6,*)'thinkdeb in type_mgbf.f90 apply begin2km ny,nx ',km,ny,nx,size(t,dim=2) - write(6,*)'thinkdeb in type_mgbf.f90 apply begin2km ny,nx2 ',km,ny,nx,size(t,1) - call flush(6) - do k=1,km - ij=1 - do j=1,jedi_ny - do i=1,jedi_nx -! i=ii+n0-1 -! j=jj+m0-1 -!clt worka(k,i,j)=t(k,ij) - trev(i,j,k)=t(k,ij) - ij=ij+1 - enddo - enddo - enddo - worka=0 - do k=1,km - do j=1,ny - do i=1,nx - worka(k,i,j)=trev(istart+i,jstart+j,k) ! no flipping of i,j) - enddo - enddo - enddo -! worka(:,n0,:)=worka(:,n0+1,:) -! worka(:,:,m0)=worka(:,:,m0) - - write(6,*)'thinkdeb in type_mgbf.f90 apply begin 3 ' - call flush(6) - - call this%mg_transfer%anal_to_filt_all !cltthink (fieldset) - write(6,*)'thinkdeb in type_mgbf.f90 apply begin 4 ' - call flush(6) - - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -!*** -!*** Adjoint test if needed -!*** - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - -!*** -!*** Filtering -!*** -!====================================================================== - -!clt call mgbf_obj_in%mg_transfer%mg_filtering_procedure(mgbf_proc,fieldset) - write(6,*)'thinkdeb in type_mgbf.f90 apply begin 5 ' - call flush(6) - call mg_filtering_procedure(mgbf_proc) !cltthink ,fieldset) - -!====================================================================== - -!*** -!*** From first generation of filter grid to analysis grid (x-directoin) -!*** - write(6,*)'thinkdeb in type_mgbf.f90 apply begin 6' - call flush(6) - - call this%mg_transfer%filt_to_anal_all !cltthink (fieldset) - - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -!*** -!*** Adjoint test if needed -!*** - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -! Halo exchange - write(6,*)'thinkdeb in type_mgbf.f90apply begin 7',jedi_ny,ny,worka(10,25,ny) - write(6,*)'thinkdeb in type_mgbf.f90apply begin 7',jedi_ny,ny,worka(10,25,ny-1) - call flush(6) - do k=1,km - trev(:,:,k)=worka(k,1,1) - trev(1:nx,jedi_ny,k)=worka(k,1:nx,ny) - enddo - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.1',jedi_ny,ny,trev(25,jedi_ny,10) - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.1',jedi_ny,ny,trev(25,jedi_ny-1,10) - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.1',jedi_ny,ny,trev(25,jedi_ny-2,10) - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.1',jedi_ny,ny,trev(25,jedi_ny-3,10) - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.1',jedi_ny,ny,trev(25,jedi_ny-4,10) - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.1',jedi_ny,ny,trev(25,jedi_ny-5,10) - do k=1,km - do j=1,ny - do i=1,nx -!cltbfore worka(k,i,j)=trev(j,i,k) ! flipping of i,j) - trev(istart+i,jstart+j,k)= worka(k,i,j) !=trev(j,i,k) ! flipping of i,j) - enddo - enddo - enddo -!clt trev(1:jedi_nx,jedi_ny,10)=0.093 - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.2',jedi_ny,ny,trev(25,jedi_ny,10) - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.2',jedi_ny,ny,trev(25,jedi_ny-1,10) - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.2',jedi_ny,ny,trev(25,jedi_ny-2,10) - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.2',jedi_ny,ny,trev(25,jedi_ny-3,10) - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.2',jedi_ny,ny,trev(25,jedi_ny-4,10) - write(6,*)'thinkdeb intype_mgbf.f90apply begin 7.2',jedi_ny,ny,trev(25,jedi_ny-5,10) - do k=1,km - ij=1 - do j=1,jedi_ny - do i=1,jedi_nx -! i=ii+n0-1 -! j=jj+m0-1 -!cltbefore trev(i,j,k)=t(k,ij) - t(k,ij)=trev(i,j,k) - ij=ij+1 - enddo - enddo - enddo - -deallocate(trev) -afunctionspace = afield%functionspace() -call afunctionspace%halo_exchange(afield) - - write(6,*)'thinkdeb in type_mgbf.f90 apply begin 8 ' - call flush(6) - - - -!==================== Forward (Smoothing step) ======================== -!*** -!*** DONE! Deallocate variables -end subroutine mgbf_apply -!*** -subroutine mgbf_finalize(this) - class (mgbf_type),intent(in)::this - call this%mg_entrymod%mg_finalize -end subroutine mgbf_finalize - - -!----------------------------------------------------------------------- -end module type_mgbf_mod diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index 7ba897b4d..4693986a2 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -1,5 +1,5 @@ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_bocos + submodule(mg_intstate) mg_bocos !*********************************************************************** ! ! ! Provide communication between subdomains and supply halos on ! @@ -10,25 +10,13 @@ module mg_bocos ! Modules: kinds, mg_mppstuff, mg_parameter, mg_domain ! ! M. Rancic (2022) ! !*********************************************************************** -use mpi +!use mpi use kinds, only: r_kind,i_kind !use mpimod, only: mype,mpi_comm_world -use mg_mppstuff, only: mype,mpi_comm_world,mpi_comm_work -use mg_mppstuff, only: itype,rtype,dtype,mpi_comm_comp,my_hgen & - ,barrierMPI,finishMPI,l_hgen,mype_hgen -use mg_parameter, only: gm -implicit none -interface boco_2d - module procedure boco_2d_g1 - module procedure boco_2d_gh -endinterface +implicit none -interface bocoT_2d - module procedure bocoT_2d_g1 - module procedure bocoT_2d_gh -endinterface interface boco_3d module procedure boco_3d_g1 @@ -74,7 +62,7 @@ module mg_bocos !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine boco_2d_g1 & + module subroutine boco_2d_g1 & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -84,18 +72,17 @@ subroutine boco_2d_g1 & ! - offset version - ! ! ! !**********************************************************************! -(W,km,im,jm,nbx,nby) +(this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- -use mg_domain, only: Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e & - ,Flwest,Fleast,Flsouth,Flnorth -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby -real(r_kind),dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +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(:,:,:):: & @@ -111,6 +98,10 @@ subroutine boco_2d_g1 & integer(i_kind) ndatax,ndatay,nbxy 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 @@ -132,13 +123,13 @@ subroutine boco_2d_g1 & lsouth = Flsouth(g_ind) lnorth = Flnorth(g_ind) - imax = im - jmax = jm + imax = im_in + jmax = jm_in !----------------------------------------------------------------------- - ndatay = km*imax*nby - ndatax = km*(jmax+2*nby)*nbx + ndatay = km_in*imax*nby + ndatax = km_in*(jmax+2*nby)*nbx ! ! SEND boundaries toward SOUTH and NORTH @@ -149,7 +140,7 @@ subroutine boco_2d_g1 & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km,1:imax,nby), stat = iaerr ) + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -166,7 +157,7 @@ subroutine boco_2d_g1 & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km,1:imax,nby), stat = iaerr ) + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -187,7 +178,7 @@ subroutine boco_2d_g1 & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( rBuf_N(1:km,1:imax,nby), stat = iaerr ) + 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 ) @@ -199,7 +190,7 @@ subroutine boco_2d_g1 & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( rBuf_S(1:km,1:imax,nby), stat = iaerr ) + 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 ) @@ -259,7 +250,7 @@ subroutine boco_2d_g1 & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km,nbx,1-nby:jmax+nby), stat = iaerr ) + allocate( sBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) do j=1-nby,jmax+nby do i=1,nbx @@ -277,7 +268,7 @@ subroutine boco_2d_g1 & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km,nbx,1-nby:jmax+nby), stat = iaerr ) + allocate( sBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) do j=1-nby,jmax+nby do i=1,nbx @@ -299,7 +290,7 @@ subroutine boco_2d_g1 & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( rBuf_E(1:km,nbx,1-nby:jmax+nby), stat = iaerr ) + 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 ) @@ -311,7 +302,7 @@ subroutine boco_2d_g1 & if( itarg_w >= 0 ) then nebpe = itarg_w - allocate( rBuf_W(1:km,nbx,1-nby:jmax+nby), stat = iaerr ) + 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 ) @@ -411,7 +402,7 @@ subroutine boco_2d_g1 & endsubroutine boco_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine boco_2d_gh & + module subroutine boco_2d_gh & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -421,19 +412,17 @@ subroutine boco_2d_gh & ! - offset version - ! ! ! !**********************************************************************! -(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mg_domain, only: Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e & - ,Flwest,Fleast,Flsouth,Flnorth - -!cltuse mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max -real(r_kind),dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W -integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +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(:,:,:):: & @@ -449,6 +438,10 @@ subroutine boco_2d_gh & 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 @@ -482,20 +475,20 @@ subroutine boco_2d_gh & if(least) then - imax = Fimax(g) + imax = Fimax_in(g) else - imax = im ! << Note that is not necesseraly im from + imax = im_in ! << Note that is not necesseraly im from endif ! mg_parameter. Could be also imL >>> if(lnorth) then - jmax = Fjmax(g) + jmax = Fjmax_in(g) else - jmax = jm + jmax = jm_in endif !----------------------------------------------------------------------- - ndatay = km*imax*nby - ndatax = km*(jmax+2*nby)*nbx + ndatay = km_in*imax*nby + ndatax = km_in*(jmax+2*nby)*nbx ! @@ -507,7 +500,7 @@ subroutine boco_2d_gh & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km,1:imax,nby), stat = iaerr ) + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -524,7 +517,7 @@ subroutine boco_2d_gh & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km,1:imax,nby), stat = iaerr ) + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -545,7 +538,7 @@ subroutine boco_2d_gh & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( rBuf_N(1:km,1:imax,nby), stat = iaerr ) + 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 ) @@ -557,7 +550,7 @@ subroutine boco_2d_gh & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( rBuf_S(1:km,1:imax,nby), stat = iaerr ) + 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 ) @@ -619,7 +612,7 @@ subroutine boco_2d_gh & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km,nbx,1-nby:jmax+nby), stat = iaerr ) + allocate( sBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) do j=1-nby,jmax+nby do i=1,nbx @@ -637,7 +630,7 @@ subroutine boco_2d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km,nbx,1-nby:jmax+nby), stat = iaerr ) + allocate( sBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) do j=1-nby,jmax+nby do i=1,nbx @@ -659,7 +652,7 @@ subroutine boco_2d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( rBuf_E(1:km,nbx,1-nby:jmax+nby), stat = iaerr ) + 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 ) @@ -671,7 +664,7 @@ subroutine boco_2d_gh & if( itarg_w >= 0 ) then nebpe = itarg_w - allocate( rBuf_W(1:km,nbx,1-nby:jmax+nby), stat = iaerr ) + 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 ) @@ -772,7 +765,7 @@ subroutine boco_2d_gh & endsubroutine boco_2d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocoT_2d_g1 & + module subroutine bocoT_2d_g1 & !*********************************************************************** ! ! ! Adjoint of side sending subroutine: ! @@ -783,17 +776,16 @@ subroutine bocoT_2d_g1 & ! - offset version - ! ! ! !*********************************************************************** -(W,km,im,jm,nbx,nby) +(this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- -use mg_domain, only: Flwest,Fleast,Flsouth,Flnorth & - ,Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby -real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +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(:,:,:):: & @@ -810,6 +802,10 @@ subroutine bocoT_2d_g1 & 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 ! @@ -829,14 +825,13 @@ subroutine bocoT_2d_g1 & lsouth = Flsouth(g_ind) lnorth = Flnorth(g_ind) - imax = im - jmax = jm + imax = im_in + jmax = jm_in !---------------------------------------------------------------------- - ndatax =km*(jmax+2*nby)*nbx - ndatay =km*imax*nby - + ndatax =km_in*(jmax+2*nby)*nbx + ndatay =km_in*imax*nby ! ! SEND extended halos toward WEST and EAST ! @@ -846,7 +841,7 @@ subroutine bocoT_2d_g1 & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km,1:nbx,1-nby:jmax+nby), stat = iaerr ) + allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) do j=1-nby,jmax+nby do i=1,nbx @@ -855,7 +850,7 @@ subroutine bocoT_2d_g1 & enddo call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & - mpi_comm_world, sHandle(4), isend) + mpi_comm_comp, sHandle(4), isend) end if @@ -864,7 +859,7 @@ subroutine bocoT_2d_g1 & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km,1:nbx,1-nby:jmax+nby), stat = iaerr ) + allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) do j=1-nby,jmax+nby do i=1,nbx @@ -873,7 +868,7 @@ subroutine bocoT_2d_g1 & enddo call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & - mpi_comm_world, sHandle(2), isend) + mpi_comm_comp, sHandle(2), isend) end if @@ -887,9 +882,9 @@ subroutine bocoT_2d_g1 & nebpe = itarg_e - allocate( rBuf_E(1:km,1:nbx,1-nby:jmax+nby), stat = iaerr ) + 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_world, rHandle(2), irecv) + mpi_comm_comp, rHandle(2), irecv) call MPI_WAIT( rHandle(2), istat, ierr ) end if @@ -900,9 +895,9 @@ subroutine bocoT_2d_g1 & nebpe = itarg_w - allocate( rBuf_W(1:km,1:nbx,1-nby:jmax+nby), stat = iaerr ) + 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_world, rHandle(4), irecv) + mpi_comm_comp, rHandle(4), irecv) call MPI_WAIT( rHandle(4), istat, ierr ) @@ -952,7 +947,7 @@ subroutine bocoT_2d_g1 & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km,1:imax,1:nby), stat = iaerr ) + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) do j=1-nby,0 do i=1,imax @@ -961,7 +956,7 @@ subroutine bocoT_2d_g1 & enddo call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & - mpi_comm_world, sHandle(3), isend) + mpi_comm_comp, sHandle(3), isend) end if ! --- toward NORTH --- @@ -969,7 +964,7 @@ subroutine bocoT_2d_g1 & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km,1:imax,1:nby), stat = iaerr ) + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -978,7 +973,7 @@ subroutine bocoT_2d_g1 & enddo call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & - mpi_comm_world, sHandle(1), isend) + mpi_comm_comp, sHandle(1), isend) end if @@ -991,9 +986,9 @@ subroutine bocoT_2d_g1 & nebpe = itarg_n - allocate( rBuf_N(1:km,1:imax,1:nby), stat = iaerr ) + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & - mpi_comm_world, rHandle(1), irecv) + mpi_comm_comp, rHandle(1), irecv) call MPI_WAIT( rHandle(1), istat, ierr ) end if @@ -1004,9 +999,9 @@ subroutine bocoT_2d_g1 & nebpe = itarg_s - allocate( rBuf_S(1:km,1:imax,1:nby), stat = iaerr ) + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & - mpi_comm_world, rHandle(3), irecv) + mpi_comm_comp, rHandle(3), irecv) call MPI_WAIT( rHandle(3), istat, ierr ) @@ -1080,7 +1075,7 @@ subroutine bocoT_2d_g1 & endsubroutine bocoT_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocoT_2d_gh & + module subroutine bocoT_2d_gh & !*********************************************************************** ! ! ! Supply n-lines inside of domains, including edges, with halos from ! @@ -1090,18 +1085,17 @@ subroutine bocoT_2d_gh & ! - offset version - ! ! ! !*********************************************************************** -(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mg_domain, only: Flwest,Fleast,Flsouth,Flnorth & - ,Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max -real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W -integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +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(:,:,:):: & @@ -1117,6 +1111,10 @@ subroutine bocoT_2d_gh & 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 ! @@ -1152,20 +1150,20 @@ subroutine bocoT_2d_gh & if(least) then - imax = Fimax(g) + imax = Fimax_in(g) else - imax = im ! << Note that is not necesseraly im from + imax = im_in ! << Note that is not necesseraly im from endif ! mg_parameter. Could be also imL >>> if(lnorth) then - jmax = Fjmax(g) + jmax = Fjmax_in(g) else - jmax = jm + jmax = jm_in endif !---------------------------------------------------------------------- - ndatax =km*(jmax+2*nby)*nbx - ndatay =km*imax*nby + ndatax =km_in*(jmax+2*nby)*nbx + ndatay =km_in*imax*nby ! ! SEND extended halos toward WEST and EAST @@ -1176,7 +1174,7 @@ subroutine bocoT_2d_gh & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km,1:nbx,1-nby:jmax+nby), stat = iaerr ) + allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) do j=1-nby,jmax+nby do i=1,nbx @@ -1194,7 +1192,7 @@ subroutine bocoT_2d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km,1:nbx,1-nby:jmax+nby), stat = iaerr ) + allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) do j=1-nby,jmax+nby do i=1,nbx @@ -1216,7 +1214,7 @@ subroutine bocoT_2d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( rBuf_E(1:km,1:nbx,1-nby:jmax+nby), stat = iaerr ) + 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 ) @@ -1228,7 +1226,7 @@ subroutine bocoT_2d_gh & if( itarg_w >= 0 ) then nebpe = itarg_w - allocate( rBuf_W(1:km,1:nbx,1-nby:jmax+nby), stat = iaerr ) + 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 ) @@ -1278,7 +1276,7 @@ subroutine bocoT_2d_gh & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km,1:imax,1:nby), stat = iaerr ) + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -1295,7 +1293,7 @@ subroutine bocoT_2d_gh & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km,1:imax,1:nby), stat = iaerr ) + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -1318,7 +1316,7 @@ subroutine bocoT_2d_gh & nebpe = itarg_n - allocate( rBuf_N(1:km,1:imax,1:nby), stat = iaerr ) + 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 ) @@ -1331,7 +1329,7 @@ subroutine bocoT_2d_gh & nebpe = itarg_s - allocate( rBuf_S(1:km,1:imax,1:nby), stat = iaerr ) + 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 ) @@ -1410,7 +1408,7 @@ subroutine bocoT_2d_gh & endsubroutine bocoT_2d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine boco_3d_g1 & + module subroutine boco_3d_g1 & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -1420,20 +1418,18 @@ subroutine boco_3d_g1 & ! - offset version - ! ! ! !**********************************************************************! -(W,km3,im,jm,Lm,nbx,nby,nbz,Fimax,Fjmax) +(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) !----------------------------------------------------------------------- -use mg_domain, only: Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e & - ,Flwest,Fleast,Flsouth,Flnorth - -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km3,im,jm,Lm,nbx,nby,nbz -real(r_kind),dimension(km3,1-nbx:im+nbx,1-nby:jm+nby,1-nbz:Lm+nbz) & +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(gm), intent(in):: Fimax,Fjmax +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in !----------------------------------------------------------------------- real(r_kind), allocatable, dimension(:,:,:,:):: & @@ -1450,6 +1446,10 @@ subroutine boco_3d_g1 & 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 ! @@ -1465,12 +1465,12 @@ subroutine boco_3d_g1 & lsouth = Flsouth(g_ind) lnorth = Flnorth(g_ind) - imax = im - jmax = jm + imax = im_in + jmax = jm_in !----------------------------------------------------------------------- - ndatay = km3*imax*nby*Lm - ndatax = km3*(jmax+2*nby)*nbx*Lm + ndatay = km3_in*imax*nby*Lm + ndatax = km3_in*(jmax+2*nby)*nbx*Lm_in ! @@ -1482,9 +1482,9 @@ subroutine boco_3d_g1 & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km3,1:imax,nby,1:Lm), stat = iaerr ) + allocate( sBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax sBuf_S(:,i,j,L) = W(:,i,j,L) @@ -1501,9 +1501,9 @@ subroutine boco_3d_g1 & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km3,1:imax,nby,1:Lm), stat = iaerr ) + allocate( sBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax sBuf_N(:,i,j,L)=W(:,i,jmax-nby+j,L) @@ -1524,7 +1524,7 @@ subroutine boco_3d_g1 & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( rBuf_N(1:km3,1:imax,nby,1:Lm), stat = iaerr ) + 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 ) @@ -1536,7 +1536,7 @@ subroutine boco_3d_g1 & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( rBuf_S(1:km3,1:imax,nby,1:Lm), stat = iaerr ) + 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 ) @@ -1550,7 +1550,7 @@ subroutine boco_3d_g1 & if( lnorth) then - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax W(:,i,jmax+j,L)=W(:,i,jmax+1-j,L) @@ -1560,7 +1560,7 @@ subroutine boco_3d_g1 & else - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax W(:,i,jmax+j,L)=rBuf_N(:,i,j,L) @@ -1574,7 +1574,7 @@ subroutine boco_3d_g1 & if(lsouth) then - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax W(:,i,-nby+j,L)=W(:,i,nby+1-j,L) @@ -1584,7 +1584,7 @@ subroutine boco_3d_g1 & else - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax W(:,i,-nby+j,L)=rBuf_S(:,i,j,L) @@ -1602,9 +1602,9 @@ subroutine boco_3d_g1 & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km3,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + allocate( sBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) - do L=1,Lm + do L=1,Lm_in do j=1-nby,jmax+nby do i=1,nbx sBuf_W(:,i,j,L) = W(:,i,j,L) @@ -1622,9 +1622,9 @@ subroutine boco_3d_g1 & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km3,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + allocate( sBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) - do L=1,Lm + 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) @@ -1646,7 +1646,7 @@ subroutine boco_3d_g1 & if( itarg_w >= 0 ) then nebpe = itarg_w - allocate( rBuf_W(1:km3,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + 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 ) @@ -1658,7 +1658,7 @@ subroutine boco_3d_g1 & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( rBuf_E(1:km3,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + 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 ) @@ -1672,7 +1672,7 @@ subroutine boco_3d_g1 & if(lwest) then - do L=1,Lm + 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) @@ -1682,7 +1682,7 @@ subroutine boco_3d_g1 & else - do L=1,Lm + 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) @@ -1697,7 +1697,7 @@ subroutine boco_3d_g1 & if(least) then - do L=1,Lm + 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) @@ -1707,7 +1707,7 @@ subroutine boco_3d_g1 & else - do L=1,Lm + 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) @@ -1762,7 +1762,7 @@ subroutine boco_3d_g1 & endsubroutine boco_3d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine boco_3d_gh & + module subroutine boco_3d_gh & !**********************************************************************! ! Side sending subroutine: ! @@ -1772,20 +1772,19 @@ subroutine boco_3d_gh & ! - offset version - ! ! ! !**********************************************************************! -(W,km3,im,jm,Lm,nbx,nby,nbz,Fimax,Fjmax,mygen_min,mygen_max) +(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mg_domain, only: Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e & - ,Flwest,Fleast,Flsouth,Flnorth -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km3,im,jm,Lm,nbx,nby,nbz,mygen_min,mygen_max -real(r_kind),dimension(km3,1-nbx:im+nbx,1-nby:jm+nby,1-nbz:Lm+nbz) & +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(gm), intent(in):: Fimax,Fjmax +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in !----------------------------------------------------------------------- real(r_kind), allocatable, dimension(:,:,:,:):: & @@ -1801,6 +1800,10 @@ subroutine boco_3d_gh & 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 @@ -1832,20 +1835,20 @@ subroutine boco_3d_gh & lnorth = Flnorth(g_ind) if(least) then - imax = Fimax(g) + imax = Fimax_in(g) else - imax = im ! << Note that is not necesseraly im from + imax = im_in ! << Note that is not necesseraly im from endif ! mg_parameter. Could be also imL >>> if(lnorth) then - jmax = Fjmax(g) + jmax = Fjmax_in(g) else - jmax = jm + jmax = jm_in endif !----------------------------------------------------------------------- - ndatay = km3*imax*nby*Lm - ndatax = km3*(jmax+2*nby)*nbx*Lm + ndatay = km3_in*imax*nby*Lm + ndatax = km3_in*(jmax+2*nby)*nbx*Lm ! ! SEND boundaries to SOUTH and NORTH @@ -1856,9 +1859,9 @@ subroutine boco_3d_gh & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km3,1:imax,nby,1:Lm), stat = iaerr ) + allocate( sBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax sBuf_S(:,i,j,L) = W(:,i,j,L) @@ -1875,9 +1878,9 @@ subroutine boco_3d_gh & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km3,1:imax,nby,1:Lm), stat = iaerr ) + allocate( sBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax sBuf_N(:,i,j,L)=W(:,i,jmax-nby+j,L) @@ -1898,7 +1901,7 @@ subroutine boco_3d_gh & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( rBuf_N(1:km3,1:imax,nby,1:Lm), stat = iaerr ) + 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 ) @@ -1910,7 +1913,7 @@ subroutine boco_3d_gh & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( rBuf_S(1:km3,1:imax,nby,1:Lm), stat = iaerr ) + 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 ) @@ -1936,7 +1939,7 @@ subroutine boco_3d_gh & if( lnorth) then - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax W(:,i,jmax+j,L)=W(:,i,jmax+1-j,L) @@ -1946,7 +1949,7 @@ subroutine boco_3d_gh & else - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax W(:,i,jmax+j,L)=rBuf_N(:,i,j,L) @@ -1960,7 +1963,7 @@ subroutine boco_3d_gh & if(lsouth) then - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax W(:,i,-nby+j,L)=W(:,i,nby+1-j,L) @@ -1970,7 +1973,7 @@ subroutine boco_3d_gh & else - do L=1,Lm + do L=1,Lm_in do j=1,nby do i=1,imax W(:,i,-nby+j,L)=rBuf_S(:,i,j,L) @@ -1999,9 +2002,9 @@ subroutine boco_3d_gh & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km3,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + allocate( sBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) - do L=1,Lm + do L=1,Lm_in do j=1-nby,jmax+nby do i=1,nbx sBuf_W(:,i,j,L) = W(:,i,j,L) @@ -2019,9 +2022,9 @@ subroutine boco_3d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km3,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + allocate( sBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) - do L=1,Lm + 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) @@ -2043,7 +2046,7 @@ subroutine boco_3d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( rBuf_E(1:km3,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + 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 ) @@ -2055,7 +2058,7 @@ subroutine boco_3d_gh & if( itarg_w >= 0 ) then nebpe = itarg_w - allocate( rBuf_W(1:km3,nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + 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 ) @@ -2081,7 +2084,7 @@ subroutine boco_3d_gh & if(lwest) then - do L=1,Lm + 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) @@ -2091,7 +2094,7 @@ subroutine boco_3d_gh & else - do L=1,Lm + 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) @@ -2106,7 +2109,7 @@ subroutine boco_3d_gh & if(least) then - do L=1,Lm + 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) @@ -2116,7 +2119,7 @@ subroutine boco_3d_gh & else - do L=1,Lm + 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) @@ -2158,7 +2161,7 @@ subroutine boco_3d_gh & endsubroutine boco_3d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocoT_3d_g1 & + module subroutine bocoT_3d_g1 & !*********************************************************************** ! * ! Supply n-lines inside of domains, including edges, with halos from * @@ -2168,19 +2171,18 @@ subroutine bocoT_3d_g1 & ! - offset version - ! ! * !*********************************************************************** -(W,km3,im,jm,Lm,nbx,nby,nbz,Fimax,Fjmax) +(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) !----------------------------------------------------------------------- -use mg_domain, only: Flwest,Fleast,Flsouth,Flnorth & - ,Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km3,im,jm,Lm,nbx,nby,nbz -real(r_kind), dimension(km3,1-nbx:im+nbx,1-nby:jm+nby,1-nbz:Lm+nbz) & +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(gm), intent(in):: Fimax,Fjmax +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in !----------------------------------------------------------------------- real(r_kind), allocatable, dimension(:,:,:,:):: & @@ -2196,6 +2198,10 @@ subroutine bocoT_3d_g1 & 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 @@ -2221,8 +2227,8 @@ subroutine bocoT_3d_g1 & jmax = jm !---------------------------------------------------------------------- - ndatax =km3*(jmax+2*nby)*nbx *Lm - ndatay =km3*imax*nby *Lm + ndatax =km3_in*(jmax+2*nby)*nbx *Lm_in + ndatay =km3_in*imax*nby *Lm_in ! ! SEND extended halos toward WEST and EAST @@ -2232,9 +2238,9 @@ subroutine bocoT_3d_g1 & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km3,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + allocate( sBuf_W(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) - do L=Lm,1,-1 + 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) @@ -2243,7 +2249,7 @@ subroutine bocoT_3d_g1 & enddo call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & - mpi_comm_world, sHandle(4), isend) + mpi_comm_comp, sHandle(4), isend) end if @@ -2252,9 +2258,9 @@ subroutine bocoT_3d_g1 & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km3,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + allocate( sBuf_E(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) - do L=Lm,1,-1 + 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) @@ -2263,7 +2269,7 @@ subroutine bocoT_3d_g1 & enddo call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & - mpi_comm_world, sHandle(2), isend) + mpi_comm_comp, sHandle(2), isend) end if ! @@ -2275,9 +2281,9 @@ subroutine bocoT_3d_g1 & nebpe = itarg_e - allocate( rBuf_E(1:km3,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + 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_world, rHandle(2), irecv) + mpi_comm_comp, rHandle(2), irecv) call MPI_WAIT( rHandle(2), istat, ierr ) end if @@ -2288,9 +2294,9 @@ subroutine bocoT_3d_g1 & nebpe = itarg_w - allocate( rBuf_W(1:km3,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + 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_world, rHandle(4), irecv) + mpi_comm_comp, rHandle(4), irecv) call MPI_WAIT( rHandle(4), istat, ierr ) @@ -2302,7 +2308,7 @@ subroutine bocoT_3d_g1 & ! From west if(lwest) then - do L=1,lm + 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) @@ -2310,7 +2316,7 @@ subroutine bocoT_3d_g1 & end do end do else - do L=1,lm + 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) @@ -2322,7 +2328,7 @@ subroutine bocoT_3d_g1 & ! From east if(least) then - do L=1,lm + 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) @@ -2330,7 +2336,7 @@ subroutine bocoT_3d_g1 & end do end do else - do L=1,lm + 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) @@ -2348,9 +2354,9 @@ subroutine bocoT_3d_g1 & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km3,1:imax,1:nby,1:Lm), stat = iaerr ) + allocate( sBuf_S(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) - do L=Lm,1,-1 + 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) @@ -2359,7 +2365,7 @@ subroutine bocoT_3d_g1 & enddo call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & - mpi_comm_world, sHandle(3), isend) + mpi_comm_comp, sHandle(3), isend) end if ! --- toward NORTH --- @@ -2367,9 +2373,9 @@ subroutine bocoT_3d_g1 & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km3,1:imax,1:nby,1:Lm), stat = iaerr ) + allocate( sBuf_N(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) - do L=Lm,1,-1 + do L=Lm_in,1,-1 do j=1,nby do i=1,imax sBuf_N(:,i,j,L)=W(:,i,jmax+j,L) @@ -2378,7 +2384,7 @@ subroutine bocoT_3d_g1 & enddo call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & - mpi_comm_world, sHandle(1), isend) + mpi_comm_comp, sHandle(1), isend) end if @@ -2392,9 +2398,9 @@ subroutine bocoT_3d_g1 & nebpe = itarg_n - allocate( rBuf_N(1:km3,1:imax,1:nby,1:Lm), stat = iaerr ) + 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_world, rHandle(1), irecv) + mpi_comm_comp, rHandle(1), irecv) call MPI_WAIT( rHandle(1), istat, ierr ) end if @@ -2405,9 +2411,9 @@ subroutine bocoT_3d_g1 & nebpe = itarg_s - allocate( rBuf_S(1:km3,1:imax,1:nby,1:Lm), stat = iaerr ) + 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_world, rHandle(3), irecv) + mpi_comm_comp, rHandle(3), irecv) call MPI_WAIT( rHandle(3), istat, ierr ) @@ -2420,7 +2426,7 @@ subroutine bocoT_3d_g1 & ! From south if(lsouth) then - do L=1,lm + 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) @@ -2428,7 +2434,7 @@ subroutine bocoT_3d_g1 & end do end do else - do L=1,lm + 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) @@ -2440,7 +2446,7 @@ subroutine bocoT_3d_g1 & ! From north if(lnorth) then - do L=1,lm + 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) @@ -2448,7 +2454,7 @@ subroutine bocoT_3d_g1 & enddo enddo else - do L=1,lm + 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) @@ -2515,7 +2521,7 @@ subroutine bocoT_3d_g1 & endsubroutine bocoT_3d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocoT_3d_gh & + module subroutine bocoT_3d_gh & !*********************************************************************** ! * ! Supply n-lines inside of domains, including edges, with halos from * @@ -2525,19 +2531,18 @@ subroutine bocoT_3d_gh & ! - offset version - ! ! * !*********************************************************************** -(W,km,im,jm,Lm,nbx,nby,nbz,Fimax,Fjmax,mygen_min,mygen_max) +(this,W,km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mg_domain, only: Flwest,Fleast,Flsouth,Flnorth & - ,Fitarg_n,Fitarg_s,Fitarg_w,Fitarg_e -!cl use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,Lm,nbx,nby,nbz,mygen_min,mygen_max -real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+nby,1-nbz:Lm+nbz) & +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(gm), intent(in):: Fimax,Fjmax +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in !----------------------------------------------------------------------- real(r_kind), allocatable, dimension(:,:,:,:):: & @@ -2553,6 +2558,10 @@ subroutine bocoT_3d_gh & 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 @@ -2587,20 +2596,20 @@ subroutine bocoT_3d_gh & lnorth = Flnorth(g_ind) if(least) then - imax = Fimax(g) + imax = Fimax_in(g) else - imax = im ! << Note that is not necesseraly im from + imax = im_in ! << Note that is not necesseraly im from endif ! mg_parameter. Could be also imL >>> if(lnorth) then - jmax = Fjmax(g) + jmax = Fjmax_in(g) else - jmax = jm + jmax = jm_in endif !---------------------------------------------------------------------- - ndatax =km*(jmax+2*nby)*nbx *Lm - ndatay =km*imax*nby *Lm + ndatax =km_in*(jmax+2*nby)*nbx *Lm_in + ndatay =km_in*imax*nby *Lm_in ! ! SEND extended halos toward WEST and EAST @@ -2610,9 +2619,9 @@ subroutine bocoT_3d_gh & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) - do L=Lm,1,-1 + 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) @@ -2630,9 +2639,9 @@ subroutine bocoT_3d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) - do L=Lm,1,-1 + 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) @@ -2654,7 +2663,7 @@ subroutine bocoT_3d_gh & nebpe = itarg_e - allocate( rBuf_E(1:km,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + 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 ) @@ -2667,7 +2676,7 @@ subroutine bocoT_3d_gh & nebpe = itarg_w - allocate( rBuf_W(1:km,1:nbx,1-nby:jmax+nby,1:Lm), stat = iaerr ) + 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 ) @@ -2682,7 +2691,7 @@ subroutine bocoT_3d_gh & ! From west if(lwest) then - do L=1,lm + 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) @@ -2690,7 +2699,7 @@ subroutine bocoT_3d_gh & end do end do else - do L=1,lm + 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) @@ -2702,7 +2711,7 @@ subroutine bocoT_3d_gh & ! From east if(least) then - do L=1,lm + 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) @@ -2710,7 +2719,7 @@ subroutine bocoT_3d_gh & end do end do else - do L=1,lm + 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) @@ -2728,9 +2737,9 @@ subroutine bocoT_3d_gh & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km,1:imax,1:nby,1:Lm), stat = iaerr ) + allocate( sBuf_S(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) - do L=Lm,1,-1 + 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) @@ -2747,9 +2756,9 @@ subroutine bocoT_3d_gh & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km,1:imax,1:nby,1:Lm), stat = iaerr ) + allocate( sBuf_N(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) - do L=Lm,1,-1 + do L=Lm_in,1,-1 do j=1,nby do i=1,imax sBuf_N(:,i,j,L)=W(:,i,jmax+j,L) @@ -2772,7 +2781,7 @@ subroutine bocoT_3d_gh & nebpe = itarg_n - allocate( rBuf_N(1:km,1:imax,1:nby,1:Lm), stat = iaerr ) + 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 ) @@ -2785,7 +2794,7 @@ subroutine bocoT_3d_gh & nebpe = itarg_s - allocate( rBuf_S(1:km,1:imax,1:nby,1:Lm), stat = iaerr ) + 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 ) @@ -2800,7 +2809,7 @@ subroutine bocoT_3d_gh & ! if(lsouth) then - do L=1,lm + 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) @@ -2808,7 +2817,7 @@ subroutine bocoT_3d_gh & end do end do else - do L=1,lm + 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) @@ -2820,7 +2829,7 @@ subroutine bocoT_3d_gh & ! From north if(lnorth) then - do L=1,lm + 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) @@ -2828,7 +2837,7 @@ subroutine bocoT_3d_gh & enddo enddo else - do L=1,lm + 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) @@ -2896,7 +2905,7 @@ subroutine bocoT_3d_gh & endsubroutine bocoT_3d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine upsend_all_g1 & + module subroutine upsend_all_g1 & !*********************************************************************** ! ! ! Upsend data from generation one to generation two ! @@ -2904,31 +2913,28 @@ subroutine upsend_all_g1 & ! - offset version - ! ! ! !*********************************************************************** -(Harray,Warray,Lm_all) +(this,Harray,Warray,km_in) !----------------------------------------------------------------------- -use mg_parameter, only: im,jm,imL,jmL,hx,hy -use mg_domain, only: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne & - ,Fitarg_up & - ,itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw -!clt use mpi +use mpi !cltthink implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: Lm_all -real(r_kind), dimension(lm_all,1:imL,1:jmL),intent(in):: Harray -real(r_kind), dimension(lm_all,1-hx:im+hx,1-hy:jm+hy),intent(out):: Warray +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:lm_all,1:imL,1:jmL):: dBuf_SW -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_SE -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_NW -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_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 @@ -2938,6 +2944,10 @@ subroutine upsend_all_g1 & 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 @@ -2962,7 +2972,7 @@ subroutine upsend_all_g1 & Warray(:,:,:) = 0.0d0 endif - ndata =lm_all*imL*jmL + ndata =km_in*imL*jmL ! ! --- Send data to SW portion of processors at higher generation @@ -2982,7 +2992,7 @@ subroutine upsend_all_g1 & else - allocate( sBuf_SW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3038,7 +3048,7 @@ subroutine upsend_all_g1 & else - allocate( sBuf_SE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3095,7 +3105,7 @@ subroutine upsend_all_g1 & else - allocate( sBuf_NW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3152,7 +3162,7 @@ subroutine upsend_all_g1 & else - allocate( sBuf_NE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3199,7 +3209,7 @@ subroutine upsend_all_g1 & !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine upsend_all_gh & + module subroutine upsend_all_gh & !*********************************************************************** ! * ! Upsend data from one grid generation to another * @@ -3208,21 +3218,19 @@ subroutine upsend_all_gh & ! - offset version - ! ! * !*********************************************************************** -(Harray,Warray,Lm_all,mygen_dn,mygen_up) +(this,Harray,Warray,km_in,mygen_dn,mygen_up) +!cltthink km is this%km !----------------------------------------------------------------------- -use mg_parameter, only: im,jm,imL,jmL,hx,hy -use mg_domain, only: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne & - ,Fitarg_up & - ,itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw -!clt use mpi +use mpi !cltthink implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: Lm_all -real(r_kind), dimension(lm_all,1:imL,1:jmL),intent(in):: Harray -real(r_kind), dimension(lm_all,1-hx:im+hx,1-hy:jm+hy),intent(out):: Warray +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 !----------------------------------------------------------------------- @@ -3230,10 +3238,10 @@ subroutine upsend_all_gh & sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_SW -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_SE -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_NW -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_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 @@ -3242,6 +3250,10 @@ subroutine upsend_all_gh & 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" !----------------------------------------------------------------------- ! @@ -3264,7 +3276,7 @@ subroutine upsend_all_gh & Warray(:,:,:)=0.0d0 endif - ndata =lm_all*imL*jmL + ndata =km_in*imL*jmL !TEST ! if(mype==0) then ! write(0,*) 'From upsend_all_gh.f90: ndata=',ndata @@ -3277,7 +3289,7 @@ subroutine upsend_all_gh & nebpe = itarg_up - allocate( sBuf_SW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3305,7 +3317,7 @@ subroutine upsend_all_gh & nebpe = itargdn_sw - allocate( rBuf_SW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + 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) @@ -3331,7 +3343,7 @@ subroutine upsend_all_gh & nebpe = itarg_up - allocate( sBuf_SE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3356,7 +3368,7 @@ subroutine upsend_all_gh & nebpe = itargdn_se - allocate( rBuf_SE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + 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) @@ -3378,7 +3390,7 @@ subroutine upsend_all_gh & if( lsendup_nw ) then nebpe = itarg_up - allocate( sBuf_NW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3404,7 +3416,7 @@ subroutine upsend_all_gh & nebpe = itargdn_nw - allocate( rBuf_NW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + 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) @@ -3428,7 +3440,7 @@ subroutine upsend_all_gh & if( lsendup_ne ) then nebpe = itarg_up - allocate( sBuf_NE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3455,7 +3467,7 @@ subroutine upsend_all_gh & if( my_hgen==mygen_up .and. itargdn_ne >= 0 ) then nebpe = itargdn_ne - allocate( rBuf_NE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + 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) @@ -3480,7 +3492,7 @@ subroutine upsend_all_gh & endsubroutine upsend_all_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine downsend_all_gh & + module subroutine downsend_all_gh & !*********************************************************************** ! * ! Downsending data from low resolution pes (mygen_up) * @@ -3490,20 +3502,17 @@ subroutine downsend_all_gh & ! - offset version - ! ! * !*********************************************************************** -(Warray,Harray,lm_all,mygen_up,mygen_dn) +(this,Warray,Harray,km_in,mygen_up,mygen_dn) !----------------------------------------------------------------------- -use mg_parameter, only: im,jm,imL,jmL,hx,hy -use mg_domain, only: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne & - ,Fitarg_up & - ,itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: lm_all -real(r_kind), dimension(lm_all,1:im,1:jm),intent(in):: Warray -real(r_kind), dimension(lm_all,1:imL,1:jmL),intent(out):: Harray +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 !----------------------------------------------------------------------- @@ -3511,10 +3520,10 @@ subroutine downsend_all_gh & sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_SW -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_SE -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_NW -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_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 @@ -3523,6 +3532,10 @@ subroutine downsend_all_gh & 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 @@ -3538,7 +3551,7 @@ subroutine downsend_all_gh & itarg_up=Fitarg_up(g_ind) - ndata =lm_all*imL*jmL + ndata =km_in*imL*jmL ! ! --- Send data from SW portion of processors at the higher generation @@ -3549,7 +3562,7 @@ subroutine downsend_all_gh & nebpe = itargdn_sw - allocate( sBuf_SW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3573,7 +3586,7 @@ subroutine downsend_all_gh & nebpe = itarg_up - allocate( rBuf_SW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + 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) @@ -3596,7 +3609,7 @@ subroutine downsend_all_gh & if(my_hgen==mygen_up .and. itargdn_se >= 0 ) then nebpe = itargdn_se - allocate( sBuf_SE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3619,7 +3632,7 @@ subroutine downsend_all_gh & nebpe = itarg_up - allocate( rBuf_SE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + 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) @@ -3643,7 +3656,7 @@ subroutine downsend_all_gh & nebpe = itargdn_nw - allocate( sBuf_NW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3666,7 +3679,7 @@ subroutine downsend_all_gh & nebpe = itarg_up - allocate( rBuf_NW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + 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) @@ -3691,7 +3704,7 @@ subroutine downsend_all_gh & nebpe = itargdn_ne - allocate( sBuf_NE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3713,7 +3726,7 @@ subroutine downsend_all_gh & if( lsendup_ne ) then nebpe = itarg_up - allocate( rBuf_NE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + 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) @@ -3733,7 +3746,7 @@ subroutine downsend_all_gh & endsubroutine downsend_all_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine downsend_all_g2 & + module subroutine downsend_all_g2 & !*********************************************************************** ! * ! Downsending data from low resolution pes (mygen_up) * @@ -3743,29 +3756,26 @@ subroutine downsend_all_g2 & ! - offset version - * ! * !*********************************************************************** -(Warray,Harray,lm_all) +(this,Warray,Harray,km_in) !----------------------------------------------------------------------- -use mg_parameter, only: im,jm,imL,jmL,hx,hy -use mg_domain, only: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne & - ,Fitarg_up & - ,itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: lm_all -real(r_kind), dimension(lm_all,1:im,1:jm),intent(in):: Warray -real(r_kind), dimension(lm_all,1:imL,1:jmL),intent(out):: Harray +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:lm_all,1:imL,1:jmL):: dBuf_SW -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_SE -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_NW -real(r_kind),dimension(1:lm_all,1:imL,1:jmL):: dBuf_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 @@ -3776,6 +3786,10 @@ subroutine downsend_all_g2 & 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 ! @@ -3791,7 +3805,7 @@ subroutine downsend_all_g2 & itarg_up=Fitarg_up(g_ind) - ndata =lm_all*imL*jmL + ndata =km_in*imL*jmL ! @@ -3814,7 +3828,7 @@ subroutine downsend_all_g2 & else - allocate( sBuf_SW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3844,7 +3858,7 @@ subroutine downsend_all_g2 & else - allocate( sBuf_SE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3874,7 +3888,7 @@ subroutine downsend_all_g2 & else - allocate( sBuf_NW(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -3904,7 +3918,7 @@ subroutine downsend_all_g2 & else - allocate( sBuf_NE(1:lm_all,1:imL,1:jmL), stat = iaerr ) + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) do j=1,jmL do i=1,imL @@ -4029,7 +4043,7 @@ subroutine downsend_all_g2 & endsubroutine downsend_all_g2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocox_2d_g1 & + module subroutine bocox_2d_g1 & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -4039,17 +4053,17 @@ subroutine bocox_2d_g1 & ! - offset version - ! ! ! !**********************************************************************! -(W,km,im,jm,nbx,nby) +(this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- -use mg_domain, only: Fitarg_w,Fitarg_e,Flwest,Fleast -!clt use mpi +use mpi !#clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby -real(r_kind),dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +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 & @@ -4063,6 +4077,10 @@ subroutine bocox_2d_g1 & 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 @@ -4080,12 +4098,12 @@ subroutine bocox_2d_g1 & lwest = Flwest(g_ind) least = Fleast(g_ind) - imax = im - jmax = jm + imax = im_in + jmax = jm_in !----------------------------------------------------------------------- - ndatax = km*jmax*nbx + ndatax = km_in*jmax*nbx !---------------------------------------------------------------------- ! @@ -4097,7 +4115,7 @@ subroutine bocox_2d_g1 & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km,nbx,1:jmax), stat = iaerr ) + allocate( sBuf_W(1:km_in,nbx,1:jmax), stat = iaerr ) do j=1,jmax do i=1,nbx @@ -4115,7 +4133,7 @@ subroutine bocox_2d_g1 & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km,nbx,1:jmax), stat = iaerr ) + allocate( sBuf_E(1:km_in,nbx,1:jmax), stat = iaerr ) do j=1,jmax do i=1,nbx @@ -4137,7 +4155,7 @@ subroutine bocox_2d_g1 & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( rBuf_E(1:km,nbx,1:jmax), stat = iaerr ) + 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 ) @@ -4149,7 +4167,7 @@ subroutine bocox_2d_g1 & if( itarg_w >= 0 ) then nebpe = itarg_w - allocate( rBuf_W(1:km,nbx,1:jmax), stat = iaerr ) + 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 ) @@ -4235,7 +4253,7 @@ subroutine bocox_2d_g1 & endsubroutine bocox_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocox_2d_gh & + module subroutine bocox_2d_gh & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -4245,18 +4263,18 @@ subroutine bocox_2d_gh & ! - offset version - ! ! ! !**********************************************************************! -(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mg_domain, only: Fitarg_w,Fitarg_e,Flwest,Fleast,Flsouth,Flnorth -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max -real(r_kind),dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W -integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +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 & @@ -4271,6 +4289,10 @@ subroutine bocox_2d_gh & 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 @@ -4302,19 +4324,19 @@ subroutine bocox_2d_gh & if(least) then - imax = Fimax(g) + 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(g) + jmax = Fjmax_in(g) else jmax = jm endif !----------------------------------------------------------------------- - ndatax = km*jmax*nbx + ndatax = km_in*jmax*nbx ! ! SEND halos to WEST and EASTH @@ -4325,7 +4347,7 @@ subroutine bocox_2d_gh & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km,nbx,1:jmax), stat = iaerr ) + allocate( sBuf_W(1:km_in,nbx,1:jmax), stat = iaerr ) do j=1,jmax do i=1,nbx @@ -4343,7 +4365,7 @@ subroutine bocox_2d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km,nbx,1:jmax), stat = iaerr ) + allocate( sBuf_E(1:km_in,nbx,1:jmax), stat = iaerr ) do j=1,jmax do i=1,nbx @@ -4365,7 +4387,7 @@ subroutine bocox_2d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( rBuf_E(1:km,nbx,1:jmax), stat = iaerr ) + 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 ) @@ -4377,7 +4399,7 @@ subroutine bocox_2d_gh & if( itarg_w >= 0 ) then nebpe = itarg_w - allocate( rBuf_W(1:km,nbx,1:jmax), stat = iaerr ) + 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 ) @@ -4464,7 +4486,7 @@ subroutine bocox_2d_gh & endsubroutine bocox_2d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocoy_2d_g1 & + module subroutine bocoy_2d_g1 & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -4474,17 +4496,17 @@ subroutine bocoy_2d_g1 & ! - offset version - ! ! ! !**********************************************************************! -(W,km,im,jm,nbx,nby) +(this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- -use mg_domain, only: Fitarg_n,Fitarg_s,Flsouth,Flnorth -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby -real(r_kind),dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +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 @@ -4497,6 +4519,10 @@ subroutine bocoy_2d_g1 & 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 @@ -4514,12 +4540,12 @@ subroutine bocoy_2d_g1 & lsouth = Flsouth(g_ind) lnorth = Flnorth(g_ind) - imax = im - jmax = jm + imax = im_in + jmax = jm_in !----------------------------------------------------------------------- - ndatay = km*imax*nby + ndatay = km_in*imax*nby ! @@ -4531,7 +4557,7 @@ subroutine bocoy_2d_g1 & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km,1:imax,nby), stat = iaerr ) + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -4548,7 +4574,7 @@ subroutine bocoy_2d_g1 & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km,1:imax,nby), stat = iaerr ) + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -4570,7 +4596,7 @@ subroutine bocoy_2d_g1 & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( rBuf_N(1:km,1:imax,nby), stat = iaerr ) + 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 ) @@ -4582,7 +4608,7 @@ subroutine bocoy_2d_g1 & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( rBuf_S(1:km,1:imax,nby), stat = iaerr ) + 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 ) @@ -4665,7 +4691,7 @@ subroutine bocoy_2d_g1 & endsubroutine bocoy_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocoy_2d_gh & + module subroutine bocoy_2d_gh & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -4675,18 +4701,18 @@ subroutine bocoy_2d_gh & ! - offset version - ! ! ! !**********************************************************************! -(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mg_domain, only: Fitarg_n,Fitarg_s,Flwest,Fleast,Flsouth,Flnorth - -!clt use mpi +use mpi !clt + implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max -real(r_kind),dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W -integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +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 & @@ -4701,6 +4727,10 @@ subroutine bocoy_2d_gh & 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 @@ -4732,19 +4762,19 @@ subroutine bocoy_2d_gh & if(least) then - imax = Fimax(g) + imax = Fimax_in(g) else - imax = im ! << Note that is not necesseraly im from + imax = im_in ! << Note that is not necesseraly im from endif ! mg_parameter. Could be also imL >>> if(lnorth) then - jmax = Fjmax(g) + jmax = Fjmax_in(g) else - jmax = jm + jmax = jm_in endif !----------------------------------------------------------------------- - ndatay = km*imax*nby + ndatay = km_in*imax*nby ! ! SEND boundaries to SOUTH and NORTH @@ -4755,7 +4785,7 @@ subroutine bocoy_2d_gh & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km,1:imax,nby), stat = iaerr ) + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -4772,7 +4802,7 @@ subroutine bocoy_2d_gh & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km,1:imax,nby), stat = iaerr ) + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -4793,7 +4823,7 @@ subroutine bocoy_2d_gh & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( rBuf_N(1:km,1:imax,nby), stat = iaerr ) + 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 ) @@ -4805,7 +4835,7 @@ subroutine bocoy_2d_gh & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( rBuf_S(1:km,1:imax,nby), stat = iaerr ) + 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 ) @@ -4891,7 +4921,7 @@ subroutine bocoy_2d_gh & endsubroutine bocoy_2d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocoTx_2d_g1 & + module subroutine bocoTx_2d_g1 & !*********************************************************************** ! ! ! Side sending subroutine: ! @@ -4902,16 +4932,17 @@ subroutine bocoTx_2d_g1 & ! - offset version - ! ! ! !*********************************************************************** -(W,km,im,jm,nbx,nby) +(this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- -use mg_domain, only: Flwest,Fleast,Fitarg_w,Fitarg_e -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this + !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby -real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +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 & @@ -4927,6 +4958,10 @@ subroutine bocoTx_2d_g1 & 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 ! @@ -4942,12 +4977,12 @@ subroutine bocoTx_2d_g1 & lwest = Flwest(g_ind) least = Fleast(g_ind) - imax = im - jmax = jm + imax = im_in + jmax = jm_in !---------------------------------------------------------------------- - ndatax =km*jmax*nbx + ndatax =km_in*jmax*nbx ! ! SEND halos toward WEST and EAST @@ -4958,7 +4993,7 @@ subroutine bocoTx_2d_g1 & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km,1:nbx,1:jmax), stat = iaerr ) + allocate( sBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr ) do j=1,jmax do i=1-nbx,0 @@ -4967,7 +5002,7 @@ subroutine bocoTx_2d_g1 & enddo call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & - mpi_comm_world, sHandle(1), isend) + mpi_comm_comp, sHandle(1), isend) end if @@ -4976,7 +5011,7 @@ subroutine bocoTx_2d_g1 & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km,1:nbx,1:jmax), stat = iaerr ) + allocate( sBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr ) do j=1,jmax do i=1,nbx @@ -4985,7 +5020,7 @@ subroutine bocoTx_2d_g1 & enddo call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & - mpi_comm_world, sHandle(2), isend) + mpi_comm_comp, sHandle(2), isend) end if @@ -4999,9 +5034,9 @@ subroutine bocoTx_2d_g1 & nebpe = itarg_e - allocate( rBuf_E(1:km,1:nbx,1:jmax), stat = iaerr ) + allocate( rBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr ) call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & - mpi_comm_world, rHandle(2), irecv) + mpi_comm_comp, rHandle(2), irecv) call MPI_WAIT( rHandle(2), istat, ierr ) end if @@ -5012,9 +5047,9 @@ subroutine bocoTx_2d_g1 & nebpe = itarg_w - allocate( rBuf_W(1:km,1:nbx,1:jmax), stat = iaerr ) + allocate( rBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr ) call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & - mpi_comm_world, rHandle(1), irecv) + mpi_comm_comp, rHandle(1), irecv) call MPI_WAIT( rHandle(1), istat, ierr ) @@ -5083,7 +5118,7 @@ subroutine bocoTx_2d_g1 & endsubroutine bocoTx_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocoTx_2d_gh & + module subroutine bocoTx_2d_gh & !*********************************************************************** ! ! ! Side sending subroutine: ! @@ -5094,17 +5129,17 @@ subroutine bocoTx_2d_gh & ! - offset version - ! ! ! !*********************************************************************** -(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mg_domain, only: Flwest,Fleast,Flnorth,Fitarg_w,Fitarg_e -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max -real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W -integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +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 & @@ -5119,6 +5154,10 @@ subroutine bocoTx_2d_gh & 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 ! @@ -5151,19 +5190,19 @@ subroutine bocoTx_2d_gh & if(least) then - imax = Fimax(g) + imax = Fimax_in(g) else - imax = im ! << Note that is not necesseraly im from + imax = im_in ! << Note that is not necesseraly im from endif ! mg_parameter. Could be also imL >>> if(lnorth) then - jmax = Fjmax(g) + jmax = Fjmax_in(g) else - jmax = jm + jmax = jm_in endif !---------------------------------------------------------------------- - ndatax =km*jmax*nbx + ndatax =km_in*jmax*nbx ! ! SEND halos toward WEST and EAST ! @@ -5173,7 +5212,7 @@ subroutine bocoTx_2d_gh & if( itarg_w >= 0) then nebpe = itarg_w - allocate( sBuf_W(1:km,1:nbx,1:jmax), stat = iaerr ) + allocate( sBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr ) do j=1,jmax do i=1-nbx,0 @@ -5191,7 +5230,7 @@ subroutine bocoTx_2d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km,0:nbx,0:jmax), stat = iaerr ) + allocate( sBuf_E(1:km_in,0:nbx,0:jmax), stat = iaerr ) do j=1,jmax do i=1,nbx @@ -5213,7 +5252,7 @@ subroutine bocoTx_2d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( rBuf_E(1:km,1:nbx,1:jmax), stat = iaerr ) + 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 ) @@ -5225,7 +5264,7 @@ subroutine bocoTx_2d_gh & if( itarg_w >= 0 ) then nebpe = itarg_w - allocate( rBuf_W(1:km,1:nbx,1:jmax), stat = iaerr ) + 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 ) @@ -5298,7 +5337,7 @@ subroutine bocoTx_2d_gh & endsubroutine bocoTx_2d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocoTy_2d_g1 & + module subroutine bocoTy_2d_g1 & !*********************************************************************** ! ! ! Side sending subroutine: ! @@ -5309,16 +5348,16 @@ subroutine bocoTy_2d_g1 & ! - offset version - ! ! ! !*********************************************************************** -(W,km,im,jm,nbx,nby) +(this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- -use mg_domain, only: Flsouth,Flnorth,Fitarg_n,Fitarg_s -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby -real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W +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 & @@ -5334,6 +5373,10 @@ subroutine bocoTy_2d_g1 & 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 ! @@ -5348,12 +5391,12 @@ subroutine bocoTy_2d_g1 & lsouth = Flsouth(g_ind) lnorth = Flnorth(g_ind) - imax = im - jmax = jm + imax = im_in + jmax = jm_in !---------------------------------------------------------------------- - ndatay =km*imax*nby + ndatay =km_in*imax*nby ! ! SEND SOUTH and NORTH halos @@ -5363,7 +5406,7 @@ subroutine bocoTy_2d_g1 & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km,1:imax,1:nby), stat = iaerr ) + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) do j=1-nby,0 do i=1,imax @@ -5372,7 +5415,7 @@ subroutine bocoTy_2d_g1 & enddo call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & - mpi_comm_world, sHandle(1), isend) + mpi_comm_comp, sHandle(1), isend) end if ! --- toward NORTH --- @@ -5380,7 +5423,7 @@ subroutine bocoTy_2d_g1 & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km,1:imax,1:nby), stat = iaerr ) + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -5389,7 +5432,7 @@ subroutine bocoTy_2d_g1 & enddo call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & - mpi_comm_world, sHandle(2), isend) + mpi_comm_comp, sHandle(2), isend) end if @@ -5402,9 +5445,9 @@ subroutine bocoTy_2d_g1 & nebpe = itarg_n - allocate( rBuf_N(1:km,1:imax,1:nby), stat = iaerr ) + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & - mpi_comm_world, rHandle(1), irecv) + mpi_comm_comp, rHandle(1), irecv) call MPI_WAIT( rHandle(1), istat, ierr ) end if @@ -5415,9 +5458,9 @@ subroutine bocoTy_2d_g1 & nebpe = itarg_s - allocate( rBuf_S(1:km,1:imax,1:nby), stat = iaerr ) + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & - mpi_comm_world, rHandle(2), irecv) + mpi_comm_comp, rHandle(2), irecv) call MPI_WAIT( rHandle(2), istat, ierr ) @@ -5487,7 +5530,7 @@ subroutine bocoTy_2d_g1 & endsubroutine bocoTy_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine bocoTy_2d_gh & + module subroutine bocoTy_2d_gh & !*********************************************************************** ! ! ! Side sending subroutine: ! @@ -5498,18 +5541,17 @@ subroutine bocoTy_2d_gh & ! - offset version - ! ! ! !*********************************************************************** -(W,km,im,jm,nbx,nby,Fimax,Fjmax,mygen_min,mygen_max) +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mg_domain, only: Fleast,Flsouth,Flnorth & - ,Fitarg_n,Fitarg_s -!clt use mpi +use mpi !clt implicit none +class(mg_intstate_type),target::this !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,im,jm,nbx,nby,mygen_min,mygen_max -real(r_kind), dimension(km,1-nbx:im+nbx,1-nby:jm+nby),intent(inout):: W -integer(i_kind), dimension(gm), intent(in):: Fimax,Fjmax +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 & @@ -5523,6 +5565,10 @@ subroutine bocoTy_2d_gh & 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 @@ -5556,20 +5602,20 @@ subroutine bocoTy_2d_gh & if(least) then - imax = Fimax(g) + imax = Fimax_in(g) else - imax = im ! << Note that is not necesseraly im from + imax = im_in ! << Note that is not necesseraly im from endif ! mg_parameter. Could be also imL >>> if(lnorth) then - jmax = Fjmax(g) + jmax = Fjmax_in(g) else - jmax = jm + jmax = jm_in endif !---------------------------------------------------------------------- - ndatay =km*imax*nby + ndatay =km_in*imax*nby ! ! SEND halos toward SOUTH and NORTH ! @@ -5578,7 +5624,7 @@ subroutine bocoTy_2d_gh & if( itarg_s >= 0 ) then nebpe = itarg_s - allocate( sBuf_S(1:km,1:imax,1:nby), stat = iaerr ) + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) do j=1-nby,0 do i=1,imax @@ -5595,7 +5641,7 @@ subroutine bocoTy_2d_gh & if( itarg_n >= 0 ) then nebpe = itarg_n - allocate( sBuf_N(1:km,1:imax,1:nby), stat = iaerr ) + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) do j=1,nby do i=1,imax @@ -5618,7 +5664,7 @@ subroutine bocoTy_2d_gh & nebpe = itarg_n - allocate( rBuf_N(1:km,1:imax,1:nby), stat = iaerr ) + 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 ) @@ -5631,7 +5677,7 @@ subroutine bocoTy_2d_gh & nebpe = itarg_s - allocate( rBuf_S(1:km,1:imax,1:nby), stat = iaerr ) + 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 ) @@ -5706,4 +5752,4 @@ subroutine bocoTy_2d_gh & endsubroutine bocoTy_2d_gh !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - endmodule mg_bocos + end submodule mg_bocos diff --git a/src/saber/mgbf/mgbf_lib/type_mg_domain.f90 b/src/saber/mgbf/mgbf_lib/mg_domain.f90 similarity index 93% rename from src/saber/mgbf/mgbf_lib/type_mg_domain.f90 rename to src/saber/mgbf/mgbf_lib/mg_domain.f90 index be78ec471..53351c6e7 100755 --- a/src/saber/mgbf/mgbf_lib/type_mg_domain.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_domain.f90 @@ -1,5 +1,5 @@ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_domain + submodule(mg_parameter) mg_domain !**********************************************************************! ! ! ! Definition of a squared integration domain ! @@ -10,69 +10,50 @@ module mg_domain use mpi use kinds, only: i_kind !use mpimod, only: mype -use mg_mppstuff implicit none -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 -type mg_domain_type -contains -procedure,nopass :: init_mg_domain -end type mg_domain_type !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ contains !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine init_mg_domain + module subroutine init_mg_domain(this) !*********************************************************************** ! * ! Initialize square domain * ! * !*********************************************************************** implicit none + class(mg_parameter_type)::this - call init_domain - call init_topology_2d + call init_domain(this) + call init_topology_2d(this) !----------------------------------------------------------------------- endsubroutine init_mg_domain !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine init_domain + module subroutine init_domain(this) !*********************************************************************** ! * ! Definition of constants that control filtering domain * ! * !*********************************************************************** -use mg_parameter 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" !----------------------------------------------------------------------- !TEST ! if(mype==0) then @@ -177,16 +158,16 @@ subroutine init_domain endsubroutine init_domain !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine init_topology_2d + module subroutine init_topology_2d(this) !*********************************************************************** ! * ! Define topology of filter grid * ! - Four generations - * ! * !*********************************************************************** -use mg_parameter, only: ixm,jym,nxy,maxpe_fgen,gm,imL,jmL implicit none + class(mg_parameter_type),target::this !----------------------------------------------------------------------- logical:: F=.false., T=.true. @@ -194,6 +175,8 @@ subroutine init_topology_2d 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 @@ -582,23 +565,23 @@ subroutine init_topology_2d ! ! Convert targets in higher generations into real targets ! - call real_itarg(Fitarg_w(2)) - call real_itarg(Fitarg_e(2)) - call real_itarg(Fitarg_s(2)) - call real_itarg(Fitarg_n(2)) + 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(Fitarg_sw(2)) - call real_itarg(Fitarg_se(2)) - call real_itarg(Fitarg_nw(2)) - call real_itarg(Fitarg_ne(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(itargdn_sw) - if(itargdn_se .ge. maxpe_fgen(1)) call real_itarg(itargdn_se) - if(itargdn_nw .ge. maxpe_fgen(1)) call real_itarg(itargdn_nw) - if(itargdn_ne .ge. maxpe_fgen(1)) call real_itarg(itargdn_ne) + 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(Fitarg_up(1)) - call real_itarg(Fitarg_up(2)) + call real_itarg(this,Fitarg_up(1)) + call real_itarg(this,Fitarg_up(2)) !TEST ! if(mype_hgen> 1) then @@ -715,16 +698,19 @@ subroutine init_topology_2d endsubroutine init_topology_2d !---------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine real_itarg & + module subroutine real_itarg & !*********************************************************************** ! * ! Definite real targets for high generations * ! * !*********************************************************************** -(itarg) +(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) @@ -734,4 +720,4 @@ subroutine real_itarg & endsubroutine real_itarg !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - endmodule mg_domain + end submodule mg_domain diff --git a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 new file mode 100644 index 000000000..482d1dc63 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 @@ -0,0 +1,168 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + submodule(mg_intstate) mg_entrymod +!*********************************************************************** +! ! +! Initialize and finialize multigrid Beta filter for modeling of ! +! background error covariance ! +! M. Rancic (2020) ! +!*********************************************************************** +use mpi +use kinds, only: r_kind,i_kind + +!cltmoved to mg_parameter integer(i_kind):: km,km2,km3 + contains + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module subroutine mg_initialize(this,inputfilename,obj_parameter) +implicit none +!**********************************************************************! +! ! +! Initialization subroutine ! +! M. Rancic (2020) ! +!*********************************************************************** +!type (type_mg_entrymod):: this +class (mg_intstate_type):: this +character*(*),optional,intent(in) :: inputfilename +class(mg_parameter_type),optional,intent(in)::obj_parameter + +!cltreal(r_kind), allocatable, dimension(:,:):: PA +!#include "type_parameter_locpointer.inc" +!#include "type_parameter_point2this.inc" + + +!--------------------------------------------------------------------------- +! +! Firs set of subroutines is called only once and serves to +! initialte the MGBF run +! +!--------------------------------------------------------------------------- + +!**** +!**** Initialize run multigrid Beta filter parameters +!**** + if (present(inputfilename)) then + call this%init_mg_parameter(inputfilename) + elseif (present(obj_parameter)) then + this%mg_parameter_type=obj_parameter + endif + +!**** +!**** Initialize MPI +!**** + + call this%init_mg_MPI + +!*** +!*** Initialize integration domain +!*** + + call this%init_mg_domain + + +!--------------------------------------------------------------------------- +! +! 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 +!*** + + if(this%l_filt) then + this%km2 = this%km2_f + this%km3 = this%km3_f + else + this%km2 = this%km2_e + this%km3 = this%km3_e + endif + write(6,*)'thinkdeb33 ',this%km2,this%km3,this%lm +!cltdebug this%km2=0;this%km3=0 !cltthinktodo this is not defined in the test case + !using + !/scratch1/NCEPDEV/da/Miodrag.Rancic/Mars_Jul05_2022/RUN/mgbf.nml_offset + this%km = this%km2+this%lm*this%km3 + +!*** +!*** Allocate variables, define weights, prepare mapping +!*** between analysis and filter grid +!*** + + call this%allocate_mg_intstate !(this%km) !cltthink + + 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 + +!for now call lwq_vertical_coef(lm ,lmf,cvf1,cvf2,cvf3,cvf4,lref) +!for now call lwq_vertical_coef(lmf,lmh,cvh1,cvh2,cvh3,cvh4,lref_h) + +!*** +!*** 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) + +!clt WORKA(:,:,:)=0. +!TEST +! call finishMPI +!TEST + +!----------------------------------------------------------------------- + endsubroutine mg_initialize + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module subroutine mg_finalize(this) +!**********************************************************************! +! ! +! Finalize multigrid Beta Function ! +! M. Rancic (2020) ! +!*********************************************************************** +!clt #use mg_parameter, only: nm,mm +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 + + call this%barrierMPI + + + call this%deallocate_mg_intstate + +!----------------------------------------------------------------------- + endsubroutine mg_finalize +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + end submodule mg_entrymod diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index 68f9e169b..0b5f593f0 100644 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -1,54 +1,26 @@ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_filtering + submodule(mg_intstate) mg_filtering !*********************************************************************** ! ! ! Contains all multigrid filtering prodecures ! ! ! ! M. Rancic (2020) ! !*********************************************************************** -use mpi +use mg_timers use kinds, only: r_kind,i_kind -use mg_parameter, only: im,jm,hx,hy,hz,km2,km3,lm,gm,Fimax,Fjmax -use mg_parameter, only: i0,j0,km -use mg_parameter, only: mgbf_line,lquart -!use mpimod, only: mype,ierror -use mg_mppstuff, only: mype,ierror -use mg_mppstuff, only: l_hgen,my_hgen,finishMPI,barrierMPI -use mg_generations, only: upsending_all,downsending_all,differencing_all -use mg_generations, only: upsending2_all,downsending2_all -use mg_transfer, only: stack_to_composite,composite_to_stack -use mg_bocos, only: boco_2d,bocoT_2d -use mg_bocos, only: boco_3d, bocoT_3d -use mg_bocos, only: bocox,bocoy -use mg_bocos, only: bocoTx,bocoTy -use jp_pbfil, only: rbeta,rbetaT +!clt use jp_pbfil, only: rbeta,rbetaT use jp_pbfil3, only: dibetat,dibeta -#if 0 -use mg_output -#endif - +use mpi -public mg_filtering_procedure -private mg_filtering_rad1 -private mg_filtering_rad2 -private mg_filtering_rad3 -private mg_filtering_lin1 -private mg_filtering_lin2 -private mg_filtering_lin3 -private mg_filtering_fast -private sup_vrbeta1 -private sup_vrbeta1T -private sup_vrbeta3 -private sup_vrbeta3T !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ contains !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine mg_filtering_procedure(mg_filt) + module subroutine mg_filtering_procedure(this,mg_filt) !*********************************************************************** ! ! ! Driver for Multigrid filtering procedures with Helmholtz operator ! @@ -66,8 +38,13 @@ subroutine mg_filtering_procedure(mg_filt) ! ! !*********************************************************************** implicit none +class(mg_intstate_type),target::this integer(i_kind),intent(in):: mg_filt +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" !----------------------------------------------------------------------- if(mgbf_line) then if(mg_filt<4) then @@ -82,26 +59,26 @@ subroutine mg_filtering_procedure(mg_filt) endif select case(mg_filt) case(1) - call mg_filtering_rad1 + call this%mg_filtering_rad1 case(2) - call mg_filtering_rad2 + call this%mg_filtering_rad2 case(3) - call mg_filtering_rad3 + call this%mg_filtering_rad3 case(4) - call mg_filtering_lin1 + call this%mg_filtering_lin1 case(5) - call mg_filtering_lin2 + call this%mg_filtering_lin2 case(6) - call mg_filtering_lin3 + call this%mg_filtering_lin3 case default - call mg_filtering_fast + call this%mg_filtering_fast end select !----------------------------------------------------------------------- endsubroutine mg_filtering_procedure !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine mg_filtering_rad1 + module subroutine mg_filtering_rad1(this) !*********************************************************************** ! ! ! Multigrid filtering procedure 1: ! @@ -112,11 +89,14 @@ subroutine mg_filtering_rad1 ! - 2d radial filter only for all variables ! ! ! !*********************************************************************** -use mg_intstate, only: pasp2,ss2 -use mg_intstate, only: VALL,HALL implicit none +class(mg_intstate_type),target:: this integer(i_kind) L,i,j,g +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" !----------------------------------------------------------------------- @@ -126,8 +106,9 @@ subroutine mg_filtering_rad1 !*** Adjoint interpolate and upsend (Step 1) !*** -! call upsending2_all(VALL,HALL) - call upsending_all(VALL,HALL) + call btim( upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim( upsend_tim) !---------------------------------------------------------------------- @@ -136,41 +117,46 @@ subroutine mg_filtering_rad1 !*** !*** Apply adjoint of Beta filter at all generations !*** + call btim( bfiltT_tim) !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - call rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) + call this%rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) if(l_hgen) then - call rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + call this%rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) endif !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - call bocoT_2d(VALL,km,im,jm,hx,hy) - call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + write(6,*)'thinkdeb33 1 ', km,im,jm,hx,hy + 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( bfiltT_tim) !*** !*** Apply (a-b\nabla^2) !*** + call btim( weight_tim) - call differencing_all(VALL,HALL) + call this%weighting_all(VALL,HALL,lhelm) + call etim( weight_tim) !*** !*** Apply Beta filter at all generations !*** + call btim( bfilt_tim) - call boco_2d(VALL,km,im,jm,hx,hy) - call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call this%boco_2d(VALL,km,im,jm,hx,hy) + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) @@ -179,29 +165,31 @@ subroutine mg_filtering_rad1 ! Filtering ! - call rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) + call this%rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) if(l_hgen) then - call rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + call this%rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) endif !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + call etim( bfilt_tim) !*** !*** Downsend, interpolate and add, then zero high generations !*** -! call downsending2_all(HALL,VALL) - call downsending_all(HALL,VALL) + call btim( dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim( dnsend_tim) !----------------------------------------------------------------------- endsubroutine mg_filtering_rad1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine mg_filtering_rad2 + module subroutine mg_filtering_rad2(this) !*********************************************************************** ! ! ! Multigrid filtering procedure 2: ! @@ -212,9 +200,8 @@ subroutine mg_filtering_rad2 ! - 2d radial filter + 1d vertical filter ! ! ! !*********************************************************************** -use mg_intstate, only: pasp1,pasp2,ss1,ss2 -use mg_intstate, only: VALL,HALL implicit none +class (mg_intstate_type),target::this real(r_kind), allocatable, dimension(:,:,:):: VM2D real(r_kind), allocatable, dimension(:,:,:):: HM2D @@ -222,6 +209,10 @@ subroutine mg_filtering_rad2 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,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. @@ -237,11 +228,9 @@ subroutine mg_filtering_rad2 !*** Adjoint interpolate and upsend !*** - if(lquart) then - call upsending2_all(VALL,HALL) - else - call upsending_all(VALL,HALL) - endif + call btim( upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim( upsend_tim) !---------------------------------------------------------------------- @@ -250,50 +239,56 @@ subroutine mg_filtering_rad2 !*** !*** Apply adjoint of Beta filter at all generations !*** + call btim( bfiltT_tim) !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - call rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) - call stack_to_composite(VALL,VM2D,VM3D) + call this%rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) + call this%stack_to_composite(VALL,VM2D,VM3D) if(l_hgen) then - call rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) - call stack_to_composite(HALL,HM2D,HM3D) + call this%rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + call this%stack_to_composite(HALL,HM2D,HM3D) endif - call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call composite_to_stack(VM2D,VM3D,VALL) + call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) if(l_hgen) then - call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call composite_to_stack(HM2D,HM3D,HALL) + call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) endif !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - call bocoT_2d(VALL,km,im,jm,hx,hy) - call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + write(6,*)'thinkdeb33 2 ', km,im,jm,hx,hy + 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( bfiltT_tim) !*** !*** Apply (a-b\nabla^2) !*** + call btim( weight_tim) - call differencing_all(VALL,HALL) + call this%weighting_all(VALL,HALL,lhelm) + call etim( weight_tim) !*** !*** Apply Beta filter at all generations (Step 7) !*** + call btim( bfilt_tim) - call boco_2d(VALL,km,im,jm,hx,hy) - call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call this%boco_2d(VALL,km,im,jm,hx,hy) + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff @@ -301,37 +296,36 @@ subroutine mg_filtering_rad2 ! Filtering ! - call rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) - call stack_to_composite(VALL,VM2D,VM3D) - if(l_hgen) then - call rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) - call stack_to_composite(HALL,HM2D,HM3D) + call this%rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) + call this%stack_to_composite(VALL,VM2D,VM3D) + if(this%l_hgen) then + call this%rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + call this%stack_to_composite(HALL,HM2D,HM3D) endif - call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call composite_to_stack(VM2D,VM3D,VALL) + call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) if(l_hgen) then - call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call composite_to_stack(HM2D,HM3D,HALL) + call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) endif - call barrierMPI + call this%barrierMPI !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + call etim( bfilt_tim) !*** !*** Downsend, interpolate and add (Step 4) !*** Then zero high generations (Step 5) !*** - if(lquart) then - call downsending2_all(HALL,VALL) - else - call downsending_all(HALL,VALL) - endif + call btim( dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim( dnsend_tim) deallocate(VM3D) deallocate(VM2D) @@ -342,7 +336,7 @@ subroutine mg_filtering_rad2 endsubroutine mg_filtering_rad2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine mg_filtering_rad3 + module subroutine mg_filtering_rad3(this) !*********************************************************************** ! ! ! Multigrid filtering procedure 2: ! @@ -354,9 +348,8 @@ subroutine mg_filtering_rad3 ! ! !*********************************************************************** !----------------------------------------------------------------------- -use mg_intstate, only: pasp2,pasp3,ss2,ss3 -use mg_intstate, only: VALL,HALL implicit none +class (mg_intstate_type),target::this real(r_kind), allocatable, dimension(:,:,:):: VM2D @@ -366,6 +359,10 @@ subroutine mg_filtering_rad3 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,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. @@ -379,13 +376,15 @@ subroutine mg_filtering_rad3 !*** Adjoint interpolate and upsend !*** -! call upsending2_all(VALL,HALL) - call upsending_all(VALL,HALL) + 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( bfiltT_tim) @@ -393,69 +392,76 @@ subroutine mg_filtering_rad3 ! ! Adjoint filtering ! - call stack_to_composite(VALL,VM2D,VM3D) - call rbetaT(km2,hx,i0,im,hy,j0,jm,pasp2,ss2,VM2D) - call sup_vrbeta3T(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,VM3D) - call composite_to_stack(VM2D,VM3D,VALL) + call this%stack_to_composite(VALL,VM2D,VM3D) + call this%rbetaT(km2,hx,i0,im,hy,j0,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 stack_to_composite(HALL,HM2D,HM3D) - call rbetaT(km2,hx,i0,im,hy,j0,jm,pasp2,ss2,HM2D) - call sup_vrbeta3T(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,HM3D) - call composite_to_stack(HM2D,HM3D,HALL) + call this%stack_to_composite(HALL,HM2D,HM3D) + call this%rbetaT(km2,hx,i0,im,hy,j0,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 !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + write(6,*)'thinkdeb33 3 ', km,im,jm,hx,hy - call bocoT_2d(VALL,km,im,jm,hx,hy) - call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + 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( bfiltT_tim) !*** !*** Apply (a-b\nabla^2) !*** + call btim( weight_tim) - call differencing_all(VALL,HALL) + call this%weighting_all(VALL,HALL,lhelm) + call etim( weight_tim) !*** !*** Apply Beta filter at all generations !*** + call btim( bfilt_tim) - call boco_2d(VALL,km,im,jm,hx,hy) - call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call this%boco_2d(VALL,km,im,jm,hx,hy) + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff ! ! Filtering ! - call stack_to_composite(VALL,VM2D,VM3D) - call rbeta(km2,hx,i0,im,hy,j0,jm,pasp2,ss2,VM2D(:,:,:)) - call sup_vrbeta3(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,VM3D) - call composite_to_stack(VM2D,VM3D,VALL) + call this%stack_to_composite(VALL,VM2D,VM3D) + call this%rbeta(km2,hx,i0,im,hy,j0,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 stack_to_composite(HALL,HM2D,HM3D) - call rbeta(km2,hx,i0,im,hy,j0,jm,pasp2,ss2,HM2D(:,:,:)) - call sup_vrbeta3(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,HM3D) - call composite_to_stack(HM2D,HM3D,HALL) + call this%stack_to_composite(HALL,HM2D,HM3D) + call this%rbeta(km2,hx,i0,im,hy,j0,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 !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + call etim( bfilt_tim) !*** !*** Downsend, interpolate and add !*** Then zero high generations !*** + call btim( dnsend_tim) -! call downsending2_all(HALL,VALL) - call downsending_all(HALL,VALL) + call this%downsending_all(HALL,VALL,lquart) + call etim( dnsend_tim) deallocate(VM3D) deallocate(VM2D) deallocate(HM3D) @@ -466,7 +472,7 @@ subroutine mg_filtering_rad3 endsubroutine mg_filtering_rad3 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine mg_filtering_lin1 + module subroutine mg_filtering_lin1(this) !*********************************************************************** ! ! ! Multigrid filtering procedure 4: ! @@ -477,14 +483,16 @@ subroutine mg_filtering_lin1 ! - 2d line filter only for all variables ! ! ! !*********************************************************************** -use mg_parameter, only: nfil -use mg_intstate, only: dixs,diys,hss2 -use mg_intstate, only: VALL,HALL 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" !----------------------------------------------------------------------- @@ -494,8 +502,9 @@ subroutine mg_filtering_lin1 !*** Adjoint interpolate and upsend (Step 1) !*** -! call upsending2_all(VALL,HALL) - call upsending_all(VALL,HALL) + call btim( upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim( upsend_tim) !---------------------------------------------------------------------- @@ -504,6 +513,7 @@ subroutine mg_filtering_lin1 !*** !*** Apply adjoint of Beta filter at all generations !*** + call btim( bfiltT_tim) @@ -513,7 +523,7 @@ subroutine mg_filtering_lin1 call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) - call bocoT_2d(VALL,km,im,jm,hx,hy) + call this%bocoT_2d(VALL,km,im,jm,hx,hy) enddo do icol=3,1,-1 @@ -523,20 +533,24 @@ subroutine mg_filtering_lin1 endif - call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + write(6,*)'thinkdeb33 4 ', km,im,jm,hx,hy + call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) enddo !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + call etim( bfiltT_tim) !*** !*** Apply (a-b\nabla^2) !*** + call btim( weight_tim) - call differencing_all(VALL,HALL) + call this%weighting_all(VALL,HALL,lhelm) + call etim( weight_tim) !*** @@ -544,19 +558,20 @@ subroutine mg_filtering_lin1 !*** + call btim( bfilt_tim) !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff ! ! Filtering ! do icol=1,3 - call boco_2d(VALL,km,im,jm,hx,hy) + call this%boco_2d(VALL,km,im,jm,hx,hy) call dibeta(km,i0-hx,0,im,im+hx, j0-hy,0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) enddo do icol=1,3 - call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) if(l_hgen) then call dibeta(km,i0-hx,0,im,im+hx, j0-hy,0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) @@ -566,21 +581,23 @@ subroutine mg_filtering_lin1 !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + call etim( bfilt_tim) !*** !*** Downsend, interpolate and add, then zero high generations !*** -! call downsending2_all(HALL,VALL) - call downsending_all(HALL,VALL) + call btim( dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim( dnsend_tim) !----------------------------------------------------------------------- endsubroutine mg_filtering_lin1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine mg_filtering_lin2 + module subroutine mg_filtering_lin2(this) !*********************************************************************** ! ! ! Multigrid filtering procedure 5: ! @@ -591,11 +608,8 @@ subroutine mg_filtering_lin2 ! - 2d radial filter + 1d vertical filter ! ! !*********************************************************************** -use mg_parameter, only: nfil -use mg_intstate, only: dixs,diys,hss2 -use mg_intstate, only: VALL,HALL -use mg_intstate, only: pasp1,ss1 implicit none +class (mg_intstate_type),target::this integer(i_kind) L,i,j integer(i_kind) icol,iout,jout @@ -605,6 +619,10 @@ subroutine mg_filtering_lin2 real(r_kind), allocatable, dimension(:,:,:):: HM2D real(r_kind), allocatable, dimension(:,:,:,:):: VM3D real(r_kind), allocatable, dimension(:,:,:,:):: HM3D +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" !---------------------------------------------------------------------- @@ -623,8 +641,9 @@ subroutine mg_filtering_lin2 !*** Adjoint interpolate and upsend (Step 1) !*** -! call upsending2_all(VALL,HALL) - call upsending_all(VALL,HALL) + call btim( upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim( upsend_tim) !---------------------------------------------------------------------- @@ -633,6 +652,7 @@ subroutine mg_filtering_lin2 !*** !*** Apply adjoint of Beta filter at all generations !*** + call btim( bfiltT_tim) @@ -644,7 +664,7 @@ subroutine mg_filtering_lin2 do icol=3,1,-1 call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) - call bocoT_2d(VALL,km,im,jm,hx,hy) + call this%bocoT_2d(VALL,km,im,jm,hx,hy) enddo do icol=3,1,-1 @@ -652,35 +672,40 @@ subroutine mg_filtering_lin2 call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) endif - call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + write(6,*)'thinkdeb33 5 ', km,im,jm,hx,hy + call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) enddo ! ! Vertical ! - call stack_to_composite(VALL,VM2D,VM3D) - call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call composite_to_stack(VM2D,VM3D,VALL) + call this%stack_to_composite(VALL,VM2D,VM3D) + call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) if(l_hgen) then - call stack_to_composite(HALL,HM2D,HM3D) - call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call composite_to_stack(HM2D,HM3D,HALL) + call this%stack_to_composite(HALL,HM2D,HM3D) + call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) endif - call bocoT_2d(VALL,km,im,jm,hx,hy) - call bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + write(6,*)'thinkdeb33 6 ', km,im,jm,hx,hy + call this%bocoT_2d(VALL,km,im,jm,hx,hy) + call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + call etim( bfiltT_tim) !*** !*** Apply (a-b\nabla^2) !*** + call btim( weight_tim) - call differencing_all(VALL,HALL) + call this%weighting_all(VALL,HALL,lhelm) + call etim( weight_tim) !*** @@ -688,19 +713,20 @@ subroutine mg_filtering_lin2 !*** + call btim( bfilt_tim) !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff ! ! Horizontal ! do icol=1,3 - call boco_2d(VALL,km,im,jm,hx,hy) + call this%boco_2d(VALL,km,im,jm,hx,hy) call dibeta(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) enddo do icol=1,3 - call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) if(l_hgen) then call dibeta(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) @@ -710,33 +736,35 @@ subroutine mg_filtering_lin2 ! Vertical ! - call boco_2d(VALL,km,im,jm,hx,hy) - call boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + 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 stack_to_composite(VALL,VM2D,VM3D) - call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call composite_to_stack(VM2D,VM3D,VALL) + call this%stack_to_composite(VALL,VM2D,VM3D) + call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) if(l_hgen) then - call stack_to_composite(HALL,HM2D,HM3D) - call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call composite_to_stack(HM2D,HM3D,HALL) + call this%stack_to_composite(HALL,HM2D,HM3D) + call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) endif - call barrierMPI + call this%barrierMPI !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + call etim( bfilt_tim) !*** !*** Downsend, interpolate and add, then zero high generations !*** -! call downsending2_all(HALL,VALL) - call downsending_all(HALL,VALL) + call btim( dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim( dnsend_tim) deallocate(VM3D) @@ -749,7 +777,7 @@ subroutine mg_filtering_lin2 endsubroutine mg_filtering_lin2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine mg_filtering_lin3 + module subroutine mg_filtering_lin3(this) !*********************************************************************** ! ! ! Multigrid filtering procedure 6: ! @@ -763,12 +791,9 @@ subroutine mg_filtering_lin3 !TEST use, intrinsic :: ieee_arithmetic !TEST -use mg_parameter, only: nfil -use mg_intstate, only: dixs,diys,dizs,hss2,vpasp3 -use mg_intstate, only: qcols,dixs3,diys3,dizs3 -use mg_intstate, only: VALL,HALL 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 @@ -783,6 +808,10 @@ subroutine mg_filtering_lin3 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,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. @@ -804,8 +833,9 @@ subroutine mg_filtering_lin3 !*** Adjoint interpolate and upsend !*** -! call upsending2_all(VALL,HALL) - call upsending_all(VALL,HALL) + call btim( upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim( upsend_tim) !---------------------------------------------------------------------- @@ -814,14 +844,15 @@ subroutine mg_filtering_lin3 !*** !*** Apply adjoint of Beta filter at all generations !*** + call btim( bfiltT_tim) ! ! From single stack to composite variables ! - call stack_to_composite(VALL,VM2D,VM3D) + call this%stack_to_composite(VALL,VM2D,VM3D) if(l_hgen) then - call stack_to_composite(HALL,HM2D,HM3D) + call this%stack_to_composite(HALL,HM2D,HM3D) endif @@ -833,7 +864,8 @@ subroutine mg_filtering_lin3 do icol=3,1,-1 call dibetat(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout) - call bocoT_2d(VM2D,km2,im,jm,hx,hy) + write(6,*)'thinkdeb33 11.0 ', km2,im,jm,hx,hy + call this%bocoT_2d(VM2D,km2,im,jm,hx,hy) enddo do icol=3,1,-1 @@ -841,7 +873,8 @@ subroutine mg_filtering_lin3 call dibetat(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout) endif - call bocoT_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) + write(6,*)'thinkdeb33 11 ', km2,im,jm,hx,hy + call this%bocoT_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) enddo ! @@ -857,7 +890,7 @@ subroutine mg_filtering_lin3 end do call dibetat(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout) - call bocoT_3d(W,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax) + call this%bocoT_3d(W,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax) enddo if(l_hgen) then @@ -874,7 +907,7 @@ subroutine mg_filtering_lin3 call dibetat(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout) endif - call bocoT_3d(H,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax,2,gm) + call this%bocoT_3d(H,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax,2,gm) enddo @@ -883,24 +916,27 @@ subroutine mg_filtering_lin3 ! VM3D(:,:,:,1:lm)= W(:,:,:,1:lm) - call composite_to_stack(VM2D,VM3D,VALL) + call this%composite_to_stack(VM2D,VM3D,VALL) if(l_hgen) then HM3D(:,:,:,1:lm)=H(:,:,:,1:lm) - call composite_to_stack(HM2D,HM3D,HALL) + call this%composite_to_stack(HM2D,HM3D,HALL) endif !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + call etim( bfiltT_tim) !*** !*** Apply (a-b\nabla^2) !*** + call btim( weight_tim) - call differencing_all(VALL,HALL) + call this%weighting_all(VALL,HALL,lhelm) + call etim( weight_tim) !*** @@ -909,10 +945,11 @@ subroutine mg_filtering_lin3 ! ! From single stacked to composite variables ! + call btim( bfilt_tim) - call stack_to_composite(VALL,VM2D,VM3D) + call this%stack_to_composite(VALL,VM2D,VM3D) if(l_hgen) then - call stack_to_composite(HALL,HM2D,HM3D) + call this%stack_to_composite(HALL,HM2D,HM3D) endif @@ -922,13 +959,13 @@ subroutine mg_filtering_lin3 ! Apply filter to 2D variables first ! do icol=1,3 - call boco_2d(VM2D,km2,im,jm,hx,hy) + call this%boco_2d(VM2D,km2,im,jm,hx,hy) call dibeta(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout) enddo do icol=1,3 - call boco_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call this%boco_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) if(l_hgen) then call dibeta(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout) @@ -950,7 +987,7 @@ subroutine mg_filtering_lin3 end do do icol=1,7 - call boco_3d(W,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax) + call this%boco_3d(W,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax) call dibeta(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout) enddo @@ -967,7 +1004,7 @@ subroutine mg_filtering_lin3 end do endif do icol=1,7 - call boco_3d(H,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax,2,gm) + call this%boco_3d(H,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax,2,gm) if(l_hgen) then call dibeta(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout) @@ -979,23 +1016,25 @@ subroutine mg_filtering_lin3 ! VM3D(:,:,:,1:lm)= W(:,:,:,1:lm) - call composite_to_stack(VM2D,VM3D,VALL) + call this%composite_to_stack(VM2D,VM3D,VALL) if(l_hgen) then HM3D(:,:,:,1:lm)=H(:,:,:,1:lm) - call composite_to_stack(HM2D,HM3D,HALL) + call this%composite_to_stack(HM2D,HM3D,HALL) endif !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + call etim( bfilt_tim) !*** !*** Downsend, interpolate and add, then zero high generations !*** -! call downsending2_all(HALL,VALL) - call downsending_all(HALL,VALL) + call btim( dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim( dnsend_tim) !----------------------------------------------------------------------- @@ -1014,7 +1053,7 @@ subroutine mg_filtering_lin3 endsubroutine mg_filtering_lin3 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine mg_filtering_fast + module subroutine mg_filtering_fast(this) !*********************************************************************** ! ! ! Fast multigrid filtering procedure: ! @@ -1025,9 +1064,8 @@ subroutine mg_filtering_fast ! - 1d+1d horizontal filter + 1d vertical filter ! ! ! !*********************************************************************** -use mg_intstate, only: pasp1,paspx,paspy,ss1,ssx,ssy -use mg_intstate, only: VALL,HALL implicit none +class (mg_intstate_type),target::this real(r_kind), allocatable, dimension(:,:,:):: VM2D real(r_kind), allocatable, dimension(:,:,:):: HM2D @@ -1035,6 +1073,10 @@ subroutine mg_filtering_fast 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,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. @@ -1050,8 +1092,9 @@ subroutine mg_filtering_fast !*** Adjoint interpolate and upsend !*** -! call upsending2_all(VALL,HALL) - call upsending_all(VALL,HALL) + call btim( upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim( upsend_tim) !---------------------------------------------------------------------- @@ -1060,6 +1103,7 @@ subroutine mg_filtering_fast !*** !*** Apply adjoint of Beta filter at all generations !*** + call btim( bfiltT_tim) @@ -1069,60 +1113,64 @@ subroutine mg_filtering_fast ! do j=0,jm - call rbetaT(km,hx,1,im,paspx,ssx,VALL(:,:,j)) + call this%rbetaT(km,hx,1,im,paspx,ssx,VALL(:,:,j)) enddo - call bocoTx(VALL,km,im,jm,hx,hy) + call this%bocoTx(VALL,km,im,jm,hx,hy) do i=0,im - call rbetaT(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) + call this%rbetaT(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) enddo - call bocoTy(VALL,km,im,jm,hx,hy) + call this%bocoTy(VALL,km,im,jm,hx,hy) - call stack_to_composite(VALL,VM2D,VM3D) + call this%stack_to_composite(VALL,VM2D,VM3D) if(l_hgen) then do j=0,jm - call rbetaT(km,hx,i0,im,paspx,ssx,HALL(:,:,j)) + call this%rbetaT(km,hx,i0,im,paspx,ssx,HALL(:,:,j)) enddo endif - call bocoTx(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call this%bocoTx(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) if(l_hgen) then do i=0,im - call rbetaT(km,hy,j0,jm,paspy,ssy,HALL(:,i,:)) + call this%rbetaT(km,hy,j0,jm,paspy,ssy,HALL(:,i,:)) enddo endif - call bocoTy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call this%bocoTy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) ! ! Vertically ! - call stack_to_composite(HALL,HM2D,HM3D) - call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call composite_to_stack(VM2D,VM3D,VALL) + call this%stack_to_composite(HALL,HM2D,HM3D) + call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) if(l_hgen) then - call sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call composite_to_stack(HM2D,HM3D,HALL) + call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) endif - call barrierMPI + call this%barrierMPI !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + call etim( bfiltT_tim) !*** !*** Apply (a-b\nabla^2) !*** + call btim( weight_tim) - call differencing_all(VALL,HALL) + call this%weighting_all(VALL,HALL,lhelm) + call etim( weight_tim) !*** !*** Apply Beta filter at all generations (Step 7) !*** + call btim( bfilt_tim) !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff @@ -1131,57 +1179,59 @@ subroutine mg_filtering_fast ! ! Horizonatally - call bocox(VALL,km,im,jm,hx,hy) + call this%bocox(VALL,km,im,jm,hx,hy) do j=0,jm - call rbeta(km,hx,i0,im,paspx,ssx,VALL(:,:,j)) + call this%rbeta(km,hx,i0,im,paspx,ssx,VALL(:,:,j)) enddo - call bocoy(VALL,km,im,jm,hx,hy) + call this%bocoy(VALL,km,im,jm,hx,hy) do i=0,im - call rbeta(km,hy,j0,jm,paspy,ssy,VALL(:,i,:)) + call this%rbeta(km,hy,j0,jm,paspy,ssy,VALL(:,i,:)) enddo - call stack_to_composite(VALL,VM2D,VM3D) + call this%stack_to_composite(VALL,VM2D,VM3D) - call bocox(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call this%bocox(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) if(l_hgen) then do j=0,jm - call rbeta(km,hx,i0,im,paspx,ssx,HALL(:,:,j)) + call this%rbeta(km,hx,i0,im,paspx,ssx,HALL(:,:,j)) enddo endif - call bocoy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call this%bocoy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) if(l_hgen) then do i=0,im - call rbeta(km,hy,j0,jm,paspy,ssy,HALL(:,i,:)) + call this%rbeta(km,hy,j0,jm,paspy,ssy,HALL(:,i,:)) enddo endif if(l_hgen) then - call stack_to_composite(HALL,HM2D,HM3D) + call this%stack_to_composite(HALL,HM2D,HM3D) endif ! ! Vertically ! - call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call composite_to_stack(VM2D,VM3D,VALL) + call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) if(l_hgen) then - call sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call composite_to_stack(HM2D,HM3D,HALL) + call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) endif - call barrierMPI + call this%barrierMPI !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + call etim( bfilt_tim) !*** !*** Downsend, interpolate and add (Step 4) !*** Then zero high generations (Step 5) !*** -! call downsending2_all(HALL,VALL) - call downsending_all(HALL,VALL) + call btim( dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim( dnsend_tim) deallocate(VM3D) deallocate(VM2D) @@ -1192,18 +1242,19 @@ subroutine mg_filtering_fast endsubroutine mg_filtering_fast !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine sup_vrbeta1 & + module subroutine sup_vrbeta1 & !********************************************************************** ! * ! conversion of vrbeta1 * ! * !********************************************************************** -(kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) +(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,i0-hx:im+hx,j0-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-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 @@ -1213,8 +1264,8 @@ subroutine sup_vrbeta1 & !---------------------------------------------------------------------- - do j=j0,jm - do i=i0,im + do j=this%j0,jm + do i=this%i0,im do L=1,Lm W(:,L)=V(:,i,j,L) end do @@ -1222,7 +1273,7 @@ subroutine sup_vrbeta1 & W(:,1-L)=W(:,1+L) W(:,LM+L)=W(:,LM-L) end do - call rbeta(kmax,hz,1,lm, pasp,ss,W) + call this%rbeta(kmax,hz,1,lm, pasp,ss,W) do l=1,Lm V(:,i,j,L)=W(:,L) end do @@ -1234,18 +1285,19 @@ subroutine sup_vrbeta1 & endsubroutine sup_vrbeta1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine sup_vrbeta1T & + module subroutine sup_vrbeta1T & !********************************************************************** ! * ! conversion of vrbeta1T * ! * !********************************************************************** -(kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) +(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,i0-hx:im+hx,j0-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-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 @@ -1255,8 +1307,8 @@ subroutine sup_vrbeta1T & !---------------------------------------------------------------------- - do j=j0,jm - do i=i0,im + do j=this%j0,jm + do i=this%i0,im do L=1,Lm W(:,L)=V(:,i,j,L) end do @@ -1264,7 +1316,7 @@ subroutine sup_vrbeta1T & W(:,1-L )=W(:,1+L ) W(:,LM+L)=W(:,LM-L) end do - call rbetaT(kmax,hz,1,lm, pasp,ss,W) + call this%rbetaT(kmax,hz,1,lm, pasp,ss,W) ! ! Apply adjoint at the edges of domain ! @@ -1282,38 +1334,39 @@ subroutine sup_vrbeta1T & endsubroutine sup_vrbeta1T !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine sup_vrbeta3 & + module subroutine sup_vrbeta3 & !********************************************************************** ! * ! conversion of vrbeta3 * ! * !********************************************************************** -(kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) +(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,i0-hx:im+hx,j0-hy:jm+hy,1:lm),intent(inout):: V -real(r_kind),dimension(3,3,i0:im,j0:jm,1:lm), intent(in):: pasp -real(r_kind),dimension(i0:im,j0:jm,1:lm), intent(in):: ss +real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(3,3,this%i0:im,this%j0:jm,1:lm), intent(in):: pasp +real(r_kind),dimension(this%i0:im,this%j0:jm,1:lm), intent(in):: ss -real(r_kind),dimension(1:kmax,i0-hx:im+hx,j0-hy:jm+hy,1-hz:lm+hz):: W +real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1-hz:lm+hz):: W integer(i_kind):: i,j,L !---------------------------------------------------------------------- do L=1,Lm - do j=j0-hy,jm+hy - do i=i0-hx,im+hx + do j=this%j0-hy,jm+hy + do i=this%i0-hx,im+hx W(:,i,j,L)=V(:,i,j,L) end do end do end do do L=1,hz - do j=j0-hy,jm+hy - do i=i0-hx,im+hx + do j=this%j0-hy,jm+hy + do i=this%i0-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 @@ -1321,12 +1374,12 @@ subroutine sup_vrbeta3 & end do - call rbeta(kmax,hx,i0,im, hy,j0,jm, hz,1,lm, pasp,ss,W) + call this%rbeta(kmax,hx,this%i0,im, hy,this%j0,jm, hz,1,lm, pasp,ss,W) do l=1,Lm - do j=j0,jm - do i=i0,im + do j=this%j0,jm + do i=this%i0,im V(:,i,j,L)=W(:,i,j,L) end do end do @@ -1336,38 +1389,39 @@ subroutine sup_vrbeta3 & endsubroutine sup_vrbeta3 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine sup_vrbeta3T & + module subroutine sup_vrbeta3T & !********************************************************************** ! * ! conversion of vrbeta3 * ! * !********************************************************************** -(kmax,hx,hy,hz,im,jm,lm, pasp,ss,V) +(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,i0-hx:im+hx,j0-hy:jm+hy,1:lm),intent(inout):: V -real(r_kind),dimension(3,3,i0:im,j0:jm,1:lm), intent(in):: pasp -real(r_kind),dimension(i0:im,j0:jm,1:lm), intent(in):: ss +real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(3,3,this%i0:im,this%j0:jm,1:lm), intent(in):: pasp +real(r_kind),dimension(this%i0:im,this%j0:jm,1:lm), intent(in):: ss -real(r_kind),dimension(1:kmax,i0-hx:im+hx,j0-hy:jm+hy,1-hz:lm+hz):: W +real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1-hz:lm+hz):: W integer(i_kind):: i,j,l !---------------------------------------------------------------------- do L=1,Lm - do j=j0-hy,jm+hy - do i=i0-hx,im+hx + do j=this%j0-hy,jm+hy + do i=this%i0-hx,im+hx W(:,i,j,L)=V(:,i,j,L) end do end do end do do L=1,hz - do j=j0-hy,jm+hy - do i=i0-hx,im+hx + do j=this%j0-hy,jm+hy + do i=this%i0-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 @@ -1375,14 +1429,14 @@ subroutine sup_vrbeta3T & end do - call rbetaT(kmax,hx,i0,im, hy,j0,jm, hz,1,lm, pasp,ss,W) + call this%rbetaT(kmax,hx,this%i0,im, hy,this%j0,jm, hz,1,lm, pasp,ss,W) ! ! Apply adjoint at the edges of domain ! do L=1,hz - do j=j0-hy,jm+hy - do i=i0-hx,im+hx + do j=this%j0-hy,jm+hy + do i=this%i0-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 @@ -1390,8 +1444,8 @@ subroutine sup_vrbeta3T & end do do l=1,lm - do j=j0,jm - do i=i0,im + do j=this%j0,jm + do i=this%i0,im V(:,i,j,l)=W(:,i,j,l) end do end do @@ -1401,4 +1455,4 @@ subroutine sup_vrbeta3T & endsubroutine sup_vrbeta3T !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - endmodule mg_filtering + end submodule mg_filtering diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index df8265041..0741f0873 100644 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -1,5 +1,5 @@ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_generations + submodule(mg_intstate) mg_generations !*********************************************************************** ! ! ! Contains procedures that include differrent generations ! @@ -9,41 +9,98 @@ module mg_generations !*********************************************************************** use mpi use kinds, only: r_kind,i_kind -use mg_parameter, only: i0,j0,im,jm,imL,jmL,hx,hy,gm -use mg_parameter, only: km,kmh,kmf,Fimax,Fjmax,FimaxL,FjmaxL -!use mpimod, only: mype ! << for GSI >> -use mg_mppstuff, only: mype -use mg_mppstuff, only: my_hgen,l_hgen,barrierMPI,finishMPI,Fimax,Fjmax -use mg_bocos, only: boco_2d,bocoT_2d -use mg_bocos, only: upsend_all,downsend_all -use mg_intstate, only: a_diff_h,b_diff_h -use mg_intstate, only: a_diff_f,b_diff_f -use mg_intstate, only: p_coef,q_coef -use mg_intstate, only: a_coef,b_coef +use mg_timers !TEST use, intrinsic:: ieee_arithmetic !TEST -public upsending_all -public downsending_all -public upsending2_all -public downsending2_all +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + contains -public differencing_all +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + 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 -private adjoint_all -private direct_all +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V -private adjoint2_all -private direct2_all +logical, intent(in):: lquart +!----------------------------------------------------------------------- + if(lquart) then + call this%downsending2(H,V) + else + call this%downsending(H,V) + endif -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - contains +!----------------------------------------------------------------------- + endsubroutine downsending_all !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine upsending_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,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-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: ! @@ -51,47 +108,47 @@ subroutine upsending_all & ! Then from g2->...->gn (H -> H) ! ! ! !*********************************************************************** -(V,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(km,1-hx:im+hx,1-hy:jm+hy),intent(in):: V -real(r_kind),dimension(km,1-hx:im+hx,1-hy:jm+hy),intent(out):: H - -real(r_kind),dimension(km,i0-2:imL+2,j0-2:jmL+2):: V_INT -real(r_kind),dimension(km,i0-2:imL+2,j0-2:jmL+2):: H_INT +real(r_kind),dimension(this%km,this%i0-2:this%imL+2,this%j0-2:this%jmL+2):: V_INT +real(r_kind),dimension(this%km,this%i0-2:this%imL+2,this%j0-2:this%jmL+2):: H_INT integer(i_kind):: g,L !----------------------------------------------------------------------- ! ! From generation 1 to generation 2 ! - call adjoint_all(V(1:km,1:im,1:jm),V_INT,km,1) + call this%adjoint(V(1:this%km,1:this%im,1:this%jm),V_INT,this%km,1) - call bocoT_2d(V_INT,km,imL,jmL,2,2) + call this%bocoT_2d(V_INT,this%km,this%imL,this%jmL,2,2) - call upsend_all(V_INT(1:km,1:imL,1:jmL),H,km) + 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,gm-1 + do g=2,this%gm-1 - if(g==my_hgen) then - call adjoint_all(H(1:km,1:im,1:jm),H_INT,km,g) + 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 bocoT_2d(H_INT,km,imL,jmL,2,2,FimaxL,FjmaxL,g,g) + call this%bocoT_2d(H_INT,this%km,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) - call upsend_all(H_INT(1:km,1:imL,1:jmL),H,km,g,g+1) + 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_all + endsubroutine upsending !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine downsending_all & + module subroutine downsending & !*********************************************************************** ! ! ! Downsend, interpolate and add: ! @@ -99,31 +156,32 @@ subroutine downsending_all & ! Then from g2->g1 ! ! ! !*********************************************************************** -(H,V) +(this,H,V) !----------------------------------------------------------------------- implicit none - -real(r_kind),dimension(km,i0-hx:im+hx,j0-hy:jm+hy),intent(inout):: H -real(r_kind),dimension(km,i0-hx:im+hx,j0-hy:jm+hy),intent(inout):: V -real(r_kind),dimension(km,i0-2:imL+2,j0-2:jmL+2):: H_INT -real(r_kind),dimension(km,i0-2:imL+2,j0-2:jmL+2):: V_INT -real(r_kind),dimension(km,i0:im,j0:jm):: H_PROX -real(r_kind),dimension(km,i0:im,j0:jm):: V_PROX +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V + +real(r_kind),dimension(this%km,this%i0-2:this%imL+2,this%j0-2:this%jmL+2):: H_INT +real(r_kind),dimension(this%km,this%i0-2:this%imL+2,this%j0-2:this%jmL+2):: V_INT +real(r_kind),dimension(this%km,this%i0:this%im,this%j0:this%jm):: H_PROX +real(r_kind),dimension(this%km,this%i0:this%im,this%j0:this%jm):: V_PROX integer(i_kind):: g,l,k integer(i_kind):: iL,jL,i,j !----------------------------------------------------------------------- ! ! Upper generations ! - do g=gm,3,-1 + do g=this%gm,3,-1 - call downsend_all(H(1:km,i0:im,j0:jm),H_INT(1:km,1:imL,1:jmL),km,g,g-1) - call boco_2d(H_INT,km,imL,jmL,2,2,FimaxL,FjmaxL,g-1,g-1) + call this%downsend_all(H(1:this%km,this%i0:this%im,this%j0: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(my_hgen==g-1) then - call direct_all(H_INT,H_PROX,km,g-1) - H(1:km,1:im,1:jm)=H (1:km,i0:im,j0:jm) & - +H_PROX(1:km,i0:im,j0:jm) + 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,this%i0:this%im,this%j0:this%jm) & + +H_PROX(1:this%km,this%i0:this%im,this%j0:this%jm) endif enddo @@ -132,21 +190,21 @@ subroutine downsending_all & ! From geneartion 2 to generation 1 ! - call downsend_all(H(1:km,i0:im,j0:jm),V_INT(1:km,1:imL,1:jmL),km) + call this%downsend_all(H(1:this%km,this%i0:this%im,this%j0:this%jm),V_INT(1:this%km,1:this%imL,1:this%jmL),this%km) H(:,:,:)=0. - call boco_2d(V_INT,km,imL,jmL,2,2) + call this%boco_2d(V_INT,this%km,this%imL,this%jmL,2,2) - call direct_all(V_INT,V_PROX,km,1) + call this%direct1(V_INT,V_PROX,this%km,1) - V(1:km,i0:im,j0:jm)=V (1:km,i0:im,j0:jm) & - +V_PROX(1:km,i0:im,j0:jm) + V(1:this%km,this%i0:this%im,this%j0:this%jm)=V (1:this%km,this%i0:this%im,this%j0:this%jm) & + +V_PROX(1:this%km,this%i0:this%im,this%j0:this%jm) !----------------------------------------------------------------------- - endsubroutine downsending_all + endsubroutine downsending !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine upsending2_all & + module subroutine upsending2 & !*********************************************************************** ! ! ! Adjoint interpolate and upsend: ! @@ -154,47 +212,49 @@ subroutine upsending2_all & ! Then from g2->...->gn (H -> H) ! ! ! !*********************************************************************** -(V,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(km,1-hx:im+hx,1-hy:jm+hy),intent(in):: V -real(r_kind),dimension(km,1-hx:im+hx,1-hy:jm+hy),intent(out):: H -real(r_kind),dimension(km,0:imL+1,0:jmL+1):: V_INT -real(r_kind),dimension(km,0:imL+1,0: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,0:this%imL+1,0:this%jmL+1):: H_INT integer(i_kind):: g,L !----------------------------------------------------------------------- ! ! From generation 1 to generation 2 ! - call adjoint2_all(V(1:km,1:im,1:jm),V_INT,km,1) + call this%adjoint2(V(1:this%km,1:this%im,1:this%jm),V_INT,this%km,1) - call bocoT_2d(V_INT,km,imL,jmL,1,1) + call this%bocoT_2d(V_INT,this%km,this%imL,this%jmL,1,1) - call upsend_all(V_INT(1:km,1:imL,1:jmL),H,km) + 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,gm-1 + do g=2,this%gm-1 - if(g==my_hgen) then - call adjoint2_all(H(1:km,1:im,1:jm),H_INT,km,g) + 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 bocoT_2d(H_INT,km,imL,jmL,1,1,FimaxL,FjmaxL,g,g) + call this%bocoT_2d(H_INT,this%km,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g,g) - call upsend_all(H_INT(1:km,1:imL,1:jmL),H,km,g,g+1) + 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_all + endsubroutine upsending2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine downsending2_all & + module subroutine downsending2 & !*********************************************************************** ! ! ! Downsend, interpolate and add: ! @@ -202,31 +262,31 @@ subroutine downsending2_all & ! Then from g2->g1 ! ! ! !*********************************************************************** -(H,V) +(this,H,V) !----------------------------------------------------------------------- implicit none - -real(r_kind),dimension(km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: H -real(r_kind),dimension(km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: V -real(r_kind),dimension(km,0:imL+1,0:jmL+1):: H_INT -real(r_kind),dimension(km,0:imL+1,0:jmL+1):: V_INT -real(r_kind),dimension(km,1:im,1:jm):: H_PROX -real(r_kind),dimension(km,1:im,1:jm):: V_PROX +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=gm,3,-1 + do g=this%gm,3,-1 - call downsend_all(H(1:km,1:im,1:jm),H_INT(1:km,1:imL,1:jmL),km,g,g-1) - call boco_2d(H_INT,km,imL,jmL,1,1,FimaxL,FjmaxL,g-1,g-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(my_hgen==g-1) then - call direct2_all(H_INT,H_PROX,km,g-1) - H(1:km,1:im,1:jm)=H (1:km,1:im,1:jm) & - +H_PROX(1:km,1:im,1:jm) + 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 @@ -235,82 +295,83 @@ subroutine downsending2_all & ! From generation 2 to generation 1 ! - call downsend_all(H(1:km,1:im,1:jm),V_INT(1:km,1:imL,1:jmL),km) + 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 boco_2d(V_INT,km,imL,jmL,1,1) + call this%boco_2d(V_INT,this%km,this%imL,this%jmL,1,1) - call direct2_all(V_INT,V_PROX,km,1) + call this%direct2(V_INT,V_PROX,this%km,1) - V(1:km,1:im,1:jm)=V (1:km,1:im,1:jm) & - +V_PROX(1:km,1:im,1:jm) + 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_all + endsubroutine downsending2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine differencing_all & + module subroutine weighting_helm & !*********************************************************************** ! ! ! Apply 2D differential operator to compound variable ! ! ! !*********************************************************************** -(V,H) +(this,V,H) !----------------------------------------------------------------------- implicit none - -real(r_kind),dimension(kmf,i0-hx:im+hx,j0-hy:jm+hy),intent(inout):: V -real(r_kind),dimension(kmh,i0-hx:im+hx,j0-hy:jm+hy),intent(inout):: H -real(r_kind),dimension(kmf,i0-1:im, j0 :jm):: DIFX -real(r_kind),dimension(kmf,i0 :im ,j0-1:jm):: DIFY -real(r_kind),dimension(kmh,i0-1:im, 0 :jm):: DIFXH -real(r_kind),dimension(kmh,i0 :im ,j0-1:jm):: DIFYH +class (mg_intstate_type),target:: this + +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,this%i0-1:this%im, this%j0 :this%jm):: DIFX +real(r_kind),dimension(this%km,this%i0 :this%im ,this%j0-1:this%jm):: DIFY +real(r_kind),dimension(this%km,this%i0-1:this%im, this%j0 :this%jm):: DIFXH +real(r_kind),dimension(this%km,this%i0 :this%im ,this%j0-1:this%jm):: DIFYH integer(i_kind):: i,j,l,k,imx,jmx !----------------------------------------------------------------------- - do j=j0,jm - do i=i0-1,im + do j=this%j0,this%jm + do i=this%i0-1,this%im DIFX(:,i,j)=V(:,i+1,j)-V(:,i,j) enddo enddo - do j=j0-1,jm - do i=i0,im + do j=this%j0-1,this%jm + do i=this%i0,this%im DIFY(:,i,j)=V(:,i,j+1)-V(:,i,j) enddo enddo - do j=j0,jm - do i=i0,im - V(:,i,j)=a_diff_f(:,i,j)*V(:,i,j) & - -b_diff_f(:,i,j)*(DIFX(:,i,j)-DIFX(:,i-1,j) & + do j=this%j0,this%jm + do i=this%i0,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(l_hgen) then +if(this%l_hgen) then ! imx = Fimax(my_hgen) ! jmx = Fjmax(my_hgen) - imx = im - jmx = jm + imx = this%im + jmx = this%jm - do j=j0,jmx - do i=i0-1,imx + do j=this%j0,jmx + do i=this%i0-1,imx DIFXH(:,i,j)=H(:,i+1,j)-H(:,i,j) enddo enddo - do j=j0-1,jmx - do i=i0,imx + do j=this%j0-1,jmx + do i=this%i0,imx DIFYH(:,i,j)=H(:,i,j+1)-H(:,i,j) enddo enddo - do j=j0,jmx - do i=i0,imx - H(:,i,j)=a_diff_h(:,i,j)*H(:,i,j) & - -b_diff_h(:,i,j)*(DIFXH(:,i,j)-DIFXH(:,i-1,j) & + do j=this%j0,jmx + do i=this%i0,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 @@ -318,10 +379,50 @@ subroutine differencing_all & endif !----------------------------------------------------------------------- - endsubroutine differencing_all + 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,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H + +integer(i_kind):: i,j,l,k,imx,jmx +!----------------------------------------------------------------------- + + do j=this%j0,this%jm + do i=this%i0,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=this%j0,jmx + do i=this%i0,imx + H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) + enddo + enddo + +endif + + +!----------------------------------------------------------------------- + endsubroutine weighting !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine adjoint_all & + module subroutine adjoint & !*********************************************************************** ! ! ! Mapping from the high to low resolution grid ! @@ -329,14 +430,15 @@ subroutine adjoint_all & ! - offset version - ! ! ! !*********************************************************************** -(F,W,km,g) +(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 -real(r_kind), dimension(km,i0:im,j0:jm), intent(in):: F -real(r_kind), dimension(km,i0-2:imL+2,j0-2:jmL+2), intent(out):: W -real(r_kind), dimension(km,i0:im,j0-2:jmL+2):: W_AUX +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,this%i0:this%im,this%j0:this%jm), intent(in):: F +real(r_kind), dimension(km_in,this%i0-2:this%imL+2,this%j0-2:this%jmL+2), intent(out):: W +real(r_kind), dimension(km_in,this%i0:this%im,this%j0-2:this%jmL+2):: W_AUX integer(i_kind):: i,j,iL,jL !----------------------------------------------------------------------- ! @@ -344,25 +446,25 @@ subroutine adjoint_all & ! W_AUX(:,:,:)= 0. - do j=jm,2,-2 + do j=this%jm,2,-2 jL = j/2 - do i=im,1,-1 - W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+p_coef(4)*F(:,i,j) - W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+p_coef(3)*F(:,i,j) - W_AUX(:,i,jL )=W_AUX(:,i,jL )+p_coef(2)*F(:,i,j) - W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+p_coef(1)*F(:,i,j) + 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=jm-1,1,-2 + do j=this%jm-1,1,-2 jL=j/2 - do i=im,1,-1 - W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+q_coef(4)*F(:,i,j) - W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+q_coef(3)*F(:,i,j) - W_AUX(:,i,jL )=W_AUX(:,i,jL )+q_coef(2)*F(:,i,j) - W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+q_coef(1)*F(:,i,j) + 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 @@ -370,28 +472,28 @@ subroutine adjoint_all & ! ! 1) ! - do jL=jmL+2,-1,-1 - do i=im-1,1,-2 + do jL=this%jmL+2,-1,-1 + do i=this%im-1,1,-2 iL = i/2 - W(:,iL+2,jL)=W(:,iL+2,jL)+q_coef(4)*W_AUX(:,i,jL) - W(:,iL+1,jL)=W(:,iL+1,jL)+q_coef(3)*W_AUX(:,i,jL) - W(:,iL ,jL)=W(:,iL ,jL)+q_coef(2)*W_AUX(:,i,jL) - W(:,iL-1,jL)=W(:,iL-1,jL)+q_coef(1)*W_AUX(:,i,jL) + 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=im,2,-2 + do i=this%im,2,-2 iL=i/2 - W(:,iL+2,jL)=W(:,iL+2,jL)+p_coef(4)*W_AUX(:,i,jL) - W(:,iL+1,jL)=W(:,iL+1,jL)+p_coef(3)*W_AUX(:,i,jL) - W(:,iL ,jL)=W(:,iL ,jL)+p_coef(2)*W_AUX(:,i,jL) - W(:,iL-1,jL)=W(:,iL-1,jL)+p_coef(1)*W_AUX(:,i,jL) + 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_all + endsubroutine adjoint !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine direct_all & + module subroutine direct1 & !*********************************************************************** ! ! ! Mapping from the low to high resolution grid ! @@ -399,58 +501,59 @@ subroutine direct_all & ! - offset version - ! ! ! !*********************************************************************** -(W,F,km,g) +(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 -real(r_kind), dimension(km,i0-2:imL+2,j0-2:jmL+2), intent(in):: W -real(r_kind), dimension(km,i0:im,j0:jm), intent(out):: F -real(r_kind), dimension(km,i0:im,j0-2:jmL+2):: W_AUX +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,this%i0-2:this%imL+2,this%j0-2:this%jmL+2), intent(in):: W +real(r_kind), dimension(km_in,this%i0:this%im,this%j0:this%jm), intent(out):: F +real(r_kind), dimension(km_in,this%i0:this%im,this%j0-2:this%jmL+2):: W_AUX integer(i_kind):: i,j,iL,jL !----------------------------------------------------------------------- ! ! 1) ! - do jL=-1,jmL+2 - do i=1,im-1,2 + do jL=-1,this%jmL+2 + do i=1,this%im-1,2 iL=i/2 - W_AUX(:,i,jL)=q_coef(1)*W(:,iL-1,jL)+q_coef(2)*W(:,iL ,jL) & - +q_coef(3)*W(:,iL+1,jL)+q_coef(4)*W(:,iL+2,jL) + 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,im,2 + do i=2,this%im,2 iL=i/2 - W_AUX(:,i,jL)=p_coef(1)*W(:,iL-1,jL)+p_coef(2)*w(:,iL ,jL) & - +p_coef(3)*W(:,iL+1,jL)+p_coef(4)*W(:,iL+2,jL) + 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,jm-1,2 + do j=1,this%jm-1,2 jL=j/2 - do i=1,im - F(:,i,j)=q_coef(1)*W_AUX(:,i,jL-1)+q_coef(2)*W_AUX(:,i,jL ) & - +q_coef(3)*W_AUX(:,i,jL+1)+q_coef(4)*W_AUX(:,i,jL+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,jm,2 + do j=2,this%jm,2 jL=j/2 - do i=1,im - F(:,i,j)=p_coef(1)*W_AUX(:,i,jL-1)+p_coef(2)*W_AUX(:,i,jL ) & - +p_coef(3)*W_AUX(:,i,jL+1)+p_coef(4)*W_AUX(:,i,jL+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 direct_all + endsubroutine direct1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine adjoint2_all & + module subroutine adjoint2 & !*********************************************************************** ! ! ! Mapping from the high to low resolution grid ! @@ -458,14 +561,15 @@ subroutine adjoint2_all & ! - offset version - ! ! ! !*********************************************************************** -(F,W,km,g) +(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 -real(r_kind), dimension(km,1:im,1:jm), intent(in):: F -real(r_kind), dimension(km,0:imL+1,0:jmL+1), intent(out):: W -real(r_kind), dimension(km,1:im,0:jmL+2):: W_AUX +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+2):: W_AUX integer(i_kind):: i,j,iL,jL !----------------------------------------------------------------------- ! @@ -473,23 +577,23 @@ subroutine adjoint2_all & ! W_AUX(:,:,:)= 0. - do j=jm,2,-2 + do j=this%jm,2,-2 jL = j/2 - do i=im,1,-1 - W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+b_coef(3)*F(:,i,j) - W_AUX(:,i,jL )=W_AUX(:,i,jL )+b_coef(2)*F(:,i,j) - W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+b_coef(1)*F(:,i,j) + 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=jm-1,1,-2 + do j=this%jm-1,1,-2 jL=(j+1)/2 - do i=im,1,-1 - W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+a_coef(3)*F(:,i,j) - W_AUX(:,i,jL )=W_AUX(:,i,jL )+a_coef(2)*F(:,i,j) - W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+a_coef(1)*F(:,i,j) + 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 @@ -497,26 +601,26 @@ subroutine adjoint2_all & ! ! 1) ! - do jL=jmL+1,0,-1 - do i=im-1,1,-2 + do jL=this%jmL+1,0,-1 + do i=this%im-1,1,-2 iL = (i+1)/2 - W(:,iL+1,jL)=W(:,iL+1,jL)+a_coef(3)*W_AUX(:,i,jL) - W(:,iL ,jL)=W(:,iL ,jL)+a_coef(2)*W_AUX(:,i,jL) - W(:,iL-1,jL)=W(:,iL-1,jL)+a_coef(1)*W_AUX(:,i,jL) + 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=im,2,-2 + do i=this%im,2,-2 iL=i/2 - W(:,iL+1,jL)=W(:,iL+1,jL)+b_coef(3)*W_AUX(:,i,jL) - W(:,iL ,jL)=W(:,iL ,jL)+b_coef(2)*W_AUX(:,i,jL) - W(:,iL-1,jL)=W(:,iL-1,jL)+b_coef(1)*W_AUX(:,i,jL) + 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_all + endsubroutine adjoint2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine direct2_all & + module subroutine direct2 & !*********************************************************************** ! ! ! Mapping from the low to high resolution grid ! @@ -524,54 +628,55 @@ subroutine direct2_all & ! - offset version - ! ! ! !*********************************************************************** -(W,F,km,g) +(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 -real(r_kind), dimension(km,0:imL+1,0:jmL+1), intent(in):: W -real(r_kind), dimension(km,1:im,1:jm), intent(out):: F -real(r_kind), dimension(km,1:im,0:jmL+1):: W_AUX +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,jmL+1 - do i=1,im-1,2 + do jL=0,this%jmL+1 + do i=1,this%im-1,2 iL=(i+1)/2 - W_AUX(:,i,jL)=a_coef(1)*W(:,iL-1,jL)+a_coef(2)*W(:,iL ,jL) & - +a_coef(3)*W(:,iL+1,jL) + 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,im,2 + do i=2,this%im,2 iL=i/2 - W_AUX(:,i,jL)=b_coef(1)*W(:,iL-1,jL)+b_coef(2)*w(:,iL ,jL) & - +b_coef(3)*W(:,iL+1,jL) + 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,jm-1,2 + do j=1,this%jm-1,2 jL=(j+1)/2 - do i=1,im - F(:,i,j)=a_coef(1)*W_AUX(:,i,jL-1)+a_coef(2)*W_AUX(:,i,jL ) & - +a_coef(3)*W_AUX(:,i,jL+1) + 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,jm,2 + do j=2,this%jm,2 jL=j/2 - do i=1,im - F(:,i,j)=b_coef(1)*W_AUX(:,i,jL-1)+b_coef(2)*W_AUX(:,i,jL ) & - +b_coef(3)*W_AUX(:,i,jL+1) + 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_all + endsubroutine direct2 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - endmodule mg_generations + end submodule mg_generations diff --git a/src/saber/mgbf/mgbf_lib/type_mg_interpolate.f90 b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 similarity index 64% rename from src/saber/mgbf/mgbf_lib/type_mg_interpolate.f90 rename to src/saber/mgbf/mgbf_lib/mg_interpolate.f90 index 92506f46f..9ec122a51 100644 --- a/src/saber/mgbf/mgbf_lib/type_mg_interpolate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 @@ -1,5 +1,5 @@ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_interpolate + submodule(mg_intstate) mg_interpolate !*********************************************************************** ! ! ! general mapping between 2d arrays using linerly squared ! @@ -7,85 +7,64 @@ module mg_interpolate ! ! ! M. Rancic (2020) ! !*********************************************************************** -use mpi use kinds -use mg_parameter, only: xa0,ya0,xf0,yf0,dxa,dxf,dya,dyf & - ,nm,mm,km,km2,km3,lm,lm_all & - ,i0,j0,n0,m0 & - ,im,jm,ib,jb -use mg_intstate, only: iref,jref & - ,cx0,cx1,cx2,cx3 & - ,cy0,cy1,cy2,cy3 -use mg_intstate, only: p_coef,q_coef -use mg_intstate, only: a_coef,b_coef +use jp_pkind2, only: fpi !use mpimod, only: mype -use mg_mppstuff, only: mype -use mg_mppstuff, only: finishMPI implicit none - -type interpolate_type -contains -procedure,nopass :: lsqr_mg_coef - -procedure,nopass :: lwq_vertical_coef -procedure,nopass :: lwq_vertical_direct -procedure,nopass :: lwq_vertical_adjoint - -procedure,nopass :: def_offset_coef - -procedure,nopass :: lsqr_direct_offset -procedure,nopass :: lsqr_adjoint_offset -end type interpolate_type !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ contains !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine def_offset_coef + module subroutine def_offset_coef (this) !*********************************************************************** implicit none +class(mg_intstate_type),target::this -real(r_kind):: r64,r32,r128 +real(r_kind):: r64,r32,r128,r2 !----------------------------------------------------------------------- r64 = 1.0d0/64.0d0 r32 = 1.0d0/32.0d0 r128= 1.0d0/128.0d0 +! r2 = 1.0d0/2.0d0 + r2 = 1.0d0 ! p_coef =(/-3.,51,29,-3/) ! q_coef =(/-3.,19.0d0,51.0d0,-3.0d0/) ! p_coef = p_coef*r64 -1 q_coef = q_coef*r64 +! q_coef = q_coef*r64 - p_coef =(/-9.,111.,29.,-3./) - q_coef =(/-3.,29.,111.,-9./) - p_coef = p_coef*r128 - q_coef = q_coef*r128 + this%p_coef =(/-9.,111.,29.,-3./) + this%q_coef =(/-3.,29.,111.,-9./) +this%p_coef = this%p_coef*r128 *r2 + this%q_coef = this%q_coef*r128 *r2 - a_coef =(/5.0d0,30.0d0,-3.0d0/) - b_coef =(/-3.0d0,30.0d0,5.0d0/) - a_coef=a_coef*r32 - b_coef=b_coef*r32 + this%a_coef =(/5.0d0,30.0d0,-3.0d0/) + this%b_coef =(/-3.0d0,30.0d0,5.0d0/) + this%a_coef=this%a_coef*r32 *r2 + this%b_coef=this%b_coef*r32 *r2 !----------------------------------------------------------------------- endsubroutine def_offset_coef !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine lsqr_mg_coef + module subroutine lsqr_mg_coef (this) !*********************************************************************** ! ! ! Prepare coeficients for mapping between: ! ! filter grid on analysis decomposition: W(i0-ib:im+ib,j0-jb:jm+jb) ! -! and analysis grid: V(0:nm,0:mm) ! +! and analysis grid: V(1:nm,1:mm) ! ! - offset version - ! ! ! ! ( im < nm and jm < mm ) ! ! ! !*********************************************************************** implicit none -real(r_kind), dimension(0:nm):: xa -real(r_kind), dimension(1-ib:im+ib):: xf -real(r_kind), dimension(0:mm):: ya -real(r_kind), dimension(1-jb:jm+jb):: yf +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 @@ -100,46 +79,49 @@ subroutine lsqr_mg_coef ! Initialize ! - do n=0,nm - xa(n)=xa0+n*dxa + do n=1,this%nm + xa(n)=this%xa0+this%dxa*(n-1) enddo - do i=1-ib,im+ib - xf(i)=xf0+i*dxf + do i=1-this%ib,this%im+this%ib + xf(i)=this%xf0+this%dxf*(i-1) enddo - do m=0,mm - ya(m)=ya0+m*dya + do m=1,this%mm + ya(m)=this%ya0+this%dya*(m-1) enddo - do j=1-jb,jm+jb - yf(j)=yf0+j*dyf + do j=1-this%jb,this%jm+this%jb + yf(j)=this%yf0+this%dyf*(j-1) enddo ! ! Find iref and jref ! - do n=0,nm - do i=1-ib,im+ib-1 + do n=1,this%nm + do i=1-this%ib,this%im+this%ib-1 if( xa(n)< xf(i)) then - iref(n)=i-2 + this%iref(n)=i-2 exit endif enddo enddo - do m=0,mm - do j=1-jb,jm+jb-1 + do m=1,this%mm + do j=1-this%jb,this%jm+this%jb-1 if(ya(m) < yf(j)) then - jref(m)=j-2 + this%jref(m)=j-2 exit endif enddo enddo +!ddreal(r_kind), dimension(1-this%ib:this%im+this%ib):: xf +write(6,*)"thinkdeb 0 ",1-this%ib, ' ',this%im+this%ib,this%nm - do n=0,nm - i=iref(n) + do n=1,this%nm + write(6,*)'thinkdeb n iref ',n,this%iref(n) + i=this%iref(n) x1=xf(i) x2=xf(i+1) x3=xf(i+2) @@ -163,14 +145,14 @@ subroutine lsqr_mg_coef CFR2 =-x2x*x4x*rx3x2*rx4x3 CFR3 = x2x*x3x*rx4x2*rx4x3 CRR =-x2x*rx3x2 - cx0(n)=CFL1*CLL - cx1(n)=CFL2*CLL+CFR1*CRR - cx2(n)=CFL3*CLL+CFR2*CRR - cx3(n)=CFR3*CRR + 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=0,mm - j=jref(m) + do m=1,this%mm + j=this%jref(m) y1=yf(j) y2=yf(j+1) y3=yf(j+2) @@ -194,10 +176,10 @@ subroutine lsqr_mg_coef CFR2 =-y2y*y4y*ry3y2*ry4y3 CFR3 = y2y*y3y*ry4y2*ry4y3 CRR =-y2y*ry3y2 - cy0(m)=CFL1*CLL - cy1(m)=CFL2*CLL+CFR1*CRR - cy2(m)=CFL3*CLL+CFR2*CRR - cy3(m)=CFR3*CRR + 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 @@ -205,7 +187,7 @@ subroutine lsqr_mg_coef endsubroutine lsqr_mg_coef !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine lwq_vertical_coef & + module subroutine lwq_vertical_coef & !*********************************************************************** ! ! ! Prepare coeficients for vetical mapping between: ! @@ -215,39 +197,39 @@ subroutine lwq_vertical_coef & ! ( im <= nm ) ! ! ! !*********************************************************************** -(nm,im,c1,c2,c3,c4,iref) -use mg_mppstuff, only: mype +(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,im -real(r_kind), dimension(1:nm), intent(out):: c1,c2,c3,c4 -integer(i_kind), dimension(1:nm), intent(out):: iref +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):: y -real(r_kind), dimension(0:im+1):: x +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+1 + do i=0,im_in+1 x(i)=(i-1)*1. enddo - dy = 1.*(im-1)/(nm-1) - do n=1,nm + dy = 1.*(im_in-1)/(nm_in-1) + do n=1,nm_in y(n)=(n-1)*dy enddo - y(nm)=x(im) + y(nm_in)=x(im_in) - do n=2,nm-1 + 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(n)=i + iref_out(n)=i dx1 = y(n)-x1 dx2 = y(n)-x2 dx3 = y(n)-x3 @@ -260,24 +242,24 @@ subroutine lwq_vertical_coef & c3(n) = -(0.5*dx13+ dx24)*dx2 c4(n) = dx23*dx2 - if(iref(n)==1) then + if(iref_out(n)==1) then c3(n)=c3(n)+c1(n) c1(n)=0. endif - if(iref(n)==im-1) then + if(iref_out(n)==im_in-1) then c2(n)=c2(n)+c4(n) c4(n)=0. endif enddo - iref(1)=1; c1(1)=0.; c2(1)=1.; c3(1)=0.; c4(1)=0. - iref(nm)=im; c1(nm)=0.; c2(nm)=1.; c3(nm)=0.; c4(n)=0. + 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 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine lwq_vertical_adjoint & + module subroutine lwq_vertical_adjoint & !*********************************************************************** ! ! ! Direct linerly weighted quadratic adjoint interpolation in vertical ! @@ -286,29 +268,30 @@ subroutine lwq_vertical_adjoint & ! ( im <= nm ) ! ! ! !*********************************************************************** -(nm,km,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) +(this,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) implicit none !----------------------------------------------------------------------- -integer(i_kind), intent(in):: nm,km,imin,imax,jmin,jmax -real(r_kind), dimension(1:nm), intent(in):: c1,c2,c3,c4 -integer(i_kind), dimension(1:nm), intent(in):: kref -real(r_kind), dimension(1:nm,imin:imax,jmin:jmax), intent(in):: w -real(r_kind), dimension(1:km,imin:imax,jmin:jmax), intent(out):: f +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-1 +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-1) then - f(km-2,:,:) = f(km-2,:,:)+c1(n)*w(n,:,:) - f(km-1,:,:) = f(km-1,:,:)+c2(n)*w(n,:,:) - f(km ,:,:) = f(km ,:,:)+c3(n)*w(n,:,:) - elseif( k==km) then + ( 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,:,:) @@ -318,13 +301,13 @@ subroutine lwq_vertical_adjoint & endif enddo f(1,:,:)=f(1,:,:)+w(1,:,:) - f(km,:,:)=f(km,:,:)+w(nm,:,:) + f(km_in,:,:)=f(km_in,:,:)+w(nm_in,:,:) !----------------------------------------------------------------------- endsubroutine lwq_vertical_adjoint !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine lwq_vertical_direct & + module subroutine lwq_vertical_direct & !*********************************************************************** ! ! ! Linerly weighted direct quadratic interpolation in vertical ! @@ -333,78 +316,80 @@ subroutine lwq_vertical_direct & ! ( im <= nm ) ! ! ! !*********************************************************************** -(km,nm,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,f,w) +(this,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,f,w) implicit none !----------------------------------------------------------------------- -integer(i_kind), intent(in):: km,nm,imin,imax,jmin,jmax -real(r_kind), dimension(1:nm), intent(in):: c1,c2,c3,c4 -integer(i_kind), dimension(1:nm), intent(in):: kref -real(r_kind), dimension(1:km,imin:imax,jmin:jmax), intent(in):: f -real(r_kind), dimension(1:nm,imin:imax,jmin:jmax), intent(out):: w +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-1 +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-1) then + ( k==km_in-1) then w(n,:,:) =c1(n)*f(k-1,:,:)+c2(n)*f(k,:,:)+c3(n)*f(k+1,:,:) elseif & - ( k==km) then + ( 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,:,:)=f(km,:,:) + w(nm_in,:,:)=f(km_in,:,:) !----------------------------------------------------------------------- endsubroutine lwq_vertical_direct !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine lsqr_direct_offset & + module subroutine lsqr_direct_offset & !*********************************************************************** ! ! ! Given a source array V(km,i0-ib:im+ib,j0-jb:jm+jb) perform ! -! direct interpolations to get target array W(km,0:nm,0:mm) ! +! direct interpolations to get target array W(km,1:nm,1:mm) ! ! using two passes of 1d interpolator ! ! ! !*********************************************************************** -(V,W,km) +(this,V_in,W,km_in) !----------------------------------------------------------------------- implicit none -integer(i_kind),intent(in):: km -real(r_kind), dimension(km,i0-ib:im+ib,j0-jb:jm+jb), intent(in):: V -real(r_kind), dimension(km,0:nm,0:mm),intent(out):: W +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,1-this%ib:this%im+this%ib,1-this%jb:this%jm+this%jb), intent(in):: V_in +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W -real(r_kind), dimension(km,0:nm,j0-jb:jm+jb):: VX +real(r_kind), dimension(km_in,1:this%nm,this%j0-this%jb:this%jm+this%jb):: VX integer(i_kind):: i,j,n,m -real(r_kind),dimension(km):: v0,v1,v2,v3 +real(r_kind),dimension(km_in):: v0,v1,v2,v3 !----------------------------------------------------------------------- - do j=j0-jb,jm+jb - do n=0,nm - i = iref(n) - v0(:)=V(:,i ,j) - v1(:)=V(:,i+1,j) - v2(:)=V(:,i+2,j) - v3(:)=V(:,i+3,j) - VX(:,n,j) = cx0(n)*v0(:)+cx1(n)*v1(:)+cx2(n)*v2(:)+cx3(n)*v3(:) + do j=this%j0-this%jb,this%jm+this%jb + 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=0,mm - j = jref(m) - do n=0,nm + 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) = cy0(m)*v0(:)+cy1(m)*v1(:)+cy2(m)*v2(:)+cy3(m)*v3(:) + W(:,n,m) = this%cy0(m)*v0(:)+this%cy1(m)*v1(:)+this%cy2(m)*v2(:)+this%cy3(m)*v3(:) enddo enddo @@ -412,7 +397,7 @@ subroutine lsqr_direct_offset & endsubroutine lsqr_direct_offset !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine lsqr_adjoint_offset & + module subroutine lsqr_adjoint_offset & !*********************************************************************** ! ! ! Given a target array W(km,0:nm,0:mm) perform adjoint ! @@ -421,47 +406,48 @@ subroutine lsqr_adjoint_offset & ! - offset version - ! ! ! !*********************************************************************** -(W,V,km) +(this,W,V_out,km_in) !----------------------------------------------------------------------- implicit none -integer(i_kind):: km -real(r_kind), dimension(km,0:nm,0:mm),intent(in):: W -real(r_kind), dimension(km,i0-ib:im+ib,j0-jb:jm+jb), intent(out):: V -real(r_kind), dimension(km,0:nm,j0-jb:jm+jb):: VX +class(mg_intstate_type),target::this +integer(i_kind):: km_in +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W +real(r_kind), dimension(km_in,1-this%ib:this%im+this%ib,1-this%jb:this%jm+this%jb), intent(out):: V_out +real(r_kind), dimension(km_in,1:this%nm,this%j0-this%jb:this%jm+this%jb):: VX integer(i_kind):: i,j,n,m,l,k integer(i_kind):: ip1,ip2,ip3 integer(i_kind):: jp1,jp2,jp3 !----------------------------------------------------------------------- - V(:,:,:) = 0. + V_out(:,:,:) = 0. VX(:,:,:)=0. - do m=0,mm - j = jref(m) + do m=1,this%mm + j = this%jref(m) jp1=j+1 jp2=j+2 jp3=j+3 - do n=0,nm - VX(:,n,j ) = VX(:,n,j )+W(:,n,m)*cy0(m) - VX(:,n,jp1) = VX(:,n,jp1)+W(:,n,m)*cy1(m) - VX(:,n,jp2) = VX(:,n,jp2)+W(:,n,m)*cy2(m) - VX(:,n,jp3) = VX(:,n,jp3)+W(:,n,m)*cy3(m) + do n=1,this%nm + VX(:,n,j ) = VX(:,n,j )+W(:,n,m)*this%cy0(m) + VX(:,n,jp1) = VX(:,n,jp1)+W(:,n,m)*this%cy1(m) + VX(:,n,jp2) = VX(:,n,jp2)+W(:,n,m)*this%cy2(m) + VX(:,n,jp3) = VX(:,n,jp3)+W(:,n,m)*this%cy3(m) enddo enddo - do j=j0-jb,jm+jb - do n=0,nm - i = iref(n) + do j=this%j0-this%jb,this%jm+this%jb + do n=1,this%nm + i = this%iref(n) ip1=i+1 ip2=i+2 ip3=i+3 - V(:,i ,j) = V(:,i ,j)+VX(:,n,j)*cx0(n) - V(:,ip1,j) = V(:,ip1,j)+VX(:,n,j)*cx1(n) - V(:,ip2,j) = V(:,ip2,j)+VX(:,n,j)*cx2(n) - V(:,ip3,j) = V(:,ip3,j)+VX(:,n,j)*cx3(n) + V_out(:,i ,j) = V_out(:,i ,j)+VX(:,n,j)*this%cx0(n) + V_out(:,ip1,j) = V_out(:,ip1,j)+VX(:,n,j)*this%cx1(n) + V_out(:,ip2,j) = V_out(:,ip2,j)+VX(:,n,j)*this%cx2(n) + V_out(:,ip3,j) = V_out(:,ip3,j)+VX(:,n,j)*this%cx3(n) enddo enddo @@ -469,4 +455,4 @@ subroutine lsqr_adjoint_offset & endsubroutine lsqr_adjoint_offset !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - endmodule mg_interpolate + end submodule mg_interpolate diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 new file mode 100644 index 000000000..b6af156a4 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -0,0 +1,1193 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_intstate +!*********************************************************************** +! ! +! Contains declarations and allocations of internal state variables ! +! use for filtering ! +! - offset version - ! +! ! +! M. Rancic (2020) ! +!*********************************************************************** +use mpi +use kinds, only: r_kind,i_kind +use jp_pkind2, only: fpi +!GSI use mpimod, only: mype +!use mg_entrymod, only: km2,km3,km +!GSI use berror, only: mg_weig1,mg_weig2,mg_weig3,mg_weig4 +!clt use jp_pbfil,only: cholaspect +!use jp_pbfil,only: getlinesum +use jp_pbfil3, only: inimomtab,t22_to_3,tritform,t33_to_6,hextform +use mg_parameter,only: mg_parameter_type +!TEST +!use gridmod, only: lat1,lon1 +!TEST +implicit none +type,extends( mg_parameter_type):: mg_intstate_type +real(r_kind), allocatable,dimension(:,:,:):: V +! +! Composite control variable on first generation o filter grid +! +real(r_kind), allocatable,dimension(:,:,:):: VALL +real(r_kind), allocatable,dimension(:,:,:):: HALL +! +! Composite control variable on high generations of filter grid +! +! +!FOR ADJOINT TEST +! +!real(r_kind), allocatable,dimension(:,:):: A +!real(r_kind), allocatable,dimension(:,:):: B +!real(r_kind), allocatable,dimension(:,:):: A0 +!real(r_kind), allocatable,dimension(:,:):: B0 +! +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 + +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 + +!real(r_kind), allocatable,dimension(:,:,:,:):: r_vol +! +! +! Composite stacked variable +! + +!cltreal(r_kind), allocatable,dimension(:,:,:):: WORKA + + +integer(i_kind),allocatable,dimension(:):: iref,jref +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(:):: 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 +!clt from interpolate.f90 +contains + procedure :: allocate_mg_intstate, def_mg_weights, init_mg_line + procedure ::def_offset_coef + procedure ::lsqr_mg_coef,lwq_vertical_coef + procedure ::lwq_vertical_direct,lwq_vertical_adjoint , & + lsqr_direct_offset, & + deallocate_mg_intstate, & + lsqr_adjoint_offset + generic ::boco_2d => boco_2d_g1,boco_2d_gh + generic ::boco_3d => boco_3d_g1,boco_3d_gh + generic ::bocoT_2d => bocoT_2d_g1,bocoT_2d_gh + generic ::bocoTx => bocoTx_2d_g1,bocoTx_2d_gh + generic ::bocoTy => bocoTy_2d_g1,bocoTy_2d_gh + generic ::bocoT_3d => bocoT_3d_g1,bocoT_3d_gh + generic ::bocox => bocox_2d_g1,bocox_2d_gh + generic ::bocoy => bocoy_2d_g1,bocoy_2d_gh + + generic ::upsend_all=> upsend_all_g1 ,upsend_all_gh + generic ::downsend_all=> downsend_all_g2 ,downsend_all_gh + procedure:: upsend_all_g1 ,upsend_all_gh + procedure:: downsend_all_g2 ,downsend_all_gh + procedure:: boco_2d_g1,boco_2d_gh + procedure:: boco_3d_g1,boco_3d_gh + procedure :: bocoT_2d_g1,bocoT_2d_gh + procedure :: bocoTx_2d_g1,bocoTx_2d_gh + procedure :: bocoTy_2d_g1,bocoTy_2d_gh + procedure :: bocoT_3d_g1,bocoT_3d_gh + procedure :: bocox_2d_g1,bocox_2d_gh + procedure :: bocoy_2d_g1,bocoy_2d_gh +!cltfrom mg_generation + procedure:: upsending_all,downsending_all,weighting_all, & + upsending,downsending,upsending2,downsending2, & + weighting_helm,weighting ,adjoint,direct1, & + adjoint2,direct2 +!clt mg_filtering + procedure ::sup_vrbeta1T,sup_vrbeta1,sup_vrbeta3T,sup_vrbeta3 + + procedure:: mg_filtering_rad1,mg_filtering_rad2,mg_filtering_rad3,& + mg_filtering_lin1,mg_filtering_lin2,mg_filtering_lin3, & + mg_filtering_fast +!clt from mg_transfer.f90 + procedure:: composite_to_stack,stack_to_composite +!clt from mg_entrymod + procedure :: mg_initialize + procedure ::mg_finalize + procedure :: anal_to_filt_all,mg_filtering_procedure,filt_to_anal_all +end type mg_intstate_type + interface + module subroutine lsqr_mg_coef(this) + import mg_intstate_type + class(mg_intstate_type),target::this + end subroutine + module subroutine lwq_vertical_coef & +(this,nm_in,im_in,c1,c2,c3,c4,iref_out) + import mg_intstate_type +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) + import mg_intstate_type +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) + import mg_intstate_type +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 +end interface +interface + module subroutine def_offset_coef(this) + import mg_intstate_type + class(mg_intstate_type),target::this + end subroutine +end interface + +interface + + module subroutine lsqr_direct_offset & +(this,V_in,W,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%ib:this%im+this%ib,1-this%jb:this%jm+this%jb), 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,this%j0-this%jb:this%jm+this%jb):: VX + end subroutine lsqr_direct_offset + + module subroutine lsqr_adjoint_offset & +(this,W,V_out,km_in) +!----------------------------------------------------------------------- + import mg_intstate_type + import i_kind,r_kind +implicit none +class(mg_intstate_type),target::this +integer(i_kind):: km_in +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W +real(r_kind), dimension(km_in,1-this%ib:this%im+this%ib,1-this%jb:this%jm+this%jb), intent(out):: V_out +real(r_kind), dimension(km_in,1:this%nm,this%j0-this%jb:this%jm+this%jb):: VX + end subroutine +!clt from mg_transfer.f90 + + module subroutine anal_to_filt_all(this,WORKA) + import mg_intstate_type + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km,this%n0:this%nm,this%m0:this%mm) + + end subroutine anal_to_filt_all + module subroutine filt_to_anal_all (this,WORKA) + import mg_intstate_type + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km,this%n0:this%nm,this%m0:this%mm) + + end subroutine filt_to_anal_all + module subroutine stack_to_composite(this,ARR_ALL,A2D,A3D) + import mg_intstate_type + class(mg_intstate_type),target::this +real(r_kind),dimension(this%km ,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy), intent(in):: ARR_ALL +real(r_kind),dimension(this%km3,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy,this%lm),intent(out):: A3D +real(r_kind),dimension(this%km2,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy) ,intent(out):: A2D + + + end subroutine stack_to_composite +module subroutine composite_to_stack & +!*********************************************************************** +! ! +! Transfer data from composite to stack variables ! +! ! +!*********************************************************************** +(this,A2D,A3D,ARR_ALL) +!---------------------------------------------------------------------- + import mg_intstate_type +implicit none +class(mg_intstate_type),target::this +real(r_kind),dimension(this%km2,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy), intent(in):: A2D +real(r_kind),dimension(this%km3,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy,this%lm),intent(in):: A3D +real(r_kind),dimension(this%km ,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy), intent(out):: ARR_ALL + end subroutine composite_to_stack + + end interface +!clt for mg_bocos +interface + 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 boco_2d_gh + + 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 boco_3d_g1 + + 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 boco_3d_gh + module subroutine bocoT_2d_g1 & +(this,W,km_in,im_in,jm_in,nbx,nby) +!----------------------------------------------------------------------- + import mg_intstate_type +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 bocoT_2d_g1 + module subroutine bocoT_2d_gh & +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- + + import mg_intstate_type +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 bocoT_2d_gh + + 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 bocoTx_2d_g1 + 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 bocoTx_2d_gh +!----------------------------------------------------------------------- + + 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 bocoTy_2d_g1 + + 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 bocoTy_2d_gh + + 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 bocoT_3d_g1 + 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 bocoT_3d_gh + 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 bocox_2d_gh + 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 bocox_2d_g1 + + 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 bocoy_2d_g1 + 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 bocoy_2d_gh + + + module subroutine upsend_all_g1 & +(this,Harray,Warray,km_in) +!----------------------------------------------------------------------- + import mg_intstate_type +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 upsend_all_g1 + module subroutine upsend_all_gh & +(this,Harray,Warray,km_in,mygen_dn,mygen_up) + import mg_intstate_type +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 upsend_all_gh + + 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 downsend_all_gh + 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 downsend_all_g2 + +end interface +!clt from mg_filtering +interface + module subroutine mg_filtering_procedure (this,mg_filt) + import mg_intstate_type + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: mg_filt + + end subroutine mg_filtering_procedure + module subroutine mg_filtering_rad1(this) + import mg_intstate_type + class(mg_intstate_type),target::this + end subroutine mg_filtering_rad1 + module subroutine mg_filtering_rad2(this) + import mg_intstate_type + class(mg_intstate_type),target::this + + end subroutine mg_filtering_rad2 + module subroutine mg_filtering_rad3(this) + import mg_intstate_type + class(mg_intstate_type),target::this + + end subroutine mg_filtering_rad3 + module subroutine mg_filtering_lin1(this) + import mg_intstate_type + class(mg_intstate_type),target::this + + end subroutine mg_filtering_lin1 +module subroutine mg_filtering_lin2(this) + import mg_intstate_type + class(mg_intstate_type),target::this + + end subroutine mg_filtering_lin2 +module subroutine mg_filtering_lin3(this) + import mg_intstate_type + class(mg_intstate_type),target::this + + end subroutine mg_filtering_lin3 +module subroutine mg_filtering_fast(this) + import mg_intstate_type + class(mg_intstate_type),target::this + + end subroutine mg_filtering_fast +module subroutine sup_vrbeta1 & + (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) +!---------------------------------------------------------------------- + import mg_intstate_type +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,this%i0-hx:im+hx,this%j0-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 sup_vrbeta1 +module subroutine sup_vrbeta1T & +(this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) + import mg_intstate_type + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-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 sup_vrbeta1T + module subroutine sup_vrbeta3 & + (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) + import mg_intstate_type + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(3,3,this%i0:im,this%j0:jm,1:lm), intent(in):: pasp +real(r_kind),dimension(this%i0:im,this%j0:jm,1:lm), intent(in):: ss + + + end subroutine sup_vrbeta3 + module subroutine sup_vrbeta3T & +!********************************************************************** +! * +! conversion of vrbeta3 * +! * +!********************************************************************** +(this,kmax,hx,hy,hz,im,jm,lm, pasp,ss,V) +!---------------------------------------------------------------------- + import mg_intstate_type +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,this%i0-hx:im+hx,this%j0-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(3,3,this%i0:im,this%j0:jm,1:lm), intent(in):: pasp +real(r_kind),dimension(this%i0:im,this%j0:jm,1:lm), intent(in):: ss + end subroutine sup_vrbeta3T + + + end interface +!clt from mg_generations.f90 + interface + module subroutine upsending_all & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! ! +!*********************************************************************** +(this,V,H,lquart) +!----------------------------------------------------------------------- + import mg_intstate_type +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 upsending_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module subroutine downsending_all & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V,lquart) +!----------------------------------------------------------------------- + import mg_intstate_type +implicit none +class (mg_intstate_type),target:: this + +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V +logical, intent(in):: lquart +end subroutine downsending_all + module subroutine weighting_all & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(this,V,H,lhelm) +!----------------------------------------------------------------------- + import mg_intstate_type +implicit none +class (mg_intstate_type),target:: this + +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H +logical, intent(in):: lhelm +end subroutine weighting_all + module subroutine upsending & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- + import mg_intstate_type +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,this%i0-2:this%imL+2,this%j0-2:this%jmL+2):: V_INT +real(r_kind),dimension(this%km,this%i0-2:this%imL+2,this%j0-2:this%jmL+2):: H_INT +end subroutine upsending + module subroutine downsending & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V) +!----------------------------------------------------------------------- + import mg_intstate_type +implicit none +class (mg_intstate_type),target:: this + +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V + +end subroutine downsending + module subroutine upsending2 & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- + import mg_intstate_type +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 upsending2 + + module subroutine downsending2 & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V) +!----------------------------------------------------------------------- + import mg_intstate_type +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 downsending2 +module subroutine weighting_helm & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- + import mg_intstate_type +implicit none +class (mg_intstate_type),target:: this + +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H +end subroutine weighting_helm + + + + module subroutine weighting & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- + import mg_intstate_type +implicit none +class (mg_intstate_type),target:: this + +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H +end subroutine weighting + +module subroutine adjoint & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,F,W,km_in,g) +!----------------------------------------------------------------------- + import mg_intstate_type +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,this%i0:this%im,this%j0:this%jm), intent(in):: F +real(r_kind), dimension(km_in,this%i0-2:this%imL+2,this%j0-2:this%jmL+2), intent(out):: W +end subroutine adjoint + +module subroutine direct1 & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,F,km_in,g) +!----------------------------------------------------------------------- + import mg_intstate_type +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,this%i0-2:this%imL+2,this%j0-2:this%jmL+2), intent(in):: W +real(r_kind), dimension(km_in,this%i0:this%im,this%j0:this%jm), intent(out):: F +end subroutine direct1 +module subroutine adjoint2 & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! using quadratics interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,F,W,km_in,g) +!----------------------------------------------------------------------- + import mg_intstate_type +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 adjoint2 + + module subroutine direct2 & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! using quadratic interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,F,km_in,g) +!----------------------------------------------------------------------- + import mg_intstate_type +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 direct2 + + module subroutine mg_initialize(this,inputfilename,obj_parameter) + import mg_intstate_type + import mg_parameter_type +class (mg_intstate_type):: this +character*(*),optional,intent(in) :: inputfilename +class(mg_parameter_type),optional,intent(in)::obj_parameter + end subroutine mg_initialize + module subroutine mg_finalize(this) + import mg_intstate_type +implicit none +class (mg_intstate_type)::this + end subroutine mg_finalize + + + + + end interface + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +!cltthink doublecheck subroutine allocate_mg_intstate(this,km) + subroutine allocate_mg_intstate(this) +!*********************************************************************** +! ! +! Allocate internal state variables ! +! ! +!*********************************************************************** + import mg_intstate_type +implicit none +class(mg_intstate_type),target::this + + +allocate(this%V(this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy,this%lm)) ; this%V=0. +allocate(this%VALL(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%VALL=0. +allocate(this%HALL(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%HALL=0. + + +allocate(this%a_diff_f(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%a_diff_f=0. +allocate(this%a_diff_h(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%a_diff_h=0. +allocate(this%b_diff_f(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%b_diff_f=0. +allocate(this%b_diff_h(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%b_diff_h=0. + +allocate(this%p_eps(this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%p_eps=0. +allocate(this%p_del(this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%p_del=0. +allocate(this%p_sig(this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%p_sig=0. +allocate(this%p_rho(this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%p_rho=0. + +allocate(this%paspx(1,1,this%i0:this%im)) ; this%paspx=0. +allocate(this%paspy(1,1,this%j0:this%jm)) ; this%paspy=0. + +allocate(this%pasp1(1,1,1:this%lm)) ; this%pasp1=0. +allocate(this%pasp2(2,2,this%i0:this%im,this%j0:this%jm)) ; this%pasp2=0. +allocate(this%pasp3(3,3,this%i0:this%im,this%j0:this%jm,1:this%lm)) ; this%pasp3=0. + +allocate(this%vpasp2(0:2,this%i0:this%im,this%j0:this%jm)) ; this%vpasp2=0. +allocate(this%hss2(this%i0:this%im,this%j0:this%jm,1:3)) ; this%hss2= 0. + +allocate(this%vpasp3(1:6,this%i0:this%im,this%j0:this%jm,1:this%lm)) ; this%vpasp3= 0. +allocate(this%hss3(this%i0:this%im,this%j0:this%jm,1:this%lm,1:6)) ; this%hss3= 0. + +allocate(this%ssx(this%i0:this%im)) ; this%ssx=0. +allocate(this%ssy(this%j0:this%jm)) ; this%ssy=0. +allocate(this%ss1(1:this%lm)) ; this%ss1=0. +allocate(this%ss2(this%i0:this%im,this%j0:this%jm)) ; this%ss2=0. +allocate(this%ss3(this%i0:this%im,this%j0:this%jm,1:this%lm)) ; this%ss3=0. + +allocate(this%dixs(this%i0:this%im,this%j0:this%jm,3)) ; this%dixs=0 +allocate(this%diys(this%i0:this%im,this%j0:this%jm,3)) ; this%diys=0 + +allocate(this%dixs3(this%i0:this%im,this%j0:this%jm,1:this%lm,6)) ; this%dixs3=0 +allocate(this%diys3(this%i0:this%im,this%j0:this%jm,1:this%lm,6)) ; this%diys3=0 +allocate(this%dizs3(this%i0:this%im,this%j0:this%jm,1:this%lm,6)) ; this%dizs3=0 + +allocate(this%qcols(0:7,this%i0:this%im,this%j0:this%jm,1:this%lm)) ; this%qcols=0 + +! +! In stnadalone version +! +!allocate(r_vol(km,0:nm,0:mm,2)) ; r_vol=0. +! +! ... but in global version there will be +! r_vol2 and r_vol3 for 2d and 3d variables +! and r_vol3 will need to be given vertical structure +! + +! +!cltallocate(WORKA(km,n0:nm,m0:mm)) ; WORKA=0. + +! +! for re-decomposition +! + +allocate(this%iref(this%n0:this%nm)) ; this%iref=0 +allocate(this%jref(this%m0:this%mm)) ; this%jref=0 + +allocate(this%cx0(this%n0:this%nm)) ; this%cx0=0. +allocate(this%cx1(this%n0:this%nm)) ; this%cx1=0. +allocate(this%cx2(this%n0:this%nm)) ; this%cx2=0. +allocate(this%cx3(this%n0:this%nm)) ; this%cx3=0. + +allocate(this%cy0(this%m0:this%mm)) ; this%cy0=0. +allocate(this%cy1(this%m0:this%mm)) ; this%cy1=0. +allocate(this%cy2(this%m0:this%mm)) ; this%cy2=0. +allocate(this%cy3(this%m0:this%mm)) ; this%cy3=0. + +!TEST +! call finishMPI +!TEST + +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(this%n0:this%nm,this%m0:this%mm)) ; this%cf00=0. +allocate(this%cf01(this%n0:this%nm,this%m0:this%mm)) ; this%cf01=0. +allocate(this%cf02(this%n0:this%nm,this%m0:this%mm)) ; this%cf02=0. +allocate(this%cf03(this%n0:this%nm,this%m0:this%mm)) ; this%cf03=0. +allocate(this%cf10(this%n0:this%nm,this%m0:this%mm)) ; this%cf10=0. +allocate(this%cf11(this%n0:this%nm,this%m0:this%mm)) ; this%cf11=0. +allocate(this%cf12(this%n0:this%nm,this%m0:this%mm)) ; this%cf12=0. +allocate(this%cf13(this%n0:this%nm,this%m0:this%mm)) ; this%cf13=0. +allocate(this%cf20(this%n0:this%nm,this%m0:this%mm)) ; this%cf20=0. +allocate(this%cf21(this%n0:this%nm,this%m0:this%mm)) ; this%cf21=0. +allocate(this%cf22(this%n0:this%nm,this%m0:this%mm)) ; this%cf22=0. +allocate(this%cf23(this%n0:this%nm,this%m0:this%mm)) ; this%cf23=0. +allocate(this%cf30(this%n0:this%nm,this%m0:this%mm)) ; this%cf30=0. +allocate(this%cf31(this%n0:this%nm,this%m0:this%mm)) ; this%cf31=0. +allocate(this%cf32(this%n0:this%nm,this%m0:this%mm)) ; this%cf32=0. +allocate(this%cf33(this%n0:this%nm,this%m0:this%mm)) ; this%cf33=0. + +allocate(this%Lref(1:this%lm)) ; this%Lref=0 +allocate(this%Lref_h(1:this%lm)) ; this%Lref_h=0 + +allocate(this%cvf1(1:this%lm)) ; this%cvf1=0. +allocate(this%cvf2(1:this%lm)) ; this%cvf2=0. +allocate(this%cvf3(1:this%lm)) ; this%cvf3=0. +allocate(this%cvf4(1:this%lm)) ; 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 ! + import mg_intstate_type +! ! +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 + +!-------------------------------------------------------- + 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. + +! r_vol(:,:,:,1)=1. + + + select case(this%my_hgen) + case(2) +! r_vol(:,:,:,2)=0.25 ! In standalone case +! gen_fac=0.25 + this%a_diff_h(:,:,:)=this%mg_weig2 + this%b_diff_h(:,:,:)=0. + case(3) +! r_vol(:,:,:,2)=0.0625 ! In standalone case +! gen_fac=0.0625 + this%a_diff_h(:,:,:)=this%mg_weig3 + this%b_diff_h(:,:,:)=0. + case default +! r_vol(:,:,:,2)=0.015625 ! In standalone case +! gen_fac=0.015625 + this%a_diff_h(:,:,:)=this%mg_weig4 + this%b_diff_h(:,:,:)=0. + end select + + + do L=1,this%lm + this%pasp1(1,1,L)=this%pasp01 + enddo + + do i=this%i0,this%im + this%paspx(1,1,i)=this%pasp02 + enddo + do j=this%j0,this%jm + this%paspy(1,1,j)=this%pasp02 + enddo + + do j=this%i0,this%jm + do i=this%j0,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=this%i0,this%jm + do i=this%j0,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 + + + call this%cholaspect(1,this%lm,this%pasp1) + call this%cholaspect(this%i0,this%im,this%j0,this%jm,this%pasp2) + call this%cholaspect(this%i0,this%im,this%j0,this%jm,1,this%lm,this%pasp3) + + + call this%getlinesum(this%hx,this%i0,this%im,this%paspx,this%ssx) + call this%getlinesum(this%hy,this%j0,this%jm,this%paspy,this%ssy) + call this%getlinesum(this%hz,1,this%lm,this%pasp1,this%ss1) + call this%getlinesum(this%hx,this%i0,this%im,this%hy,this%j0,this%jm,this%pasp2,this%ss2) + call this%getlinesum(this%hx,this%i0,this%im,this%hy,this%j0,this%jm,this%hz,1,this%lm,this%pasp3,this%ss3) +!----------------------------------------------------------------------- + endsubroutine def_mg_weights + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine init_mg_line(this) + import mg_intstate_type +implicit none +class(mg_intstate_type),target::this +integer(i_kind):: i,j,L,icol +logical:: ff +!*********************************************************************** +! ! +! Inititate line filters ! +! ! +!*********************************************************************** +!----------------------------------------------------------------------- + + do j=this%j0,this%jm + do i=this%i0,this%im + call t22_to_3(this%pasp2(:,:,i,j),this%vpasp2(:,i,j)) + enddo + enddo + + do l=1,this%lm + do j=this%j0,this%jm + do i=this%i0,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(this%i0,this%im,this%i0,this%jm,this%vpasp2, this%dixs,this%diys, ff) + + do icol=1,3 + this%hss2(:,:,icol)=this%vpasp2(icol-1,:,:) + enddo + + + call hextform(this%i0,this%im,this%j0,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 testing +! +!cltthink deallocate(WORKA) + +! +! for re-decomposition +! +deallocate(this%iref,this%jref) + +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%p_coef,this%q_coef) +deallocate(this%a_coef,this%b_coef) + + + + end subroutine deallocate_mg_intstate + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + end module mg_intstate diff --git a/src/saber/mgbf/mgbf_lib/type_mg_mppstuff.f90 b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 old mode 100755 new mode 100644 similarity index 78% rename from src/saber/mgbf/mgbf_lib/type_mg_mppstuff.f90 rename to src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 index 4d7ec37d5..beec75e6f --- a/src/saber/mgbf/mgbf_lib/type_mg_mppstuff.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 @@ -1,5 +1,5 @@ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_mppstuff + submodule(mg_parameter) mg_mppstuff !*********************************************************************** ! ! ! Everything related to mpi communication ! @@ -8,34 +8,20 @@ module mg_mppstuff ! Modules: kinds, mg_parameter ! ! M. Rancic (2020) ! !*********************************************************************** -use mpi use kinds, only: i_kind -use mg_parameter implicit none -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 !keep_for_now integer(i_kind):: ns,ms,ninc,minc,ninc2,minc2 -type mppstuff_type -contains -procedure,nopass :: init_mg_MPI,finishMPI,barrierMPI -end type mppstuff_type + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ contains !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine init_mg_MPI + module subroutine init_mg_MPI(this) !*********************************************************************** ! ! ! Initialize mpi ! @@ -46,19 +32,35 @@ subroutine init_mg_MPI implicit none +class (mg_parameter_type),target:: this integer(i_kind):: g,m -integer(i_kind), dimension(npes_filt):: out_ranks +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" !----------------------------------------------------------------------- -!clt mgbf4jedi - mpi_comm_comp=MPI_COMM_WORLD + +!cltorg mpi_comm_comp=MPI_COMM_WORLD !*** !*** Initial MPI calls !*** - call MPI_INIT(ierr) - call MPI_COMM_RANK(mpi_comm_comp,mype,ierr) +!cltorg call MPI_INIT(ierr) + 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 + write(6,*)'thinkdebmype is ',mype + 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 @@ -130,7 +132,7 @@ subroutine init_mg_MPI !*** Define group communicator for higher generations !*** ! -! Associate a group with communicator mpi_comm_comp +! Associate a group with communicator this@mpi_comm_comp ! call MPI_COMM_GROUP(mpi_comm_comp,group_world,ierr) ! @@ -162,7 +164,7 @@ subroutine init_mg_MPI !TEST ! write(mype+100,*) 'mype, mype_gr=',mype, mype_gr ! print *, 'mype, mype_gr=',mype, mype_gr -! call MPI_FINALIZE(mpi_comm_comp) +! call MPI_FINALIZE(this@mpi_comm_comp) ! stop !TEST @@ -176,7 +178,7 @@ subroutine init_mg_MPI endsubroutine init_mg_MPI !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine barrierMPI + module subroutine barrierMPI(this) !*********************************************************************** ! ! ! Call barrier for all ! @@ -185,7 +187,10 @@ subroutine barrierMPI use mpi implicit none -integer:: ierr + 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) @@ -194,7 +199,7 @@ subroutine barrierMPI endsubroutine barrierMPI !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine finishMPI + module subroutine finishMPI(this) !*********************************************************************** ! ! ! Finalize MPI ! @@ -203,16 +208,15 @@ subroutine finishMPI use mpi implicit none -integer:: ierr - -!----------------------------------------------------------------------- + class(mg_parameter_type),target::this +!cltthinkdeb don't need mpi_finalize if mgbf is a lib to be called from outside ! - call MPI_FINALIZE(ierr) + call MPI_FINALIZE(this%ierr) stop ! !----------------------------------------------------------------------- endsubroutine finishMPI !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - endmodule mg_mppstuff + end submodule mg_mppstuff diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 new file mode 100644 index 000000000..1f7b2f84b --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -0,0 +1,996 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_parameter +!*********************************************************************** +! ! +! Set resolution, grid and decomposition ! +! - offset version - ! +! ! +! Note: ixm(1)=nxm, jym(1)=mym ! +! ! +! 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) ! +! ! +! Modules: kinds, jp_pietc ! +! M. Rancic (2022) ! +!*********************************************************************** +!clt org use mpi +use kinds, only: i_kind,r_kind +use jp_pietc, only: u1 +!use berror, only: mg_ampl0,im_filt,jm_filt +!TEST +!use mpimod, only: nxpe,nype +!TEST + +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 +logical:: mgbf_line +integer(i_kind):: nxPE,nyPE,im_filt,jm_filt +logical:: lquart,lhelm + +!*** +!*** Number of generations +!*** +integer(i_kind):: gm + +!*** +!*** 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):: mym + +! +! 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):: lm ! number of vertical layers +integer(i_kind):: lm05 ! half of vertical levels +integer(i_kind):: km2_f ! number of 2d variables for filtering +integer(i_kind):: km3_f ! number of 3d variables for filtering +integer(i_kind):: km2_e ! number of 2d variables for ensemble +integer(i_kind):: km3_e ! number of 3d variables for ensemble +logical :: l_filt ! logical flag for filtering or enseble +!integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) +integer(i_kind):: lmf ! number of vertical levels for filtering (generation one) +integer(i_kind):: lmh ! number of vertical levels for filtering (high generations) + + + +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 +!cltmovedfrom mg_entrymod.f90 +integer(i_kind):: km,km2,km3 +!cltmoved from type_mg_mppstuff.f90 +integer(i_kind):: mype +character(len=5):: c_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 +!clt moved 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 + + +contains +procedure::init_mg_parameter +procedure:: init_mg_MPI +procedure:: finishMPI +procedure:: barrierMPI + +!clt from mg_domain +procedure:: init_mg_domain +!clt 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 + module subroutine init_mg_MPI(this) + import :: mg_parameter_type + class(mg_parameter_type),target :: this + end subroutine init_mg_MPI + module subroutine finishMPI(this) + import :: mg_parameter_type + class(mg_parameter_type),target :: this + end subroutine finishMPI + module subroutine barrierMPI(this) + import :: mg_parameter_type + class(mg_parameter_type),target :: this + end subroutine barrierMPI + module subroutine init_mg_domain(this) + import mg_parameter_type + class(mg_parameter_type)::this + end subroutine init_mg_domain + module subroutine init_domain(this) + import mg_parameter_type + class(mg_parameter_type),target::this + end subroutine init_domain + + module subroutine init_topology_2d(this) + import mg_parameter_type + class(mg_parameter_type),target::this + end subroutine init_topology_2d + module subroutine real_itarg (this,itarg) + import mg_parameter_type + class(mg_parameter_type),target::this + integer(i_kind), intent(inout):: itarg + end subroutine real_itarg + +end interface +!clt from jp_pbfil +!clt from jb_pbfile + +interface + +module subroutine cholaspect1(lx,mx, el) ! [cholaspect] +use kinds, only: dp=>r_kind +integer, intent(in ):: lx,mx +real(dp),dimension(1,1,lx:mx),intent(inout):: el +!----------------------------------------------------------------------------- +end subroutine cholaspect1 +module subroutine cholaspect2(lx,mx, ly,my, el) ! [cholaspect] +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 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 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 cholaspect3 + +module subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el) ! [cholaspect] +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 cholaspect4 +module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [getlinesum] +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 getlinesum1 + +module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum] +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 getlinesum2 +module subroutine getlinesum3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss)! [getlinesum] +!============================================================================= +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 getlinesum3 +module subroutine getlinesum4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & + el, ss) ! [getlinesum] +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 getlinesum4 + +module subroutine rbeta1(this,hx,lx,mx, el,ss, a) ! [rbeta] +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 rbeta1 + +module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] +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 rbeta2 +module subroutine rbeta3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] +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 rbeta3 +module subroutine rbeta4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a)! [rbeta] +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 rbeta4 +module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) ! [rbetat] +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 rbeta1T +module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] +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 rbeta2T +module subroutine rbeta3T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] +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 rbeta3T +module subroutine rbeta4T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & + el,ss, a) ! [rbetat] +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 rbeta4T +module subroutine vrbeta4t(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, & + hw,lw,mw, el,ss, a)! [rbetat] +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 vrbeta4t +module subroutine vrbeta1(this,nv,hx,lx,mx, el,ss, a) ! [rbeta] +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 vrbeta1 +module subroutine vrbeta2(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] +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 vrbeta2 +module subroutine vrbeta3(this,nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] +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 vrbeta3 +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 + +end subroutine vrbeta4 +module subroutine vrbeta1T(this,nv, hx,lx,mx, el,ss, a) ! [rbetat] +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 vrbeta1T +module subroutine vrbeta2T(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] +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 vrbeta2T +module subroutine vrbeta3T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] +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 vrbeta3T +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 ! number of vertical layers +integer(i_kind):: km2_f ! number of 2d variables for filtering +integer(i_kind):: km3_f ! number of 3d variables for filtering +integer(i_kind):: km2_e ! number of 2d variables for ensemble +integer(i_kind):: km3_e ! number of 3d variables for ensemble +logical :: l_filt ! logical flag for filtering or enseble +!integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) +integer(i_kind):: lmf ! number of vertical levels for filtering (generation one) +integer(i_kind):: lmh ! number of vertical levels for filtering (high generations) +! 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 +!clt include "type_parameter_locpointer.inc" +!clt include "type_parameter_point2this.inc" + + +! +! Set number of PEs in x and y directions +! + 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,lmf,lmh & + ,km2_f,km3_f,km2_e,km3_e & + ,l_filt & + ,ldelta,lquart,lhelm & + ,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) +! +!----------------------------------------------------------------- +!clt 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=lm + this%lmf=lmf + this%lmh=lmh + this%km2_f=km2_f + this%km3_f=km3_f + this%km2_e=km2_e + this%km3_e=km3_e + this%l_filt=l_filt + 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 +!clt + + + this%nxm = nxPE + this%mym = nyPE +! + this%im = im_filt + this%jm = jm_filt + +!----------------------------------------------------------------- +! +! +! For 168 PES +! +! nxm = 14 +! mym = 12 +! +! For 256 PES +! +! +! nxm = 16 +! mym = 16 +! +! For 336 PES +! +! nxm = 28 +! mym = 12 +! +! For 448 PES +! +! nxm = 28 +! mym = 16 +! +! +! For 512 PES +! +! nxm = 32 +! mym = 16 +! +! For 704 PES +! +! nxm = 32 +! mym = 22 +! +! For 768 PES +! +! nxm = 32 +! mym = 24 +! +! +! For 924 PES +! +! nxm = 28 +! mym = 33 +! +! For 1056 PES +! +! nxm = 32 +! mym = 33 +! +! For 1408 PES +! +! nxm = 32 +! mym = 44 +! +! For 1848 PES +! +! nxm = 56 +! mym = 33 +! +! For 2464 PES +! +! nxm = 56 +! mym = 44 + + +! +! Define maximum number of generations 'gm' +! + + call def_maxgen(this%nxm,this%mym,this%gm) + +! Restrict to 4 + + if(this%gm>4) then + this%gm=4 + 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 +! + +!SMALL DOMAIN +! nm0 = 1792 +! mm0 = 1056 +!SMALL DOMAIN + +!TEST +! nm0 = 384 +! mm0 = 384 +!TEST + + this%nm = this%nm0/this%nxm + this%mm = this%mm0/this%mym + +!*** +!*** 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%mym*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 mym +! + 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%mym /= this%mm0 ) then + write(17,*) 'mm,mym,mm0=',this%mm,this%mym,this%mm0 + stop 'mm0 is not divisible by mym' + 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%mym) + + + 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) +!TEST +! write(15,*)'Fimax(',g,')=',Fimax(g) +! write(15,*)'Fjmax(',g,')=',Fjmax(g) +!TEST + enddo + + do g=1,this%gm + this%FimaxL(g)=this%Fimax(g)/2 + this%FjmaxL(g)=this%Fjmax(g)/2 + enddo + + +!*** +!*** Filter related parameters +!** +!D lengthx = 6. ! arbitrary chosen scale of the domain +!D lengthy = 6. ! arbitrary chosen scale of the domain + 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 !cltthinkdeb what + 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 + +!D xa0 =0. +!D ya0 =0. + this%xa0 = this%dxa*0.5 + this%ya0 = this%dya*0.5 + +!D xf0=-dxf*0.5 +!D yf0=-dyf*0.5 + this%xf0 = this%dxf*0.5 + this%yf0 = this%dyf*0.5 + + this%imL=this%im/2 + this%jmL=this%jm/2 + +! pasp0=1 +! pasp0 = 5 ! Main +!! pasp0 = 2. + this%pasp01 = mg_ampl01 + this%pasp02 = mg_ampl02 + this%pasp03 = mg_ampl03 + + +!TEST hx=8 +!TEST hz=8 +!TEST hz=4 +!TEST hz=5 +! hx=6 +! hy=hx +! hz=6 + + this%nh= 6 + this%nfil = this%nh + 2 + +! p = 4 ! Exponent of Beta function +! p = 2 ! Exponent of Beta function + + 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) + !clt call this%init_mg_MPI + !clt call this%init_mg_domain + +!---------------------------------------------------------------------- + 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,mym,gm) +!---------------------------------------------------------------------- +implicit none +integer, intent(in):: nxm,mym +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 = mym; 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/saber/mgbf/mgbf_lib/mg_timers.f90 b/src/saber/mgbf/mgbf_lib/mg_timers.f90 new file mode 100755 index 000000000..ce9fead20 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/mg_timers.f90 @@ -0,0 +1,186 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + module mg_timers +!*********************************************************************** +! ! +! Measure cpu and wallclock timing ! +! D. Jovic (2017) ! +! Adjusted: M. Rancic (2020) ! +!*********************************************************************** + 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 :: bfiltT_tim + type(timer),save,public :: vadv1_tim + type(timer),save,public :: bfilt_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 :: 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, & + bfiltT_tim%time_clock, & + bfilt_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,10(',',F10.4))") mype, & + init_tim%time_cpu, & + an2filt_tim%time_cpu, & + upsend_tim%time_cpu, & + bfiltT_tim%time_cpu, & + weight_tim%time_cpu, & + bfilt_tim%time_cpu, & + dnsend_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,10(',',A10))") "mype", & + "init", & + "an2filt", & + "upsend", & + "bfiltT", & + "weight", & + "bfilt", & + "dnsend", & + "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 +!----------------------------------------------------------------------- + endmodule mg_timers diff --git a/src/saber/mgbf/mgbf_lib/type_mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 similarity index 63% rename from src/saber/mgbf/mgbf_lib/type_mg_transfer.f90 rename to src/saber/mgbf/mgbf_lib/mg_transfer.f90 index 910126130..d2e7bc239 100644 --- a/src/saber/mgbf/mgbf_lib/type_mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -1,5 +1,5 @@ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_transfer + submodule(mg_intstate) mg_transfer !*********************************************************************** ! ! ! Transfer data between analysis and filter grid ! @@ -10,43 +10,31 @@ module mg_transfer !*********************************************************************** use mpi use kinds, only: r_kind,i_kind -use mg_parameter -use mg_intstate, only: VALL,WORKA -use mg_mppstuff, only: mype,ierror,mpi_comm_world -use mg_mppstuff, only: nx,my,mpi_comm_comp +!TEST +!use mg_output, only: output_spec1_2dd +!TEST -implicit none - -integer(i_kind):: n,m,l,k,i,j - -public anal_to_filt_all -public filt_to_anal_all - -public stack_to_composite -public composite_to_stack -public -type mg_transfer_type - contains - procedure,nopass :: anal_to_filt_all - procedure,nopass :: filt_to_anal_all -end type mg_transfer_type !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ contains !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine anal_to_filt_all + module subroutine anal_to_filt_all(this,WORKA) !*********************************************************************** ! ! ! Transfer data from analysis to first generaton of filter grid ! ! ! !*********************************************************************** -use mg_interpolate, only: lsqr_adjoint_offset -use mg_bocos, only: bocoT_2d implicit none +class(mg_intstate_type),target::this +real (r_kind):: WORKA(this%km,this%n0:this%nm,this%m0:this%mm) real(r_kind),allocatable,dimension(:,:,:):: VLOC +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" !---------------------------------------------------------------------- @@ -56,7 +44,7 @@ subroutine anal_to_filt_all !T call btim( aintp_tim) VLOC=0. - call lsqr_adjoint_offset(WORKA,VLOC,km) + call this%lsqr_adjoint_offset(WORKA,VLOC,km) !T call etim( aintp_tim) @@ -67,7 +55,7 @@ subroutine anal_to_filt_all !*** - call bocoT_2d(VLOC,km,im,jm,ib,jb) + call this%bocoT_2d(VLOC,km,im,jm,ib,jb) VALL=0. VALL(1:km,i0:im,j0:jm)=VLOC(1:km,i0:im,j0:jm) @@ -81,19 +69,25 @@ subroutine anal_to_filt_all endsubroutine anal_to_filt_all !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine filt_to_anal_all + module subroutine filt_to_anal_all(this,WORKA) !*********************************************************************** ! ! ! Transfer data from filter to analysis grid ! ! ! !*********************************************************************** -use mg_interpolate, only: lsqr_direct_offset -use mg_bocos, only: boco_2d implicit none +class(mg_intstate_type),target::this +real (r_kind):: WORKA(this%km,this%n0:this%nm,this%m0:this%mm) real(r_kind),allocatable,dimension(:,:,:):: VLOC - +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!TEST +!real(r_kind), allocatable, dimension(:,:):: PA +!TEST !---------------------------------------------------------------------- @@ -112,17 +106,26 @@ subroutine filt_to_anal_all !*** !*** Supply boundary conditions for VLOC !*** - call boco_2d(VLOC,km,im,jm,ib,jb) + call this%boco_2d(VLOC,km,im,jm,ib,jb) !*** !*** Interpolate to analysis grid composite variables !*** +!TEST +! allocate(PA(1:im,1:jm)) +! +! PA(1:im,1:jm)=VLOC(3*lm+lm/2,1:im,1:jm) +! +! call output_spec1_2dd(PA,im,jm) +! +! call finishMPI +!TEST !T call btim( intp_tim) - call lsqr_direct_offset(VLOC,WORKA,km) + call this%lsqr_direct_offset(VLOC,WORKA,this%km) !cltthink !T call etim( intp_tim) deallocate(VLOC) @@ -135,78 +138,79 @@ subroutine filt_to_anal_all !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine stack_to_composite & + module subroutine stack_to_composite & !*********************************************************************** ! ! ! Transfer data from stack to composite variables ! ! ! !*********************************************************************** -(ARR_ALL,A2D,A3D) +(this,ARR_ALL,A2D,A3D) !---------------------------------------------------------------------- implicit none -real(r_kind),dimension(km ,i0-hx:im+hx,j0-hy:jm+hy), intent(in):: ARR_ALL -real(r_kind),dimension(km3,i0-hx:im+hx,j0-hy:jm+hy,lm),intent(out):: A3D -real(r_kind),dimension(km2,i0-hx:im+hx,j0-hy:jm+hy) ,intent(out):: A2D +class(mg_intstate_type),target::this +real(r_kind),dimension(this%km ,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy), intent(in):: ARR_ALL +real(r_kind),dimension(this%km3,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy,this%lm),intent(out):: A3D +real(r_kind),dimension(this%km2,this%i0-this%hx:this%im+this%hx,this%j0-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=j0-hy,jm+hy do i=i0-hx,im+hx - A3D(1,i,j,L)=ARR_ALL( L,i,j) - A3D(2,i,j,L)=ARR_ALL( lm+L,i,j) - A3D(3,i,j,L)=ARR_ALL(2*lm+L,i,j) - A3D(4,i,j,L)=ARR_ALL(3*lm+L,i,j) - A3D(5,i,j,L)=ARR_ALL(4*lm+L,i,j) - A3D(6,i,j,L)=ARR_ALL(5*lm+L,i,j) + do k=1,km3 + A3D(k,i,j,L)=ARR_ALL( (k-1)*lm+L,i,j ) + enddo enddo enddo enddo - - A2D(1,:,:)=ARR_ALL(6*lm+1,:,:) - A2D(2,:,:)=ARR_ALL(6*lm+2,:,:) - A2D(3,:,:)=ARR_ALL(6*lm+3,:,:) - A2D(4,:,:)=ARR_ALL(6*lm+4,:,:) + do k=1,km2 + A2D(k,:,:)=ARR_ALL(km3*lm+k,:,:) + enddo !---------------------------------------------------------------------- endsubroutine stack_to_composite !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine composite_to_stack & + module subroutine composite_to_stack & !*********************************************************************** ! ! ! Transfer data from composite to stack variables ! ! ! !*********************************************************************** -(A2D,A3D,ARR_ALL) +(this,A2D,A3D,ARR_ALL) !---------------------------------------------------------------------- implicit none -real(r_kind),dimension(km2,i0-hx:im+hx,j0-hy:jm+hy), intent(in):: A2D -real(r_kind),dimension(km3,i0-hx:im+hx,j0-hy:jm+hy,lm),intent(in):: A3D -real(r_kind),dimension(km ,i0-hx:im+hx,j0-hy:jm+hy), intent(out):: ARR_ALL -integer(i_kind):: i,j,L +class(mg_intstate_type),target::this +real(r_kind),dimension(this%km2,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy), intent(in):: A2D +real(r_kind),dimension(this%km3,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy,this%lm),intent(in):: A3D +real(r_kind),dimension(this%km ,this%i0-this%hx:this%im+this%hx,this%j0-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=j0-hy,jm+hy do i=i0-hx,im+hx - ARR_ALL( L,i,j)= A3D(1,i,j,L) - ARR_ALL( lm+L,i,j)= A3D(2,i,j,L) - ARR_ALL(2*lm+L,i,j)= A3D(3,i,j,L) - ARR_ALL(3*lm+L,i,j)= A3D(4,i,j,L) - ARR_ALL(4*lm+L,i,j)= A3D(5,i,j,L) - ARR_ALL(5*lm+L,i,j)= A3D(6,i,j,L) + do k=1,km3 + ARR_ALL( (k-1)*lm+L,i,j )=A3D(k,i,j,L) + enddo enddo enddo enddo - - ARR_ALL(6*lm+1,:,:)= A2D(1,:,:) - ARR_ALL(6*lm+2,:,:)= A2D(2,:,:) - ARR_ALL(6*lm+3,:,:)= A2D(3,:,:) - ARR_ALL(6*lm+4,:,:)= A2D(4,:,:) + do k=1,km2 + ARR_ALL(km3*lm+k,:,:)=A2D(k,:,:) + enddo !---------------------------------------------------------------------- endsubroutine composite_to_stack !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - endmodule mg_transfer + end submodule mg_transfer diff --git a/src/saber/mgbf/mgbf_lib/type_intstat_locpointer.inc b/src/saber/mgbf/mgbf_lib/type_intstat_locpointer.inc new file mode 100644 index 000000000..b73455583 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_intstat_locpointer.inc @@ -0,0 +1,79 @@ +!clt for treatment of variables from type_mg_intstate.f90 +real(r_kind), dimension(:,:,:),pointer:: V +! +! Composite control variable on first generation o filter grid +! +real(r_kind), dimension(:,:,:),pointer:: VALL +real(r_kind), dimension(:,:,:),pointer:: HALL +! +! Composite control variable on high generations of filter grid +! +! +!FOR ADJOINT TEST +! +!real(r_kind), dimension(:,:),pointer:: A +!real(r_kind), dimension(:,:),pointer:: B +!real(r_kind), dimension(:,:),pointer:: A0 +!real(r_kind), dimension(:,:),pointer:: B0 +! +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 + +!real(r_kind), dimension(:,:,:,:),pointer:: r_vol +! +! +! Composite stacked variable +! + +!clt real(r_kind), dimension(:,:,:),pointer:: WORKA + + +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/saber/mgbf/mgbf_lib/type_intstat_point2this.inc b/src/saber/mgbf/mgbf_lib/type_intstat_point2this.inc new file mode 100644 index 000000000..c6c14fac8 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_intstat_point2this.inc @@ -0,0 +1,87 @@ +!clt from type_instate_locpoint.inc +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 + +!clt WORKA=>this%WORKA + + +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/saber/mgbf/mgbf_lib/type_mg_entrymod.f90 b/src/saber/mgbf/mgbf_lib/type_mg_entrymod.f90 deleted file mode 100644 index 7ec145628..000000000 --- a/src/saber/mgbf/mgbf_lib/type_mg_entrymod.f90 +++ /dev/null @@ -1,180 +0,0 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_entrymod -!*********************************************************************** -! ! -! Initialize and finialize multigrid Beta filter for modeling of ! -! background error covariance ! -! M. Rancic (2020) ! -!*********************************************************************** -use mpi -use kinds, only: r_kind,i_kind -use mg_parameter -!use mpimod, only: mype -use mg_mppstuff, only: mype -use mg_mppstuff, only: init_mg_MPI,finishMPI,barrierMPI -use mg_domain, only: init_mg_domain -use mg_intstate, only: allocate_mg_intstate,def_mg_weights & - ,init_mg_line & - ,deallocate_mg_intstate & - ,cvf1,cvf2,cvf3,cvf4,lref & - ,cvh1,cvh2,cvh3,cvh4,lref_h & - ,WORKA -use mg_interpolate,only: lsqr_mg_coef,lwq_vertical_coef,def_offset_coef -#if 0 -use mg_input, only: input_2d,input_3d,input_spec1_2d -use mg_output, only: output_spec1_2d,output_vertical_2d -#endif -implicit none -public -type mg_entrymod_type -contains - procedure,nopass :: mg_initialize - procedure,nopass :: mg_finalize -end type mg_entrymod_type - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - contains -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine mg_initialize -!**********************************************************************! -! ! -! Initialization subroutine ! -! M. Rancic (2020) ! -!*********************************************************************** -!use mg_parameter, only: nm,mm - -real(r_kind), allocatable, dimension(:,:):: PA - -!**** -!**** Initialize run multigrid Beta filter parameters -!**** -#if 0 - call mg_parameter_type%init_mg_parameter -#endif - -!**** -!**** Initialize MPI -!**** - - call init_mg_MPI - -!*** -!*** Initialize integration domain -!*** - - call init_mg_domain - -!*** -!*** Allocate variables, define weights, prepare mapping -!*** between analysis and filter grid -!*** - - call allocate_mg_intstate - - call def_mg_weights - - if(mgbf_line) then - call init_mg_line - endif - - call lsqr_mg_coef - call def_offset_coef - call lwq_vertical_coef(lm ,lmf,cvf1,cvf2,cvf3,cvf4,lref) - call lwq_vertical_coef(lmf,lmh,cvh1,cvh2,cvh3,cvh4,lref_h) - -!*** -!*** Just for testing of standalone version. In GSI WORKA will be given -!*** through a separate subroutine -!*** -!clt -#if 0 - 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) - -if(ldelta) then - -allocate(PA(0:nm,0:mm)) - - PA = 0. - call input_spec1_2d(PA,nxm/2,mym/2,'md') - - WORKA(3*lm+1:4*lm,:,:)=0. - WORKA(3*lm+lm/2,:,:)=PA(:,:) - - -deallocate(PA) - -endif -#endif - -!----------------------------------------------------------------------- - endsubroutine mg_initialize - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine mg_finalize -!**********************************************************************! -! ! -! Finalize multigrid Beta Function ! -! M. Rancic (2020) ! -!*********************************************************************** -use mg_parameter, only: nm,mm - -real(r_kind), allocatable, dimension(:,:):: PA, VA -integer(i_kind):: n,m,L -!----------------------------------------------------------------------- - -if(ldelta) then - -! -! Horizontal cross-section -! - -allocate(PA(0:nm,0:mm)) - - PA(:,:)=WORKA(3*lm+lm/2,:,:) -#if 0 - call output_spec1_2d(PA) -#endif - -deallocate(PA) - -! -! Vertical cross-section -! - -allocate(VA(0:nm,1:lm)) - - - do l=1,lm - do n=0,nm - VA(n,l)=WORKA(3*lm+l,n,mm/2) - enddo - enddo -#if 0 - call output_vertical_2d(VA,4) -#endif - -deallocate(VA) - -endif - - call barrierMPI - - - call deallocate_mg_intstate - -!----------------------------------------------------------------------- - endsubroutine mg_finalize -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - endmodule mg_entrymod diff --git a/src/saber/mgbf/mgbf_lib/type_mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/type_mg_intstate.f90 deleted file mode 100755 index f5b6b1c40..000000000 --- a/src/saber/mgbf/mgbf_lib/type_mg_intstate.f90 +++ /dev/null @@ -1,437 +0,0 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_intstate -!*********************************************************************** -! ! -! Contains declarations and allocations of internal state variables ! -! use for filtering ! -! - offset version - ! -! ! -! M. Rancic (2020) ! -!*********************************************************************** -use mpi -use kinds, only: r_kind,i_kind -use jp_pkind2, only: fpi -!GSI use mpimod, only: mype -use mg_mppstuff, only: mype -use mg_parameter, only: n0,m0,i0,j0 -use mg_parameter, only: im,jm,nh,hx,hy,pasp01,pasp02,pasp03 -use mg_parameter, only: lm,hz,p,km,km2,km3,km,nm,mm,ib,jb,nb,mb -use mg_parameter, only: lmf,lmh,kmf,kmh -!GSI use berror, only: mg_weig1,mg_weig2,mg_weig3,mg_weig4 -use mg_parameter, only: mg_weig1,mg_weig2,mg_weig3,mg_weig4 -use mg_mppstuff, only: my_hgen,finishMPI,barrierMPI -use jp_pbfil,only: cholaspect -use jp_pbfil,only: getlinesum -use jp_pbfil3, only: inimomtab,t22_to_3,tritform,t33_to_6,hextform -!TEST -!use gridmod, only: lat1,lon1 -!TEST -implicit none -public WORKA -type mg_intstate_type -contains -procedure,nopass :: allocate_mg_intstate, def_mg_weights , init_mg_line, deallocate_mg_intstate -end type mg_intstate_type - - -real(r_kind), allocatable,dimension(:,:,:):: V -! -! Composite control variable on first generation o filter grid -! -real(r_kind), allocatable,dimension(:,:,:):: VALL -real(r_kind), allocatable,dimension(:,:,:):: HALL -! -! Composite control variable on high generations of filter grid -! -! -!FOR ADJOINT TEST -! -!real(r_kind), allocatable,dimension(:,:):: A -!real(r_kind), allocatable,dimension(:,:):: B -!real(r_kind), allocatable,dimension(:,:):: A0 -!real(r_kind), allocatable,dimension(:,:):: B0 -! -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 - -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 - -!real(r_kind), allocatable,dimension(:,:,:,:):: r_vol -! -! -! Composite stacked variable -! - -real(r_kind), allocatable,dimension(:,:,:):: WORKA - - -integer(i_kind),allocatable,dimension(:):: iref,jref -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(:):: 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 -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine allocate_mg_intstate -!*********************************************************************** -implicit none -! ! -! Allocate internal state variables ! -! ! -!*********************************************************************** - -allocate(V(i0-hx:im+hx,j0-hy:jm+hy,lm)) ; V=0. -allocate(VALL(kmf,i0-hx:im+hx,j0-hy:jm+hy)) ; VALL=0. -allocate(HALL(kmh,i0-hx:im+hx,j0-hy:jm+hy)) ; HALL=0. - - -allocate(a_diff_f(kmf,i0-hx:im+hx,j0-hy:jm+hy)) ; a_diff_f=0. -allocate(a_diff_h(kmh,i0-hx:im+hx,j0-hy:jm+hy)) ; a_diff_h=0. -allocate(b_diff_f(kmf,i0-hx:im+hx,j0-hy:jm+hy)) ; b_diff_f=0. -allocate(b_diff_h(kmf,i0-hx:im+hx,j0-hy:jm+hy)) ; b_diff_h=0. - -allocate(p_eps(i0-hx:im+hx,j0-hy:jm+hy)) ; p_eps=0. -allocate(p_del(i0-hx:im+hx,j0-hy:jm+hy)) ; p_del=0. -allocate(p_sig(i0-hx:im+hx,j0-hy:jm+hy)) ; p_sig=0. -allocate(p_rho(i0-hx:im+hx,j0-hy:jm+hy)) ; p_rho=0. - -allocate(paspx(1,1,i0:im)) ; paspx=0. -allocate(paspy(1,1,j0:jm)) ; paspy=0. - -allocate(pasp1(1,1,1:lm)) ; pasp1=0. -allocate(pasp2(2,2,i0:im,j0:jm)) ; pasp2=0. -allocate(pasp3(3,3,i0:im,j0:jm,1:lm)) ; pasp3=0. - -allocate(vpasp2(0:2,i0:im,j0:jm)) ; vpasp2=0. -allocate(hss2(i0:im,j0:jm,1:3)) ; hss2= 0. - -allocate(vpasp3(1:6,i0:im,j0:jm,1:lm)) ; vpasp3= 0. -allocate(hss3(i0:im,j0:jm,1:lm,1:6)) ; hss3= 0. - -allocate(ssx(i0:im)) ; ssx=0. -allocate(ssy(j0:jm)) ; ssy=0. -allocate(ss1(1:lm)) ; ss1=0. -allocate(ss2(i0:im,j0:jm)) ; ss2=0. -allocate(ss3(i0:im,j0:jm,1:lm)) ; ss3=0. - -allocate(dixs(i0:im,j0:jm,3)) ; dixs=0 -allocate(diys(i0:im,j0:jm,3)) ; diys=0 - -allocate(dixs3(i0:im,j0:jm,1:lm,6)) ; dixs3=0 -allocate(diys3(i0:im,j0:jm,1:lm,6)) ; diys3=0 -allocate(dizs3(i0:im,j0:jm,1:lm,6)) ; dizs3=0 - -allocate(qcols(0:7,i0:im,j0:jm,1:lm)) ; qcols=0 - -! -! In stnadalone version -! -!allocate(r_vol(km,0:nm,0:mm,2)) ; r_vol=0. -! -! ... but in global version there will be -! r_vol2 and r_vol3 for 2d and 3d variables -! and r_vol3 will need to be given vertical structure -! - -! -allocate(WORKA(km,n0:nm,m0:mm)) ; WORKA=0. - -! -! for re-decomposition -! - -allocate(iref(n0:nm)) ; iref=0 -allocate(jref(m0:mm)) ; jref=0 - -allocate(cx0(n0:nm)) ; cx0=0. -allocate(cx1(n0:nm)) ; cx1=0. -allocate(cx2(n0:nm)) ; cx2=0. -allocate(cx3(n0:nm)) ; cx3=0. - -allocate(cy0(m0:mm)) ; cy0=0. -allocate(cy1(m0:mm)) ; cy1=0. -allocate(cy2(m0:mm)) ; cy2=0. -allocate(cy3(m0:mm)) ; cy3=0. - -allocate(p_coef(4)) ; p_coef=0. -allocate(q_coef(4)) ; q_coef=0. - -allocate(a_coef(3)) ; a_coef=0. -allocate(b_coef(3)) ; b_coef=0. - - -allocate(cf00(n0:nm,m0:mm)) ; cf00=0. -allocate(cf01(n0:nm,m0:mm)) ; cf01=0. -allocate(cf02(n0:nm,m0:mm)) ; cf02=0. -allocate(cf03(n0:nm,m0:mm)) ; cf03=0. -allocate(cf10(n0:nm,m0:mm)) ; cf10=0. -allocate(cf11(n0:nm,m0:mm)) ; cf11=0. -allocate(cf12(n0:nm,m0:mm)) ; cf12=0. -allocate(cf13(n0:nm,m0:mm)) ; cf13=0. -allocate(cf20(n0:nm,m0:mm)) ; cf20=0. -allocate(cf21(n0:nm,m0:mm)) ; cf21=0. -allocate(cf22(n0:nm,m0:mm)) ; cf22=0. -allocate(cf23(n0:nm,m0:mm)) ; cf23=0. -allocate(cf30(n0:nm,m0:mm)) ; cf30=0. -allocate(cf31(n0:nm,m0:mm)) ; cf31=0. -allocate(cf32(n0:nm,m0:mm)) ; cf32=0. -allocate(cf33(n0:nm,m0:mm)) ; cf33=0. - -allocate(Lref(1:lm)) ; Lref=0 -allocate(Lref_h(1:lmf)) ; Lref_h=0 - -allocate(cvf1(1:lm)) ; cvf1=0. -allocate(cvf2(1:lm)) ; cvf2=0. -allocate(cvf3(1:lm)) ; cvf3=0. -allocate(cvf4(1:lm)) ; cvf4=0. - -allocate(cvh1(1:lmf)) ; cvh1=0. -allocate(cvh2(1:lmf)) ; cvh2=0. -allocate(cvh3(1:lmf)) ; cvh3=0. -allocate(cvh4(1:lmf)) ; cvh4=0. - - -!----------------------------------------------------------------------- - endsubroutine allocate_mg_intstate - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine def_mg_weights -!*********************************************************************** -! ! -! Define weights and scales ! -! ! -!*********************************************************************** -implicit none -integer(i_kind):: i,j,L -real(r_kind):: gen_fac -!----------------------------------------------------------------------- - - p_eps(:,:)=0.0 - p_del(:,:)=0.0 - p_sig(:,:)=0.0 - p_rho(:,:)=0.0 - -!-------------------------------------------------------- - gen_fac=1. - a_diff_f(:,:,:)=mg_weig1 - a_diff_h(:,:,:)=mg_weig1 - - b_diff_f(:,:,:)=0. - b_diff_h(:,:,:)=0. - -! r_vol(:,:,:,1)=1. - - - select case(my_hgen) - case(2) -! r_vol(:,:,:,2)=0.25 ! In standalone case -! gen_fac=0.25 - a_diff_h(:,:,:)=mg_weig2 - b_diff_h(:,:,:)=0. - case(3) -! r_vol(:,:,:,2)=0.0625 ! In standalone case -! gen_fac=0.0625 - a_diff_h(:,:,:)=mg_weig3 - b_diff_h(:,:,:)=0. - case default -! r_vol(:,:,:,2)=0.015625 ! In standalone case -! gen_fac=0.015625 - a_diff_h(:,:,:)=mg_weig4 - b_diff_h(:,:,:)=0. - end select - - - do L=1,lm - pasp1(1,1,L)=pasp01 - enddo - - do i=i0,im - paspx(1,1,i)=pasp02 - enddo - do j=j0,jm - paspy(1,1,j)=pasp02 - enddo - - do j=i0,jm - do i=j0,im - pasp2(1,1,i,j)=pasp02*(1.+p_del(i,j)) - pasp2(2,2,i,j)=pasp02*(1.-p_del(i,j)) - pasp2(1,2,i,j)=pasp02*p_eps(i,j) - pasp2(2,1,i,j)=pasp02*p_eps(i,j) - end do - end do - - do L=1,lm - do j=i0,jm - do i=j0,im - pasp3(1,1,i,j,l)=pasp03*(1+p_del(i,j)) - pasp3(2,2,i,j,l)=pasp03 - pasp3(3,3,i,j,l)=pasp03*(1-p_del(i,j)) - pasp3(1,2,i,j,l)=pasp03*p_eps(i,j) - pasp3(2,1,i,j,l)=pasp03*p_eps(i,j) - pasp3(2,3,i,j,l)=pasp03*p_sig(i,j) - pasp3(3,2,i,j,l)=pasp03*p_sig(i,j) - pasp3(1,3,i,j,l)=pasp03*p_rho(i,j) - pasp3(3,1,i,j,l)=pasp03*p_rho(i,j) - end do - end do - end do - - - call cholaspect(1,lm,pasp1) - call cholaspect(i0,im,j0,jm,pasp2) - call cholaspect(i0,im,j0,jm,1,lm,pasp3) - - - call getlinesum(hx,i0,im,paspx,ssx) - call getlinesum(hy,j0,jm,paspy,ssy) - call getlinesum(hz,1,lm,pasp1,ss1) - call getlinesum(hx,i0,im,hy,j0,jm,pasp2,ss2) - call getlinesum(hx,i0,im,hy,j0,jm,hz,1,lm,pasp3,ss3) -!----------------------------------------------------------------------- - endsubroutine def_mg_weights - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine init_mg_line -!*********************************************************************** -! ! -! Inititate line filters ! -implicit none -! ! -!*********************************************************************** -integer(i_kind):: i,j,L,icol -logical:: ff -!----------------------------------------------------------------------- - - do j=j0,jm - do i=i0,im - call t22_to_3(pasp2(:,:,i,j),vpasp2(:,i,j)) - enddo - enddo - - do l=1,lm - do j=j0,jm - do i=i0,im - call t33_to_6(pasp3(:,:,i,j,l),vpasp3(:,i,j,l)) - enddo - enddo - enddo - - - - call inimomtab(p,nh,ff) - - call tritform(i0,im,i0,jm,vpasp2, dixs,diys, ff) - - do icol=1,3 - hss2(:,:,icol)=vpasp2(icol-1,:,:) - enddo - - - call hextform(i0,im,j0,jm,1,lm,vpasp3,qcols,dixs3,diys3,dizs3, ff) - - - do icol=1,6 - hss3(:,:,:,icol)=vpasp3(icol,:,:,:) - enddo - - -!----------------------------------------------------------------------- - endsubroutine init_mg_line - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine deallocate_mg_intstate -!*********************************************************************** -! ! -! Deallocate internal state variables ! -! ! -!*********************************************************************** - -implicit none -deallocate(V) - -deallocate(HALL,VALL) - -deallocate(a_diff_f,b_diff_f) -deallocate(a_diff_h,b_diff_h) -deallocate(p_eps,p_del,p_sig,p_rho,pasp1,pasp2,pasp3,ss1,ss2,ss3) -deallocate(dixs,diys) -deallocate(dixs3,diys3,dizs3) -deallocate(qcols) -! -! for testing -! -deallocate(WORKA) - -! -! for re-decomposition -! -deallocate(iref,jref) - -deallocate(cf00,cf01,cf02,cf03,cf10,cf11,cf12,cf13) -deallocate(cf20,cf21,cf22,cf23,cf30,cf31,cf32,cf33) - -deallocate(Lref,Lref_h) - -deallocate(cvf1,cvf2,cvf3,cvf4) - -deallocate(cvh1,cvh2,cvh3,cvh4) - -deallocate(cx0,cx1,cx2,cx3) -deallocate(cy0,cy1,cy2,cy3) - -deallocate(p_coef,q_coef) -deallocate(a_coef,b_coef) - - - - endsubroutine deallocate_mg_intstate - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - endmodule mg_intstate diff --git a/src/saber/mgbf/mgbf_lib/type_mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/type_mg_parameter.f90 deleted file mode 100755 index b967a45e1..000000000 --- a/src/saber/mgbf/mgbf_lib/type_mg_parameter.f90 +++ /dev/null @@ -1,610 +0,0 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_parameter -!*********************************************************************** -! ! -! Set resolution, grid and decomposition ! -! - offset version - ! -! ! -! Note: ixm(1)=nxm, jym(1)=mym ! -! ! -! If mod(nxm,2)=0 then mod(im0,4)=0 ! -! If mod(mym,2)>0 then mod(im0,8)=0 ! -! ! -! Modules: kinds, jp_pietc ! -! M. Rancic (2022) ! -!*********************************************************************** -use mpi -use kinds, only: i_kind,r_kind -use jp_pietc, only: u1 -!use berror, only: mg_ampl0,im_filt,jm_filt -!TEST -!use mpimod, only: nxpe,nype -!TEST - -implicit none -#if 0 -xxx -type mg_parameter_type -#endif -!----------------------------------------------------------------------- -!*** -!*** 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 -logical:: mgbf_line -integer(i_kind):: nxPE,nyPE,im_filt,jm_filt -logical:: lquart - -!*** -!*** Number of generations -!*** -integer(i_kind):: gm - -!*** -!*** 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):: mym - -! -! 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):: lm ! number of vertical layers -integer(i_kind):: lm05 ! half of vertical levels -integer(i_kind):: km3 ! number of 3d variables -integer(i_kind):: km2 ! number of 2d variables -integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) -integer(i_kind):: lm_all ! vertically stacked all variables (lm_all=km - for now) - -integer(i_kind):: lmf ! number of vertical levels for filtering (generation one) -integer(i_kind):: lmh ! number of vertical levels for filtering (high generations) -integer(i_kind):: lmf_all ! number of vertically stacked variables (generation one) -integer(i_kind):: lmh_all ! number of vertically stacked high generations variabes -integer(i_kind):: kmf ! number of vertically stacked variables (generation one) -integer(i_kind):: kmh ! number of vertically stacked high generations variabes - - -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 -#if 1 -type mg_parameter_type -#endif -contains -procedure,nopass :: init =>init_mg_parameter -end type mg_parameter_type -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - contains -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine init_mg_parameter() -!**********************************************************************! -! ! -! Initialize .... ! -! ! -!**********************************************************************! -integer(i_kind):: g - -! -! Set number of PEs in x and y directions -! - 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 & - ,nxPE,nyPE,im_filt,jm_filt & - ,nm0,mm0 & - ,lm,lmf,lmh & - ,ldelta,lquart -! - open(unit=10,file='mgbeta.nml',status='old',action='read') - read(10,nml=parameters_mgbeta) - close(unit=10) -! -!----------------------------------------------------------------- - - nxm = nxPE - mym = nyPE -! - im = im_filt - jm = jm_filt - -!----------------------------------------------------------------- -! -! -! For 168 PES -! -! nxm = 14 -! mym = 12 -! -! For 256 PES -! -! -! nxm = 16 -! mym = 16 -! -! For 336 PES -! -! nxm = 28 -! mym = 12 -! -! For 448 PES -! -! nxm = 28 -! mym = 16 -! -! -! For 512 PES -! -! nxm = 32 -! mym = 16 -! -! For 704 PES -! -! nxm = 32 -! mym = 22 -! -! For 768 PES -! -! nxm = 32 -! mym = 24 -! -! -! For 924 PES -! -! nxm = 28 -! mym = 33 -! -! For 1056 PES -! -! nxm = 32 -! mym = 33 -! -! For 1408 PES -! -! nxm = 32 -! mym = 44 -! -! For 1848 PES -! -! nxm = 56 -! mym = 33 -! -! For 2464 PES -! -! nxm = 56 -! mym = 44 - - -! -! Define maximum number of generations 'gm' -! - - call def_maxgen(nxm,mym,gm) - -! Restrict to 4 - - if(gm>4) then - gm=4 - endif -! - -!*** -!*** Analysis grid -!*** - -! -! Number of grid intervals on GSI grid for the reduced RTMA domain -! before padding -! -!clt needed jedi input - nA_max0 = 1792 - mA_max0 = 1056 - - -! -! Number of grid points on the analysis grid after padding -! - -!SMALL DOMAIN -! nm0 = 1792 -! mm0 = 1056 -!SMALL DOMAIN - -!TEST -! nm0 = 384 -! mm0 = 384 -!TEST - - nm = nm0/nxm - mm = mm0/mym - -!*** -!*** 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 - - im00 = nxm*im - jm00 = mym*jm - - n0 = 0 ! For now - m0 = 0 ! For now - - i0 = 1 - j0 = 1 - -! -! Make sure that nm0 and mm0 and divisibvle with nxm and mym -! - if(nm*nxm /= nm0 ) then - write(17,*) 'nm,nxm,nm0=',nm,nxm,nm0 - stop 'nm0 is not divisible by nxm' - endif - - if(mm*mym /= mm0 ) then - write(17,*) 'mm,mym,mm0=',mm,mym,mm0 - stop 'mm0 is not divisible by mym' - endif - -! -! Set number of processors at higher generations -! - - allocate(ixm(gm)) - allocate(jym(gm)) - allocate(nxy(gm)) - allocate(maxpe_fgen(0:gm)) - allocate(im0(gm)) - allocate(jm0(gm)) - allocate(Fimax(gm)) - allocate(Fjmax(gm)) - allocate(FimaxL(gm)) - allocate(FjmaxL(gm)) - - call def_ngens(ixm,gm,nxm) - call def_ngens(jym,gm,mym) - - - do g=1,gm - nxy(g)=ixm(g)*jym(g) - enddo - - maxpe_fgen(0)= 0 - do g=1,gm - maxpe_fgen(g)=maxpe_fgen(g-1)+nxy(g) - enddo - - maxpe_filt=maxpe_fgen(gm) - npes_filt=maxpe_filt-nxy(1) - - im0(1)=im00 - do g=2,gm - im0(g)=im0(g-1)/2 - enddo - - jm0(1)=jm00 - do g=2,gm - jm0(g)=jm0(g-1)/2 - enddo - - do g=1,gm - Fimax(g)=im0(g)-im*(ixm(g)-1) - Fjmax(g)=jm0(g)-jm*(jym(g)-1) -!TEST -! write(15,*)'Fimax(',g,')=',Fimax(g) -! write(15,*)'Fjmax(',g,')=',Fjmax(g) -!TEST - enddo - - do g=1,gm - FimaxL(g)=Fimax(g)/2 - FjmaxL(g)=Fjmax(g)/2 - enddo - -!*** -!*** Number of variables -!*** -!cltmgbf4jedi - - km3 = 6 - km2 = 4 - -!*** -!*** Vertical distribution -!*** - -! lm = 1 -! lm = 50 -! lm05 = lm/2 - km = km3*lm+km2 - lm_all = km3*lm+km2 ! to be deleted - -! lmf = 48 -! lmh = lmf/2 -!TEST -! lmf = lm -! lmh = lmf -!TEST - lmf_all = km3*lmf+km2 ! to be deleted - lmh_all = km3*lmh+km2 ! to be deleted - kmf = km3*lmf+km2 - kmh = km3*lmh+km2 - - - -!*** -!*** Filter related parameters -!** -!clt mgbf4jedi to be put into namelist? - lengthx = 6. ! arbitrary chosen scale of the domain - lengthy = 6. ! arbitrary chosen scale of the domain - - - ib=4 - jb=4 - - dxa = lengthx/nm - dxf = lengthx/im - nb = 2*dxf/dxa - - dya = lengthy/mm - dyf = lengthy/jm - mb = 2*dyf/dya - - xa0 =0. - ya0 =0. - - xf0=-dxf*0.5 - yf0=-dyf*0.5 - - imL=im/2 - jmL=jm/2 - -! pasp0=1 -! pasp0 = 5 ! Main -!! pasp0 = 2. - pasp01 = mg_ampl01 - pasp02 = mg_ampl02 - pasp03 = mg_ampl03 - - -!TEST hx=8 -!TEST hz=8 -!TEST hz=4 -!TEST hz=5 -! hx=6 -! hy=hx -! hz=6 -!clt mgbf4jedi - nh= 6 - nfil = nh + 2 - -! p = 4 ! Exponent of Beta function -! p = 2 ! Exponent of Beta function - - pee2=p*2 - rmom2_1=u1/sqrt(pee2+3) - rmom2_2=u1/sqrt(pee2+4) - rmom2_3=u1/sqrt(pee2+5) - rmom2_4=u1/sqrt(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,mym,gm) -!---------------------------------------------------------------------- -implicit none -integer, intent(in):: nxm,mym -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 = mym; 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/saber/mgbf/mgbf_lib/type_mgbf.f90 b/src/saber/mgbf/mgbf_lib/type_mgbf.f90 deleted file mode 100755 index 4bbbd769b..000000000 --- a/src/saber/mgbf/mgbf_lib/type_mgbf.f90 +++ /dev/null @@ -1,119 +0,0 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -module type_mgbf_mod -!*********************************************************************** -! ! -! Multigrid Beta filter for modeling background error covariance ! -! ! -! M. Rancic (2020) ! -!*********************************************************************** -use mpi -use kinds, only: r_kind,i_kind -use mg_entrymod, only:mg_entrymod_type, mg_initialize,mg_finalize -use mg_mppstuff, only: finishMPI,mype -use mg_filtering, only: mg_filtering_procedure -use mg_transfer, only: mg_transfer_type,anal_to_filt_all,filt_to_anal_all -use mg_parameter, only: mgbf_proc -use type_fieldset, only: fieldset_type -implicit none -type mgbf_type - type(mg_entrymod_type):: mg_entrymod - type(mg_transfer_type):: mg_transfer - contains - procedure,pass:: mgbf_init - procedure,pass:: mgbf_apply - procedure,nopass:: mgbf_finalize -end type mgbf_type -!----------------------------------------------------------------------- -contains - -subroutine mgbf_init(this) - class (mgbf_type),intent(in)::this -!*** -!*** Initialzie multigrid Beta filter -!*** - call this%mg_entrymod%mg_initialize - -end subroutine mgbf_init - -!*** -!*** From the analysis to first generation of filter grid -!*** - subroutine mgbf_apply(this,fieldset) - use mg_intstate,only: worka - use atlas_module, only: atlas_fieldset,atlas_field,atlas_functionspace - use mg_parameter, only: km,n0,nm,m0,mm - type(atlas_functionspace) :: afunctionspace - class (mgbf_type),intent(in):: this - type(atlas_field) :: afield - type(atlas_fieldset),intent(inout) :: fieldset !< Fieldset - real(kind=r_kind), pointer :: t(:,:) - integer(i_kind)::i,j,k,ij,ii,jj,nx,ny - nx=nm-n0+1 - ny=mm-m0+1 - afield = fieldset%field('air_temperature') - call afield%data(t) - do k=1,km - ij=1 - do jj=1,ny - do ii=1,nx - i=ii-n0+1 - j=jj-m0+1 - worka(k,i,j)=t(ij,k) - enddo - enddo - enddo - - - call this%mg_transfer%anal_to_filt_all !cltthink (fieldset) - - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -!*** -!*** Adjoint test if needed -!*** - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - -!*** -!*** Filtering -!*** -!====================================================================== - -!clt call mgbf_obj_in%mg_transfer%mg_filtering_procedure(mgbf_proc,fieldset) - call mg_filtering_procedure(mgbf_proc) !cltthink ,fieldset) - -!====================================================================== - -!*** -!*** From first generation of filter grid to analysis grid (x-directoin) -!*** - - call this%mg_transfer%filt_to_anal_all !cltthink (fieldset) - - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -!*** -!*** Adjoint test if needed -!*** - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -! Halo exchange - -afunctionspace = afield%functionspace() -call afunctionspace%halo_exchange(afield) - - - -!==================== Forward (Smoothing step) ======================== -!*** -!*** DONE! Deallocate variables -end subroutine mgbf_apply -!*** -subroutine mgbf_finalize(this) - class (mgbf_type),intent(in)::this - call this%mg_entrymod%mg_finalize -end subroutine mgbf_finalize - - -!----------------------------------------------------------------------- -end module type_mgbf_mod diff --git a/src/saber/mgbf/mgbf_lib/type_parameter_locpointer.inc b/src/saber/mgbf/mgbf_lib/type_parameter_locpointer.inc new file mode 100644 index 000000000..5039ea8ce --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_parameter_locpointer.inc @@ -0,0 +1,92 @@ +! https://stackoverflow.com/questions/24990491/fortran-namelist-associate-does-not-work +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:: 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:: mym +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:: lm ! number of vertical layers +integer(i_kind),pointer:: lm05 ! half of vertical levels +integer(i_kind),pointer:: km2_f ! number of 2d variables for filtering +integer(i_kind),pointer:: km3_f ! number of 3d variables for filtering +integer(i_kind),pointer:: km2_e ! number of 2d variables for ensemble +integer(i_kind),pointer:: km3_e ! number of 3d variables for ensemble +logical,pointer :: l_filt ! logical flag for filtering or enseble +!integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) +integer(i_kind),pointer:: lmf ! number of vertical levels for filtering (generation one) +integer(i_kind),pointer:: lmh ! number of vertical levels for filtering (high generations) +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 +!clt from mg_entrymod.f90 +integer(i_kind),pointer:: km,km2,km3 +!clt from mg_mppstuff.f90 +integer(i_kind),pointer:: mype +character(len=5),pointer:: c_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 +!clt moved 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 + + diff --git a/src/saber/mgbf/mgbf_lib/type_parameter_point2this.inc b/src/saber/mgbf/mgbf_lib/type_parameter_point2this.inc new file mode 100644 index 000000000..176ebb73f --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/type_parameter_point2this.inc @@ -0,0 +1,230 @@ + +!*** +! apply the solution from +!*** Namelist parameters +!*** +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 + +!*** +!*** Number of generations +!*** +gm=>this%gm + +!*** +!*** Horizontal resolution +!*** + +! +! Original number of data on GSI analysis grid +! +nA_max0=>this%nA_max0 +mA_max0=>this%mA_max0 + +! +! Global number of data on Analysis grid +! +nm0 =>this%nm0 + mm0=>this%mm0 + +! +! Number of PEs on Analysis grid +! +nxm =>this%nxm +mym =>this%mym + +! +! Number of data on local Analysis grid +! +nm =>this%nm +mm =>this%mm + +! +! Number of data on global Filter grid +! +im00=>this%im00 +jm00=>this%jm00 + +! +! Number of data on local Filter grid +! +im=>this%im +jm =>this%jm + +! +! Initial index on local Filter grid +! +i0=>this%i0 +j0=>this%j0 +! +! Initial index on local analysis grid +! +n0=>this%n0 +m0=>this%m0 + +! +! Halo on local Filter grid +! +ib=>this%ib +jb=>this%jb + +! +! Halo on local Analysis grid +! + 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 +lm=>this%lm ! number of vertical layers + lm05=>this%lm05 ! half of vertical levels +km2_f=>this%km2_f ! number of 2d variables for filtering +km3_f=>this%km3_f ! number of 3d variables for filtering +km2_e=>this%km2_e ! number of 2d variables for ensemble +km3_e=>this%km3_e ! number of 3d variables for ensemble +l_filt=>this%l_filt ! logical flag for filtering or enseble + lmf =>this%lmf ! number of vertical levels for filtering (generation one) +lmh =>this%lmh ! number of vertical levels for filtering (high generations) + + + +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 + +! +! Just for standalone test +! +!clt from entrymode.f90 +ldelta=>this%ldelta +km=>this%km +km2=>this%km2 +km3=>this%km3 +!clt from mg_mpstuff.f90 +mype=>this%mype +c_mype=>this%c_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 +!clt moved from *_mg_domain.f90 +!logical,dimension(2):: Flwest,Fleast,Flnorth,Flsouth + Flwest=>this%Flwest + Fleast=>this%Fleast + Flnorth=>this%Flnorth + Flsouth=>this%Flsouth +!integer(i_kind),dimension(2):: Fitarg_n,Fitarg_e,Fitarg_s,Fitarg_w + Fitarg_n=>this%Fitarg_n + Fitarg_e=>this%Fitarg_e + Fitarg_s=>this%Fitarg_s + Fitarg_w=>this%Fitarg_w +!integer(i_kind),dimension(2):: Fitarg_sw,Fitarg_se,Fitarg_ne,Fitarg_nw + Fitarg_sw=>this%Fitarg_sw + Fitarg_se=>this%Fitarg_se + Fitarg_ne=>this%Fitarg_ne + Fitarg_nw=>this%Fitarg_nw + +!logical,dimension(2):: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne + 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 cefeedcffb39318ec53e4f246f971cbb45eeec78 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Wed, 1 May 2024 17:17:12 +0000 Subject: [PATCH 003/199] an initial basic version for mgbf in saber using the stand-alone mgbf lib --- src/saber/CMakeLists.txt | 6 +- src/saber/gsi/grid/Grid.cc | 1 + src/saber/gsi/grid/gsi_grid_mod.f90 | 1 + src/saber/mgbf/CMakeLists.txt | 60 + src/saber/mgbf/covariance/MGBF_Covariance.cc | 2 +- src/saber/mgbf/covariance/MGBF_Covariance.h | 95 +- src/saber/mgbf/covariance/dd | 7 - src/saber/mgbf/covariance/dd.h | 245 -- .../mgbf/covariance/mgbf_covariance_mod.f90 | 106 +- src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 | 234 -- src/saber/mgbf/mgbf_lib/jp_pbfil.f90 | 181 +- src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 | 40 +- src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 | 142 +- src/saber/mgbf/mgbf_lib/jp_pietc.f90 | 37 +- src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 | 38 +- src/saber/mgbf/mgbf_lib/jp_pkind.f90 | 20 + src/saber/mgbf/mgbf_lib/jp_pkind2.f90 | 24 +- src/saber/mgbf/mgbf_lib/jp_pmat.f90 | 67 +- src/saber/mgbf/mgbf_lib/jp_pmat4.f90 | 126 +- src/saber/mgbf/mgbf_lib/kinds.f90 | 9 +- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 2669 +++++++++++++++-- src/saber/mgbf/mgbf_lib/mg_domain.f90 | 207 +- src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 | 796 +++++ src/saber/mgbf/mgbf_lib/mg_entrymod.f90 | 150 +- src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 2259 +++++++------- src/saber/mgbf/mgbf_lib/mg_generations.f90 | 1560 ++++++++-- src/saber/mgbf/mgbf_lib/mg_interpolate.f90 | 684 ++++- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 2225 +++++++------- src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 | 120 +- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 1048 +++---- src/saber/mgbf/mgbf_lib/mg_timers.f90 | 70 +- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 497 ++- .../mgbf/mgbf_lib/type_intstat_locpointer.inc | 41 +- .../mgbf/mgbf_lib/type_intstat_point2this.inc | 50 +- .../mgbf_lib/type_parameter_locpointer.inc | 71 +- .../mgbf_lib/type_parameter_point2this.inc | 345 +-- src/saber/oops/ErrorCovariance.h | 3 +- 37 files changed, 9541 insertions(+), 4695 deletions(-) create mode 100644 src/saber/mgbf/CMakeLists.txt delete mode 100644 src/saber/mgbf/covariance/dd delete mode 100644 src/saber/mgbf/covariance/dd.h delete mode 100755 src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 mode change 100755 => 100644 src/saber/mgbf/mgbf_lib/jp_pietc.f90 mode change 100755 => 100644 src/saber/mgbf/mgbf_lib/jp_pkind.f90 mode change 100755 => 100644 src/saber/mgbf/mgbf_lib/jp_pmat.f90 mode change 100755 => 100644 src/saber/mgbf/mgbf_lib/kinds.f90 mode change 100755 => 100644 src/saber/mgbf/mgbf_lib/mg_bocos.f90 mode change 100755 => 100644 src/saber/mgbf/mgbf_lib/mg_domain.f90 create mode 100644 src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 mode change 100755 => 100644 src/saber/mgbf/mgbf_lib/mg_timers.f90 diff --git a/src/saber/CMakeLists.txt b/src/saber/CMakeLists.txt index 09ac1111e..fb22cbe7f 100644 --- a/src/saber/CMakeLists.txt +++ b/src/saber/CMakeLists.txt @@ -4,7 +4,7 @@ # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # Build list of subdirs with files to add -set( _subdirs blocks bump fastlam generic interpolation oops spectralb util vader mgbf) +set( _subdirs blocks bump fastlam generic gsi interpolation oops spectralb util vader mgbf) #clt set( _subdirs blocks bump fastlam generic interpolation oops spectralb util vader mgbf) foreach( _subdir IN LISTS _subdirs ) add_subdirectory( ${_subdir} ) @@ -38,6 +38,10 @@ if( gsibec_FOUND ) target_link_libraries( ${PROJECT_NAME} PUBLIC sp::sp_d ) endif() endif() +if( MGBFLIB_FOUND ) + target_link_libraries( ${PROJECT_NAME} PUBLIC mgbflib ) + target_compile_definitions( ${PROJECT_NAME} PUBLIC MGBF_FOUND) +endif() if( FFTW_FOUND ) target_link_libraries( ${PROJECT_NAME} PUBLIC FFTW::fftw3) endif() diff --git a/src/saber/gsi/grid/Grid.cc b/src/saber/gsi/grid/Grid.cc index 3ff1cae61..bd3af15a3 100644 --- a/src/saber/gsi/grid/Grid.cc +++ b/src/saber/gsi/grid/Grid.cc @@ -36,6 +36,7 @@ Grid::Grid(const eckit::mpi::Comm & comm, const eckit::Configuration & conf) gsi_grid_get_levels_f90(keySelf_, gsiLevels_); // Create a functionspace for the GSI grid + // tothink atlas::FieldSet gsiGridFieldSet = atlas::FieldSet(); gsi_grid_set_atlas_lonlat_f90(keySelf_, gsiGridFieldSet.get()); atlas::Field lonlat = gsiGridFieldSet["lonlat"]; diff --git a/src/saber/gsi/grid/gsi_grid_mod.f90 b/src/saber/gsi/grid/gsi_grid_mod.f90 index 2d1cc5a52..a2bfab6c7 100644 --- a/src/saber/gsi/grid/gsi_grid_mod.f90 +++ b/src/saber/gsi/grid/gsi_grid_mod.f90 @@ -399,6 +399,7 @@ subroutine set_atlas_lonlat(self, grid_fieldset) call lonlat_field%data(real_ptr) ! Fill lon/lat +!clttothink real_ptr(1,:) = reshape(self%grid_lons(self%isc:self%iec, & self%jsc:self%jec), (/self%ngrid/)) real_ptr(2,:) = reshape(self%grid_lats(self%isc:self%iec, & diff --git a/src/saber/mgbf/CMakeLists.txt b/src/saber/mgbf/CMakeLists.txt new file mode 100644 index 000000000..4307eec96 --- /dev/null +++ b/src/saber/mgbf/CMakeLists.txt @@ -0,0 +1,60 @@ +# (C) Copyright 2022 United States Government as represented by the Administrator of the National +# Aeronautics and Space Administration +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +file(GLOB jbfiles mgbf_lib/*.f90) + message(STATUS "thinkdeb-2 " ${jbfiles} ) +set (jbfilenames "") +foreach ( _fname ${jbfiles} ) + get_filename_component( basefilename ${_fname} NAME ) + list ( APPEND jbfilenames mgbf_lib/${basefilename} ) + message(STATUS "thinkdeb-1 " ${basefilename}) + message(STATUS "thinkdeb0 " ${jbfilenames}) +endforeach () +message(STATUS "thinkdeb " ${jbfilenames}) +#set (jbfilenames "mgbf_lib/jp_pbfil.f90" ) +set (build_saber_mgbf 1) +if( build_saber_mgbf ) + list(APPEND mgbf_src_files_list + + # Covariance block + covariance/MGBF_Covariance.h + covariance/MGBF_Covariance.cc + covariance/MGBF_Covariance.interface.F90 + covariance/MGBF_Covariance.interface.h + covariance/mgbf_covariance_mod.f90 + + # Grid +#clt grid/MGBF_Grid.h +#clt grid/MGBF_Grid.interface.F90 +#clt grid/MGBF_Grid.interface.h +#clt grid/mgbf_grid_mod.f90 + + # Interpolation block + #clt don't need interpolation block for being now +# interpolation/MGBF_Interpolation.h + + # Unstructured interpolation code ported from oops (until new interp code can be used) +# interpolation/unstructured_interp/saber_unstructured_interpolation_mod.F90 +# interpolation/unstructured_interp/UnstructuredInterpolation.cc +# interpolation/unstructured_interp/UnstructuredInterpolation.h +# interpolation/unstructured_interp/UnstructuredInterpolation.interface.F90 +# interpolation/unstructured_interp/UnstructuredInterpolation.interface.h + + # Utilities +# utils/mgbf_utils_mod.f90 + + ) +endif() +#clt find_package(mgbf_lib REQUIRED ) +message (STATUS "thinkdeb1 " ${mgbf_src_files_list} ) + +set( mgbf_src_files + +${mgbf_src_files_list} +${jbfilenames} + +PARENT_SCOPE +) + message (STATUS "thinkdeb2.4" ${mgbf_src_files} ) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.cc b/src/saber/mgbf/covariance/MGBF_Covariance.cc index 6f82f812d..9cab16c0b 100644 --- a/src/saber/mgbf/covariance/MGBF_Covariance.cc +++ b/src/saber/mgbf/covariance/MGBF_Covariance.cc @@ -30,7 +30,7 @@ namespace mgbf { // ------------------------------------------------------------------------------------------------- -static SaberCentralBlockMaker makerCovariance_("MGBF_covariance"); +static SaberCentralBlockMaker makerCovariance_("MGBF_covariance"); } // namespace MGBF } // namespace saber diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index 8e1ffa50b..1097970e7 100644 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -10,20 +10,22 @@ #include #include +#include #include #include "atlas/field.h" + #include "oops/base/FieldSet3D.h" #include "oops/base/GeometryData.h" #include "oops/base/Variables.h" +#include "saber/blocks/SaberBlockParametersBase.h" +#include "saber/blocks/SaberCentralBlockBase.h" #include "saber/mgbf/covariance/MGBF_Covariance.interface.h" -//clt #include "saber/mgbf/grid/MGBF_Grid.h" -#include "saber/blocks/SaberCentralBlockBase.h" -#include "saber/blocks/SaberBlockParametersBase.h" #include +#include "saber/oops/Utilities.h" using atlas::option::levels; @@ -35,11 +37,12 @@ namespace oops { namespace saber { namespace mgbf { - + typedef int MGBF_CovarianceKey; // ------------------------------------------------------------------------------------------------- -class CovarianceParameters: public SaberBlockParametersBase { - OOPS_CONCRETE_PARAMETERS(CovarianceParameters,SaberBlockParametersBase) +class MGBF_CovarianceParameters: public SaberBlockParametersBase { + OOPS_CONCRETE_PARAMETERS(MGBF_CovarianceParameters,SaberBlockParametersBase) public: + oops::RequiredParameter MGBFNML{"mgbf namelist file", this}; // Mandatory active variables oops::Variables mandatoryActiveVars() const override {return oops::Variables();} }; @@ -47,16 +50,16 @@ class CovarianceParameters: public SaberBlockParametersBase { // ------------------------------------------------------------------------------------------------- //clt template -class Covariance : public SaberCentralBlockBase { +class MGBF_Covariance : public SaberCentralBlockBase { //clt typedef oops::Increment Increment_; public: static const std::string classname() {return "saber::mgbf::Covariance";} - typedef CovarianceParameters Parameters_; + typedef MGBF_CovarianceParameters Parameters_; //cltorg Covariance(const Geometry_ &, const Parameters_ &, const State_ &, const State_ &); -Covariance(const oops::GeometryData & geometryData, +MGBF_Covariance(const oops::GeometryData & geometryData, const oops::Variables & centralVars, const eckit::Configuration & covarConf, const Parameters_ & params, @@ -64,48 +67,47 @@ Covariance(const oops::GeometryData & geometryData, const oops::FieldSet3D & fg ); - virtual ~Covariance(); - + virtual ~MGBF_Covariance(); void randomize(oops::FieldSet3D &) const override; void multiply(oops::FieldSet3D &) const override; - std::vector> getReadConfs() const override; - void setReadFields(const std::vector &) override; - void read() override; + std::vector> getReadConfs() const override{}; + void setReadFields(const std::vector &) override{}; - void directCalibration(const oops::FieldSets &) override; + void read() override {}; - void iterativeCalibrationInit() override; - void iterativeCalibrationUpdate(const oops::FieldSet3D &) override; - void iterativeCalibrationFinal() override; + void directCalibration(const oops::FieldSets &) override {}; - void dualResolutionSetup(const oops::GeometryData &) override; + void iterativeCalibrationInit() override {}; + void iterativeCalibrationUpdate(const oops::FieldSet3D &) override{}; + void iterativeCalibrationFinal() override{}; - void write() const override; + void dualResolutionSetup(const oops::GeometryData &) override{}; + + void write() const override {}; std::vector> fieldsToWrite() const - override; + override {}; - size_t ctlVecSize() const override {return static_cast(99999) ;} - void multiplySqrt(const atlas::Field &, oops::FieldSet3D &, const size_t &) const override; - void multiplySqrtAD(const oops::FieldSet3D &, atlas::Field &, const size_t &) const override; +//cltorg size_t ctlVecSize() const override {return bump_->getCvSize();} + void multiplySqrt(const atlas::Field &, oops::FieldSet3D &, const size_t &) const override {}; + void multiplySqrtAD(const oops::FieldSet3D &, atlas::Field &, const size_t &) const override {}; private: - void print(std::ostream &) const override; + void print(std::ostream &) const override ; // Fortran LinkedList key - CovarianceKey keySelf_; + MGBF_CovarianceKey keySelf_; // Variables std::vector variables_; // Function space atlas::FunctionSpace mgbfGridFuncSpace_; - // Grid -//clt Grid grid_; + oops::Variables activeVars_; }; // ------------------------------------------------------------------------------------------------- -Covariance::Covariance(const oops::GeometryData & geometryData, +MGBF_Covariance::MGBF_Covariance(const oops::GeometryData & geometryData, const oops::Variables & centralVars, const eckit::Configuration & covarConf, const Parameters_ & params, @@ -114,10 +116,16 @@ Covariance::Covariance(const oops::GeometryData & geometryData, : SaberCentralBlockBase(params, xb.validTime()) { oops::Log::trace() << classname() << "MGBF::Covariance starting" << std::endl; + // Get active variables + activeVars_ = getActiveVars(params, centralVars); + //clt util::Timer timer(classname(), "Covariance"); std::cout<<"thinkdebconfig0 ifhas -1 "<iterativeUpdate(fset, ie); - oops::Log::trace() << classname() << "::iterativeCalibration done" << std::endl; -} -void Covariance::getOutputFields(const eckit::LocalConfiguration & config , atlas::FieldSet & fset) const { - oops::Log::trace() << classname() << "dummy getOutFields" << std::endl; - }; - -// ------------------------------------------------------------------------------------------------- -void Covariance::finalSetup() { - oops::Log::trace() << classname() << "::calibration starting" << std::endl; -//clttothink dump - oops::Log::trace() << classname() << "::calibration done" << std::endl; -} -void Covariance::print(std::ostream & os) const { +void MGBF_Covariance::print(std::ostream & os) const { os << classname(); } diff --git a/src/saber/mgbf/covariance/dd b/src/saber/mgbf/covariance/dd deleted file mode 100644 index 42a9e11fa..000000000 --- a/src/saber/mgbf/covariance/dd +++ /dev/null @@ -1,7 +0,0 @@ -Covariance(const oops::GeometryData & geometryData, - const oops::Variables & centralVars, - const eckit::Configuration & covarConf, - const Parameters_ & params, - const oops::FieldSet3D & xb, - const oops::FieldSet3D & fg, - ); diff --git a/src/saber/mgbf/covariance/dd.h b/src/saber/mgbf/covariance/dd.h deleted file mode 100644 index d97c0fb7f..000000000 --- a/src/saber/mgbf/covariance/dd.h +++ /dev/null @@ -1,245 +0,0 @@ -/* - * (C) Copyright 2022 United States Government as represented by the Administrator of the National - * Aeronautics and Space Administration - * - * This software is licensed under the terms of the Apache Licence Version 2.0 - * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. - */ - -#pragma once - -#include -#include -#include - -#include "atlas/field.h" - -#include "oops/base/GeometryData.h" -#include "oops/base/Variables.h" - - -#include "atlas/grid.h" -#include "atlas/library.h" -#include "atlas/runtime/Log.h" - -#include "oops/base/Geometry.h" -#include "oops/base/State.h" -#include "oops/base/Variables.h" -#include "oops/util/abor1_cpp.h" - -#include "saber/mgbf/covariance/MGBF_Covariance.interface.h" -//clt #include "saber/mgbf/grid/MGBF_Grid.h" -#include "saber/blocks/SaberCentralBlockBase.h" -#include "saber/blocks/SaberBlockParametersBase.h" -#include - - -using atlas::option::levels; -using atlas::option::name; - -namespace oops { - class Variables; -} - -namespace saber { -namespace mgbf { - -// ------------------------------------------------------------------------------------------------- -class CovarianceParameters: public SaberBlockParametersBase { - OOPS_CONCRETE_PARAMETERS(CovarianceParameters,SaberBlockParametersBase) - public: - // Mandatory active variables - oops::Variables mandatoryActiveVars() const override {return oops::Variables();} -}; - -// ------------------------------------------------------------------------------------------------- - -//clt template -class Covariance : public SaberCentralBlockBase { -//clt typedef oops::Increment Increment_; - - public: - static const std::string classname() {return "saber::mgbf::Covariance";} - typedef CovarianceParameters Parameters_; - - -//cltorg Covariance(const Geometry_ &, const Parameters_ &, const State_ &, const State_ &); -Covariance(const oops::GeometryData &, - const std::vector &, - const oops::Variables &, - const Parameters_ &, - const atlas::FieldSet &, - const atlas::FieldSet &, - const std::vector &, - const size_t &); - - virtual ~Covariance(); - - void randomize(oops::FieldSet3D &) const override; - void multiply(oops::FieldSet3D &) const override; - std::vector> getReadConfs() const override; - void setReadFields(const std::vector &) override; - - void read() override; - - void directCalibration(const oops::FieldSets &) override; - - void iterativeCalibrationInit() override; - void iterativeCalibrationUpdate(const oops::FieldSet3D &) override; - void iterativeCalibrationFinal() override; - - void dualResolutionSetup(const oops::GeometryData &) override; - - void write() const override; - std::vector> fieldsToWrite() const - override; - -//clttodo size_t ctlVecSize() const override {return bump_->getCvSize();} - void multiplySqrt(const atlas::Field &, oops::FieldSet3D &, const size_t &) const override; - void multiplySqrtAD(const oops::FieldSet3D &, atlas::Field &, const size_t &) const override; - - - private: - void print(std::ostream &) const override; - // Fortran LinkedList key - CovarianceKey keySelf_; - // Variables - std::vector variables_; - // Function space - atlas::FunctionSpace mgbfGridFuncSpace_; - // Grid -//clt Grid grid_; -}; - -// ------------------------------------------------------------------------------------------------- - - -Covariance::Covariance(const oops::GeometryData & geometryData, - const std::vector & activeVariableSizes, - const oops::Variables & centralVars, - const Parameters_ & params, - const atlas::FieldSet & xbg, - const atlas::FieldSet & xfg, - const std::vector & fsetVec, - const size_t & timeRank) - : variables_() - - -//clt Covariance::Covariance(const Geometry_ & geom, const Parameters_ & params, - //clt const State_ & xbg, const State_ & xfg) -//clt : SaberCentralBlockBase(params), variables_() -//clt : SaberCentralBlockBase(params), variables_(), grid_(geom.getComm(), params) -{ - oops::Log::trace() << classname() << "MGBF::Covariance starting" << std::endl; - util::Timer timer(classname(), "Covariance"); - std::cout<<"thinkdebconfig0 ifhas -1 "<(fieldName | levels(sabField.levels()))); - } - - // Replace whatever fields are coming in with the mgbf grid fields - fset = newFields; - - // Call implementation -//clt MGBF_covariance_randomize_f90(keySelf_, fset.get()); - mgbf_covariance_randomize_f90(keySelf_, fset.get()); - oops::Log::trace() << classname() << "::randomize done" << std::endl; -} - -// ------------------------------------------------------------------------------------------------- - -void Covariance::multiply(atlas::FieldSet & fset) const { - oops::Log::trace() << classname() << "::multiply starting" << std::endl; - util::Timer timer(classname(), "multiply"); - mgbf_covariance_multiply_f90(keySelf_, fset.get()); - oops::Log::trace() << classname() << "::multiply done" << std::endl; -} - -// ------------------------------------------------------------------------------------------------- - - -// ------------------------------------------------------------------------------------------------- - -// ----------------------------------------------------------------------------- -// -// -// ------------------------------------------------------------------------------------------------- - -void Covariance::iterativeCalibration(const atlas::FieldSet & fset, const size_t & ie) { - oops::Log::trace() << classname() << "::iterativeCalibration starting" << std::endl; -//clt bump_->iterativeUpdate(fset, ie); - oops::Log::trace() << classname() << "::iterativeCalibration done" << std::endl; -} -void Covariance::getOutputFields(const eckit::LocalConfiguration & config , atlas::FieldSet & fset) const { - oops::Log::trace() << classname() << "dummy getOutFields" << std::endl; - }; - -// ------------------------------------------------------------------------------------------------- -void Covariance::finalSetup() { - oops::Log::trace() << classname() << "::calibration starting" << std::endl; -//clttothink dump - oops::Log::trace() << classname() << "::calibration done" << std::endl; -} - -void Covariance::print(std::ostream & os) const { - os << classname(); -} - - - -} // namespace mgbf -} // namespace saber diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 1667ac07f..1d9d2595e 100644 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -15,12 +15,12 @@ module mgbf_covariance_mod use fckit_configuration_module, only: fckit_configuration ! oops -use kinds, only: r_kind +use kinds, only: r_kind,i_kind use random_mod ! saber !clt use mgbf_grid_mod, only: mgbf_grid -use mg_intstate , only: mgbf_instate_type +use mg_intstate , only: mg_intstate_type implicit none private @@ -29,7 +29,7 @@ module mgbf_covariance_mod ! Fortran class header type :: mgbf_covariance - type(mgbf_instate_type) :: mgbf_instate + type(mg_intstate_type) :: intstate logical :: noMGBF logical :: bypassMGBFbe logical :: cv ! cv=.true.; sv=.false. @@ -63,12 +63,11 @@ subroutine create(self, comm, config, background, firstguess) ! Locals character(len=*), parameter :: myname_=myname//'*create' -character(len=:), allocatable :: nml,bef +character(len=:), allocatable :: mgbf_nml logical :: central integer :: layout(2) type(atlas_field) :: afield -real(kind=r_kind), pointer :: t(:,:) ! Hold communicator ! ----------------- @@ -80,7 +79,7 @@ subroutine create(self, comm, config, background, firstguess) self%rank = comm%rank() call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) -#if 0 +call config%get_or_die("mgbf namelist ", mgbf_nml) if (.not. self%noMGBF) then call config%get_or_die("saber central block", central) if (.not. central) then @@ -90,16 +89,14 @@ subroutine create(self, comm, config, background, firstguess) ! Get required name of resources for MGBF B error ! ---------------------------------------------- - call config%get_or_die("mgbf berror namelist file", nml) - call config%get_or_die("mgbf error covariance file", bef) - call self%mg_initialize("mgbeta.nml") + call config%get_or_die("mgbf berror namelist file", mgbf_nml) +!// call config%get_or_die("mgbf error covariance file", bef) ! Initialize MGBF-Berror components ! -------------------------------- ! layout=-1 endif -#endif -call self%mgbf_intstate%mg_initialize() +call self%intstate%mg_initialize(mgbf_nml) !mgbf_nml like mgbeta.nml ! Get background (temporary test of the functionality) !cltafield = background%field('air_temperature') !clt call afield%data(t) @@ -115,11 +112,9 @@ subroutine delete(self) ! Locals -#if 0 -if (.not. self%noMGBF) then - call mgbfbclim_final(.false.) -endif -#endif +!clt //if (.not. self%noMGBF) then + call self%intstate%mg_finalize() +!clt endif ! Delete the grid ! --------------- @@ -184,44 +179,69 @@ subroutine multiply(self, fields) ! Locals type(atlas_field) :: afield -real(kind=r_kind), pointer :: ttodo(:,:) +real(kind=r_kind), pointer :: ptr_2d(:,:) +real(kind=r_kind), pointer :: ptr_3d(:,:,:) +integer(kind=i_kind):: nz,ilev,isize +real(kind=r_kind), allocatable :: work_mgbf(:,:,:) !clt now noly consider t ! afield = fields%field('air_temperature') ! call afield%data(t) !*** From the analysis to first generation of filter grid !*** - call btim( an2filt_tim) - - call self%anal_to_filt_all(ttodo) - call etim( an2filt_tim) - - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -!*** -!*** Adjoint test if needed -!*** - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ + allocate(work_mgbf(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) +!clt first as in ckgcov_a_en_new_factorization_ad + ilev=1 + do isize=1,fields%size() + + afield= fields%field(isize) !clttodo + if(afield%rank() == 2) then + call afield%data(ptr_2d) + work_mgbf(ilev,:,:)=ptr_2d + ilev=ilev+1 + elseif (afield%rank() == 3) then + call afield%data(ptr_3d) + nz=afield%levels() + work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + stop + endif + enddo + call self%intstate%anal_to_filt_allmap(work_mgbf) +!clt second as in ckgcov_a_en_new_factorization + call self%intstate%filtering_procedure(self%intstate%mgbf_proc,1) + + work_mgbf=0.0 ! to use zero-like constants !,why? + + call self%intstate%anal_to_filt_allmap(work_mgbf) + +!the following should match fields ===> work_mgbf + ilev=1 + do isize=1,fields%size() + + afield=fields%field(isize) !clttodo + if(afield%rank() == 2) then + call afield%data(ptr_2d) + ptr_2d=work_mgbf(ilev,:,:) + ilev=ilev+1 + elseif (afield%rank() == 3) then + call afield%data(ptr_3d) + nz=afield%levels() + ptr_3d=work_mgbf(ilev:ilev+nz-1,:,:) + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + stop + endif + enddo -!*** -!*** Filtering -!*** -!====================================================================== - call self%mg_filtering_procedure(self%mgbf_proc) !clt to be changed -!*** From first generation of filter grid to analysis grid (x-directoin) -!*** - call btim( filt2an_tim) - call obj_mgbf%filt_to_anal_all(ttodo) - -! Halo exchange -!afunctionspace = afield%functionspace() -!call afunctionspace%halo_exchange(afield) - + deallocate(work_mgbf) end subroutine multiply diff --git a/src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 b/src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 deleted file mode 100755 index 68a8811a8..000000000 --- a/src/saber/mgbf/mgbf_lib/RBETA_TEST.f90 +++ /dev/null @@ -1,234 +0,0 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - program RBETA_TEST -!*********************************************************************** -! ! -! Multigrid Beta filter for modeling background error covariance ! -! ! -! M. Rancic (2020) ! -!*********************************************************************** -use mpi -use kinds, only: r_kind,i_kind -!clt use mg_entrymod, only: mg_initialize,mg_finalize -!clt use mg_mppstuff, only: finishMPI,mype -!clt use mg_filtering, only: mg_filtering_procedure -!clt use mg_transfer, only: anal_to_filt_all,filt_to_anal_all -!clt use mg_parameter, only: mgbf_proc -use mg_intstate -use mg_timers -use mg_input - -implicit none -type (mg_intstate_type):: obj_mgbf -type (mg_intstate_type):: obj2_mgbf -real(r_kind), allocatable, dimension(:,:):: PA -real(r_kind), allocatable,dimension(:,:,:):: WORKA - integer :: mype,unitnum - character*4 :: file_str - integer(i_kind):: ierr - -!----------------------------------------------------------------------- - - call btim( total_tim) - call btim( init_tim) - - call MPI_INIT(ierr) - -!*** -!*** Initialzie multigrid Beta filter -if(1.gt.0) then -!*** - call obj_mgbf%mg_initialize("mgbeta.nml") - - call etim( init_tim) -!clt write(6,*)"worka dim ",obj_mgbf%km,obj_mgbf%n0,obj_mgbf%nm,obj_mgbf%m0,obj_mgbf%mm - allocate(WORKA(obj_mgbf%km,obj_mgbf%n0:obj_mgbf%nm,obj_mgbf%m0:obj_mgbf%mm)) ; WORKA=0. -if(obj_mgbf%ldelta) then - - allocate(PA(1:obj_mgbf%nm,1:obj_mgbf%mm)) - - PA = 0. - call input_spec1_2d(obj_mgbf, PA,obj_mgbf%nxm/2,obj_mgbf%mym/2,'md') - -! WORKA(3*lm+1:4*lm,:,:)=0. - WORKA(3*obj_mgbf%lm+obj_mgbf%lm/2,:,:)=PA(:,:) - - -deallocate(PA) - -endif -!*** -!*** From the analysis to first generation of filter grid -!*** - call btim( an2filt_tim) - - call obj_mgbf%anal_to_filt_all(WORKA) - call etim( an2filt_tim) - - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -!*** -!*** Adjoint test if needed -!*** - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - -!*** -!*** Filtering -!*** -!====================================================================== - - call obj_mgbf%mg_filtering_procedure(obj_mgbf%mgbf_proc) !clt to be changed - -!====================================================================== - -!*** -!*** From first generation of filter grid to analysis grid (x-directoin) -!*** - - call btim( filt2an_tim) - call obj_mgbf%filt_to_anal_all(WORKA) - - call etim( filt2an_tim) - mype=obj_mgbf%mype - unitnum=25+mype - write(6,*)WORKA(1,1,1) - write(file_str,"(I4.4)") mype - - open(unit=unitnum,file='mpi'//file_str//'version-worka.bin',access="sequential",form='unformatted',STATUS='replace') - write(unitnum)WORKA -!clt if(any(WORKA .gt.0.01)) then - if(mype==35) then - write(6,*)'thinkdebworka ',size(WORKA) - write(6,*)WORKA - call flush(6) - endif - - close (unitnum) - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -!*** -!*** Adjoint test if needed -!*** - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - - -!==================== Forward (Smoothing step) ======================== -!*** -!*** DONE! Deallocate variables -!*** - call btim( output_tim) - call obj_mgbf%mg_finalize - - call etim( output_tim) - call etim( total_tim) - - - deallocate(WORKA) -!*** -!*** Print wall clock and cpu timing -!*** -!clt for another obj2_mgbf -endif !1 gt 2 - - - -!clt call obj_mgbf%finishMPI - write(6,*)'thinkdeb to run for obj_2' - call MPI_BARRIER(MPI_COMM_WORLD,ierr) - call obj2_mgbf%mg_initialize("mgbeta.nml") - - write(6,*)"worka dim2 ",obj2_mgbf%km,obj2_mgbf%n0,obj2_mgbf%nm,obj2_mgbf%m0,obj2_mgbf%mm - allocate(WORKA(obj2_mgbf%km,obj2_mgbf%n0:obj2_mgbf%nm,obj2_mgbf%m0:obj2_mgbf%mm)) ; WORKA=0. -if(obj2_mgbf%ldelta) then - - allocate(PA(1:obj2_mgbf%nm,1:obj2_mgbf%mm)) - - PA = 0. - call input_spec1_2d(obj2_mgbf, PA,obj2_mgbf%nxm/2,obj2_mgbf%mym/2,'md') - -! WORKA(3*lm+1:4*lm,:,:)=0. - WORKA(3*obj2_mgbf%lm+obj2_mgbf%lm/2,:,:)=PA(:,:) - - -deallocate(PA) - -endif -!*** -!*** From the analysis to first generation of filter grid -!*** -! call btim( an2filt_tim) - - call obj2_mgbf%anal_to_filt_all(WORKA) - !call etim( an2filt_tim) - - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -!*** -!*** Adjoint test if needed -!*** - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - -!*** -!*** Filtering -!*** -!====================================================================== - - call obj2_mgbf%mg_filtering_procedure(obj2_mgbf%mgbf_proc) !clt to be changed - -!====================================================================== - -!*** -!*** From first generation of filter grid to analysis grid (x-directoin) -!*** - -! call btim( filt2an_tim) - call obj2_mgbf%filt_to_anal_all(WORKA) - -! call etim( filt2an_tim) - mype=obj2_mgbf%mype - unitnum=25+mype - write(6,*)WORKA(1,1,1) - write(file_str,"(I4.4)") mype - - open(unit=unitnum,file='mpi'//file_str//'version-worka.bin',access="sequential",form='unformatted',STATUS='replace') - write(unitnum)WORKA -!clt if(any(WORKA .gt.0.01)) then - if(mype==35) then - write(6,*)'thinkdebworka2 ',size(WORKA) - write(6,*)WORKA - call flush(6) - endif - - close (unitnum) - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ -!*** -!*** Adjoint test if needed -!*** - -!\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - - -!==================== Forward (Smoothing step) ======================== -!*** -!*** DONE! Deallocate variables -!*** -! call btim( output_tim) - call obj2_mgbf%mg_finalize - -! call etim( output_tim) -! call etim( total_tim) - - -!*** -!*** Print wall clock and cpu timing -!*** - call print_mg_timers("version0-timing_cpu.csv", print_cpu, obj2_mgbf%mype) - - call MPI_FINALIZE(ierr) - - -!----------------------------------------------------------------------- - endprogram RBETA_TEST diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 index 4d28dfa3d..89a919659 100644 --- a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 @@ -1,52 +1,72 @@ -! ********************************* -! * module pbfil -! * -! * R. J. Purser -! * -! * NOAA/NCEP/EMC -! * -! * March 2019 -! * -! * -! * -! ********************************* +submodule(mg_parameter) jp_pbfil +!$$$ submodule documentation block +! . . . . +! module: jp_pbfil +! prgmmr: purser org: NOAA/EMC date: 2019-03 ! -! Codes for the beta filters. -! 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. +! abstract: Codes for the beta filters ! -! Be sure to have run cholaspect, and then getlinesum, prior to applying -! the -! beta filters themselves. +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-02-20 yokota - refactoring to apply for GSI ! -! Direct dependencies: -! Libraries: jp_pmat -! Modules: jp_pkind, jp_pietc, jp_pmat -! mg_parameter +! 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 - ! -!============================================================================= -submodule(mg_parameter) jp_pbfil -!============================================================================= +! 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_pkind, only: dp use jp_pietc, only: u1 implicit none - contains !============================================================================= -module subroutine cholaspect1(lx,mx, el) ! [cholaspect] +module subroutine cholaspect1(lx,mx, el) ! [cholaspect] !============================================================================= ! Convert the given field, el, of aspect tensors into the equivalent ! field @@ -62,7 +82,7 @@ module subroutine cholaspect1(lx,mx, el) ! [cholas 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] +module subroutine cholaspect2(lx,mx, ly,my, el) ! [cholaspect] !============================================================================= ! Convert the given field, el, of aspect tensors into the equivalent ! field @@ -81,7 +101,7 @@ module subroutine cholaspect2(lx,mx, ly,my, el) ! [chola enddo; enddo end subroutine cholaspect2 !============================================================================= -module subroutine cholaspect3(lx,mx, ly,my, lz,mz, el) ! [cholaspect] +module subroutine cholaspect3(lx,mx, ly,my, lz,mz, el) ! [cholaspect] !============================================================================= ! Convert the given field, el, of aspect tensors into the equivalent ! field @@ -100,7 +120,7 @@ module subroutine cholaspect3(lx,mx, ly,my, lz,mz, el) ! [chola enddo; enddo; enddo end subroutine cholaspect3 !============================================================================= -module subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el) ! [cholaspect] +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 @@ -121,7 +141,7 @@ module subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el) ! [chola end subroutine cholaspect4 !============================================================================= -module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [getlinesum] +module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [getlinesum] !============================================================================= ! Get inverse of the line-sum of the matrix representing the ! unnormalized @@ -130,7 +150,7 @@ module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [g ! so it can be used subsequently in the normalized version of this ! filter. !============================================================================= - class(mg_parameter_type)::this +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 @@ -155,9 +175,9 @@ module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [g enddo end subroutine getlinesum1 !============================================================================= -module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum] +module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum] !============================================================================= - class(mg_parameter_type)::this +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 @@ -194,9 +214,9 @@ module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) ! [g enddo; enddo! ix, iy end subroutine getlinesum2 !============================================================================= -module subroutine getlinesum3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss)! [getlinesum] +module subroutine getlinesum3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss) ! [getlinesum] !============================================================================= - class(mg_parameter_type)::this +class(mg_parameter_type)::this integer, intent(in ):: hx,Lx,mx, & hy,ly,my, & hz,lz,mz @@ -246,9 +266,9 @@ module subroutine getlinesum3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss)! [g end subroutine getlinesum3 !============================================================================= module subroutine getlinesum4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & - el, ss) ! [getlinesum] + el, ss) ! [getlinesum] !============================================================================= - class(mg_parameter_type)::this +class(mg_parameter_type)::this integer, intent(in ):: hx,Lx,mx, & hy,ly,my, & hz,lz,mz, & @@ -309,7 +329,7 @@ module subroutine getlinesum4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & end subroutine getlinesum4 !============================================================================= -module subroutine rbeta1(this,hx,lx,mx, el,ss, a) ! [rbeta] +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 @@ -320,7 +340,7 @@ module subroutine rbeta1(this,hx,lx,mx, el,ss, a) ! The output data occupy the central region ! Lx <= ix <= Mx. !============================================================================= - class(mg_parameter_type)::this +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 @@ -347,7 +367,7 @@ module subroutine rbeta1(this,hx,lx,mx, el,ss, a) a=b end subroutine rbeta1 !============================================================================= -module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] +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 @@ -358,7 +378,7 @@ module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) ! The output data occupy the central region ! Lx <= ix <= Mx, Ly <= iy <= My. !============================================================================= - class(mg_parameter_type)::this +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 @@ -395,7 +415,7 @@ module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) a=b end subroutine rbeta2 !============================================================================= -module subroutine rbeta3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] +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 @@ -406,7 +426,7 @@ module subroutine rbeta3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! The output data occupy the central region ! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz. !============================================================================= - class(mg_parameter_type)::this +class(mg_parameter_type)::this integer, intent(in ):: hx,Lx,mx,& hy,ly,my,& hz,lz,mz @@ -450,7 +470,7 @@ module subroutine rbeta3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) 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] +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 @@ -462,7 +482,7 @@ module subroutine rbeta4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a)! ! The output data occupy the central region ! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz, Lw <= iw <= Mw. !============================================================================= - class(mg_parameter_type)::this +class(mg_parameter_type)::this integer, intent(in ):: hx,Lx,mx,& hy,ly,my,& hz,lz,mz,& @@ -519,11 +539,11 @@ 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] + el,ss,a) ! [rbeta] !============================================================================= ! Vector version of rbeta4 filtering nv fields at once. !============================================================================= - class(mg_parameter_type)::this +class(mg_parameter_type)::this integer, intent(in ):: nv, & hx,Lx,mx,& hy,ly,my,& @@ -580,7 +600,7 @@ module subroutine vrbeta4(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & end subroutine vrbeta4 !============================================================================= -module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) ! [rbetat] +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 @@ -590,7 +610,7 @@ module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) ! ! the extended domain, ! Lx-hx <= jx <= mx+hx. !============================================================================= - class(mg_parameter_type)::this +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 @@ -616,7 +636,7 @@ module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) ! a=b end subroutine rbeta1t !============================================================================= -module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] +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 @@ -626,7 +646,7 @@ module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) ! ! the extended domain, ! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy !============================================================================= - class(mg_parameter_type)::this +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 @@ -662,7 +682,7 @@ module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) ! a=b end subroutine rbeta2t !============================================================================= -module subroutine rbeta3T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] +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 @@ -672,7 +692,7 @@ module subroutine rbeta3T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! ! the extended domain, ! Lx-hx <= jx <= Mx+hx, Ly-hy <= Jy <= My+hy, Lz-hz <= Jz <= Mz+hz. !============================================================================= - class(mg_parameter_type)::this +class(mg_parameter_type)::this integer, intent(in ):: hx,Lx,mx,& hy,ly,my,& hz,lz,mz @@ -716,7 +736,7 @@ module subroutine rbeta3T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! end subroutine rbeta3t !============================================================================= module subroutine rbeta4T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & - el,ss, a) ! [rbetat] + el,ss, a) ! [rbetat] !============================================================================= ! Perform an ADJOINT radial beta-function filter in 4D. ! It conserves "masses" initially distributed only at the closure of @@ -727,7 +747,7 @@ module subroutine rbeta4T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & ! 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 +class(mg_parameter_type)::this integer, intent(in ):: hx,Lx,mx,& hy,ly,my,& hz,lz,mz,& @@ -782,11 +802,11 @@ end subroutine rbeta4t !============================================================================= module subroutine vrbeta4t(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, & - hw,lw,mw, el,ss, a)! [rbetat] + hw,lw,mw, el,ss, a) ! [rbetat] !============================================================================= ! Vector version of rbeta4t filtering nv fields at once. !============================================================================= - class(mg_parameter_type)::this +class(mg_parameter_type)::this integer, intent(in ):: nv, & hx,Lx,mx,& hy,ly,my,& @@ -842,11 +862,11 @@ end subroutine vrbeta4t ! Vector versions of the above routines: !============================================================================= -module subroutine vrbeta1(this,nv,hx,lx,mx, el,ss, a) ! [rbeta] +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 +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 @@ -875,11 +895,11 @@ module subroutine vrbeta1(this,nv,hx,lx,mx, el,ss, a) end subroutine vrbeta1 !============================================================================= -module subroutine vrbeta2(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] +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 +class(mg_parameter_type)::this integer, intent(in ):: nv, & hx,Lx,mx, & hy,ly,my @@ -918,11 +938,12 @@ module subroutine vrbeta2(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) a=b end subroutine vrbeta2 -module subroutine vrbeta3(this,nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] +!============================================================================= +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 +class(mg_parameter_type)::this integer, intent(in ):: nv, & hx,Lx,mx,& hy,ly,my,& @@ -970,11 +991,11 @@ end subroutine vrbeta3 ! Vector versions of the above routines: !============================================================================= -module subroutine vrbeta1T(this,nv, hx,lx,mx, el,ss, a) ! [rbetat] +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 +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 @@ -1001,11 +1022,11 @@ module subroutine vrbeta1T(this,nv, hx,lx,mx, el,ss, a) ! a=b end subroutine vrbeta1t !============================================================================= -module subroutine vrbeta2T(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] +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 +class(mg_parameter_type)::this integer, intent(in ):: nv, & hx,Lx,mx, & hy,ly,my @@ -1044,11 +1065,11 @@ module subroutine vrbeta2T(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! end subroutine vrbeta2t !============================================================================= -module subroutine vrbeta3T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] +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 +class(mg_parameter_type)::this integer, intent(in ):: nv, & hx,Lx,mx,& hy,ly,my,& diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 index 1724ce48c..63493f972 100644 --- a/src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 @@ -1,20 +1,28 @@ -!# -! ********************************** -! * module pbfil2 * -! * R. J. Purser * -! * NOAA/NCEP/EMC * -! * August 2019 * -! ********************************** -! Direct dependencies: -! Module: jp_pkind -! -!============================================================================= module jp_pbfil2 -!============================================================================= -! Module of data defining the exact transition rules of the decad algorithm -! based on the PG(3,2) reference geometry. An overview of this topic is given -! NOAA/NCEP Office Note 500. -!============================================================================= +!$$$ 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 diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 index 047638f50..61a693257 100644 --- a/src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 @@ -1,64 +1,96 @@ -!# -! ********************************* -! * module jp_pbfil3 * -! * R. J. Purser * -! * NOAA/NCEP/EMC * -! * August 2021 * -! * jim.purser@noaa.gov * -! ********************************* +module jp_pbfil3 +!$$$ module documentation block +! . . . . +! module: jp_pbfil3 +! prgmmr: purser org: NOAA/EMC date: 2021-08 ! -! Codes for the beta line filters. +! abstract: Codes for the beta line filters ! -! -! Direct dependencies: -! Libraries: jp_pmat -! Modules: jp_pkind, jp_pkind2, jp_pietc, jp_pmat4, jp_pbfil2 +! 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 - ! -!============================================================================= -module jp_pbfil3 -!============================================================================= -! 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. +! Functions Included: ! -! 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. +! 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. ! -! 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 -!# -!============================================================================= +! 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 diff --git a/src/saber/mgbf/mgbf_lib/jp_pietc.f90 b/src/saber/mgbf/mgbf_lib/jp_pietc.f90 old mode 100755 new mode 100644 index 51ad5ae09..b102d22b7 --- a/src/saber/mgbf/mgbf_lib/jp_pietc.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pietc.f90 @@ -1,15 +1,30 @@ -! -!============================================================================= module jp_pietc -!============================================================================= -! R. J. Purser (jim.purser@noaa.gov) 2014 -! Some of the commonly used constants (pi etc) mainly for double-precision -! subroutines. -! 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. -!============================================================================= +!$$$ 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 diff --git a/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 b/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 index d445eafd0..8f3097225 100644 --- a/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 @@ -1,17 +1,29 @@ -! -!============================================================================= module jp_pietc_s -!============================================================================= -! R. J. Purser (jim.purser@noaa.gov) -! 2014 -! Some of the commonly used constants (pi etc) -! 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. +!$$$ 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 diff --git a/src/saber/mgbf/mgbf_lib/jp_pkind.f90 b/src/saber/mgbf/mgbf_lib/jp_pkind.f90 old mode 100755 new mode 100644 index 7e602c17a..cdbf19f4e --- a/src/saber/mgbf/mgbf_lib/jp_pkind.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pkind.f90 @@ -1,4 +1,24 @@ 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),& diff --git a/src/saber/mgbf/mgbf_lib/jp_pkind2.f90 b/src/saber/mgbf/mgbf_lib/jp_pkind2.f90 index e35545a1a..3dcecc563 100644 --- a/src/saber/mgbf/mgbf_lib/jp_pkind2.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pkind2.f90 @@ -1,6 +1,24 @@ -!=================================================================== -module jp_pkind2 ! Integer kinds for helf- and fourth-precision integers -!=================================================================== +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) diff --git a/src/saber/mgbf/mgbf_lib/jp_pmat.f90 b/src/saber/mgbf/mgbf_lib/jp_pmat.f90 old mode 100755 new mode 100644 index 504cab0da..f139feea0 --- a/src/saber/mgbf/mgbf_lib/jp_pmat.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pmat.f90 @@ -1,33 +1,46 @@ +module jp_pmat +!$$$ module documentation block +! . . . . +! module: jp_pmat +! prgmmr: fujita org: NOAA/EMC date: 1993 ! -! ********************************************** -! * MODULE jp_pmat * -! * R. J. Purser, NOAA/NCEP/EMC 1993 * -! * and Tsukasa Fujita, visiting scientist * -! * from JMA. * -! * Major modifications: 2002, 2009, 2012 * -! * jim.purser@noaa.gov * -! * * -! ********************************************** +! abstract: Utility routines for various linear inversions and Cholesky ! -! Utility routines for various linear inversions and Cholesky. -! Dependency: modules jp_pkind, jp_pietc -! 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. -! -! DIRECT DEPENDENCIES: -! Modules: jp_pkind, jp_pietc +! module history log: +! 2002 purser +! 2009 purser +! 2012 purser ! -!============================================================================= -module jp_pmat -!============================================================================= +! 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 diff --git a/src/saber/mgbf/mgbf_lib/jp_pmat4.f90 b/src/saber/mgbf/mgbf_lib/jp_pmat4.f90 index 713ca6108..552d5efde 100644 --- a/src/saber/mgbf/mgbf_lib/jp_pmat4.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pmat4.f90 @@ -1,60 +1,86 @@ +module jp_pmat4 +!$$$ module documentation block +! . . . . +! module: jp_pmat4 +! prgmmr: purser org: NOAA/EMC date: 2005-10 ! -! ********************************************** -! * MODULE jp_pmat4 * -! * R. J. Purser, NOAA/NCEP/EMC Oct 2005 * -! * 18th May 2012 * -! * jim.purser@noaa.gov * -! * * -! ********************************************** +! abstract: Euclidean geometry, geometric (stereographic) projections, +! related transformations (Mobius) ! -! Euclidean geometry, geometric (stereographic) projections, -! related transformations (Mobius). -! 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. +! 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. ! -! May 2017: 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. ! -! FUNCTION: -! 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 -! SUBROUTINE: -! 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 - ! -! 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. +! 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 - ! -! DIRECT DEPENDENCIES -! Libraries[their Modules]: jp_pmat[pmat] -! Additional Modules : pkind, jp_pietc, jp_pietc_s +! 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. ! -!============================================================================ -module jp_pmat4 -!============================================================================ +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + use mpi use jp_pkind, only: spi,sp,dp,dpc implicit none diff --git a/src/saber/mgbf/mgbf_lib/kinds.f90 b/src/saber/mgbf/mgbf_lib/kinds.f90 old mode 100755 new mode 100644 index 6a0a5481d..678085a99 --- a/src/saber/mgbf/mgbf_lib/kinds.f90 +++ b/src/saber/mgbf/mgbf_lib/kinds.f90 @@ -96,9 +96,6 @@ module kinds ! Default values ! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND *** -!misha -!#define _REAL8 1 -!misha !#ifdef _REAL4_ ! integer, parameter, private :: default_real = 1 ! 1=single, !#endif @@ -109,7 +106,13 @@ module kinds ! integer, parameter, private :: default_real = 3 ! 3=quad !#endif integer, parameter, public :: r_kind = real_kinds( default_real ) + integer, parameter, public :: dp = real_kinds( default_real ) + integer, parameter, public :: sp = r_single integer, parameter, public :: num_bytes_for_r_kind = & real_byte_sizes( default_real ) + integer,parameter, public :: spc=kind((1.0,1.0)) + integer,parameter, public :: dpc=kind((1.0d0,1.0d0)) + private:: one_dpi; integer(8),parameter:: one_dpi=1 + integer,parameter , public :: dpi=kind(one_dpi) end module kinds diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 old mode 100755 new mode 100644 index 4693986a2..05de3c97d --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -1,22 +1,70 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - submodule(mg_intstate) mg_bocos -!*********************************************************************** -! ! -! Provide communication between subdomains and supply halos on ! -! filter grid ! -! - offset version - ! -! ! -! Libraries: mpi ! -! Modules: kinds, mg_mppstuff, mg_parameter, mg_domain ! -! M. Rancic (2022) ! -!*********************************************************************** -!use mpi -use kinds, only: r_kind,i_kind -!use mpimod, only: mype,mpi_comm_world +submodule(mg_intstate) mg_bocos +!$$$ submodule documentation block +! . . . . +! module: mg_bocos +! prgmmr: rancic org: NCEP/EMC date: 2022 +! +! abstract: Provide communication between subdomains and supply halos +! on filter grid (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: +! boco_2d_g1 - +! boco_2d_gh - +! bocoT_2d_g1 - +! bocoT_2d_gh - +! boco_3d_g1 - +! boco_3d_gh - +! bocoT_3d_g1 - +! bocoT_3d_gh - +! upsend_all_g1 - +! upsend_all_gh - +! downsend_all_gh - +! downsend_all_g2 - +! bocox_2d_g1 - +! bocox_2d_gh - +! bocoy_2d_g1 - +! bocoy_2d_gh - +! bocoTx_2d_g1 - +! bocoTx_2d_gh - +! bocoTy_2d_g1 - +! bocoTy_2d_gh - +! boco_2d_loc - +! bocoT_2d_loc - +! upsend_loc_g12 - +! upsend_loc_g23 - +! upsend_loc_g34 - +! downsend_loc_g43 - +! downsend_loc_g32 - +! downsend_loc_g21 - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block +use kinds, only: r_kind,i_kind implicit none +interface boco_2d + module procedure boco_2d_g1 + module procedure boco_2d_gh +endinterface + +interface bocoT_2d + module procedure bocoT_2d_g1 + module procedure bocoT_2d_gh +endinterface interface boco_3d module procedure boco_3d_g1 @@ -58,11 +106,11 @@ module procedure bocoTy_2d_gh endinterface !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - contains +contains !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine boco_2d_g1 & +module subroutine boco_2d_g1 & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -74,17 +122,13 @@ module subroutine boco_2d_g1 & !**********************************************************************! (this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- - -use mpi !clt - +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 @@ -98,9 +142,9 @@ module subroutine boco_2d_g1 & integer(i_kind) ndatax,ndatay,nbxy integer(i_kind) g_ind,g logical l_sidesend -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- ! @@ -399,10 +443,10 @@ module subroutine boco_2d_g1 & !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !----------------------------------------------------------------------- - endsubroutine boco_2d_g1 +endsubroutine boco_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine boco_2d_gh & +module subroutine boco_2d_gh & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -414,17 +458,14 @@ module subroutine boco_2d_gh & !**********************************************************************! (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mpi !clt - +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 @@ -438,9 +479,9 @@ module subroutine boco_2d_gh & integer(i_kind) ndatax,ndatay integer(i_kind) g_ind,g logical l_sidesend -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- ! @@ -762,10 +803,10 @@ module subroutine boco_2d_gh & !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !----------------------------------------------------------------------- - endsubroutine boco_2d_gh +endsubroutine boco_2d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocoT_2d_g1 & +module subroutine bocoT_2d_g1 & !*********************************************************************** ! ! ! Adjoint of side sending subroutine: ! @@ -778,16 +819,13 @@ module subroutine bocoT_2d_g1 & !*********************************************************************** (this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- -use mpi !clt - +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 @@ -802,9 +840,9 @@ module subroutine bocoT_2d_g1 & logical l_sidesend integer(i_kind) g_ind,g,k !----------------------------------------------------------------------- -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" ! ! Limit comminications to selected number of generations @@ -1072,10 +1110,10 @@ module subroutine bocoT_2d_g1 & !----------------------------------------------------------------------- - endsubroutine bocoT_2d_g1 +endsubroutine bocoT_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocoT_2d_gh & +module subroutine bocoT_2d_gh & !*********************************************************************** ! ! ! Supply n-lines inside of domains, including edges, with halos from ! @@ -1087,17 +1125,14 @@ module subroutine bocoT_2d_gh & !*********************************************************************** (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mpi !clt - +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 @@ -1111,9 +1146,9 @@ module subroutine bocoT_2d_gh & logical l_sidesend integer(i_kind) g_ind,g,k !----------------------------------------------------------------------- -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" ! ! Limit comminications to selected number of generations @@ -1405,10 +1440,10 @@ module subroutine bocoT_2d_gh & !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !----------------------------------------------------------------------- - endsubroutine bocoT_2d_gh +endsubroutine bocoT_2d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine boco_3d_g1 & +module subroutine boco_3d_g1 & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -1420,10 +1455,8 @@ module subroutine boco_3d_g1 & !**********************************************************************! (this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) !----------------------------------------------------------------------- -use mpi !clt - +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 @@ -1446,9 +1479,9 @@ module subroutine boco_3d_g1 & integer(i_kind) g_ind,g logical l_sidesend !----------------------------------------------------------------------- -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" ! ! Limit communications to generation one @@ -1759,10 +1792,10 @@ module subroutine boco_3d_g1 & !----------------------------------------------------------------------- - endsubroutine boco_3d_g1 +endsubroutine boco_3d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine boco_3d_gh & +module subroutine boco_3d_gh & !**********************************************************************! ! Side sending subroutine: ! @@ -1774,11 +1807,8 @@ 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) !----------------------------------------------------------------------- - -use mpi !clt - +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 @@ -1800,9 +1830,9 @@ module subroutine boco_3d_gh & integer(i_kind) ndatax,ndatay integer(i_kind) g_ind,g logical l_sidesend -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- ! @@ -2158,10 +2188,10 @@ module subroutine boco_3d_gh & !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !----------------------------------------------------------------------- - endsubroutine boco_3d_gh +endsubroutine boco_3d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocoT_3d_g1 & +module subroutine bocoT_3d_g1 & !*********************************************************************** ! * ! Supply n-lines inside of domains, including edges, with halos from * @@ -2173,11 +2203,9 @@ module subroutine bocoT_3d_g1 & !*********************************************************************** (this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) !----------------------------------------------------------------------- -use mpi !clt - +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) & @@ -2198,9 +2226,9 @@ module subroutine bocoT_3d_g1 & integer(i_kind) ndatax,ndatay logical l_sidesend integer(i_kind) g_ind,g,k -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- ! @@ -2518,10 +2546,10 @@ module subroutine bocoT_3d_g1 & !----------------------------------------------------------------------- - endsubroutine bocoT_3d_g1 +endsubroutine bocoT_3d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocoT_3d_gh & +module subroutine bocoT_3d_gh & !*********************************************************************** ! * ! Supply n-lines inside of domains, including edges, with halos from * @@ -2532,19 +2560,16 @@ 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) - !----------------------------------------------------------------------- -use mpi !clt +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 @@ -2558,9 +2583,9 @@ module subroutine bocoT_3d_gh & integer(i_kind) ndatax,ndatay logical l_sidesend integer(i_kind) g_ind,g,k -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- ! @@ -2902,10 +2927,10 @@ module subroutine bocoT_3d_gh & !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !----------------------------------------------------------------------- - endsubroutine bocoT_3d_gh +endsubroutine bocoT_3d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine upsend_all_g1 & +module subroutine upsend_all_g1 & !*********************************************************************** ! ! ! Upsend data from generation one to generation two ! @@ -2915,17 +2940,13 @@ module subroutine upsend_all_g1 & !*********************************************************************** (this,Harray,Warray,km_in) !----------------------------------------------------------------------- -use mpi !cltthink - +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 & @@ -2944,9 +2965,9 @@ module subroutine upsend_all_g1 & 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_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- @@ -3204,12 +3225,12 @@ module subroutine upsend_all_g1 & !----------------------------------------------------------------------- - endsubroutine upsend_all_g1 +endsubroutine upsend_all_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine upsend_all_gh & +module subroutine upsend_all_gh & !*********************************************************************** ! * ! Upsend data from one grid generation to another * @@ -3219,20 +3240,15 @@ module subroutine upsend_all_gh & ! * !*********************************************************************** (this,Harray,Warray,km_in,mygen_dn,mygen_up) -!cltthink km is this%km !----------------------------------------------------------------------- -use mpi !cltthink - +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 & @@ -3250,9 +3266,9 @@ module subroutine upsend_all_gh & 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_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- @@ -3277,12 +3293,6 @@ module subroutine upsend_all_gh & endif ndata =km_in*imL*jmL -!TEST -! if(mype==0) then -! write(0,*) 'From upsend_all_gh.f90: ndata=',ndata -! endif -!TEST - if( lsendup_sw ) then @@ -3296,9 +3306,6 @@ module subroutine upsend_all_gh & sBuf_SW(:,i,j) = Harray(:,i,j) enddo enddo -!TEST -! write(0,*) 'UPSEND_ALL_GH SW: ndata,mype,nepbe=',ndata,mype,nebpe -!TEST call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & mpi_comm_work, sHandle(1), isend) @@ -3330,10 +3337,6 @@ module subroutine upsend_all_gh & enddo endif -!TEST -! call finishMPI -!TEST - ! ! --- Send data to SE portion of processors at higher generation @@ -3447,9 +3450,6 @@ module subroutine upsend_all_gh & sBuf_NE(:,i,j) = Harray(:,i,j) enddo enddo -!TEST -! write(0,*) 'UPSEND_ALL_GH NE: ndata,mype,nepbe,mygen_up',ndata,mype,nebpe,mygen_up -!TEST call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & mpi_comm_work, sHandle(4), isend) @@ -3484,15 +3484,11 @@ module subroutine upsend_all_gh & endif -!TEST -! call finishMPI -!TEST - !----------------------------------------------------------------------- - endsubroutine upsend_all_gh +endsubroutine upsend_all_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine downsend_all_gh & +module subroutine downsend_all_gh & !*********************************************************************** ! * ! Downsending data from low resolution pes (mygen_up) * @@ -3504,18 +3500,15 @@ module subroutine downsend_all_gh & !*********************************************************************** (this,Warray,Harray,km_in,mygen_up,mygen_dn) !----------------------------------------------------------------------- -use mpi !clt - +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 @@ -3532,9 +3525,9 @@ module subroutine downsend_all_gh & 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_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- @@ -3743,10 +3736,10 @@ module subroutine downsend_all_gh & end if !----------------------------------------------------------------------- - endsubroutine downsend_all_gh +endsubroutine downsend_all_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine downsend_all_g2 & +module subroutine downsend_all_g2 & !*********************************************************************** ! * ! Downsending data from low resolution pes (mygen_up) * @@ -3758,17 +3751,14 @@ module subroutine downsend_all_g2 & !*********************************************************************** (this,Warray,Harray,km_in) !----------------------------------------------------------------------- -use mpi !clt - +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 @@ -3786,9 +3776,9 @@ module subroutine downsend_all_g2 & integer(i_kind):: itarg_up integer(i_kind):: g_ind !----------------------------------------------------------------------- -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" ! ! Define generational flags @@ -4040,10 +4030,10 @@ module subroutine downsend_all_g2 & !----------------------------------------------------------------------- - endsubroutine downsend_all_g2 +endsubroutine downsend_all_g2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocox_2d_g1 & +module subroutine bocox_2d_g1 & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -4055,17 +4045,13 @@ module subroutine bocox_2d_g1 & !**********************************************************************! (this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- - -use mpi !#clt - +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 @@ -4077,9 +4063,9 @@ module subroutine bocox_2d_g1 & integer(i_kind) isend,irecv,nebpe integer(i_kind) ndatax integer(i_kind) g_ind,g -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- ! @@ -4250,10 +4236,10 @@ module subroutine bocox_2d_g1 & !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !----------------------------------------------------------------------- - endsubroutine bocox_2d_g1 +endsubroutine bocox_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocox_2d_gh & +module subroutine bocox_2d_gh & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -4265,18 +4251,14 @@ module subroutine bocox_2d_gh & !**********************************************************************! (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- - -use mpi !clt - +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 @@ -4289,9 +4271,9 @@ module subroutine bocox_2d_gh & integer(i_kind) ndatax integer(i_kind) g_ind,g logical l_sidesend -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- ! @@ -4483,10 +4465,10 @@ module subroutine bocox_2d_gh & !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !----------------------------------------------------------------------- - endsubroutine bocox_2d_gh +endsubroutine bocox_2d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocoy_2d_g1 & +module subroutine bocoy_2d_g1 & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -4498,12 +4480,9 @@ module subroutine bocoy_2d_g1 & !**********************************************************************! (this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- - -use mpi !clt - +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 @@ -4519,9 +4498,9 @@ module subroutine bocoy_2d_g1 & integer(i_kind) isend,irecv,nebpe integer(i_kind) ndatay integer(i_kind) g_ind,g -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- ! @@ -4688,10 +4667,10 @@ module subroutine bocoy_2d_g1 & !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !----------------------------------------------------------------------- - endsubroutine bocoy_2d_g1 +endsubroutine bocoy_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocoy_2d_gh & +module subroutine bocoy_2d_gh & !**********************************************************************! ! ! ! Side sending subroutine: ! @@ -4703,18 +4682,14 @@ module subroutine bocoy_2d_gh & !**********************************************************************! (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- - -use mpi !clt - +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 @@ -4727,9 +4702,9 @@ module subroutine bocoy_2d_gh & integer(i_kind) ndatay integer(i_kind) g_ind,g logical l_sidesend -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- ! @@ -4918,10 +4893,10 @@ module subroutine bocoy_2d_gh & !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !----------------------------------------------------------------------- - endsubroutine bocoy_2d_gh +endsubroutine bocoy_2d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocoTx_2d_g1 & +module subroutine bocoTx_2d_g1 & !*********************************************************************** ! ! ! Side sending subroutine: ! @@ -4934,17 +4909,13 @@ module subroutine bocoTx_2d_g1 & !*********************************************************************** (this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- -use mpi !clt - +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 @@ -4958,9 +4929,9 @@ module subroutine bocoTx_2d_g1 & logical l_sidesend integer(i_kind) g_ind,g,k !----------------------------------------------------------------------- -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" ! ! Limit comminications to selected number of generations @@ -5115,10 +5086,10 @@ module subroutine bocoTx_2d_g1 & end if !----------------------------------------------------------------------- - endsubroutine bocoTx_2d_g1 +endsubroutine bocoTx_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocoTx_2d_gh & +module subroutine bocoTx_2d_gh & !*********************************************************************** ! ! ! Side sending subroutine: ! @@ -5131,17 +5102,14 @@ module subroutine bocoTx_2d_gh & !*********************************************************************** (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mpi !clt - +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 @@ -5154,9 +5122,9 @@ module subroutine bocoTx_2d_gh & logical l_sidesend integer(i_kind) g_ind,g,k !----------------------------------------------------------------------- -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" ! ! Limit comminications to selected number of generations @@ -5230,7 +5198,7 @@ module subroutine bocoTx_2d_gh & if( itarg_e >= 0 ) then nebpe = itarg_e - allocate( sBuf_E(1:km_in,0:nbx,0:jmax), stat = iaerr ) + allocate( sBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr ) do j=1,jmax do i=1,nbx @@ -5334,10 +5302,10 @@ module subroutine bocoTx_2d_gh & !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !----------------------------------------------------------------------- - endsubroutine bocoTx_2d_gh +endsubroutine bocoTx_2d_gh !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocoTy_2d_g1 & +module subroutine bocoTy_2d_g1 & !*********************************************************************** ! ! ! Side sending subroutine: ! @@ -5350,16 +5318,13 @@ module subroutine bocoTy_2d_g1 & !*********************************************************************** (this,W,km_in,im_in,jm_in,nbx,nby) !----------------------------------------------------------------------- -use mpi !clt - +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 @@ -5373,9 +5338,9 @@ module subroutine bocoTy_2d_g1 & logical l_sidesend integer(i_kind) g_ind,g,k !----------------------------------------------------------------------- -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" ! ! Limit comminications to selected number of generations @@ -5527,10 +5492,10 @@ module subroutine bocoTy_2d_g1 & !----------------------------------------------------------------------- - endsubroutine bocoTy_2d_g1 +endsubroutine bocoTy_2d_g1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine bocoTy_2d_gh & +module subroutine bocoTy_2d_gh & !*********************************************************************** ! ! ! Side sending subroutine: ! @@ -5543,17 +5508,14 @@ module subroutine bocoTy_2d_gh & !*********************************************************************** (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) !----------------------------------------------------------------------- -use mpi !clt - +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 @@ -5565,9 +5527,9 @@ module subroutine bocoTy_2d_gh & integer(i_kind) ndatay logical l_sidesend integer(i_kind) g_ind,g,k -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- ! @@ -5749,7 +5711,2306 @@ module subroutine bocoTy_2d_gh & !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff !----------------------------------------------------------------------- - endsubroutine bocoTy_2d_gh +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 +end submodule mg_bocos diff --git a/src/saber/mgbf/mgbf_lib/mg_domain.f90 b/src/saber/mgbf/mgbf_lib/mg_domain.f90 old mode 100755 new mode 100644 index 53351c6e7..d56d1a5f9 --- a/src/saber/mgbf/mgbf_lib/mg_domain.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_domain.f90 @@ -1,70 +1,79 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - submodule(mg_parameter) mg_domain -!**********************************************************************! -! ! -! Definition of a squared integration domain ! -! ! -! Modules: kinds, mg_mppstuff, mg_parameter ! -! M. Rancic (2020) ! -!**********************************************************************! +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 -!use mpimod, only: mype implicit none - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - contains +contains !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine init_mg_domain(this) +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) +class(mg_parameter_type)::this +call init_domain(this) +call init_topology_2d(this) !----------------------------------------------------------------------- - endsubroutine init_mg_domain +endsubroutine init_mg_domain !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine init_domain(this) +module subroutine init_domain(this) !*********************************************************************** ! * ! Definition of constants that control filtering domain * ! * !*********************************************************************** - implicit none - class(mg_parameter_type),target::this - +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" +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" !----------------------------------------------------------------------- -!TEST -! if(mype==0) then -! print *,'FROM INIT_DOMAIN: nxm,mym=',nxm,mym -! endif -!TEST Flwest(1)=nx.eq.1 Fleast(1)=nx.eq.nxm Flsouth(1)=my.eq.1 - Flnorth(1)=my.eq.mym + Flnorth(1)=my.eq.nym if(l_hgen) then @@ -113,7 +122,7 @@ module subroutine init_domain(this) itarg_sA=mype-nxm endif - if(my==mym) then + if(my==nym) then itarg_nA=-1 else itarg_nA=mype+nxm @@ -122,7 +131,7 @@ module subroutine init_domain(this) lwestA=nx.eq.1 leastA=nx.eq.nxm lsouthA=my.eq.1 - lnorthA=my.eq.mym + lnorthA=my.eq.nym !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> @@ -155,28 +164,25 @@ module subroutine init_domain(this) !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> !----------------------------------------------------------------------- - endsubroutine init_domain +endsubroutine init_domain !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine init_topology_2d(this) +module subroutine init_topology_2d(this) !*********************************************************************** ! * ! Define topology of filter grid * ! - Four generations - * ! * !*********************************************************************** - implicit none - class(mg_parameter_type),target::this - +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" +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" !----------------------------------------------------------------------- ! ! Topology of generations of the squared domain @@ -207,8 +213,8 @@ module subroutine init_topology_2d(this) ! | | | | | | | | | ! | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | ! |_____|_____|_____|_____|_____|_____|_____|_____| - - +! +! ! G2 ! ___________ ___________ ___________ ___________ ! | | | | | @@ -235,8 +241,8 @@ module subroutine init_topology_2d(this) ! | | | | | ! | | | | | ! |___________|___________|___________|___________| - - +! +! ! G3 ! _______________________ _______________________ ! | | | @@ -263,8 +269,8 @@ module subroutine init_topology_2d(this) ! | | | ! | | | ! |_______________________|_______________________| - - +! +! ! G4 ! _______________________________________________ ! | | @@ -291,7 +297,7 @@ module subroutine init_topology_2d(this) ! | | ! | | ! |_______________________________________________| - +! !---------------------------------------------------------------------- do g = 1,2 @@ -502,18 +508,6 @@ module subroutine init_topology_2d(this) endif -!TEST -! if(mype_hgen>-1.and.my_hgen 1) then -! if(mype_hgen> 2) then -! write(200+mype_hgen,'(a,3i5)') 'mype_hgen,mype,my_hgen=',mype_hgen,mype,my_hgen -! write(200+mype_hgen,'(a,i5)') 'itargdn_sw=',itargdn_sw -! write(200+mype_hgen,'(a,i5)') 'itargdn_se=',itargdn_se -! write(200+mype_hgen,'(a,i5)') 'itargdn_nw=',itargdn_nw -! write(200+mype_hgen,'(a,i5)') 'itargdn_ne=',itargdn_ne -! write(200+mype_hgen,'(a)') ' ' -! endif -! call finishMPI -!TEST - -!TEST -! write(100+mype,'(a,2i5)') 'mype=',mype -! write(100+mype,'(a,i5)') 'Fitarg_up=',Fitarg_up(1) -! if(Flsendup_sw(1)) then -! write(100+mype,'(a,l5)') 'Flsendup_sw=',Flsendup_sw(1) -! endif -! if(Flsendup_se(1)) then -! write(100+mype,'(a,l5)') 'Flsendup_se=',Flsendup_se(1) -! endif -! if(Flsendup_nw(1)) then -! write(100+mype,'(a,l5)') 'Flsendup_nw=',Flsendup_nw(1) -! endif -! if(Flsendup_ne(1)) then -! write(100+mype,'(a,l5)') 'Flsendup_ne=',Flsendup_ne(1) -! endif -! write(100+mype,'(a)') ' ' -! -! if(mype_hgen>-1.and.my_hgen>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! write(200+mype_filt,'(a)')'---------------------------------' ! write(200+mype_filt,'(a)')'From init_topology_2d' @@ -670,12 +598,6 @@ module subroutine init_topology_2d(this) ! 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)')' ' -!TEST -! if(my_hgen == 2) then -! write(100+mype,'(a,2i5)')'mype,itargdn_se=',mype,itargdn_se -! endif -! call finishMPI -!TEST ! 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) @@ -695,10 +617,10 @@ module subroutine init_topology_2d(this) ! call finishMPI !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> !----------------------------------------------------------------------- - endsubroutine init_topology_2d +endsubroutine init_topology_2d !---------------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine real_itarg & +module subroutine real_itarg & !*********************************************************************** ! * ! Definite real targets for high generations * @@ -707,17 +629,16 @@ module subroutine real_itarg & (this,itarg) !----------------------------------------------------------------------- implicit none - class(mg_parameter_type),target::this +class(mg_parameter_type),target::this integer(i_kind), intent(inout):: itarg -include "type_parameter_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" !----------------------------------------------------------------------- - if(itarg>-1) then - itarg = itarg-nxy(1) - endif - +if(itarg>-1) then + itarg = itarg-nxy(1) +endif !----------------------------------------------------------------------- - endsubroutine real_itarg +endsubroutine real_itarg !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - end submodule mg_domain +end submodule mg_domain diff --git a/src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 b/src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 new file mode 100644 index 000000000..183a5f23d --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/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 - +call this%init_mg_domain +if(this%l_loc) then + call this%init_domain_loc +endif !--------------------------------------------------------------------------- ! @@ -73,72 +85,52 @@ module subroutine mg_initialize(this,inputfilename,obj_parameter) !*** depending on specific application !*** - if(this%l_filt) then - this%km2 = this%km2_f - this%km3 = this%km3_f - else - this%km2 = this%km2_e - this%km3 = this%km3_e - endif - write(6,*)'thinkdeb33 ',this%km2,this%km3,this%lm -!cltdebug this%km2=0;this%km3=0 !cltthinktodo this is not defined in the test case - !using - !/scratch1/NCEPDEV/da/Miodrag.Rancic/Mars_Jul05_2022/RUN/mgbf.nml_offset - this%km = this%km2+this%lm*this%km3 - !*** !*** Allocate variables, define weights, prepare mapping !*** between analysis and filter grid !*** - call this%allocate_mg_intstate !(this%km) !cltthink +call this%allocate_mg_intstate - call this%def_offset_coef +call this%def_offset_coef - call this%def_mg_weights +call this%def_mg_weights - if( this%mgbf_line) then - call this%init_mg_line - endif +if(this%mgbf_line) then + call this%init_mg_line +endif - call this%lsqr_mg_coef +call this%lsqr_mg_coef -!for now call lwq_vertical_coef(lm ,lmf,cvf1,cvf2,cvf3,cvf4,lref) -!for now call lwq_vertical_coef(lmf,lmh,cvh1,cvh2,cvh3,cvh4,lref_h) +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( 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) - -!clt WORKA(:,:,:)=0. -!TEST -! call finishMPI -!TEST +!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 +endsubroutine mg_initialize !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine mg_finalize(this) +module subroutine mg_finalize(this) !**********************************************************************! ! ! ! Finalize multigrid Beta Function ! ! M. Rancic (2020) ! !*********************************************************************** -!clt #use mg_parameter, only: nm,mm implicit none class (mg_intstate_type)::this @@ -148,21 +140,19 @@ module subroutine mg_finalize(this) !----------------------------------------------------------------------- if(this%ldelta) then - -! -! Horizontal cross-section -! -nm=this%nm -mm=this%mm -lm=this%lm + ! + ! Horizontal cross-section + ! + nm=this%nm + mm=this%mm + lm=this%lm endif - call this%barrierMPI - +if(this%nxm*this%nym>1) call this%barrierMPI - call this%deallocate_mg_intstate +call this%deallocate_mg_intstate !----------------------------------------------------------------------- - endsubroutine mg_finalize +endsubroutine mg_finalize !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - end submodule mg_entrymod +end submodule mg_entrymod diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index 0b5f593f0..714a4b6bf 100644 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -1,1271 +1,1245 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - submodule(mg_intstate) mg_filtering -!*********************************************************************** -! ! -! Contains all multigrid filtering prodecures ! -! ! -! M. Rancic (2020) ! -!*********************************************************************** +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 -!clt use jp_pbfil, only: rbeta,rbetaT use jp_pbfil3, only: dibetat,dibeta use mpi - - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - contains +contains !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine mg_filtering_procedure(this,mg_filt) +module subroutine filtering_procedure(this,mg_filt,mg_filt_flag) !*********************************************************************** ! ! ! Driver for Multigrid filtering procedures with Helmholtz operator ! ! ! -! 1, 2, 3: Radial filter ! -! 1: 2d radial filter for all variables ! -! -> 2: 2d radial filter with 1d in vertical for 3d variables ! -! 3: 3d radial filter for 3d variables ! -! ! -! 4, 5, 6: Line filter ! -! 4: 2d line filter for all variables ! -! 5: 2d line filter with 1d in vertical for 3d variables ! -! 6: 3d line filter for 3d variables ! -! ! -! ! !*********************************************************************** implicit none class(mg_intstate_type),target::this - integer(i_kind),intent(in):: mg_filt -include "type_parameter_locpointer.inc" +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_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- - if(mgbf_line) then - if(mg_filt<4) then - print*,'("Line filters have options 4-6")' - stop - endif - else - if(mg_filt>3) then - print*,'("Radial filters have options 1-3")' - stop - endif - endif - select case(mg_filt) - case(1) - call this%mg_filtering_rad1 - case(2) - call this%mg_filtering_rad2 - case(3) - call this%mg_filtering_rad3 - case(4) - call this%mg_filtering_lin1 - case(5) - call this%mg_filtering_lin2 - case(6) - call this%mg_filtering_lin3 - case default - call this%mg_filtering_fast - end select - +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 mg_filtering_procedure +endsubroutine filtering_procedure !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine mg_filtering_rad1(this) +module subroutine filtering_rad3(this) !*********************************************************************** ! ! -! Multigrid filtering procedure 1: ! +! Multigrid filtering procedure: ! ! ! ! - Multiple of 2D and 3D variables ! ! - 1 upsending and downsending ! ! - Applicaton of Helmholtz differential operator ! -! - 2d radial filter only for all variables ! +! - 3d radial filter ! ! ! !*********************************************************************** +!----------------------------------------------------------------------- implicit none -class(mg_intstate_type),target:: this - -integer(i_kind) L,i,j,g -include "type_parameter_locpointer.inc" +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_parameter_point2this.inc" include "type_intstat_point2this.inc" -!----------------------------------------------------------------------- - - -!==================== Adjoint (Conservative step) ====================== +!---------------------------------------------------------------------- +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 (Step 1) +!*** Adjoint interpolate and upsend !*** - - call btim( upsend_tim) - call this%upsending_all(VALL,HALL,lquart) - call etim( upsend_tim) -!---------------------------------------------------------------------- - - -!---------------------------------------------------------------------- - + 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( bfiltT_tim) - - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - call this%rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) - if(l_hgen) then - call this%rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + 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) - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - write(6,*)'thinkdeb33 1 ', km,im,jm,hx,hy - 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( bfiltT_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) - - + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) !*** -!*** Apply Beta filter at all generations +!*** 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( bfilt_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) - - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -! -! Filtering -! - - call this%rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) + 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%rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + 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 - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - call etim( bfilt_tim) - + call etim(hfilt_tim) !*** -!*** Downsend, interpolate and add, then zero high generations +!*** Downsend, interpolate and add +!*** Then zero high generations !*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) - call btim( dnsend_tim) - call this%downsending_all(HALL,VALL,lquart) - - call etim( dnsend_tim) - - +deallocate(VM3D) +deallocate(VM2D) +deallocate(HM3D) +deallocate(HM2D) !----------------------------------------------------------------------- - endsubroutine mg_filtering_rad1 +endsubroutine filtering_rad3 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine mg_filtering_rad2(this) +module subroutine filtering_lin3(this) !*********************************************************************** ! ! -! Multigrid filtering procedure 2: ! +! Multigrid filtering procedure: ! ! ! -! - Multiple of 2D and 3D variables ! +! - Multiple of 2D line filter ! ! - 1 upsending and downsending ! ! - Applicaton of Helmholtz differential operator ! -! - 2d radial filter + 1d vertical filter ! +! - 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 - -integer(i_kind) L,i,j -include "type_parameter_locpointer.inc" +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_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- - -allocate(VM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. -allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. -allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. -allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. - - - -!==================== Adjoint (Conservative step) ====================== +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 +!*** Adjoint interpolate and upsend !*** - - call btim( upsend_tim) - call this%upsending_all(VALL,HALL,lquart) - call etim( upsend_tim) -!---------------------------------------------------------------------- - - -!---------------------------------------------------------------------- - + 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( bfiltT_tim) - - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - call this%rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) - call this%stack_to_composite(VALL,VM2D,VM3D) +! +! From single stack to composite variables +! + call btim(hfiltT_tim) + call this%stack_to_composite(VALL,VM2D,VM3D) if(l_hgen) then - call this%rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) - call this%stack_to_composite(HALL,HM2D,HM3D) + 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 - call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call this%composite_to_stack(VM2D,VM3D,VALL) + 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 - call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call this%composite_to_stack(HM2D,HM3D,HALL) - endif - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - - write(6,*)'thinkdeb33 2 ', km,im,jm,hx,hy - 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( bfiltT_tim) + 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) - - + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) !*** -!*** Apply Beta filter at all generations (Step 7) +!*** Apply Beta filter at all generations !*** - call btim( bfilt_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) - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff ! -! Filtering +! From single stacked to composite variables ! - - call this%rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) - call this%stack_to_composite(VALL,VM2D,VM3D) - if(this%l_hgen) then - call this%rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) - call this%stack_to_composite(HALL,HM2D,HM3D) - endif - - call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call this%composite_to_stack(VM2D,VM3D,VALL) + call btim(hfilt_tim) + call this%stack_to_composite(VALL,VM2D,VM3D) if(l_hgen) then - call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call this%composite_to_stack(HM2D,HM3D,HALL) - endif - call this%barrierMPI - - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + 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 - call etim( bfilt_tim) + 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 (Step 4) -!*** Then zero high generations (Step 5) +!*** Downsend, interpolate and add, then zero high generations !*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) - call btim( dnsend_tim) - call this%downsending_all(HALL,VALL,lquart) - - call etim( dnsend_tim) - -deallocate(VM3D) +deallocate(VM3D) deallocate(VM2D) deallocate(HM3D) deallocate(HM2D) - +deallocate(W) +deallocate(H) +deallocate(JCOL) !----------------------------------------------------------------------- - endsubroutine mg_filtering_rad2 +endsubroutine filtering_lin3 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine mg_filtering_rad3(this) +module subroutine filtering_rad2_bkg(this) !*********************************************************************** ! ! -! Multigrid filtering procedure 2: ! +! Multigrid filtering procedure: ! ! ! -! - Multiple of 2D and 3D variables ! -! - 1 upsending and downsending ! -! - Applicaton of Helmholtz differential operator ! -! - 3d radial filter +! - Apply vertical filter before and after horizontal ! +! - 2d 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_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" - -!---------------------------------------------------------------------- -allocate(VM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. -allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. -allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. -allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. - -!==================== Adjoint (Conservative step) ====================== - +!----------------------------------------------------------------------- +!*** +!*** 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) - - + 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( bfiltT_tim) - - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -! -! Adjoint filtering -! - call this%stack_to_composite(VALL,VM2D,VM3D) - call this%rbetaT(km2,hx,i0,im,hy,j0,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,i0,im,hy,j0,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 - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - write(6,*)'thinkdeb33 3 ', km,im,jm,hx,hy - - 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 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 etim( bfiltT_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) - - + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) !*** -!*** Apply Beta filter at all generations +!*** 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( bfilt_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) - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -! -! Filtering -! - call this%stack_to_composite(VALL,VM2D,VM3D) - call this%rbeta(km2,hx,i0,im,hy,j0,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) + call btim(hfilt_tim) + call this%rbeta(km,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:)) if(l_hgen) then - call this%stack_to_composite(HALL,HM2D,HM3D) - call this%rbeta(km2,hx,i0,im,hy,j0,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) + call this%rbeta(km,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:)) endif - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - call etim( bfilt_tim) - + call etim(hfilt_tim) !*** -!*** Downsend, interpolate and add -!*** Then zero high generations +!*** 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) - - + 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 mg_filtering_rad3 +endsubroutine filtering_rad2_bkg !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine mg_filtering_lin1(this) +module subroutine filtering_lin2_bkg(this) !*********************************************************************** ! ! -! Multigrid filtering procedure 4: ! +! Multigrid filtering procedure: ! ! ! -! - Multiple of 2D line filter ! -! - 1 upsending and downsending ! -! - Applicaton of Helmholtz differential operator ! -! - 2d line filter only for all variables ! +! - 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_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" -!----------------------------------------------------------------------- - - -!==================== Adjoint (Conservative step) ====================== - +!---------------------------------------------------------------------- !*** -!*** Adjoint interpolate and upsend (Step 1) +!*** 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) -!---------------------------------------------------------------------- - - -!---------------------------------------------------------------------- - + 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( bfiltT_tim) - - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - do icol=3,1,-1 - call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) - - call this%bocoT_2d(VALL,km,im,jm,hx,hy) - enddo - do icol=3,1,-1 - if(l_hgen) then - call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) - endif - - - write(6,*)'thinkdeb33 4 ', km,im,jm,hx,hy - call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + 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 - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - call etim( bfiltT_tim) + 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) - - + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) !*** !*** Apply Beta filter at all generations !*** - - - call btim( bfilt_tim) - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -! -! Filtering -! - do icol=1,3 - call this%boco_2d(VALL,km,im,jm,hx,hy) - call dibeta(km,i0-hx,0,im,im+hx, j0-hy,0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) - enddo - do icol=1,3 - call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) - if(l_hgen) then - call dibeta(km,i0-hx,0,im,im+hx, j0-hy,0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) - endif + 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 - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - call etim( bfilt_tim) - + 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 +!*** Downsend, interpolate and add, then zero high generations !*** - - call btim( dnsend_tim) - call this%downsending_all(HALL,VALL,lquart) - - call etim( dnsend_tim) - - + 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 mg_filtering_lin1 +endsubroutine filtering_lin2_bkg !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine mg_filtering_lin2(this) +module subroutine filtering_fast_bkg(this) !*********************************************************************** ! ! -! Multigrid filtering procedure 5: ! +! Fast multigrid filtering procedure: ! ! ! -! - Multiple of 2D line filter ! -! - 1 upsending and downsending ! -! - Applicaton of Helmholtz differential operator ! -! - 2d radial filter + 1d vertical filter +! - 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 -integer(i_kind) icol,iout,jout -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 -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" - -!---------------------------------------------------------------------- - -allocate(VM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. -allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. -allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. -allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. - - !----------------------------------------------------------------------- - - -!==================== Adjoint (Conservative step) ====================== - !*** -!*** Adjoint interpolate and upsend (Step 1) +!*** Adjoint of beta filter in vertical direction !*** - - call btim( upsend_tim) - call this%upsending_all(VALL,HALL,lquart) - call etim( upsend_tim) -!---------------------------------------------------------------------- - - -!---------------------------------------------------------------------- - + 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( bfiltT_tim) - - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -! -! Horizontal -! - - do icol=3,1,-1 - call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) - call this%bocoT_2d(VALL,km,im,jm,hx,hy) - enddo - - do icol=3,1,-1 - if(l_hgen) then - call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) - endif - write(6,*)'thinkdeb33 5 ', km,im,jm,hx,hy - call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call btim(hfiltT_tim) + do i=im,1,-1 + call this%rbetaT(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) enddo -! -! Vertical -! - - call this%stack_to_composite(VALL,VM2D,VM3D) - call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call this%composite_to_stack(VM2D,VM3D,VALL) - - if(l_hgen) then - call this%stack_to_composite(HALL,HM2D,HM3D) - call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call this%composite_to_stack(HM2D,HM3D,HALL) - endif - - write(6,*)'thinkdeb33 6 ', km,im,jm,hx,hy - call this%bocoT_2d(VALL,km,im,jm,hx,hy) - call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - call etim( bfiltT_tim) + 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) - - + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) !*** !*** Apply Beta filter at all generations !*** - - - call btim( bfilt_tim) - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -! -! Horizontal -! - do icol=1,3 - call this%boco_2d(VALL,km,im,jm,hx,hy) - call dibeta(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) - enddo - - do icol=1,3 - call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) - if(l_hgen) then - call dibeta(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) - endif + 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 -! -! Vertical -! - - 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 this%stack_to_composite(VALL,VM2D,VM3D) - call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call this%composite_to_stack(VM2D,VM3D,VALL) - - if(l_hgen) then - call this%stack_to_composite(HALL,HM2D,HM3D) - call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call this%composite_to_stack(HM2D,HM3D,HALL) - endif - - - call this%barrierMPI -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - - call etim( bfilt_tim) - + 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 +!*** 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) - - + 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 mg_filtering_lin2 +endsubroutine filtering_fast_bkg !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine mg_filtering_lin3(this) +module subroutine filtering_rad2_ens(this,mg_filt_flag) !*********************************************************************** ! ! -! Multigrid filtering procedure 6: ! +! Multigrid filtering procedure for ensemble: ! ! ! -! - Multiple of 2D line filter ! -! - 1 upsending and downsending ! -! - Applicaton of Helmholtz differential operator ! -! - 3d line filter +! - Apply vertical filter before and after horizontal ! +! - 2d radial filter ! +! - Version for localization of ensemble ! ! ! !*********************************************************************** -!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" +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_parameter_point2this.inc" include "type_intstat_point2this.inc" - - -allocate(VM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. -allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. -allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. -allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. - -allocate(W(km3,i0-hx:im+hx,j0-hy:jm+hy,1-hz:lm+hz)) ; W=0. -allocate(H(km3,i0-hx:im+hx,j0-hy:jm+hy,1-hz:lm+hz)) ; H=0. - -allocate(JCOL(0:im,0:jm,1:Lm)) ; JCOL=0 - !----------------------------------------------------------------------- - - -!==================== Adjoint (Conservative step) ====================== - +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) - call this%upsending_all(VALL,HALL,lquart) - call etim( upsend_tim) -!---------------------------------------------------------------------- - - -!---------------------------------------------------------------------- - + 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 +!*** Apply adjoint of Beta filter at all generations !*** - call btim( bfiltT_tim) - -! -! From single stack to composite variables -! - - call this%stack_to_composite(VALL,VM2D,VM3D) - if(l_hgen) then - call this%stack_to_composite(HALL,HM2D,HM3D) - endif - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -! -! Apply adjoint filter to 2D variables first -! - - do icol=3,1,-1 - call dibetat(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout) - write(6,*)'thinkdeb33 11.0 ', km2,im,jm,hx,hy - call this%bocoT_2d(VM2D,km2,im,jm,hx,hy) - enddo - - do icol=3,1,-1 - if(l_hgen) then - call dibetat(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout) - endif - write(6,*)'thinkdeb33 11 ', km2,im,jm,hx,hy - call this%bocoT_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) - enddo - -! -! Create and apply adjoint filter to extended 3D variables -! - - W(:,:,:,1:lm)=VM3D(:,:,:,1:lm) - - do icol=7,1,-1 - do L=1,hz - W(:,:,:,1-L )=0. - W(:,:,:,LM+L)=0. - end do - call dibetat(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & - ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout) - call this%bocoT_3d(W,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax) - enddo - - if(l_hgen) then - H(:,:,:,1:lm)=HM3D(:,:,:,1:lm) - endif - - do icol=7,1,-1 - if(l_hgen) then - do L=1,hz - H(:,:,:,1-L )=0. - H(:,:,:,LM+L)=0. - end do - - call dibetat(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & - ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout) - endif - call this%bocoT_3d(H,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax,2,gm) - enddo - - -! -! Go back from extended 3D variables and combine them with 2D variables in one stacked variable -! - - 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 - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + 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 etim( bfiltT_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) - call btim( weight_tim) - - call this%weighting_all(VALL,HALL,lhelm) - - - 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 !*** -! -! From single stacked to composite variables -! - call btim( bfilt_tim) - - call this%stack_to_composite(VALL,VM2D,VM3D) - if(l_hgen) then - call this%stack_to_composite(HALL,HM2D,HM3D) - endif - - + 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) -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -! -! Apply filter to 2D variables first -! - do icol=1,3 - call this%boco_2d(VM2D,km2,im,jm,hx,hy) - call dibeta(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout) - enddo + 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 - do icol=1,3 - call this%boco_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) - if(l_hgen) then - call dibeta(km2,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & - dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout) - endif +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +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 -! -! Create and apply filter to extended 3D variables -! - - W(:,:,:,1:lm)=VM3D(:,:,:,1:lm) - do L=1,hz - do j=j0-hy,jm+hy - do i=i0-hx,im+hx - W(:,i,j,1-L )=VM3D(:,i,j, 1+L) - W(:,i,j,LM+L)=VM3D(:,i,j,LM-L) - end do - end do - end do - - do icol=1,7 - call this%boco_3d(W,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax) - call dibeta(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & - ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout) - enddo - - if(l_hgen) then - H(:,:,:,1:lm)=HM3D(:,:,:,1:lm) - do L=1,hz - do j=j0-hy,jm+hy - do i=i0-hx,im+hx - H(:,i,j,1-L )=HM3D(:,i,j, 1+L) - H(:,i,j,LM+L)=HM3D(:,i,j,LM-L) - end do - end do - end do - endif - do icol=1,7 - call this%boco_3d(H,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax,2,gm) - if(l_hgen) then - call dibeta(km3,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & - ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout) - endif - enddo - -! -! Go back from extended 3D variables and combine them with 2D variables in one stacked variable -! - - VM3D(:,:,:,1:lm)= W(:,:,:,1:lm) - call this%composite_to_stack(VM2D,VM3D,VALL) - + do icol=3,1,-1 if(l_hgen) then - HM3D(:,:,:,1:lm)=H(:,:,:,1:lm) - call this%composite_to_stack(HM2D,HM3D,HALL) + 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 - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - call etim( bfilt_tim) - + 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 !*** -!*** 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) +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_ens(VALL,HALL,km_all) + call etim(weight_tim) -deallocate(JCOL) +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 mg_filtering_lin3 +endsubroutine filtering_lin2_ens !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine mg_filtering_fast(this) +module subroutine filtering_fast_ens(this,mg_filt_flag) !*********************************************************************** ! ! -! Fast multigrid filtering procedure: ! +! Fast multigrid filtering procedure for ensemble: ! ! ! -! - Multiple of 2D and 3D variables ! -! - 1 upsending and downsending ! -! - Applicaton of Helmholtz differential operator ! +! - 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 - -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),intent(in):: mg_filt_flag integer(i_kind) L,i,j -include "type_parameter_locpointer.inc" +include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- - -allocate(VM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. -allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. -allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. -allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. - - - -!==================== Adjoint (Conservative step) ====================== - +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 +!*** Adjoint interpolate and upsend !*** - - call btim( upsend_tim) - call this%upsending_all(VALL,HALL,lquart) - call etim( upsend_tim) -!---------------------------------------------------------------------- - - -!---------------------------------------------------------------------- - + 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 +!*** Apply adjoint of Beta filter at all generations !*** - call btim( bfiltT_tim) - - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -! -! Horizontally -! - - do j=0,jm - call this%rbetaT(km,hx,1,im,paspx,ssx,VALL(:,:,j)) - enddo - call this%bocoTx(VALL,km,im,jm,hx,hy) - - do i=0,im - call this%rbetaT(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) - enddo - call this%bocoTy(VALL,km,im,jm,hx,hy) - - call this%stack_to_composite(VALL,VM2D,VM3D) - - if(l_hgen) then - do j=0,jm - call this%rbetaT(km,hx,i0,im,paspx,ssx,HALL(:,:,j)) - enddo + 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 - call this%bocoTx(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) - - if(l_hgen) then - do i=0,im - call this%rbetaT(km,hy,j0,jm,paspy,ssy,HALL(:,i,:)) - enddo + 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 this%bocoTy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) - -! -! Vertically -! - call this%stack_to_composite(HALL,HM2D,HM3D) - call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call this%composite_to_stack(VM2D,VM3D,VALL) - if(l_hgen) then - call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call this%composite_to_stack(HM2D,HM3D,HALL) - endif - - - call this%barrierMPI -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - - call etim( bfiltT_tim) + 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) - call btim( weight_tim) - - call this%weighting_all(VALL,HALL,lhelm) - - - 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 (Step 7) +!*** Apply Beta filter at all generations !*** - call btim( bfilt_tim) - - -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff -! -! Filtering -! -! Horizonatally - - call this%bocox(VALL,km,im,jm,hx,hy) - do j=0,jm - call this%rbeta(km,hx,i0,im,paspx,ssx,VALL(:,:,j)) - enddo - - call this%bocoy(VALL,km,im,jm,hx,hy) - do i=0,im - call this%rbeta(km,hy,j0,jm,paspy,ssy,VALL(:,i,:)) - enddo - - call this%stack_to_composite(VALL,VM2D,VM3D) - - call this%bocox(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) - if(l_hgen) then - do j=0,jm - call this%rbeta(km,hx,i0,im,paspx,ssx,HALL(:,:,j)) - enddo + 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 this%bocoy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) - if(l_hgen) then - do i=0,im - call this%rbeta(km,hy,j0,jm,paspy,ssy,HALL(:,i,:)) - enddo + 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 - if(l_hgen) then - call this%stack_to_composite(HALL,HM2D,HM3D) + 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 - -! -! Vertically -! - - call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) - call this%composite_to_stack(VM2D,VM3D,VALL) - if(l_hgen) then - call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) - call this%composite_to_stack(HM2D,HM3D,HALL) - endif - - call this%barrierMPI -!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - - call etim( bfilt_tim) - !*** -!*** Downsend, interpolate and add (Step 4) -!*** Then zero high generations (Step 5) +!*** 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 - call btim( dnsend_tim) - call this%downsending_all(HALL,VALL,lquart) - - call etim( dnsend_tim) +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +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" +!----------------------------------------------------------------------- -deallocate(VM3D) -deallocate(VM2D) -deallocate(HM3D) -deallocate(HM2D) +!*** +!*** 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 mg_filtering_fast +endsubroutine filtering_rad_highest !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine sup_vrbeta1 & +module subroutine sup_vrbeta1 & !********************************************************************** ! * -! conversion of vrbeta1 * +! conversion of vrbeta1 * ! * !********************************************************************** -(this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) !---------------------------------------------------------------------- implicit none - class(mg_intstate_type),target::this - +class(mg_intstate_type),target::this integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm -real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1:lm),intent(inout):: V +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=this%j0,jm - do i=this%i0,im + do j=1,jm + do i=1,im do L=1,Lm W(:,L)=V(:,i,j,L) end do @@ -1279,36 +1253,31 @@ module subroutine sup_vrbeta1 & end do end do end do - !---------------------------------------------------------------------- - endsubroutine sup_vrbeta1 +endsubroutine sup_vrbeta1 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine sup_vrbeta1T & +module subroutine sup_vrbeta1T & !********************************************************************** ! * -! conversion of vrbeta1T * +! Adjoint of sup_vrbeta1 * ! * !********************************************************************** -(this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) !---------------------------------------------------------------------- implicit none - class(mg_intstate_type),target::this - +class(mg_intstate_type),target::this integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm -real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1:lm),intent(inout):: V +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=this%j0,jm - do i=this%i0,im + do j=1,jm + do i=1,im do L=1,Lm W(:,L)=V(:,i,j,L) end do @@ -1331,42 +1300,38 @@ module subroutine sup_vrbeta1T & end do !---------------------------------------------------------------------- - endsubroutine sup_vrbeta1T +endsubroutine sup_vrbeta1T !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine sup_vrbeta3 & +module subroutine sup_vrbeta3 & !********************************************************************** ! * ! conversion of vrbeta3 * ! * !********************************************************************** -(this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) !---------------------------------------------------------------------- implicit none - class(mg_intstate_type),target::this - +class(mg_intstate_type),target::this integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm -real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1:lm),intent(inout):: V -real(r_kind),dimension(3,3,this%i0:im,this%j0:jm,1:lm), intent(in):: pasp -real(r_kind),dimension(this%i0:im,this%j0:jm,1:lm), intent(in):: ss - -real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1-hz:lm+hz):: W - +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=this%j0-hy,jm+hy - do i=this%i0-hx,im+hx + 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=this%j0-hy,jm+hy - do i=this%i0-hx,im+hx + 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 @@ -1374,54 +1339,50 @@ module subroutine sup_vrbeta3 & end do - call this%rbeta(kmax,hx,this%i0,im, hy,this%j0,jm, hz,1,lm, pasp,ss,W) + call this%rbeta(kmax,hx,1,im, hy,1,jm, hz,1,lm, pasp,ss,W) do l=1,Lm - do j=this%j0,jm - do i=this%i0,im + 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 +endsubroutine sup_vrbeta3 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine sup_vrbeta3T & +module subroutine sup_vrbeta3T & !********************************************************************** ! * -! conversion of vrbeta3 * +! Adjoint of sup_vrbeta3 * ! * !********************************************************************** -(this,kmax,hx,hy,hz,im,jm,lm, pasp,ss,V) +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) !---------------------------------------------------------------------- implicit none - class(mg_intstate_type), target::this - +class(mg_intstate_type),target::this integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm -real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1:lm),intent(inout):: V -real(r_kind),dimension(3,3,this%i0:im,this%j0:jm,1:lm), intent(in):: pasp -real(r_kind),dimension(this%i0:im,this%j0:jm,1:lm), intent(in):: ss - -real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1-hz:lm+hz):: W - +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=this%j0-hy,jm+hy - do i=this%i0-hx,im+hx + 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=this%j0-hy,jm+hy - do i=this%i0-hx,im+hx + 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 @@ -1429,14 +1390,14 @@ module subroutine sup_vrbeta3T & end do - call this%rbetaT(kmax,hx,this%i0,im, hy,this%j0,jm, hz,1,lm, pasp,ss,W) + 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=this%j0-hy,jm+hy - do i=this%i0-hx,im+hx + 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 @@ -1444,15 +1405,225 @@ module subroutine sup_vrbeta3T & end do do l=1,lm - do j=this%j0,jm - do i=this%i0,im + 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 +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 +end submodule mg_filtering diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index 0741f0873..2008a7528 100644 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -1,9 +1,64 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - submodule(mg_intstate) mg_generations +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 + !*********************************************************************** ! ! -! Contains procedures that include differrent generations ! -! - offset version - ! ! ! M. Rancic (2022) ! !*********************************************************************** @@ -14,12 +69,25 @@ 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 +contains !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine upsending_all & +module subroutine upsending_all & !*********************************************************************** ! ! ! Adjoint interpolate and upsend: ! @@ -39,13 +107,12 @@ module subroutine upsending_all & else call this%upsending(V,H) endif - !----------------------------------------------------------------------- - endsubroutine upsending_all +endsubroutine upsending_all !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine downsending_all & +module subroutine downsending_all & !*********************************************************************** ! ! ! Downsend, interpolate and add: ! @@ -57,10 +124,8 @@ module subroutine downsending_all & !----------------------------------------------------------------------- implicit none class (mg_intstate_type),target:: this - -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-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,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V logical, intent(in):: lquart !----------------------------------------------------------------------- @@ -71,10 +136,10 @@ module subroutine downsending_all & endif !----------------------------------------------------------------------- - endsubroutine downsending_all +endsubroutine downsending_all !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine weighting_all & +module subroutine weighting_all & !*********************************************************************** ! ! ! Apply 2D differential operator to compound variable ! @@ -84,9 +149,8 @@ module subroutine weighting_all & !----------------------------------------------------------------------- implicit none class (mg_intstate_type),target:: this -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-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%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H logical, intent(in):: lhelm !----------------------------------------------------------------------- @@ -97,10 +161,10 @@ module subroutine weighting_all & endif !----------------------------------------------------------------------- - endsubroutine weighting_all +endsubroutine weighting_all !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine upsending & +module subroutine upsending & !*********************************************************************** ! ! ! Adjoint interpolate and upsend: ! @@ -114,9 +178,8 @@ module subroutine upsending & 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,this%i0-2:this%imL+2,this%j0-2:this%jmL+2):: V_INT -real(r_kind),dimension(this%km,this%i0-2:this%imL+2,this%j0-2: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%imL+2,-1:this%jmL+2):: H_INT integer(i_kind):: g,L !----------------------------------------------------------------------- ! @@ -143,12 +206,11 @@ module subroutine upsending & end do - !----------------------------------------------------------------------- - endsubroutine upsending +endsubroutine upsending !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine downsending & +module subroutine downsending & !*********************************************************************** ! ! ! Downsend, interpolate and add: ! @@ -160,13 +222,12 @@ module subroutine downsending & !----------------------------------------------------------------------- implicit none class (mg_intstate_type),target:: this -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V - -real(r_kind),dimension(this%km,this%i0-2:this%imL+2,this%j0-2:this%jmL+2):: H_INT -real(r_kind),dimension(this%km,this%i0-2:this%imL+2,this%j0-2:this%jmL+2):: V_INT -real(r_kind),dimension(this%km,this%i0:this%im,this%j0:this%jm):: H_PROX -real(r_kind),dimension(this%km,this%i0:this%im,this%j0:this%jm):: V_PROX +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 !----------------------------------------------------------------------- @@ -175,13 +236,13 @@ module subroutine downsending & ! do g=this%gm,3,-1 - call this%downsend_all(H(1:this%km,this%i0:this%im,this%j0:this%jm),H_INT(1:this%km,1:this%imL,1:this%jmL),this%km,g,g-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,this%i0:this%im,this%j0:this%jm) & - +H_PROX(1:this%km,this%i0:this%im,this%j0:this%jm) + 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 @@ -190,21 +251,21 @@ module subroutine downsending & ! From geneartion 2 to generation 1 ! - call this%downsend_all(H(1:this%km,this%i0:this%im,this%j0:this%jm),V_INT(1:this%km,1:this%imL,1:this%jmL),this%km) + 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,this%i0:this%im,this%j0:this%jm)=V (1:this%km,this%i0:this%im,this%j0:this%jm) & - +V_PROX(1:this%km,this%i0:this%im,this%j0:this%jm) + 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 +endsubroutine downsending !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine upsending2 & +module subroutine upsending_highest & !*********************************************************************** ! ! ! Adjoint interpolate and upsend: ! @@ -216,11 +277,77 @@ module subroutine upsending2 & !----------------------------------------------------------------------- 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 @@ -249,12 +376,11 @@ module subroutine upsending2 & end do - !----------------------------------------------------------------------- - endsubroutine upsending2 +endsubroutine upsending2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine downsending2 & +module subroutine downsending2 & !*********************************************************************** ! ! ! Downsend, interpolate and add: ! @@ -285,8 +411,8 @@ module subroutine downsending2 & 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) + 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 @@ -302,262 +428,966 @@ module subroutine downsending2 & 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) + 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 +endsubroutine downsending2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine weighting_helm & +module subroutine upsending_ens & !*********************************************************************** ! ! -! Apply 2D differential operator to compound variable ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! ! ! !*********************************************************************** -(this,V,H) +(this,V,H,kmx) !----------------------------------------------------------------------- implicit none class (mg_intstate_type),target:: this - -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H -real(r_kind),dimension(this%km,this%i0-1:this%im, this%j0 :this%jm):: DIFX -real(r_kind),dimension(this%km,this%i0 :this%im ,this%j0-1:this%jm):: DIFY -real(r_kind),dimension(this%km,this%i0-1:this%im, this%j0 :this%jm):: DIFXH -real(r_kind),dimension(this%km,this%i0 :this%im ,this%j0-1:this%jm):: DIFYH -integer(i_kind):: i,j,l,k,imx,jmx +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 +! - do j=this%j0,this%jm - do i=this%i0-1,this%im - DIFX(:,i,j)=V(:,i+1,j)-V(:,i,j) - enddo - enddo - do j=this%j0-1,this%jm - do i=this%i0,this%im - DIFY(:,i,j)=V(:,i,j+1)-V(:,i,j) - enddo - enddo - - - do j=this%j0,this%jm - do i=this%i0,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 + call this%adjoint(V(1:kmx,1:this%im,1:this%jm),V_INT,kmx,1) -if(this%l_hgen) then + call this%bocoT_2d(V_INT,kmx,this%imL,this%jmL,2,2) -! imx = Fimax(my_hgen) -! jmx = Fjmax(my_hgen) + 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 - imx = this%im - jmx = this%jm + if(g==this%my_hgen) then + call this%adjoint(H(1:kmx,1:this%im,1:this%jm),H_INT,kmx,g) + endif - do j=this%j0,jmx - do i=this%i0-1,imx - DIFXH(:,i,j)=H(:,i+1,j)-H(:,i,j) - enddo - enddo - do j=this%j0-1,jmx - do i=this%i0,imx - DIFYH(:,i,j)=H(:,i,j+1)-H(:,i,j) - enddo - enddo + call this%bocoT_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) - do j=this%j0,jmx - do i=this%i0,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 + call this%upsend_all(H_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx,g,g+1) -endif + end do !----------------------------------------------------------------------- - endsubroutine weighting_helm +endsubroutine upsending_ens !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine weighting & +module subroutine downsending_ens & !*********************************************************************** ! ! -! Apply 2D differential operator to compound variable ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! ! ! !*********************************************************************** -(this,V,H) +(this,H,V,kmx) !----------------------------------------------------------------------- implicit none class (mg_intstate_type),target:: this -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H - -integer(i_kind):: i,j,l,k,imx,jmx +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 - do j=this%j0,this%jm - do i=this%i0,this%im - V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j) - enddo - enddo + 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) -if(this%l_hgen) then + call this%boco_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g-1,g-1) - imx = this%im - jmx = this%jm + 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 - do j=this%j0,jmx - do i=this%i0,imx - H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) - enddo - enddo + enddo -endif +! +! 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 weighting +endsubroutine downsending_ens !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine adjoint & +module subroutine upsending_ens_nearest & !*********************************************************************** ! ! -! Mapping from the high to low resolution grid ! -! using linearly squared interpolations ! -! - offset version - ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! ! ! !*********************************************************************** -(this,F,W,km_in,g) +(this,V,H,kmx) !----------------------------------------------------------------------- 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,this%i0:this%im,this%j0:this%jm), intent(in):: F -real(r_kind), dimension(km_in,this%i0-2:this%imL+2,this%j0-2:this%jmL+2), intent(out):: W -real(r_kind), dimension(km_in,this%i0:this%im,this%j0-2:this%jmL+2):: W_AUX -integer(i_kind):: i,j,iL,jL +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 !----------------------------------------------------------------------- ! -! 3) +! From generation 1 to generation 2 ! - W_AUX(:,:,:)= 0. - do j=this%jm,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,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 + call this%adjoint_nearest(V(1:kmx,1:this%im,1:this%jm),V_INT,kmx,1) - W(:,:,:)=0. + 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) ! -! 1) +! From generation 2 sequentially to higher generations ! - do jL=this%jmL+2,-1,-1 - do i=this%im-1,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,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 + 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 adjoint +endsubroutine upsending_ens_nearest !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine direct1 & +module subroutine downsending_ens_nearest & !*********************************************************************** ! ! -! Mapping from the low to high resolution grid ! -! using linearly squared interpolations ! -! - offset version - ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! ! ! !*********************************************************************** -(this,W,F,km_in,g) +(this,H,V,kmx) !----------------------------------------------------------------------- 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,this%i0-2:this%imL+2,this%j0-2:this%jmL+2), intent(in):: W -real(r_kind), dimension(km_in,this%i0:this%im,this%j0:this%jm), intent(out):: F -real(r_kind), dimension(km_in,this%i0:this%im,this%j0-2:this%jmL+2):: W_AUX -integer(i_kind):: i,j,iL,jL +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 !----------------------------------------------------------------------- - -! -! 1) -! - do jL=-1,this%jmL+2 - do i=1,this%im-1,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,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) +! Upper generations ! - do j=1,this%jm-1,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 + 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 + ! -! 3) +! From geneartion 2 to generation 1 ! - do j=2,this%jm,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 + + 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 direct1 +endsubroutine downsending_ens_nearest !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine adjoint2 & +module subroutine upsending2_ens & !*********************************************************************** ! ! -! Mapping from the high to low resolution grid ! -! using quadratics interpolations ! +! 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 - ! ! ! !*********************************************************************** @@ -569,7 +1399,7 @@ module subroutine adjoint2 & 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+2):: W_AUX +real(r_kind), dimension(km_in,1:this%im,0:this%jmL+1):: W_AUX integer(i_kind):: i,j,iL,jL !----------------------------------------------------------------------- ! @@ -577,7 +1407,7 @@ module subroutine adjoint2 & ! W_AUX(:,:,:)= 0. - do j=this%jm,2,-2 + 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) @@ -588,7 +1418,7 @@ module subroutine adjoint2 & ! ! 2) ! - do j=this%jm-1,1,-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) @@ -602,13 +1432,13 @@ module subroutine adjoint2 & ! 1) ! do jL=this%jmL+1,0,-1 - do i=this%im-1,1,-2 + 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,2,-2 + 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) @@ -617,10 +1447,10 @@ module subroutine adjoint2 & enddo !----------------------------------------------------------------------- - endsubroutine adjoint2 +endsubroutine adjoint2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine direct2 & +module subroutine direct2 & !*********************************************************************** ! ! ! Mapping from the low to high resolution grid ! @@ -643,40 +1473,284 @@ module subroutine direct2 & ! 1) ! do jL=0,this%jmL+1 - do i=1,this%im-1,2 + 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) & + 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,2 + 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) & + 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,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 ) & + 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,2 + 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 ) & + 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 +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 +end submodule mg_generations diff --git a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 index 9ec122a51..534679258 100644 --- a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 @@ -1,34 +1,65 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - submodule(mg_intstate) mg_interpolate -!*********************************************************************** -! ! -! general mapping between 2d arrays using linerly squared ! -! interpolations ! -! ! -! M. Rancic (2020) ! -!*********************************************************************** +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 -!use mpimod, only: mype implicit none !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - contains +contains !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine def_offset_coef (this) +module subroutine def_offset_coef (this) !*********************************************************************** implicit none class(mg_intstate_type),target::this -real(r_kind):: r64,r32,r128,r2 +real(r_kind):: r64,r32,r128 !----------------------------------------------------------------------- r64 = 1.0d0/64.0d0 r32 = 1.0d0/32.0d0 r128= 1.0d0/128.0d0 -! r2 = 1.0d0/2.0d0 - r2 = 1.0d0 ! p_coef =(/-3.,51,29,-3/) ! q_coef =(/-3.,19.0d0,51.0d0,-3.0d0/) @@ -37,22 +68,22 @@ module subroutine def_offset_coef (this) this%p_coef =(/-9.,111.,29.,-3./) this%q_coef =(/-3.,29.,111.,-9./) -this%p_coef = this%p_coef*r128 *r2 - this%q_coef = this%q_coef*r128 *r2 + this%p_coef = this%p_coef*r128 + this%q_coef = this%q_coef*r128 - this%a_coef =(/5.0d0,30.0d0,-3.0d0/) - this%b_coef =(/-3.0d0,30.0d0,5.0d0/) - this%a_coef=this%a_coef*r32 *r2 - this%b_coef=this%b_coef*r32 *r2 + 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 +endsubroutine def_offset_coef !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine lsqr_mg_coef (this) +module subroutine lsqr_mg_coef (this) !*********************************************************************** ! ! ! Prepare coeficients for mapping between: ! -! filter grid on analysis decomposition: W(i0-ib:im+ib,j0-jb:jm+jb) ! +! filter grid on analysis decomposition: W(1-ib:im+ib,1-jb:jm+jb) ! ! and analysis grid: V(1:nm,1:mm) ! ! - offset version - ! ! ! @@ -74,6 +105,8 @@ module subroutine lsqr_mg_coef (this) 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 @@ -102,6 +135,8 @@ module subroutine lsqr_mg_coef (this) 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 @@ -111,16 +146,14 @@ module subroutine lsqr_mg_coef (this) 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 -!ddreal(r_kind), dimension(1-this%ib:this%im+this%ib):: xf -write(6,*)"thinkdeb 0 ",1-this%ib, ' ',this%im+this%ib,this%nm - do n=1,this%nm - write(6,*)'thinkdeb n iref ',n,this%iref(n) i=this%iref(n) x1=xf(i) x2=xf(i+1) @@ -182,15 +215,77 @@ module subroutine lsqr_mg_coef (this) 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 +endsubroutine lsqr_mg_coef !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine lwq_vertical_coef & +module subroutine lwq_vertical_coef & !*********************************************************************** ! ! -! Prepare coeficients for vetical mapping between: ! +! Prepare coeficients for vertical mapping between: ! ! analysis grid vertical resolution (nm) and ! ! generation one of filter grid vertical resoluition (im) ! ! ! @@ -253,19 +348,18 @@ module subroutine lwq_vertical_coef & 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 +endsubroutine lwq_vertical_coef !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine lwq_vertical_adjoint & +module subroutine lwq_vertical_adjoint & !*********************************************************************** ! ! ! Direct linerly weighted quadratic adjoint interpolation in vertical ! -! from reslution nm to resolution im ! +! from reslution nm to resolution km ! ! ! -! ( im <= nm ) ! +! ( km <= nm ) ! ! ! !*********************************************************************** (this,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) @@ -304,16 +398,16 @@ module subroutine lwq_vertical_adjoint & f(km_in,:,:)=f(km_in,:,:)+w(nm_in,:,:) !----------------------------------------------------------------------- - endsubroutine lwq_vertical_adjoint +endsubroutine lwq_vertical_adjoint !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine lwq_vertical_direct & +module subroutine lwq_vertical_direct & !*********************************************************************** ! ! ! Linerly weighted direct quadratic interpolation in vertical ! -! from reslouion im to resolution nm ! +! from reslouion km to resolution nm ! ! ! -! ( im <= nm ) ! +! ( km <= nm ) ! ! ! !*********************************************************************** (this,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,f,w) @@ -343,35 +437,189 @@ module subroutine lwq_vertical_direct & 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 lwq_vertical_direct +endsubroutine l_vertical_direct_spec !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine lsqr_direct_offset & +module subroutine lsqr_direct_offset & !*********************************************************************** ! ! -! Given a source array V(km,i0-ib:im+ib,j0-jb:jm+jb) perform ! +! 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) +(this,V_in,W,km_in,ibm,jbm) !----------------------------------------------------------------------- implicit none class(mg_intstate_type),target::this -integer(i_kind),intent(in):: km_in -real(r_kind), dimension(km_in,1-this%ib:this%im+this%ib,1-this%jb:this%jm+this%jb), intent(in):: V_in +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,this%j0-this%jb:this%jm+this%jb):: VX +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=this%j0-this%jb,this%jm+this%jb + do j=1-jbm,this%jm+jbm do n=1,this%nm i = this%iref(n) v0(:)=V_in(:,i ,j) @@ -392,67 +640,333 @@ module subroutine lsqr_direct_offset & 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 +endsubroutine lsqr_direct_offset !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine lsqr_adjoint_offset & +module subroutine lsqr_adjoint_offset & !*********************************************************************** ! ! -! Given a target array W(km,0:nm,0:mm) perform adjoint ! -! interpolations to get source array V(km,i0-ib:im+ib,j0-jb:jm+jb) ! +! 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) +(this,W,V_out,km_in,ibm,jbm) !----------------------------------------------------------------------- implicit none class(mg_intstate_type),target::this -integer(i_kind):: km_in +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-this%ib:this%im+this%ib,1-this%jb:this%jm+this%jb), intent(out):: V_out -real(r_kind), dimension(km_in,1:this%nm,this%j0-this%jb:this%jm+this%jb):: VX +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 -integer(i_kind):: ip1,ip2,ip3 -integer(i_kind):: jp1,jp2,jp3 +real(r_kind):: c0,c1,c2,c3 !----------------------------------------------------------------------- - - V_out(:,:,:) = 0. - + V_out(:,:,:)=0. VX(:,:,:)=0. do m=1,this%mm j = this%jref(m) - jp1=j+1 - jp2=j+2 - jp3=j+3 + c0 = this%cy0(m) + c1 = this%cy1(m) + c2 = this%cy2(m) + c3 = this%cy3(m) do n=1,this%nm - VX(:,n,j ) = VX(:,n,j )+W(:,n,m)*this%cy0(m) - VX(:,n,jp1) = VX(:,n,jp1)+W(:,n,m)*this%cy1(m) - VX(:,n,jp2) = VX(:,n,jp2)+W(:,n,m)*this%cy2(m) - VX(:,n,jp3) = VX(:,n,jp3)+W(:,n,m)*this%cy3(m) + 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 j=this%j0-this%jb,this%jm+this%jb do n=1,this%nm i = this%iref(n) - ip1=i+1 - ip2=i+2 - ip3=i+3 + 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 - V_out(:,i ,j) = V_out(:,i ,j)+VX(:,n,j)*this%cx0(n) - V_out(:,ip1,j) = V_out(:,ip1,j)+VX(:,n,j)*this%cx1(n) - V_out(:,ip2,j) = V_out(:,ip2,j)+VX(:,n,j)*this%cx2(n) - V_out(:,ip3,j) = V_out(:,ip3,j)+VX(:,n,j)*this%cx3(n) +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +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 lsqr_adjoint_offset +endsubroutine l_vertical_direct_spec2 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - end submodule mg_interpolate +end submodule mg_interpolate diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index b6af156a4..932084c70 100644 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1,50 +1,63 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_intstate -!*********************************************************************** -! ! -! Contains declarations and allocations of internal state variables ! -! use for filtering ! -! - offset version - ! -! ! -! M. Rancic (2020) ! -!*********************************************************************** +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 -!GSI use mpimod, only: mype -!use mg_entrymod, only: km2,km3,km -!GSI use berror, only: mg_weig1,mg_weig2,mg_weig3,mg_weig4 -!clt use jp_pbfil,only: cholaspect -!use jp_pbfil,only: getlinesum use jp_pbfil3, only: inimomtab,t22_to_3,tritform,t33_to_6,hextform use mg_parameter,only: mg_parameter_type -!TEST -!use gridmod, only: lat1,lon1 -!TEST implicit none type,extends( mg_parameter_type):: mg_intstate_type real(r_kind), allocatable,dimension(:,:,:):: V ! -! Composite control variable on first generation o filter grid +! Composite control variable on first generation of filter grid ! real(r_kind), allocatable,dimension(:,:,:):: VALL -real(r_kind), allocatable,dimension(:,:,:):: HALL ! ! Composite control variable on high generations of filter grid ! -! -!FOR ADJOINT TEST -! -!real(r_kind), allocatable,dimension(:,:):: A -!real(r_kind), allocatable,dimension(:,:):: B -!real(r_kind), allocatable,dimension(:,:):: A0 -!real(r_kind), allocatable,dimension(:,:):: B0 -! +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 @@ -77,16 +90,10 @@ module mg_intstate integer(fpi), allocatable,dimension(:,:,:,:):: qcols -!real(r_kind), allocatable,dimension(:,:,:,:):: r_vol -! -! -! Composite stacked variable -! - -!cltreal(r_kind), allocatable,dimension(:,:,:):: WORKA - - 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 @@ -94,6 +101,12 @@ module mg_intstate 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 @@ -101,902 +114,1040 @@ module mg_intstate ,cf10,cf11,cf12,cf13 & ,cf20,cf21,cf22,cf23 & ,cf30,cf31,cf32,cf33 -!clt from interpolate.f90 contains - procedure :: allocate_mg_intstate, def_mg_weights, init_mg_line - procedure ::def_offset_coef - procedure ::lsqr_mg_coef,lwq_vertical_coef - procedure ::lwq_vertical_direct,lwq_vertical_adjoint , & - lsqr_direct_offset, & - deallocate_mg_intstate, & - lsqr_adjoint_offset - generic ::boco_2d => boco_2d_g1,boco_2d_gh - generic ::boco_3d => boco_3d_g1,boco_3d_gh - generic ::bocoT_2d => bocoT_2d_g1,bocoT_2d_gh - generic ::bocoTx => bocoTx_2d_g1,bocoTx_2d_gh - generic ::bocoTy => bocoTy_2d_g1,bocoTy_2d_gh - generic ::bocoT_3d => bocoT_3d_g1,bocoT_3d_gh - generic ::bocox => bocox_2d_g1,bocox_2d_gh - generic ::bocoy => bocoy_2d_g1,bocoy_2d_gh - - generic ::upsend_all=> upsend_all_g1 ,upsend_all_gh - generic ::downsend_all=> downsend_all_g2 ,downsend_all_gh - procedure:: upsend_all_g1 ,upsend_all_gh - procedure:: downsend_all_g2 ,downsend_all_gh - procedure:: boco_2d_g1,boco_2d_gh - procedure:: boco_3d_g1,boco_3d_gh - procedure :: bocoT_2d_g1,bocoT_2d_gh - procedure :: bocoTx_2d_g1,bocoTx_2d_gh - procedure :: bocoTy_2d_g1,bocoTy_2d_gh - procedure :: bocoT_3d_g1,bocoT_3d_gh - procedure :: bocox_2d_g1,bocox_2d_gh - procedure :: bocoy_2d_g1,bocoy_2d_gh -!cltfrom mg_generation - procedure:: upsending_all,downsending_all,weighting_all, & - upsending,downsending,upsending2,downsending2, & - weighting_helm,weighting ,adjoint,direct1, & - adjoint2,direct2 -!clt mg_filtering - procedure ::sup_vrbeta1T,sup_vrbeta1,sup_vrbeta3T,sup_vrbeta3 - - procedure:: mg_filtering_rad1,mg_filtering_rad2,mg_filtering_rad3,& - mg_filtering_lin1,mg_filtering_lin2,mg_filtering_lin3, & - mg_filtering_fast -!clt from mg_transfer.f90 - procedure:: composite_to_stack,stack_to_composite -!clt from mg_entrymod - procedure :: mg_initialize - procedure ::mg_finalize - procedure :: anal_to_filt_all,mg_filtering_procedure,filt_to_anal_all + 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 - module subroutine lsqr_mg_coef(this) - import mg_intstate_type - class(mg_intstate_type),target::this - end subroutine - module subroutine lwq_vertical_coef & -(this,nm_in,im_in,c1,c2,c3,c4,iref_out) - import mg_intstate_type -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) - import mg_intstate_type -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) - import mg_intstate_type -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 -end interface -interface - module subroutine def_offset_coef(this) - import mg_intstate_type - class(mg_intstate_type),target::this - end subroutine -end interface - -interface - - module subroutine lsqr_direct_offset & -(this,V_in,W,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%ib:this%im+this%ib,1-this%jb:this%jm+this%jb), 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,this%j0-this%jb:this%jm+this%jb):: VX - end subroutine lsqr_direct_offset - - module subroutine lsqr_adjoint_offset & -(this,W,V_out,km_in) -!----------------------------------------------------------------------- - import mg_intstate_type - import i_kind,r_kind -implicit none -class(mg_intstate_type),target::this -integer(i_kind):: km_in -real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W -real(r_kind), dimension(km_in,1-this%ib:this%im+this%ib,1-this%jb:this%jm+this%jb), intent(out):: V_out -real(r_kind), dimension(km_in,1:this%nm,this%j0-this%jb:this%jm+this%jb):: VX - end subroutine -!clt from mg_transfer.f90 - - module subroutine anal_to_filt_all(this,WORKA) - import mg_intstate_type - class(mg_intstate_type),target::this - real (r_kind):: WORKA(this%km,this%n0:this%nm,this%m0:this%mm) - - end subroutine anal_to_filt_all - module subroutine filt_to_anal_all (this,WORKA) - import mg_intstate_type - class(mg_intstate_type),target::this - real (r_kind):: WORKA(this%km,this%n0:this%nm,this%m0:this%mm) - - end subroutine filt_to_anal_all - module subroutine stack_to_composite(this,ARR_ALL,A2D,A3D) - import mg_intstate_type - class(mg_intstate_type),target::this -real(r_kind),dimension(this%km ,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy), intent(in):: ARR_ALL -real(r_kind),dimension(this%km3,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy,this%lm),intent(out):: A3D -real(r_kind),dimension(this%km2,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy) ,intent(out):: A2D - - - end subroutine stack_to_composite -module subroutine composite_to_stack & -!*********************************************************************** -! ! -! Transfer data from composite to stack variables ! -! ! -!*********************************************************************** -(this,A2D,A3D,ARR_ALL) -!---------------------------------------------------------------------- - import mg_intstate_type -implicit none -class(mg_intstate_type),target::this -real(r_kind),dimension(this%km2,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy), intent(in):: A2D -real(r_kind),dimension(this%km3,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy,this%lm),intent(in):: A3D -real(r_kind),dimension(this%km ,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy), intent(out):: ARR_ALL - end subroutine composite_to_stack - - end interface -!clt for mg_bocos -interface - 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 boco_2d_gh - - 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 boco_3d_g1 - - 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 boco_3d_gh - module subroutine bocoT_2d_g1 & -(this,W,km_in,im_in,jm_in,nbx,nby) -!----------------------------------------------------------------------- - import mg_intstate_type -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 bocoT_2d_g1 - module subroutine bocoT_2d_gh & -(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) -!----------------------------------------------------------------------- - - import mg_intstate_type -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 bocoT_2d_gh - - 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 bocoTx_2d_g1 - 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 bocoTx_2d_gh -!----------------------------------------------------------------------- - - 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 bocoTy_2d_g1 - - 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 bocoTy_2d_gh - - 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 bocoT_3d_g1 - 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 bocoT_3d_gh - 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 bocox_2d_gh - 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 bocox_2d_g1 - - 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 bocoy_2d_g1 - 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 bocoy_2d_gh - - - module subroutine upsend_all_g1 & -(this,Harray,Warray,km_in) -!----------------------------------------------------------------------- - import mg_intstate_type -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 upsend_all_g1 - module subroutine upsend_all_gh & -(this,Harray,Warray,km_in,mygen_dn,mygen_up) - import mg_intstate_type -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 upsend_all_gh - - 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 downsend_all_gh - 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 downsend_all_g2 - -end interface -!clt from mg_filtering -interface - module subroutine mg_filtering_procedure (this,mg_filt) - import mg_intstate_type - class(mg_intstate_type),target::this +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 - - end subroutine mg_filtering_procedure - module subroutine mg_filtering_rad1(this) - import mg_intstate_type - class(mg_intstate_type),target::this - end subroutine mg_filtering_rad1 - module subroutine mg_filtering_rad2(this) - import mg_intstate_type - class(mg_intstate_type),target::this - - end subroutine mg_filtering_rad2 - module subroutine mg_filtering_rad3(this) - import mg_intstate_type - class(mg_intstate_type),target::this - - end subroutine mg_filtering_rad3 - module subroutine mg_filtering_lin1(this) - import mg_intstate_type - class(mg_intstate_type),target::this - - end subroutine mg_filtering_lin1 -module subroutine mg_filtering_lin2(this) - import mg_intstate_type - class(mg_intstate_type),target::this - - end subroutine mg_filtering_lin2 -module subroutine mg_filtering_lin3(this) - import mg_intstate_type - class(mg_intstate_type),target::this - - end subroutine mg_filtering_lin3 -module subroutine mg_filtering_fast(this) - import mg_intstate_type - class(mg_intstate_type),target::this - - end subroutine mg_filtering_fast -module subroutine sup_vrbeta1 & - (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) -!---------------------------------------------------------------------- - import mg_intstate_type -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,this%i0-hx:im+hx,this%j0-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 sup_vrbeta1 -module subroutine sup_vrbeta1T & -(this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) - import mg_intstate_type - class(mg_intstate_type),target::this - integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm -real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-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 sup_vrbeta1T - module subroutine sup_vrbeta3 & - (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) - import mg_intstate_type - class(mg_intstate_type),target::this - integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm -real(r_kind),dimension(1:kmax,this%i0-hx:im+hx,this%j0-hy:jm+hy,1:lm),intent(inout):: V -real(r_kind),dimension(3,3,this%i0:im,this%j0:jm,1:lm), intent(in):: pasp -real(r_kind),dimension(this%i0:im,this%j0:jm,1:lm), intent(in):: ss - - - end subroutine sup_vrbeta3 - module subroutine sup_vrbeta3T & -!********************************************************************** -! * -! conversion of vrbeta3 * -! * -!********************************************************************** -(this,kmax,hx,hy,hz,im,jm,lm, pasp,ss,V) -!---------------------------------------------------------------------- - import mg_intstate_type -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,this%i0-hx:im+hx,this%j0-hy:jm+hy,1:lm),intent(inout):: V -real(r_kind),dimension(3,3,this%i0:im,this%j0:jm,1:lm), intent(in):: pasp -real(r_kind),dimension(this%i0:im,this%j0:jm,1:lm), intent(in):: ss - end subroutine sup_vrbeta3T - - - end interface -!clt from mg_generations.f90 - interface - module subroutine upsending_all & -!*********************************************************************** -! ! -! Adjoint interpolate and upsend: ! -! ! -!*********************************************************************** -(this,V,H,lquart) -!----------------------------------------------------------------------- - import mg_intstate_type -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 upsending_all - -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine downsending_all & -!*********************************************************************** -! ! -! Downsend, interpolate and add: ! -! First from gm->g3...->g2 ! -! Then from g2->g1 ! -! ! -!*********************************************************************** -(this,H,V,lquart) -!----------------------------------------------------------------------- - import mg_intstate_type -implicit none -class (mg_intstate_type),target:: this - -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V -logical, intent(in):: lquart -end subroutine downsending_all - module subroutine weighting_all & -!*********************************************************************** -! ! -! Apply 2D differential operator to compound variable ! -! ! -!*********************************************************************** -(this,V,H,lhelm) -!----------------------------------------------------------------------- - import mg_intstate_type -implicit none -class (mg_intstate_type),target:: this - -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H -logical, intent(in):: lhelm -end subroutine weighting_all - module subroutine upsending & -!*********************************************************************** -! ! -! Adjoint interpolate and upsend: ! -! First from g1->g2 (V -> H) ! -! Then from g2->...->gn (H -> H) ! -! ! -!*********************************************************************** -(this,V,H) -!----------------------------------------------------------------------- - import mg_intstate_type -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,this%i0-2:this%imL+2,this%j0-2:this%jmL+2):: V_INT -real(r_kind),dimension(this%km,this%i0-2:this%imL+2,this%j0-2:this%jmL+2):: H_INT -end subroutine upsending - module subroutine downsending & -!*********************************************************************** -! ! -! Downsend, interpolate and add: ! -! First from gm->g3...->g2 ! -! Then from g2->g1 ! -! ! -!*********************************************************************** -(this,H,V) -!----------------------------------------------------------------------- - import mg_intstate_type -implicit none -class (mg_intstate_type),target:: this - -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V - -end subroutine downsending - module subroutine upsending2 & -!*********************************************************************** -! ! -! Adjoint interpolate and upsend: ! -! First from g1->g2 (V -> H) ! -! Then from g2->...->gn (H -> H) ! -! ! -!*********************************************************************** -(this,V,H) -!----------------------------------------------------------------------- - import mg_intstate_type -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 upsending2 - - module subroutine downsending2 & -!*********************************************************************** -! ! -! Downsend, interpolate and add: ! -! First from gm->g3...->g2 ! -! Then from g2->g1 ! -! ! -!*********************************************************************** -(this,H,V) -!----------------------------------------------------------------------- - import mg_intstate_type -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 downsending2 -module subroutine weighting_helm & -!*********************************************************************** -! ! -! Apply 2D differential operator to compound variable ! -! ! -!*********************************************************************** -(this,V,H) -!----------------------------------------------------------------------- - import mg_intstate_type -implicit none -class (mg_intstate_type),target:: this - -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H -end subroutine weighting_helm - - - - module subroutine weighting & -!*********************************************************************** -! ! -! Apply 2D differential operator to compound variable ! -! ! -!*********************************************************************** -(this,V,H) -!----------------------------------------------------------------------- - import mg_intstate_type -implicit none -class (mg_intstate_type),target:: this - -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: V -real(r_kind),dimension(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy),intent(inout):: H -end subroutine weighting - -module subroutine adjoint & -!*********************************************************************** -! ! -! Mapping from the high to low resolution grid ! -! using linearly squared interpolations ! -! - offset version - ! -! ! -!*********************************************************************** -(this,F,W,km_in,g) -!----------------------------------------------------------------------- - import mg_intstate_type -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,this%i0:this%im,this%j0:this%jm), intent(in):: F -real(r_kind), dimension(km_in,this%i0-2:this%imL+2,this%j0-2:this%jmL+2), intent(out):: W -end subroutine adjoint - -module subroutine direct1 & -!*********************************************************************** -! ! -! Mapping from the low to high resolution grid ! -! using linearly squared interpolations ! -! - offset version - ! -! ! -!*********************************************************************** -(this,W,F,km_in,g) -!----------------------------------------------------------------------- - import mg_intstate_type -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,this%i0-2:this%imL+2,this%j0-2:this%jmL+2), intent(in):: W -real(r_kind), dimension(km_in,this%i0:this%im,this%j0:this%jm), intent(out):: F -end subroutine direct1 -module subroutine adjoint2 & -!*********************************************************************** -! ! -! Mapping from the high to low resolution grid ! -! using quadratics interpolations ! -! - offset version - ! -! ! -!*********************************************************************** -(this,F,W,km_in,g) -!----------------------------------------------------------------------- - import mg_intstate_type -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 adjoint2 - - module subroutine direct2 & -!*********************************************************************** -! ! -! Mapping from the low to high resolution grid ! -! using quadratic interpolations ! -! - offset version - ! -! ! -!*********************************************************************** -(this,W,F,km_in,g) -!----------------------------------------------------------------------- - import mg_intstate_type -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 direct2 - - module subroutine mg_initialize(this,inputfilename,obj_parameter) - import mg_intstate_type - import mg_parameter_type -class (mg_intstate_type):: this -character*(*),optional,intent(in) :: inputfilename -class(mg_parameter_type),optional,intent(in)::obj_parameter - end subroutine mg_initialize - module subroutine mg_finalize(this) - import mg_intstate_type -implicit none -class (mg_intstate_type)::this - end subroutine mg_finalize - - - - - end interface + 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 +contains !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -!cltthink doublecheck subroutine allocate_mg_intstate(this,km) - subroutine allocate_mg_intstate(this) +subroutine allocate_mg_intstate(this) !*********************************************************************** ! ! ! Allocate internal state variables ! ! ! !*********************************************************************** - import mg_intstate_type 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(this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy,this%lm)) ; this%V=0. -allocate(this%VALL(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%VALL=0. -allocate(this%HALL(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%HALL=0. - +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,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%a_diff_f=0. -allocate(this%a_diff_h(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%a_diff_h=0. -allocate(this%b_diff_f(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%b_diff_f=0. -allocate(this%b_diff_h(this%km,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%b_diff_h=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(this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%p_eps=0. -allocate(this%p_del(this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%p_del=0. -allocate(this%p_sig(this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%p_sig=0. -allocate(this%p_rho(this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy)) ; this%p_rho=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,this%i0:this%im)) ; this%paspx=0. -allocate(this%paspy(1,1,this%j0:this%jm)) ; this%paspy=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,this%i0:this%im,this%j0:this%jm)) ; this%pasp2=0. -allocate(this%pasp3(3,3,this%i0:this%im,this%j0:this%jm,1:this%lm)) ; this%pasp3=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,this%i0:this%im,this%j0:this%jm)) ; this%vpasp2=0. -allocate(this%hss2(this%i0:this%im,this%j0:this%jm,1:3)) ; this%hss2= 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,this%i0:this%im,this%j0:this%jm,1:this%lm)) ; this%vpasp3= 0. -allocate(this%hss3(this%i0:this%im,this%j0:this%jm,1:this%lm,1:6)) ; this%hss3= 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(this%i0:this%im)) ; this%ssx=0. -allocate(this%ssy(this%j0:this%jm)) ; this%ssy=0. -allocate(this%ss1(1:this%lm)) ; this%ss1=0. -allocate(this%ss2(this%i0:this%im,this%j0:this%jm)) ; this%ss2=0. -allocate(this%ss3(this%i0:this%im,this%j0:this%jm,1:this%lm)) ; this%ss3=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(this%i0:this%im,this%j0:this%jm,3)) ; this%dixs=0 -allocate(this%diys(this%i0:this%im,this%j0:this%jm,3)) ; this%diys=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(this%i0:this%im,this%j0:this%jm,1:this%lm,6)) ; this%dixs3=0 -allocate(this%diys3(this%i0:this%im,this%j0:this%jm,1:this%lm,6)) ; this%diys3=0 -allocate(this%dizs3(this%i0:this%im,this%j0:this%jm,1:this%lm,6)) ; this%dizs3=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,this%i0:this%im,this%j0:this%jm,1:this%lm)) ; this%qcols=0 - -! -! In stnadalone version -! -!allocate(r_vol(km,0:nm,0:mm,2)) ; r_vol=0. -! -! ... but in global version there will be -! r_vol2 and r_vol3 for 2d and 3d variables -! and r_vol3 will need to be given vertical structure -! - -! -!cltallocate(WORKA(km,n0:nm,m0:mm)) ; WORKA=0. +allocate(this%qcols(0:7,1:this%im,1:this%jm,1:this%lm)) ; this%qcols=0 ! ! for re-decomposition ! -allocate(this%iref(this%n0:this%nm)) ; this%iref=0 -allocate(this%jref(this%m0:this%mm)) ; this%jref=0 - -allocate(this%cx0(this%n0:this%nm)) ; this%cx0=0. -allocate(this%cx1(this%n0:this%nm)) ; this%cx1=0. -allocate(this%cx2(this%n0:this%nm)) ; this%cx2=0. -allocate(this%cx3(this%n0:this%nm)) ; this%cx3=0. - -allocate(this%cy0(this%m0:this%mm)) ; this%cy0=0. -allocate(this%cy1(this%m0:this%mm)) ; this%cy1=0. -allocate(this%cy2(this%m0:this%mm)) ; this%cy2=0. -allocate(this%cy3(this%m0:this%mm)) ; this%cy3=0. - -!TEST -! call finishMPI -!TEST - -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(this%n0:this%nm,this%m0:this%mm)) ; this%cf00=0. -allocate(this%cf01(this%n0:this%nm,this%m0:this%mm)) ; this%cf01=0. -allocate(this%cf02(this%n0:this%nm,this%m0:this%mm)) ; this%cf02=0. -allocate(this%cf03(this%n0:this%nm,this%m0:this%mm)) ; this%cf03=0. -allocate(this%cf10(this%n0:this%nm,this%m0:this%mm)) ; this%cf10=0. -allocate(this%cf11(this%n0:this%nm,this%m0:this%mm)) ; this%cf11=0. -allocate(this%cf12(this%n0:this%nm,this%m0:this%mm)) ; this%cf12=0. -allocate(this%cf13(this%n0:this%nm,this%m0:this%mm)) ; this%cf13=0. -allocate(this%cf20(this%n0:this%nm,this%m0:this%mm)) ; this%cf20=0. -allocate(this%cf21(this%n0:this%nm,this%m0:this%mm)) ; this%cf21=0. -allocate(this%cf22(this%n0:this%nm,this%m0:this%mm)) ; this%cf22=0. -allocate(this%cf23(this%n0:this%nm,this%m0:this%mm)) ; this%cf23=0. -allocate(this%cf30(this%n0:this%nm,this%m0:this%mm)) ; this%cf30=0. -allocate(this%cf31(this%n0:this%nm,this%m0:this%mm)) ; this%cf31=0. -allocate(this%cf32(this%n0:this%nm,this%m0:this%mm)) ; this%cf32=0. -allocate(this%cf33(this%n0:this%nm,this%m0:this%mm)) ; this%cf33=0. - -allocate(this%Lref(1:this%lm)) ; this%Lref=0 -allocate(this%Lref_h(1:this%lm)) ; this%Lref_h=0 - -allocate(this%cvf1(1:this%lm)) ; this%cvf1=0. -allocate(this%cvf2(1:this%lm)) ; this%cvf2=0. -allocate(this%cvf3(1:this%lm)) ; this%cvf3=0. -allocate(this%cvf4(1:this%lm)) ; 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. - +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 +endsubroutine allocate_mg_intstate !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine def_mg_weights(this) +subroutine def_mg_weights(this) !*********************************************************************** ! ! ! Define weights and scales ! - import mg_intstate_type ! ! implicit none class (mg_intstate_type),target::this @@ -1005,94 +1156,143 @@ subroutine def_mg_weights(this) 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 +this%p_eps(:,:)=0.0 +this%p_del(:,:)=0.0 +this%p_sig(:,:)=0.0 +this%p_rho(:,:)=0.0 !-------------------------------------------------------- - 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. - -! r_vol(:,:,:,1)=1. - - - select case(this%my_hgen) - case(2) -! r_vol(:,:,:,2)=0.25 ! In standalone case -! gen_fac=0.25 - this%a_diff_h(:,:,:)=this%mg_weig2 - this%b_diff_h(:,:,:)=0. - case(3) -! r_vol(:,:,:,2)=0.0625 ! In standalone case -! gen_fac=0.0625 - this%a_diff_h(:,:,:)=this%mg_weig3 - this%b_diff_h(:,:,:)=0. - case default -! r_vol(:,:,:,2)=0.015625 ! In standalone case -! gen_fac=0.015625 - this%a_diff_h(:,:,:)=this%mg_weig4 - this%b_diff_h(:,:,:)=0. - end select - - - do L=1,this%lm - this%pasp1(1,1,L)=this%pasp01 - enddo - - do i=this%i0,this%im - this%paspx(1,1,i)=this%pasp02 - enddo - do j=this%j0,this%jm - this%paspy(1,1,j)=this%pasp02 - enddo - - do j=this%i0,this%jm - do i=this%j0,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=this%i0,this%jm - do i=this%j0,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 - - - call this%cholaspect(1,this%lm,this%pasp1) - call this%cholaspect(this%i0,this%im,this%j0,this%jm,this%pasp2) - call this%cholaspect(this%i0,this%im,this%j0,this%jm,1,this%lm,this%pasp3) - - - call this%getlinesum(this%hx,this%i0,this%im,this%paspx,this%ssx) - call this%getlinesum(this%hy,this%j0,this%jm,this%paspy,this%ssy) - call this%getlinesum(this%hz,1,this%lm,this%pasp1,this%ss1) - call this%getlinesum(this%hx,this%i0,this%im,this%hy,this%j0,this%jm,this%pasp2,this%ss2) - call this%getlinesum(this%hx,this%i0,this%im,this%hy,this%j0,this%jm,this%hz,1,this%lm,this%pasp3,this%ss3) +! +! 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 +endsubroutine def_mg_weights !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine init_mg_line(this) - import mg_intstate_type +subroutine init_mg_line(this) implicit none class(mg_intstate_type),target::this integer(i_kind):: i,j,L,icol @@ -1104,44 +1304,39 @@ subroutine init_mg_line(this) !*********************************************************************** !----------------------------------------------------------------------- - do j=this%j0,this%jm - do i=this%i0,this%im - call t22_to_3(this%pasp2(:,:,i,j),this%vpasp2(:,i,j)) - enddo - enddo - - do l=1,this%lm - do j=this%j0,this%jm - do i=this%i0,this%im - call t33_to_6(this%pasp3(:,:,i,j,l),this%vpasp3(:,i,j,l)) - enddo - enddo - enddo +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 inimomtab(this%p,this%nh,ff) +call tritform(1,this%im,1,this%jm,this%vpasp2, this%dixs,this%diys, ff) - call tritform(this%i0,this%im,this%i0,this%jm,this%vpasp2, this%dixs,this%diys, ff) +do icol=1,3 + this%hss2(:,:,icol)=this%vpasp2(icol-1,:,:) +enddo - 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) - - call hextform(this%i0,this%im,this%j0,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 +do icol=1,6 + this%hss3(:,:,:,icol)=this%vpasp3(icol,:,:,:) +enddo - !----------------------------------------------------------------------- - endsubroutine init_mg_line +endsubroutine init_mg_line !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine deallocate_mg_intstate(this) +subroutine deallocate_mg_intstate(this) implicit none class (mg_intstate_type),target:: this !*********************************************************************** @@ -1160,15 +1355,13 @@ subroutine deallocate_mg_intstate(this) deallocate(this%dixs,this%diys) deallocate(this%dixs3,this%diys3,this%dizs3) deallocate(this%qcols) -! -! for testing -! -!cltthink deallocate(WORKA) ! ! 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) @@ -1182,12 +1375,20 @@ subroutine deallocate_mg_intstate(this) 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 subroutine deallocate_mg_intstate !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - end module mg_intstate +end module mg_intstate diff --git a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 index beec75e6f..e1d24b180 100644 --- a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 @@ -1,27 +1,40 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - submodule(mg_parameter) mg_mppstuff -!*********************************************************************** -! ! -! Everything related to mpi communication ! -! ! -! Library: mpi ! -! Modules: kinds, mg_parameter ! -! M. Rancic (2020) ! -!*********************************************************************** +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 - -!keep_for_now integer(i_kind):: ns,ms,ninc,minc,ninc2,minc2 - - - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - contains +contains !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine init_mg_MPI(this) +module subroutine init_mg_MPI(this) !*********************************************************************** ! ! ! Initialize mpi ! @@ -30,7 +43,6 @@ module subroutine init_mg_MPI(this) !*********************************************************************** use mpi - implicit none class (mg_parameter_type),target:: this integer(i_kind):: g,m @@ -38,34 +50,26 @@ module subroutine init_mg_MPI(this) integer(i_kind):: nf integer(i_kind)::ierr integer(i_kind):: color -include "type_parameter_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" !----------------------------------------------------------------------- -!cltorg mpi_comm_comp=MPI_COMM_WORLD !*** !*** Initial MPI calls !*** -!cltorg call MPI_INIT(ierr) 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 - write(6,*)'thinkdebmype is ',mype 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 !*** @@ -73,31 +77,9 @@ module subroutine init_mg_MPI(this) nx = mod(mype,nxm)+1 my = (mype/nxm)+1 -! if(nx==1) then -! ns=0 -! ninc=1 -! ninc2=2 -! else -! ns=1 -! ninc=0 -! ninc2=1 -! endif -! -! if(my==1) then -! ms=0 -! minc=1 -! minc2=2 -! else -! ms=1 -! minc=0 -! minc2=1 -! endif - - !*** !*** Define PEs that handle high generations !*** - mype_hgen=-1 my_hgen=-1 @@ -112,17 +94,12 @@ module subroutine init_mg_MPI(this) enddo l_hgen = mype_hgen >-1 -!TEST -! write(300+mype,*)'mype,my_hgen,l_gen,mype_hgen=',mype,my_hgen,l_hgen,mype_hgen -!TEST - !*** !*** Chars !*** write(c_mype,1000) mype 1000 format(i5.5) - !----------------------------------------------------------------------- ! call MPI_BARRIER(mpi_comm_comp,ierr) @@ -150,7 +127,6 @@ module subroutine init_mg_MPI(this) 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) @@ -161,24 +137,15 @@ module subroutine init_mg_MPI(this) endif -!TEST -! write(mype+100,*) 'mype, mype_gr=',mype, mype_gr -! print *, 'mype, mype_gr=',mype, mype_gr -! call MPI_FINALIZE(this@mpi_comm_comp) -! stop -!TEST - - - !----------------------------------------------------------------------- ! call MPI_BARRIER(mpi_comm_comp,ierr) ! !----------------------------------------------------------------------- - endsubroutine init_mg_MPI +endsubroutine init_mg_MPI !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine barrierMPI(this) +module subroutine barrierMPI(this) !*********************************************************************** ! ! ! Call barrier for all ! @@ -187,19 +154,19 @@ module subroutine barrierMPI(this) use mpi implicit none - class(mg_parameter_type),target::this +class(mg_parameter_type),target::this integer(i_kind):: ierr -include "type_parameter_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" !----------------------------------------------------------------------- call MPI_BARRIER(mpi_comm_comp,ierr) !----------------------------------------------------------------------- - endsubroutine barrierMPI +endsubroutine barrierMPI !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine finishMPI(this) +module subroutine finishMPI(this) !*********************************************************************** ! ! ! Finalize MPI ! @@ -208,15 +175,16 @@ module subroutine finishMPI(this) use mpi implicit none - class(mg_parameter_type),target::this -!cltthinkdeb don't need mpi_finalize if mgbf is a lib to be called from outside +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 +endsubroutine finishMPI !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - end submodule mg_mppstuff +end submodule mg_mppstuff diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 1f7b2f84b..f08b87aab 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -1,27 +1,38 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_parameter -!*********************************************************************** -! ! -! Set resolution, grid and decomposition ! -! - offset version - ! -! ! -! Note: ixm(1)=nxm, jym(1)=mym ! -! ! -! 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) ! -! ! -! Modules: kinds, jp_pietc ! -! M. Rancic (2022) ! -!*********************************************************************** -!clt org use mpi +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 -!use berror, only: mg_ampl0,im_filt,jm_filt -!TEST -!use mpimod, only: nxpe,nype -!TEST implicit none type:: mg_parameter_type @@ -31,7 +42,9 @@ module mg_parameter !*** 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 +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 @@ -40,6 +53,7 @@ module mg_parameter !*** Number of generations !*** integer(i_kind):: gm +integer(i_kind):: gm_max !*** !*** Horizontal resolution @@ -61,7 +75,7 @@ module mg_parameter ! Number of PEs on Analysis grid ! integer(i_kind):: nxm -integer(i_kind):: mym +integer(i_kind):: nym ! ! Number of data on local Analysis grid @@ -104,14 +118,12 @@ module mg_parameter 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 @@ -119,22 +131,31 @@ module mg_parameter integer, allocatable, dimension(:):: FimaxL,FjmaxL integer(i_kind):: npes_filt - integer(i_kind):: maxpe_filt integer(i_kind):: imL,jmL -integer(i_kind):: lm ! number of vertical layers -integer(i_kind):: lm05 ! half of vertical levels -integer(i_kind):: km2_f ! number of 2d variables for filtering -integer(i_kind):: km3_f ! number of 3d variables for filtering -integer(i_kind):: km2_e ! number of 2d variables for ensemble -integer(i_kind):: km3_e ! number of 3d variables for ensemble -logical :: l_filt ! logical flag for filtering or enseble -!integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) -integer(i_kind):: lmf ! number of vertical levels for filtering (generation one) -integer(i_kind):: lmh ! number of vertical levels for filtering (high generations) - - +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 @@ -149,362 +170,301 @@ module mg_parameter ! Just for standalone test ! logical:: ldelta -!cltmovedfrom mg_entrymod.f90 -integer(i_kind):: km,km2,km3 -!cltmoved from type_mg_mppstuff.f90 -integer(i_kind):: mype + +!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 +integer(i_kind):: my_hgen +integer(i_kind):: mype_hgen logical:: l_hgen integer(i_kind):: nx,my -!clt moved from *_mg_domain.f90 +!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),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):: 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 -procedure:: init_mg_MPI -procedure:: finishMPI -procedure:: barrierMPI - -!clt from mg_domain -procedure:: init_mg_domain -!clt 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 + 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) - import :: mg_parameter_type - class(mg_parameter_type),target :: this - end subroutine init_mg_MPI + class(mg_parameter_type),target :: this + end subroutine module subroutine finishMPI(this) - import :: mg_parameter_type - class(mg_parameter_type),target :: this - end subroutine finishMPI + class(mg_parameter_type),target :: this + end subroutine module subroutine barrierMPI(this) - import :: mg_parameter_type - class(mg_parameter_type),target :: this - end subroutine barrierMPI + class(mg_parameter_type),target :: this + end subroutine +!from mg_domain.f90 module subroutine init_mg_domain(this) - import mg_parameter_type class(mg_parameter_type)::this - end subroutine init_mg_domain - module subroutine init_domain(this) - import mg_parameter_type + end subroutine + module subroutine init_domain(this) class(mg_parameter_type),target::this - end subroutine init_domain - - module subroutine init_topology_2d(this) - import mg_parameter_type - class(mg_parameter_type),target::this - end subroutine init_topology_2d - module subroutine real_itarg (this,itarg) - import mg_parameter_type - class(mg_parameter_type),target::this - integer(i_kind), intent(inout):: itarg - end subroutine real_itarg - -end interface -!clt from jp_pbfil -!clt from jb_pbfile - -interface - -module subroutine cholaspect1(lx,mx, el) ! [cholaspect] -use kinds, only: dp=>r_kind -integer, intent(in ):: lx,mx -real(dp),dimension(1,1,lx:mx),intent(inout):: el -!----------------------------------------------------------------------------- -end subroutine cholaspect1 -module subroutine cholaspect2(lx,mx, ly,my, el) ! [cholaspect] -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 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 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 cholaspect3 - -module subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el) ! [cholaspect] -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 cholaspect4 -module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [getlinesum] -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 getlinesum1 - -module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum] -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 getlinesum2 -module subroutine getlinesum3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss)! [getlinesum] -!============================================================================= -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 getlinesum3 -module subroutine getlinesum4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & - el, ss) ! [getlinesum] -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 getlinesum4 - -module subroutine rbeta1(this,hx,lx,mx, el,ss, a) ! [rbeta] -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 rbeta1 - -module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] -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 rbeta2 -module subroutine rbeta3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] -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 rbeta3 -module subroutine rbeta4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a)! [rbeta] -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 rbeta4 -module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) ! [rbetat] -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 rbeta1T -module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] -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 rbeta2T -module subroutine rbeta3T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] -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 rbeta3T -module subroutine rbeta4T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & - el,ss, a) ! [rbetat] -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 rbeta4T -module subroutine vrbeta4t(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, & - hw,lw,mw, el,ss, a)! [rbetat] -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 vrbeta4t -module subroutine vrbeta1(this,nv,hx,lx,mx, el,ss, a) ! [rbeta] -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 vrbeta1 -module subroutine vrbeta2(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] -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 vrbeta2 -module subroutine vrbeta3(this,nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] -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 vrbeta3 -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 - -end subroutine vrbeta4 -module subroutine vrbeta1T(this,nv, hx,lx,mx, el,ss, a) ! [rbetat] -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 vrbeta1T -module subroutine vrbeta2T(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] -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 vrbeta2T -module subroutine vrbeta3T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] -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 vrbeta3T + 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 +contains !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine init_mg_parameter(this,inputfilename) +subroutine init_mg_parameter(this,inputfilename) !**********************************************************************! ! ! ! Initialize .... ! @@ -514,8 +474,8 @@ subroutine init_mg_parameter(this,inputfilename) class (mg_parameter_type),target:: this integer(i_kind):: g character(*):: inputfilename -!*** Namelist parameters as local variable -!*** + +! 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 @@ -524,38 +484,43 @@ subroutine init_mg_parameter(this,inputfilename) logical:: lquart,lhelm logical:: ldelta -integer(i_kind):: lm ! number of vertical layers -integer(i_kind):: km2_f ! number of 2d variables for filtering -integer(i_kind):: km3_f ! number of 3d variables for filtering -integer(i_kind):: km2_e ! number of 2d variables for ensemble -integer(i_kind):: km3_e ! number of 3d variables for ensemble -logical :: l_filt ! logical flag for filtering or enseble -!integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) -integer(i_kind):: lmf ! number of vertical levels for filtering (generation one) -integer(i_kind):: lmh ! number of vertical levels for filtering (high generations) +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 -!clt include "type_parameter_locpointer.inc" -!clt include "type_parameter_point2this.inc" - -! -! Set number of PEs in x and y directions -! 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,lmf,lmh & - ,km2_f,km3_f,km2_e,km3_e & - ,l_filt & + ,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 ! @@ -564,7 +529,7 @@ subroutine init_mg_parameter(this,inputfilename) close(unit=10) ! !----------------------------------------------------------------- -!clt for safety, copy all namelist loc vars to them of this object +!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 @@ -578,14 +543,18 @@ subroutine init_mg_parameter(this,inputfilename) this%p =p this%mgbf_line=mgbf_line this%mgbf_proc=mgbf_proc + this%lm_a=lm_a this%lm=lm - this%lmf=lmf - this%lmh=lmh - this%km2_f=km2_f - this%km3_f=km3_f - this%km2_e=km2_e - this%km3_e=km3_e - this%l_filt=l_filt + 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 @@ -595,14 +564,12 @@ subroutine init_mg_parameter(this,inputfilename) this%nyPE=nyPE this%im_filt=im_filt this%jm_filt=jm_filt -!clt + this%nxm = nxPE + this%nym = nyPE - this%nxm = nxPE - this%mym = nyPE -! - this%im = im_filt - this%jm = jm_filt + this%im = im_filt + this%jm = jm_filt !----------------------------------------------------------------- ! @@ -610,79 +577,94 @@ subroutine init_mg_parameter(this,inputfilename) ! For 168 PES ! ! nxm = 14 -! mym = 12 +! nym = 12 ! ! For 256 PES ! -! ! nxm = 16 -! mym = 16 +! nym = 16 ! ! For 336 PES ! ! nxm = 28 -! mym = 12 +! nym = 12 ! ! For 448 PES ! ! nxm = 28 -! mym = 16 -! +! nym = 16 ! ! For 512 PES ! ! nxm = 32 -! mym = 16 +! nym = 16 ! ! For 704 PES ! ! nxm = 32 -! mym = 22 +! nym = 22 ! ! For 768 PES ! ! nxm = 32 -! mym = 24 -! +! nym = 24 ! ! For 924 PES ! ! nxm = 28 -! mym = 33 +! nym = 33 ! ! For 1056 PES ! ! nxm = 32 -! mym = 33 +! nym = 33 ! ! For 1408 PES ! ! nxm = 32 -! mym = 44 +! nym = 44 ! ! For 1848 PES ! ! nxm = 56 -! mym = 33 +! nym = 33 ! ! For 2464 PES ! ! nxm = 56 -! mym = 44 +! 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%mym,this%gm) + call def_maxgen(this%nxm,this%nym,this%gm) -! Restrict to 4 +! Restrict to gm_max - if(this%gm>4) then - this%gm=4 - endif -! + 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 @@ -692,26 +674,15 @@ subroutine init_mg_parameter(this,inputfilename) ! Number of grid intervals on GSI grid for the reduced RTMA domain ! before padding ! - this%nA_max0 = 1792 - this%mA_max0 = 1056 - + this%nA_max0 = 1792 + this%mA_max0 = 1056 ! ! Number of grid points on the analysis grid after padding ! -!SMALL DOMAIN -! nm0 = 1792 -! mm0 = 1056 -!SMALL DOMAIN - -!TEST -! nm0 = 384 -! mm0 = 384 -!TEST - - this%nm = this%nm0/this%nxm - this%mm = this%mm0/this%mym + this%nm = this%nm0/this%nxm + this%mm = this%mm0/this%nym !*** !*** Filter grid @@ -725,20 +696,17 @@ subroutine init_mg_parameter(this,inputfilename) ! ! im = 120 ! jm = 80 - +! ! For 256 PES ! - ! im = 96 ! jm = 64 - +! ! im = 88 ! jm = 56 - ! ! For 336 PES ! - ! im = 56 ! jm = 80 ! @@ -788,8 +756,7 @@ subroutine init_mg_parameter(this,inputfilename) ! jm = 20 this%im00 = this%nxm*this%im - this%jm00 = this%mym*this%jm - + this%jm00 = this%nym*this%jm this%n0 = 1 this%m0 = 1 @@ -798,142 +765,115 @@ subroutine init_mg_parameter(this,inputfilename) this%j0 = 1 ! -! Make sure that nm0 and mm0 and divisibvle with nxm and mym +! 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%mym /= this%mm0 ) then - write(17,*) 'mm,mym,mm0=',this%mm,this%mym,this%mm0 - stop 'mm0 is not divisible by mym' + 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%mym) - - - 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) -!TEST -! write(15,*)'Fimax(',g,')=',Fimax(g) -! write(15,*)'Fjmax(',g,')=',Fjmax(g) -!TEST - enddo - - do g=1,this%gm - this%FimaxL(g)=this%Fimax(g)/2 - this%FjmaxL(g)=this%Fjmax(g)/2 - enddo - + 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 !** -!D lengthx = 6. ! arbitrary chosen scale of the domain -!D lengthy = 6. ! arbitrary chosen scale of the domain - this%lengthx = 1.*this%nm ! arbitrary chosen scale of the domain - this%lengthy = 1.*this%mm ! arbitrary chosen scale of the domain + 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%ib=6 !cltthinkdeb what - this%jb=6 + this%dxa =this%lengthx/this%nm + this%dxf = this%lengthx/this%im + this%nb = 2*this%dxf/this%dxa - 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%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 -!D xa0 =0. -!D ya0 =0. - this%xa0 = this%dxa*0.5 - this%ya0 = this%dya*0.5 - -!D xf0=-dxf*0.5 -!D yf0=-dyf*0.5 - this%xf0 = this%dxf*0.5 - this%yf0 = this%dyf*0.5 + this%xf0 = this%dxf*0.5 + this%yf0 = this%dyf*0.5 this%imL=this%im/2 this%jmL=this%jm/2 -! pasp0=1 -! pasp0 = 5 ! Main -!! pasp0 = 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 - -!TEST hx=8 -!TEST hz=8 -!TEST hz=4 -!TEST hz=5 -! hx=6 -! hy=hx -! hz=6 - - this%nh= 6 + this%nh= max(hx,hy,hz) this%nfil = this%nh + 2 -! p = 4 ! Exponent of Beta function -! p = 2 ! Exponent of Beta function - - 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) - !clt call this%init_mg_MPI - !clt call this%init_mg_domain + 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 +end subroutine init_mg_parameter !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine def_maxgen & +subroutine def_maxgen & !********************************************************************** ! ! ! Given number of PEs in x and y direction decides what is the ! @@ -941,10 +881,10 @@ subroutine def_maxgen & ! ! ! M. Rancic 2020 ! !********************************************************************** -(nxm,mym,gm) +(nxm,nym,gm) !---------------------------------------------------------------------- implicit none -integer, intent(in):: nxm,mym +integer, intent(in):: nxm,nym integer, intent(out):: gm integer:: npx,npy,gx,gy @@ -955,7 +895,7 @@ subroutine def_maxgen & if(npx == 1) exit end do - npy = mym; gy=1 + npy = nym; gy=1 Do npy = (npy + 1)/2 gy = gy + 1 @@ -966,10 +906,10 @@ subroutine def_maxgen & !---------------------------------------------------------------------- - endsubroutine def_maxgen +endsubroutine def_maxgen !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - subroutine def_ngens & +subroutine def_ngens & !*********************************************************************! ! ! ! Given number of generations, find number of PEs is s direction ! @@ -990,7 +930,7 @@ subroutine def_ngens & end do !---------------------------------------------------------------------- - endsubroutine def_ngens +endsubroutine def_ngens !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - end module mg_parameter +end module mg_parameter diff --git a/src/saber/mgbf/mgbf_lib/mg_timers.f90 b/src/saber/mgbf/mgbf_lib/mg_timers.f90 old mode 100755 new mode 100644 index ce9fead20..0905d4d86 --- a/src/saber/mgbf/mgbf_lib/mg_timers.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_timers.f90 @@ -1,11 +1,32 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module mg_timers -!*********************************************************************** -! ! -! Measure cpu and wallclock timing ! -! D. Jovic (2017) ! -! Adjusted: M. Rancic (2020) ! -!*********************************************************************** +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 @@ -33,9 +54,11 @@ module mg_timers type(timer),save,public :: an2filt_tim type(timer),save,public :: filt2an_tim type(timer),save,public :: weight_tim - type(timer),save,public :: bfiltT_tim + type(timer),save,public :: hfiltT_tim + type(timer),save,public :: vfiltT_tim type(timer),save,public :: vadv1_tim - type(timer),save,public :: bfilt_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 @@ -52,6 +75,7 @@ module mg_timers 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, & @@ -124,8 +148,8 @@ subroutine print_mg_timers(filename, print_type,mype) upsend_tim%time_clock, & dnsend_tim%time_clock, & weight_tim%time_clock, & - bfiltT_tim%time_clock, & - bfilt_tim%time_clock, & + hfiltT_tim%time_clock, & + hfilt_tim%time_clock, & filt2an_tim%time_clock, & aintp_tim%time_clock, & intp_tim%time_clock, & @@ -133,14 +157,18 @@ subroutine print_mg_timers(filename, print_type,mype) output_tim%time_clock, & total_tim%time_clock else if ( print_type == print_cpu ) then - write(buffer,"(I6,10(',',F10.4))") mype, & + write(buffer,"(I6,14(',',F10.4))") mype, & init_tim%time_cpu, & an2filt_tim%time_cpu, & + vfiltT_tim%time_cpu, & upsend_tim%time_cpu, & - bfiltT_tim%time_cpu, & + hfiltT_tim%time_cpu, & + bocoT_tim%time_cpu, & weight_tim%time_cpu, & - bfilt_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 @@ -149,14 +177,18 @@ subroutine print_mg_timers(filename, print_type,mype) bufsize = LEN(TRIM(buffer)) + 1 buffer(bufsize:bufsize) = NEW_LINE(' ') - write(header,"(A6,10(',',A10))") "mype", & + write(header,"(A6,14(',',A10))") "mype", & "init", & "an2filt", & + "vfiltT", & "upsend", & - "bfiltT", & + "hfiltT", & + "bocoT" , & "weight", & - "bfilt", & + "boco", & + "hfilt", & "dnsend", & + "vfilt", & "filt2an", & "output", & "total" @@ -183,4 +215,4 @@ function ctime() call CPU_TIME(ctime) endfunction ctime !----------------------------------------------------------------------- - endmodule mg_timers +end module mg_timers diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index d2e7bc239..5f929c024 100644 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -1,26 +1,50 @@ -!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - submodule(mg_intstate) mg_transfer -!*********************************************************************** -! ! -! Transfer data between analysis and filter grid ! -! ! -! Modules: kinds, mg_parameter, mg_intstate, mg_bocos, mg_interpolate, ! -! mg_timers, mg_mppstuff ! -! M. Rancic (2021) ! -!*********************************************************************** +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 -!TEST -!use mg_output, only: output_spec1_2dd -!TEST - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - contains +contains !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine anal_to_filt_all(this,WORKA) +module subroutine anal_to_filt_allmap(this,WORKA) !*********************************************************************** ! ! ! Transfer data from analysis to first generaton of filter grid ! @@ -28,48 +52,101 @@ module subroutine anal_to_filt_all(this,WORKA) !*********************************************************************** implicit none class(mg_intstate_type),target::this -real (r_kind):: WORKA(this%km,this%n0:this%nm,this%m0:this%mm) - -real(r_kind),allocatable,dimension(:,:,:):: VLOC -include "type_parameter_locpointer.inc" +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_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 - allocate(VLOC(km,i0-ib:im+ib,j0-jb:jm+jb)) - - -!T call btim( aintp_tim) - - VLOC=0. - call this%lsqr_adjoint_offset(WORKA,VLOC,km) - - -!T call etim( aintp_tim) +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +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 -!*** -!*** Apply adjoint lateral bc on PKF and WKF -!*** - + do L=1,lm + F3D(:,:,:,L)=A3D(:,:,:,L) + enddo - call this%bocoT_2d(VLOC,km,im,jm,ib,jb) - - VALL=0. - VALL(1:km,i0:im,j0:jm)=VLOC(1:km,i0:im,j0:jm) - + endif - deallocate(VLOC) + call this%C2S_ens(F3D,WORK,1,nm,1,mm,lm,km,km_all) -! call etim( btrns1_tim) + call this%anal_to_filt(WORK) + call etim(an2filt_tim) +deallocate(A3D,F3D,WORK) !---------------------------------------------------------------------- - endsubroutine anal_to_filt_all +endsubroutine anal_to_filt_all !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine filt_to_anal_all(this,WORKA) +module subroutine filt_to_anal_all(this,WORKA) !*********************************************************************** ! ! ! Transfer data from filter to analysis grid ! @@ -77,68 +154,113 @@ module subroutine filt_to_anal_all(this,WORKA) !*********************************************************************** implicit none class(mg_intstate_type),target::this -real (r_kind):: WORKA(this%km,this%n0:this%nm,this%m0:this%mm) - - -real(r_kind),allocatable,dimension(:,:,:):: VLOC -include "type_parameter_locpointer.inc" +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_parameter_point2this.inc" include "type_intstat_point2this.inc" -!TEST -!real(r_kind), allocatable, dimension(:,:):: PA -!TEST - !---------------------------------------------------------------------- +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)) -!T call btim( btrns2_tim) + call btim(filt2an_tim) + call this%filt_to_anal(WORK) -!*** -!*** Define VLOC -!*** + call this%S2C_ens(WORK,F3D,1,nm,1,mm,lm,km,km_all) - allocate(VLOC(1:km,i0-ib:im+ib,j0-jb:jm+jb)) + 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 - VLOC=0. - VLOC(1:km,i0:im,j0:jm)=VALL(1:km,i0:im,j0:jm) - + do L=1,lm + A3D(:,:,:,L)=F3D(:,:,:,L) + enddo -!*** -!*** Supply boundary conditions for VLOC -!*** - call this%boco_2d(VLOC,km,im,jm,ib,jb) + endif + call this%C2S_ens(A3D,WORKA,1,nm,1,mm,lm_a,km_a,km_a_all) + call etim(filt2an_tim) -!*** -!*** Interpolate to analysis grid composite variables -!*** -!TEST -! allocate(PA(1:im,1:jm)) -! -! PA(1:im,1:jm)=VLOC(3*lm+lm/2,1:im,1:jm) -! -! call output_spec1_2dd(PA,im,jm) -! -! call finishMPI -!TEST +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)) -!T call btim( intp_tim) + 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%lsqr_direct_offset(VLOC,WORKA,this%km) !cltthink + call this%anal_to_filt(WORK) + call etim(an2filt_tim) -!T call etim( intp_tim) - deallocate(VLOC) +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)) -!T call etim( btrns2_tim) + call btim(filt2an_tim) + call this%filt_to_anal(WORK) -!---------------------------------------------------------------------- - endsubroutine filt_to_anal_all + 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 & +module subroutine stack_to_composite & !*********************************************************************** ! ! ! Transfer data from stack to composite variables ! @@ -148,18 +270,18 @@ module subroutine stack_to_composite & !---------------------------------------------------------------------- implicit none class(mg_intstate_type),target::this -real(r_kind),dimension(this%km ,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy), intent(in):: ARR_ALL -real(r_kind),dimension(this%km3,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy,this%lm),intent(out):: A3D -real(r_kind),dimension(this%km2,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy) ,intent(out):: A2D -!---------------------------------------------------------------------- -integer(i_kind)::i,j,k, L -include "type_parameter_locpointer.inc" +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_parameter_point2this.inc" include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- do L=1,lm - do j=j0-hy,jm+hy - do i=i0-hx,im+hx + 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 @@ -172,10 +294,10 @@ module subroutine stack_to_composite & enddo !---------------------------------------------------------------------- - endsubroutine stack_to_composite +endsubroutine stack_to_composite !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& - module subroutine composite_to_stack & +module subroutine composite_to_stack & !*********************************************************************** ! ! ! Transfer data from composite to stack variables ! @@ -185,18 +307,18 @@ module subroutine composite_to_stack & !---------------------------------------------------------------------- implicit none class(mg_intstate_type),target::this -real(r_kind),dimension(this%km2,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy), intent(in):: A2D -real(r_kind),dimension(this%km3,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy,this%lm),intent(in):: A3D -real(r_kind),dimension(this%km ,this%i0-this%hx:this%im+this%hx,this%j0-this%hy:this%jm+this%hy), intent(out):: ARR_ALL +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_parameter_locpointer.inc" include "type_intstat_locpointer.inc" -include "type_parameter_point2this.inc" +include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !---------------------------------------------------------------------- do L=1,lm - do j=j0-hy,jm+hy - do i=i0-hx,im+hx + 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 @@ -209,8 +331,169 @@ module subroutine composite_to_stack & enddo !---------------------------------------------------------------------- - endsubroutine composite_to_stack +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 +end submodule mg_transfer diff --git a/src/saber/mgbf/mgbf_lib/type_intstat_locpointer.inc b/src/saber/mgbf/mgbf_lib/type_intstat_locpointer.inc index b73455583..52cdb687e 100644 --- a/src/saber/mgbf/mgbf_lib/type_intstat_locpointer.inc +++ b/src/saber/mgbf/mgbf_lib/type_intstat_locpointer.inc @@ -1,79 +1,44 @@ -!clt for treatment of variables from type_mg_intstate.f90 real(r_kind), dimension(:,:,:),pointer:: V -! -! Composite control variable on first generation o filter grid -! real(r_kind), dimension(:,:,:),pointer:: VALL real(r_kind), dimension(:,:,:),pointer:: HALL -! -! Composite control variable on high generations of filter grid -! -! -!FOR ADJOINT TEST -! -!real(r_kind), dimension(:,:),pointer:: A -!real(r_kind), dimension(:,:),pointer:: B -!real(r_kind), dimension(:,:),pointer:: A0 -!real(r_kind), dimension(:,:),pointer:: B0 -! 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 - -!real(r_kind), dimension(:,:,:,:),pointer:: r_vol -! -! -! Composite stacked variable -! - -!clt real(r_kind), dimension(:,:,:),pointer:: WORKA - - 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 + ,cf10,cf11,cf12,cf13 & + ,cf20,cf21,cf22,cf23 & + ,cf30,cf31,cf32,cf33 diff --git a/src/saber/mgbf/mgbf_lib/type_intstat_point2this.inc b/src/saber/mgbf/mgbf_lib/type_intstat_point2this.inc index c6c14fac8..ab8923f05 100644 --- a/src/saber/mgbf/mgbf_lib/type_intstat_point2this.inc +++ b/src/saber/mgbf/mgbf_lib/type_intstat_point2this.inc @@ -1,47 +1,43 @@ -!clt from type_instate_locpoint.inc 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 +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 +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 +vpasp2=>this%vpasp2 +hss2=>this%hss2 +vpasp3=>this%vpasp3 +hss3=>this%hss3 ssx=>this%ssx ssy=>this%ssy - ss1=>this%ss1 +ss1=>this%ss1 ss2=>this%ss2 ss3=>this%ss3 - dixs=>this%dixs - diys=>this%diys - dizs=>this%dizs +dixs=>this%dixs +diys=>this%diys +dizs=>this%dizs - dixs3=>this%dixs3 - diys3=>this%diys3 +dixs3=>this%dixs3 +diys3=>this%diys3 dizs3=>this%dizs3 qcols=>this%qcols -!clt WORKA=>this%WORKA - - iref=>this%iref jref=>this%jref Lref=>this%Lref diff --git a/src/saber/mgbf/mgbf_lib/type_parameter_locpointer.inc b/src/saber/mgbf/mgbf_lib/type_parameter_locpointer.inc index 5039ea8ce..7a8f587dd 100644 --- a/src/saber/mgbf/mgbf_lib/type_parameter_locpointer.inc +++ b/src/saber/mgbf/mgbf_lib/type_parameter_locpointer.inc @@ -1,17 +1,17 @@ -! https://stackoverflow.com/questions/24990491/fortran-namelist-associate-does-not-work 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 +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:: mym +integer(i_kind),pointer:: nym integer(i_kind),pointer:: nm integer(i_kind),pointer:: mm integer(i_kind),pointer:: im00 @@ -39,16 +39,28 @@ 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:: lm ! number of vertical layers -integer(i_kind),pointer:: lm05 ! half of vertical levels -integer(i_kind),pointer:: km2_f ! number of 2d variables for filtering -integer(i_kind),pointer:: km3_f ! number of 3d variables for filtering -integer(i_kind),pointer:: km2_e ! number of 2d variables for ensemble -integer(i_kind),pointer:: km3_e ! number of 3d variables for ensemble -logical,pointer :: l_filt ! logical flag for filtering or enseble -!integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) -integer(i_kind),pointer:: lmf ! number of vertical levels for filtering (generation one) -integer(i_kind),pointer:: lmh ! number of vertical levels for filtering (high generations) +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 @@ -56,37 +68,38 @@ 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 -!clt from mg_entrymod.f90 -integer(i_kind),pointer:: km,km2,km3 -!clt from mg_mppstuff.f90 -integer(i_kind),pointer:: mype + +!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 +logical,pointer:: l_hgen integer(i_kind),pointer:: nx,my -!clt moved from *_mg_domain.f90 + +!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/saber/mgbf/mgbf_lib/type_parameter_point2this.inc b/src/saber/mgbf/mgbf_lib/type_parameter_point2this.inc index 176ebb73f..310f18331 100644 --- a/src/saber/mgbf/mgbf_lib/type_parameter_point2this.inc +++ b/src/saber/mgbf/mgbf_lib/type_parameter_point2this.inc @@ -1,101 +1,47 @@ - -!*** -! apply the solution from -!*** Namelist parameters -!*** 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 - -!*** -!*** Number of generations -!*** -gm=>this%gm - -!*** -!*** Horizontal resolution -!*** - -! -! Original number of data on GSI analysis grid -! -nA_max0=>this%nA_max0 -mA_max0=>this%mA_max0 - -! -! Global number of data on Analysis grid -! -nm0 =>this%nm0 - mm0=>this%mm0 - -! -! Number of PEs on Analysis grid -! -nxm =>this%nxm -mym =>this%mym - -! -! Number of data on local Analysis grid -! -nm =>this%nm -mm =>this%mm - -! -! Number of data on global Filter grid -! -im00=>this%im00 -jm00=>this%jm00 - -! -! Number of data on local Filter grid -! -im=>this%im -jm =>this%jm - -! -! Initial index on local Filter grid -! -i0=>this%i0 -j0=>this%j0 -! -! Initial index on local analysis grid -! -n0=>this%n0 -m0=>this%m0 - -! -! Halo on local Filter grid -! -ib=>this%ib -jb=>this%jb - -! -! Halo on local Analysis grid -! - nb=>this%nb - mb=>this%mb - - -hx=>this%hx -hy=>this%hy -hz=>this%hz -p=>this%p +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 +nfil=>this%nfil +pasp01=>this%pasp01 pasp02=>this%pasp02 pasp03=>this%pasp03 pee2=>this%pee2 @@ -103,40 +49,45 @@ 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 +maxpe_fgen=>this%maxpe_fgen +ixm=>this%ixm jym=>this%jym -nxy=>this%nxy +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 -lm=>this%lm ! number of vertical layers - lm05=>this%lm05 ! half of vertical levels -km2_f=>this%km2_f ! number of 2d variables for filtering -km3_f=>this%km3_f ! number of 3d variables for filtering -km2_e=>this%km2_e ! number of 2d variables for ensemble -km3_e=>this%km3_e ! number of 3d variables for ensemble -l_filt=>this%l_filt ! logical flag for filtering or enseble - lmf =>this%lmf ! number of vertical levels for filtering (generation one) -lmh =>this%lmh ! number of vertical levels for filtering (high generations) - - - +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 @@ -145,86 +96,94 @@ 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 -! -! Just for standalone test -! -!clt from entrymode.f90 -ldelta=>this%ldelta -km=>this%km -km2=>this%km2 -km3=>this%km3 -!clt from mg_mpstuff.f90 -mype=>this%mype -c_mype=>this%c_mype -npes=>this%npes +!from mg_mppstuff.f90 +c_mype=>this%c_mype +mype=>this%mype +npes=>this%npes iTYPE=>this%iTYPE -rTYPE=>this%rTYPE -dTYPE=>this%dTYPE +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 -!clt moved from *_mg_domain.f90 -!logical,dimension(2):: Flwest,Fleast,Flnorth,Flsouth - Flwest=>this%Flwest - Fleast=>this%Fleast - Flnorth=>this%Flnorth - Flsouth=>this%Flsouth -!integer(i_kind),dimension(2):: Fitarg_n,Fitarg_e,Fitarg_s,Fitarg_w - Fitarg_n=>this%Fitarg_n - Fitarg_e=>this%Fitarg_e - Fitarg_s=>this%Fitarg_s - Fitarg_w=>this%Fitarg_w -!integer(i_kind),dimension(2):: Fitarg_sw,Fitarg_se,Fitarg_ne,Fitarg_nw - Fitarg_sw=>this%Fitarg_sw - Fitarg_se=>this%Fitarg_se - Fitarg_ne=>this%Fitarg_ne - Fitarg_nw=>this%Fitarg_nw - -!logical,dimension(2):: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne - 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 - +ierror=>this%ierror +mpi_comm_work=>this%mpi_comm_work +group_world=>this%group_world +group_work=>this%group_work +mype_gr=>this%mype_gr +npes_gr=>this%npes_gr +my_hgen=>this%my_hgen +mype_hgen=>this%mype_hgen +l_hgen=>this%l_hgen +nx=>this%nx +my=>this%my + +!from mg_domain.f90 +Flwest=>this%Flwest +Fleast=>this%Fleast +Flnorth=>this%Flnorth +Flsouth=>this%Flsouth +Fitarg_n=>this%Fitarg_n +Fitarg_e=>this%Fitarg_e +Fitarg_s=>this%Fitarg_s +Fitarg_w=>this%Fitarg_w +Fitarg_sw=>this%Fitarg_sw +Fitarg_se=>this%Fitarg_se +Fitarg_ne=>this%Fitarg_ne +Fitarg_nw=>this%Fitarg_nw +Flsendup_sw=>this%Flsendup_sw +Flsendup_se=>this%Flsendup_se +Flsendup_nw=>this%Flsendup_nw +Flsendup_ne=>this%Flsendup_ne +Fitarg_up=>this%Fitarg_up +itargdn_sw=>this%itargdn_sw +itargdn_se=>this%itargdn_se +itargdn_ne=>this%itargdn_ne +itargdn_nw=>this%itargdn_nw +itarg_wA=>this%itarg_wA +itarg_eA=>this%itarg_eA +itarg_sA=>this%itarg_sA +itarg_nA=>this%itarg_nA +lwestA=>this%lwestA +leastA=>this%leastA +lsouthA=>this%lsouthA +lnorthA=>this%lnorthA +ix=>this%ix +jy=>this%jy +mype_filt=>this%mype_filt + +!from mg_domain_loc.f90 +nsq21=>this%nsq21 +nsq32=>this%nsq32 +nsq43=>this%nsq43 +Flsouth_loc=>this%Flsouth_loc +Flnorth_loc=>this%Flnorth_loc +Flwest_loc=>this%Flwest_loc +Fleast_loc=>this%Fleast_loc +Fitarg_s_loc=>this%Fitarg_s_loc +Fitarg_n_loc=>this%Fitarg_n_loc +Fitarg_w_loc=>this%Fitarg_w_loc +Fitarg_e_loc=>this%Fitarg_e_loc +Fitargup_loc12=>this%Fitargup_loc12 +Fitargup_loc23=>this%Fitargup_loc23 +Fitargup_loc34=>this%Fitargup_loc34 +itargdn_sw_loc21=>this%itargdn_sw_loc21 +itargdn_se_loc21=>this%itargdn_se_loc21 +itargdn_nw_loc21=>this%itargdn_nw_loc21 +itargdn_ne_loc21=>this%itargdn_ne_loc21 +itargdn_sw_loc32=>this%itargdn_sw_loc32 +itargdn_se_loc32=>this%itargdn_se_loc32 +itargdn_nw_loc32=>this%itargdn_nw_loc32 +itargdn_ne_loc32=>this%itargdn_ne_loc32 +itargdn_sw_loc43=>this%itargdn_sw_loc43 +itargdn_se_loc43=>this%itargdn_se_loc43 +itargdn_nw_loc43=>this%itargdn_nw_loc43 +itargdn_ne_loc43=>this%itargdn_ne_loc43 +lsendup_sw_loc=>this%lsendup_sw_loc +lsendup_se_loc=>this%lsendup_se_loc +lsendup_nw_loc=>this%lsendup_nw_loc +lsendup_ne_loc=>this%lsendup_ne_loc diff --git a/src/saber/oops/ErrorCovariance.h b/src/saber/oops/ErrorCovariance.h index 3f6c0758c..18e507f12 100644 --- a/src/saber/oops/ErrorCovariance.h +++ b/src/saber/oops/ErrorCovariance.h @@ -103,7 +103,8 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, const State4D_ & fg) : oops::ModelSpaceCovarianceBase(geom, config, xb, fg) { - oops::Log::trace() << "ErrorCovariance::ErrorCovariance starting" << std::endl; + oops::Log::trace() << "saber::ErrorCovariance::ErrorCovariance starting" << std::endl; + oops::Log::info() << "saber::ErrorCovariance::ErrorCovariance starting 2" << std::endl; ErrorCovarianceParameters params; params.deserialize(config); From fe1b6addfb12808861358bdbbfee396995d322e2 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 13 May 2024 13:07:47 -0500 Subject: [PATCH 004/199] a version with codes to use interpolator from saber::gsi and using the old cmake structure for mgbf --- src/saber/CMakeLists.txt | 5 +-- src/saber/mgbf/CMakeLists.txt | 21 +++++++----- .../mgbf/covariance/{Grid.cc => mgbf_Grid.cc} | 2 +- .../mgbf/covariance/{Grid.h => mgbf_Grid.h} | 34 ++++++++++++++++++- .../mgbf/covariance/mgbf_Interpolation.cc | 28 +++++++-------- .../mgbf/covariance/mgbf_Interpolation.h | 21 +++++++----- 6 files changed, 74 insertions(+), 37 deletions(-) rename src/saber/mgbf/covariance/{Grid.cc => mgbf_Grid.cc} (96%) rename src/saber/mgbf/covariance/{Grid.h => mgbf_Grid.h} (59%) diff --git a/src/saber/CMakeLists.txt b/src/saber/CMakeLists.txt index 160839889..fb22cbe7f 100644 --- a/src/saber/CMakeLists.txt +++ b/src/saber/CMakeLists.txt @@ -4,7 +4,7 @@ # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # Build list of subdirs with files to add -set( _subdirs blocks bump fastlam generic gsi interpolation oops spectralb util vader ) +set( _subdirs blocks bump fastlam generic gsi interpolation oops spectralb util vader mgbf) #clt set( _subdirs blocks bump fastlam generic interpolation oops spectralb util vader mgbf) foreach( _subdir IN LISTS _subdirs ) add_subdirectory( ${_subdir} ) @@ -23,9 +23,6 @@ if( OpenMP_FOUND ) target_link_libraries( ${PROJECT_NAME} PUBLIC OpenMP::OpenMP_Fortran OpenMP::OpenMP_CXX ) endif() -add_subdirectory(mgbf) -target_link_libraries(${PROJECT_NAME} PUBLIC mgbf_interface) - target_link_libraries( ${PROJECT_NAME} PUBLIC NetCDF::NetCDF_Fortran NetCDF::NetCDF_C ) target_link_libraries( ${PROJECT_NAME} PUBLIC MPI::MPI_Fortran ) target_link_libraries( ${PROJECT_NAME} PUBLIC ${LAPACK_LIBRARIES} ) diff --git a/src/saber/mgbf/CMakeLists.txt b/src/saber/mgbf/CMakeLists.txt index 970e60916..4307eec96 100644 --- a/src/saber/mgbf/CMakeLists.txt +++ b/src/saber/mgbf/CMakeLists.txt @@ -3,10 +3,16 @@ # # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. - - -add_subdirectory(mgbf_lib) # Include the mgbf_lib directory - +file(GLOB jbfiles mgbf_lib/*.f90) + message(STATUS "thinkdeb-2 " ${jbfiles} ) +set (jbfilenames "") +foreach ( _fname ${jbfiles} ) + get_filename_component( basefilename ${_fname} NAME ) + list ( APPEND jbfilenames mgbf_lib/${basefilename} ) + message(STATUS "thinkdeb-1 " ${basefilename}) + message(STATUS "thinkdeb0 " ${jbfilenames}) +endforeach () +message(STATUS "thinkdeb " ${jbfilenames}) #set (jbfilenames "mgbf_lib/jp_pbfil.f90" ) set (build_saber_mgbf 1) if( build_saber_mgbf ) @@ -47,11 +53,8 @@ message (STATUS "thinkdeb1 " ${mgbf_src_files_list} ) set( mgbf_src_files ${mgbf_src_files_list} +${jbfilenames} +PARENT_SCOPE ) message (STATUS "thinkdeb2.4" ${mgbf_src_files} ) -add_library(mgbf_interface STATIC ${mgbf_src_files} ) -target_link_libraries(mgbf_interface PRIVATE mgbf_lib) -target_include_directories(mgbf_interface - PRIVATE ${CMAKE_CURRENT_BINARY_DIR}/mgbf_lib/modules) -#target_include_directories(mgbf_interface public ../blocks) diff --git a/src/saber/mgbf/covariance/Grid.cc b/src/saber/mgbf/covariance/mgbf_Grid.cc similarity index 96% rename from src/saber/mgbf/covariance/Grid.cc rename to src/saber/mgbf/covariance/mgbf_Grid.cc index e2d213880..e3afa7762 100644 --- a/src/saber/mgbf/covariance/Grid.cc +++ b/src/saber/mgbf/covariance/mgbf_Grid.cc @@ -50,7 +50,7 @@ Grid::Grid(const eckit::mpi::Comm & comm, const eckit::Configuration & conf) eckit::LocalConfiguration serialPartConf{}; serialPartConf.set("partition", 0); const atlas::grid::Partitioner part("serial", serialPartConf); - targetFunctionSpace_.reset(new atlas::functionspace::StructuredColumns(grid, part)); + targetFunctionSpace_.reset(new atlas::functionspace::PointCloud(grid, part)); //clt mgbfGridFuncSpace_ = atlas::functionspace::PointCloud(lonlat); diff --git a/src/saber/mgbf/covariance/Grid.h b/src/saber/mgbf/covariance/mgbf_Grid.h similarity index 59% rename from src/saber/mgbf/covariance/Grid.h rename to src/saber/mgbf/covariance/mgbf_Grid.h index b497a1062..f2a333b3a 100644 --- a/src/saber/mgbf/covariance/Grid.h +++ b/src/saber/mgbf/covariance/mgbf_Grid.h @@ -55,7 +55,39 @@ class Grid { int mgbfLevels_; }; +Grid::Grid(const eckit::mpi::Comm & comm, const eckit::Configuration & conf) +{ + oops::Log::trace() << classname() << "::Grid starting" << std::endl; + util::Timer timer(classname(), "Grid"); +// set up grid and functionspace based on description in the yaml + const atlas::StructuredGrid grid(conf); +//clt how about PointCloud functionspace + const atlas::functionspace::StructuredColumns mgbfGridFuncSpace_(grid); + + + //clt mgbfGridFuncSpace_ = atlas::functionspace::PointCloud(lonlat); + + oops::Log::trace() << classname() << "::Grid done" << std::endl; +// +} + +// ------------------------------------------------------------------------------------------------- + +Grid::~Grid() { + oops::Log::trace() << classname() << "::~Grid starting" << std::endl; + util::Timer timer(classname(), "~Grid"); +} + +// ------------------------------------------------------------------------------------------------- + +void Grid::print(std::ostream & os) const { + oops::Log::trace() << classname() << "::print starting" << std::endl; + util::Timer timer(classname(), "print"); + oops::Log::trace() << classname() << "::print done" << std::endl; +} + // ------------------------------------------------------------------------------------------------- +// -} // namespace gsi +} // namespace mgbf } // namespace saber diff --git a/src/saber/mgbf/covariance/mgbf_Interpolation.cc b/src/saber/mgbf/covariance/mgbf_Interpolation.cc index ea6a260b5..fd8ca0c58 100644 --- a/src/saber/mgbf/covariance/mgbf_Interpolation.cc +++ b/src/saber/mgbf/covariance/mgbf_Interpolation.cc @@ -6,7 +6,7 @@ * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. */ -#include "saber/mgbf/interpolation/Interpolation.h" +#include "saber/mgbf/covariance/mgbf_Interpolation.h" #include #include @@ -19,7 +19,7 @@ #include "oops/base/Variables.h" #include "saber/blocks/SaberOuterBlockBase.h" -//cltorg #include "saber/gsi/grid/Grid.h" +#include "saber/mgbf/covaraince/Grid.h" #include "saber/oops/Utilities.h" @@ -33,26 +33,21 @@ static SaberOuterBlockMaker makerInterpolation_("mgbf interpolati // ------------------------------------------------------------------------------------------------- //clt mgbfInterpolation::mgbfInterpolation(const oops::GeometryData & outerGeometryData, -mgbfInterpolation::mgbfInterpolation(const oops::GeometryData & sourceGeometryData, - const oops::Geometry & targetGeometry; +mgbf_Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, const oops::Variables & outerVars, const eckit::Configuration & covarConf, const Parameters_ & params, const oops::FieldSet3D & xb, const oops::FieldSet3D & fg) : SaberOuterBlockBase(params, xb.validTime()), innerVars_(outerVars) + { - oops::Log::trace() << classname() << "::Interpolation starting" << std::endl; + oops::Log::trace() << classname() << "::mgbf_Interpolation constructor starting" << std::endl; util::Timer timer(classname(), "MGBF Interpolation"); // Grid // Grid Grid grid(outerGeometryData.comm(), params.toConfiguration()); - auto targetfunctionspace = targetGeometry.generic() - interpolator_.reset(new oops::GlobalInterpolator(conf, - targetfunctionspace, - targetGeometry.getComm())); - // Inner geometry and variables innerGeometryData_.reset(new oops::GeometryData(grid.functionSpace(), @@ -66,13 +61,18 @@ mgbfInterpolation::mgbfInterpolation(const oops::GeometryData & sourceGeometryDa for (const std::string & var : activeVars.variables()) { activeVariableSizes.push_back(activeVars.getLevels(var)); } - - oops::Log::trace() << classname() << "::Interpolation done" << std::endl; + interpolator_.reset(new UnstructuredInterpolation(outerGeometryData.comm(), + params.toConfiguration(), + innerGeometryData_->functionSpace(), + outerGeometryData.functionSpace(), + activeVariableSizes, + activeVars)); + oops::Log::trace() << classname() << "mgbf::Interpolator constructor done" << std::endl; } // ------------------------------------------------------------------------------------------------- -Interpolation::~Interpolation() { +mgbf_Interpolation::~mgbf_Interpolation() { oops::Log::trace() << classname() << "::~Interpolation starting" << std::endl; util::Timer timer(classname(), "~Interpolation"); oops::Log::trace() << classname() << "::~Interpolation done" << std::endl; @@ -113,5 +113,5 @@ void Interpolation::print(std::ostream & os) const { // ------------------------------------------------------------------------------------------------- -} // namespace gsi +} // namespace mgbf } // namespace saber diff --git a/src/saber/mgbf/covariance/mgbf_Interpolation.h b/src/saber/mgbf/covariance/mgbf_Interpolation.h index 42efa8c83..f95e94413 100644 --- a/src/saber/mgbf/covariance/mgbf_Interpolation.h +++ b/src/saber/mgbf/covariance/mgbf_Interpolation.h @@ -28,6 +28,8 @@ #include "saber/blocks/SaberBlockParametersBase.h" #include "saber/blocks/SaberOuterBlockBase.h" #include "oops/base/GeometryData.h" +#include "saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.h" + namespace saber { namespace mgbf { @@ -40,7 +42,6 @@ class mgbf_InterpolationParameters : public SaberBlockParametersBase { // File containing grid and coefficients oops::RequiredParameter mgbfFile{"mgbf error covariance file", this}; oops::RequiredParameter mgbfNML{"mgbf berror namelist file", this}; - oops::RequiredParameter mgbfGRD{"gsi akbk", this}; // Handle vertical top-2-bottom and vice-verse wrt to GSI oops::Parameter vflip{"flip vertical grid", true, this}; @@ -49,7 +50,6 @@ class mgbf_InterpolationParameters : public SaberBlockParametersBase { // Debugging mode oops::Parameter debugMode{"debugging mode", false, this}; - oops::Parameter bypassGSI{"debugging bypass gsi", false, this}; // Mandatory active variables oops::Variables mandatoryActiveVars() const override {return oops::Variables();} @@ -58,20 +58,24 @@ class mgbf_InterpolationParameters : public SaberBlockParametersBase { // ------------------------------------------------------------------------------------------------- template -class mgbfInterpolation : public SaberOuterBlockBase { +class mgbf_Interpolation : public SaberOuterBlockBase { public: static const std::string classname() {return "saber::mgbf::Interpolation";} typedef mgbfInterpolationParameters Parameters_; typedef T_Interpolator Interpolator_; - mgbfInterpolation( const oops::Geometry & targetGeometry; + mgbf_Interpolation(const oops::GeometryData &, const oops::Variables &, const eckit::Configuration &, const Parameters_ &, const oops::FieldSet3D &, const oops::FieldSet3D &); - virtual ~Interpolation(); + + + + + virtual ~mgbf_Interpolation(); // source stuff are corresponding to stuff with the innner block // target stuff are corresponding to stuff with the outer block const oops::GeometryData & innerGeometryData() const override {return *innerGeometryData_;} @@ -86,15 +90,16 @@ class mgbfInterpolation : public SaberOuterBlockBase { void print(std::ostream &) const override; std::unique_ptr innerGeometryData_; oops::Variables innerVars_; - const oops::functionspace targetFunctionspace_ , // Interpolation object - std::unique_ptr interpolator_; + // clt follow examples in gsi::interpolation + std::unique_ptr interpolator_; // Inverse interpolation object (need adjoint) + std::unique_ptr inverseInterpolator_; }; // ------------------------------------------------------------------------------------------------- -} // namespace gsi +} // namespace mgbf } // namespace saber From b69bb5c72fa59d3c88f29053b2a85cb35e2df33b Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 25 May 2024 07:49:13 -0500 Subject: [PATCH 005/199] mgbf version being debugged --- src/saber/mgbf/covariance/mgbf_Grid.cc | 8 ++-- src/saber/mgbf/covariance/mgbf_Grid.h | 40 ++++++++++--------- .../mgbf/covariance/mgbf_Interpolation.cc | 27 +++++++------ .../mgbf/covariance/mgbf_Interpolation.h | 25 +++++++----- 4 files changed, 55 insertions(+), 45 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_Grid.cc b/src/saber/mgbf/covariance/mgbf_Grid.cc index 9bac6723c..b06f86cb3 100644 --- a/src/saber/mgbf/covariance/mgbf_Grid.cc +++ b/src/saber/mgbf/covariance/mgbf_Grid.cc @@ -10,11 +10,11 @@ #include #include -#include "atlas/field.h" -#include "atlas/functionspace.h" +//#include "atlas/field.h" +//#include "atlas/functionspace.h" -#include "oops/util/Logger.h" -#include "oops/util/Timer.h" +//#include "oops/util/Logger.h" +//#include "oops/util/Timer.h" namespace saber { diff --git a/src/saber/mgbf/covariance/mgbf_Grid.h b/src/saber/mgbf/covariance/mgbf_Grid.h index f2a333b3a..c7c3b0e13 100644 --- a/src/saber/mgbf/covariance/mgbf_Grid.h +++ b/src/saber/mgbf/covariance/mgbf_Grid.h @@ -18,51 +18,53 @@ #include "oops/util/parameters/Parameters.h" #include "oops/util/parameters/RequiredParameter.h" -#include "saber/gsi/grid/Grid.interface.h" //cltorg modified from gsi/Grid.h namespace saber { -namespace gsi { +namespace mgbf { // ------------------------------------------------------------------------------------------------- -class GridParameters : public oops::Parameters { - OOPS_CONCRETE_PARAMETERS(GridParameters, Parameters) +class mgbfGridParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(mgbfGridParameters, Parameters) }; // ------------------------------------------------------------------------------------------------- -class Grid { +class mgbfGrid { public: - static const std::string classname() {return "saber::gsi::Grid";} + static const std::string classname() {return "saber::mgbf::mgbfGrid";} // Constructor & destructor - Grid(const eckit::mpi::Comm &, const eckit::Configuration &); - ~Grid(); + mgbfGrid(const eckit::mpi::Comm &, const eckit::Configuration &); + ~mgbfGrid(); // Accessor functions - int levels() {return gsiLevels_;} - const atlas::FunctionSpace & functionSpace() const {return mgbfGridFuncSpace_;} - atlas::FunctionSpace & functionSpace() {return mgbfGridFuncSpace_;} +//clt int levels() {return gsiLevels_;} + const atlas::FunctionSpace & functionSpace() const {return mgbfFuncSpace_;} + atlas::FunctionSpace & functionSpace() {return mgbfFuncSpace_;} private: void print(std::ostream &) const; // Fortran LinkedList key - GridKey keySelf_; +//clt GridKey keySelf_; // Function spaces - atlas::FunctionSpace mgbfGridFuncSpace_; + atlas::FunctionSpace mgbfFuncSpace_; // Number of levels int mgbfLevels_; }; -Grid::Grid(const eckit::mpi::Comm & comm, const eckit::Configuration & conf) +mgbfGrid::mgbfGrid(const eckit::mpi::Comm & comm, const eckit::Configuration & conf) { - oops::Log::trace() << classname() << "::Grid starting" << std::endl; - util::Timer timer(classname(), "Grid"); + oops::Log::tracexx() << classname() << "::Grid starting" << std::endl; + oops::Log::trace()<<"mgbf config is "< makerInterpolation_("mgbf interpolation to model grid and it adjoint"); +//clt template +static SaberOuterBlockMaker makerInterpolation_("mgbf interpolation to model grid"); // ------------------------------------------------------------------------------------------------- //clt mgbfInterpolation::mgbfInterpolation(const oops::GeometryData & outerGeometryData, -mgbf_Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, +mgbf_Interpolation::mgbf_Interpolation(const oops::GeometryData & outerGeometryData, const oops::Variables & outerVars, const eckit::Configuration & covarConf, const Parameters_ & params, @@ -46,10 +47,11 @@ mgbf_Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, util::Timer timer(classname(), "MGBF Interpolation"); // Grid - // Grid - Grid grid(outerGeometryData.comm(), params.toConfiguration()); + oops::Log::trace()<<"in mgbf interp params "<functionSpace(), outerGeometryData.functionSpace(), @@ -73,14 +76,14 @@ mgbf_Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, // ------------------------------------------------------------------------------------------------- mgbf_Interpolation::~mgbf_Interpolation() { - oops::Log::trace() << classname() << "::~Interpolation starting" << std::endl; - util::Timer timer(classname(), "~Interpolation"); - oops::Log::trace() << classname() << "::~Interpolation done" << std::endl; + oops::Log::trace() << classname() << "::~mgbfInterpolation starting" << std::endl; + util::Timer timer(classname(), "~mgbfInterpolation"); + oops::Log::trace() << classname() << "::~mgbfInterpolation done" << std::endl; } // ------------------------------------------------------------------------------------------------- -void Interpolation::multiply(oops::FieldSet3D & fset) const { +void mgbf_Interpolation::multiply(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiply starting" << std::endl; util::Timer timer(classname(), "multiply"); interpolator_->apply(fset.fieldSet()); @@ -89,7 +92,7 @@ void Interpolation::multiply(oops::FieldSet3D & fset) const { // ------------------------------------------------------------------------------------------------- -void Interpolation::multiplyAD(oops::FieldSet3D & fset) const { +void mgbf_Interpolation::multiplyAD(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; util::Timer timer(classname(), "multiplyAD"); interpolator_->applyAD(fset.fieldSet()); @@ -107,7 +110,7 @@ void Interpolation::multiplyAD(oops::FieldSet3D & fset) const { // ------------------------------------------------------------------------------------------------- -void Interpolation::print(std::ostream & os) const { +void mgbf_Interpolation::print(std::ostream & os) const { os << classname(); } diff --git a/src/saber/mgbf/covariance/mgbf_Interpolation.h b/src/saber/mgbf/covariance/mgbf_Interpolation.h index f95e94413..a8ff170b0 100644 --- a/src/saber/mgbf/covariance/mgbf_Interpolation.h +++ b/src/saber/mgbf/covariance/mgbf_Interpolation.h @@ -7,6 +7,7 @@ */ #pragma once +#include "saber/mgbf/covariance/mgbf_Interpolation.h" #include #include @@ -36,12 +37,13 @@ namespace mgbf { // ------------------------------------------------------------------------------------------------- class mgbf_InterpolationParameters : public SaberBlockParametersBase { - OOPS_CONCRETE_PARAMETERS(InterpolationParameters, SaberBlockParametersBase) + OOPS_CONCRETE_PARAMETERS(mgbf_InterpolationParameters, SaberBlockParametersBase) public: // File containing grid and coefficients - oops::RequiredParameter mgbfFile{"mgbf error covariance file", this}; - oops::RequiredParameter mgbfNML{"mgbf berror namelist file", this}; +// lf oops::RequiredParameter mgbfFile{"mgbf error covariance file", this}; +// oops::RequiredParameter mgbfNML{"mgbf namelist file", this}; + oops::RequiredParameter mgbfgrid{"mgbf grid", this}; // Handle vertical top-2-bottom and vice-verse wrt to GSI oops::Parameter vflip{"flip vertical grid", true, this}; @@ -57,13 +59,13 @@ class mgbf_InterpolationParameters : public SaberBlockParametersBase { // ------------------------------------------------------------------------------------------------- -template +//clt template class mgbf_Interpolation : public SaberOuterBlockBase { public: static const std::string classname() {return "saber::mgbf::Interpolation";} - typedef mgbfInterpolationParameters Parameters_; - typedef T_Interpolator Interpolator_; + typedef mgbf_InterpolationParameters Parameters_; +//clt typedef T Interpolator_; mgbf_Interpolation(const oops::GeometryData &, const oops::Variables &, @@ -80,11 +82,14 @@ class mgbf_Interpolation : public SaberOuterBlockBase { // target stuff are corresponding to stuff with the outer block const oops::GeometryData & innerGeometryData() const override {return *innerGeometryData_;} const oops::Variables & innerVars() const override {return innerVars_;} - const atlas::functionspace outerFunctionspace , + const atlas::FunctionSpace outerFunctionspace ; void multiply(oops::FieldSet3D &) const override; void multiplyAD(oops::FieldSet3D &) const override; - void leftInverseMultiply(oops::FieldSet3D &) const override; + void leftInverseMultiply(oops::FieldSet3D &) const override + { +//clt to timplement + } private: void print(std::ostream &) const override; @@ -93,10 +98,10 @@ class mgbf_Interpolation : public SaberOuterBlockBase { // Interpolation object // clt follow examples in gsi::interpolation - std::unique_ptr interpolator_; + std::unique_ptr interpolator_; // Inverse interpolation object (need adjoint) - std::unique_ptr inverseInterpolator_; + std::unique_ptr inverseInterpolator_; }; // ------------------------------------------------------------------------------------------------- From 4c087bb3f7457f5eeaab05fa688dd18587ee5667 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 4 Jun 2024 07:05:08 -0500 Subject: [PATCH 006/199] a working mgbf version verified by Dirac test with fv3 --- src/saber/blocks/SaberCentralBlockBase.h | 8 +++ src/saber/blocks/SaberOuterBlockBase.cc | 3 ++ src/saber/blocks/SaberParametricBlockChain.cc | 1 + src/saber/blocks/SaberParametricBlockChain.h | 5 ++ .../UnstructuredInterpolation.cc | 12 +++++ .../UnstructuredInterpolation.interface.F90 | 8 +++ src/saber/mgbf/CMakeLists.txt | 10 ++-- src/saber/mgbf/covariance/MGBF_Covariance.h | 6 +-- src/saber/mgbf/covariance/mgbf_Grid.h | 11 +++- .../mgbf/covariance/mgbf_covariance_mod.f90 | 50 +++++++++++++------ src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 3 ++ src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 | 8 +++ src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 25 ++++++---- src/saber/oops/ErrorCovarianceToolbox.h | 4 ++ 14 files changed, 116 insertions(+), 38 deletions(-) diff --git a/src/saber/blocks/SaberCentralBlockBase.h b/src/saber/blocks/SaberCentralBlockBase.h index d0cae7432..55bf43e9c 100644 --- a/src/saber/blocks/SaberCentralBlockBase.h +++ b/src/saber/blocks/SaberCentralBlockBase.h @@ -30,6 +30,7 @@ #include "oops/util/Printable.h" #include "saber/blocks/SaberBlockParametersBase.h" + #include // Forward declaration namespace oops { @@ -224,8 +225,15 @@ void SaberCentralBlockBase::read(const oops::Geometry & geom, // Read fieldsets as increments std::vector fsetVec; + oops::Log::trace() << "SaberCentralBlockBase::read starting 2" << std::endl; +//clt oops::Log::trace() << "SaberCentralBlockBase::read typeid getReadConfs2 " <getReadConfs()).name() <getReadConfs() <getReadConfs()) { // Create increment + oops::Log::trace()<<"thinkdeb inputcofig "< dx(geom, vars, validTime_); dx.read(input.second); oops::Log::test() << "Norm of input parameter " << input.first diff --git a/src/saber/blocks/SaberOuterBlockBase.cc b/src/saber/blocks/SaberOuterBlockBase.cc index 0966a91f7..1cab74aad 100644 --- a/src/saber/blocks/SaberOuterBlockBase.cc +++ b/src/saber/blocks/SaberOuterBlockBase.cc @@ -60,6 +60,9 @@ std::unique_ptr SaberOuterBlockFactory::create( oops::Log::error() << id << " does not exist in saber::SaberOuterBlockFactory." << std::endl; throw eckit::UserError("Element does not exist in saber::SaberOuterBlockFactory.", Here()); } + oops::Log::trace()<<"thinkin outer black create ,covarConfig "< ptr = jsb->second->make(outerGeometryData, outerVars, covarConfig, params, xb, fg); oops::Log::trace() << "SaberOuterBlockBase::create done" << std::endl; diff --git a/src/saber/blocks/SaberParametricBlockChain.cc b/src/saber/blocks/SaberParametricBlockChain.cc index 2a8811f6a..05cd06b68 100644 --- a/src/saber/blocks/SaberParametricBlockChain.cc +++ b/src/saber/blocks/SaberParametricBlockChain.cc @@ -65,6 +65,7 @@ SaberParametricBlockChain::SaberParametricBlockChain( saberCentralBlockParams, fset4dXb, fset4dFg); + oops::Log::trace() << "thinkdeb in SaberParametricBlockChain.cc Creating central block done "<getReadConfs().size() != 0) { diff --git a/src/saber/blocks/SaberParametricBlockChain.h b/src/saber/blocks/SaberParametricBlockChain.h index 9a100118e..8d8d43fcf 100644 --- a/src/saber/blocks/SaberParametricBlockChain.h +++ b/src/saber/blocks/SaberParametricBlockChain.h @@ -135,6 +135,7 @@ SaberParametricBlockChain::SaberParametricBlockChain(const oops::Geometry cmpOuterBlocksParams); } + oops::Log::trace() << "SaberParametricBlockChain ctor starting outerblockchain finished" << std::endl; // Set outer geometry data for central block const oops::GeometryData & currentOuterGeom = outerBlockChain_ ? outerBlockChain_->innerGeometryData() : geom.generic(); @@ -154,9 +155,13 @@ SaberParametricBlockChain::SaberParametricBlockChain(const oops::Geometry saberCentralBlockParams, fset4dXb, fset4dFg); + oops::Log::trace() << "in SaberParametricBlockChain.h after initCenteraBlock "<read "<read(geom, currentOuterVars); + oops::Log::trace() << "in SaberParametricBlockChain.h after centralBlock_->read "< namespace saber { namespace gsi { @@ -33,8 +34,19 @@ UnstructuredInterpolation::UnstructuredInterpolation( : innerFuncSpace_(innerFuncSpace), outerFuncSpace_(outerFuncSpace), activeVariableSizes_(activeVariableSizes), activeVars_(activeVars) { + oops::Log::trace()<<"thinkdeb in gsi::UnstracutredInterpolation CTOR begin"<> getReadConfs() const override{}; - void setReadFields(const std::vector &) override{}; +//clttodo std::vector> getReadConfs() const override{}; +//clttodo void setReadFields(const std::vector &) override{}; - void read() override {}; +//clttodo void read() override {}; void directCalibration(const oops::FieldSets &) override {}; diff --git a/src/saber/mgbf/covariance/mgbf_Grid.h b/src/saber/mgbf/covariance/mgbf_Grid.h index c7c3b0e13..58ddab869 100644 --- a/src/saber/mgbf/covariance/mgbf_Grid.h +++ b/src/saber/mgbf/covariance/mgbf_Grid.h @@ -13,10 +13,12 @@ #include "atlas/field.h" #include "atlas/functionspace.h" +#include "atlas/grid.h" #include "oops/util/parameters/Parameter.h" #include "oops/util/parameters/Parameters.h" #include "oops/util/parameters/RequiredParameter.h" +#include //clt //cltorg modified from gsi/Grid.h @@ -56,14 +58,19 @@ class mgbfGrid { mgbfGrid::mgbfGrid(const eckit::mpi::Comm & comm, const eckit::Configuration & conf) { - oops::Log::tracexx() << classname() << "::Grid starting" << std::endl; + oops::Log::trace() << classname() << "::Grid starting" << std::endl; oops::Log::trace()<<"mgbf config is "< work_mgbf + dim2d=shape(work2d_mgbf) + work2d_mgbf=reshape(work_mgbf,[dim2d(1),dim2d(2)]) ilev=1 + write(6,*)'thinkdeb fields name and size ',fields%size(),'' ,fields%name() do isize=1,fields%size() afield=fields%field(isize) !clttodo if(afield%rank() == 2) then call afield%data(ptr_2d) - ptr_2d=work_mgbf(ilev,:,:) - ilev=ilev+1 + nz=afield%levels() + write(6,*)'think nz of afield is ',nz + ptr_2d(1:nz,:)=work2d_mgbf(ilev:ilev+nz-1,:) + ilev=ilev+nz elseif (afield%rank() == 3) then call afield%data(ptr_3d) nz=afield%levels() - ptr_3d=work_mgbf(ilev:ilev+nz-1,:,:) + write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo + stop + + +!clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) ilev=ilev+nz else write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo @@ -242,6 +259,7 @@ subroutine multiply(self, fields) deallocate(work_mgbf) + deallocate(work2d_mgbf) end subroutine multiply diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 6eb721f68..cbe9b9c56 100644 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1018,12 +1018,15 @@ subroutine allocate_mg_intstate(this) implicit none class(mg_intstate_type),target::this +write(6,*)"thinkdeb in allocate_mg_intstate ",this%l_loc 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 +write(6,*)"thinkdeb in allocate_mg_intstate hx,km3 ",this%km_all,this%hx,this%im,this%hy,this%jm,this%lm +call flush(6) 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. diff --git a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 index c2bdaf72f..5236571ff 100644 --- a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 @@ -59,12 +59,16 @@ module subroutine init_mg_MPI(this) !*** call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr) call MPI_COMM_SIZE(MPI_COMM_WORLD,npes,ierr) + write(6,*)'thinkdeb in mg_mppstuff npes,mype is ',npes,mype + call flush(6) ! 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) + write(6,*)'thinkdeb in mg_mppstuff new npes, world is ',npes,' ',mpi_comm_comp + call flush(6) rTYPE = MPI_REAL dTYPE = MPI_DOUBLE @@ -103,6 +107,8 @@ module subroutine init_mg_MPI(this) !----------------------------------------------------------------------- ! call MPI_BARRIER(mpi_comm_comp,ierr) + write(6,*)'thinkdeb in mg_mppstuff 2 ' + call flush(6) ! !----------------------------------------------------------------------- !*** @@ -112,6 +118,8 @@ module subroutine init_mg_MPI(this) ! Associate a group with communicator this@mpi_comm_comp ! call MPI_COMM_GROUP(mpi_comm_comp,group_world,ierr) + write(6,*)'thinkdeb in mg_mppstuff 3, npes_filt ',npes_filt + call flush(6) ! ! Create a new group out of exising group ! diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index bc887a411..a7d6ef3fa 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -53,7 +53,7 @@ module mg_parameter !*** Number of generations !*** integer(i_kind):: gm -integer(i_kind):: gm_max +integer(i_kind):: gm_max !clt should be removed? !*** !*** Horizontal resolution @@ -145,11 +145,11 @@ module mg_parameter 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_loc=.false. ! logical flag for localization +logical :: l_filt_g1=.true. ! logical flag for filtering of generation one +logical :: l_lin_vertical=.true. ! logical flag for linear interpolation in vertcial +logical :: l_lin_horizontal=.true. ! logical flag for linear interpolation in horizontal +logical :: l_quad_horizontal=.false. ! 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) @@ -488,15 +488,15 @@ subroutine init_mg_parameter(this,inputfilename) 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):: n_ens=1 ! 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 +logical :: l_new_map=.false. ! logical flag for new mapping between analysis and filter grid +logical :: l_vertical_filter=.false. ! logical flag for vertical filtering +integer(i_kind):: gm_max=4 !clt by defaul ! Global number of data on Analysis grid integer(i_kind):: nm0 @@ -639,10 +639,13 @@ subroutine init_mg_parameter(this,inputfilename) ! this%km_a = this%km2+this%lm_a*this%km3 + write(6,*)'thinkdeb mg_parameter.f90 km2,lm,km3 ',this%km2,' ',this%lm ,' ',this%km3 this%km = this%km2+this%lm *this%km3 + write(6,*)'thinkdeb mg_parameter.f90 km ',this%km,' ',this%km_a this%km_a_all = this%km_a * this%n_ens this%km_all = this%km * this%n_ens + write(6,*)'thinkdeb mg_parameter.f90 km_all ',this%km_all,' ',this%n_ens this%km2_all = this%km2 * this%n_ens this%km3_all = this%km3 * this%n_ens @@ -680,7 +683,7 @@ subroutine init_mg_parameter(this,inputfilename) ! ! Number of grid points on the analysis grid after padding ! - + write(6,*)'thinkdeb mg_parameter nm0,nxm',this%nm0,this%nxm this%nm = this%nm0/this%nxm this%mm = this%mm0/this%nym diff --git a/src/saber/oops/ErrorCovarianceToolbox.h b/src/saber/oops/ErrorCovarianceToolbox.h index 9b816d1ce..a9715f5c8 100644 --- a/src/saber/oops/ErrorCovarianceToolbox.h +++ b/src/saber/oops/ErrorCovarianceToolbox.h @@ -291,13 +291,17 @@ template class ErrorCovarianceToolbox : public oops::Applicatio const State4D_ & xx, const Increment4D_ & dxi) const { // Define output increment + // tothinkdo + oops::Log::trace() << "dirac starting" << std::endl; Increment4D_ dxo(dxi, false); // Covariance + oops::Log::trace() << "dirac Bmat being created" << std::endl; std::unique_ptr Bmat(CovarianceFactory_::create( geom, vars, covarConf, xx, xx)); // Multiply + oops::Log::trace() << "dirac Bmat 's multiply to be invoked" << std::endl; Bmat->multiply(dxi, dxo); // Update ID From e7bf8bf523bb6584893658ee72f349e31750c5dd Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 14 Jun 2024 07:52:53 -0500 Subject: [PATCH 007/199] mgbf being debugged --- .../UnstructuredInterpolation.cc | 9 +- .../UnstructuredInterpolation.interface.F90 | 8 -- src/saber/mgbf/covariance/mgbf_Grid.h | 9 +- .../mgbf/covariance/mgbf_covariance_mod.f90 | 95 +++++++++++++++++-- src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 1 + src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 4 +- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 35 ++++--- 7 files changed, 124 insertions(+), 37 deletions(-) diff --git a/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.cc b/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.cc index 688c7f69c..519346657 100644 --- a/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.cc +++ b/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.cc @@ -19,6 +19,8 @@ #include "saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.h" #include "saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.interface.h" #include +#include "mpi.h" +#include namespace saber { namespace gsi { @@ -36,10 +38,13 @@ UnstructuredInterpolation::UnstructuredInterpolation( { oops::Log::trace()<<"thinkdeb in gsi::UnstracutredInterpolation CTOR begin"< //clt +#include "mpi.h" +#include //cltorg modified from gsi/Grid.h @@ -62,14 +64,17 @@ mgbfGrid::mgbfGrid(const eckit::mpi::Comm & comm, const eckit::Configuration & c oops::Log::trace()<<"mgbf config is "< work_mgbf - dim2d=shape(work2d_mgbf) + if(1.gt.2) then + if(myrank == 0) then + write(6,*)'thindkeb250 nxloc,nyloc/nzloc ',nxloc,nyloc,nzloc + do k=1,nzloc + do j=1,nyloc + do i=1,nxloc + work_mgbf(k,i,j)=j + enddo + enddo + enddo + + else if(myrank == 1) then + write(6,*)'thindkeb250 nxloc,nyloc/nzloc ',nxloc,nyloc,nzloc + do k=1,nzloc + do j=1,nyloc + do i=1,nxloc + work_mgbf(k,i,j)=j + enddo + enddo + enddo + else if(myrank == 2) then + write(6,*)'thindkeb250 nxloc,nyloc/nzloc ',nxloc,nyloc,nzloc + do k=1,nzloc + do j=1,nyloc + do i=1,nxloc + work_mgbf(k,i,j)=nyloc+j + enddo + enddo + enddo + else if(myrank == 3) then + write(6,*)'thindkeb250 nxloc,nyloc/nzloc ',nxloc,nyloc,nzloc + do k=1,nzloc + do j=1,nyloc + do i=1,nxloc + work_mgbf(k,i,j)=j+nyloc + enddo + enddo + enddo + else + write(6,*)'something is wrong here 255, stop' + stop + endif + endif !1>2 + do k=1,nzloc + do j=1,nyloc + do i=1,nxloc + if(work_mgbf(k,i,j).ne.0.0) then + write(6,*)'thinkdeb end non-zeror work_mgbf ',k,' ',i,' ',j,' ',work_mgbf(k,i,j) + endif + enddo + enddo + enddo + work2d_mgbf=reshape(work_mgbf,[dim2d(1),dim2d(2)]) + do k=1,nzloc + do ij=1,nxloc*nyloc + if(work2d_mgbf(k,ij).ne.0.0) then + write(6,*)'thinkdeb end non-zeror work2d_mgbf ',k,' ',ij,' ',work2d_mgbf(k,ij) + endif + enddo + enddo ilev=1 write(6,*)'thinkdeb fields name and size ',fields%size(),'' ,fields%name() do isize=1,fields%size() diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index 5b7267085..72bdf8069 100644 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -751,6 +751,7 @@ module subroutine filtering_fast_bkg(this) !*** !*** Apply beta filter in vertical direction !*** + write(6,*)'thinkdeb l_vertical_filter is ',l_vertical_filter 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) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index a7d6ef3fa..ac3c872ce 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -489,13 +489,13 @@ subroutine init_mg_parameter(this,inputfilename) 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=1 ! number of ensemble members -logical :: l_loc ! logical flag for localization +logical :: l_loc=.false. 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=.false. ! logical flag for new mapping between analysis and filter grid -logical :: l_vertical_filter=.false. ! logical flag for vertical filtering +logical :: l_vertical_filter=.true. ! logical flag for vertical filtering integer(i_kind):: gm_max=4 !clt by defaul ! Global number of data on Analysis grid diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index a3fbee99e..878fdb978 100644 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -58,14 +58,16 @@ module subroutine anal_to_filt_allmap(this,WORKA) 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 + write(6,*)'thinkdeb in mg_transfer ',km_a_all, km_all,nm,im,mm,jm + write(6,*)'thinkdeb in mg_transfer l_new_map ',l_new_map +!clttothink if(km_a_all==km_all.and.nm==im.and.mm==jm) then +!cltothink VALL=0. +!clttohink VALL(1:km_all,1:im,1:jm)=WORKA +!clttothinkelseif(l_new_map) then +!clttothink call this%anal_to_filt_all2(WORKA) +!cltothinkelse call this%anal_to_filt_all(WORKA) -endif +!cltothinkendif !---------------------------------------------------------------------- endsubroutine anal_to_filt_allmap @@ -84,14 +86,15 @@ module subroutine filt_to_anal_allmap(this,WORKA) 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 +write(6,*)'filt_toanal_allmap ',km_a_all,' ',km_all,' ',nm,' ',im,' ',mm,' ',jm +!cltothink if(km_a_all==km_all.and.nm==im.and.mm==jm) then +!clttothink WORKA=VALL(1:km_all,1:im,1:jm) +!clttothink VALL=0. +!cltothink elseif(l_new_map) then +!cltothink call this%filt_to_anal_all2(WORKA) +!clttothink else call this%filt_to_anal_all(WORKA) -endif +!cltthink endif !---------------------------------------------------------------------- endsubroutine filt_to_anal_allmap @@ -117,10 +120,11 @@ module subroutine anal_to_filt_all(this,WORKA) 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)) +!tothink call btim(an2filt_tim) call this%S2C_ens(WORKA,A3D,1,nm,1,mm,lm_a,km_a,km_a_all) - + write(6,*)'thinkdeb in mg_transfer.f90 lm_a ,lm ',lm_a,' ',lm 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) @@ -427,6 +431,7 @@ module subroutine anal_to_filt(this,WORK) !---------------------------------------------------------------------- VALL=0. +!clttothink if(l_lin_horizontal) then ibm=1 jbm=1 From ba9d2dad1b3b8af8773d3cbb9ca80e41154077bb Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 2 Jul 2024 11:24:45 +0000 Subject: [PATCH 008/199] debugging coding --- src/saber/mgbf/covariance/mgbf_Interpolation.cc | 4 ++-- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 3 +-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_Interpolation.cc b/src/saber/mgbf/covariance/mgbf_Interpolation.cc index 43e44ab56..a785ec1b5 100644 --- a/src/saber/mgbf/covariance/mgbf_Interpolation.cc +++ b/src/saber/mgbf/covariance/mgbf_Interpolation.cc @@ -60,8 +60,8 @@ mgbf_Interpolation::mgbf_Interpolation(const oops::GeometryData & outerGeometryD // Active variables const oops::Variables activeVars = getActiveVars(params, outerVars); std::vector activeVariableSizes; - for (const std::string & var : activeVars.variables()) { - activeVariableSizes.push_back(activeVars.getLevels(var)); + for (const auto & var : activeVars) { + activeVariableSizes.push_back(var.getLevels()); } oops::Log::trace()<<"in mgbf interp before interpolator "< Date: Tue, 16 Jul 2024 01:45:48 +0000 Subject: [PATCH 009/199] a working version of mgbf for fv3jedi --- src/saber/mgbf/covariance/1 | 12 ------ .../mgbf/covariance/mgbf_covariance_mod.f90 | 39 +++++++++---------- src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 1 + src/saber/mgbf/mgbf_lib/mg_generations.f90 | 1 + src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 1 + src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 9 ++++- src/saber/oops/ErrorCovarianceToolbox.h | 29 ++++++++++++++ 7 files changed, 59 insertions(+), 33 deletions(-) delete mode 100644 src/saber/mgbf/covariance/1 diff --git a/src/saber/mgbf/covariance/1 b/src/saber/mgbf/covariance/1 deleted file mode 100644 index d4b3ec8f9..000000000 --- a/src/saber/mgbf/covariance/1 +++ /dev/null @@ -1,12 +0,0 @@ -1 -MGBF_Covariance.h -dd -dd.h -mgbf_covariance_mod.f90 -MGBF_Covariance.cc -MGBF_Covariance.interface.h -Convariance.h.org -MGBF_Covariance.interface.F90 -dr-bak/ -tlei_tools_linkedlist_implementation.fypp -tlei_tools_linkedlist_interface.fypp diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 6fbb1b0a0..5ef29c0a5 100644 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -183,6 +183,7 @@ subroutine multiply(self, fields) real(kind=r_kind), pointer :: ptr_3d(:,:,:) integer(kind=i_kind):: nz,ilev,isize real(kind=r_kind), allocatable :: work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) real(kind=r_kind), allocatable :: work2d_mgbf(:,:) integer(kind=i_kind) :: dim2d(2),dim3d(3) integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc @@ -196,7 +197,9 @@ subroutine multiply(self, fields) write(6,*)"thinkdeb mgbf multiply mgbf_covariance_mod.f90 " write(6,*)"thinkdeb mgbf work_mgbf dim ",self%intstate%km_a_all,self%intstate%nm,self%intstate%mm allocate(work_mgbf(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) + allocate(work_mgbf2(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work2d_mgbf(self%intstate%km_a_all,self%intstate%nm*self%intstate%mm)) + work_mgbf2=0.0 ilev=1 do isize=1,fields%size() @@ -224,26 +227,15 @@ subroutine multiply(self, fields) nxloc=dim3d(2) nyloc=dim3d(3) nzloc=dim3d(1) - do k=1,nzloc - do ij=1,nxloc*nyloc - if(work2d_mgbf(k,ij).ne.0.0) then - write(6,*)'thinkdeb begin non-zeror work2d_mgbf ',k,' ',ij,' ',work2d_mgbf(k,ij) - endif - enddo - enddo - do k=1,nzloc - do j=1,nyloc - do i=1,nxloc - if(work_mgbf(k,i,j).ne.0.0) then - write(6,*)'thinkdeb begin non-zeror work_mgbf ',k,' ',i,' ',j,' ',work_mgbf(k,i,j) - endif - enddo - enddo - enddo call self%intstate%anal_to_filt_allmap(work_mgbf) + write(6,*)'thinkdeb skipp filtering stepxx 3' + if(1.gt.0) then call self%intstate%filtering_procedure(self%intstate%mgbf_proc,1) + endif - call self%intstate%filt_to_anal_allmap(work_mgbf) +!cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) + call self%intstate%filt_to_anal_allmap(work_mgbf2) + work_mgbf=work_mgbf2 if(1.gt.2) then if(myrank == 0) then @@ -297,17 +289,22 @@ subroutine multiply(self, fields) enddo enddo enddo - + write(6,*)"thinkdeb is2 continuous1 ",is_contiguous(work_mgbf) + write(6,*)"thinkdeb is continuous2 ",is_contiguous(work2d_mgbf) + write(6,*)'thinkdeb dim2d is ',dim2d(1),dim2d(2) work2d_mgbf=reshape(work_mgbf,[dim2d(1),dim2d(2)]) + write(6,*)'thinkdeb-2 work2d_mgbf (20,60) =',work2d_mgbf(20,60) do k=1,nzloc do ij=1,nxloc*nyloc if(work2d_mgbf(k,ij).ne.0.0) then - write(6,*)'thinkdeb end non-zeror work2d_mgbf ',k,' ',ij,' ',work2d_mgbf(k,ij) + write(6,*)'thinkdebnon-zeror work2d_mgbf ',k,' ',ij,' ',work2d_mgbf(k,ij) + write(6,*)'thinkdeb-1 work2d_mgbf (20,60) =',work2d_mgbf(20,60) endif enddo enddo - ilev=1 + write(6,*)'thinkdeb2 work2d_mgbf (20,60) =',work2d_mgbf(20,60) write(6,*)'thinkdeb fields name and size ',fields%size(),'' ,fields%name() + ilev=1 do isize=1,fields%size() afield=fields%field(isize) !clttodo @@ -315,7 +312,9 @@ subroutine multiply(self, fields) call afield%data(ptr_2d) nz=afield%levels() write(6,*)'think nz of afield is ',nz + write(6,*)'thinkdeb3 work2d_mgbf (20,60) =',work2d_mgbf(20,60) ptr_2d(1:nz,:)=work2d_mgbf(ilev:ilev+nz-1,:) + write(6,*)'thinkdeb ptr_2d (20,60) =',ptr_2d(20,60) ilev=ilev+nz elseif (afield%rank() == 3) then call afield%data(ptr_3d) diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index 72bdf8069..880a1bff2 100644 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -69,6 +69,7 @@ module subroutine filtering_procedure(this,mg_filt,mg_filt_flag) if(this%nxm*this%nym>1) then select case(mg_filt) case(1) + write(6,*)'thinkdeb filtering_rad3 is used' call this%filtering_rad3 case(2) call this%filtering_lin3 diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index 291f0a57c..73550cf93 100644 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -102,6 +102,7 @@ module subroutine upsending_all & logical, intent(in):: lquart !----------------------------------------------------------------------- + write(6,*)'thinkdeb in mg_generations.f90,lquart is ', lquart if(lquart) then call this%upsending2(V,H) else diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index cbe9b9c56..ce3cfecbb 100644 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1029,6 +1029,7 @@ subroutine allocate_mg_intstate(this) call flush(6) allocate(this%V(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm)) ; this%V=0. +write(6,*)'thinkdeb VALL dimension ',this%km_all,1-this%hx,' ',this%im+this%hx,' ',1-this%hy, ' ',this%jm+this%hy 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. diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index a7138620d..3504d96d8 100644 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -124,6 +124,7 @@ module subroutine anal_to_filt_all(this,WORKA) !tothink call btim(an2filt_tim) +if(2.gt.3) then call this%S2C_ens(WORKA,A3D,1,nm,1,mm,lm_a,km_a,km_a_all) write(6,*)'thinkdeb in mg_transfer.f90 lm_a ,lm ',lm_a,' ',lm if(lm_a>lm) then @@ -144,7 +145,9 @@ module subroutine anal_to_filt_all(this,WORKA) call this%C2S_ens(F3D,WORK,1,nm,1,mm,lm,km,km_all) write(6,*)'thinkdeb before anal_to_filt ,if WORK has non-zero ',contains_nonzero(WORK) - call this%anal_to_filt(WORK) +endif !2.gt.3 +!cltorg call this%anal_to_filt(WORK) + call this%anal_to_filt(WORKA) write(6,*)'thinkdeb after anal_to_filt ,if WORK has non-zero ',contains_nonzero(WORK) call etim(an2filt_tim) @@ -171,6 +174,8 @@ module subroutine filt_to_anal_all(this,WORKA) include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !---------------------------------------------------------------------- + call this%filt_to_anal(WORKA) !cltadded +if (2.gt.3) then ! clt 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)) @@ -199,6 +204,7 @@ module subroutine filt_to_anal_all(this,WORKA) call etim(filt2an_tim) deallocate(A3D,F3D,WORK) +endif !2.gt. 3 !---------------------------------------------------------------------- endsubroutine filt_to_anal_all @@ -434,6 +440,7 @@ module subroutine anal_to_filt(this,WORK) !---------------------------------------------------------------------- VALL=0. write(6,*)"thinkdeb in anal_to_filt work nonzeor ? ",contains_nonzero(work) +!clttothink write(6,*)"thinkdeb in anal_to_filt l_?_horizonal ",l_lin_horizontal,l_quad_horizontal !clttothink if(l_lin_horizontal) then diff --git a/src/saber/oops/ErrorCovarianceToolbox.h b/src/saber/oops/ErrorCovarianceToolbox.h index 3aace2c18..14efea649 100644 --- a/src/saber/oops/ErrorCovarianceToolbox.h +++ b/src/saber/oops/ErrorCovarianceToolbox.h @@ -51,6 +51,10 @@ #include "saber/oops/Utilities.h" #include "saber/util/FieldSetHelpers.h" +#include "oops/base/PostProcessor.h" +#include "oops/base/StructuredGridPostProcessor.h" +#include "oops/base/StructuredGridWriter.h" + namespace saber { // ----------------------------------------------------------------------------- @@ -508,9 +512,34 @@ void write_1d_covariances(const eckit::mpi::Comm & comm, // Seek and replace %id% with id, recursively util::seekAndReplace(outputBConf, "%id%", id); + for (auto& fld:dxo[0].fieldSet() ) { + oops::Log::trace()<<"thinkdeb dxo 0 input fld is "< post; + const eckit::LocalConfiguration anLatlonConf(outputBConf, "analysis to structured grid"); + oops::Log::trace() << "thinkdeb anaLatlonConf: " << anLatlonConf << std::endl; + oops::StructuredGridWriter latlonwriter(anLatlonConf,dxo.geometry()); + oops::Log::trace() << "thinkdeb before latlonwrite.interpolatAndWriter " << std::endl; + latlonwriter.interpolateAndWrite(dxo[0]); //clttodo + +// post.enrollProcessor(new oops::StructuredGridPostProcessor( + // anLatlonConf, dxo.geometry() )); + }; + + + +//end of b1 oops::Log::test() << "Covariance(" << id << ") * Increment:" << dxo << std::endl; // Look for hybrid or ensemble covariance models From b84523641fe1f555cb0c44773c24b78dfa9c3178 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 19 Jul 2024 23:41:51 +0000 Subject: [PATCH 010/199] continued validation of mgbf --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 107 ++++++------------ src/saber/oops/ErrorCovarianceToolbox.h | 2 +- 2 files changed, 33 insertions(+), 76 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 5ef29c0a5..fdc9d08f0 100644 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -188,28 +188,39 @@ subroutine multiply(self, fields) integer(kind=i_kind) :: dim2d(2),dim3d(3) integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc integer(kind=i_kind):: i,j,k,ij +integer(kind=i_kind):: n2d +logical :: l3d_encountered + !clt now noly consider t ! afield = fields%field('air_temperature') ! call afield%data(t) !*** From the analysis to first generation of filter grid -!*** - write(6,*)"thinkdeb mgbf multiply mgbf_covariance_mod.f90 " - write(6,*)"thinkdeb mgbf work_mgbf dim ",self%intstate%km_a_all,self%intstate%nm,self%intstate%mm + n2d=0 + l3d_encountered=.false. allocate(work_mgbf(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work_mgbf2(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work2d_mgbf(self%intstate%km_a_all,self%intstate%nm*self%intstate%mm)) work_mgbf2=0.0 ilev=1 do isize=1,fields%size() - + afield= fields%field(isize) !clttodo if(afield%rank() == 2) then nz=afield%levels() + write(6,*)'thinkdeb55 isize/name/nz is ',isize,' ',afield%name(),' ',nz call afield%data(ptr_2d) work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d ilev=ilev+1 + if(nz > 1) l3d_encountered=.true. + if(nz == 1) then + if(l3d_encountered ) stop ! is required 2d fields are saved consecutively + n2d=n2d+1 + endif elseif (afield%rank() == 3) then + write(6,*)'this case needs more work, stop' ! a better exption handling to be added + call flush(6) + stop call afield%data(ptr_3d) nz=afield%levels() work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d @@ -219,6 +230,10 @@ subroutine multiply(self, fields) stop endif enddo + if(self%intstate%km2.ne.n2d) then + write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' + stop ! a better exception handling is to be added + endif dim2d=shape(work2d_mgbf) dim3d=shape(work_mgbf) @@ -227,8 +242,18 @@ subroutine multiply(self, fields) nxloc=dim3d(2) nyloc=dim3d(3) nzloc=dim3d(1) + write(6,*)"thinkdeb666-1" + do k=1,nzloc + do j=1,nxloc + do i=1,nxloc + if(work_mgbf(k,i,j) .gt.0.001) then + write(6,*)'thinkdeb666, non zeror k,i,j work_mgbf ',i,j,k,' ',work_mgbf(k,i,j) + endif + enddo + enddo + enddo + if(1 > 0) then call self%intstate%anal_to_filt_allmap(work_mgbf) - write(6,*)'thinkdeb skipp filtering stepxx 3' if(1.gt.0) then call self%intstate%filtering_procedure(self%intstate%mgbf_proc,1) endif @@ -236,74 +261,8 @@ subroutine multiply(self, fields) !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) call self%intstate%filt_to_anal_allmap(work_mgbf2) work_mgbf=work_mgbf2 - - if(1.gt.2) then - if(myrank == 0) then - write(6,*)'thindkeb250 nxloc,nyloc/nzloc ',nxloc,nyloc,nzloc - do k=1,nzloc - do j=1,nyloc - do i=1,nxloc - work_mgbf(k,i,j)=j - enddo - enddo - enddo - - else if(myrank == 1) then - write(6,*)'thindkeb250 nxloc,nyloc/nzloc ',nxloc,nyloc,nzloc - do k=1,nzloc - do j=1,nyloc - do i=1,nxloc - work_mgbf(k,i,j)=j - enddo - enddo - enddo - else if(myrank == 2) then - write(6,*)'thindkeb250 nxloc,nyloc/nzloc ',nxloc,nyloc,nzloc - do k=1,nzloc - do j=1,nyloc - do i=1,nxloc - work_mgbf(k,i,j)=nyloc+j - enddo - enddo - enddo - else if(myrank == 3) then - write(6,*)'thindkeb250 nxloc,nyloc/nzloc ',nxloc,nyloc,nzloc - do k=1,nzloc - do j=1,nyloc - do i=1,nxloc - work_mgbf(k,i,j)=j+nyloc - enddo - enddo - enddo - else - write(6,*)'something is wrong here 255, stop' - stop - endif - endif !1>2 - do k=1,nzloc - do j=1,nyloc - do i=1,nxloc - if(work_mgbf(k,i,j).ne.0.0) then - write(6,*)'thinkdeb end non-zeror work_mgbf ',k,' ',i,' ',j,' ',work_mgbf(k,i,j) - endif - enddo - enddo - enddo - write(6,*)"thinkdeb is2 continuous1 ",is_contiguous(work_mgbf) - write(6,*)"thinkdeb is continuous2 ",is_contiguous(work2d_mgbf) - write(6,*)'thinkdeb dim2d is ',dim2d(1),dim2d(2) + endif !1>2 work2d_mgbf=reshape(work_mgbf,[dim2d(1),dim2d(2)]) - write(6,*)'thinkdeb-2 work2d_mgbf (20,60) =',work2d_mgbf(20,60) - do k=1,nzloc - do ij=1,nxloc*nyloc - if(work2d_mgbf(k,ij).ne.0.0) then - write(6,*)'thinkdebnon-zeror work2d_mgbf ',k,' ',ij,' ',work2d_mgbf(k,ij) - write(6,*)'thinkdeb-1 work2d_mgbf (20,60) =',work2d_mgbf(20,60) - endif - enddo - enddo - write(6,*)'thinkdeb2 work2d_mgbf (20,60) =',work2d_mgbf(20,60) - write(6,*)'thinkdeb fields name and size ',fields%size(),'' ,fields%name() ilev=1 do isize=1,fields%size() @@ -311,10 +270,8 @@ subroutine multiply(self, fields) if(afield%rank() == 2) then call afield%data(ptr_2d) nz=afield%levels() - write(6,*)'think nz of afield is ',nz - write(6,*)'thinkdeb3 work2d_mgbf (20,60) =',work2d_mgbf(20,60) + write(6,*)'thinkdeb552 isize/name/nz is ',isize,' ',afield%name(),' ',nz ptr_2d(1:nz,:)=work2d_mgbf(ilev:ilev+nz-1,:) - write(6,*)'thinkdeb ptr_2d (20,60) =',ptr_2d(20,60) ilev=ilev+nz elseif (afield%rank() == 3) then call afield%data(ptr_3d) diff --git a/src/saber/oops/ErrorCovarianceToolbox.h b/src/saber/oops/ErrorCovarianceToolbox.h index 0c1553bba..0a3612f83 100644 --- a/src/saber/oops/ErrorCovarianceToolbox.h +++ b/src/saber/oops/ErrorCovarianceToolbox.h @@ -458,7 +458,7 @@ template class ErrorCovarianceToolbox : public oops::Applicatio for (auto& fld:dxo[0].fieldSet() ) { oops::Log::trace()<<"thinkdeb dxo 1 input fld is "< Date: Sun, 21 Jul 2024 03:26:19 +0000 Subject: [PATCH 011/199] continued verification of mgbf codes --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 38 +++++++++++++------ 1 file changed, 27 insertions(+), 11 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index fdc9d08f0..f190192b3 100644 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -201,7 +201,13 @@ subroutine multiply(self, fields) allocate(work_mgbf(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work_mgbf2(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work2d_mgbf(self%intstate%km_a_all,self%intstate%nm*self%intstate%mm)) + dim2d=shape(work2d_mgbf) + dim3d=shape(work_mgbf) + nxloc=dim3d(2) + nyloc=dim3d(3) + nzloc=dim3d(1) work_mgbf2=0.0 + ilev=1 do isize=1,fields%size() @@ -211,12 +217,19 @@ subroutine multiply(self, fields) write(6,*)'thinkdeb55 isize/name/nz is ',isize,' ',afield%name(),' ',nz call afield%data(ptr_2d) work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - ilev=ilev+1 + ilev=ilev+nz if(nz > 1) l3d_encountered=.true. if(nz == 1) then if(l3d_encountered ) stop ! is required 2d fields are saved consecutively n2d=n2d+1 endif + do k=1,64 ! #nzloc + do i=1,nxloc*nyloc + if(ptr_2d(k,i) .gt.0.001) then + write(6,*)'thinkdeb666ptr, non zeror k,ij work2d_mgbf ',i,k+64*(isize-1),' ',ptr_2d(k,i) + endif + enddo + enddo elseif (afield%rank() == 3) then write(6,*)'this case needs more work, stop' ! a better exption handling to be added call flush(6) @@ -234,15 +247,18 @@ subroutine multiply(self, fields) write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added endif - dim2d=shape(work2d_mgbf) - dim3d=shape(work_mgbf) - - work_mgbf=reshape(work2d_mgbf,[dim3d(1),dim3d(2),dim3d(3)]) + do k=1,nzloc + work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) + enddo - nxloc=dim3d(2) - nyloc=dim3d(3) - nzloc=dim3d(1) write(6,*)"thinkdeb666-1" + do k=1,nzloc + do i=1,nxloc*nyloc + if(work2d_mgbf(k,i) .gt.0.001) then + write(6,*)'thinkdeb666, non zeror k,ij work2d_mgbf ',i,k,' ',work2d_mgbf(k,i) + endif + enddo + enddo do k=1,nzloc do j=1,nxloc do i=1,nxloc @@ -252,7 +268,6 @@ subroutine multiply(self, fields) enddo enddo enddo - if(1 > 0) then call self%intstate%anal_to_filt_allmap(work_mgbf) if(1.gt.0) then call self%intstate%filtering_procedure(self%intstate%mgbf_proc,1) @@ -261,8 +276,9 @@ subroutine multiply(self, fields) !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) call self%intstate%filt_to_anal_allmap(work_mgbf2) work_mgbf=work_mgbf2 - endif !1>2 - work2d_mgbf=reshape(work_mgbf,[dim2d(1),dim2d(2)]) + do k=1,nzloc + work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + enddo ilev=1 do isize=1,fields%size() From a887c15af2ed82f75544764badf2e6fb43ef097b Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 19 Aug 2024 17:36:09 +0000 Subject: [PATCH 012/199] a version for ensemble localization using mgbf too --- .../UnstructuredInterpolation.cc | 11 +- .../UnstructuredInterpolation.interface.F90 | 3 + .../mgbf/covariance/mgbf_Interpolation.cc | 12 +- .../mgbf/covariance/mgbf_covariance_mod.f90 | 124 +++++++++++++----- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 7 +- src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 1 + src/saber/mgbf/mgbf_lib/mg_generations.f90 | 1 - src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 19 ++- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 10 +- src/saber/oops/ErrorCovarianceToolbox.h | 2 +- src/saber/oops/Localization.h | 8 ++ 11 files changed, 138 insertions(+), 60 deletions(-) diff --git a/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.cc b/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.cc index 95cb17263..d4f39034c 100644 --- a/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.cc +++ b/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.cc @@ -36,22 +36,19 @@ UnstructuredInterpolation::UnstructuredInterpolation( : innerFuncSpace_(innerFuncSpace), outerFuncSpace_(outerFuncSpace), activeVariableSizes_(activeVariableSizes), activeVars_(activeVars) { - oops::Log::trace()<<"thinkdeb in gsi::UnstracutredInterpolation CTOR begin"<( atlas::option::name(activeVars_[i].name()) | atlas::option::levels(activeVariableSizes_[i])); + std::cout<apply(fset[activeVars_[i].name()], outerField); util::removeFieldsFromFieldSet(fset, {activeVars_[i].name()}); fset.add(outerField); @@ -91,6 +91,7 @@ void UnstructuredInterpolation::apply(atlas::FieldSet & fset) { // ----------------------------------------------------------------------------- void UnstructuredInterpolation::applyAD(atlas::FieldSet & fset) { +//clt std::cout<( atlas::option::name(activeVars_[i].name()) | atlas::option::levels(activeVariableSizes_[i])); diff --git a/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.interface.F90 b/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.interface.F90 index 0e48ad29a..7adabe24a 100644 --- a/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.interface.F90 +++ b/src/saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.interface.F90 @@ -68,6 +68,7 @@ subroutine saber_unstrc_create_c(c_key_unstrc, c_comm, c_lonlat1, & read_from_file = .false. endif +write(6,*)'thinkdeb in gsi_interp*interface.h ngrid1/2 =',ngrid1,' ',ngrid2 if (read_from_file) then call fckit_log%info("Reading interpolator from file") call f_config%get_or_die("infile", infile) @@ -178,7 +179,9 @@ subroutine saber_unstrc_apply_c(c_key_unstrc, c_infield, c_outfield) bind(c, nam call outfield%data(fout_r2) do jlev = 1, jlev1 +!clt write(6,*)'thinkdeb in UnstructuredInterpolation.interface.F90 jlev ',jlev call unstrc_int%apply(fin_r2(jlev,:), fout_r2(jlev,:)) +!clt write(6,*)'thinkdeb in UnstructuredInterpolation.interface.F90 jlev end ' enddo endif diff --git a/src/saber/mgbf/covariance/mgbf_Interpolation.cc b/src/saber/mgbf/covariance/mgbf_Interpolation.cc index a785ec1b5..d09bb6102 100644 --- a/src/saber/mgbf/covariance/mgbf_Interpolation.cc +++ b/src/saber/mgbf/covariance/mgbf_Interpolation.cc @@ -84,18 +84,26 @@ mgbf_Interpolation::~mgbf_Interpolation() { // ------------------------------------------------------------------------------------------------- void mgbf_Interpolation::multiply(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::multiply starting" << std::endl; + oops::Log::trace() << classname() << "::multiply starting <apply(fset.fieldSet()); - oops::Log::trace() << classname() << "::multiply done" << std::endl; +// std::cout <<"mgbf_Interpolation::multiply starting 2 fset" << std::endl; +// fset.print(std::cout) ; + oops::Log::trace() << "mgbf_Interpolation::multiply done" << std::endl; } // ------------------------------------------------------------------------------------------------- void mgbf_Interpolation::multiplyAD(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; +// std::cout<<"thinkdeb mgbf::interpolation::mutliplyAD cout<applyAD(fset.fieldSet()); +// std::cout<<"thinkdeb after mgbf::interpolation::mutliplyAD cout< 1) l3d_encountered=.true. if(nz == 1) then if(l3d_encountered ) stop ! is required 2d fields are saved consecutively n2d=n2d+1 endif - do k=1,64 ! #nzloc - do i=1,nxloc*nyloc - if(ptr_2d(k,i) .gt.0.001) then - write(6,*)'thinkdeb666ptr, non zeror k,ij work2d_mgbf ',i,k+64*(isize-1),' ',ptr_2d(k,i) - endif - enddo - enddo + if(isize==1) then + varvlev_index(isize,1)= 1 + varvlev_index(isize,2)= nz + else + varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz + varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 + endif + elseif (afield%rank() == 3) then write(6,*)'this case needs more work, stop' ! a better exption handling to be added call flush(6) @@ -243,39 +265,72 @@ subroutine multiply(self, fields) stop endif enddo + do k=1,nzloc + work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) + enddo + if(test_once) then +!clt open(iounit,file=trim(fileoutput), status='replace',form="formatted") + + open(iounit,file=trim(fileoutput), status='unknown', action='write', position='append', form='formatted',iostat=i) + write(iounit,*)"itest is ",itest + write(iounit,*) work_mgbf + itest=itest+1 + if(itest==1) test_once=.false. + close(iounit) + do k=1,nzloc + do j=1,nyloc + do i=1,nxloc + if(work_mgbf(k,i,j).gt.0.002) then + write(6,*)'thinkdeb work_mgbf .gt.0.002 ',i,j,k, ' ',work_mgbf(k,i,j) + endif + enddo + enddo + enddo + endif if(self%intstate%km2.ne.n2d) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added endif - do k=1,nzloc - work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) - enddo + + if(test_once.and..1.gt.2) then + open(iounit,file=trim(fileoutput), status='replace',form="formatted") + write(iounit,*) work_mgbf + test_once=.false. + close(iounit) + endif - write(6,*)"thinkdeb666-1" - do k=1,nzloc - do i=1,nxloc*nyloc - if(work2d_mgbf(k,i) .gt.0.001) then - write(6,*)'thinkdeb666, non zeror k,ij work2d_mgbf ',i,k,' ',work2d_mgbf(k,i) - endif - enddo - enddo - do k=1,nzloc - do j=1,nxloc - do i=1,nxloc - if(work_mgbf(k,i,j) .gt.0.001) then - write(6,*)'thinkdeb666, non zeror k,i,j work_mgbf ',i,j,k,' ',work_mgbf(k,i,j) - endif - enddo - enddo - enddo call self%intstate%anal_to_filt_allmap(work_mgbf) - if(1.gt.0) then call self%intstate%filtering_procedure(self%intstate%mgbf_proc,1) - endif !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) call self%intstate%filt_to_anal_allmap(work_mgbf2) + write(6,*)"thinkdeb22 in covarian*mod.f90 l_for_localization ",self%intstate%l_for_localization + + if(.not. self%intstate%l_for_localization) then !clthinkdeb work_mgbf=work_mgbf2 + else !now, only for cases all are 3d arrays + allocate(work1var_mgbf(nz,nxloc,nyloc)) + work1var_mgbf=0.0 + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + write(6,*)'ivar is ',ivar,' ',lev1,' ',lev2 + work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) + enddo + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + deallocate(work1var_mgbf) + endif + iounit=20+myrank + if(test_once.and.1.gt.2) then + open(iounit,file=trim(fileoutput), status='replace',form="formatted") + write(iounit,*) work_mgbf + test_once=.false. + close(iounit) + endif do k=1,nzloc work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) enddo @@ -286,7 +341,6 @@ subroutine multiply(self, fields) if(afield%rank() == 2) then call afield%data(ptr_2d) nz=afield%levels() - write(6,*)'thinkdeb552 isize/name/nz is ',isize,' ',afield%name(),' ',nz ptr_2d(1:nz,:)=work2d_mgbf(ilev:ilev+nz-1,:) ilev=ilev+nz elseif (afield%rank() == 3) then @@ -309,7 +363,9 @@ subroutine multiply(self, fields) deallocate(work_mgbf) + deallocate(work_mgbf2) deallocate(work2d_mgbf) + deallocate( varvlev_index) end subroutine multiply diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index 6499b0ed9..0bc4e4974 100644 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -848,7 +848,6 @@ module subroutine bocoT_2d_g1 & ! Limit comminications to selected number of generations ! - g_ind=1 ! ! from mg_domain @@ -878,6 +877,7 @@ module subroutine bocoT_2d_g1 & if( itarg_w >= 0) then nebpe = itarg_w +!clttothink1 allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) @@ -918,6 +918,7 @@ module subroutine bocoT_2d_g1 & if( itarg_e >= 0 ) then nebpe = itarg_e +!cltothink1-2 allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) @@ -928,11 +929,11 @@ module subroutine bocoT_2d_g1 & 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) @@ -985,6 +986,7 @@ module subroutine bocoT_2d_g1 & 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 @@ -1002,6 +1004,7 @@ module subroutine bocoT_2d_g1 & if( itarg_n >= 0 ) then nebpe = itarg_n + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) do j=1,nby diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index 880a1bff2..8ce8539b1 100644 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -66,6 +66,7 @@ module subroutine filtering_procedure(this,mg_filt,mg_filt_flag) include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- + write(6,*)'thinkdeb filtering_procedure nxm,nym ',this%nxm,' ',this%nym if(this%nxm*this%nym>1) then select case(mg_filt) case(1) diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index 73550cf93..291f0a57c 100644 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -102,7 +102,6 @@ module subroutine upsending_all & logical, intent(in):: lquart !----------------------------------------------------------------------- - write(6,*)'thinkdeb in mg_generations.f90,lquart is ', lquart if(lquart) then call this%upsending2(V,H) else diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index ac3c872ce..3dbf43d73 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -38,6 +38,7 @@ module mg_parameter type:: mg_parameter_type !----------------------------------------------------------------------- !*** +logical:: l_for_localization=.false. !used for localizaiton while multiple variates need additional treeatment !*** Namelist parameters !*** real(r_kind):: mg_ampl01,mg_ampl02,mg_ampl03 @@ -481,8 +482,9 @@ subroutine init_mg_parameter(this,inputfilename) integer(i_kind):: mgbf_proc logical:: mgbf_line integer(i_kind):: nxPE,nyPE,im_filt,jm_filt -logical:: lquart,lhelm -logical:: ldelta +logical:: lquart=.false.,lhelm=.false. !clt what should be the default +logical:: ldelta=.false. +logical:: l_for_localization=.false. integer(i_kind):: lm_a ! number of vertical layers in analysis fields integer(i_kind):: lm ! number of vertical layers in filter grids @@ -490,10 +492,10 @@ subroutine init_mg_parameter(this,inputfilename) integer(i_kind):: km3 ! number of 3d variables for filtering integer(i_kind):: n_ens=1 ! number of ensemble members logical :: l_loc=.false. -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_filt_g1=.false. ! logical flag for filtering of generation one +logical :: l_lin_vertical=.false. ! logical flag for linear interpolation in vertcial +logical :: l_lin_horizontal=.false. ! logical flag for linear interpolation in horizontal +logical :: l_quad_horizontal=.false. ! logical flag for quadratic interpolation in horizontal logical :: l_new_map=.false. ! logical flag for new mapping between analysis and filter grid logical :: l_vertical_filter=.true. ! logical flag for vertical filtering integer(i_kind):: gm_max=4 !clt by defaul @@ -519,7 +521,7 @@ subroutine init_mg_parameter(this,inputfilename) ,l_quad_horizontal & ,l_new_map & ,l_vertical_filter & - ,ldelta,lquart,lhelm & + ,l_for_localization,ldelta,lquart,lhelm & ,gm_max & ,nm0,mm0 & ,nxPE,nyPE,im_filt,jm_filt @@ -555,6 +557,8 @@ subroutine init_mg_parameter(this,inputfilename) this%l_quad_horizontal=l_quad_horizontal this%l_new_map=l_new_map this%l_vertical_filter=l_vertical_filter + this%l_for_localization=l_for_localization + write(6,*)'thinkdeb22 this%l_for_localization ',this%l_for_localization this%ldelta=ldelta this%lquart=lquart this%lhelm=lhelm @@ -855,6 +859,7 @@ subroutine init_mg_parameter(this,inputfilename) this%imL=this%im/2 this%jmL=this%jm/2 + write(6,*)'thinkdebzzz in mp_para imL/jmL ',this%imL, ' ',this%jmL this%imH=this%im0(this%gm) this%jmH=this%jm0(this%gm) diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index 3504d96d8..8e2531ff4 100644 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -59,8 +59,7 @@ module subroutine anal_to_filt_allmap(this,WORKA) include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !---------------------------------------------------------------------- - write(6,*)'thinkdeb in mg_transfer ',km_a_all, km_all,nm,im,mm,jm - write(6,*)'thinkdeb in mg_transfer l_new_map ',l_new_map +! write(6,*)'thinkdeb in mg_transfer ',km_a_all, km_all,nm,im,mm,jm !clttothink if(km_a_all==km_all.and.nm==im.and.mm==jm) then !cltothink VALL=0. !clttohink VALL(1:km_all,1:im,1:jm)=WORKA @@ -68,6 +67,7 @@ module subroutine anal_to_filt_allmap(this,WORKA) !clttothink call this%anal_to_filt_all2(WORKA) !cltothinkelse call this%anal_to_filt_all(WORKA) +! write(6,*)'thinkdeb in mg_transfer after anal_to_filt ',l_new_map !cltothinkendif !---------------------------------------------------------------------- endsubroutine anal_to_filt_allmap @@ -126,7 +126,6 @@ module subroutine anal_to_filt_all(this,WORKA) call btim(an2filt_tim) if(2.gt.3) then call this%S2C_ens(WORKA,A3D,1,nm,1,mm,lm_a,km_a,km_a_all) - write(6,*)'thinkdeb in mg_transfer.f90 lm_a ,lm ',lm_a,' ',lm 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) @@ -144,11 +143,9 @@ module subroutine anal_to_filt_all(this,WORKA) endif call this%C2S_ens(F3D,WORK,1,nm,1,mm,lm,km,km_all) - write(6,*)'thinkdeb before anal_to_filt ,if WORK has non-zero ',contains_nonzero(WORK) endif !2.gt.3 !cltorg call this%anal_to_filt(WORK) call this%anal_to_filt(WORKA) - write(6,*)'thinkdeb after anal_to_filt ,if WORK has non-zero ',contains_nonzero(WORK) call etim(an2filt_tim) deallocate(A3D,F3D,WORK) @@ -439,9 +436,7 @@ module subroutine anal_to_filt(this,WORK) include "type_intstat_point2this.inc" !---------------------------------------------------------------------- VALL=0. - write(6,*)"thinkdeb in anal_to_filt work nonzeor ? ",contains_nonzero(work) !clttothink - write(6,*)"thinkdeb in anal_to_filt l_?_horizonal ",l_lin_horizontal,l_quad_horizontal !clttothink if(l_lin_horizontal) then ibm=1 @@ -462,7 +457,6 @@ module subroutine anal_to_filt(this,WORK) !*** call this%bocoT_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) - write(6,*)"thinkdeb in anal_to_filt VALL nonzeor ? ",contains_nonzero(VALL) !---------------------------------------------------------------------- endsubroutine anal_to_filt diff --git a/src/saber/oops/ErrorCovarianceToolbox.h b/src/saber/oops/ErrorCovarianceToolbox.h index 0a3612f83..4db11a274 100644 --- a/src/saber/oops/ErrorCovarianceToolbox.h +++ b/src/saber/oops/ErrorCovarianceToolbox.h @@ -450,7 +450,7 @@ template class ErrorCovarianceToolbox : public oops::Applicatio util::seekAndReplace(outputBConf, "%id%", id); for (auto& fld:dxo[0].fieldSet() ) { oops::Log::trace()<<"thinkdeb dxo 0 input fld is "<::multiply(Increment_ & dx) const { // SABER block chain multiplication oops::FieldSet4D fset4d({dx.validTime(), dx.geometry().getComm()}); fset4d[0].shallowCopy(dx.fieldSet()); + oops::Log::trace()<multiply(fset4d); +#if 1 + dx.fromFieldSet(fset4d[0].fieldSet()); //cltthinkdeb +// oops::Log::trace()< Date: Thu, 29 Aug 2024 15:19:29 +0000 Subject: [PATCH 013/199] mgbf ensemble localization dealing with 2d variables --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 57 +++++++++---------- 1 file changed, 28 insertions(+), 29 deletions(-) mode change 100644 => 100755 src/saber/mgbf/covariance/mgbf_covariance_mod.f90 diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 old mode 100644 new mode 100755 index ede910ff9..b6f57dff2 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -189,7 +189,7 @@ subroutine multiply(self, fields) real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) real(kind=r_kind), allocatable :: work2d_mgbf(:,:) integer(kind=i_kind) :: dim2d(2),dim3d(3) -integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc +integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d integer(kind=i_kind)::nvar integer(kind=i_kind):: i,ivar,j,k,ij,lev1,lev2,iounit integer(kind=i_kind):: n2d @@ -205,6 +205,12 @@ subroutine multiply(self, fields) ! afield = fields%field('air_temperature') ! call afield%data(t) !*** From the analysis to first generation of filter grid + if(self%intstate%l_for_localization .and. self%intstate%km2) then + write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & +& "in which, the first level contains the 2d variables and others zeros " + + stop !to use a better exit procdure + endif myrank=self%rank write(str_rank,"(I4.4)")myrank if(self%intstate%l_for_localization) then @@ -221,14 +227,17 @@ subroutine multiply(self, fields) allocate(work_mgbf(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work_mgbf2(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work2d_mgbf(self%intstate%km_a_all,self%intstate%nm*self%intstate%mm)) + work2d_mgbf=0.0 + dim2d=shape(work2d_mgbf) + dim3d=shape(work_mgbf) nxloc=dim3d(2) nyloc=dim3d(3) nzloc=dim3d(1) - work_mgbf2=0.0 + nz3d=self%intstate%lm nvar=fields%size() - allocate( varvlev_index(nvar,2)) + allocate( varvlev_index(nvar,3)) ilev=1 do isize=1,fields%size() @@ -246,10 +255,20 @@ subroutine multiply(self, fields) endif if(isize==1) then varvlev_index(isize,1)= 1 - varvlev_index(isize,2)= nz + if(.not.self%intstate%l_for_localization )then + varvlev_index(isize,2)= nz + else + varvlev_index(isize,2)= nz3d + endif + varvlev_index(isize,3)= nz else - varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz - varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 + varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d + if(.not.self%intstate%l_for_localization )then + varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 + else + varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 + endif + varvlev_index(isize,3)=nz endif elseif (afield%rank() == 3) then @@ -268,25 +287,6 @@ subroutine multiply(self, fields) do k=1,nzloc work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) enddo - if(test_once) then -!clt open(iounit,file=trim(fileoutput), status='replace',form="formatted") - - open(iounit,file=trim(fileoutput), status='unknown', action='write', position='append', form='formatted',iostat=i) - write(iounit,*)"itest is ",itest - write(iounit,*) work_mgbf - itest=itest+1 - if(itest==1) test_once=.false. - close(iounit) - do k=1,nzloc - do j=1,nyloc - do i=1,nxloc - if(work_mgbf(k,i,j).gt.0.002) then - write(6,*)'thinkdeb work_mgbf .gt.0.002 ',i,j,k, ' ',work_mgbf(k,i,j) - endif - enddo - enddo - enddo - endif if(self%intstate%km2.ne.n2d) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added @@ -308,13 +308,12 @@ subroutine multiply(self, fields) if(.not. self%intstate%l_for_localization) then !clthinkdeb work_mgbf=work_mgbf2 - else !now, only for cases all are 3d arrays + else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures allocate(work1var_mgbf(nz,nxloc,nyloc)) work1var_mgbf=0.0 do ivar=1,nvar lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) - write(6,*)'ivar is ',ivar,' ',lev1,' ',lev2 work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) enddo do ivar=1,nvar @@ -341,8 +340,8 @@ subroutine multiply(self, fields) if(afield%rank() == 2) then call afield%data(ptr_2d) nz=afield%levels() - ptr_2d(1:nz,:)=work2d_mgbf(ilev:ilev+nz-1,:) - ilev=ilev+nz + lev1=varvlev_index(isize,1) + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) elseif (afield%rank() == 3) then call afield%data(ptr_3d) nz=afield%levels() From 33bb24ee1404018b763bef517a4b86f9fc83decd Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Wed, 25 Sep 2024 18:12:42 +0000 Subject: [PATCH 014/199] upgrading for treatment of 2d variables in mgbf ensemble localization and vertically varied normalization coefficients --- quench/src/Increment.cc | 6 + quench/src/Increment.h | 1 + src/saber/mgbf/CMakeLists.txt | 0 src/saber/mgbf/covariance/Convariance.h.org | 0 src/saber/mgbf/covariance/MGBF_Covariance.cc | 0 src/saber/mgbf/covariance/MGBF_Covariance.h | 0 .../covariance/MGBF_Covariance.interface.F90 | 1 - .../covariance/MGBF_Covariance.interface.h | 0 src/saber/mgbf/covariance/mgbf_Grid.cc | 0 src/saber/mgbf/covariance/mgbf_Grid.h | 0 .../mgbf/covariance/mgbf_Interpolation.cc | 0 .../mgbf/covariance/mgbf_Interpolation.h | 0 .../mgbf/covariance/mgbf_covariance_mod.f90 | 66 +++- .../tlei_tools_linkedlist_implementation.fypp | 0 .../tlei_tools_linkedlist_interface.fypp | 0 src/saber/mgbf/mgbf_lib/CMakeLists.txt | 0 src/saber/mgbf/mgbf_lib/jp_pbfil.f90 | 0 src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 | 0 src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 | 0 src/saber/mgbf/mgbf_lib/jp_pietc.f90 | 0 src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 | 0 src/saber/mgbf/mgbf_lib/jp_pkind.f90 | 0 src/saber/mgbf/mgbf_lib/jp_pkind2.f90 | 0 src/saber/mgbf/mgbf_lib/jp_pmat.f90 | 0 src/saber/mgbf/mgbf_lib/jp_pmat4.f90 | 0 src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 0 src/saber/mgbf/mgbf_lib/mg_domain.f90 | 0 src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 | 0 src/saber/mgbf/mgbf_lib/mg_entrymod.f90 | 0 src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 329 +++++++++++++++++- src/saber/mgbf/mgbf_lib/mg_generations.f90 | 0 src/saber/mgbf/mgbf_lib/mg_interpolate.f90 | 0 src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 7 + src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 | 0 src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 8 +- src/saber/mgbf/mgbf_lib/mg_timers.f90 | 2 + src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 0 src/saber/mgbf/mgbf_lib/mgbf_kind.f90 | 0 .../mgbf/mgbf_lib/type_intstat_locpointer.inc | 0 .../mgbf/mgbf_lib/type_intstat_point2this.inc | 0 .../mgbf_lib/type_parameter_locpointer.inc | 0 .../mgbf_lib/type_parameter_point2this.inc | 0 src/saber/oops/Localization.h | 1 + 43 files changed, 408 insertions(+), 13 deletions(-) mode change 100644 => 100755 src/saber/mgbf/CMakeLists.txt mode change 100644 => 100755 src/saber/mgbf/covariance/Convariance.h.org mode change 100644 => 100755 src/saber/mgbf/covariance/MGBF_Covariance.cc mode change 100644 => 100755 src/saber/mgbf/covariance/MGBF_Covariance.h mode change 100644 => 100755 src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 mode change 100644 => 100755 src/saber/mgbf/covariance/MGBF_Covariance.interface.h mode change 100644 => 100755 src/saber/mgbf/covariance/mgbf_Grid.cc mode change 100644 => 100755 src/saber/mgbf/covariance/mgbf_Grid.h mode change 100644 => 100755 src/saber/mgbf/covariance/mgbf_Interpolation.cc mode change 100644 => 100755 src/saber/mgbf/covariance/mgbf_Interpolation.h mode change 100644 => 100755 src/saber/mgbf/covariance/tlei_tools_linkedlist_implementation.fypp mode change 100644 => 100755 src/saber/mgbf/covariance/tlei_tools_linkedlist_interface.fypp mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/CMakeLists.txt mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/jp_pbfil.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/jp_pietc.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/jp_pkind.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/jp_pkind2.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/jp_pmat.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/jp_pmat4.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_bocos.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_domain.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_entrymod.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_filtering.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_generations.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_interpolate.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_intstate.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_parameter.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_timers.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mg_transfer.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/mgbf_kind.f90 mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/type_intstat_locpointer.inc mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/type_intstat_point2this.inc mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/type_parameter_locpointer.inc mode change 100644 => 100755 src/saber/mgbf/mgbf_lib/type_parameter_point2this.inc diff --git a/quench/src/Increment.cc b/quench/src/Increment.cc index a7c11d974..dd1bd2fe5 100644 --- a/quench/src/Increment.cc +++ b/quench/src/Increment.cc @@ -15,6 +15,8 @@ #include "oops/util/Logger.h" #include "src/Fields.h" +#include +#include namespace quench { @@ -79,6 +81,10 @@ void Increment::zero(const util::DateTime & vt) { fields_->zero(); fields_->time() = vt; } +void Increment::ones() { + std::cerr << "Error: quench::Increment::ones called unexpectedly. This method should not be used for being now" << std::endl; + throw std::runtime_error("Unexpected call to quench::Increment::ones"); +} // ----------------------------------------------------------------------------- void Increment::axpy(const double & zz, const Increment & dx, const bool check) { diff --git a/quench/src/Increment.h b/quench/src/Increment.h index b5a4c77a2..4409c9254 100644 --- a/quench/src/Increment.h +++ b/quench/src/Increment.h @@ -50,6 +50,7 @@ class Increment : public util::Printable, void diff(const State &, const State &); void zero(); void zero(const util::DateTime &); + void ones(); void dirac(const eckit::Configuration &); Increment & operator =(const Increment &); Increment & operator+=(const Increment &); diff --git a/src/saber/mgbf/CMakeLists.txt b/src/saber/mgbf/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/covariance/Convariance.h.org b/src/saber/mgbf/covariance/Convariance.h.org old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.cc b/src/saber/mgbf/covariance/MGBF_Covariance.cc old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 old mode 100644 new mode 100755 index 71f262c39..e7d108210 --- a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 +++ b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 @@ -100,7 +100,6 @@ subroutine mgbf_covariance_delete_cpp(c_self) & ! LinkedList ! ---------- call mgbf_covariance_registry%get(c_self, f_self) - ! Call implementation ! ------------------- call f_self%delete() diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.h b/src/saber/mgbf/covariance/MGBF_Covariance.interface.h old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/covariance/mgbf_Grid.cc b/src/saber/mgbf/covariance/mgbf_Grid.cc old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/covariance/mgbf_Grid.h b/src/saber/mgbf/covariance/mgbf_Grid.h old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/covariance/mgbf_Interpolation.cc b/src/saber/mgbf/covariance/mgbf_Interpolation.cc old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/covariance/mgbf_Interpolation.h b/src/saber/mgbf/covariance/mgbf_Interpolation.h old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index b6f57dff2..93ebc59f7 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -35,6 +35,8 @@ module mgbf_covariance_mod logical :: cv ! cv=.true.; sv=.false. integer :: mp_comm_world integer :: rank + logical :: l_2dvar_last_vertical_level=.true. !when used for localization,2dvars are put on the last vertical level + !when the fields in fset are stored from top to bottom !clt integer :: lat2,lon2 ! these belog to mgbf_grid contains procedure, public :: create @@ -188,6 +190,7 @@ subroutine multiply(self, fields) real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) real(kind=r_kind), allocatable :: work2d_mgbf(:,:) +real(kind=r_kind), allocatable :: rnormalization(:) integer(kind=i_kind) :: dim2d(2),dim3d(3) integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d integer(kind=i_kind)::nvar @@ -227,7 +230,9 @@ subroutine multiply(self, fields) allocate(work_mgbf(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work_mgbf2(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work2d_mgbf(self%intstate%km_a_all,self%intstate%nm*self%intstate%mm)) + allocate(rnormalization(self%intstate%km_a_all)) work2d_mgbf=0.0 + rnormalization=1.0 dim2d=shape(work2d_mgbf) @@ -237,6 +242,7 @@ subroutine multiply(self, fields) nzloc=dim3d(1) nz3d=self%intstate%lm nvar=fields%size() + write(6,*)'thinkdeb l_2d is ',self%l_2dvar_last_vertical_level allocate( varvlev_index(nvar,3)) ilev=1 do isize=1,fields%size() @@ -245,12 +251,29 @@ subroutine multiply(self, fields) if(afield%rank() == 2) then nz=afield%levels() call afield%data(ptr_2d) - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - ilev=ilev+nz + if(nz == 1) then + if(self%intstate%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + write(6,*)'thinkdebxxx right250 ',ilev+nz3d-1 + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + + + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif if(nz > 1) l3d_encountered=.true. if(nz == 1) then - if(l3d_encountered ) stop ! is required 2d fields are saved consecutively + if(l3d_encountered ) then + write(6,*)"l3d_encountered is true , 2dvariable is not put in the begining, stop" + stop ! is required 2d fields are saved consecutively + endif n2d=n2d+1 endif if(isize==1) then @@ -260,17 +283,20 @@ subroutine multiply(self, fields) else varvlev_index(isize,2)= nz3d endif - varvlev_index(isize,3)= nz + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 else - varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d +!cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d + varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 if(.not.self%intstate%l_for_localization )then varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 else varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 endif - varvlev_index(isize,3)=nz + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 endif + rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) + ilev=varvlev_index(isize,2)+1 elseif (afield%rank() == 3) then write(6,*)'this case needs more work, stop' ! a better exption handling to be added call flush(6) @@ -285,9 +311,10 @@ subroutine multiply(self, fields) endif enddo do k=1,nzloc + work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) enddo - if(self%intstate%km2.ne.n2d) then + if(self%intstate%km2.ne.n2d.and. .not.self%intstate%l_for_localization ) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added endif @@ -309,7 +336,7 @@ subroutine multiply(self, fields) if(.not. self%intstate%l_for_localization) then !clthinkdeb work_mgbf=work_mgbf2 else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures - allocate(work1var_mgbf(nz,nxloc,nyloc)) + allocate(work1var_mgbf(nz3d,nxloc,nyloc)) work1var_mgbf=0.0 do ivar=1,nvar lev1=varvlev_index(ivar,1) @@ -337,15 +364,34 @@ subroutine multiply(self, fields) do isize=1,fields%size() afield=fields%field(isize) !clttodo + write(6,*)'thinkdeb in mgbf_covariance_mod.f90 rank is ',afield%rank() if(afield%rank() == 2) then call afield%data(ptr_2d) nz=afield%levels() lev1=varvlev_index(isize,1) - ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + write(6,*)'thinkdeb right2503 ',lev1,nz3d + if(nz.gt.1) then + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + if(self%intstate%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + write(6,*)'thinkdebxxx right2502, lev? ',lev1+nz3d-1 + + ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + + endif + endif + elseif (afield%rank() == 3) then call afield%data(ptr_3d) nz=afield%levels() write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo + call flush(6) stop @@ -353,6 +399,7 @@ subroutine multiply(self, fields) ilev=ilev+nz else write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + call flush(6) stop endif enddo @@ -364,6 +411,7 @@ subroutine multiply(self, fields) deallocate(work_mgbf) deallocate(work_mgbf2) deallocate(work2d_mgbf) + deallocate(rnormalization) deallocate( varvlev_index) end subroutine multiply diff --git a/src/saber/mgbf/covariance/tlei_tools_linkedlist_implementation.fypp b/src/saber/mgbf/covariance/tlei_tools_linkedlist_implementation.fypp old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/covariance/tlei_tools_linkedlist_interface.fypp b/src/saber/mgbf/covariance/tlei_tools_linkedlist_interface.fypp old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/CMakeLists.txt b/src/saber/mgbf/mgbf_lib/CMakeLists.txt old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil2.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil3.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/jp_pietc.f90 b/src/saber/mgbf/mgbf_lib/jp_pietc.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 b/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/jp_pkind.f90 b/src/saber/mgbf/mgbf_lib/jp_pkind.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/jp_pkind2.f90 b/src/saber/mgbf/mgbf_lib/jp_pkind2.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/jp_pmat.f90 b/src/saber/mgbf/mgbf_lib/jp_pmat.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/jp_pmat4.f90 b/src/saber/mgbf/mgbf_lib/jp_pmat4.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/mg_domain.f90 b/src/saber/mgbf/mgbf_lib/mg_domain.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 b/src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 old mode 100644 new mode 100755 index 8ce8539b1..6d104076d --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -75,9 +75,11 @@ module subroutine filtering_procedure(this,mg_filt,mg_filt_flag) case(2) call this%filtering_lin3 case(3) - call this%filtering_rad2_bkg +!clt call this%filtering_rad2_bkg + call this%filtering_rad2 case(4) - call this%filtering_lin2_bkg +!clt call this%filtering_lin2_bkg + call this%filtering_lin2 case(5) call this%filtering_fast_bkg case(6) @@ -437,6 +439,151 @@ module subroutine filtering_lin3(this) deallocate(JCOL) !----------------------------------------------------------------------- endsubroutine filtering_lin3 + module subroutine filtering_rad2(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure 2: ! +! ! +! - Multiple of 2D and 3D variables ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 2d radial filter + 1d vertical 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,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. +allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. +allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. +allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. + + + +!==================== Adjoint (Conservative step) ====================== + +!*** +!*** 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( bfiltT_tim) + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + call this%rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) + call this%stack_to_composite(VALL,VM2D,VM3D) + + if(l_hgen) then + call this%rbetaT(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + call this%stack_to_composite(HALL,HM2D,HM3D) + endif + + call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + + write(6,*)'thinkdeb33 2 ', km,im,jm,hx,hy + 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( bfiltT_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 (Step 7) +!*** + call btim( bfilt_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) + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Filtering +! + + call this%rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,VALL(:,:,:)) + call this%stack_to_composite(VALL,VM2D,VM3D) + if(this%l_hgen) then + call this%rbeta(km,hx,i0,im,hy,j0,jm,pasp2,ss2,HALL(:,:,:)) + call this%stack_to_composite(HALL,HM2D,HM3D) + endif + + call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + call this%barrierMPI + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + call etim( bfilt_tim) + +!*** +!*** Downsend, interpolate and add (Step 4) +!*** Then zero high generations (Step 5) +!*** + + 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_rad2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& module subroutine filtering_rad2_bkg(this) @@ -520,6 +667,184 @@ module subroutine filtering_rad2_bkg(this) endif !----------------------------------------------------------------------- endsubroutine filtering_rad2_bkg + module subroutine filtering_lin2(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure 5: ! +! ! +! - Multiple of 2D line filter ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 2d radial filter + 1d vertical filter +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this + +integer(i_kind) L,i,j +integer(i_kind) icol,iout,jout +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 +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" + +!---------------------------------------------------------------------- + +allocate(VM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; VM3D=0. +allocate(VM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; VM2D=0. +allocate(HM3D(km3,i0-hx:im+hx,j0-hy:jm+hy,lm)) ; HM3D=0. +allocate(HM2D(km2,i0-hx:im+hx,j0-hy:jm+hy )) ; HM2D=0. + + +!----------------------------------------------------------------------- + + +!==================== Adjoint (Conservative step) ====================== + +!*** +!*** Adjoint interpolate and upsend (Step 1) +!*** + + 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( bfiltT_tim) + + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Horizontal +! + + do icol=3,1,-1 + call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) + call this%bocoT_2d(VALL,km,im,jm,hx,hy) + enddo + + do icol=3,1,-1 + if(l_hgen) then + call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) + endif + write(6,*)'thinkdeb33 5 ', km,im,jm,hx,hy + call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + enddo +! +! Vertical +! + + call this%stack_to_composite(VALL,VM2D,VM3D) + call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) + + if(l_hgen) then + call this%stack_to_composite(HALL,HM2D,HM3D) + call this%sup_vrbeta1T(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + + write(6,*)'thinkdeb33 6 ', km,im,jm,hx,hy + call this%bocoT_2d(VALL,km,im,jm,hx,hy) + call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + call etim( bfiltT_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( bfilt_tim) + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! Horizontal +! + do icol=1,3 + call this%boco_2d(VALL,km,im,jm,hx,hy) + call dibeta(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VALL, ff, iout,jout) + enddo + + do icol=1,3 + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + if(l_hgen) then + call dibeta(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) + endif + enddo +! +! Vertical +! + write(6,*)'thinkdeb888 ' + 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 this%stack_to_composite(VALL,VM2D,VM3D) + call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) + + if(l_hgen) then + call this%stack_to_composite(HALL,HM2D,HM3D) + call this%sup_vrbeta1(km3,hx,hy,hz,im,jm,lm,pasp1,ss1,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + + + call this%barrierMPI +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + + call etim( bfilt_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_lin2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& module subroutine filtering_lin2_bkg(this) diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 old mode 100644 new mode 100755 index ce3cfecbb..01b637257 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -179,6 +179,7 @@ module mg_intstate procedure :: filtering_procedure procedure :: filtering_rad3,filtering_lin3 procedure :: filtering_rad2_bkg,filtering_lin2_bkg,filtering_fast_bkg + procedure :: filtering_rad2,filtering_lin2 procedure :: filtering_rad2_ens,filtering_lin2_ens,filtering_fast_ens procedure :: filtering_rad_highest procedure :: sup_vrbeta1T,sup_vrbeta1,sup_vrbeta3T,sup_vrbeta3 @@ -841,12 +842,18 @@ module subroutine filtering_rad3(this) module subroutine filtering_lin3(this) class(mg_intstate_type),target::this end subroutine + module subroutine filtering_rad2(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_lin2(this) + class(mg_intstate_type),target::this + end subroutine module subroutine filtering_fast_bkg(this) class(mg_intstate_type),target::this end subroutine diff --git a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 old mode 100644 new mode 100755 index 3dbf43d73..86b754e34 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -35,6 +35,7 @@ module mg_parameter use jp_pietc, only: u1 implicit none +integer(i_kind),parameter :: lm_max=200 type:: mg_parameter_type !----------------------------------------------------------------------- !*** @@ -138,6 +139,8 @@ module mg_parameter 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 +real(r_kind):: coef_normalization(lm_max)=1.0 !normalizaton coefficients + 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 @@ -488,6 +491,7 @@ subroutine init_mg_parameter(this,inputfilename) integer(i_kind):: lm_a ! number of vertical layers in analysis fields integer(i_kind):: lm ! number of vertical layers in filter grids +real(r_kind):: coef_normalization(lm_max)=1.0 !normalizaton coefficients 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=1 ! number of ensemble members @@ -511,7 +515,7 @@ subroutine init_mg_parameter(this,inputfilename) ,mg_weig1,mg_weig2,mg_weig3,mg_weig4 & ,hx,hy,hz,p & ,mgbf_line,mgbf_proc & - ,lm_a,lm & + ,lm_a,lm,coef_normalization & ,km2,km3 & ,n_ens & ,l_loc & @@ -547,6 +551,7 @@ subroutine init_mg_parameter(this,inputfilename) this%mgbf_proc=mgbf_proc this%lm_a=lm_a this%lm=lm + this%coef_normalization=coef_normalization this%km2=km2 this%km3=km3 this%n_ens=n_ens @@ -672,6 +677,7 @@ subroutine init_mg_parameter(this,inputfilename) if(this%nxm*this%nym<=1) then this%gm=gm_max endif + write(6,*)"thindkeb888 gm is ",this%gm !*** !*** Analysis grid diff --git a/src/saber/mgbf/mgbf_lib/mg_timers.f90 b/src/saber/mgbf/mgbf_lib/mg_timers.f90 old mode 100644 new mode 100755 index a05fc7c24..4d1438dbd --- a/src/saber/mgbf/mgbf_lib/mg_timers.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_timers.f90 @@ -57,6 +57,7 @@ module mg_timers type(timer),save,public :: hfiltT_tim type(timer),save,public :: vfiltT_tim type(timer),save,public :: vadv1_tim + type(timer),save,public :: bfilt_tim type(timer),save,public :: hfilt_tim type(timer),save,public :: vfilt_tim type(timer),save,public :: adv2_tim @@ -77,6 +78,7 @@ module mg_timers type(timer),save,public :: intp_tim type(timer),save,public :: bocoT_tim type(timer),save,public :: boco_tim + type(timer),save,public :: bfiltT_tim integer, parameter, public :: print_clock = 1, & print_cpu = 2, & diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/mgbf_kind.f90 b/src/saber/mgbf/mgbf_lib/mgbf_kind.f90 old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/type_intstat_locpointer.inc b/src/saber/mgbf/mgbf_lib/type_intstat_locpointer.inc old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/type_intstat_point2this.inc b/src/saber/mgbf/mgbf_lib/type_intstat_point2this.inc old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/type_parameter_locpointer.inc b/src/saber/mgbf/mgbf_lib/type_parameter_locpointer.inc old mode 100644 new mode 100755 diff --git a/src/saber/mgbf/mgbf_lib/type_parameter_point2this.inc b/src/saber/mgbf/mgbf_lib/type_parameter_point2this.inc old mode 100644 new mode 100755 diff --git a/src/saber/oops/Localization.h b/src/saber/oops/Localization.h index 1d77ad05a..aad971bd0 100644 --- a/src/saber/oops/Localization.h +++ b/src/saber/oops/Localization.h @@ -146,6 +146,7 @@ void Localization::multiply(Increment_ & dx) const { // fset4d[0].print(std::cout); #else + oops::Log::trace() << "Localization:multiply startingxxxold " << std::endl; // ATLAS fieldset to Increment_ dx.synchronizeFields(); #endif From 9b5bbc86bc3f81d11a546917194928f51f7845d2 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 1 Nov 2024 16:21:17 +0000 Subject: [PATCH 015/199] a fix in the initialization for the line filter --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 33 ++++++--- src/saber/mgbf/mgbf_lib/jp_pbfil.f90 | 2 + src/saber/mgbf/mgbf_lib/mg_entrymod.f90 | 1 + src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 4 +- src/saber/mgbf/mgbf_lib/mg_interpolate.f90 | 68 +++++++++++++++++++ src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 35 +++++++++- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 10 ++- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 49 ++++++++++++- 8 files changed, 182 insertions(+), 20 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 93ebc59f7..055a5dbdd 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -240,9 +240,13 @@ subroutine multiply(self, fields) nxloc=dim3d(2) nyloc=dim3d(3) nzloc=dim3d(1) - nz3d=self%intstate%lm + nz3d=self%intstate%lm_a nvar=fields%size() write(6,*)'thinkdeb l_2d is ',self%l_2dvar_last_vertical_level + call flush(6) + write(6,*)'thinkdeb nvar is ',nvar + call flush(6) + allocate( varvlev_index(nvar,3)) ilev=1 do isize=1,fields%size() @@ -310,6 +314,8 @@ subroutine multiply(self, fields) stop endif enddo + write(6,*)'thinkdeb333 nzloc is ',nzloc + call flush(6) do k=1,nzloc work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) @@ -325,38 +331,41 @@ subroutine multiply(self, fields) test_once=.false. close(iounit) endif - + write(6,*)'thinkdeb mfbf begin ',nvar + call flush(6) call self%intstate%anal_to_filt_allmap(work_mgbf) call self%intstate%filtering_procedure(self%intstate%mgbf_proc,1) !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) call self%intstate%filt_to_anal_allmap(work_mgbf2) write(6,*)"thinkdeb22 in covarian*mod.f90 l_for_localization ",self%intstate%l_for_localization + write(6,*)'thinkdeb mgbf after' + call flush(6) +!clt# work_mgbf=999.0 !thinkdeb for debug - if(.not. self%intstate%l_for_localization) then !clthinkdeb + if(.not. self%intstate%l_for_localization ) then !clthinkdebxxx work_mgbf=work_mgbf2 else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + write(6,*)'thinkdeb 333 work1var_mgbf.shape ',shape(work1var_mgbf) + write(6,*)'thinkdeb 3331 work_mgbf2.shape ',shape(work_mgbf2) + write(6,*)'thinkdeb 3331 work_mgbf.shape ',shape(work_mgbf) work1var_mgbf=0.0 + write(6,*)'thinkdeb 555 0 ',self%intstate%km_a_all do ivar=1,nvar lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) + write(6,*)'thinkdeb 555 is ',lev1,lev2, ' nz3d =',nz3d work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) enddo do ivar=1,nvar lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) + write(6,*)'thinkdeb 555 2 is ',lev1,lev2, ' nz3d =',nz3d work_mgbf(lev1:lev2,:,:)=work1var_mgbf enddo deallocate(work1var_mgbf) endif - iounit=20+myrank - if(test_once.and.1.gt.2) then - open(iounit,file=trim(fileoutput), status='replace',form="formatted") - write(iounit,*) work_mgbf - test_once=.false. - close(iounit) - endif do k=1,nzloc work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) enddo @@ -369,7 +378,7 @@ subroutine multiply(self, fields) call afield%data(ptr_2d) nz=afield%levels() lev1=varvlev_index(isize,1) - write(6,*)'thinkdeb right2503 ',lev1,nz3d + write(6,*)'thinkdeb right2503 ',lev1,nz3d,nz if(nz.gt.1) then ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) else @@ -407,6 +416,8 @@ subroutine multiply(self, fields) + write(6,*)'thinkdeb end of covariance multiply ' + call flush(6) deallocate(work_mgbf) deallocate(work_mgbf2) diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 index 725d4dbe2..b62a66951 100755 --- a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 @@ -159,6 +159,7 @@ module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [getlinesum] real(dp) :: s,rr,rrc,exx,x integer :: ix,gxl,gxm,gx !============================================================================= +!clt write(6,*)'thinkdebss Lx,MX = ',Lx, ' ',Mx do ix=Lx,Mx s=0 exx=el(1,1,ix)*this%rmom2_1 @@ -172,6 +173,7 @@ module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [getlinesum] s=s+rrc**this%p enddo ss(ix)=u1/s +!clt write(6,*)'thinkdebss is ',ss(ix) enddo end subroutine getlinesum1 !============================================================================= diff --git a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 index 8818337a6..84ee42217 100755 --- a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 @@ -97,6 +97,7 @@ module subroutine mg_initialize(this,inputfilename,obj_parameter) call this%def_mg_weights if(this%mgbf_line) then + write(6,*)'thinkdeb init_mg_line is called' call this%init_mg_line endif diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index 6d104076d..8b5f593a5 100755 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -78,8 +78,8 @@ module subroutine filtering_procedure(this,mg_filt,mg_filt_flag) !clt call this%filtering_rad2_bkg call this%filtering_rad2 case(4) -!clt call this%filtering_lin2_bkg - call this%filtering_lin2 + call this%filtering_lin2_bkg +!clt call this%filtering_lin2 case(5) call this%filtering_fast_bkg case(6) diff --git a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 index 59c2a8cc3..96db5915a 100755 --- a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 @@ -967,6 +967,74 @@ module subroutine l_vertical_direct_spec2 & enddo !----------------------------------------------------------------------- endsubroutine l_vertical_direct_spec2 +module subroutine test_vertical_interpolation_adj(this, km_in, nm_in, imin, imax, jmin, jmax, adj_F, adj_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), intent(inout) :: adj_F(1:km_in, imin:imax, jmin:jmax) + real(r_kind), intent(in) :: adj_W(1:nm_in, imin:imax, jmin:jmax) + ! Local variables + integer(i_kind) :: i, j, n, k + real(r_kind) :: s, alpha + !----------------------------------------------------------------------- + ! Initialize adj_F to zero + adj_F(:, :, :) = 0.0_r_kind + + ! Loop over spatial dimensions + do i = imin, imax ! Loop over X dimension + do j = jmin, jmax ! Loop over Y dimension + ! Loop over fine vertical levels n + do n = 1, nm_in + ! Compute the fractional position in the coarse grid + s = real(n - 1) * real(km_in - 1) / real(nm_in - 1) + k = int(s) + 1 ! Coarse level index + if (k >= km_in) then + k = km_in - 1 + s = real(km_in - 1) + end if + alpha = s - real(k - 1) + ! Accumulate adjoints back to adj_F + adj_F(k, i, j) = adj_F(k, i, j) + (1.0_r_kind - alpha) * adj_W(n, i, j) + adj_F(k + 1, i, j) = adj_F(k + 1, i, j) + alpha * adj_W(n, i, j) + end do + end do + end do + !----------------------------------------------------------------------- +end subroutine test_vertical_interpolation_adj +module subroutine test_vertical_interpolation(this, km_in, nm_in, imin, imax, jmin, jmax, 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), intent(in) :: F(1:km_in, imin:imax, jmin:jmax) + real(r_kind), intent(out) :: W(1:nm_in, imin:imax, jmin:jmax) + ! Local variables + integer(i_kind) :: i, j, n, k + real(r_kind) :: s, alpha + !----------------------------------------------------------------------- + ! Loop over spatial dimensions + do i = imin, imax ! Loop over X dimension + do j = jmin, jmax ! Loop over Y dimension + ! Loop over fine vertical levels n + do n = 1, nm_in + ! Compute the fractional position in the coarse grid + s = real(n - 1) * real(km_in - 1) / real(nm_in - 1) + k = int(s) + 1 ! Coarse level index + if (k >= km_in) then + k = km_in - 1 + s = real(km_in - 1) + end if + alpha = s - real(k - 1) + ! Perform linear interpolation + W(n, i, j) = (1.0_r_kind - alpha) * F(k, i, j) + alpha * F(k + 1, i, j) + end do + end do + end do + !----------------------------------------------------------------------- +end subroutine test_vertical_interpolation + + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ end submodule mg_interpolate diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 01b637257..7fe025dbe 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -122,6 +122,7 @@ module mg_intstate procedure :: lsqr_mg_coef,lwq_vertical_coef procedure :: lwq_vertical_direct,lwq_vertical_adjoint procedure :: lwq_vertical_direct_spec,lwq_vertical_adjoint_spec + procedure :: test_vertical_interpolation, test_vertical_interpolation_adj 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 @@ -242,6 +243,9 @@ module subroutine lwq_vertical_direct_spec & 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 @@ -336,6 +340,24 @@ module subroutine lin_adjoint_offset & 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 + module subroutine test_vertical_interpolation & + (this, km_in, nm_in, imin, imax, jmin, jmax, 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), intent(in) :: F(1:km_in, imin:imax, jmin:jmax) + real(r_kind), intent(out) :: W(1:nm_in, imin:imax, jmin:jmax) + end subroutine + module subroutine test_vertical_interpolation_adj & + (this, km_in, nm_in, imin, imax, jmin, jmax, adj_F, adj_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), intent(inout) :: adj_F(1:km_in, imin:imax, jmin:jmax) + real(r_kind), intent(in) :: adj_W(1:nm_in, imin:imax, jmin:jmax) + end subroutine !from mg_bocos.f90 module subroutine boco_2d_g1 & (this,W,km_in,im_in,jm_in,nbx,nby) @@ -1236,7 +1258,7 @@ subroutine def_mg_weights(this) end do -if(.not.this%mgbf_line) then +!cltorg if(.not.this%mgbf_line) then if(this%nxm*this%nym>1) then if(this%l_loc) then if(this%l_vertical_filter) then @@ -1274,6 +1296,7 @@ subroutine def_mg_weights(this) this%ssy=this%ssy/sqrt(this%VALL(1,1,this%jm/2)) this%VALL(1,1,:)=0. else + write(6,*)"thinkdeb tothink" 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) @@ -1282,8 +1305,15 @@ subroutine def_mg_weights(this) 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) +! this%ssx=1.0 !cltthinkdeb +! this%ssy=1.0 !cltthinkdeb +!clt the following still fail +! this%ss1=0.0 !cltthinkdeb +! this%ss2=0.0 !cltthinkdeb +! this%ss3=0.0 !cltthinkdeb end if else + write(6,*)"thinkdeb tothink2" 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,& @@ -1298,7 +1328,7 @@ subroutine def_mg_weights(this) 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 +!cltorg end if !----------------------------------------------------------------------- endsubroutine def_mg_weights @@ -1314,7 +1344,6 @@ subroutine init_mg_line(this) ! ! !*********************************************************************** !----------------------------------------------------------------------- - do j=1,this%jm do i=1,this%im call t22_to_3(this%pasp2(:,:,i,j),this%vpasp2(:,i,j)) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 86b754e34..0355ed0d5 100755 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -140,6 +140,8 @@ module mg_parameter integer(i_kind):: lm_a ! number of vertical layers in analysis fields integer(i_kind):: lm ! number of vertical layers in filter grids real(r_kind):: coef_normalization(lm_max)=1.0 !normalizaton coefficients +real(r_kind):: coef_normalization_const=-9999.0 ! constant, if set, this contant will be + ! assigned to all elements of coef_normalization integer(i_kind):: km2 ! number of 2d variables for filtering integer(i_kind):: km3 ! number of 3d variables for filtering @@ -492,6 +494,7 @@ subroutine init_mg_parameter(this,inputfilename) integer(i_kind):: lm_a ! number of vertical layers in analysis fields integer(i_kind):: lm ! number of vertical layers in filter grids real(r_kind):: coef_normalization(lm_max)=1.0 !normalizaton coefficients +real(r_kind):: coef_normalization_const=-9999.0 ! constant, if set, this contant will be 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=1 ! number of ensemble members @@ -516,6 +519,7 @@ subroutine init_mg_parameter(this,inputfilename) ,hx,hy,hz,p & ,mgbf_line,mgbf_proc & ,lm_a,lm,coef_normalization & + ,coef_normalization_const & ,km2,km3 & ,n_ens & ,l_loc & @@ -529,7 +533,7 @@ subroutine init_mg_parameter(this,inputfilename) ,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) @@ -551,6 +555,10 @@ subroutine init_mg_parameter(this,inputfilename) this%mgbf_proc=mgbf_proc this%lm_a=lm_a this%lm=lm + + if (coef_normalization_const >0 ) then ! constant, if set, this contant will be + coef_normalization=coef_normalization_const + endif this%coef_normalization=coef_normalization this%km2=km2 this%km3=km3 diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index 8e2531ff4..c1d7b1a83 100755 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -113,6 +113,7 @@ module subroutine anal_to_filt_all(this,WORKA) real(r_kind),allocatable,dimension(:,:,:,:):: F3D real(r_kind),allocatable,dimension(:,:,:):: WORK integer(i_kind):: L +integer(i_kind):: ivar,lev1_a,lev2_a,lev1_f,lev2_f include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" include "type_parameter_point2this.inc" @@ -144,8 +145,28 @@ module subroutine anal_to_filt_all(this,WORKA) call this%C2S_ens(F3D,WORK,1,nm,1,mm,lm,km,km_all) endif !2.gt.3 -!cltorg call this%anal_to_filt(WORK) - call this%anal_to_filt(WORKA) + if(lm_a>lm) then + do ivar=1,this%km2 !2dvar is directly passed + work(ivar,:,:)=worka(ivar,:,:) + enddo + + do ivar=1,this%km3 + lev1_a=this%km2+1+(ivar-1)*this%lm_a + lev1_f=this%km2+1+(ivar-1)*this%lm + lev2_a=lev1_a+this%lm_a-1 + lev2_f=lev1_f+this%lm-1 + +!clt call this%lwq_vertical_adjoint(nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) +!cltorg call this%lwq_vertical_adjoint(this%lm_a,this%lm,1,nm,1,mm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref, & +!clt worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) + call this%test_vertical_interpolation_adj(this%lm,this%lm_a,1,nm,1,mm, work(lev1_f:lev2_f,:,:), & + worka(lev1_a:lev2_a,:,:)) + enddo + else + work=worka + endif +!clt call this%anal_to_filt(WORKA) + call this%anal_to_filt(WORK) call etim(an2filt_tim) deallocate(A3D,F3D,WORK) @@ -166,12 +187,34 @@ module subroutine filt_to_anal_all(this,WORKA) real(r_kind),allocatable,dimension(:,:,:,:):: F3D real(r_kind),allocatable,dimension(:,:,:):: WORK integer(i_kind):: L +integer(i_kind)::ivar, lev1_a,lev2_a,lev1_f,lev2_f + include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !---------------------------------------------------------------------- - call this%filt_to_anal(WORKA) !cltadded + allocate(WORK(km_all,1:nm,1:mm)) + call this%filt_to_anal(WORK) !cltadded + if(lm_a>lm) then + do ivar=1,this%km2 !2dvar is directly passed + worka(ivar,:,:)=work(ivar,:,:) + enddo + + do ivar=1,this%km3 + lev1_a=this%km2+1+(ivar-1)*this%lm_a + lev1_f=this%km2+1+(ivar-1)*this%lm + lev2_a=lev1_a+this%lm_a-1 + lev2_f=lev1_f+this%lm-1 +!clt call this%lwq_vertical_direct(this%lm,this%lm_a,1,nm,1,mm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref, & +!clt work(lev1_f:lev2_f,:,:),worka(lev1_a:lev2_a,:,:)) + call this%test_vertical_interpolation(this%lm,this%lm_a,1,nm,1,mm, work(lev1_f:lev2_f,:,:), & + worka(lev1_a:lev2_a,:,:)) + enddo + else + worka=work + endif + deallocate(WORK) if (2.gt.3) then ! clt allocate(WORK(km_all,1:nm,1:mm)) allocate(A3D(km3_all,1:nm,1:mm,lm_a)) From f394467e371b62e635b4905e6d6278e94194cebb Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 26 Nov 2024 21:10:52 +0000 Subject: [PATCH 016/199] added the function to run on reduced vertical levels --- src/saber/mgbf/mgbf_lib/mg_interpolate.f90 | 198 ++++++++++++++++++++- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 35 ++++ src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 17 +- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 39 ++-- 4 files changed, 271 insertions(+), 18 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 index 96db5915a..23464cb49 100755 --- a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 @@ -642,6 +642,50 @@ module subroutine lsqr_direct_offset & enddo !----------------------------------------------------------------------- endsubroutine lsqr_direct_offset +module subroutine lsqr_direct_offset_add& +!*********************************************************************** +! ! +! 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 ! +!clt from lsqr_direct_offset, for l_anal_sub_of_filt=.true. +! ! +!*********************************************************************** +(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_add !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& module subroutine lsqr_adjoint_offset & @@ -700,6 +744,64 @@ module subroutine lsqr_adjoint_offset & enddo !----------------------------------------------------------------------- endsubroutine lsqr_adjoint_offset +module subroutine lsqr_adjoint_offset_add & +!clt to be finished +!*********************************************************************** +! ! +! 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 - ! +!clt from lsqr_adjoint_offset, for l_anal_sub_of_filt=.true. +! ! +!*********************************************************************** +(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,this%mm-1 + 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,this%nm-1 + 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_add !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& module subroutine quad_direct_offset & @@ -839,6 +941,49 @@ module subroutine lin_direct_offset & enddo !----------------------------------------------------------------------- endsubroutine lin_direct_offset +module subroutine lin_direct_offset_add & +!clt to be finished +!*********************************************************************** +! ! +! 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 ! +!clt copied from lin_driect_offset, when l_anal_filt =.true +! ! +! - 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,this%nm-1 + 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,this%mm-1 + 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_add + !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& module subroutine lin_adjoint_offset & @@ -864,7 +1009,7 @@ module subroutine lin_adjoint_offset & integer(i_kind):: i,j,n,m,l,k real(r_kind):: c0,c1 !----------------------------------------------------------------------- - V_out(:,:,:)=0. + V_out(:,:,:)=0. VX(:,:,:)=0. do m=1,this%mm @@ -890,6 +1035,57 @@ module subroutine lin_adjoint_offset & enddo !----------------------------------------------------------------------- endsubroutine lin_adjoint_offset +module subroutine lin_adjoint_offset_add & +!*********************************************************************** +! ! +! 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 - ! +!ctl modified from lin_adjoint_offset, when analysis grids are part of +!clt the filtering grids, only halo points are to be defined +! ! +!*********************************************************************** +(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 +!----------------------------------------------------------------------- + + VX(:,:,:)=0. + + do m=1,this%mm,this%mm-1 + 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,this%nm-1 + 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_add !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& module subroutine l_vertical_adjoint_spec2 & diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 7fe025dbe..785cb71f4 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -128,6 +128,7 @@ module mg_intstate procedure :: lsqr_direct_offset,lsqr_adjoint_offset procedure :: quad_direct_offset,quad_adjoint_offset procedure :: lin_direct_offset,lin_adjoint_offset + procedure :: lin_direct_offset_add,lin_adjoint_offset_add !from mg_bocos.f90 generic :: boco_2d => boco_2d_g1,boco_2d_gh procedure :: boco_2d_g1,boco_2d_gh @@ -297,6 +298,15 @@ module subroutine lsqr_direct_offset & 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_direct_offset_add & + (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 @@ -306,6 +316,15 @@ module subroutine lsqr_adjoint_offset & 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 lsqr_adjoint_offset_add & + (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 @@ -332,6 +351,14 @@ module subroutine lin_direct_offset & 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_direct_offset_add & + (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 @@ -340,6 +367,14 @@ module subroutine lin_adjoint_offset & 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 + module subroutine lin_adjoint_offset_add & + (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 module subroutine test_vertical_interpolation & (this, km_in, nm_in, imin, imax, jmin, jmax, F, W) implicit none diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 0355ed0d5..241ed69f1 100755 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -158,6 +158,7 @@ module mg_parameter logical :: l_quad_horizontal=.false. ! 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 +logical :: l_anal_sub_of_filt ! true : analysis grids and filtering grids are the same excpet for later has boundary points integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) integer(i_kind):: km_4 integer(i_kind):: km_16 @@ -505,6 +506,7 @@ subroutine init_mg_parameter(this,inputfilename) logical :: l_quad_horizontal=.false. ! logical flag for quadratic interpolation in horizontal logical :: l_new_map=.false. ! logical flag for new mapping between analysis and filter grid logical :: l_vertical_filter=.true. ! logical flag for vertical filtering +logical :: l_anal_sub_of_filt=.false. integer(i_kind):: gm_max=4 !clt by defaul ! Global number of data on Analysis grid @@ -529,7 +531,8 @@ subroutine init_mg_parameter(this,inputfilename) ,l_quad_horizontal & ,l_new_map & ,l_vertical_filter & - ,l_for_localization,ldelta,lquart,lhelm & + ,l_anal_sub_of_filt & + ,l_for_localization,ldelta,lquart,lhelm & ,gm_max & ,nm0,mm0 & ,nxPE,nyPE,im_filt,jm_filt @@ -570,6 +573,7 @@ subroutine init_mg_parameter(this,inputfilename) this%l_quad_horizontal=l_quad_horizontal this%l_new_map=l_new_map this%l_vertical_filter=l_vertical_filter + this%l_anal_sub_of_filt=l_anal_sub_of_filt this%l_for_localization=l_for_localization write(6,*)'thinkdeb22 this%l_for_localization ',this%l_for_localization this%ldelta=ldelta @@ -581,7 +585,6 @@ subroutine init_mg_parameter(this,inputfilename) this%nyPE=nyPE this%im_filt=im_filt this%jm_filt=jm_filt - this%nxm = nxPE this%nym = nyPE @@ -704,6 +707,16 @@ subroutine init_mg_parameter(this,inputfilename) write(6,*)'thinkdeb mg_parameter nm0,nxm',this%nm0,this%nxm this%nm = this%nm0/this%nxm this%mm = this%mm0/this%nym + if(this%l_anal_sub_of_filt ) then + if(this%im_filt.ne.this%nm.or.this%jm_filt.ne.this%mm) then + write(6,*)'l_anal_sub_of_filter is true but the numbers of analysis/filtering grids are wrong, stop' + stop + endif + if(.not. l_lin_horizontal) then + write(6,*)'l_anal_sub_of_filter is true ,now, only work for l_lin_horizontal=.ture. stop' + stop + endif + endif !*** !*** Filter grid diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index c1d7b1a83..a11bd4aa6 100755 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -481,20 +481,25 @@ module subroutine anal_to_filt(this,WORK) VALL=0. !clttothink !clttothink - 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 - + if(.not.this%l_anal_sub_of_filt) then + 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 + else + VALL(1:km_all,1:im,1:jm)=WORK + call this%lin_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 !*** @@ -537,7 +542,10 @@ module subroutine filt_to_anal(this,WORK) !*** call this%boco_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) - + if(this%l_anal_sub_of_filt) then + WORK(:,:,:)=VALL(:,1:im,1:jm) + call this%lin_direct_offset_add(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) + else 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 @@ -545,6 +553,7 @@ module subroutine filt_to_anal(this,WORK) else call this%lsqr_direct_offset(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) endif + endif !---------------------------------------------------------------------- endsubroutine filt_to_anal From fcbd1c477098c5dc0608af504a68c2a71429402b Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 17 Dec 2024 16:15:05 +0000 Subject: [PATCH 017/199] added pieices for l_anal_sub_of_filt to work --- src/saber/mgbf/mgbf_lib/mg_interpolate.f90 | 11 +++++++++-- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 4 ++-- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 7 +++++-- 3 files changed, 16 insertions(+), 6 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 index 23464cb49..a1eca3d8b 100755 --- a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 @@ -770,7 +770,7 @@ module subroutine lsqr_adjoint_offset_add & !----------------------------------------------------------------------- V_out(:,:,:)=0. VX(:,:,:)=0. - +if(1.gt.2) then do m=1,this%mm,this%mm-1 j = this%jref(m) c0 = this%cy0(m) @@ -800,6 +800,8 @@ module subroutine lsqr_adjoint_offset_add & V_out(:,i+3,j) = V_out(:,i+3,j)+vxk(:)*c3 enddo enddo +endif + V_out(:,1: this%im,1:this%jm)= V_out(:,1: this%im,1:this%jm)+W !----------------------------------------------------------------------- endsubroutine lsqr_adjoint_offset_add @@ -964,6 +966,7 @@ module subroutine lin_direct_offset_add & integer(i_kind):: i,j,n,m real(r_kind),dimension(km_in):: v0,v1 !----------------------------------------------------------------------- +if (1.gt.2 ) then do n=1,this%nm,this%nm-1 i = this%irefL(n) do j=1-jbm,this%jm+jbm @@ -981,6 +984,8 @@ module subroutine lin_direct_offset_add & W(:,n,m) = this%Ly0(m)*v0(:)+this%Ly1(m)*v1(:) enddo enddo +end if ! 1>2 + W=V_in(:,1: this%im,1:this%jm) !----------------------------------------------------------------------- endsubroutine lin_direct_offset_add @@ -1062,7 +1067,7 @@ module subroutine lin_adjoint_offset_add & !----------------------------------------------------------------------- VX(:,:,:)=0. - +if(1.gt.2) then do m=1,this%mm,this%mm-1 j = this%jrefL(m) c0 = this%Ly0(m) @@ -1084,6 +1089,8 @@ module subroutine lin_adjoint_offset_add & V_out(:,i+1,j) = V_out(:,i+1,j)+vxk(:)*c1 enddo enddo +endif + V_out(:,1: this%im,1:this%jm)= V_out(:,1: this%im,1:this%jm)+W !----------------------------------------------------------------------- endsubroutine lin_adjoint_offset_add diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 241ed69f1..6de8a04c3 100755 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -712,8 +712,8 @@ subroutine init_mg_parameter(this,inputfilename) write(6,*)'l_anal_sub_of_filter is true but the numbers of analysis/filtering grids are wrong, stop' stop endif - if(.not. l_lin_horizontal) then - write(6,*)'l_anal_sub_of_filter is true ,now, only work for l_lin_horizontal=.ture. stop' + if(l_lin_horizontal.or.l_quad_horizontal) then + write(6,*)'l_anal_sub_of_filter is true,now, only work for lsqr, stop' stop endif endif diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index a11bd4aa6..db2529ef0 100755 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -496,8 +496,10 @@ module subroutine anal_to_filt(this,WORK) call this%lsqr_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm) endif else + ibm=3 + jbm=3 VALL(1:km_all,1:im,1:jm)=WORK - call this%lin_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm) + !clt call this%lin_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm) endif !*** @@ -543,8 +545,9 @@ module subroutine filt_to_anal(this,WORK) call this%boco_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) if(this%l_anal_sub_of_filt) then + write(6,*)'thinkdeb555 l_anl_sub_of ', this%l_anal_sub_of_filt WORK(:,:,:)=VALL(:,1:im,1:jm) - call this%lin_direct_offset_add(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) +!cltorg call this%lin_direct_offset_add(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) else 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) From f3865f59341489552c49a20288b2f02f966cd9d7 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 2 Jan 2025 12:59:37 +0000 Subject: [PATCH 018/199] some minor changes --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 23 ------------------- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 6 ----- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 6 ----- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 1 - 4 files changed, 36 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 055a5dbdd..f6a520ff2 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -242,10 +242,6 @@ subroutine multiply(self, fields) nzloc=dim3d(1) nz3d=self%intstate%lm_a nvar=fields%size() - write(6,*)'thinkdeb l_2d is ',self%l_2dvar_last_vertical_level - call flush(6) - write(6,*)'thinkdeb nvar is ',nvar - call flush(6) allocate( varvlev_index(nvar,3)) ilev=1 @@ -258,7 +254,6 @@ subroutine multiply(self, fields) if(nz == 1) then if(self%intstate%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - write(6,*)'thinkdebxxx right250 ',ilev+nz3d-1 work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d else work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d @@ -314,8 +309,6 @@ subroutine multiply(self, fields) stop endif enddo - write(6,*)'thinkdeb333 nzloc is ',nzloc - call flush(6) do k=1,nzloc work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) @@ -331,37 +324,26 @@ subroutine multiply(self, fields) test_once=.false. close(iounit) endif - write(6,*)'thinkdeb mfbf begin ',nvar - call flush(6) call self%intstate%anal_to_filt_allmap(work_mgbf) call self%intstate%filtering_procedure(self%intstate%mgbf_proc,1) !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) call self%intstate%filt_to_anal_allmap(work_mgbf2) - write(6,*)"thinkdeb22 in covarian*mod.f90 l_for_localization ",self%intstate%l_for_localization - write(6,*)'thinkdeb mgbf after' - call flush(6) !clt# work_mgbf=999.0 !thinkdeb for debug if(.not. self%intstate%l_for_localization ) then !clthinkdebxxx work_mgbf=work_mgbf2 else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - write(6,*)'thinkdeb 333 work1var_mgbf.shape ',shape(work1var_mgbf) - write(6,*)'thinkdeb 3331 work_mgbf2.shape ',shape(work_mgbf2) - write(6,*)'thinkdeb 3331 work_mgbf.shape ',shape(work_mgbf) work1var_mgbf=0.0 - write(6,*)'thinkdeb 555 0 ',self%intstate%km_a_all do ivar=1,nvar lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) - write(6,*)'thinkdeb 555 is ',lev1,lev2, ' nz3d =',nz3d work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) enddo do ivar=1,nvar lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) - write(6,*)'thinkdeb 555 2 is ',lev1,lev2, ' nz3d =',nz3d work_mgbf(lev1:lev2,:,:)=work1var_mgbf enddo deallocate(work1var_mgbf) @@ -373,18 +355,15 @@ subroutine multiply(self, fields) do isize=1,fields%size() afield=fields%field(isize) !clttodo - write(6,*)'thinkdeb in mgbf_covariance_mod.f90 rank is ',afield%rank() if(afield%rank() == 2) then call afield%data(ptr_2d) nz=afield%levels() lev1=varvlev_index(isize,1) - write(6,*)'thinkdeb right2503 ',lev1,nz3d,nz if(nz.gt.1) then ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) else if(self%intstate%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - write(6,*)'thinkdebxxx right2502, lev? ',lev1+nz3d-1 ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) else @@ -416,8 +395,6 @@ subroutine multiply(self, fields) - write(6,*)'thinkdeb end of covariance multiply ' - call flush(6) deallocate(work_mgbf) deallocate(work_mgbf2) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 785cb71f4..2854b08ff 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1082,18 +1082,14 @@ subroutine allocate_mg_intstate(this) implicit none class(mg_intstate_type),target::this -write(6,*)"thinkdeb in allocate_mg_intstate ",this%l_loc 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 -write(6,*)"thinkdeb in allocate_mg_intstate hx,km3 ",this%km_all,this%hx,this%im,this%hy,this%jm,this%lm -call flush(6) allocate(this%V(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm)) ; this%V=0. -write(6,*)'thinkdeb VALL dimension ',this%km_all,1-this%hx,' ',this%im+this%hx,' ',1-this%hy, ' ',this%jm+this%hy 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. @@ -1331,7 +1327,6 @@ subroutine def_mg_weights(this) this%ssy=this%ssy/sqrt(this%VALL(1,1,this%jm/2)) this%VALL(1,1,:)=0. else - write(6,*)"thinkdeb tothink" 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) @@ -1348,7 +1343,6 @@ subroutine def_mg_weights(this) ! this%ss3=0.0 !cltthinkdeb end if else - write(6,*)"thinkdeb tothink2" 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,& diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 6de8a04c3..06f74e6d5 100755 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -575,7 +575,6 @@ subroutine init_mg_parameter(this,inputfilename) this%l_vertical_filter=l_vertical_filter this%l_anal_sub_of_filt=l_anal_sub_of_filt this%l_for_localization=l_for_localization - write(6,*)'thinkdeb22 this%l_for_localization ',this%l_for_localization this%ldelta=ldelta this%lquart=lquart this%lhelm=lhelm @@ -659,13 +658,10 @@ subroutine init_mg_parameter(this,inputfilename) ! this%km_a = this%km2+this%lm_a*this%km3 - write(6,*)'thinkdeb mg_parameter.f90 km2,lm,km3 ',this%km2,' ',this%lm ,' ',this%km3 this%km = this%km2+this%lm *this%km3 - write(6,*)'thinkdeb mg_parameter.f90 km ',this%km,' ',this%km_a this%km_a_all = this%km_a * this%n_ens this%km_all = this%km * this%n_ens - write(6,*)'thinkdeb mg_parameter.f90 km_all ',this%km_all,' ',this%n_ens this%km2_all = this%km2 * this%n_ens this%km3_all = this%km3 * this%n_ens @@ -704,7 +700,6 @@ subroutine init_mg_parameter(this,inputfilename) ! ! Number of grid points on the analysis grid after padding ! - write(6,*)'thinkdeb mg_parameter nm0,nxm',this%nm0,this%nxm this%nm = this%nm0/this%nxm this%mm = this%mm0/this%nym if(this%l_anal_sub_of_filt ) then @@ -886,7 +881,6 @@ subroutine init_mg_parameter(this,inputfilename) this%imL=this%im/2 this%jmL=this%jm/2 - write(6,*)'thinkdebzzz in mp_para imL/jmL ',this%imL, ' ',this%jmL this%imH=this%im0(this%gm) this%jmH=this%jm0(this%gm) diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index db2529ef0..3efd7c1f2 100755 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -545,7 +545,6 @@ module subroutine filt_to_anal(this,WORK) call this%boco_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) if(this%l_anal_sub_of_filt) then - write(6,*)'thinkdeb555 l_anl_sub_of ', this%l_anal_sub_of_filt WORK(:,:,:)=VALL(:,1:im,1:jm) !cltorg call this%lin_direct_offset_add(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) else From ec989b6b5e380e3f61875076830d2fb6c6bc0db4 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sun, 12 Jan 2025 15:32:23 +0000 Subject: [PATCH 019/199] changes for use of mg_timer --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 16 +++ src/saber/mgbf/mgbf_lib/mg_timers.f90 | 130 +++++++++++------- 2 files changed, 100 insertions(+), 46 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index f6a520ff2..5bee167b1 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -21,6 +21,7 @@ module mgbf_covariance_mod ! saber !clt use mgbf_grid_mod, only: mgbf_grid use mg_intstate , only: mg_intstate_type +use mg_timers implicit none private @@ -115,6 +116,7 @@ subroutine delete(self) ! Locals !clt //if (.not. self%noMGBF) then + call print_mg_timers("mg_timer_output",999,self%rank) call self%intstate%mg_finalize() !clt endif @@ -204,10 +206,13 @@ subroutine multiply(self, fields) character(len=4) :: str_rank + !clt now noly consider t ! afield = fields%field('air_temperature') ! call afield%data(t) !*** From the analysis to first generation of filter grid + call btim(mg_multiply_time) + call btim(mg_preprocess_time) if(self%intstate%l_for_localization .and. self%intstate%km2) then write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & & "in which, the first level contains the 2d variables and others zeros " @@ -324,13 +329,22 @@ subroutine multiply(self, fields) test_once=.false. close(iounit) endif + call etim(mg_preprocess_time) + + call btim(mg_anal_to_filt_time) call self%intstate%anal_to_filt_allmap(work_mgbf) + call etim(mg_anal_to_filt_time) + call btim(mg_filtering_time) call self%intstate%filtering_procedure(self%intstate%mgbf_proc,1) + call btim(mg_filtering_time) !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) + call btim(mg_filt_to_anal_time) call self%intstate%filt_to_anal_allmap(work_mgbf2) + call etim(mg_filt_to_anal_time) !clt# work_mgbf=999.0 !thinkdeb for debug + call btim(mg_postprocess_time) if(.not. self%intstate%l_for_localization ) then !clthinkdebxxx work_mgbf=work_mgbf2 else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures @@ -392,6 +406,7 @@ subroutine multiply(self, fields) endif enddo + call etim(mg_postprocess_time) @@ -401,6 +416,7 @@ subroutine multiply(self, fields) deallocate(work2d_mgbf) deallocate(rnormalization) deallocate( varvlev_index) + call etim(mg_multiply_time) end subroutine multiply diff --git a/src/saber/mgbf/mgbf_lib/mg_timers.f90 b/src/saber/mgbf/mgbf_lib/mg_timers.f90 index 4d1438dbd..39df6343e 100755 --- a/src/saber/mgbf/mgbf_lib/mg_timers.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_timers.f90 @@ -79,6 +79,12 @@ module mg_timers type(timer),save,public :: bocoT_tim type(timer),save,public :: boco_tim type(timer),save,public :: bfiltT_tim + type(timer),save,public :: mg_multiply_time + type(timer),save,public :: mg_preprocess_time + type(timer),save,public :: mg_postprocess_time + type(timer),save,public :: mg_anal_to_filt_time + type(timer),save,public :: mg_filt_to_anal_time + type(timer),save,public :: mg_filtering_time integer, parameter, public :: print_clock = 1, & print_cpu = 2, & @@ -92,9 +98,11 @@ subroutine btim(t) implicit none type(timer), intent(inout) :: t - if (t%running) then - write(0,*)'btim: timer is already running' - STOP + if (.not.t%running) then + t%time_clock = 0 + t%time_cpu = 0 +! write(0,*)'btim: timer is already running' +! STOP end if t%running = .true. @@ -119,8 +127,8 @@ subroutine etim(t) 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 +!clt noneed t%start_clock = 0.0 +!clt noneed t%start_cpu = 0.0 endsubroutine etim !----------------------------------------------------------------------- @@ -136,16 +144,21 @@ subroutine print_mg_timers(filename, print_type,mype) integer :: ierr integer(kind=MPI_OFFSET_KIND) :: disp integer, dimension(MPI_STATUS_SIZE) :: stat - character(len=1024) :: buffer, header - integer :: bufsize - +! character(len=1024) :: header + character(len=1024) :: header1,header2 + character(len=1024) :: buffer1,buffer2,buffer3,buffer4 +! integer :: bufsize + integer :: bufsize1,bufsize2,bufsize3,bufsize4 + integer(i_kind):: num_ranks + call MPI_Comm_size(MPI_COMM_WORLD, num_ranks, ierr) 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, & +!clt buffer = ' ' + buffer1=' '; buffer2=' ';buffer3=' ';buffer4=' ' +!cltj# if ( print_type == print_clock ) then + write(buffer1,"(I6,18(',',F10.4))") mype, & init_tim%time_clock, & upsend_tim%time_clock, & dnsend_tim%time_clock, & @@ -157,50 +170,75 @@ subroutine print_mg_timers(filename, print_type,mype) 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 + total_tim%time_clock, & + mg_multiply_time%time_clock , & + mg_preprocess_time%time_clock , & + mg_anal_to_filt_time%time_clock, & + mg_filtering_time%time_clock, & + mg_filt_to_anal_time%time_clock, & + mg_postprocess_time%time_clock + write(buffer2,"(I6,18(',',F10.4))") mype, & + init_tim%time_cpu, & + upsend_tim%time_cpu, & + dnsend_tim%time_cpu, & + weight_tim%time_cpu, & + hfiltT_tim%time_cpu, & + hfilt_tim%time_cpu, & + filt2an_tim%time_cpu, & + aintp_tim%time_cpu, & + intp_tim%time_cpu, & + an2filt_tim%time_cpu, & + output_tim%time_cpu, & + total_tim%time_cpu, & + mg_multiply_time%time_cpu , & + mg_preprocess_time%time_cpu , & + mg_anal_to_filt_time%time_cpu, & + mg_filtering_time%time_cpu, & + mg_filt_to_anal_time%time_cpu, & + mg_postprocess_time%time_cpu +!clt# else if ( print_type == print_cpu ) then +! end if - bufsize = LEN(TRIM(buffer)) + 1 - buffer(bufsize:bufsize) = NEW_LINE(' ') + bufsize1 = LEN(TRIM(buffer1)) + 1 + bufsize2 = LEN(TRIM(buffer2)) + 1 + buffer1(bufsize1:bufsize1) = NEW_LINE(' ') + buffer2(bufsize2:bufsize2) = NEW_LINE(' ') - write(header,"(A6,14(',',A10))") "mype", & + write(header1,"(A6,18(',',A10))") "mype", & "init", & - "an2filt", & - "vfiltT", & "upsend", & - "hfiltT", & - "bocoT" , & + "dnsend", & "weight", & - "boco", & + "hfiltT", & "hfilt", & - "dnsend", & - "vfilt", & "filt2an", & - "output", & - "total" + "aintp" , & + "intp" , & + "an2filt" , & + "output", & + "total", & + "multiply", & + "preprocess", & + "anal_to_filt", & + "filtering", & + "filt_to_anal", & + "postprocess" - header(bufsize:bufsize) = NEW_LINE(' ') + header1(bufsize1:bufsize1) = NEW_LINE(' ') + if(sizeof(header1(1:1)) /= 1) then + write(6,*)" the one character is not using one byte as assumened ,stop" + stop + endif 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) + write(6,*)'thinkdebxxx bufsize 1/2 num_ranks is ',bufsize1, ' ',bufsize2,' ',num_ranks + if(mype==0) call MPI_File_write_at(fh, disp, header1, bufsize1, MPI_BYTE, stat, ierr) + disp =disp+ bufsize1 + disp = disp+(mype)*bufsize1 + call MPI_File_write_at(fh, disp, buffer1, bufsize1, MPI_BYTE, stat, ierr) + disp=bufsize1+num_ranks*bufsize1 + disp = disp+(mype)*bufsize2 + call MPI_File_write_at(fh, disp, buffer2, bufsize2, MPI_BYTE, stat, ierr) + call MPI_File_close(fh, ierr) From d6c74e8f18e097df102ba70d4ecfa5f7647ca778 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 13 Jan 2025 15:36:52 +0000 Subject: [PATCH 020/199] added more mg_timers --- src/saber/mgbf/covariance/MGBF_Covariance.h | 2 +- .../covariance/MGBF_Covariance.interface.F90 | 8 ++++- .../mgbf/covariance/mgbf_covariance_mod.f90 | 2 +- src/saber/mgbf/mgbf_lib/mg_timers.f90 | 34 ++++++++++++++----- 4 files changed, 35 insertions(+), 11 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index 45b1f7316..27eb7d544 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -124,7 +124,7 @@ MGBF_Covariance::MGBF_Covariance(const oops::GeometryData & geometryData, // Get active variables activeVars_ = getActiveVars(params, centralVars); -//clt util::Timer timer(classname(), "Covariance"); + util::Timer timer(classname(), "Covariance"); std::cout<<"thinkdebconfig0 ifhas -1 "< Date: Fri, 17 Jan 2025 15:39:41 +0000 Subject: [PATCH 021/199] changes for mg_timers to get accumulated time --- src/saber/mgbf/mgbf_lib/mg_timers.f90 | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_timers.f90 b/src/saber/mgbf/mgbf_lib/mg_timers.f90 index a21635bbc..3881bfb07 100755 --- a/src/saber/mgbf/mgbf_lib/mg_timers.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_timers.f90 @@ -41,7 +41,7 @@ module mg_timers real(r_kind) :: start_cpu = 0.0 real(r_kind) :: time_clock = 0.0 real(r_kind) :: time_cpu = 0.0 - integer(i_kind) :: icount = 0.0 + integer(i_kind) :: icount = 0 end type timer type(timer),save,public :: total_tim @@ -128,7 +128,7 @@ subroutine etim(t) write(0,*)'etim: timer is not running' STOP end if - t%running = .false. +!clt t%running = .true. t%time_clock = t%time_clock + (wt - t%start_clock) t%time_cpu = t%time_cpu + (ct - t%start_cpu) @@ -164,13 +164,19 @@ subroutine print_mg_timers(filename, print_type,mype) !clt buffer = ' ' buffer1=' '; buffer2=' ';buffer3=' ';buffer4=' ' !cltj# if ( print_type == print_clock ) then - write(buffer1,"(I6,21(',',F10.4),',',I10)") mype, & + write(6,*)'thinkdebxxx icound is ',mg_interface_multiply_time%icount + write(buffer1,"(I6,25(',',F10.4),',',I10)") 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, & + vfiltT_tim%time_clock, & + vfilt_tim%time_clock, & + bocoT_tim%time_clock, & + boco_tim%time_clock, & + filt2an_tim%time_clock, & aintp_tim%time_clock, & intp_tim%time_clock, & @@ -187,13 +193,17 @@ subroutine print_mg_timers(filename, print_type,mype) mg_filt_to_anal_time%time_clock, & mg_postprocess_time%time_clock , & mg_interface_multiply_time%icount - write(buffer2,"(I6,21(',',F10.4),',',I10)") mype, & + write(buffer2,"(I6,25(',',F10.4),',',I10)") mype, & init_tim%time_cpu, & upsend_tim%time_cpu, & dnsend_tim%time_cpu, & weight_tim%time_cpu, & hfiltT_tim%time_cpu, & hfilt_tim%time_cpu, & + vfiltT_tim%time_cpu, & + bocoT_tim%time_cpu, & + boco_tim%time_cpu, & + vfilt_tim%time_cpu, & filt2an_tim%time_cpu, & aintp_tim%time_cpu, & intp_tim%time_cpu, & @@ -218,13 +228,17 @@ subroutine print_mg_timers(filename, print_type,mype) buffer1(bufsize1:bufsize1) = NEW_LINE(' ') buffer2(bufsize2:bufsize2) = NEW_LINE(' ') - write(header1,"(A6,22(',',A10))") "mype", & + write(header1,"(A6,26(',',A10))") "mype", & "init", & "upsend", & "dnsend", & "weight", & "hfiltT", & "hfilt", & + "vfiltT", & + "vfilt", & + "bocoT", & + "boco", & "filt2an", & "aintp" , & "intp" , & From 9ed4e8be6ed1c363e3f4c03cbd3833fb11e38a2b Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 10 Feb 2025 14:41:20 +0000 Subject: [PATCH 022/199] added a basic version of mgbf using inhomogeneous weights --- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 106 +++++++++++++++++++++-- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 7 +- 2 files changed, 106 insertions(+), 7 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 2854b08ff..44b34801a 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -49,6 +49,7 @@ module mg_intstate real(r_kind), allocatable,dimension(:,:,:):: a_diff_h real(r_kind), allocatable,dimension(:,:,:):: b_diff_f real(r_kind), allocatable,dimension(:,:,:):: b_diff_h +real(r_kind), allocatable, dimension(:,:,:,:):: weig_var ! 3D weights in each sub domain ! ! Localization weights @@ -1089,6 +1090,9 @@ subroutine allocate_mg_intstate(this) 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%weig_var(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%gm)) ; this%weig_var=0. + 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. @@ -1216,9 +1220,94 @@ subroutine def_mg_weights(this) implicit none class (mg_intstate_type),target::this !*********************************************************************** -integer(i_kind):: i,j,L +integer(i_kind):: i,j,k,L + real(r_kind):: gen_fac +real(r_kind),allocatable, dimension(:,:,:,:):: weig_g +real(r_kind),allocatable, dimension(:,:,:,:):: loc_a +real(r_kind),allocatable, dimension(:,:,:):: weigh_tmp +real(r_kind),allocatable, dimension(:):: par_weig_g +integer :: rank, size, ierr, comm2d +integer,allocatable,dimension(:) :: sendcounts, displs +integer :: dims(2), periods(2), coords(2) +integer(i_kind):: nxloc,nyloc,nz,nt,start_idx,end_idx +integer(i_kind):: ig !----------------------------------------------------------------------- +start_idx=Lbound(this%weig_var,4) +end_idx=Lbound(this%weig_var,4) +if(start_idx /=1 ) then + write(6,*)'the expected begin index of weig_var is 1, stop' + stop +endif +allocate(sendcounts(this%nxpe*this%nype), displs(this%nxpe*this%nype)) +!clt first transform/upsend original mg_weigh_var to their correct locations +if(this%l_mg_weig_readin) then + dims=(/this%nxpe,this%nype/) + periods=(/0,0/) + nxloc=this%im + nyloc=this%jm + nz=this%km + nt=this%gm + allocate(loc_a(nxloc,nyloc,nz,nt)) + call MPI_CART_CREATE(MPI_COMM_WORLD, 2, dims, periods, .false., comm2d, ierr) + call MPI_COMM_RANK(comm2d, rank, ierr) + call MPI_CART_COORDS(comm2d, rank, 2, coords, ierr) + allocate(loc_a(nxloc,nyloc,nz,nt)) + if (rank == 0) then + allocate(weig_g(this%km,this%nm,this%mm,this%gm)) + !cltclt read in global_weight(nx,ny,km,ng) + endif + do j = 0, this%nype - 1 + do i = 0, this%nxpe - 1 + sendcounts(i + j * this%nxpe) = nxloc * nyloc * this%km * nt + displs(i + j * this%nxpe) = ((i * nxloc) + (j * nyloc) * nxloc) * nz * nt + end do + end do + + call MPI_Scatterv(weig_g, sendcounts, displs, MPI_INTEGER, loc_a, nxloc * nyloc * nz * nt, MPI_INTEGER, 0, comm2d, ierr) + call MPI_COMM_FREE(comm2d, ierr) + do ig=1,this%gm + do k=1,this%km + this%weig_var(k,1:nxloc,1:nyloc,ig)=loc_a(:,:,k,ig) + enddo + enddo +!clt the following would have different results in corners when run on different order +!cltthink to be investigated further + do i=1-this%hx, 0 + this%weig_var(:,i,:,:)=this%weig_var(:,1,:,:) + enddo + do i=nxloc+1,nxloc+this%hx +!clt this%weig_var(:,nxloc+1:nxloc+this%hx,:,:)=this%weig_var(:,nxloc,:,:) + this%weig_var(:,i,:,:)=this%weig_var(:,nxloc,:,:) + enddo + do j=1-this%hy,0 +!cltorg this%weig_var(:,:,1-this%hy:0,:)=this%weig_var(:,:,1,:) + this%weig_var(:,:,j,:)=this%weig_var(:,:,1,:) + enddo + do j=nyloc+1,nyloc+this%hy +!clt this%weig_var(:,:,ny+1:ny+this%hy,:)=this%weig_var(:,:,ny,:) + this%weig_var(:,:,j,:)=this%weig_var(:,:,nyloc,:) + enddo +!clttothink + allocate(weigh_tmp(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%weig_var=0. +!clt to convert data in weigt_var to their correct locations + do ig=start_idx,end_idx + weigh_tmp=this%weig_var(:,:,:,ig) + call this%upsending(weigh_tmp,this%weig_var(:,:,:,ig)) + enddo + + deallocate(weig_g,weigh_tmp) +else + allocate(par_weig_g(4)) + par_weig_g=(/this%mg_weig1,this%mg_weig2,this%mg_weig3,this%mg_weig4/) + do ig=start_idx,end_idx + weigh_tmp=par_weig_g(ig) + call this%upsending(weigh_tmp,this%weig_var(:,:,:,ig)) + enddo + + deallocate(par_weig_g) +endif +deallocate(sendcounts, displs) this%p_eps(:,:)=0.0 this%p_del(:,:)=0.0 @@ -1237,19 +1326,24 @@ subroutine def_mg_weights(this) endif !-------------------------------------------------------- gen_fac=1. -this%a_diff_f(:,:,:)=this%mg_weig1 -this%a_diff_h(:,:,:)=this%mg_weig1 +!cltorg this%a_diff_f(:,:,:)=this%mg_weig1 +this%a_diff_f(:,:,:)=this%weig_var(:,:,:,1) +!cltorg this%a_diff_h(:,:,:)=this%mg_weig1 +this%a_diff_h(:,:,:)=this%weig_var(:,:,:,1) this%b_diff_f(:,:,:)=0. this%b_diff_h(:,:,:)=0. select case(this%my_hgen) case(2) - this%a_diff_h(:,:,:)=this%mg_weig2 +!cltorg this%a_diff_h(:,:,:)=this%mg_weig2 + this%a_diff_h(:,:,:)=this%weig_var(:,:,:,2) case(3) - this%a_diff_h(:,:,:)=this%mg_weig3 +!cltorg this%a_diff_h(:,:,:)=this%mg_weig3 + this%a_diff_h(:,:,:)=this%weig_var(:,:,:,3) case default - this%a_diff_h(:,:,:)=this%mg_weig4 +!cltorg this%a_diff_h(:,:,:)=this%mg_weig4 + this%a_diff_h(:,:,:)=this%weig_var(:,:,:,4) end select do L=1,this%lm diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 06f74e6d5..d3fe7acab 100755 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -44,6 +44,7 @@ module mg_parameter !*** real(r_kind):: mg_ampl01,mg_ampl02,mg_ampl03 real(r_kind):: mg_weig1,mg_weig2,mg_weig3,mg_weig4 + ! avoid a global version of it to avoid memory usage 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) @@ -210,6 +211,7 @@ module mg_parameter 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 +logical:: l_mg_weig_readin=.false. contains procedure :: init_mg_parameter @@ -515,6 +517,7 @@ subroutine init_mg_parameter(this,inputfilename) integer(i_kind):: hx,hy,hz integer(i_kind):: p +logical:: l_mg_weig_readin=.false. namelist /parameters_mgbeta/ mg_ampl01,mg_ampl02,mg_ampl03 & ,mg_weig1,mg_weig2,mg_weig3,mg_weig4 & @@ -535,7 +538,8 @@ subroutine init_mg_parameter(this,inputfilename) ,l_for_localization,ldelta,lquart,lhelm & ,gm_max & ,nm0,mm0 & - ,nxPE,nyPE,im_filt,jm_filt + ,nxPE,nyPE,im_filt,jm_filt , & + l_mg_weig_readin open(unit=10,file=inputfilename,status='old',action='read') read(10,nml=parameters_mgbeta) @@ -669,6 +673,7 @@ subroutine init_mg_parameter(this,inputfilename) this%km_4 = this%km/4 this%km_16 = this%km/16 this%km_64 = this%km/64 + this%l_mg_weig_readin=l_mg_weig_readin ! ! Define maximum number of generations 'gm' From aa8abcaa61047436da60e52a65d5fcd436e124b8 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Wed, 12 Feb 2025 22:13:51 +0000 Subject: [PATCH 023/199] used normalized adjoint in upsending_normalized for weights --- src/saber/mgbf/mgbf_lib/mg_generations.f90 | 160 +++++++++++++++++++++ src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 32 ++++- 2 files changed, 188 insertions(+), 4 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index 291f0a57c..2014bf4c0 100755 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -208,6 +208,51 @@ module subroutine upsending & !----------------------------------------------------------------------- endsubroutine upsending +module subroutine upsending_normalized & +!*********************************************************************** +! using adjoint_normalized +! ! +! 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_normalized(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_normalized(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_normalized !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& module subroutine downsending & @@ -1322,6 +1367,121 @@ module subroutine adjoint & !----------------------------------------------------------------------- endsubroutine adjoint +module subroutine adjoint_normalized & +!*********************************************************************** +!clt normalized adjoint , more efficient way to be explored later +! ! +! 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 +real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: WEIG_AUX +real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2) :: Wnorm +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 3) +! + W_AUX(:,:,:)= 0. + WEIG_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) + + WEIG_AUX(:,i,jL+2)=WEIG_AUX(:,i,jL+2)+this%p_coef(4) + WEIG_AUX(:,i,jL+1)=WEIG_AUX(:,i,jL+1)+this%p_coef(3) + WEIG_AUX(:,i,jL )=WEIG_AUX(:,i,jL )+this%p_coef(2) + WEIG_AUX(:,i,jL-1)=WEIG_AUX(:,i,jL-1)+this%p_coef(1) + 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) + + WEIG_AUX(:,i,jL+2)=WEIG_AUX(:,i,jL+2)+this%q_coef(4) + WEIG_AUX(:,i,jL+1)=WEIG_AUX(:,i,jL+1)+this%q_coef(3) + WEIG_AUX(:,i,jL )=WEIG_AUX(:,i,jL )+this%q_coef(2) + WEIG_AUX(:,i,jL-1)=WEIG_AUX(:,i,jL-1)+this%q_coef(1) + + + enddo + enddo + + W(:,:,:)=0. +! +! 1) + Wnorm=0.! + 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) + + Wnorm(:,iL+2,jL)=Wnorm(:,iL+2,jL)+this%q_coef(4)*WEIG_AUX(:,i,jL) + Wnorm(:,iL+1,jL)=Wnorm(:,iL+1,jL)+this%q_coef(3)*WEIG_AUX(:,i,jL) + Wnorm(:,iL ,jL)=Wnorm(:,iL ,jL)+this%q_coef(2)*WEIG_AUX(:,i,jL) + Wnorm(:,iL-1,jL)=Wnorm(:,iL-1,jL)+this%q_coef(1)*WEIG_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) + + Wnorm(:,iL+2,jL)=Wnorm(:,iL+2,jL)+this%p_coef(4)*WEIG_AUX(:,i,jL) + Wnorm(:,iL+1,jL)=Wnorm(:,iL+1,jL)+this%p_coef(3)*WEIG_AUX(:,i,jL) + Wnorm(:,iL ,jL)=Wnorm(:,iL ,jL)+this%p_coef(2)*WEIG_AUX(:,i,jL) + Wnorm(:,iL-1,jL)=Wnorm(:,iL-1,jL)+this%p_coef(1)*WEIG_AUX(:,i,jL) + enddo + enddo +!clt normalization +! + 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)/Wnorm(:,iL+2,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)/Wnorm(:,iL+1,jL) + W(:,iL ,jL)=W(:,iL ,jL)/Wnorm(:,iL,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)/Wnorm(:,iL-1,jL) + + enddo + do i=this%im-mod(this%im,2),2,-2 + iL=i/2 + W(:,iL+2,jL)=W(:,iL+2,jL)/Wnorm(:,iL+2,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)/Wnorm(:,iL+1,jL) + W(:,iL ,jL)=W(:,iL ,jL)/Wnorm(:,iL,jL) + W(:,iL-1 ,jL)=W(:,iL-1 ,jL)/Wnorm(:,iL-1,jL) + + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine adjoint_normalized !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& module subroutine direct1 & diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 44b34801a..d090be59a 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -162,6 +162,7 @@ module mg_intstate !from mg_generation.f90 procedure:: upsending_all,downsending_all,weighting_all procedure:: upsending,downsending + procedure:: upsending_normalized procedure:: upsending_highest,downsending_highest procedure:: upsending2,downsending2 procedure:: upsending_ens,downsending_ens @@ -175,6 +176,7 @@ module mg_intstate generic :: weighting_loc => weighting_loc_g3,weighting_loc_g4 procedure:: weighting_loc_g3,weighting_loc_g4 procedure:: adjoint,direct1 + procedure:: adjoint_normalized procedure:: adjoint2,direct2 procedure:: adjoint_nearest,direct_nearest procedure:: adjoint_highest,direct_highest @@ -648,6 +650,15 @@ module subroutine upsending & 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 upsending_normalized & + (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 @@ -825,6 +836,15 @@ module subroutine adjoint & 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 adjoint_normalized & + (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 @@ -1234,12 +1254,13 @@ subroutine def_mg_weights(this) integer(i_kind):: ig !----------------------------------------------------------------------- start_idx=Lbound(this%weig_var,4) -end_idx=Lbound(this%weig_var,4) +end_idx=Ubound(this%weig_var,4) if(start_idx /=1 ) then write(6,*)'the expected begin index of weig_var is 1, stop' stop endif allocate(sendcounts(this%nxpe*this%nype), displs(this%nxpe*this%nype)) +allocate(weigh_tmp(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%weig_var=0. !clt first transform/upsend original mg_weigh_var to their correct locations if(this%l_mg_weig_readin) then dims=(/this%nxpe,this%nype/) @@ -1256,6 +1277,8 @@ subroutine def_mg_weights(this) if (rank == 0) then allocate(weig_g(this%km,this%nm,this%mm,this%gm)) !cltclt read in global_weight(nx,ny,km,ng) +else + allocate(weig_g(1,1,1,1)) endif do j = 0, this%nype - 1 do i = 0, this%nxpe - 1 @@ -1264,7 +1287,7 @@ subroutine def_mg_weights(this) end do end do - call MPI_Scatterv(weig_g, sendcounts, displs, MPI_INTEGER, loc_a, nxloc * nyloc * nz * nt, MPI_INTEGER, 0, comm2d, ierr) + call MPI_Scatterv(weig_g, sendcounts, displs, MPI_REAL, loc_a, nxloc * nyloc * nz * nt, MPI_REAL, 0, comm2d, ierr) call MPI_COMM_FREE(comm2d, ierr) do ig=1,this%gm do k=1,this%km @@ -1289,11 +1312,10 @@ subroutine def_mg_weights(this) this%weig_var(:,:,j,:)=this%weig_var(:,:,nyloc,:) enddo !clttothink - allocate(weigh_tmp(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%weig_var=0. !clt to convert data in weigt_var to their correct locations do ig=start_idx,end_idx weigh_tmp=this%weig_var(:,:,:,ig) - call this%upsending(weigh_tmp,this%weig_var(:,:,:,ig)) + call this%upsending_normalized(weigh_tmp,this%weig_var(:,:,:,ig)) enddo deallocate(weig_g,weigh_tmp) @@ -1301,7 +1323,9 @@ subroutine def_mg_weights(this) allocate(par_weig_g(4)) par_weig_g=(/this%mg_weig1,this%mg_weig2,this%mg_weig3,this%mg_weig4/) do ig=start_idx,end_idx + write(6,*)'thinkdeb255 par_weig_g(ig) ',par_weig_g(ig) weigh_tmp=par_weig_g(ig) +!cltorg call this%upsending_normalized(weigh_tmp,this%weig_var(:,:,:,ig)) call this%upsending(weigh_tmp,this%weig_var(:,:,:,ig)) enddo From f016e14cc6a11d6ff2a3dd7b0c0d8ec8fdcff168 Mon Sep 17 00:00:00 2001 From: TingLei-NOAA Date: Tue, 18 Feb 2025 13:14:02 -0500 Subject: [PATCH 024/199] adding safety check in adjoint_normalization --- src/saber/mgbf/mgbf_lib/mg_generations.f90 | 75 +++++++++++++++++++--- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 8 ++- 2 files changed, 72 insertions(+), 11 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index 2014bf4c0..858a03cef 100755 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -965,6 +965,7 @@ module subroutine downsending_loc_g3 & 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) @@ -1387,11 +1388,14 @@ module subroutine adjoint_normalized & real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: WEIG_AUX real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2) :: Wnorm +real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2) :: W_tmp integer(i_kind):: i,j,iL,jL +integer(i_kind):: k +real(r_kind), parameter :: eps = 1.0e-10_r_kind ! Add epsilon for safety check !----------------------------------------------------------------------- ! ! 3) -! + write(6,*)'thinkdeb253 f is ',minval(F),' ',maxval(F)! W_AUX(:,:,:)= 0. WEIG_AUX(:,:,:)= 0. @@ -1409,6 +1413,8 @@ module subroutine adjoint_normalized & WEIG_AUX(:,i,jL-1)=WEIG_AUX(:,i,jL-1)+this%p_coef(1) enddo enddo + write(6,*)'thinkdeb253 1 W_AUX is ',minval(W_AUX),' ',maxval(W_AUX)! + write(6,*)'thinkdeb253 1 WEIG_AUX is ',minval(WEIG_AUX),' ',maxval(WEIG_AUX)! ! ! 2) ! @@ -1428,6 +1434,8 @@ module subroutine adjoint_normalized & enddo enddo + write(6,*)'thinkdeb253 2 W_AUX is ',minval(W_AUX),' ',maxval(W_AUX)! + write(6,*)'thinkdeb253 2 WEIG_AUX is ',minval(WEIG_AUX),' ',maxval(WEIG_AUX)! W(:,:,:)=0. ! @@ -1459,27 +1467,76 @@ module subroutine adjoint_normalized & Wnorm(:,iL-1,jL)=Wnorm(:,iL-1,jL)+this%p_coef(1)*WEIG_AUX(:,i,jL) enddo enddo + write(6,*)'thinkdeb253 3 W is ',minval(W),' ',maxval(W)! + write(6,*)'thinkdeb253 3 Wnorm is ',minval(Wnorm),' ',maxval(Wnorm)! + W_tmp=W !clt normalization ! +if (1.gt.0) then 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)/Wnorm(:,iL+2,jL) - W(:,iL+1,jL)=W(:,iL+1,jL)/Wnorm(:,iL+1,jL) - W(:,iL ,jL)=W(:,iL ,jL)/Wnorm(:,iL,jL) - W(:,iL-1,jL)=W(:,iL-1,jL)/Wnorm(:,iL-1,jL) + do k=1,km_in + if(abs(Wnorm(k,iL+2,jL)) > eps) then + W(k,iL+2,jL)=W(k,iL+2,jL)/Wnorm(k,iL+2,jL) + else + W(k,iL+2,jL)=0.0_r_kind + endif + if(abs(W(k,iL+2,jL)) .gt. 1000) then + write(6,*)"thinkdeb254 large w/old ",k,iL+2,jL,' ',W_tmp(k,iL+2,jL),W(k,iL+2,jL),' ',Wnorm(k,iL+2,jL) + endif + if (abs(Wnorm(k,iL+1,jL)) > eps) then + W(k,iL+1,jL)=W(k,iL+1,jL)/Wnorm(k,iL+1,jL) + else + W(k,iL+1,jL)=0.0_r_kind + endif + if (abs(Wnorm(k,iL,jL)) > eps) then + W(k,iL ,jL)=W(k,iL ,jL)/Wnorm(k,iL,jL) + else + W(k,iL ,jL)=0.0_r_kind + endif + + if (abs(Wnorm(k,iL-1,jL)) > eps) then + W(k,iL-1,jL)=W(k,iL-1,jL)/Wnorm(k,iL-1,jL) + else + W(k,iL-1,jL)=0.0_r_kind + endif + enddo !for k enddo do i=this%im-mod(this%im,2),2,-2 iL=i/2 - W(:,iL+2,jL)=W(:,iL+2,jL)/Wnorm(:,iL+2,jL) - W(:,iL+1,jL)=W(:,iL+1,jL)/Wnorm(:,iL+1,jL) - W(:,iL ,jL)=W(:,iL ,jL)/Wnorm(:,iL,jL) - W(:,iL-1 ,jL)=W(:,iL-1 ,jL)/Wnorm(:,iL-1,jL) + do k=1,km_in + if(abs(Wnorm(k,iL+2,jL)) > eps) then + W(k,iL+2,jL)=W(k,iL+2,jL)/Wnorm(k,iL+2,jL) + else + W(k,iL+2,jL)=0.0_r_kind + endif + + if(abs(Wnorm(k,iL+1,jL)) > eps) then + W(k,iL+1,jL)=W(k,iL+1,jL)/Wnorm(k,iL+1,jL) + else + W(k,iL+1,jL)=0.0_r_kind + endif + if (abs(Wnorm(k,iL,jL)) > eps) then + W(k,iL ,jL)=W(k,iL ,jL)/Wnorm(k,iL,jL) + else + W(k,iL ,jL)=0.0_r_kind + endif + + if (abs(Wnorm(k,iL-1,jL)) > eps) then + W(k,iL-1,jL)=W(k,iL-1,jL)/Wnorm(k,iL-1,jL) + else + W(k,iL-1,jL)=0.0_r_kind + endif + enddo !for k enddo enddo + write(6,*)'thinkdeb253 4 W is ',minval(W),' ',maxval(W)! + write(6,*)'thinkdeb253 4 Wnorm is ',minval(Wnorm),' ',maxval(Wnorm)! +endif !----------------------------------------------------------------------- endsubroutine adjoint_normalized diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index d090be59a..23444bc00 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1325,8 +1325,8 @@ subroutine def_mg_weights(this) do ig=start_idx,end_idx write(6,*)'thinkdeb255 par_weig_g(ig) ',par_weig_g(ig) weigh_tmp=par_weig_g(ig) -!cltorg call this%upsending_normalized(weigh_tmp,this%weig_var(:,:,:,ig)) - call this%upsending(weigh_tmp,this%weig_var(:,:,:,ig)) + call this%upsending_normalized(weigh_tmp,this%weig_var(:,:,:,ig)) +!clto call this%upsending(weigh_tmp,this%weig_var(:,:,:,ig)) enddo deallocate(par_weig_g) @@ -1351,6 +1351,7 @@ subroutine def_mg_weights(this) !-------------------------------------------------------- gen_fac=1. !cltorg this%a_diff_f(:,:,:)=this%mg_weig1 +write(6,*)'thinkdeb256 weigh1 ',this%mg_weig1,maxval(this%weig_var(:,:,:,1)),maxval(this%weig_var(:,:,:,1)) this%a_diff_f(:,:,:)=this%weig_var(:,:,:,1) !cltorg this%a_diff_h(:,:,:)=this%mg_weig1 this%a_diff_h(:,:,:)=this%weig_var(:,:,:,1) @@ -1361,11 +1362,14 @@ subroutine def_mg_weights(this) select case(this%my_hgen) case(2) !cltorg this%a_diff_h(:,:,:)=this%mg_weig2 +write(6,*)'thinkdeb256 weigh2 ',this%mg_weig2,maxval(this%weig_var(:,:,:,2)),maxval(this%weig_var(:,:,:,2)) this%a_diff_h(:,:,:)=this%weig_var(:,:,:,2) case(3) !cltorg this%a_diff_h(:,:,:)=this%mg_weig3 +write(6,*)'thinkdeb256 weigh3 ',this%mg_weig3,maxval(this%weig_var(:,:,:,3)),maxval(this%weig_var(:,:,:,3)) this%a_diff_h(:,:,:)=this%weig_var(:,:,:,3) case default +write(6,*)'thinkdeb256 weigh4 ',this%mg_weig1,maxval(this%weig_var(:,:,:,4)),maxval(this%weig_var(:,:,:,4)) !cltorg this%a_diff_h(:,:,:)=this%mg_weig4 this%a_diff_h(:,:,:)=this%weig_var(:,:,:,4) end select From b6feddacd1be95c1d9265d6ae6b6a041c240c84d Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 25 Feb 2025 01:01:01 +0000 Subject: [PATCH 025/199] the adjoint_normalized was right but not accurate enough to propogate the weights --- src/saber/mgbf/mgbf_lib/mg_generations.f90 | 60 +++------------------- 1 file changed, 6 insertions(+), 54 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index 858a03cef..f5fccab94 100755 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -234,6 +234,7 @@ module subroutine upsending_normalized & call this%adjoint_normalized(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) +!clttothink call this%upsend_all(V_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km) ! @@ -1473,65 +1474,16 @@ module subroutine adjoint_normalized & !clt normalization ! if (1.gt.0) then - do jL=this%jmL+2,-1,-1 - do i=this%im-1+mod(this%im,2),1,-2 - iL = i/2 + do j=this%jmL+2,-1,-1 + do i=this%imL+2,-1,-1 do k=1,km_in - if(abs(Wnorm(k,iL+2,jL)) > eps) then - W(k,iL+2,jL)=W(k,iL+2,jL)/Wnorm(k,iL+2,jL) + if(abs(Wnorm(k,i,j)) > eps) then + W(k,i,j)=W_tmp(k,i,j)/Wnorm(k,i,j) else - W(k,iL+2,jL)=0.0_r_kind - endif - if(abs(W(k,iL+2,jL)) .gt. 1000) then - write(6,*)"thinkdeb254 large w/old ",k,iL+2,jL,' ',W_tmp(k,iL+2,jL),W(k,iL+2,jL),' ',Wnorm(k,iL+2,jL) - endif - if (abs(Wnorm(k,iL+1,jL)) > eps) then - W(k,iL+1,jL)=W(k,iL+1,jL)/Wnorm(k,iL+1,jL) - else - W(k,iL+1,jL)=0.0_r_kind - endif - - if (abs(Wnorm(k,iL,jL)) > eps) then - W(k,iL ,jL)=W(k,iL ,jL)/Wnorm(k,iL,jL) - else - W(k,iL ,jL)=0.0_r_kind - endif - - if (abs(Wnorm(k,iL-1,jL)) > eps) then - W(k,iL-1,jL)=W(k,iL-1,jL)/Wnorm(k,iL-1,jL) - else - W(k,iL-1,jL)=0.0_r_kind + W(k,i,j)=0.0_r_kind endif enddo !for k enddo - do i=this%im-mod(this%im,2),2,-2 - iL=i/2 - do k=1,km_in - if(abs(Wnorm(k,iL+2,jL)) > eps) then - W(k,iL+2,jL)=W(k,iL+2,jL)/Wnorm(k,iL+2,jL) - else - W(k,iL+2,jL)=0.0_r_kind - endif - - if(abs(Wnorm(k,iL+1,jL)) > eps) then - W(k,iL+1,jL)=W(k,iL+1,jL)/Wnorm(k,iL+1,jL) - else - W(k,iL+1,jL)=0.0_r_kind - endif - - if (abs(Wnorm(k,iL,jL)) > eps) then - W(k,iL ,jL)=W(k,iL ,jL)/Wnorm(k,iL,jL) - else - W(k,iL ,jL)=0.0_r_kind - endif - - if (abs(Wnorm(k,iL-1,jL)) > eps) then - W(k,iL-1,jL)=W(k,iL-1,jL)/Wnorm(k,iL-1,jL) - else - W(k,iL-1,jL)=0.0_r_kind - endif - enddo !for k - enddo enddo write(6,*)'thinkdeb253 4 W is ',minval(W),' ',maxval(W)! write(6,*)'thinkdeb253 4 Wnorm is ',minval(Wnorm),' ',maxval(Wnorm)! From 581350507369e4adec9e2eb4c11acf0a7c222d2f Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 4 Mar 2025 19:39:17 +0000 Subject: [PATCH 026/199] for debugging --- CMakeLists.txt | 4 +- src/saber/blocks/SaberOuterBlockBase.h | 1 + src/saber/blocks/SaberOuterBlockChain.h | 6 +- src/saber/interpolation/Geometry.cc | 1 + src/saber/interpolation/Interpolation.cc | 3 + .../mgbf/covariance/mgbf_covariance_mod.f90 | 3 + src/saber/mgbf/mgbf_lib/mg_generations.f90 | 146 +++++++----------- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 26 +++- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 7 + 9 files changed, 103 insertions(+), 94 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 9251fcca5..dad711839 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -42,7 +42,9 @@ find_package( NetCDF REQUIRED COMPONENTS C Fortran ) #cltold find_package( atlas 0.35.0 REQUIRED COMPONENTS OMP_Fortran ) find_package( eckit 1.17.1 REQUIRED COMPONENTS MPI ) find_package( fckit 0.9.5 REQUIRED ) -find_package( atlas 0.35.0 REQUIRED COMPONENTS OMP_Fortran TESSELATION) +set(CMAKE_FIND_DEBUG_MODE TRUE) +#clt find_package( atlas 0.35.0 REQUIRED COMPONENTS OMP_Fortran TESSELATION) +find_package( atlas 0.35.0 REQUIRED COMPONENTS OMP_Fortran ) # TODO(Benjamin): check when ATLAS PR #215 is merged into a tagged version to update the version number if( atlas_VERSION VERSION_GREATER "0.38.1" ) set( ATLAS_REGIONAL_INTERP ON ) diff --git a/src/saber/blocks/SaberOuterBlockBase.h b/src/saber/blocks/SaberOuterBlockBase.h index d555aedea..bcb0195aa 100644 --- a/src/saber/blocks/SaberOuterBlockBase.h +++ b/src/saber/blocks/SaberOuterBlockBase.h @@ -248,6 +248,7 @@ class SaberOuterBlockMaker : public SaberOuterBlockFactory { const SaberBlockParametersBase & params, const oops::FieldSet3D & xb, const oops::FieldSet3D & fg) override { + oops::Log::trace() << "SaberOuterBlockMaker::make starting" << std::endl; const auto &stronglyTypedParams = dynamic_cast(params); return std::make_unique(outerGeometryData, outerVars, covarConf, stronglyTypedParams, xb, fg); diff --git a/src/saber/blocks/SaberOuterBlockChain.h b/src/saber/blocks/SaberOuterBlockChain.h index b4ba0c74a..688f20429 100644 --- a/src/saber/blocks/SaberOuterBlockChain.h +++ b/src/saber/blocks/SaberOuterBlockChain.h @@ -193,7 +193,7 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, const eckit::LocalConfiguration & covarConf, const std::vector & params) { oops::Log::trace() << "SaberOuterBlockChain ctor starting" << std::endl; - oops::Log::info() << "Info : Creating outer blocks" << std::endl; + oops::Log::info() << "Info xx : Creating outer blocks" << std::endl; // In addition to other configuration option pass model data information for vader // TODO(AS): check whether covarConf needs to be passed to the blocks (ideally not) @@ -211,6 +211,7 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, geom.generic() : outerBlocks_.back()->innerGeometryData(); // Initialize outer block + oops::Log::trace() << "SaberOuterBlockChain before initBlock" << std::endl; const auto[saberOuterBlockParams, currentOuterVars, activeVars] @@ -220,9 +221,12 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, outerVars, fset4dXb, fset4dFg); + oops::Log::trace() << "SaberOuterBlockChain after initBlock" << std::endl; + oops::Log::trace() << "SaberOuterBlockChain before read " << std::endl; // Read and add model fields outerBlocks_.back()->read(geom, currentOuterVars); + oops::Log::trace() << "SaberOuterBlockChain after read " << std::endl; if (saberOuterBlockParams.doCalibration()) { // Block calibration diff --git a/src/saber/interpolation/Geometry.cc b/src/saber/interpolation/Geometry.cc index 14b282b60..3ae550405 100644 --- a/src/saber/interpolation/Geometry.cc +++ b/src/saber/interpolation/Geometry.cc @@ -32,6 +32,7 @@ Geometry::Geometry(const eckit::Configuration & config, const eckit::mpi::Comm & comm) : comm_(comm), halo_(1) { + oops::Log::trace() <<"interpolation::Geometry ctor start" << std::endl; atlas::Mesh mesh; util::setupFunctionSpace(comm_, config, grid_, partitioner_, mesh, functionSpace_, fieldSet_); diff --git a/src/saber/interpolation/Interpolation.cc b/src/saber/interpolation/Interpolation.cc index d25ecdf96..f1b9711d8 100644 --- a/src/saber/interpolation/Interpolation.cc +++ b/src/saber/interpolation/Interpolation.cc @@ -35,6 +35,7 @@ Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, // Set up GeometryData Geometry geom(params.innerGeom, outerGeometryData.comm()); + oops::Log::trace() << classname() << "::Interpolation after geom ctor" << std::endl; innerGeomData_.reset(new oops::GeometryData(geom.functionSpace(), geom.fields(), true, outerGeometryData.comm())); @@ -57,6 +58,7 @@ Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, void Interpolation::multiply(oops::FieldSet3D & fieldSet) const { oops::Log::trace() << classname() << "::multiply starting" << std::endl; + util::Timer timer(classname(), "multiply"); // Temporary FieldSet of active variables for interpolation source atlas::FieldSet sourceFieldSet; @@ -99,6 +101,7 @@ void Interpolation::multiply(oops::FieldSet3D & fieldSet) const { void Interpolation::multiplyAD(oops::FieldSet3D & fieldSet) const { oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; + util::Timer timer(classname(), "multiplyAD"); // Temporary FieldSet of active variables for interpolation target atlas::FieldSet targetFieldSet; diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index fd410315e..244312db7 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -235,6 +235,7 @@ subroutine multiply(self, fields) allocate(work_mgbf(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work_mgbf2(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work2d_mgbf(self%intstate%km_a_all,self%intstate%nm*self%intstate%mm)) + write(6,*)"thinkdeb 2551 in covariance km_all is ",self%intstate%km_a_all allocate(rnormalization(self%intstate%km_a_all)) work2d_mgbf=0.0 rnormalization=1.0 @@ -374,11 +375,13 @@ subroutine multiply(self, fields) nz=afield%levels() lev1=varvlev_index(isize,1) if(nz.gt.1) then + write(6,*)'thinkdeb2552 dimension of ptr_2d are ',size(ptr_2d,1), ' ',size(ptr_2d,2) ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) else if(self%intstate%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + write(6,*)'thinkdeb2553 dimension of 2 dimensio of ptr_2d,work2d are ',size(ptr_2d,2), ' ',size(work2d_mgbf,2) ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) else ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index f5fccab94..ec927a38a 100755 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -230,25 +230,32 @@ module subroutine upsending_normalized & ! ! From generation 1 to generation 2 ! - - call this%adjoint_normalized(V(1:this%km,1:this%im,1:this%jm),V_INT,this%km,1) + write(6,*)'thinkdeb144 before adjoint_nral min/max input ', minval(V),maxval(V) + call this%adjoint_normalized(V(1:this%km,0:this%im+1,0:this%jm+1),V_INT,this%km,1) + write(6,*)'thinkdeb144 after adjoint_nral min/max output ', minval(V_INT),maxval(V_INT) call this%bocoT_2d(V_INT,this%km,this%imL,this%jmL,2,2) + write(6,*)'thinkdeb144 after 2 min/max output ', minval(V_INT),maxval(V_INT) !clttothink call this%upsend_all(V_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km) + write(6,*)'thinkdeb144 after 2 min/max output ', minval(H),maxval(H) ! ! From generation 2 sequentially to higher generations ! do g=2,this%gm-1 if(g==this%my_hgen) then - call this%adjoint_normalized(H(1:this%km,1:this%im,1:this%jm),H_INT,this%km,g) + write(6,*)'thinkdeb144 before second adjoint min/max input ', minval(H),maxval(H) + call this%adjoint_normalized(H(1:this%km,0:this%im+1,0:this%jm+1),H_INT,this%km,g) + write(6,*)'thinkdeb144 after second adjoint min/max input ', minval(H_INT),maxval(H_INT) endif call this%bocoT_2d(H_INT,this%km,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) + write(6,*)'thinkdeb144 before final upsend_all min/max input ', minval(H_INT),maxval(H_INT) call this%upsend_all(H_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km,g,g+1) + write(6,*)'thinkdeb144 after final upsend_all min/max input ', minval(H_INT),maxval(H_INT) end do @@ -1371,12 +1378,10 @@ module subroutine adjoint & endsubroutine adjoint module subroutine adjoint_normalized & !*********************************************************************** -!clt normalized adjoint , more efficient way to be explored later -! ! -! Mapping from the high to low resolution grid ! -! using linearly squared interpolations ! ! - offset version - ! ! ! +!modified from Misha's adjoint_bilin_norm.f90 +!except for the addtional normalization step, let holo points of W equal to inner points !*********************************************************************** (this,F,W,km_in,g) !----------------------------------------------------------------------- @@ -1384,107 +1389,72 @@ module subroutine adjoint_normalized & 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%im+1,0:this%jm+1), 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 -real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: WEIG_AUX real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2) :: Wnorm -real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2) :: W_tmp integer(i_kind):: i,j,iL,jL +real(r_kind):: r1_16,r3_16,r9_16 integer(i_kind):: k real(r_kind), parameter :: eps = 1.0e-10_r_kind ! Add epsilon for safety check !----------------------------------------------------------------------- ! ! 3) write(6,*)'thinkdeb253 f is ',minval(F),' ',maxval(F)! - W_AUX(:,:,:)= 0. - WEIG_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) - - WEIG_AUX(:,i,jL+2)=WEIG_AUX(:,i,jL+2)+this%p_coef(4) - WEIG_AUX(:,i,jL+1)=WEIG_AUX(:,i,jL+1)+this%p_coef(3) - WEIG_AUX(:,i,jL )=WEIG_AUX(:,i,jL )+this%p_coef(2) - WEIG_AUX(:,i,jL-1)=WEIG_AUX(:,i,jL-1)+this%p_coef(1) - enddo - enddo - write(6,*)'thinkdeb253 1 W_AUX is ',minval(W_AUX),' ',maxval(W_AUX)! - write(6,*)'thinkdeb253 1 WEIG_AUX is ',minval(WEIG_AUX),' ',maxval(WEIG_AUX)! -! -! 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) - - WEIG_AUX(:,i,jL+2)=WEIG_AUX(:,i,jL+2)+this%q_coef(4) - WEIG_AUX(:,i,jL+1)=WEIG_AUX(:,i,jL+1)+this%q_coef(3) - WEIG_AUX(:,i,jL )=WEIG_AUX(:,i,jL )+this%q_coef(2) - WEIG_AUX(:,i,jL-1)=WEIG_AUX(:,i,jL-1)+this%q_coef(1) - - - enddo - enddo - write(6,*)'thinkdeb253 2 W_AUX is ',minval(W_AUX),' ',maxval(W_AUX)! - write(6,*)'thinkdeb253 2 WEIG_AUX is ',minval(WEIG_AUX),' ',maxval(WEIG_AUX)! - W(:,:,:)=0. -! -! 1) Wnorm=0.! - 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) - Wnorm(:,iL+2,jL)=Wnorm(:,iL+2,jL)+this%q_coef(4)*WEIG_AUX(:,i,jL) - Wnorm(:,iL+1,jL)=Wnorm(:,iL+1,jL)+this%q_coef(3)*WEIG_AUX(:,i,jL) - Wnorm(:,iL ,jL)=Wnorm(:,iL ,jL)+this%q_coef(2)*WEIG_AUX(:,i,jL) - Wnorm(:,iL-1,jL)=Wnorm(:,iL-1,jL)+this%q_coef(1)*WEIG_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) - - Wnorm(:,iL+2,jL)=Wnorm(:,iL+2,jL)+this%p_coef(4)*WEIG_AUX(:,i,jL) - Wnorm(:,iL+1,jL)=Wnorm(:,iL+1,jL)+this%p_coef(3)*WEIG_AUX(:,i,jL) - Wnorm(:,iL ,jL)=Wnorm(:,iL ,jL)+this%p_coef(2)*WEIG_AUX(:,i,jL) - Wnorm(:,iL-1,jL)=Wnorm(:,iL-1,jL)+this%p_coef(1)*WEIG_AUX(:,i,jL) - enddo - enddo - write(6,*)'thinkdeb253 3 W is ',minval(W),' ',maxval(W)! - write(6,*)'thinkdeb253 3 Wnorm is ',minval(Wnorm),' ',maxval(Wnorm)! - W_tmp=W -!clt normalization +!----------------------------------------------------------------------- +r1_16 = 1./16. +r3_16 = 3.*r1_16 +r9_16 = 9.*r1_16 + + + + do jL=1,this%jmL + j = 2*jL - 1 + do iL=1,this%imL + i = 2*iL - 1 + W(:,iL,jL) = r1_16*(F(:,i-1,j-1)+F(:,i+2,j-1)+F(:,i-1,j+2)+F(:,i+2,j+2))+ & + + r3_16*(F(:,i,j-1)+F(:,i+1,j-1) & + + F(:,i-1,j)+F(:,i-1,j+1) & + + F(:,i+2,j)+F(:,i+2,j+1) & + + F(:,i,j+2)+F(:,i+1,j+2)) & + + r9_16*(F(:,i,j)+F(:,i+1,j)+F(:,i,j+1)+F(:,i+1,j+1)) + wnorm(:,iL,jL) =wnorm(:,iL,jL)+ r1_16*4+ & + + r3_16*8 & + + r9_16*4 + enddo + enddo + ! if (1.gt.0) then - do j=this%jmL+2,-1,-1 - do i=this%imL+2,-1,-1 + do jL=1,this%jmL + do iL=1,this%imL do k=1,km_in - if(abs(Wnorm(k,i,j)) > eps) then - W(k,i,j)=W_tmp(k,i,j)/Wnorm(k,i,j) + if(abs(Wnorm(k,iL,jL)) > eps) then + W(k,iL,jL)=W(k,iL,jL)/Wnorm(k,iL,jL) else - W(k,i,j)=0.0_r_kind + W(k,iL,jL)=0.0_r_kind endif enddo !for k enddo enddo +!clt the following procedure would cause values on the corner change +!if the order of the following assignment change +!an assumption is that those boundary points (including corner points) +!would be specified through mpi exchanges of halo points later +if (1.gt.2) then + W(:,-1:0,:)=spread(W(:,1,:),dim=2,ncopies=2) + W(:,this%imL+1:this%imL+2,:)=spread(W(:,this%imL,:),dim=2,ncopies=2) + W(:,:,-1:0)=spread(W(:,:,1),dim=3,ncopies=2) + W(:,:,this%jmL+1:this%jmL+2)=spread(W(:,:,this%jmL),dim=3,ncopies=2) +else + W(:,-1:0,:)=0 + W(:,this%imL+1:this%imL+2,:)=0 + W(:,:,-1:0)=0 + W(:,:,this%jmL+1:this%jmL+2)=0 +endif + write(6,*)'thinkdeb253 4 W is ',minval(W),' ',maxval(W)! write(6,*)'thinkdeb253 4 Wnorm is ',minval(Wnorm),' ',maxval(Wnorm)! diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 23444bc00..74f63f5b6 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -842,7 +842,7 @@ module subroutine adjoint_normalized & 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%im+1,0:this%jm+1), 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 & @@ -1352,6 +1352,7 @@ subroutine def_mg_weights(this) gen_fac=1. !cltorg this%a_diff_f(:,:,:)=this%mg_weig1 write(6,*)'thinkdeb256 weigh1 ',this%mg_weig1,maxval(this%weig_var(:,:,:,1)),maxval(this%weig_var(:,:,:,1)) +if(this%l_mgbf_inhomogeneous ) then this%a_diff_f(:,:,:)=this%weig_var(:,:,:,1) !cltorg this%a_diff_h(:,:,:)=this%mg_weig1 this%a_diff_h(:,:,:)=this%weig_var(:,:,:,1) @@ -1362,17 +1363,34 @@ subroutine def_mg_weights(this) select case(this%my_hgen) case(2) !cltorg this%a_diff_h(:,:,:)=this%mg_weig2 -write(6,*)'thinkdeb256 weigh2 ',this%mg_weig2,maxval(this%weig_var(:,:,:,2)),maxval(this%weig_var(:,:,:,2)) +write(6,*)'thinkdeb256 weigh2 ',this%mg_weig2,minval(this%weig_var(:,:,:,2)),maxval(this%weig_var(:,:,:,2)) this%a_diff_h(:,:,:)=this%weig_var(:,:,:,2) case(3) !cltorg this%a_diff_h(:,:,:)=this%mg_weig3 -write(6,*)'thinkdeb256 weigh3 ',this%mg_weig3,maxval(this%weig_var(:,:,:,3)),maxval(this%weig_var(:,:,:,3)) +write(6,*)'thinkdeb256 weigh3 ',this%mg_weig3,minval(this%weig_var(:,:,:,3)),maxval(this%weig_var(:,:,:,3)) this%a_diff_h(:,:,:)=this%weig_var(:,:,:,3) +write(6,*)'thinkdeb256 weigh3 1 ',this%weig_var(:,:,:,3) case default -write(6,*)'thinkdeb256 weigh4 ',this%mg_weig1,maxval(this%weig_var(:,:,:,4)),maxval(this%weig_var(:,:,:,4)) +write(6,*)'thinkdeb256 weigh4 ',this%mg_weig1,minval(this%weig_var(:,:,:,4)),maxval(this%weig_var(:,:,:,4)) !cltorg this%a_diff_h(:,:,:)=this%mg_weig4 this%a_diff_h(:,:,:)=this%weig_var(:,:,:,4) end select +else +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 + +endif do L=1,this%lm this%pasp1(1,1,L)=this%pasp01 diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index d3fe7acab..ecf561160 100755 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -40,6 +40,7 @@ module mg_parameter !----------------------------------------------------------------------- !*** logical:: l_for_localization=.false. !used for localizaiton while multiple variates need additional treeatment +logical:: l_mgbf_inhomogeneous=.false. !used inhomogeneous mgbf !*** Namelist parameters !*** real(r_kind):: mg_ampl01,mg_ampl02,mg_ampl03 @@ -493,6 +494,7 @@ subroutine init_mg_parameter(this,inputfilename) logical:: lquart=.false.,lhelm=.false. !clt what should be the default logical:: ldelta=.false. logical:: l_for_localization=.false. +logical:: l_mgbf_inhomogeneous=.false. integer(i_kind):: lm_a ! number of vertical layers in analysis fields integer(i_kind):: lm ! number of vertical layers in filter grids @@ -536,6 +538,7 @@ subroutine init_mg_parameter(this,inputfilename) ,l_vertical_filter & ,l_anal_sub_of_filt & ,l_for_localization,ldelta,lquart,lhelm & + , l_mgbf_inhomogeneous & ,gm_max & ,nm0,mm0 & ,nxPE,nyPE,im_filt,jm_filt , & @@ -579,6 +582,7 @@ subroutine init_mg_parameter(this,inputfilename) this%l_vertical_filter=l_vertical_filter this%l_anal_sub_of_filt=l_anal_sub_of_filt this%l_for_localization=l_for_localization + this%l_mgbf_inhomogeneous = l_mgbf_inhomogeneous this%ldelta=ldelta this%lquart=lquart this%lhelm=lhelm @@ -662,9 +666,12 @@ subroutine init_mg_parameter(this,inputfilename) ! this%km_a = this%km2+this%lm_a*this%km3 + write(6,*)'thinkdeb255 lm_a,km3,km2 ',this%km2,this%lm_a,this%km3 + write(6,*)'thinkdeb255 km_a ',this%km_a this%km = this%km2+this%lm *this%km3 this%km_a_all = this%km_a * this%n_ens + write(6,*)'thinkdeb255 km_a_all ',this%km_a_all this%km_all = this%km * this%n_ens this%km2_all = this%km2 * this%n_ens From 44f8f721e6a8f60f56261ed51d45aef93097ecb4 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 17 Mar 2025 20:05:32 +0000 Subject: [PATCH 027/199] enhanced mgbf interface to work with oops:: unstructured interpolator as the outer block --- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 128 ++++++++++++------------ 1 file changed, 65 insertions(+), 63 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 74f63f5b6..0def34a95 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1262,74 +1262,76 @@ subroutine def_mg_weights(this) allocate(sendcounts(this%nxpe*this%nype), displs(this%nxpe*this%nype)) allocate(weigh_tmp(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%weig_var=0. !clt first transform/upsend original mg_weigh_var to their correct locations -if(this%l_mg_weig_readin) then - dims=(/this%nxpe,this%nype/) - periods=(/0,0/) - nxloc=this%im - nyloc=this%jm - nz=this%km - nt=this%gm - allocate(loc_a(nxloc,nyloc,nz,nt)) - call MPI_CART_CREATE(MPI_COMM_WORLD, 2, dims, periods, .false., comm2d, ierr) - call MPI_COMM_RANK(comm2d, rank, ierr) - call MPI_CART_COORDS(comm2d, rank, 2, coords, ierr) - allocate(loc_a(nxloc,nyloc,nz,nt)) - if (rank == 0) then - allocate(weig_g(this%km,this%nm,this%mm,this%gm)) - !cltclt read in global_weight(nx,ny,km,ng) -else - allocate(weig_g(1,1,1,1)) - endif - do j = 0, this%nype - 1 - do i = 0, this%nxpe - 1 - sendcounts(i + j * this%nxpe) = nxloc * nyloc * this%km * nt - displs(i + j * this%nxpe) = ((i * nxloc) + (j * nyloc) * nxloc) * nz * nt +if(this%l_mgbf_inhomogeneous ) then + if(this%l_mg_weig_readin) then + dims=(/this%nxpe,this%nype/) + periods=(/0,0/) + nxloc=this%im + nyloc=this%jm + nz=this%km + nt=this%gm + allocate(loc_a(nxloc,nyloc,nz,nt)) + call MPI_CART_CREATE(MPI_COMM_WORLD, 2, dims, periods, .false., comm2d, ierr) + call MPI_COMM_RANK(comm2d, rank, ierr) + call MPI_CART_COORDS(comm2d, rank, 2, coords, ierr) + allocate(loc_a(nxloc,nyloc,nz,nt)) + if (rank == 0) then + allocate(weig_g(this%km,this%nm,this%mm,this%gm)) + !cltclt read in global_weight(nx,ny,km,ng) + else + allocate(weig_g(1,1,1,1)) + endif + do j = 0, this%nype - 1 + do i = 0, this%nxpe - 1 + sendcounts(i + j * this%nxpe) = nxloc * nyloc * this%km * nt + displs(i + j * this%nxpe) = ((i * nxloc) + (j * nyloc) * nxloc) * nz * nt + end do end do - end do - - call MPI_Scatterv(weig_g, sendcounts, displs, MPI_REAL, loc_a, nxloc * nyloc * nz * nt, MPI_REAL, 0, comm2d, ierr) - call MPI_COMM_FREE(comm2d, ierr) - do ig=1,this%gm - do k=1,this%km - this%weig_var(k,1:nxloc,1:nyloc,ig)=loc_a(:,:,k,ig) - enddo - enddo -!clt the following would have different results in corners when run on different order -!cltthink to be investigated further - do i=1-this%hx, 0 - this%weig_var(:,i,:,:)=this%weig_var(:,1,:,:) + + call MPI_Scatterv(weig_g, sendcounts, displs, MPI_REAL, loc_a, nxloc * nyloc * nz * nt, MPI_REAL, 0, comm2d, ierr) + call MPI_COMM_FREE(comm2d, ierr) + do ig=1,this%gm + do k=1,this%km + this%weig_var(k,1:nxloc,1:nyloc,ig)=loc_a(:,:,k,ig) + enddo enddo - do i=nxloc+1,nxloc+this%hx -!clt this%weig_var(:,nxloc+1:nxloc+this%hx,:,:)=this%weig_var(:,nxloc,:,:) - this%weig_var(:,i,:,:)=this%weig_var(:,nxloc,:,:) - enddo - do j=1-this%hy,0 -!cltorg this%weig_var(:,:,1-this%hy:0,:)=this%weig_var(:,:,1,:) - this%weig_var(:,:,j,:)=this%weig_var(:,:,1,:) - enddo - do j=nyloc+1,nyloc+this%hy -!clt this%weig_var(:,:,ny+1:ny+this%hy,:)=this%weig_var(:,:,ny,:) - this%weig_var(:,:,j,:)=this%weig_var(:,:,nyloc,:) - enddo -!clttothink -!clt to convert data in weigt_var to their correct locations + !clt the following would have different results in corners when run on different order + !cltthink to be investigated further + do i=1-this%hx, 0 + this%weig_var(:,i,:,:)=this%weig_var(:,1,:,:) + enddo + do i=nxloc+1,nxloc+this%hx + !clt this%weig_var(:,nxloc+1:nxloc+this%hx,:,:)=this%weig_var(:,nxloc,:,:) + this%weig_var(:,i,:,:)=this%weig_var(:,nxloc,:,:) + enddo + do j=1-this%hy,0 + !cltorg this%weig_var(:,:,1-this%hy:0,:)=this%weig_var(:,:,1,:) + this%weig_var(:,:,j,:)=this%weig_var(:,:,1,:) + enddo + do j=nyloc+1,nyloc+this%hy + !clt this%weig_var(:,:,ny+1:ny+this%hy,:)=this%weig_var(:,:,ny,:) + this%weig_var(:,:,j,:)=this%weig_var(:,:,nyloc,:) + enddo + !clttothink + !clt to convert data in weigt_var to their correct locations + do ig=start_idx,end_idx + weigh_tmp=this%weig_var(:,:,:,ig) + call this%upsending_normalized(weigh_tmp,this%weig_var(:,:,:,ig)) + enddo + + deallocate(weig_g,weigh_tmp) + else + allocate(par_weig_g(4)) + par_weig_g=(/this%mg_weig1,this%mg_weig2,this%mg_weig3,this%mg_weig4/) do ig=start_idx,end_idx - weigh_tmp=this%weig_var(:,:,:,ig) - call this%upsending_normalized(weigh_tmp,this%weig_var(:,:,:,ig)) + write(6,*)'thinkdeb255 par_weig_g(ig) ',par_weig_g(ig) + weigh_tmp=par_weig_g(ig) + call this%upsending_normalized(weigh_tmp,this%weig_var(:,:,:,ig)) + !clto call this%upsending(weigh_tmp,this%weig_var(:,:,:,ig)) enddo - deallocate(weig_g,weigh_tmp) -else - allocate(par_weig_g(4)) - par_weig_g=(/this%mg_weig1,this%mg_weig2,this%mg_weig3,this%mg_weig4/) - do ig=start_idx,end_idx - write(6,*)'thinkdeb255 par_weig_g(ig) ',par_weig_g(ig) - weigh_tmp=par_weig_g(ig) - call this%upsending_normalized(weigh_tmp,this%weig_var(:,:,:,ig)) -!clto call this%upsending(weigh_tmp,this%weig_var(:,:,:,ig)) - enddo - - deallocate(par_weig_g) + deallocate(par_weig_g) + endif endif deallocate(sendcounts, displs) From b000a461f854ff9240d4c0453b1ec7d5e32ad673 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sun, 30 Mar 2025 14:21:06 +0000 Subject: [PATCH 028/199] adding treatment for halo point inside mgbf interface (c++) --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 79 ++++++++++++++++--- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 11 ++- src/saber/mgbf/mgbf_lib/mgbf_util.f90 | 47 +++++++++++ 3 files changed, 123 insertions(+), 14 deletions(-) create mode 100644 src/saber/mgbf/mgbf_lib/mgbf_util.f90 diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 244312db7..ae8bf6c3c 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -9,6 +9,7 @@ module mgbf_covariance_mod ! atlas use atlas_module, only: atlas_fieldset, atlas_field use atlas_module, only: atlas_functionspace +use atlas_module, only: atlas_functionspace_StructuredColumns ! fckit use fckit_mpi_module, only: fckit_mpi_comm @@ -23,6 +24,7 @@ module mgbf_covariance_mod use mg_intstate , only: mg_intstate_type use mg_timers +use mpi implicit none private public mgbf_covariance @@ -204,7 +206,11 @@ subroutine multiply(self, fields) integer(kind=i_kind)::itest=0 character(len=32) :: fileoutput character(len=4) :: str_rank - +integer :: n_owned_size +integer, pointer :: ghost(:) +!clttype(atlas_FunctionSpace) :: fs +type(atlas_functionspace_StructuredColumns) :: fs +integer :: ierr !clt now noly consider t @@ -254,23 +260,41 @@ subroutine multiply(self, fields) do isize=1,fields%size() afield= fields%field(isize) !clttodo + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug if(afield%rank() == 2) then nz=afield%levels() call afield%data(ptr_2d) if(nz == 1) then if(self%intstate%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + if(n_owned_size >0 ) then + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + endif else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif endif else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif endif else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif endif if(nz > 1) l3d_encountered=.true. @@ -367,27 +391,62 @@ subroutine multiply(self, fields) work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) enddo ilev=1 + n_owned_size=0 do isize=1,fields%size() afield=fields%field(isize) !clttodo + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug if(afield%rank() == 2) then call afield%data(ptr_2d) nz=afield%levels() lev1=varvlev_index(isize,1) if(nz.gt.1) then - write(6,*)'thinkdeb2552 dimension of ptr_2d are ',size(ptr_2d,1), ' ',size(ptr_2d,2) - ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) +! if(n_owned_size == 0) then +! do i = 1, size(ghost) +! if (ghost(i) == 0) then + ! This point is owned (not a halo point) +! n_owned_size=n_owned_size+1 +! endif +! end do +!! write(6,*)'thinkdeb2552 dimension of ptr_2d are ',size(ptr_2d,1), ' ',size(ptr_2d,2) +! endif + write(6,*)'thinkdeb2553 dimension of 2 dimensio of ptr_2d,work2d are ',size(ptr_2d,2), ' ',size(work2d_mgbf,2) + write(6,*)'thinkdeb2552 n_owned_size ',n_owned_size,' ','total size is ' ,size(ptr_2d,2) + call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb + if(n_owned_size >0 ) then + ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif else if(self%intstate%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level write(6,*)'thinkdeb2553 dimension of 2 dimensio of ptr_2d,work2d are ',size(ptr_2d,2), ' ',size(work2d_mgbf,2) - ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif else - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif endif else - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif endif endif diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 0def34a95..abdb06b2c 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1252,6 +1252,7 @@ subroutine def_mg_weights(this) integer :: dims(2), periods(2), coords(2) integer(i_kind):: nxloc,nyloc,nz,nt,start_idx,end_idx integer(i_kind):: ig +character*72 tmpfilename !----------------------------------------------------------------------- start_idx=Lbound(this%weig_var,4) end_idx=Ubound(this%weig_var,4) @@ -1353,7 +1354,8 @@ subroutine def_mg_weights(this) !-------------------------------------------------------- gen_fac=1. !cltorg this%a_diff_f(:,:,:)=this%mg_weig1 -write(6,*)'thinkdeb256 weigh1 ',this%mg_weig1,maxval(this%weig_var(:,:,:,1)),maxval(this%weig_var(:,:,:,1)) +write(tmpfilename, '("mgbf_tmpfile_", I0, ".txt")') this%mype +open(12,file=trim(tmpfilename),form="formatted") if(this%l_mgbf_inhomogeneous ) then this%a_diff_f(:,:,:)=this%weig_var(:,:,:,1) !cltorg this%a_diff_h(:,:,:)=this%mg_weig1 @@ -1365,18 +1367,19 @@ subroutine def_mg_weights(this) select case(this%my_hgen) case(2) !cltorg this%a_diff_h(:,:,:)=this%mg_weig2 -write(6,*)'thinkdeb256 weigh2 ',this%mg_weig2,minval(this%weig_var(:,:,:,2)),maxval(this%weig_var(:,:,:,2)) +write(12,*)'thinkdeb256 weigh2 ',this%mg_weig2,minval(this%weig_var(:,:,:,2)),(this%weig_var(:,:,:,2)) this%a_diff_h(:,:,:)=this%weig_var(:,:,:,2) case(3) !cltorg this%a_diff_h(:,:,:)=this%mg_weig3 -write(6,*)'thinkdeb256 weigh3 ',this%mg_weig3,minval(this%weig_var(:,:,:,3)),maxval(this%weig_var(:,:,:,3)) +write(12,*)'thinkdeb256 weigh3 ',this%mg_weig3,minval(this%weig_var(:,:,:,3)),(this%weig_var(:,:,:,3)) this%a_diff_h(:,:,:)=this%weig_var(:,:,:,3) write(6,*)'thinkdeb256 weigh3 1 ',this%weig_var(:,:,:,3) case default -write(6,*)'thinkdeb256 weigh4 ',this%mg_weig1,minval(this%weig_var(:,:,:,4)),maxval(this%weig_var(:,:,:,4)) +write(12,*)'thinkdeb256 weigh4 ',this%mg_weig1,minval(this%weig_var(:,:,:,4)),(this%weig_var(:,:,:,4)) !cltorg this%a_diff_h(:,:,:)=this%mg_weig4 this%a_diff_h(:,:,:)=this%weig_var(:,:,:,4) end select +close (12) else this%a_diff_h(:,:,:)=this%mg_weig1 diff --git a/src/saber/mgbf/mgbf_lib/mgbf_util.f90 b/src/saber/mgbf/mgbf_lib/mgbf_util.f90 new file mode 100644 index 000000000..094738662 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/mgbf_util.f90 @@ -0,0 +1,47 @@ +module mgbf_utils +use mgbf_kinds,only: r_kind, i_kind +implicit none +private +public :: contains_nonzero + +interface contains_nonzero + module procedure contains_nonzero_real + module procedure contains_nonzero_integer +end interface +contains + +logical function contains_nonzero_real(array) result(has_nonzero) + real(r_kind), intent(in) :: array(:, :, :) ! Declare 3D array + integer(i_kind) :: i, j, k + + has_nonzero = .false. + do k = 1, size(array, 3) ! Loop over third dimension + do j = 1, size(array, 2) ! Loop over second dimension + do i = 1, size(array, 1) ! Loop over first dimension + if (array(i, j, k) /= 0.0) then + has_nonzero = .true. + return + end if + end do + end do + end do +end function contains_nonzero_real + +logical function contains_nonzero_integer(array) result(has_nonzero) + integer(i_kind), intent(in) :: array(:, :, :) ! Declare 3D array + integer(i_kind) :: i, j, k + + has_nonzero = .false. + do k = 1, size(array, 3) ! Loop over third dimension + do j = 1, size(array, 2) ! Loop over second dimension + do i = 1, size(array, 1) ! Loop over first dimension + if (array(i, j, k) /= 0) then + has_nonzero = .true. + return + end if + end do + end do + end do +end function contains_nonzero_integer +end module mgbf_utils + From daf4a4a071cbb4d5f91068ae13a82e94a91c417a Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sun, 30 Mar 2025 14:22:18 +0000 Subject: [PATCH 029/199] adding treatment for halo point inside mgbf interface (c++) --- src/saber/mgbf/covariance/MGBF_Covariance.h | 7 +++++ .../mgbf/covariance/mgbf_covariance_mod.f90 | 28 +++++++++++++++++-- test/CMakeLists.txt | 1 + 3 files changed, 33 insertions(+), 3 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index 27eb7d544..84caaebb4 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -203,6 +203,13 @@ void MGBF_Covariance::multiply(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiply starting" << std::endl; util::Timer timer(classname(), "multiply"); mgbf_covariance_multiply_f90(keySelf_, fset.get()); + // Mark all fields as having dirty halos after modification + for (const auto & fieldname : fset.field_names()) { + atlas::Field field = fset[fieldname]; + field.set_dirty(); // Mark field as having dirty halos that need to be synchronized + } + // Perform the actual halo exchange + fset.fieldSet().haloExchange(); oops::Log::trace() << classname() << "::multiply done" << std::endl; } diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index ae8bf6c3c..7fcaaabad 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -25,6 +25,7 @@ module mgbf_covariance_mod use mg_timers use mpi +use, intrinsic :: ieee_arithmetic implicit none private public mgbf_covariance @@ -211,7 +212,7 @@ subroutine multiply(self, fields) !clttype(atlas_FunctionSpace) :: fs type(atlas_functionspace_StructuredColumns) :: fs integer :: ierr - +real(kind=8) :: val !clt now noly consider t ! afield = fields%field('air_temperature') @@ -265,6 +266,28 @@ subroutine multiply(self, fields) if(afield%rank() == 2) then nz=afield%levels() call afield%data(ptr_2d) + do k=1,nz + do i=1,n_owned_size + val=ptr_2d(k,i) + if (ieee_is_nan(val)) then + print *, '[Fortran] ❗ NaN detected in value' + elseif (ieee_is_finite(val) .eqv. .false.) then + print *, '[Fortran] ❗ Inf detected in value' + elseif (abs(val) > 1.0e20) then + print *, '[Fortran] ⚠️ Suspicious large value:', val + endif + enddo + do i=n_owned_size+1,size(ptr_2d,2) + val=ptr_2d(k,i) + if (ieee_is_nan(val)) then + print *, '[Fortran]2 ❗ NaN detected in value' + elseif (ieee_is_finite(val) .eqv. .false.) then + print *, '[Fortran]2 ❗ Inf detected in value' + elseif (abs(val) > 1.0e20) then + print *, '[Fortran]2 ⚠️ Suspicious large value:', val + endif + enddo + enddo if(nz == 1) then if(self%intstate%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level @@ -339,6 +362,7 @@ subroutine multiply(self, fields) stop endif enddo + return !cltthinkdeb do k=1,nzloc work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) @@ -347,7 +371,6 @@ subroutine multiply(self, fields) write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added endif - if(test_once.and..1.gt.2) then open(iounit,file=trim(fileoutput), status='replace',form="formatted") write(iounit,*) work_mgbf @@ -413,7 +436,6 @@ subroutine multiply(self, fields) ! endif write(6,*)'thinkdeb2553 dimension of 2 dimensio of ptr_2d,work2d are ',size(ptr_2d,2), ' ',size(work2d_mgbf,2) write(6,*)'thinkdeb2552 n_owned_size ',n_owned_size,' ','total size is ' ,size(ptr_2d,2) - call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb if(n_owned_size >0 ) then ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) else diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 40d6e288b..97cc97d11 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -33,6 +33,7 @@ if( ENABLE_QUENCH ) set( SABER_TEST_VALGRIND 0 ) set( SABER_TEST_FASTLAM 1 ) set( SABER_TEST_GSI_GEOS 0 ) + set( SABER_TEST_MGBF 0 ) if( gsibec_FOUND ) set( SABER_TEST_GSI_GEOS 1 ) endif() From a95663643f52cfb628f68a04e0fe3edc4cfccea6 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sun, 30 Mar 2025 14:42:47 +0000 Subject: [PATCH 030/199] update interface for gsi:: interpolator --- src/saber/interpolation/Interpolation.cc | 18 +++++++++++++++++- .../mgbf/covariance/mgbf_Interpolation.cc | 1 - .../mgbf/covariance/mgbf_covariance_mod.f90 | 1 - 3 files changed, 17 insertions(+), 3 deletions(-) diff --git a/src/saber/interpolation/Interpolation.cc b/src/saber/interpolation/Interpolation.cc index ea584c8a1..ef35c0273 100644 --- a/src/saber/interpolation/Interpolation.cc +++ b/src/saber/interpolation/Interpolation.cc @@ -11,6 +11,8 @@ #include "oops/util/FieldSetOperations.h" #include "oops/util/Logger.h" +#include "mpi.h" //cltthinkdeb todo +#include //cltthink namespace saber { namespace interpolation { @@ -32,7 +34,7 @@ Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, activeVars_(params.activeVars.value().get_value_or(outerVars)), invVars_(params.inverseVars.value()) { - oops::Log::trace() << classname() << "::Interpolation starting" << std::endl; + oops::Log::trace() << classname() << "::Interpolationthinkdeb555 starting" << std::endl; // Set up GeometryData Geometry geom(params.innerGeom, outerGeometryData.comm()); @@ -44,10 +46,24 @@ Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, globalInterp_.reset(new oops::GlobalInterpolator( params.forwardInterpConf.value(), *innerGeomData_, outerGeometryData.functionSpace(), outerGeometryData.comm())); + int mpirank; + MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); + std::ofstream file("mgbf_filtering_grid_latlon_"+std::to_string(mpirank)+".txt"); + innerGeomData_->functionSpace().lonlat().dump(file); + std::ofstream file2("model_native_grid_latlon_"+std::to_string(mpirank)+".txt"); + outerGeomData_.functionSpace().lonlat().dump(file2); } else if (params.interpType.value() == "regional") { regionalInterp_.reset(new atlas::Interpolation( + atlas::util::Config("type", "regional-linear-2d"), innerGeomData_->functionSpace(), outerGeomData_.functionSpace())); + int mpirank; + MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); + std::ofstream file("mgbf_filtering_grid_latlon_"+std::to_string(mpirank)+".txt"); + innerGeomData_->functionSpace().lonlat().dump(file); + std::ofstream file2("model_native_grid_latlon_"+std::to_string(mpirank)+".txt"); + outerGeomData_.functionSpace().lonlat().dump(file2); + } else { throw eckit::UserError("wrong interpolator type: " + params.interpType.value(), Here()); } diff --git a/src/saber/mgbf/covariance/mgbf_Interpolation.cc b/src/saber/mgbf/covariance/mgbf_Interpolation.cc index d09bb6102..6c2575229 100755 --- a/src/saber/mgbf/covariance/mgbf_Interpolation.cc +++ b/src/saber/mgbf/covariance/mgbf_Interpolation.cc @@ -68,7 +68,6 @@ mgbf_Interpolation::mgbf_Interpolation(const oops::GeometryData & outerGeometryD params.toConfiguration(), innerGeometryData_->functionSpace(), outerGeometryData.functionSpace(), - activeVariableSizes, activeVars)); oops::Log::trace() << classname() << "mgbf::Interpolator constructor done" << std::endl; } diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 7fcaaabad..ec9cc0e32 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -362,7 +362,6 @@ subroutine multiply(self, fields) stop endif enddo - return !cltthinkdeb do k=1,nzloc work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) From 8d53c7b9657255e227e0b5281352c9ed53345143 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 3 Apr 2025 20:05:25 +0000 Subject: [PATCH 031/199] added mgbf ctest in saber --- test/CMakeLists.txt | 38 +++++++++- test/testdata/dirac_mgbf_reg_1.nml | 19 +++++ test/testinput/dirac_mgbf_reg_1.yaml | 79 +++++++++++++++++++++ test/testlist/saber_data.txt | 1 + test/testlist/saber_test_tier1-mgbf_reg.txt | 1 + 5 files changed, 137 insertions(+), 1 deletion(-) create mode 100755 test/testdata/dirac_mgbf_reg_1.nml create mode 100644 test/testinput/dirac_mgbf_reg_1.yaml create mode 100644 test/testlist/saber_test_tier1-mgbf_reg.txt diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 97cc97d11..2246de477 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -125,6 +125,11 @@ if( ENABLE_QUENCH ) list( APPEND saber_test_full ${saber_test} ) endif() endif() + if( SABER_TEST_MGBF_REG ) + message( STATUS " - TIER 1 MGBF-REG" ) + file( STRINGS testlist/saber_test_tier1-mgbf_reg.txt saber_test ) + list( APPEND saber_test_full ${saber_test} ) + endif() # TIER > 1 if( SABER_TEST_TIER GREATER 1 ) @@ -249,8 +254,15 @@ if( ENABLE_QUENCH ) set (parallelHybridCheck false CACHE BOOL "" FORCE ) endif() endif() + # check for MGBF, it will be dealt with seperately for them to require more mpi ranks + string( FIND ${test} "mgbf" mgbf_result ) + if( mgbf_result EQUAL -1 ) + set( mgbfCheck true CACHE BOOL "" FORCE ) + else() + set( mgbfCheck false CACHE BOOL "" FORCE ) + endif() - if( docTutorialCheck AND gsiGfsCheck AND 4dCheck AND parallelHybridCheck ) + if( docTutorialCheck AND gsiGfsCheck AND 4dCheck AND parallelHybridCheck AND mgbfCheck ) # Get dependencies file( STRINGS testdeps/${test}.txt deps ) set( deps_list "" ) @@ -320,6 +332,30 @@ if( ENABLE_QUENCH ) endif() endforeach() endforeach() +# GSI scaling optimization for HDIAG +foreach( test ${saber_test_full} ) + string( FIND ${test} "mgbf" result ) + if( result MATCHES 0 AND ${mpi} LESS_EQUAL 2 ) + # Get dependencies + file( STRINGS testdeps/${test}.txt deps ) + set( deps_list "" ) + list( APPEND deps_list ${deps} ) + list( LENGTH deps_list deps_length ) + if( ${deps_length} GREATER 0 ) + list( TRANSFORM deps_list PREPEND saber_test_ ) + list( TRANSFORM deps_list APPEND _${mpi}-${omp} ) + endif() + + # Add test + ecbuild_add_test( TARGET saber_test_${test}_${mpi}-${omp} + MPI 4 + OMP 1 + COMMAND ${CMAKE_BINARY_DIR}/bin/saber_quench_error_covariance_toolbox.x + ARGS testinput/${yaml_prefix}${test}.yaml + DEPENDS saber_quench_error_covariance_toolbox.x + ) + endif() +endforeach() else() # Tests deactivated message( STATUS "SABER-QUENCH tests deactivated" ) diff --git a/test/testdata/dirac_mgbf_reg_1.nml b/test/testdata/dirac_mgbf_reg_1.nml new file mode 100755 index 000000000..7a9b1a707 --- /dev/null +++ b/test/testdata/dirac_mgbf_reg_1.nml @@ -0,0 +1,19 @@ +&PARAMETERS_MGBETA + mg_ampl01=4.0,mg_ampl02=5.0,mg_ampl03=2.0, + mg_weig1=16.,mg_weig2=248.,mg_weig3=128.,mg_weig4=1., + hx=6,hy=6,hz=6,p=2, + mgbf_line=.true., mgbf_proc=4, + lm_a=8,lm=8,km2=0,km3=1, + coef_normalization_const=7.81173466 +! + nxPE=2,nyPE=2,im_filt=12,jm_filt=12, +! +!GSI - REDUCED DOMAIN + nm0 = 24, + mm0 = 24, + + l_vertical_filter=.true. + l_for_localization=.false., +/ +~ + diff --git a/test/testinput/dirac_mgbf_reg_1.yaml b/test/testinput/dirac_mgbf_reg_1.yaml new file mode 100644 index 000000000..253ce84e0 --- /dev/null +++ b/test/testinput/dirac_mgbf_reg_1.yaml @@ -0,0 +1,79 @@ +geometry: + function space: StructuredColumns + grid: + type : "regional" + nx : 16 + ny : 16 + dx : 30.0e3 + dy : 30.0e3 + lonlat(centre) : [261,40] + projection : + type : lambert_conformal_conic + latitude0 : 40 + longitude0 : 261 + units: "degrees" + y_numbering : 1 + partitioner: checkerboard + groups: + - variables: + - air_horizontal_streamfunction + levels: 8 + + halo: 1 + +background: + date: '2010-01-01T12:00:00Z' + state variables: + - air_horizontal_streamfunction +background error: + covariance model: SABER + saber central block: + saber block name: ID + saber central block: + saber block name: MGBF_covariance + mgbf namelist file: dirac_mgbf_reg_1.nml + + saber outer blocks: + - saber block name: interpolation + inner geometry: + function space: StructuredColumns + grid: + type : "regional" + nx : 24 + ny : 24 + dx : 30.0e3 + dy : 30.0e3 + lonlat(centre) : [261,40] + projection : + type : lambert_conformal_conic + latitude0 : 40 + longitude0 : 261 + units: "degrees" + y_numbering : 1 + partitioner: checkerboard + groups: + - variables: + - air_horizontal_streamfunction + levels: 8 + halo: 1 + + forward interpolator: + local interpolator type: oops unstructured grid interpolator + inverse interpolator: + local interpolator type: oops unstructured grid interpolator + active variables: + - air_horizontal_streamfunction +dirac: + lon: + - 261.0 + lat: + - 40.0 + level: + - 5 + variable: + - air_horizontal_streamfunction +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/dirac_mgbf_1/dirac_%id%_%MPI% +test: + reference filename: testref/dirac_mgbf_1.ref diff --git a/test/testlist/saber_data.txt b/test/testlist/saber_data.txt index 5169e0338..8dd7e1dd8 100644 --- a/test/testlist/saber_data.txt +++ b/test/testlist/saber_data.txt @@ -17,3 +17,4 @@ MIO_coefficients.nc MUstats.nc ptheta_bar_mean.nc Prho_bar_Mean.nc +dirac_mgbf_reg_1.nml diff --git a/test/testlist/saber_test_tier1-mgbf_reg.txt b/test/testlist/saber_test_tier1-mgbf_reg.txt new file mode 100644 index 000000000..afe388100 --- /dev/null +++ b/test/testlist/saber_test_tier1-mgbf_reg.txt @@ -0,0 +1 @@ +dirac_mgbf_reg_1 From a7ea45a39dbf20faed7f9cd9fdce405af0f07ada Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 9 May 2025 19:55:06 +0000 Subject: [PATCH 032/199] add mgbf ctest --- test/CMakeLists.txt | 6 +++--- test/testdeps/dirac_mgbf_reg_1.txt | 0 2 files changed, 3 insertions(+), 3 deletions(-) create mode 100644 test/testdeps/dirac_mgbf_reg_1.txt diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 2246de477..fbd57ddd1 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -33,7 +33,7 @@ if( ENABLE_QUENCH ) set( SABER_TEST_VALGRIND 0 ) set( SABER_TEST_FASTLAM 1 ) set( SABER_TEST_GSI_GEOS 0 ) - set( SABER_TEST_MGBF 0 ) + set( SABER_TEST_MGBF_REG 1 ) if( gsibec_FOUND ) set( SABER_TEST_GSI_GEOS 1 ) endif() @@ -332,10 +332,10 @@ if( ENABLE_QUENCH ) endif() endforeach() endforeach() -# GSI scaling optimization for HDIAG +# mgbf foreach( test ${saber_test_full} ) string( FIND ${test} "mgbf" result ) - if( result MATCHES 0 AND ${mpi} LESS_EQUAL 2 ) + if( NOT result EQUAL -1 ) # Get dependencies file( STRINGS testdeps/${test}.txt deps ) set( deps_list "" ) diff --git a/test/testdeps/dirac_mgbf_reg_1.txt b/test/testdeps/dirac_mgbf_reg_1.txt new file mode 100644 index 000000000..e69de29bb From 2acd0e63ffb74074f11821280107327aaef48a25 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 9 May 2025 21:28:55 +0000 Subject: [PATCH 033/199] remove mgbf_grid and mgbf_interpolation --- src/saber/mgbf/covariance/mgbf_Grid.cc | 28 ---- src/saber/mgbf/covariance/mgbf_Grid.h | 107 --------------- .../mgbf/covariance/mgbf_Interpolation.cc | 127 ------------------ .../mgbf/covariance/mgbf_Interpolation.h | 110 --------------- 4 files changed, 372 deletions(-) delete mode 100755 src/saber/mgbf/covariance/mgbf_Grid.cc delete mode 100755 src/saber/mgbf/covariance/mgbf_Grid.h delete mode 100755 src/saber/mgbf/covariance/mgbf_Interpolation.cc delete mode 100755 src/saber/mgbf/covariance/mgbf_Interpolation.h diff --git a/src/saber/mgbf/covariance/mgbf_Grid.cc b/src/saber/mgbf/covariance/mgbf_Grid.cc deleted file mode 100755 index b06f86cb3..000000000 --- a/src/saber/mgbf/covariance/mgbf_Grid.cc +++ /dev/null @@ -1,28 +0,0 @@ -/* - * (C) Copyright 2022 United States Government as represented by the Administrator of the National - * Aeronautics and Space Administration - * - * This software is licensed under the terms of the Apache Licence Version 2.0 - * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. - */ - - -#include -#include - -//#include "atlas/field.h" -//#include "atlas/functionspace.h" - -//#include "oops/util/Logger.h" -//#include "oops/util/Timer.h" - - -namespace saber { -namespace mgbf { - -// ------------------------------------------------------------------------------------------------- - -// ------------------------------------------------------------------------------------------------- - -} // namespace mgbf -} // namespace saber diff --git a/src/saber/mgbf/covariance/mgbf_Grid.h b/src/saber/mgbf/covariance/mgbf_Grid.h deleted file mode 100755 index 38b68bdbb..000000000 --- a/src/saber/mgbf/covariance/mgbf_Grid.h +++ /dev/null @@ -1,107 +0,0 @@ -/* - * (C) Copyright 2022 United States Government as represented by the Administrator of the National - * Aeronautics and Space Administration - * - * This software is licensed under the terms of the Apache Licence Version 2.0 - * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. - */ - -#pragma once - -#include -#include - -#include "atlas/field.h" -#include "atlas/functionspace.h" -#include "atlas/grid.h" - -#include "oops/util/parameters/Parameter.h" -#include "oops/util/parameters/Parameters.h" -#include "oops/util/parameters/RequiredParameter.h" -#include //clt -#include "mpi.h" -#include - -//cltorg modified from gsi/Grid.h - -namespace saber { -namespace mgbf { - -// ------------------------------------------------------------------------------------------------- - -class mgbfGridParameters : public oops::Parameters { - OOPS_CONCRETE_PARAMETERS(mgbfGridParameters, Parameters) -}; - -// ------------------------------------------------------------------------------------------------- - -class mgbfGrid { - public: - static const std::string classname() {return "saber::mgbf::mgbfGrid";} - - // Constructor & destructor - mgbfGrid(const eckit::mpi::Comm &, const eckit::Configuration &); - ~mgbfGrid(); - - // Accessor functions -//clt int levels() {return gsiLevels_;} - const atlas::FunctionSpace & functionSpace() const {return mgbfFuncSpace_;} - atlas::FunctionSpace & functionSpace() {return mgbfFuncSpace_;} - - private: - void print(std::ostream &) const; - // Fortran LinkedList key -//clt GridKey keySelf_; - // Function spaces - atlas::FunctionSpace mgbfFuncSpace_; - // Number of levels - int mgbfLevels_; -}; - -mgbfGrid::mgbfGrid(const eckit::mpi::Comm & comm, const eckit::Configuration & conf) -{ - oops::Log::trace() << classname() << "::Grid starting" << std::endl; - oops::Log::trace()<<"mgbf config is "< -#include -#include - -#include "atlas/field.h" -#include "atlas/library.h" -#include "atlas/runtime/Log.h" - -#include "oops/base/Variables.h" - -#include "saber/blocks/SaberOuterBlockBase.h" -#include "saber/mgbf/covariance/mgbf_Grid.h" - -#include "saber/oops/Utilities.h" - -namespace saber { -namespace mgbf { - -// ------------------------------------------------------------------------------------------------- - -//clt template -static SaberOuterBlockMaker makerInterpolation_("mgbf interpolation to model grid"); - -// ------------------------------------------------------------------------------------------------- - -//clt mgbfInterpolation::mgbfInterpolation(const oops::GeometryData & outerGeometryData, -mgbf_Interpolation::mgbf_Interpolation(const oops::GeometryData & outerGeometryData, - const oops::Variables & outerVars, - const eckit::Configuration & covarConf, - const Parameters_ & params, - const oops::FieldSet3D & xb, - const oops::FieldSet3D & fg) - : SaberOuterBlockBase(params, xb.validTime()), innerVars_(outerVars) - -{ - oops::Log::trace() << classname() << "::mgbf_Interpolation constructor starting" << std::endl; - util::Timer timer(classname(), "MGBF Interpolation"); - - // Grid - oops::Log::trace()<<"in mgbf interp params "< activeVariableSizes; - for (const auto & var : activeVars) { - activeVariableSizes.push_back(var.getLevels()); - } - oops::Log::trace()<<"in mgbf interp before interpolator "<functionSpace(), - outerGeometryData.functionSpace(), - activeVars)); - oops::Log::trace() << classname() << "mgbf::Interpolator constructor done" << std::endl; -} - -// ------------------------------------------------------------------------------------------------- - -mgbf_Interpolation::~mgbf_Interpolation() { - oops::Log::trace() << classname() << "::~mgbfInterpolation starting" << std::endl; - util::Timer timer(classname(), "~mgbfInterpolation"); - oops::Log::trace() << classname() << "::~mgbfInterpolation done" << std::endl; -} - -// ------------------------------------------------------------------------------------------------- - -void mgbf_Interpolation::multiply(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::multiply starting <apply(fset.fieldSet()); -// std::cout <<"mgbf_Interpolation::multiply starting 2 fset" << std::endl; -// fset.print(std::cout) ; - oops::Log::trace() << "mgbf_Interpolation::multiply done" << std::endl; -} - -// ------------------------------------------------------------------------------------------------- - -void mgbf_Interpolation::multiplyAD(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; -// std::cout<<"thinkdeb mgbf::interpolation::mutliplyAD cout<applyAD(fset.fieldSet()); -// std::cout<<"thinkdeb after mgbf::interpolation::mutliplyAD cout<apply(fset.fieldSet()); - oops::Log::trace() << classname() << "::leftInverseMultiply done" << std::endl; -} */ - -// ------------------------------------------------------------------------------------------------- - -void mgbf_Interpolation::print(std::ostream & os) const { - os << classname(); -} - -// ------------------------------------------------------------------------------------------------- - -} // namespace mgbf -} // namespace saber diff --git a/src/saber/mgbf/covariance/mgbf_Interpolation.h b/src/saber/mgbf/covariance/mgbf_Interpolation.h deleted file mode 100755 index a8ff170b0..000000000 --- a/src/saber/mgbf/covariance/mgbf_Interpolation.h +++ /dev/null @@ -1,110 +0,0 @@ -/* - * (C) Copyright 2022 United States Government as represented by the Administrator of the National - * Aeronautics and Space Administration - * - * This software is licensed under the terms of the Apache Licence Version 2.0 - * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. - */ - -#pragma once -#include "saber/mgbf/covariance/mgbf_Interpolation.h" - -#include -#include -#include - -#include "atlas/field.h" -#include "atlas/functionspace.h" - -#include "atlas/library.h" -#include "atlas/runtime/Log.h" - -#include "oops/base/GeometryData.h" -#include "oops/base/Variables.h" -#include "oops/util/parameters/OptionalParameter.h" -#include "oops/util/parameters/Parameter.h" -#include "oops/util/parameters/Parameters.h" -#include "oops/util/parameters/RequiredParameter.h" - -#include "saber/blocks/SaberBlockParametersBase.h" -#include "saber/blocks/SaberOuterBlockBase.h" -#include "oops/base/GeometryData.h" -#include "saber/gsi/interpolation/unstructured_interp/UnstructuredInterpolation.h" - - -namespace saber { -namespace mgbf { - -// ------------------------------------------------------------------------------------------------- -class mgbf_InterpolationParameters : public SaberBlockParametersBase { - OOPS_CONCRETE_PARAMETERS(mgbf_InterpolationParameters, SaberBlockParametersBase) - - public: - // File containing grid and coefficients -// lf oops::RequiredParameter mgbfFile{"mgbf error covariance file", this}; -// oops::RequiredParameter mgbfNML{"mgbf namelist file", this}; - oops::RequiredParameter mgbfgrid{"mgbf grid", this}; - - // Handle vertical top-2-bottom and vice-verse wrt to GSI - oops::Parameter vflip{"flip vertical grid", true, this}; - - // Processor layout - - // Debugging mode - oops::Parameter debugMode{"debugging mode", false, this}; - - // Mandatory active variables - oops::Variables mandatoryActiveVars() const override {return oops::Variables();} -}; - -// ------------------------------------------------------------------------------------------------- - -//clt template -class mgbf_Interpolation : public SaberOuterBlockBase { - public: - static const std::string classname() {return "saber::mgbf::Interpolation";} - - typedef mgbf_InterpolationParameters Parameters_; -//clt typedef T Interpolator_; - - mgbf_Interpolation(const oops::GeometryData &, - const oops::Variables &, - const eckit::Configuration &, - const Parameters_ &, - const oops::FieldSet3D &, - const oops::FieldSet3D &); - - - - - virtual ~mgbf_Interpolation(); -// source stuff are corresponding to stuff with the innner block -// target stuff are corresponding to stuff with the outer block - const oops::GeometryData & innerGeometryData() const override {return *innerGeometryData_;} - const oops::Variables & innerVars() const override {return innerVars_;} - const atlas::FunctionSpace outerFunctionspace ; - - void multiply(oops::FieldSet3D &) const override; - void multiplyAD(oops::FieldSet3D &) const override; - void leftInverseMultiply(oops::FieldSet3D &) const override - { -//clt to timplement - } - - private: - void print(std::ostream &) const override; - std::unique_ptr innerGeometryData_; - oops::Variables innerVars_; - - // Interpolation object - // clt follow examples in gsi::interpolation - std::unique_ptr interpolator_; - - // Inverse interpolation object (need adjoint) - std::unique_ptr inverseInterpolator_; -}; - -// ------------------------------------------------------------------------------------------------- - -} // namespace mgbf -} // namespace saber From 7a0320ac1102263c3ac64f75d034c1bc25f33190 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 30 May 2025 18:08:05 +0000 Subject: [PATCH 034/199] fix to remove hard wired enforced zero of a_diff_f (used as the weght of first generation) --- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index abdb06b2c..2a3b7ba3d 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1381,10 +1381,9 @@ subroutine def_mg_weights(this) end select close (12) else -this%a_diff_h(:,:,:)=this%mg_weig1 +this%a_diff_f(:,:,:)=this%mg_weig1 this%b_diff_f(:,:,:)=0. -this%b_diff_h(:,:,:)=0. select case(this%my_hgen) case(2) From c12e109e7f64485afc696c63fa434bc5a733de2a Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 13 Jun 2025 14:32:40 +0000 Subject: [PATCH 035/199] commented out some debug print lines --- src/saber/mgbf/CMakeLists.txt | 10 ++-- .../mgbf/covariance/mgbf_covariance_mod.f90 | 50 +++++++++---------- src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 12 ++--- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 6 +-- src/saber/mgbf/mgbf_lib/mg_timers.f90 | 4 +- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 10 ++-- 6 files changed, 46 insertions(+), 46 deletions(-) diff --git a/src/saber/mgbf/CMakeLists.txt b/src/saber/mgbf/CMakeLists.txt index 8f26850b9..132314786 100755 --- a/src/saber/mgbf/CMakeLists.txt +++ b/src/saber/mgbf/CMakeLists.txt @@ -25,12 +25,12 @@ if( build_saber_mgbf ) covariance/MGBF_Covariance.interface.h covariance/mgbf_covariance_mod.f90 - # Grid - covariance/mgbf_Grid.h - covariance/mgbf_Grid.cc +#clth # Grid +# covariance/mgbf_Grid.h +# covariance/mgbf_Grid.cc # Interpolation block - covariance/mgbf_Interpolation.h - covariance/mgbf_Interpolation.cc +# covariance/mgbf_Interpolation.h +# covariance/mgbf_Interpolation.cc # interpolation/MGBF_Interpolation.h # Unstructured interpolation code ported from oops (until new interp code can be used) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index ec9cc0e32..4aa6f6108 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -242,7 +242,6 @@ subroutine multiply(self, fields) allocate(work_mgbf(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work_mgbf2(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) allocate(work2d_mgbf(self%intstate%km_a_all,self%intstate%nm*self%intstate%mm)) - write(6,*)"thinkdeb 2551 in covariance km_all is ",self%intstate%km_a_all allocate(rnormalization(self%intstate%km_a_all)) work2d_mgbf=0.0 rnormalization=1.0 @@ -266,28 +265,29 @@ subroutine multiply(self, fields) if(afield%rank() == 2) then nz=afield%levels() call afield%data(ptr_2d) - do k=1,nz - do i=1,n_owned_size - val=ptr_2d(k,i) - if (ieee_is_nan(val)) then - print *, '[Fortran] ❗ NaN detected in value' - elseif (ieee_is_finite(val) .eqv. .false.) then - print *, '[Fortran] ❗ Inf detected in value' - elseif (abs(val) > 1.0e20) then - print *, '[Fortran] ⚠️ Suspicious large value:', val - endif - enddo - do i=n_owned_size+1,size(ptr_2d,2) - val=ptr_2d(k,i) - if (ieee_is_nan(val)) then - print *, '[Fortran]2 ❗ NaN detected in value' - elseif (ieee_is_finite(val) .eqv. .false.) then - print *, '[Fortran]2 ❗ Inf detected in value' - elseif (abs(val) > 1.0e20) then - print *, '[Fortran]2 ⚠️ Suspicious large value:', val - endif - enddo - enddo +!clt do k=1,nz +!clt do i=1,n_owned_size + !clt val=ptr_2d(k,i) +!clt if (ieee_is_nan(val)) then + !clt print *, '[Fortran] ❗ NaN detected in value' + !clt elseif (ieee_is_finite(val) .eqv. .false.) then + !clt print *, '[Fortran] ❗ Inf detected in value' + !clt elseif (abs(val) > 1.0e20) then + !clt print *, '[Fortran] ⚠️ Suspicious large value:', val + !clt endif +!clt enddo +!clt do i=n_owned_size+1,size(ptr_2d,2) + !clt val=ptr_2d(k,i) +! if (ieee_is_nan(val)) then +! print *, '[Fortran]2 ❗ NaN detected in value' +!j elseif (ieee_is_finite(val) .eqv. .false.) then +! print *, '[Fortran]2 ❗ Inf detected in value' +! elseif (abs(val) > 1.0e20) then +! print *, '[Fortran]2 ⚠️ Suspicious large value:', val +! endif +! enddo +! enddo + if(nz == 1) then if(self%intstate%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level @@ -433,8 +433,7 @@ subroutine multiply(self, fields) ! end do !! write(6,*)'thinkdeb2552 dimension of ptr_2d are ',size(ptr_2d,1), ' ',size(ptr_2d,2) ! endif - write(6,*)'thinkdeb2553 dimension of 2 dimensio of ptr_2d,work2d are ',size(ptr_2d,2), ' ',size(work2d_mgbf,2) - write(6,*)'thinkdeb2552 n_owned_size ',n_owned_size,' ','total size is ' ,size(ptr_2d,2) +!clt write(6,*)'thinkdeb2552 n_owned_size ',n_owned_size,' ','total size is ' ,size(ptr_2d,2) if(n_owned_size >0 ) then ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) else @@ -445,7 +444,6 @@ subroutine multiply(self, fields) if(self%intstate%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - write(6,*)'thinkdeb2553 dimension of 2 dimensio of ptr_2d,work2d are ',size(ptr_2d,2), ' ',size(work2d_mgbf,2) call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb if(n_owned_size >0 ) then ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index 8b5f593a5..b4bfe754d 100755 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -66,11 +66,9 @@ module subroutine filtering_procedure(this,mg_filt,mg_filt_flag) include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !----------------------------------------------------------------------- - write(6,*)'thinkdeb filtering_procedure nxm,nym ',this%nxm,' ',this%nym if(this%nxm*this%nym>1) then select case(mg_filt) case(1) - write(6,*)'thinkdeb filtering_rad3 is used' call this%filtering_rad3 case(2) call this%filtering_lin3 @@ -514,7 +512,7 @@ module subroutine filtering_rad2(this) !fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - write(6,*)'thinkdeb33 2 ', km,im,jm,hx,hy +! write(6,*)'thinkdeb33 2 ', km,im,jm,hx,hy call this%bocoT_2d(VALL,km,im,jm,hx,hy) call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) @@ -742,7 +740,7 @@ module subroutine filtering_lin2(this) call dibetat(km,i0-hx,i0,im,im+hx, j0-hy,j0,jm,jm+hy, nfil, & dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HALL, ff, iout,jout) endif - write(6,*)'thinkdeb33 5 ', km,im,jm,hx,hy +! write(6,*)'thinkdeb33 5 ', km,im,jm,hx,hy call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) enddo ! @@ -759,7 +757,7 @@ module subroutine filtering_lin2(this) call this%composite_to_stack(HM2D,HM3D,HALL) endif - write(6,*)'thinkdeb33 6 ', km,im,jm,hx,hy +! write(6,*)'thinkdeb33 6 ', km,im,jm,hx,hy call this%bocoT_2d(VALL,km,im,jm,hx,hy) call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) @@ -805,7 +803,7 @@ module subroutine filtering_lin2(this) ! ! Vertical ! - write(6,*)'thinkdeb888 ' +! write(6,*)'thinkdeb888 ' call this%boco_2d(VALL,km,im,jm,hx,hy) call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) @@ -1078,7 +1076,7 @@ module subroutine filtering_fast_bkg(this) !*** !*** Apply beta filter in vertical direction !*** - write(6,*)'thinkdeb l_vertical_filter is ',l_vertical_filter +! write(6,*)'thinkdeb l_vertical_filter is ',l_vertical_filter 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) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index ecf561160..3c13e2579 100755 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -666,12 +666,12 @@ subroutine init_mg_parameter(this,inputfilename) ! this%km_a = this%km2+this%lm_a*this%km3 - write(6,*)'thinkdeb255 lm_a,km3,km2 ',this%km2,this%lm_a,this%km3 - write(6,*)'thinkdeb255 km_a ',this%km_a +! write(6,*)'thinkdeb255 lm_a,km3,km2 ',this%km2,this%lm_a,this%km3 +! write(6,*)'thinkdeb255 km_a ',this%km_a this%km = this%km2+this%lm *this%km3 this%km_a_all = this%km_a * this%n_ens - write(6,*)'thinkdeb255 km_a_all ',this%km_a_all +! write(6,*)'thinkdeb255 km_a_all ',this%km_a_all this%km_all = this%km * this%n_ens this%km2_all = this%km2 * this%n_ens diff --git a/src/saber/mgbf/mgbf_lib/mg_timers.f90 b/src/saber/mgbf/mgbf_lib/mg_timers.f90 index 3881bfb07..66a9f415b 100755 --- a/src/saber/mgbf/mgbf_lib/mg_timers.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_timers.f90 @@ -164,7 +164,7 @@ subroutine print_mg_timers(filename, print_type,mype) !clt buffer = ' ' buffer1=' '; buffer2=' ';buffer3=' ';buffer4=' ' !cltj# if ( print_type == print_clock ) then - write(6,*)'thinkdebxxx icound is ',mg_interface_multiply_time%icount +! write(6,*)'thinkdebxxx icound is ',mg_interface_multiply_time%icount write(buffer1,"(I6,25(',',F10.4),',',I10)") mype, & init_tim%time_clock, & upsend_tim%time_clock, & @@ -262,7 +262,7 @@ subroutine print_mg_timers(filename, print_type,mype) stop endif disp = 0 - write(6,*)'thinkdebxxx bufsize 1/2 num_ranks is ',bufsize1, ' ',bufsize2,' ',num_ranks +! write(6,*)'thinkdebxxx bufsize 1/2 num_ranks is ',bufsize1, ' ',bufsize2,' ',num_ranks if(mype==0) call MPI_File_write_at(fh, disp, header1, bufsize1, MPI_BYTE, stat, ierr) disp =disp+ bufsize1 disp = disp+(mype)*bufsize1 diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index 3efd7c1f2..3df423c1a 100755 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -87,7 +87,7 @@ module subroutine filt_to_anal_allmap(this,WORKA) include "type_parameter_point2this.inc" include "type_intstat_point2this.inc" !---------------------------------------------------------------------- -write(6,*)'filt_toanal_allmap ',km_a_all,' ',km_all,' ',nm,' ',im,' ',mm,' ',jm +!write(6,*)'filt_toanal_allmap ',km_a_all,' ',km_all,' ',nm,' ',im,' ',mm,' ',jm !cltothink if(km_a_all==km_all.and.nm==im.and.mm==jm) then !clttothink WORKA=VALL(1:km_all,1:im,1:jm) !clttothink VALL=0. @@ -505,8 +505,10 @@ module subroutine anal_to_filt(this,WORK) !*** !*** Apply adjoint lateral bc on PKF and WKF !*** - +!cltthinkdeb555 +!clt if(.not.this%l_anal_sub_of_filt) then call this%bocoT_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) + !clt endif !---------------------------------------------------------------------- endsubroutine anal_to_filt @@ -542,8 +544,10 @@ module subroutine filt_to_anal(this,WORK) !*** !*** Supply boundary conditions for VALL !*** - +!cltthinkdeb255 +! if(.not.this%l_anal_sub_of_filt) then call this%boco_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) +! endif if(this%l_anal_sub_of_filt) then WORK(:,:,:)=VALL(:,1:im,1:jm) !cltorg call this%lin_direct_offset_add(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) From a09a3bcfb276580003f7fc3ede438f73d8446046 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sun, 22 Jun 2025 21:08:13 +0000 Subject: [PATCH 036/199] The fix for an array index out-of-bounds issue in mg_domain.f90 when gm_max=1 --- src/saber/mgbf/mgbf_lib/mg_domain.f90 | 5 ++++- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_domain.f90 b/src/saber/mgbf/mgbf_lib/mg_domain.f90 index 4f942107f..55a59a195 100755 --- a/src/saber/mgbf/mgbf_lib/mg_domain.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_domain.f90 @@ -471,8 +471,11 @@ module subroutine init_topology_2d(this) nx_up=(nx-1)/2 !+1 my_up=(my-1)/2 !+1 - + if(this%gm >= 2) then Fitarg_up(1)=maxpe_fgen(1)+my_up*ixm(2)+nx_up + else + Fitarg_up(1)=-1 !cltthinkdebtodo + endif if(l_hgen.and.my_hgen < gm) then diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 3c13e2579..552d9d0c2 100755 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -696,7 +696,7 @@ subroutine init_mg_parameter(this,inputfilename) if(this%nxm*this%nym<=1) then this%gm=gm_max endif - write(6,*)"thindkeb888 gm is ",this%gm +! write(6,*)"thindkeb888 gm is ",this%gm !*** !*** Analysis grid From 59c1453f9207c884c41481e643f91598c9c60af2 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 15 Jul 2025 02:18:26 +0000 Subject: [PATCH 037/199] add Jim's vertical filtering changing codes --- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 1 + src/saber/mgbf/mgbf_lib/phint.f90 | 225 ++++++++++++++++++++++++ src/saber/mgbf/mgbf_lib/phint1.f90 | 170 ++++++++++++++++++ 3 files changed, 396 insertions(+) create mode 100644 src/saber/mgbf/mgbf_lib/phint.f90 create mode 100644 src/saber/mgbf/mgbf_lib/phint1.f90 diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 2a3b7ba3d..ed77a7cc0 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1517,6 +1517,7 @@ subroutine init_mg_line(this) ! ! !*********************************************************************** !----------------------------------------------------------------------- +!clttothink do j=1,this%jm do i=1,this%im call t22_to_3(this%pasp2(:,:,i,j),this%vpasp2(:,i,j)) diff --git a/src/saber/mgbf/mgbf_lib/phint.f90 b/src/saber/mgbf/mgbf_lib/phint.f90 new file mode 100644 index 000000000..ca23094d6 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/phint.f90 @@ -0,0 +1,225 @@ +!# +! ********************************************* +! * MODULE phint * +! * R. J. Purser, NOAA/NCEP/EMC 2018 * +! * jim.purser@noaa.gov * +! * * +! ********************************************* +! +! Simple 4-point smooth interpolation from: +! (1) a uniform grid (whint and whintd); +! (2) a variable grid (whintvar and whintvard) +! based on "Hermite"-like formulas ensuring continuity of +! derivative at each node. +! The target point, x, is generally assumed to belong to the central +! interval, ([0.,1.], in the case of whnt and whntd) and derivatives (when +! applicable) are with respect to the grid index variable. +! +! COMPILE AFTER: {pietc} +! +!============================================================================= +module phint +!============================================================================= +use pkind, only: spi,dp +use pietc, only: u0,u1,u2,o2 +implicit none +private +public:: hint,whint,wint3 + +interface hint; module procedure hint,hintd; end interface +interface whint + module procedure whint,whintd,whintvar,whintvard +end interface whint +interface wint3 + module procedure wint3,wint3d +end interface wint3 + +contains + +!============================================================================= +subroutine hint(x,as,a)! [hint] +!============================================================================= +! smoothly interpolate the value from four uniformly-spaced source values, as, +! to a point located a fraction, x, into the central interval. The result is a. +!============================================================================= +implicit none +real(dp), intent(in ):: x +real(dp),dimension(-1:2),intent(in ):: as +real(dp), intent(out):: a +!----------------------------------------------------------------------------- +real(dp):: da0,dda0,da1,dda1,quad0,quad1,xm +!============================================================================= +da0=(as(1)-as(-1))*o2 ; da1=(as(2)-as(0))*o2 +dda0=as(-1)-2*as(0)+as(1); dda1=as(0)-2*as(1)+as(2) +xm=x-u1 +quad0=as(0)+x *(da0+x* dda0*o2) +quad1=as(1)+xm*(da1+xm*dda1*o2) +a=quad1*x-quad0*xm +end subroutine hint +!============================================================================= +subroutine hintd(x,as,a,da)! [hint] +!============================================================================= +! smoothly interpolate the value and its derivative from four uniformly-spaced +! source values, as, to a point located a fraction, x, into the central +! interval. The results are a and da. +!============================================================================= +implicit none +real(dp), intent(in ):: x +real(dp),dimension(-1:2),intent(in ):: as +real(dp), intent(out):: a,da +!----------------------------------------------------------------------------- +real(dp):: da0,dda0,da1,dda1,quad0,quad1,dquad0,dquad1,xm +!============================================================================= +da0=(as(1)-as(-1))*o2 ; da1=(as(2)-as(0))*o2 +dda0=as(-1)-u2*as(0)+as(1); dda1=as(0)-u2*as(1)+as(2) +xm=x-u1 +quad0=as(0)+x *(da0+x *dda0*o2); dquad0=da0+x *dda0 +quad1=as(1)+xm*(da1+xm*dda1*o2); dquad1=da1+xm*dda1 +a =quad1 *x-quad0 *xm +da=dquad1*x-dquad0*xm+quad1-quad0 +end subroutine hintd + +!============================================================================= +subroutine whint(x,wint)! [whint] +!============================================================================= +! Return the interpolation weights, wint, for smooth 4-point interpolation +! from a uniform grid to a target located a fraction, x, into the central +! of the three intervals defined by the four points. +!============================================================================= +implicit none +real(dp), intent(in ):: x +real(dp),dimension(-1:2),intent(out):: wint +!----------------------------------------------------------------------------- +real(dp):: xm1,xp1,xm2 +!============================================================================= +xm2=x-u2; xm1=x-u1; xp1=x+u1 +wint=(/-x*xm1*o2, xm1*xp1, -x*xp1*o2, u0 /)*xm1+ & + (/ u0, xm1*xm2*o2, -xm2*x, xm1*x*o2 /)*x +end subroutine whint +!============================================================================= +subroutine whintd(x,wint,dwint)! [whint] +!============================================================================= +! Return the interpolation weights, wint, for smooth 4-point interpolation +! from a uniform grid to a target located a fraction, x, into the central +! of the three intervals defined by the four points. +!============================================================================= +implicit none +real(dp), intent(in ):: x +real(dp),dimension(-1:2),intent(out):: wint,dwint +!----------------------------------------------------------------------------- +real(dp) :: xm1,xp1,xm2 +real(dp),dimension(-1:2):: quad0,quad1,dquad0,dquad1 +!============================================================================= +xm2=x-u2; xm1=x-u1; xp1=x+u1 +quad0=(/-x*xm1*o2, xm1*xp1, -x*xp1*o2, u0 /) +quad1=(/ u0,xm1*xm2*o2, -xm2*x, xm1*x*o2 /) +dquad0=(/ -x+o2, u2*x, -x-o2, u0 /) +dquad1=(/ u0, xm1-o2, -u2*xm1, xm1+o2 /) +wint = quad0*xm1+ quad1*x +dwint=dquad0*xm1+dquad1*x+quad0+quad1 +end subroutine whintd + +!============================================================================= +subroutine whintvar(xs,x,wint)! [whint] +!============================================================================= +use pkind, only: dp +use pietc, only: u0 +implicit none +real(dp),dimension(0:3),intent(in ):: xs +real(dp), intent(in ):: x +real(dp),dimension(0:3),intent(out):: wint +!----------------------------------------------------------------------------- +real(dp):: x01,x12,x23,x02,x13,x0,x1,x2,x3 +!============================================================================= +x01=xs(1)-xs(0) +x12=xs(2)-xs(1) +x23=xs(3)-xs(2) +x02=xs(2)-xs(0) +x13=xs(3)-xs(1) +x0=x-xs(0) +x1=x-xs(1) +x2=x-xs(2) +x3=x-xs(3) +wint=-(/ x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12),u0/)*x2/x12 & + +(/u0,x2*x3/(x12*x13),-x1*x3/(x12*x23),x1*x2/(x13*x23)/)*x1/x12 +end subroutine whintvar + +!============================================================================= +subroutine whintvard(xs,x,wint,dwint)! [whint] +!============================================================================= +use pkind, only: dp +use pietc, only: u0 +implicit none +real(dp),dimension(0:3),intent(in ):: xs +real(dp), intent(in ):: x +real(dp),dimension(0:3),intent(out):: wint,dwint +!----------------------------------------------------------------------------- +real(dp),dimension(0:3):: q1,q2 +real(dp) :: x01,x12,x23,x02,x13,x0,x1,x2,x3 +!============================================================================= +x01=xs(1)-xs(0) +x12=xs(2)-xs(1) +x23=xs(3)-xs(2) +x02=xs(2)-xs(0) +x13=xs(3)-xs(1) +x0=x-xs(0) +x1=x-xs(1) +x2=x-xs(2) +x3=x-xs(3) +q1=-(/x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12),u0/) +q2= (/u0,x2*x3/(x12*x13),-x1*x3/(x12*x23),x1*x2/(x13*x23)/) +wint=q1*x2/x12+q2*x1/x12 +dwint=-(/(x1+x2)/(x01*x02),-(x0+x2)/(x01*x12),(x0+x1)/(x02*x12),u0/)*x2/x12 & + +(/u0,(x2+x3)/(x12*x13),-(x1+x3)/(x12*x23),(x1+x2)/(x13*x23)/)*x1/x12 & + +(q1+q2)/x12 +end subroutine whintvard + +!============================================================================= +subroutine wint3(xs,x,wint)! [wint3] +!============================================================================= +! Get the weights, wint, for Lagrange 3-point interpolation to x from a +! variable-spaced grid xs +!============================================================================= +use pkind, only: dp +implicit none +real(dp),dimension(0:2),intent(in ):: xs +real(dp), intent(in ):: x +real(dp),dimension(0:2),intent(out):: wint +!----------------------------------------------------------------------------- +real(dp):: x01,x12,x02,x0,x1,x2 +!============================================================================= +x01=xs(1)-xs(0) +x12=xs(2)-xs(1) +x02=xs(2)-xs(0) +x0=x-xs(0) +x1=x-xs(1) +x2=x-xs(2) +wint=(/x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12)/) +end subroutine wint3 + +!============================================================================= +subroutine wint3d(xs,x,wint,dwint)! [wint3] +!============================================================================= +! Get the weights, wint, for Lagrange 3-point interpolation to x from a +! variable-spaced grid xs and the derivative weights dwint. +!============================================================================= +use pkind, only: dp +implicit none +real(dp),dimension(0:2),intent(in ):: xs +real(dp), intent(in ):: x +real(dp),dimension(0:2),intent(out):: wint,dwint +!----------------------------------------------------------------------------- +real(dp):: x01,x12,x02,x0,x1,x2 +!============================================================================= +x01=xs(1)-xs(0) +x12=xs(2)-xs(1) +x02=xs(2)-xs(0) +x0=x-xs(0) +x1=x-xs(1) +x2=x-xs(2) +wint=(/x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12)/) +dwint=(/(x1+x2)/(x01*x02),-(x0+x2)/(x01*x12),(x0+x1)/(x02*x12)/) +end subroutine wint3d + +end module phint +!# diff --git a/src/saber/mgbf/mgbf_lib/phint1.f90 b/src/saber/mgbf/mgbf_lib/phint1.f90 new file mode 100644 index 000000000..1ad1c8e46 --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/phint1.f90 @@ -0,0 +1,170 @@ +!# +! ********************************************* +! * MODULE phint1 * +! * R. J. Purser, NOAA/NCEP/EMC 2025 * +! * jim.purser@noaa.gov * +! * * +! ********************************************* +! Use interpolations of phint.f90 to construct a grid uniform in units of +! the "scale" given by a gridded profile. Also, use the interpolation of +! the logarithm of a given profile, followed by application of the exponential +! function, to ensure that the interpolation of a positive gridded function +! from one grid to another remains both smooth and positive. +! +! COMPILE AFTER: { phint.f90 } +! +!============================================================================ +module phint1 +!============================================================================ +implicit none +private +public:: make_ssgrid, logintgrid + +interface make_ssgrid + module procedure make_ssgrid +end interface make_ssgrid +interface logintgrid + module procedure logintgrid +end interface logintgrid + +contains + +!============================================================================ +subroutine make_ssgrid(nz,nf,ns,sigofz,sstop,dss,isofz,zofis)! [make_ssgrid] +!============================================================================ +! Use the vertical profile, sigofs, of idealized correlation scale +! on the unit-spaced model grid of nz spaces to derive the total integrated +! depth, sstop, of the vertical domain in these scale units. Then, +! by using careful interpolations of the log of sigofz on the grid refined +! in the vertical by a factor of nf, divide the vertical domain into +! a new grid whose spacing is uniform in these scale units and which +! possesses ns grid spaces. On this grid, the correslation scale is +! constant, and can be taken to be sstopons=sstop/ns. +! Also, output the array, isofz, defining the index-coordinate of +! the new grid that corresponds to each model grid level, and the +! model grid index coordinate, zofis, that corresponds to each level of +! out new scale-grid. All grids are assumed to go from index 0. +!============================================================================ +use pkind, only: dp,spi +use pietc, only: u1,o2 +use phint, only: wint3,whint +implicit none +integer(spi), intent(in ):: nz,nf,ns +real(dp),dimension(0:nz),intent(in ):: sigofz +real(dp), intent(out):: sstop,dss +real(dp),dimension(0:nz),intent(out):: isofz +real(dp),dimension(0:ns),intent(out):: zofis +!---------------------------------------------------------------------------- +real(dp),dimension(0:nz) :: zs,logsig +real(dp),dimension(0:nz*nf):: zsf,logsigf,ssf +real(dp),dimension(0:ns) :: ss +real(dp),dimension(3) :: w3 +real(dp),dimension(4) :: w4 +real(dp) :: r,s,z,dzf +integer(spi) :: iz,izf,izfm,izfp,is,nzf +!============================================================================ +! Interpolate the log of the sigofz distribution to a finer grid: +do iz=0,nz + zs(iz)=iz + logsig(iz)=log(sigofz(iz)) +enddo +dzf=u1/nf +nzf=nz*nf +do izf=0,nzf + zsf(izf)=izf*dzf +enddo + +do izf=0,nzf + z=zsf(izf) + iz=min(nz-1,max(0,floor(z))) + if(iz==0)then + call wint3(zs(0:2),z,w3) + logsigf(izf)=dot_product(w3,logsig(0:2)) + elseif(iz==nz-1)then + call wint3(zs(nz-2:nz),z,w3) + logsigf(izf)=dot_product(w3,logsig(nz-2:nz)) + else + call whint(zs(iz-1:iz+2),z,w4) + logsigf(izf)=dot_product(w4,logsig(iz-1:iz+2)) + endif +enddo + +ssf(0)=0 +do izf=1,nzf + izfm=izf-1 + ssf(izf)=ssf(izfm)+exp(-(logsigf(izfm)+logsigf(izf))*o2)*dzf +enddo +sstop =ssf(nzf) + +! define the new grid of ns spaces that uniformly divides the +! range of ss: +dss=sstop/ns +isofz(0)=0 +isofz(nz)=ns +do iz=1,nz-1 + izf=iz*nf + isofz(iz)=ssf(izf)/dss +enddo +do is=0,ns + ss(is)=is*dss +enddo +zofis(0)=0 +zofis(ns)=nz +izfp=1 +do is=1,ns-1 + s=ss(is) + do + if(ssf(izfp)>=s)exit + izfp=izfp+1 + enddo + izf=izfp-1 + r=(s-ssf(izf))/(ssf(izfp)-ssf(izf)) + zofis(is)=(izf+r)/nf +enddo +end subroutine make_ssgrid + +!============================================================================ +subroutine logintgrid(nz,ns,zofs,az, as)! [logintgrid] +!============================================================================ +! From a grid [0:nz] of positive values, az, use logarithms +! to ensure that the smooth interpolation to a new grid [0:ns] +! of target values, as, all remain positive. The array zofs +! defines the index z-grid coordinates of each of the s-grid points. +!============================================================================ +use pkind, only: dp,spi +use phint, only: wint3,whint +implicit none +integer(spi), intent(in ):: nz,ns +real(dp),dimension(0:ns),intent(in ):: zofs +real(dp),dimension(0:nz),intent(in ):: az +real(dp),dimension(0:ns),intent(out):: as +!---------------------------------------------------------------------------- +real(dp),dimension(0:nz):: zs,logaz +real(dp),dimension(3) :: w3! 3-point interpolation weights (at ends) +real(dp),dimension(4) :: w4! 4-point interpolation weights (interior) +real(dp) :: logas,z +integer(spi) :: is,iz +!============================================================================ +do iz=0,nz + zs(iz)=iz + logaz(iz)=log(az(iz)) +enddo +do is=0,ns + z=zofs(is) + iz=min(nz-1,max(0,floor(z))) + if(iz==0)then + call wint3(zs(0:2),z,w3) + logas=dot_product(w3,logaz(0:2)) + elseif(iz==nz-1)then + call wint3(zs(nz-2:nz),z,w3) + logas=dot_product(w3,logaz(nz-2:nz)) + else + call whint(zs(iz-1:iz+2),z,w4) + logas=dot_product(w4,logaz(iz-1:iz+2)) + endif + as(is)=exp(logas) +enddo +end subroutine logintgrid + +end module phint1 +!# From 41a9298e7ce01e1b7642373e99e917bff669749d Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 18 Jul 2025 00:51:16 +0000 Subject: [PATCH 038/199] initial work for incorporating Jim's codes for vertically varied filtering grids (in terms of analysis grid units) --- src/saber/CMakeLists.txt | 4 +- src/saber/mgbf/mgbf_lib/CMakeLists.txt | 2 +- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 1 + src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 102 ++++++- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 11 +- src/saber/mgbf/mgbf_lib/phint.f90 | 80 +++--- src/saber/mgbf/mgbf_lib/phint1.f90 | 332 +++++++++++++++++++++-- 7 files changed, 460 insertions(+), 72 deletions(-) mode change 100755 => 100644 src/saber/mgbf/mgbf_lib/mg_parameter.f90 diff --git a/src/saber/CMakeLists.txt b/src/saber/CMakeLists.txt index 2825adf8a..69cf68b2e 100644 --- a/src/saber/CMakeLists.txt +++ b/src/saber/CMakeLists.txt @@ -38,8 +38,8 @@ if( gsibec_FOUND ) target_link_libraries( ${PROJECT_NAME} PUBLIC sp::sp_d ) endif() endif() -if( MGBFLIB_FOUND ) - target_link_libraries( ${PROJECT_NAME} PUBLIC mgbflib ) +if( MGBFLIB_FOUND EQUAL 9999 ) + target_link_libraries( ${PROJECT_NAME} PUBLIC mgbf_lib ) target_compile_definitions( ${PROJECT_NAME} PUBLIC MGBF_FOUND) endif() if( FFTW_FOUND ) diff --git a/src/saber/mgbf/mgbf_lib/CMakeLists.txt b/src/saber/mgbf/mgbf_lib/CMakeLists.txt index c2bb5a9eb..149a5a7d1 100755 --- a/src/saber/mgbf/mgbf_lib/CMakeLists.txt +++ b/src/saber/mgbf/mgbf_lib/CMakeLists.txt @@ -14,7 +14,7 @@ ${jbfilenames} #PARENT_SCOPE ) -add_library(mgbf_lib STATIC ${mgbf_lib_src_files}) +add_library(mgbflib STATIC ${mgbf_lib_src_files}) set_target_properties(mgbf_lib PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/modules) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index ed77a7cc0..76a582354 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1601,6 +1601,7 @@ subroutine deallocate_mg_intstate(this) if(this%l_loc) then deallocate(this%w1_loc,this%w2_loc,this%w3_loc,this%w4_loc) endif +deallocate( this%aspect_vert_profile_angrid ,this%aspect_vert_profile_filtgrid) end subroutine deallocate_mg_intstate diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 old mode 100755 new mode 100644 index 552d9d0c2..b7d804dd4 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -33,6 +33,8 @@ module mg_parameter use mgbf_kinds, only: i_kind,r_kind use jp_pietc, only: u1 +use phint1 +use mpi implicit none integer(i_kind),parameter :: lm_max=200 @@ -133,6 +135,8 @@ module mg_parameter integer, allocatable, dimension(:):: im0,jm0 integer, allocatable, dimension(:):: Fimax,Fjmax integer, allocatable, dimension(:):: FimaxL,FjmaxL +real(r_kind), allocatable, dimension(:):: zofis ! index of s(fitering grids) in analysis grids (its index is its coor) +real(r_kind), allocatable, dimension(:):: isofz ! index of z of analysis grids in the filtering grids integer(i_kind):: npes_filt integer(i_kind):: maxpe_filt @@ -161,6 +165,8 @@ module mg_parameter logical :: l_new_map ! logical flag for new mapping between analysis and filter grid logical :: l_vertical_filter ! logical flag for vertical filtering logical :: l_anal_sub_of_filt ! true : analysis grids and filtering grids are the same excpet for later has boundary points +logical :: l_vert_stretched_filtgrid ! true : filtering grids are stretched in tems of analysis grid unit +logical :: l_vert_varied_ampl01 ! true, ampl01 is varied over the vertical analysis levels integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) integer(i_kind):: km_4 integer(i_kind):: km_16 @@ -213,6 +219,9 @@ module mg_parameter 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 logical:: l_mg_weig_readin=.false. +!clt for use of resolution-varied vertical filtering grids +real(r_kind), allocatable,dimension(:):: aspect_vert_profile_angrid ! should be of size (lm) +real(r_kind), allocatable,dimension(:):: aspect_vert_profile_filtgrid ! should be of size (lm) contains procedure :: init_mg_parameter @@ -511,6 +520,8 @@ subroutine init_mg_parameter(this,inputfilename) logical :: l_new_map=.false. ! logical flag for new mapping between analysis and filter grid logical :: l_vertical_filter=.true. ! logical flag for vertical filtering logical :: l_anal_sub_of_filt=.false. +logical :: l_vert_stretched_filtgrid=.false. +logical :: l_vert_varied_ampl01=.false. ! true, ampl01 is varied over the vertical analysis levels integer(i_kind):: gm_max=4 !clt by defaul ! Global number of data on Analysis grid @@ -520,6 +531,7 @@ subroutine init_mg_parameter(this,inputfilename) integer(i_kind):: hx,hy,hz integer(i_kind):: p logical:: l_mg_weig_readin=.false. +integer(i_kind), parameter :: nf=20! refinement factor for z grid,used in make_ssgrid namelist /parameters_mgbeta/ mg_ampl01,mg_ampl02,mg_ampl03 & ,mg_weig1,mg_weig2,mg_weig3,mg_weig4 & @@ -537,6 +549,8 @@ subroutine init_mg_parameter(this,inputfilename) ,l_new_map & ,l_vertical_filter & ,l_anal_sub_of_filt & + ,l_vert_stretched_filtgrid & + ,l_vert_varied_ampl01 & ,l_for_localization,ldelta,lquart,lhelm & , l_mgbf_inhomogeneous & ,gm_max & @@ -548,6 +562,15 @@ subroutine init_mg_parameter(this,inputfilename) read(10,nml=parameters_mgbeta) close(unit=10) ! + allocate(this%aspect_vert_profile_angrid(lm_a),this%aspect_vert_profile_filtgrid(lm)) + allocate(this%zofis(lm)) + allocate(this%isofz(lm_a)) +#if 1 + if(this%l_vert_varied_ampl01 ) then + call convert_vert_varied_aspt +!in which the mg_ampl01 will be re-defined + endif +#endif !----------------------------------------------------------------- !for safety, copy all namelist loc vars to them of this object this%mg_ampl01=mg_ampl01 @@ -581,6 +604,8 @@ subroutine init_mg_parameter(this,inputfilename) this%l_new_map=l_new_map this%l_vertical_filter=l_vertical_filter this%l_anal_sub_of_filt=l_anal_sub_of_filt + this%l_vert_stretched_filtgrid=l_vert_stretched_filtgrid + this%l_vert_varied_ampl01=l_vert_varied_ampl01 this%l_for_localization=l_for_localization this%l_mgbf_inhomogeneous = l_mgbf_inhomogeneous this%ldelta=ldelta @@ -706,8 +731,8 @@ subroutine init_mg_parameter(this,inputfilename) ! Number of grid intervals on GSI grid for the reduced RTMA domain ! before padding ! - this%nA_max0 = 1792 - this%mA_max0 = 1056 +!clt this%nA_max0 = 1792 +!clt this%mA_max0 = 1056 ! ! Number of grid points on the analysis grid after padding @@ -896,7 +921,6 @@ subroutine init_mg_parameter(this,inputfilename) this%imH=this%im0(this%gm) this%jmH=this%jm0(this%gm) - this%pasp01 = mg_ampl01 this%pasp02 = mg_ampl02 this%pasp03 = mg_ampl03 @@ -909,6 +933,78 @@ subroutine init_mg_parameter(this,inputfilename) this%rmom2_2=u1/sqrt(this%pee2+4) this%rmom2_3=u1/sqrt(this%pee2+5) this%rmom2_4=u1/sqrt(this%pee2+6) +#if 1 + +contains + +subroutine convert_vert_varied_aspt + + integer(i_kind) :: myunit,lm_tmp,i,iz,is,mype,ierr + real(r_kind)::sstop,dss + real (r_kind),allocatable,dimension(:)::sigofz + real (r_kind),allocatable,dimension(:)::sigofis + + allocate(this%aspect_vert_profile_angrid(lm_a),this%aspect_vert_profile_filtgrid(lm)) + allocate(sigofz(lm_a),sigofis(lm)) + call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr) + if(l_vert_stretched_filtgrid) then + if(mype.eq.0) then + open(newunit=myunit,file="mgbf_vert_aspt_profile.txt",status='old') + read(myunit,*)lm_tmp + if(lm_tmp.ne.lm_a) then + error stop " the lm_a is not the same as the size in mgbf_vert_aspt_profile.txt, stop" + endif + do i=1,lm_a + read(myunit,*)this%aspect_vert_profile_angrid(i) + enddo + endif + call MPI_Type_match_size(MPI_TYPECLASS_REAL, kind(this%aspect_vert_profile_angrid), mpi_real, ierr) + if (ierr /= MPI_SUCCESS) then + write(6,*) "ERROR: No matching MPI type for real kind =", kind(this%aspect_vert_profile_angrid) + call MPI_Abort(MPI_COMM_WORLD, 1, ierr) + endif + call MPI_Bcast(this%aspect_vert_profile_angrid, lm_a, mpi_real, 0, MPI_COMM_WORLD, ierr) + +! nz=lm_a-1 +! ns=lm-1 + +! calibrate sigscale to make sigofz go to sigbottom at z=0: + sigofz=this%aspect_vert_profile_angrid + print'('' list the levels and sigofz from the top down:'')' + if(mype==0) then + do iz=lm_a,1,-1 + write(6,*)iz,sigofz(iz) + enddo + endif + +! Make the new grid whose resolution of the correlation scale sigofz +! is uniform throughout. +! isofz is the s-index coordinate of each of the original z-grid points. +! zofis is the z-index coordinate of each of the new s-grid points. +!cltorg call make_ssgrid(nz,nf,ns,sigofz, sstop,dss,isofz,zofis) + call make_ssgrid(lm_a-1,nf,lm-1,sigofz, sstop,dss,this%isofz,this%zofis) + +! Use the new s-grid locations zofis, and the original profile of +! correlation scales sigofz, to interpolate, smoothly and positively, +! these scales sig to each of the new s-grid points: +!clt call logintgrid(nz,ns,zofis,sigofz,sigofis) + call logintgrid(lm_a-1,lm-1,this%zofis,sigofz,sigofis) + if(mype==0) then + print'('' list the profile coordinates of zofis,sigofis, for each is:'')' + do is=1,lm + write(6,*)is,this%zofis(is),sigofis(is) + enddo + endif + mg_ampl01=sum(sigofis)/size(sigofis) + + endif + + + deallocate(sigofz,sigofis) +end subroutine convert_vert_varied_aspt + +#endif + !---------------------------------------------------------------------- end subroutine init_mg_parameter diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index 3df423c1a..914a08ef2 100755 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -39,6 +39,7 @@ use mg_timers use mgbf_kinds, only: r_kind,i_kind use mgbf_utils,only : contains_nonzero +use phint1 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ contains @@ -159,8 +160,12 @@ module subroutine anal_to_filt_all(this,WORKA) !clt call this%lwq_vertical_adjoint(nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) !cltorg call this%lwq_vertical_adjoint(this%lm_a,this%lm,1,nm,1,mm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref, & !clt worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) - call this%test_vertical_interpolation_adj(this%lm,this%lm_a,1,nm,1,mm, work(lev1_f:lev2_f,:,:), & + if (this%l_vert_stretched_filtgrid) then + call intgrid_f2a_3d_ad(this%lm_a-1,this%lm-1,nm,mm,this%zofis,worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) + else + call this%test_vertical_interpolation_adj(this%lm,this%lm_a,1,nm,1,mm, work(lev1_f:lev2_f,:,:), & worka(lev1_a:lev2_a,:,:)) + endif enddo else work=worka @@ -208,8 +213,12 @@ module subroutine filt_to_anal_all(this,WORKA) lev2_f=lev1_f+this%lm-1 !clt call this%lwq_vertical_direct(this%lm,this%lm_a,1,nm,1,mm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref, & !clt work(lev1_f:lev2_f,:,:),worka(lev1_a:lev2_a,:,:)) + if (this%l_vert_stretched_filtgrid) then + call intgrid_f2a_3d(this%lm_a-1,this%lm-1,nm,mm,this%zofis,worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) + else call this%test_vertical_interpolation(this%lm,this%lm_a,1,nm,1,mm, work(lev1_f:lev2_f,:,:), & worka(lev1_a:lev2_a,:,:)) + endif enddo else worka=work diff --git a/src/saber/mgbf/mgbf_lib/phint.f90 b/src/saber/mgbf/mgbf_lib/phint.f90 index ca23094d6..431d6088d 100644 --- a/src/saber/mgbf/mgbf_lib/phint.f90 +++ b/src/saber/mgbf/mgbf_lib/phint.f90 @@ -20,8 +20,8 @@ !============================================================================= module phint !============================================================================= -use pkind, only: spi,dp -use pietc, only: u0,u1,u2,o2 +use mgbf_kinds, only: i_kind,r_kind +use jp_pietc, only: u0,u1,u2,o2 implicit none private public:: hint,whint,wint3 @@ -43,11 +43,11 @@ subroutine hint(x,as,a)! [hint] ! to a point located a fraction, x, into the central interval. The result is a. !============================================================================= implicit none -real(dp), intent(in ):: x -real(dp),dimension(-1:2),intent(in ):: as -real(dp), intent(out):: a +real(r_kind), intent(in ):: x +real(r_kind),dimension(-1:2),intent(in ):: as +real(r_kind), intent(out):: a !----------------------------------------------------------------------------- -real(dp):: da0,dda0,da1,dda1,quad0,quad1,xm +real(r_kind):: da0,dda0,da1,dda1,quad0,quad1,xm !============================================================================= da0=(as(1)-as(-1))*o2 ; da1=(as(2)-as(0))*o2 dda0=as(-1)-2*as(0)+as(1); dda1=as(0)-2*as(1)+as(2) @@ -64,11 +64,11 @@ subroutine hintd(x,as,a,da)! [hint] ! interval. The results are a and da. !============================================================================= implicit none -real(dp), intent(in ):: x -real(dp),dimension(-1:2),intent(in ):: as -real(dp), intent(out):: a,da +real(r_kind), intent(in ):: x +real(r_kind),dimension(-1:2),intent(in ):: as +real(r_kind), intent(out):: a,da !----------------------------------------------------------------------------- -real(dp):: da0,dda0,da1,dda1,quad0,quad1,dquad0,dquad1,xm +real(r_kind):: da0,dda0,da1,dda1,quad0,quad1,dquad0,dquad1,xm !============================================================================= da0=(as(1)-as(-1))*o2 ; da1=(as(2)-as(0))*o2 dda0=as(-1)-u2*as(0)+as(1); dda1=as(0)-u2*as(1)+as(2) @@ -87,10 +87,10 @@ subroutine whint(x,wint)! [whint] ! of the three intervals defined by the four points. !============================================================================= implicit none -real(dp), intent(in ):: x -real(dp),dimension(-1:2),intent(out):: wint +real(r_kind), intent(in ):: x +real(r_kind),dimension(-1:2),intent(out):: wint !----------------------------------------------------------------------------- -real(dp):: xm1,xp1,xm2 +real(r_kind):: xm1,xp1,xm2 !============================================================================= xm2=x-u2; xm1=x-u1; xp1=x+u1 wint=(/-x*xm1*o2, xm1*xp1, -x*xp1*o2, u0 /)*xm1+ & @@ -104,11 +104,11 @@ subroutine whintd(x,wint,dwint)! [whint] ! of the three intervals defined by the four points. !============================================================================= implicit none -real(dp), intent(in ):: x -real(dp),dimension(-1:2),intent(out):: wint,dwint +real(r_kind), intent(in ):: x +real(r_kind),dimension(-1:2),intent(out):: wint,dwint !----------------------------------------------------------------------------- -real(dp) :: xm1,xp1,xm2 -real(dp),dimension(-1:2):: quad0,quad1,dquad0,dquad1 +real(r_kind) :: xm1,xp1,xm2 +real(r_kind),dimension(-1:2):: quad0,quad1,dquad0,dquad1 !============================================================================= xm2=x-u2; xm1=x-u1; xp1=x+u1 quad0=(/-x*xm1*o2, xm1*xp1, -x*xp1*o2, u0 /) @@ -122,14 +122,14 @@ end subroutine whintd !============================================================================= subroutine whintvar(xs,x,wint)! [whint] !============================================================================= -use pkind, only: dp -use pietc, only: u0 +use jp_pkind, only: dp +use jp_pietc, only: u0 implicit none -real(dp),dimension(0:3),intent(in ):: xs -real(dp), intent(in ):: x -real(dp),dimension(0:3),intent(out):: wint +real(r_kind),dimension(0:3),intent(in ):: xs +real(r_kind), intent(in ):: x +real(r_kind),dimension(0:3),intent(out):: wint !----------------------------------------------------------------------------- -real(dp):: x01,x12,x23,x02,x13,x0,x1,x2,x3 +real(r_kind):: x01,x12,x23,x02,x13,x0,x1,x2,x3 !============================================================================= x01=xs(1)-xs(0) x12=xs(2)-xs(1) @@ -147,15 +147,15 @@ end subroutine whintvar !============================================================================= subroutine whintvard(xs,x,wint,dwint)! [whint] !============================================================================= -use pkind, only: dp -use pietc, only: u0 +use jp_pkind, only: dp +use jp_pietc, only: u0 implicit none -real(dp),dimension(0:3),intent(in ):: xs -real(dp), intent(in ):: x -real(dp),dimension(0:3),intent(out):: wint,dwint +real(r_kind),dimension(0:3),intent(in ):: xs +real(r_kind), intent(in ):: x +real(r_kind),dimension(0:3),intent(out):: wint,dwint !----------------------------------------------------------------------------- -real(dp),dimension(0:3):: q1,q2 -real(dp) :: x01,x12,x23,x02,x13,x0,x1,x2,x3 +real(r_kind),dimension(0:3):: q1,q2 +real(r_kind) :: x01,x12,x23,x02,x13,x0,x1,x2,x3 !============================================================================= x01=xs(1)-xs(0) x12=xs(2)-xs(1) @@ -180,13 +180,13 @@ subroutine wint3(xs,x,wint)! [wint3] ! Get the weights, wint, for Lagrange 3-point interpolation to x from a ! variable-spaced grid xs !============================================================================= -use pkind, only: dp +use jp_pkind, only: dp implicit none -real(dp),dimension(0:2),intent(in ):: xs -real(dp), intent(in ):: x -real(dp),dimension(0:2),intent(out):: wint +real(r_kind),dimension(0:2),intent(in ):: xs +real(r_kind), intent(in ):: x +real(r_kind),dimension(0:2),intent(out):: wint !----------------------------------------------------------------------------- -real(dp):: x01,x12,x02,x0,x1,x2 +real(r_kind):: x01,x12,x02,x0,x1,x2 !============================================================================= x01=xs(1)-xs(0) x12=xs(2)-xs(1) @@ -203,13 +203,13 @@ subroutine wint3d(xs,x,wint,dwint)! [wint3] ! Get the weights, wint, for Lagrange 3-point interpolation to x from a ! variable-spaced grid xs and the derivative weights dwint. !============================================================================= -use pkind, only: dp +use jp_pkind, only: dp implicit none -real(dp),dimension(0:2),intent(in ):: xs -real(dp), intent(in ):: x -real(dp),dimension(0:2),intent(out):: wint,dwint +real(r_kind),dimension(0:2),intent(in ):: xs +real(r_kind), intent(in ):: x +real(r_kind),dimension(0:2),intent(out):: wint,dwint !----------------------------------------------------------------------------- -real(dp):: x01,x12,x02,x0,x1,x2 +real(r_kind):: x01,x12,x02,x0,x1,x2 !============================================================================= x01=xs(1)-xs(0) x12=xs(2)-xs(1) diff --git a/src/saber/mgbf/mgbf_lib/phint1.f90 b/src/saber/mgbf/mgbf_lib/phint1.f90 index 1ad1c8e46..55e7c192c 100644 --- a/src/saber/mgbf/mgbf_lib/phint1.f90 +++ b/src/saber/mgbf/mgbf_lib/phint1.f90 @@ -16,8 +16,9 @@ !============================================================================ module phint1 !============================================================================ +use mgbf_kinds, only: i_kind,r_kind implicit none -private +public public:: make_ssgrid, logintgrid interface make_ssgrid @@ -45,23 +46,22 @@ subroutine make_ssgrid(nz,nf,ns,sigofz,sstop,dss,isofz,zofis)! [make_ssgrid] ! model grid index coordinate, zofis, that corresponds to each level of ! out new scale-grid. All grids are assumed to go from index 0. !============================================================================ -use pkind, only: dp,spi -use pietc, only: u1,o2 +use jp_pietc, only: u1,o2 use phint, only: wint3,whint implicit none -integer(spi), intent(in ):: nz,nf,ns -real(dp),dimension(0:nz),intent(in ):: sigofz -real(dp), intent(out):: sstop,dss -real(dp),dimension(0:nz),intent(out):: isofz -real(dp),dimension(0:ns),intent(out):: zofis +integer(i_kind), intent(in ):: nz,nf,ns +real(r_kind),dimension(0:nz),intent(in ):: sigofz +real(r_kind), intent(out):: sstop,dss +real(r_kind),dimension(0:nz),intent(out):: isofz +real(r_kind),dimension(0:ns),intent(out):: zofis !---------------------------------------------------------------------------- -real(dp),dimension(0:nz) :: zs,logsig -real(dp),dimension(0:nz*nf):: zsf,logsigf,ssf -real(dp),dimension(0:ns) :: ss -real(dp),dimension(3) :: w3 -real(dp),dimension(4) :: w4 -real(dp) :: r,s,z,dzf -integer(spi) :: iz,izf,izfm,izfp,is,nzf +real(r_kind),dimension(0:nz) :: zs,logsig +real(r_kind),dimension(0:nz*nf):: zsf,logsigf,ssf +real(r_kind),dimension(0:ns) :: ss +real(r_kind),dimension(3) :: w3 +real(r_kind),dimension(4) :: w4 +real(r_kind) :: r,s,z,dzf +integer(i_kind) :: iz,izf,izfm,izfp,is,nzf !============================================================================ ! Interpolate the log of the sigofz distribution to a finer grid: do iz=0,nz @@ -131,19 +131,18 @@ subroutine logintgrid(nz,ns,zofs,az, as)! [logintgrid] ! of target values, as, all remain positive. The array zofs ! defines the index z-grid coordinates of each of the s-grid points. !============================================================================ -use pkind, only: dp,spi use phint, only: wint3,whint implicit none -integer(spi), intent(in ):: nz,ns -real(dp),dimension(0:ns),intent(in ):: zofs -real(dp),dimension(0:nz),intent(in ):: az -real(dp),dimension(0:ns),intent(out):: as +integer(i_kind), intent(in ):: nz,ns +real(r_kind),dimension(0:ns),intent(in ):: zofs +real(r_kind),dimension(0:nz),intent(in ):: az +real(r_kind),dimension(0:ns),intent(out):: as !---------------------------------------------------------------------------- -real(dp),dimension(0:nz):: zs,logaz -real(dp),dimension(3) :: w3! 3-point interpolation weights (at ends) -real(dp),dimension(4) :: w4! 4-point interpolation weights (interior) -real(dp) :: logas,z -integer(spi) :: is,iz +real(r_kind),dimension(0:nz):: zs,logaz +real(r_kind),dimension(3) :: w3! 3-point interpolation weights (at ends) +real(r_kind),dimension(4) :: w4! 4-point interpolation weights (interior) +real(r_kind) :: logas,z +integer(i_kind) :: is,iz !============================================================================ do iz=0,nz zs(iz)=iz @@ -165,6 +164,289 @@ subroutine logintgrid(nz,ns,zofs,az, as)! [logintgrid] as(is)=exp(logas) enddo end subroutine logintgrid +subroutine intgrid(nz,ns,zofs,az, as)! [logintgrid] +!clt modified from logintgrid, but don't do the log transformation +!============================================================================ +! From a grid [0:nz] of positive values, az, use logarithms +! to ensure that the smooth interpolation to a new grid [0:ns] +! of target values, as, all remain positive. The array zofs +! defines the index z-grid coordinates of each of the s-grid points. +!============================================================================ +use phint, only: wint3,whint +implicit none +integer(i_kind), intent(in ):: nz,ns +real(r_kind),dimension(0:ns),intent(in ):: zofs +real(r_kind),dimension(0:nz),intent(in ):: az +real(r_kind),dimension(0:ns),intent(out):: as +!---------------------------------------------------------------------------- +real(r_kind),dimension(0:nz):: zs,logaz +real(r_kind),dimension(3) :: w3! 3-point interpolation weights (at ends) +real(r_kind),dimension(4) :: w4! 4-point interpolation weights (interior) +real(r_kind) :: z +integer(i_kind) :: is,iz +!============================================================================ +do iz=0,nz + zs(iz)=iz +enddo +do is=0,ns + z=zofs(is) + iz=min(nz-1,max(0,floor(z))) + if(iz==0)then + call wint3(zs(0:2),z,w3) + as=dot_product(w3,az(0:2)) + elseif(iz==nz-1)then + call wint3(zs(nz-2:nz),z,w3) + as=dot_product(w3,az(nz-2:nz)) + else + call whint(zs(iz-1:iz+2),z,w4) + as=dot_product(w4,az(iz-1:iz+2)) + endif +enddo +end subroutine intgrid +subroutine intgrid_ad(nz, ns, zofs, az_ad, as_ad) +!--------------------------------------------------------------------- +! Adjoint of intgrid: propagate adjoint variables from as_ad to az_ad +!--------------------------------------------------------------------- +use phint, only: wint3, whint +implicit none +integer(i_kind), intent(in) :: nz, ns +real(r_kind), dimension(0:ns),intent(in) :: zofs +real(r_kind), dimension(0:nz),intent(inout):: az_ad ! inout for accumulation +real(r_kind), dimension(0:ns),intent(in) :: as_ad + +! local variables +real(r_kind), dimension(0:nz) :: zs +real(r_kind), dimension(3) :: w3 +real(r_kind), dimension(4) :: w4 +real(r_kind) :: z +integer(i_kind) :: is, iz + +!------------------------------------------------------------- +! Build zs same as in forward +do iz = 0, nz + zs(iz) = iz +enddo + +! Initialize az_ad if needed +! az_ad = 0.0_dp ! if not already initialized outside + +do is = 0, ns + z = zofs(is) + iz = min(nz - 1, max(0, floor(z))) + + if (iz == 0) then + call wint3(zs(0:2), z, w3) + az_ad(0:2) = az_ad(0:2) + as_ad(is) * w3 + elseif (iz == nz - 1) then + call wint3(zs(nz-2:nz), z, w3) + az_ad(nz-2:nz) = az_ad(nz-2:nz) + as_ad(is) * w3 + else + call whint(zs(iz-1:iz+2), z, w4) + az_ad(iz-1:iz+2) = az_ad(iz-1:iz+2) + as_ad(is) * w4 + endif +enddo + +end subroutine intgrid_ad +subroutine intgrid_f2a(nz, ns, zofs, as, az) +!------------------------------------------------------------------------------- +! This routine interpolates from reduced-resolution `as` to high-resolution `az`, +! using the same stencil logic as in the original `intgrid` routine. +! +! Input: +! - as(0:ns) : values on coarse grid (positions given by zofs) +! - zofs(0:ns): coarse grid index positions (e.g., fractional positions in fine grid) +! +! Output: +! - az(0:nz) : interpolated values on full fine grid +!------------------------------------------------------------------------------- +use phint, only: wint3, whint +implicit none + +integer(i_kind), intent(in) :: nz, ns +real(r_kind), dimension(0:ns),intent(in) :: zofs +real(r_kind), dimension(0:ns),intent(in) :: as +real(r_kind), dimension(0:nz),intent(out) :: az + +! Local variables +real(r_kind), dimension(3) :: w3 +real(r_kind), dimension(4) :: w4 +real(r_kind) :: z +integer(i_kind) :: iz, is + +!------------------------------------------------------------------------------- +! Loop over fine grid points and interpolate from coarse `as` at `zofs` + +do iz = 0, nz + z = real(iz, r_kind) ! The fine grid point we want to interpolate + + ! Search for the coarse grid interval that contains z + is = 0 + do while (is < ns .and. zofs(is+1) < z) + is = is + 1 + end do + + ! Boundary handling + if (is <= 1) then + call wint3(zofs(0:2), z, w3) + az(iz) = dot_product(w3, as(0:2)) + elseif (is >= ns-1) then + call wint3(zofs(ns-2:ns), z, w3) + az(iz) = dot_product(w3, as(ns-2:ns)) + else + call whint(zofs(is-1:is+2), z, w4) + az(iz) = dot_product(w4, as(is-1:is+2)) + end if +end do + +end subroutine intgrid_f2a +subroutine intgrid_f2a_ad(nz, ns, zofs, az_ad, as_ad) +!------------------------------------------------------------------------------- +! Adjoint of intgrid_synthesis. +! Accumulates contributions from fine-grid adjoint az_ad into coarse-grid adjoint as_ad +! +! Input: +! - az_ad(0:nz) : adjoint values on fine grid +! - zofs(0:ns) : coarse grid locations (same as in forward) +! +! Output: +! - as_ad(0:ns) : adjoint values on coarse grid (to be accumulated) +!------------------------------------------------------------------------------- +use phint, only: wint3, whint +implicit none + +integer(i_kind), intent(in) :: nz, ns +real(r_kind), dimension(0:ns), intent(in) :: zofs +real(r_kind), dimension(0:nz), intent(in) :: az_ad +real(r_kind), dimension(0:ns), intent(inout) :: as_ad ! inout to allow accumulation + +! Local +real(r_kind), dimension(3) :: w3 +real(r_kind), dimension(4) :: w4 +real(r_kind) :: z +integer(i_kind) :: iz, is + +!------------------------------------------------------------------------------- +do iz = 0, nz + z = real(iz, r_kind) + + ! Find interpolation interval (same logic as in synthesis) + is = 0 + do while (is < ns .and. zofs(is+1) < z) + is = is + 1 + end do + + ! Accumulate az_ad(iz) into as_ad via adjoint of interpolation + if (is <= 1) then + call wint3(zofs(0:2), z, w3) + as_ad(0:2) = as_ad(0:2) + az_ad(iz) * w3 + elseif (is >= ns-1) then + call wint3(zofs(ns-2:ns), z, w3) + as_ad(ns-2:ns) = as_ad(ns-2:ns) + az_ad(iz) * w3 + else + call whint(zofs(is-1:is+2), z, w4) + as_ad(is-1:is+2) = as_ad(is-1:is+2) + az_ad(iz) * w4 + end if +end do + +end subroutine intgrid_f2a_ad +subroutine intgrid_f2a_3d(nz, ns, nx, ny, zofs, az,as) +!------------------------------------------------------------------------------ +! Interpolates in vertical (first) dimension using zofs(0:ns,nx,ny) +! Output: az(0:nz, nx, ny) +!------------------------------------------------------------------------------ +use phint, only: wint3, whint +implicit none + +integer(i_kind), intent(in) :: nz, ns, nx, ny +real(r_kind), dimension(0:ns,nx,ny), intent(in) :: zofs +real(r_kind), dimension(0:ns,nx,ny), intent(in) :: as +real(r_kind), dimension(0:nz,nx,ny), intent(out) :: az + +! Local +real(r_kind), dimension(3) :: w3 +real(r_kind), dimension(4) :: w4 +real(r_kind) :: z +integer(i_kind) :: i, j, k, s + +!------------------------------------------------------------------------------ +do j = 1, ny + do i = 1, nx + do k = 0, nz + z = real(k, r_kind) ! target vertical level index + + ! Find s such that zofs(s+1,i,j) > z ≥ zofs(s,i,j) + s = 0 + do while (s < ns .and. zofs(s+1,i,j) < z) + s = s + 1 + end do + + if (s <= 1) then + call wint3(zofs(0:2,i,j), z, w3) + az(k,i,j) = dot_product(w3, as(0:2,i,j)) + elseif (s >= ns-1) then + call wint3(zofs(ns-2:ns,i,j), z, w3) + az(k,i,j) = dot_product(w3, as(ns-2:ns,i,j)) + else + call whint(zofs(s-1:s+2,i,j), z, w4) + az(k,i,j) = dot_product(w4, as(s-1:s+2,i,j)) + end if + + end do + end do +end do + +end subroutine intgrid_f2a_3d +subroutine intgrid_f2a_3d_ad(nz, ns, nx, ny, zofs, az_ad, as_ad) +!------------------------------------------------------------------------------ +! Adjoint of intgrid_synthesis_3d +! Accumulates az_ad(0:nz,nx,ny) into as_ad(0:ns,nx,ny) +!------------------------------------------------------------------------------ +use phint, only: wint3, whint +implicit none + +integer(i_kind), intent(in) :: nz, ns, nx, ny +real(r_kind), dimension(0:ns,nx,ny), intent(in) :: zofs +real(r_kind), dimension(0:nz,nx,ny), intent(in) :: az_ad +real(r_kind), dimension(0:ns,nx,ny), intent(inout) :: as_ad ! inout to accumulate + +! Local +real(r_kind), dimension(3) :: w3 +real(r_kind), dimension(4) :: w4 +real(r_kind) :: z +integer(i_kind) :: i, j, k, s + +!------------------------------------------------------------------------------ +do j = 1, ny + do i = 1, nx + do k = 0, nz + z = real(k, r_kind) + + s = 0 + do while (s < ns .and. zofs(s+1,i,j) < z) + s = s + 1 + end do + + if (s <= 1) then + call wint3(zofs(0:2,i,j), z, w3) + as_ad(0:2,i,j) = as_ad(0:2,i,j) + az_ad(k,i,j) * w3 + elseif (s >= ns-1) then + call wint3(zofs(ns-2:ns,i,j), z, w3) + as_ad(ns-2:ns,i,j) = as_ad(ns-2:ns,i,j) + az_ad(k,i,j) * w3 + else + call whint(zofs(s-1:s+2,i,j), z, w4) + as_ad(s-1:s+2,i,j) = as_ad(s-1:s+2,i,j) + az_ad(k,i,j) * w4 + end if + + end do + end do +end do + +end subroutine intgrid_f2a_3d_ad + + + + + end module phint1 !# From ded7a512cc5619b0e63f420c6a187f473edeedd9 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 22 Jul 2025 22:03:00 +0000 Subject: [PATCH 039/199] WIP debug the vertically stretched filtering function --- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 50 +++- src/saber/mgbf/mgbf_lib/phint.f90 | 1 + src/saber/mgbf/mgbf_lib/phint1.f90 | 319 +++++++++++++++++++---- 3 files changed, 309 insertions(+), 61 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index b7d804dd4..622b85030 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -166,7 +166,7 @@ module mg_parameter logical :: l_vertical_filter ! logical flag for vertical filtering logical :: l_anal_sub_of_filt ! true : analysis grids and filtering grids are the same excpet for later has boundary points logical :: l_vert_stretched_filtgrid ! true : filtering grids are stretched in tems of analysis grid unit -logical :: l_vert_varied_ampl01 ! true, ampl01 is varied over the vertical analysis levels +!logical :: l_vert_varied_ampl01 ! true, ampl01 is varied over the vertical analysis levels integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) integer(i_kind):: km_4 integer(i_kind):: km_16 @@ -521,7 +521,7 @@ subroutine init_mg_parameter(this,inputfilename) logical :: l_vertical_filter=.true. ! logical flag for vertical filtering logical :: l_anal_sub_of_filt=.false. logical :: l_vert_stretched_filtgrid=.false. -logical :: l_vert_varied_ampl01=.false. ! true, ampl01 is varied over the vertical analysis levels +!cltlogical :: l_vert_varied_ampl01=.false. ! true, ampl01 is varied over the vertical analysis levels integer(i_kind):: gm_max=4 !clt by defaul ! Global number of data on Analysis grid @@ -550,7 +550,6 @@ subroutine init_mg_parameter(this,inputfilename) ,l_vertical_filter & ,l_anal_sub_of_filt & ,l_vert_stretched_filtgrid & - ,l_vert_varied_ampl01 & ,l_for_localization,ldelta,lquart,lhelm & , l_mgbf_inhomogeneous & ,gm_max & @@ -562,11 +561,11 @@ subroutine init_mg_parameter(this,inputfilename) read(10,nml=parameters_mgbeta) close(unit=10) ! - allocate(this%aspect_vert_profile_angrid(lm_a),this%aspect_vert_profile_filtgrid(lm)) allocate(this%zofis(lm)) allocate(this%isofz(lm_a)) + this%l_vert_stretched_filtgrid=l_vert_stretched_filtgrid #if 1 - if(this%l_vert_varied_ampl01 ) then + if(this%l_vert_stretched_filtgrid ) then call convert_vert_varied_aspt !in which the mg_ampl01 will be re-defined endif @@ -605,7 +604,7 @@ subroutine init_mg_parameter(this,inputfilename) this%l_vertical_filter=l_vertical_filter this%l_anal_sub_of_filt=l_anal_sub_of_filt this%l_vert_stretched_filtgrid=l_vert_stretched_filtgrid - this%l_vert_varied_ampl01=l_vert_varied_ampl01 +!clt this%l_vert_varied_ampl01=l_vert_varied_ampl01 this%l_for_localization=l_for_localization this%l_mgbf_inhomogeneous = l_mgbf_inhomogeneous this%ldelta=ldelta @@ -943,11 +942,15 @@ subroutine convert_vert_varied_aspt real(r_kind)::sstop,dss real (r_kind),allocatable,dimension(:)::sigofz real (r_kind),allocatable,dimension(:)::sigofis + integer(i_kind):: user_mpi_real allocate(this%aspect_vert_profile_angrid(lm_a),this%aspect_vert_profile_filtgrid(lm)) allocate(sigofz(lm_a),sigofis(lm)) call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr) - if(l_vert_stretched_filtgrid) then + write(6,*)'thinkdeb mype is ',mype, l_vert_stretched_filtgrid + write(6,*)'thinkdeb mype is lm_a ',mype, lm_a,lm + call flush(6) + if(this%l_vert_stretched_filtgrid) then if(mype.eq.0) then open(newunit=myunit,file="mgbf_vert_aspt_profile.txt",status='old') read(myunit,*)lm_tmp @@ -957,25 +960,41 @@ subroutine convert_vert_varied_aspt do i=1,lm_a read(myunit,*)this%aspect_vert_profile_angrid(i) enddo + close(myunit) endif - call MPI_Type_match_size(MPI_TYPECLASS_REAL, kind(this%aspect_vert_profile_angrid), mpi_real, ierr) + write(6,*)'thinkdeb mype is 1.1.0 ',mype + write(6,*) 'DEBUG: lm_a=', lm_a +write(6,*) 'DEBUG: allocated=', allocated(this%aspect_vert_profile_angrid) +if (allocated(this%aspect_vert_profile_angrid)) then + write(6,*) 'DEBUG: size=', size(this%aspect_vert_profile_angrid) + write(6,*) 'DEBUG: kind1=', kind(this%aspect_vert_profile_angrid(1)) +endif + call MPI_Type_match_size(MPI_TYPECLASS_REAL, kind(this%aspect_vert_profile_angrid(1)), user_mpi_real, ierr) if (ierr /= MPI_SUCCESS) then - write(6,*) "ERROR: No matching MPI type for real kind =", kind(this%aspect_vert_profile_angrid) + write(6,*) "ERROR: No matching MPI type for real kind =", kind(this%aspect_vert_profile_angrid(1)) call MPI_Abort(MPI_COMM_WORLD, 1, ierr) endif - call MPI_Bcast(this%aspect_vert_profile_angrid, lm_a, mpi_real, 0, MPI_COMM_WORLD, ierr) + write(6,*)'thinkdeb mype is 1.2 ',mype + call flush(6) + call MPI_Bcast(this%aspect_vert_profile_angrid, lm_a, user_mpi_real, 0, MPI_COMM_WORLD, ierr) ! nz=lm_a-1 ! ns=lm-1 + write(6,*)'thinkdeb mype is 1 ',mype + call flush(6) ! calibrate sigscale to make sigofz go to sigbottom at z=0: sigofz=this%aspect_vert_profile_angrid - print'('' list the levels and sigofz from the top down:'')' + print'('' list the levels and sigofz from the top down:'')' + write(6,*)'thinkdeb mype is 3 ',mype + call flush(6) if(mype==0) then do iz=lm_a,1,-1 write(6,*)iz,sigofz(iz) enddo endif + write(6,*)'thinkdeb mype is 3 ',mype + call flush(6) ! Make the new grid whose resolution of the correlation scale sigofz ! is uniform throughout. @@ -983,17 +1002,24 @@ subroutine convert_vert_varied_aspt ! zofis is the z-index coordinate of each of the new s-grid points. !cltorg call make_ssgrid(nz,nf,ns,sigofz, sstop,dss,isofz,zofis) call make_ssgrid(lm_a-1,nf,lm-1,sigofz, sstop,dss,this%isofz,this%zofis) + write(6,*)'thinkdeb mype is after make_ssgrid ',mype + call flush(6) ! Use the new s-grid locations zofis, and the original profile of ! correlation scales sigofz, to interpolate, smoothly and positively, ! these scales sig to each of the new s-grid points: !clt call logintgrid(nz,ns,zofis,sigofz,sigofis) call logintgrid(lm_a-1,lm-1,this%zofis,sigofz,sigofis) - if(mype==0) then print'('' list the profile coordinates of zofis,sigofis, for each is:'')' do is=1,lm write(6,*)is,this%zofis(is),sigofis(is) enddo + if(mype==6) then + open(newunit=myunit,file="converted_mgbf_vert_aspt_profile.txt",status='replace') + do is=1,lm + write(myunit,*)is,this%zofis(is),sigofis(is) + enddo + close(myunit) endif mg_ampl01=sum(sigofis)/size(sigofis) diff --git a/src/saber/mgbf/mgbf_lib/phint.f90 b/src/saber/mgbf/mgbf_lib/phint.f90 index 431d6088d..58be7bfcd 100644 --- a/src/saber/mgbf/mgbf_lib/phint.f90 +++ b/src/saber/mgbf/mgbf_lib/phint.f90 @@ -86,6 +86,7 @@ subroutine whint(x,wint)! [whint] ! from a uniform grid to a target located a fraction, x, into the central ! of the three intervals defined by the four points. !============================================================================= + implicit none real(r_kind), intent(in ):: x real(r_kind),dimension(-1:2),intent(out):: wint diff --git a/src/saber/mgbf/mgbf_lib/phint1.f90 b/src/saber/mgbf/mgbf_lib/phint1.f90 index 55e7c192c..2f50b0f22 100644 --- a/src/saber/mgbf/mgbf_lib/phint1.f90 +++ b/src/saber/mgbf/mgbf_lib/phint1.f90 @@ -17,13 +17,26 @@ module phint1 !============================================================================ use mgbf_kinds, only: i_kind,r_kind +use phint, only: wint3,whint,v1_wint3,v1_whint implicit none public -public:: make_ssgrid, logintgrid +public:: make_ssf, make_ssgrid, intftos, sstosig, logintgrid, zsigtossig +interface make_ssf + module procedure make_ssf +end interface make_ssf interface make_ssgrid module procedure make_ssgrid end interface make_ssgrid +interface zsigtossig + module procedure zsigtossig +end interface zsigtossig +interface intftos + module procedure intftos +end interface intftos +interface sstosig + module procedure sstosig +end interface sstosig interface logintgrid module procedure logintgrid end interface logintgrid @@ -47,7 +60,6 @@ subroutine make_ssgrid(nz,nf,ns,sigofz,sstop,dss,isofz,zofis)! [make_ssgrid] ! out new scale-grid. All grids are assumed to go from index 0. !============================================================================ use jp_pietc, only: u1,o2 -use phint, only: wint3,whint implicit none integer(i_kind), intent(in ):: nz,nf,ns real(r_kind),dimension(0:nz),intent(in ):: sigofz @@ -64,38 +76,10 @@ subroutine make_ssgrid(nz,nf,ns,sigofz,sstop,dss,isofz,zofis)! [make_ssgrid] integer(i_kind) :: iz,izf,izfm,izfp,is,nzf !============================================================================ ! Interpolate the log of the sigofz distribution to a finer grid: -do iz=0,nz - zs(iz)=iz - logsig(iz)=log(sigofz(iz)) -enddo dzf=u1/nf nzf=nz*nf -do izf=0,nzf - zsf(izf)=izf*dzf -enddo - -do izf=0,nzf - z=zsf(izf) - iz=min(nz-1,max(0,floor(z))) - if(iz==0)then - call wint3(zs(0:2),z,w3) - logsigf(izf)=dot_product(w3,logsig(0:2)) - elseif(iz==nz-1)then - call wint3(zs(nz-2:nz),z,w3) - logsigf(izf)=dot_product(w3,logsig(nz-2:nz)) - else - call whint(zs(iz-1:iz+2),z,w4) - logsigf(izf)=dot_product(w4,logsig(iz-1:iz+2)) - endif -enddo - -ssf(0)=0 -do izf=1,nzf - izfm=izf-1 - ssf(izf)=ssf(izfm)+exp(-(logsigf(izfm)+logsigf(izf))*o2)*dzf -enddo -sstop =ssf(nzf) - +call make_ssf(nz,nf,sigofz,ssf) +sstop=ssf(nzf) ! define the new grid of ns spaces that uniformly divides the ! range of ss: dss=sstop/ns @@ -123,6 +107,83 @@ subroutine make_ssgrid(nz,nf,ns,sigofz,sstop,dss,isofz,zofis)! [make_ssgrid] enddo end subroutine make_ssgrid +!=========================================================================== +subroutine zsigtossig(nz,nf,ns,zofs,sigofz,sigofs)! [zsigtossig] +!=========================================================================== +! Interpolate the sigma in z-grid units from the z-grid to the +! equivalent sigma in s-grid unit in the s-grid. The z-grid index +! coordinates of the each s-grid level is given by zofs. The index +! range of the z-grid is [0:nz], of the s-grid it is [0:ns] and an +! intermediate refined version of the z-grid has index range, [0:nz*nf] +! where nf is a positive integer refinement factor to ensure that the +! intermediate calculations have only small truncation errors. +! sigofz is the z-grid sigma, sigofs is the computed s-grid sigma. +!=========================================================================== +implicit none +integer(i_kind), intent(in ):: nz,nf,ns +real(r_kind),dimension(0:ns),intent(in ):: zofs +real(r_kind),dimension(0:nz),intent(in ):: sigofz +real(r_kind),dimension(0:ns),intent(out):: sigofs +!--------------------------------------------------------------------------- +real(r_kind),dimension(0:nz*nf):: ssf,sss +!========================================================================== +call make_ssf(nz,nf,sigofz,ssf) +call intftos(nz,nf,ns,zofs,ssf,sss) +call sstosig(ns,sss,sigofs) +end subroutine zsigtossig + +!============================================================================ +subroutine intftos(nz,nf,ns,zofs,ssf,sss)! [intftos] +!============================================================================ +! Linearly interpolate values ssf on the fine grid [0:nz*nf] to the ss grid [0:ns] +! whose coordinates in fine grid index units are zofs*nf, where nf is the +! refinement factor that was used to generate the fine grid for the original +! [0:nz] grid. (zofs are the index coordinate in that original [0:nz] grid.) +!============================================================================ +implicit none +integer(i_kind), intent(in ):: nz,nf,ns +real(r_kind),dimension(0:ns), intent(in ):: zofs +real(r_kind),dimension(0:nz*ns),intent(in ):: ssf +real(r_kind),dimension(0:ns), intent(out):: sss +!---------------------------------------------------------------------------- +real(r_kind) :: w1,w2,zf +integer(i_kind):: is,izf,izfp,nzf +!============================================================================ +nzf=nz*nf +do is=0,ns + zf=zofs(is)*nf + izf=min(nzf-1,max(0,floor(zf))) + izfp=izf+1 + w1=izfp-zf + w2=zf-izf + sss(is)=w1*ssf(izf)+w2*ssf(izfp)! <- linearly interpolate +enddo +end subroutine intftos + +!=========================================================================== +subroutine sstosig(ns,ss,sig)! [sstosig] +!=========================================================================== +! Given the effective distance in correlation scale units ss of each grid +! s-gridpoint in [0:ns], from the datum (usually from gridpoint 0), use +! simple finite differences to convert the information in ss to the corresponding +! sigma values, sig, at each grid point, where sig measures the correlation +! scale at each point in the grid units. +!=========================================================================== +use jp_pietc, only: u1,u2 +implicit none +integer(i_kind), intent(in ):: ns +real(r_kind),dimension(0:ns),intent(in ):: ss +real(r_kind),dimension(0:ns),intent(out):: sig +!---------------------------------------------------------------------------- +integer(i_kind):: is +!============================================================================ +sig(0)=u1/(ss(1)-ss(0)) +do is=1,ns-1 + sig(is)=u2/(ss(is+1)-ss(is-1)) +enddo +sig(ns)=u1/(ss(ns)-ss(ns-1)) +end subroutine sstosig + !============================================================================ subroutine logintgrid(nz,ns,zofs,az, as)! [logintgrid] !============================================================================ @@ -131,7 +192,6 @@ subroutine logintgrid(nz,ns,zofs,az, as)! [logintgrid] ! of target values, as, all remain positive. The array zofs ! defines the index z-grid coordinates of each of the s-grid points. !============================================================================ -use phint, only: wint3,whint implicit none integer(i_kind), intent(in ):: nz,ns real(r_kind),dimension(0:ns),intent(in ):: zofs @@ -164,6 +224,62 @@ subroutine logintgrid(nz,ns,zofs,az, as)! [logintgrid] as(is)=exp(logas) enddo end subroutine logintgrid +subroutine make_ssf(nz,nf,sigofz,ssf)! [make_ssf] +!============================================================================ +! Use the scales, in original [0:nz] "z-grid" units, sigofz, to define an effective +! integrated distance, ss, in these scale units, for every level of a refined version +! [0:nz*nf] of that original z grid. This is done by regarding each sigofz as the +! inverse of the derivative of ss wrt the z-index, and integrating the interpolated +! inverse of sigofz on a uniformly refined version [0:nz*nf] of the z grid. To avoid +! small or negative values occurring in the interpolation, it is actually the +! logarithm of (1/sigofz) (i.e., -log(sigofz) ) that we interpolate. The fine grid +! of values of ss are returns as the array ssf. +!============================================================================ +use jp_pietc, only: u1,o2 +implicit none +integer(i_kind), intent(in ):: nz,nf +real(r_kind),dimension(0:nz), intent(in ):: sigofz +real(r_kind),dimension(0:nz*nf),intent(out):: ssf +!----------------------------------------------------------------------------- +real(r_kind),dimension(0:nz*nf):: zsf,logsigf +real(r_kind),dimension(0:nz) :: zs,logsig +real(r_kind),dimension(3) :: w3 +real(r_kind),dimension(4) :: w4 +real(r_kind) :: dzf,z +integer(i_kind) :: izf,izfm,iz,nzf +!============================================================================= +! Interpolate the log of the sigofz distribution to a finer grid: +do iz=0,nz + zs(iz)=iz + logsig(iz)=log(sigofz(iz)) +enddo +dzf=u1/nf +nzf=nz*nf +do izf=0,nzf + zsf(izf)=izf*dzf +enddo + +do izf=0,nzf + z=zsf(izf) + iz=min(nz-1,max(0,floor(z))) + if(iz==0)then + call wint3(zs(0:2),z,w3) + logsigf(izf)=dot_product(w3,logsig(0:2)) + elseif(iz==nz-1)then + call wint3(zs(nz-2:nz),z,w3) + logsigf(izf)=dot_product(w3,logsig(nz-2:nz)) + else + call whint(zs(iz-1:iz+2),z,w4) + logsigf(izf)=dot_product(w4,logsig(iz-1:iz+2)) + endif +enddo + +ssf(0)=0 +do izf=1,nzf + izfm=izf-1 + ssf(izf)=ssf(izfm)+exp(-(logsigf(izfm)+logsigf(izf))*o2)*dzf +enddo +end subroutine make_ssf subroutine intgrid(nz,ns,zofs,az, as)! [logintgrid] !clt modified from logintgrid, but don't do the log transformation !============================================================================ @@ -172,7 +288,6 @@ subroutine intgrid(nz,ns,zofs,az, as)! [logintgrid] ! of target values, as, all remain positive. The array zofs ! defines the index z-grid coordinates of each of the s-grid points. !============================================================================ -use phint, only: wint3,whint implicit none integer(i_kind), intent(in ):: nz,ns real(r_kind),dimension(0:ns),intent(in ):: zofs @@ -207,7 +322,6 @@ subroutine intgrid_ad(nz, ns, zofs, az_ad, as_ad) !--------------------------------------------------------------------- ! Adjoint of intgrid: propagate adjoint variables from as_ad to az_ad !--------------------------------------------------------------------- -use phint, only: wint3, whint implicit none integer(i_kind), intent(in) :: nz, ns real(r_kind), dimension(0:ns),intent(in) :: zofs @@ -259,7 +373,6 @@ subroutine intgrid_f2a(nz, ns, zofs, as, az) ! Output: ! - az(0:nz) : interpolated values on full fine grid !------------------------------------------------------------------------------- -use phint, only: wint3, whint implicit none integer(i_kind), intent(in) :: nz, ns @@ -311,7 +424,6 @@ subroutine intgrid_f2a_ad(nz, ns, zofs, az_ad, as_ad) ! Output: ! - as_ad(0:ns) : adjoint values on coarse grid (to be accumulated) !------------------------------------------------------------------------------- -use phint, only: wint3, whint implicit none integer(i_kind), intent(in) :: nz, ns @@ -354,11 +466,10 @@ subroutine intgrid_f2a_3d(nz, ns, nx, ny, zofs, az,as) ! Interpolates in vertical (first) dimension using zofs(0:ns,nx,ny) ! Output: az(0:nz, nx, ny) !------------------------------------------------------------------------------ -use phint, only: wint3, whint implicit none integer(i_kind), intent(in) :: nz, ns, nx, ny -real(r_kind), dimension(0:ns,nx,ny), intent(in) :: zofs +real(r_kind), dimension(0:ns), intent(in) :: zofs real(r_kind), dimension(0:ns,nx,ny), intent(in) :: as real(r_kind), dimension(0:nz,nx,ny), intent(out) :: az @@ -369,6 +480,7 @@ subroutine intgrid_f2a_3d(nz, ns, nx, ny, zofs, az,as) integer(i_kind) :: i, j, k, s !------------------------------------------------------------------------------ +write(6,*)'thinkdeb10000 zofs in interpolation zofs ',zofs do j = 1, ny do i = 1, nx do k = 0, nz @@ -376,18 +488,18 @@ subroutine intgrid_f2a_3d(nz, ns, nx, ny, zofs, az,as) ! Find s such that zofs(s+1,i,j) > z ≥ zofs(s,i,j) s = 0 - do while (s < ns .and. zofs(s+1,i,j) < z) + do while (s < ns .and. zofs(s+1) < z) s = s + 1 end do if (s <= 1) then - call wint3(zofs(0:2,i,j), z, w3) + call wint3(zofs(0:2), z, w3) az(k,i,j) = dot_product(w3, as(0:2,i,j)) elseif (s >= ns-1) then - call wint3(zofs(ns-2:ns,i,j), z, w3) + call wint3(zofs(ns-2:ns), z, w3) az(k,i,j) = dot_product(w3, as(ns-2:ns,i,j)) else - call whint(zofs(s-1:s+2,i,j), z, w4) + call whint(zofs(s-1:s+2), z, w4) az(k,i,j) = dot_product(w4, as(s-1:s+2,i,j)) end if @@ -396,16 +508,63 @@ subroutine intgrid_f2a_3d(nz, ns, nx, ny, zofs, az,as) end do end subroutine intgrid_f2a_3d +subroutine intgrid_f2a_3d_top2bot(nz, ns, nx, ny, zofs, az, as) +!------------------------------------------------------------------------------ +! Interpolates in vertical (first) dimension using zofs(0:ns,nx,ny) +! Arrays are stored from top (0) to bottom (ns/nz) +! Output: az(0:nz, nx, ny) +!------------------------------------------------------------------------------ +implicit none + +integer(i_kind), intent(in) :: nz, ns, nx, ny +real(r_kind), dimension(0:ns), intent(in) :: zofs +real(r_kind), dimension(0:ns,nx,ny), intent(in) :: as +real(r_kind), dimension(0:nz,nx,ny), intent(out) :: az + +! Local +real(r_kind), dimension(3) :: w3 +real(r_kind), dimension(4) :: w4 +real(r_kind) :: z +integer(i_kind) :: i, j, k, s + +!------------------------------------------------------------------------------ +do j = 1, ny + do i = 1, nx + do k = 0, nz + z = real(nz - k, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) + + ! Find s such that zofs(s+1) < z ≤ zofs(s) + s = 0 + do while (s < ns .and. zofs(s+1) < z) + s = s + 1 + end do + + if (s <= 1) then + call v1_wint3(zofs(0:2), z, w3) + az(k,i,j) = dot_product(w3, as(0:2,i,j)) + elseif (s >= ns-1) then + call v1_wint3(zofs(ns-2:ns), z, w3) + az(k,i,j) = dot_product(w3, as(ns-2:ns,i,j)) + else + call v1_whint(zofs(s-1:s+2), z, w4) + az(k,i,j) = dot_product(w4, as(s-1:s+2,i,j)) + end if + + end do + end do +end do + +end subroutine intgrid_f2a_3d_top2bot + subroutine intgrid_f2a_3d_ad(nz, ns, nx, ny, zofs, az_ad, as_ad) !------------------------------------------------------------------------------ ! Adjoint of intgrid_synthesis_3d ! Accumulates az_ad(0:nz,nx,ny) into as_ad(0:ns,nx,ny) !------------------------------------------------------------------------------ -use phint, only: wint3, whint implicit none integer(i_kind), intent(in) :: nz, ns, nx, ny -real(r_kind), dimension(0:ns,nx,ny), intent(in) :: zofs +real(r_kind), dimension(0:ns), intent(in) :: zofs real(r_kind), dimension(0:nz,nx,ny), intent(in) :: az_ad real(r_kind), dimension(0:ns,nx,ny), intent(inout) :: as_ad ! inout to accumulate @@ -416,32 +575,94 @@ subroutine intgrid_f2a_3d_ad(nz, ns, nx, ny, zofs, az_ad, as_ad) integer(i_kind) :: i, j, k, s !------------------------------------------------------------------------------ +write(6,*)'intgrid_f2a_3d_ad 1 ',ny,nx,nz +!clt todo some optimization could be done, when the interpolation coeff is homogeneous do j = 1, ny do i = 1, nx do k = 0, nz z = real(k, r_kind) s = 0 - do while (s < ns .and. zofs(s+1,i,j) < z) + do while (s < ns .and. zofs(s+1) < z) s = s + 1 end do if (s <= 1) then - call wint3(zofs(0:2,i,j), z, w3) + call wint3(zofs(0:2), z, w3) as_ad(0:2,i,j) = as_ad(0:2,i,j) + az_ad(k,i,j) * w3 elseif (s >= ns-1) then - call wint3(zofs(ns-2:ns,i,j), z, w3) + call wint3(zofs(ns-2:ns), z, w3) as_ad(ns-2:ns,i,j) = as_ad(ns-2:ns,i,j) + az_ad(k,i,j) * w3 else - call whint(zofs(s-1:s+2,i,j), z, w4) + call whint(zofs(s-1:s+2), z, w4) as_ad(s-1:s+2,i,j) = as_ad(s-1:s+2,i,j) + az_ad(k,i,j) * w4 end if end do end do end do +write(6,*)'intgrid_f2a_3d_ad 100' +call flush(6) end subroutine intgrid_f2a_3d_ad +subroutine intgrid_f2a_3d_ad_top2bot(nz, ns, nx, ny, zofs, az, as) +!------------------------------------------------------------------------------ +! Adjoint of vertical interpolation: accumulates from az (on z) to as (on s) +! Arrays are stored from top (0) to bottom (ns/nz) +! Input: az(0:nz, nx, ny) +! Output: as(0:ns, nx, ny) (accumulated) +!------------------------------------------------------------------------------ +implicit none + +integer(i_kind), intent(in) :: nz, ns, nx, ny +real(r_kind), dimension(0:ns), intent(in) :: zofs +real(r_kind), dimension(0:nz,nx,ny), intent(in) :: az +real(r_kind), dimension(0:ns,nx,ny), intent(inout) :: as + +! Local +real(r_kind), dimension(3) :: w3 +real(r_kind), dimension(4) :: w4 +real(r_kind) :: z +integer(i_kind) :: i, j, k, s, m + +!------------------------------------------------------------------------------ +! Zero out as (if not already done) +as(:,:,:) = 0.0_r_kind + +do j = 1, ny + do i = 1, nx + do k = 0, nz + z = real(nz - k, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) + + ! Find s such that zofs(s+1) < z ≤ zofs(s) + s = 0 + do while (s < ns .and. zofs(s+1) < z) + s = s + 1 + end do + + if (s <= 1) then + call v1_wint3(zofs(0:2), z, w3) + do m = 0, 2 + as(m,i,j) = as(m,i,j) + w3(m+1) * az(k,i,j) + end do + elseif (s >= ns-1) then + call v1_wint3(zofs(ns-2:ns), z, w3) + do m = ns-2, ns + as(m,i,j) = as(m,i,j) + w3(m-ns+3) * az(k,i,j) + end do + else + call v1_whint(zofs(s-1:s+2), z, w4) + do m = s-1, s+2 + as(m,i,j) = as(m,i,j) + w4(m-s+2) * az(k,i,j) + end do + end if + + end do + end do +end do + +end subroutine intgrid_f2a_3d_ad_top2bot + From 65bbe5aa9e5d6f7a8b39e680039760b2f560a0cd Mon Sep 17 00:00:00 2001 From: TingLei-NOAA Date: Mon, 28 Jul 2025 22:27:59 -0400 Subject: [PATCH 040/199] add *top2bot*fast subs --- src/saber/mgbf/mgbf_lib/phint1.f90 | 159 +++++++++++++++++++++++++++++ 1 file changed, 159 insertions(+) diff --git a/src/saber/mgbf/mgbf_lib/phint1.f90 b/src/saber/mgbf/mgbf_lib/phint1.f90 index 2f50b0f22..4f66a62d0 100644 --- a/src/saber/mgbf/mgbf_lib/phint1.f90 +++ b/src/saber/mgbf/mgbf_lib/phint1.f90 @@ -556,6 +556,165 @@ subroutine intgrid_f2a_3d_top2bot(nz, ns, nx, ny, zofs, az, as) end subroutine intgrid_f2a_3d_top2bot +subroutine intgrid_f2a_3d_top2bot_fast(nz, ns, nx, ny, zofs, az, as) +!------------------------------------------------------------------------------ +! Optimized vertical interpolation (top-to-bottom storage) +! Precomputes mapping and weights, then applies to all horizontal points +!------------------------------------------------------------------------------ +use phint, only: wint3, whint +implicit none + +integer(i_kind), intent(in) :: nz, ns, nx, ny +real(r_kind), dimension(0:ns), intent(in) :: zofs +real(r_kind), dimension(0:ns,nx,ny), intent(in) :: as +real(r_kind), dimension(0:nz,nx,ny), intent(out) :: az + +! Local +integer :: k, s, m, i, j +real(r_kind) :: z +integer, parameter :: wint3_type=1, wint3_top_type=2, whint_type=3 +integer, dimension(0:nz) :: interp_type +integer, dimension(4,0:nz) :: src_inds +real(r_kind), dimension(4,0:nz) :: weights +real(r_kind), dimension(3) :: w3 +real(r_kind), dimension(4) :: w4 + +!------------------ Precompute indices and weights ---------------------------- +do k = 0, nz + z = real(nz - k, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) + s = 0 + do while (s < ns .and. zofs(s+1) < z) + s = s + 1 + end do + + if (s <= 1) then + call wint3(zofs(0:2), z, w3) + interp_type(k) = wint3_type + src_inds(1:3,k) = (/0,1,2/) + weights(1:3,k) = w3 + src_inds(4,k) = -1 + weights(4,k) = 0.0_r_kind + elseif (s >= ns-1) then + call wint3(zofs(ns-2:ns), z, w3) + interp_type(k) = wint3_top_type + src_inds(1:3,k) = (/ns-2, ns-1, ns/) + weights(1:3,k) = w3 + src_inds(4,k) = -1 + weights(4,k) = 0.0_r_kind + else + call whint(zofs(s-1:s+2), z, w4) + interp_type(k) = whint_type + src_inds(1:4,k) = (/s-1, s, s+1, s+2/) + weights(1:4,k) = w4 + end if +end do + +!------------------ Apply interpolation using precomputed weights ------------- +do j = 1, ny + do i = 1, nx + do k = 0, nz + select case (interp_type(k)) + case (wint3_type, wint3_top_type) + az(k,i,j) = 0.0_r_kind + do m = 1, 3 + az(k,i,j) = az(k,i,j) + weights(m,k) * as(src_inds(m,k),i,j) + end do + case (whint_type) + az(k,i,j) = 0.0_r_kind + do m = 1, 4 + az(k,i,j) = az(k,i,j) + weights(m,k) * as(src_inds(m,k),i,j) + end do + end select + end do + end do +end do + +end subroutine intgrid_f2a_3d_top2bot_fast + +subroutine intgrid_f2a_3d_ad_top2bot_fast(nz, ns, nx, ny, zofs, az_ad, as_ad) +!------------------------------------------------------------------------------ +! Optimized adjoint of vertical interpolation (top-to-bottom storage) +! Precomputes mapping and weights, then applies to all horizontal points +! Input: az_ad(0:nz, nx, ny) +! Output: as_ad(0:ns, nx, ny) (accumulated) +!------------------------------------------------------------------------------ +use phint, only: wint3, whint +implicit none + +integer(i_kind), intent(in) :: nz, ns, nx, ny +real(r_kind), dimension(0:ns), intent(in) :: zofs +real(r_kind), dimension(0:nz,nx,ny), intent(in) :: az_ad +real(r_kind), dimension(0:ns,nx,ny), intent(inout) :: as_ad + +! Local +integer :: k, s, m, i, j +real(r_kind) :: z +integer, parameter :: wint3_type=1, wint3_top_type=2, whint_type=3 +integer, dimension(0:nz) :: interp_type +integer, dimension(4,0:nz) :: src_inds +real(r_kind), dimension(4,0:nz) :: weights +real(r_kind), dimension(3) :: w3 +real(r_kind), dimension(4) :: w4 + +!------------------ Precompute indices and weights ---------------------------- +do k = 0, nz + z = real(nz - k, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) + s = 0 + do while (s < ns .and. zofs(s+1) < z) + s = s + 1 + end do + + if (s <= 1) then + call wint3(zofs(0:2), z, w3) + interp_type(k) = wint3_type + src_inds(1:3,k) = (/0,1,2/) + weights(1:3,k) = w3 + src_inds(4,k) = -1 + weights(4,k) = 0.0_r_kind + elseif (s >= ns-1) then + call wint3(zofs(ns-2:ns), z, w3) + interp_type(k) = wint3_top_type + src_inds(1:3,k) = (/ns-2, ns-1, ns/) + weights(1:3,k) = w3 + src_inds(4,k) = -1 + weights(4,k) = 0.0_r_kind + else + call whint(zofs(s-1:s+2), z, w4) + interp_type(k) = whint_type + src_inds(1:4,k) = (/s-1, s, s+1, s+2/) + weights(1:4,k) = w4 + end if +end do + +!------------------ Apply adjoint interpolation using precomputed weights ------------- +! as_ad should be initialized to zero before accumulation +as_ad(:,:,:) = 0.0_r_kind + +do j = 1, ny + do i = 1, nx + do k = 0, nz + select case (interp_type(k)) + case (wint3_type, wint3_top_type) + do m = 1, 3 + if (src_inds(m,k) >= 0 .and. src_inds(m,k) <= ns) then + as_ad(src_inds(m,k),i,j) = as_ad(src_inds(m,k),i,j) + weights(m,k) * az_ad(k,i,j) + end if + end do + case (whint_type) + do m = 1, 4 + if (src_inds(m,k) >= 0 .and. src_inds(m,k) <= ns) then + as_ad(src_inds(m,k),i,j) = as_ad(src_inds(m,k),i,j) + weights(m,k) * az_ad(k,i,j) + end if + end do + end select + end do + end do +end do + +end subroutine intgrid_f2a_3d_ad_top2bot_fast + + + subroutine intgrid_f2a_3d_ad(nz, ns, nx, ny, zofs, az_ad, as_ad) !------------------------------------------------------------------------------ ! Adjoint of intgrid_synthesis_3d From 5c9c06ad6aa6f29d71aa0f7c960642591ed872cd Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 29 Jul 2025 14:28:14 +0000 Subject: [PATCH 041/199] WIP --- src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 3 +- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 3 +- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 18 ++- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 37 +----- src/saber/mgbf/mgbf_lib/phint.f90 | 161 ++++++++++++++++++++++- src/saber/mgbf/mgbf_lib/phint1.f90 | 100 ++++++++------ 6 files changed, 242 insertions(+), 80 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index b4bfe754d..cb08af508 100755 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -866,7 +866,8 @@ module subroutine filtering_lin2_bkg(this) !---------------------------------------------------------------------- !*** !*** Adjoint of beta filter in vertical direction -!*** +!**wr* +write(6,*)'thinkdeb999 l_vertical_fitler ',l_vertical_filter 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) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 76a582354..9bb3b1c2c 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1601,7 +1601,8 @@ subroutine deallocate_mg_intstate(this) if(this%l_loc) then deallocate(this%w1_loc,this%w2_loc,this%w3_loc,this%w4_loc) endif -deallocate( this%aspect_vert_profile_angrid ,this%aspect_vert_profile_filtgrid) +if (allocated(this%aspect_vert_profile_angrid) ) deallocate( this%aspect_vert_profile_angrid) +if (allocated(this%aspect_vert_profile_filtgrid) ) deallocate( this%aspect_vert_profile_filtgrid) end subroutine deallocate_mg_intstate diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 622b85030..52bc71073 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -984,7 +984,7 @@ subroutine convert_vert_varied_aspt call flush(6) ! calibrate sigscale to make sigofz go to sigbottom at z=0: - sigofz=this%aspect_vert_profile_angrid + sigofz=sqrt(this%aspect_vert_profile_angrid) print'('' list the levels and sigofz from the top down:'')' write(6,*)'thinkdeb mype is 3 ',mype call flush(6) @@ -1009,22 +1009,28 @@ subroutine convert_vert_varied_aspt ! correlation scales sigofz, to interpolate, smoothly and positively, ! these scales sig to each of the new s-grid points: !clt call logintgrid(nz,ns,zofis,sigofz,sigofis) - call logintgrid(lm_a-1,lm-1,this%zofis,sigofz,sigofis) + call zsigtossig(lm_a-1,nf,lm-1,this%zofis,sigofz,sigofis) print'('' list the profile coordinates of zofis,sigofis, for each is:'')' do is=1,lm - write(6,*)is,this%zofis(is),sigofis(is) + write(6,*)is,this%zofis(is),(sigofis(is))**2 enddo if(mype==6) then open(newunit=myunit,file="converted_mgbf_vert_aspt_profile.txt",status='replace') do is=1,lm - write(myunit,*)is,this%zofis(is),sigofis(is) + write(myunit,*)is,this%zofis(is),(sigofis(is))**2 enddo close(myunit) endif - mg_ampl01=sum(sigofis)/size(sigofis) + mg_ampl01=(sum(sigofis**2)/size(sigofis)) + write(6,*)'thinkdeb999 the converted mg_mapl01 is ',mg_ampl01 +!clt if(this%l_2dvar_last_vertical_level == .true. ) then !the fieldset passed into mgbf will be top-down,so +!clttodo need to access this from mgbf lib too + this%zofis=this%zofis(lm:1:-1) - endif +!# endif + endif + deallocate(sigofz,sigofis) end subroutine convert_vert_varied_aspt diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index 914a08ef2..9817b2993 100755 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -160,8 +160,11 @@ module subroutine anal_to_filt_all(this,WORKA) !clt call this%lwq_vertical_adjoint(nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) !cltorg call this%lwq_vertical_adjoint(this%lm_a,this%lm,1,nm,1,mm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref, & !clt worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) + write(6,*)'thinkdeb999 l_vert_stretched_filtgrid is ',this%l_vert_stretched_filtgrid if (this%l_vert_stretched_filtgrid) then - call intgrid_f2a_3d_ad(this%lm_a-1,this%lm-1,nm,mm,this%zofis,worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) + write(6,*)'thinkdeb999 l_vert_stretched_filtgrid 2 is ',this%l_vert_stretched_filtgrid + + call intgrid_f2a_3d_ad_top2bot_fast(this%lm_a-1,this%lm-1,nm,mm,this%zofis,worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) else call this%test_vertical_interpolation_adj(this%lm,this%lm_a,1,nm,1,mm, work(lev1_f:lev2_f,:,:), & worka(lev1_a:lev2_a,:,:)) @@ -214,7 +217,7 @@ module subroutine filt_to_anal_all(this,WORKA) !clt call this%lwq_vertical_direct(this%lm,this%lm_a,1,nm,1,mm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref, & !clt work(lev1_f:lev2_f,:,:),worka(lev1_a:lev2_a,:,:)) if (this%l_vert_stretched_filtgrid) then - call intgrid_f2a_3d(this%lm_a-1,this%lm-1,nm,mm,this%zofis,worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) + call intgrid_f2a_3d_top2bot_fast(this%lm_a-1,this%lm-1,nm,mm,this%zofis,worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) else call this%test_vertical_interpolation(this%lm,this%lm_a,1,nm,1,mm, work(lev1_f:lev2_f,:,:), & worka(lev1_a:lev2_a,:,:)) @@ -224,36 +227,6 @@ module subroutine filt_to_anal_all(this,WORKA) worka=work endif deallocate(WORK) -if (2.gt.3) then ! clt -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) -endif !2.gt. 3 !---------------------------------------------------------------------- endsubroutine filt_to_anal_all diff --git a/src/saber/mgbf/mgbf_lib/phint.f90 b/src/saber/mgbf/mgbf_lib/phint.f90 index 58be7bfcd..9387b9b8f 100644 --- a/src/saber/mgbf/mgbf_lib/phint.f90 +++ b/src/saber/mgbf/mgbf_lib/phint.f90 @@ -24,7 +24,7 @@ module phint use jp_pietc, only: u0,u1,u2,o2 implicit none private -public:: hint,whint,wint3 +public:: hint,whint,v1_whint,wint3,v1_wint3 interface hint; module procedure hint,hintd; end interface interface whint @@ -33,6 +33,12 @@ module phint interface wint3 module procedure wint3,wint3d end interface wint3 +interface v1_wint3 + module procedure v1_wint3,v1_wint3d +end interface v1_wint3 +interface v1_whint + module procedure v1_whint,v1_whintd,v1_whintvar,v1_whintvard +end interface v1_whint contains @@ -97,6 +103,24 @@ subroutine whint(x,wint)! [whint] wint=(/-x*xm1*o2, xm1*xp1, -x*xp1*o2, u0 /)*xm1+ & (/ u0, xm1*xm2*o2, -xm2*x, xm1*x*o2 /)*x end subroutine whint +subroutine v1_whint(x,wint)! [whint] +!the same as wint +!============================================================================= +! Return the interpolation weights, wint, for smooth 4-point interpolation +! from a uniform grid to a target located a fraction, x, into the central +! of the three intervals defined by the four points. +!============================================================================= + +implicit none +real(r_kind), intent(in ):: x +real(r_kind),dimension(-1:2),intent(out):: wint +!----------------------------------------------------------------------------- +real(r_kind):: xm1,xp1,xm2 +!============================================================================= +xm2=x-u2; xm1=x-u1; xp1=x+u1 +wint=(/-x*xm1*o2, xm1*xp1, -x*xp1*o2, u0 /)*xm1+ & + (/ u0, xm1*xm2*o2, -xm2*x, xm1*x*o2 /)*x +end subroutine v1_whint !============================================================================= subroutine whintd(x,wint,dwint)! [whint] !============================================================================= @@ -119,6 +143,29 @@ subroutine whintd(x,wint,dwint)! [whint] wint = quad0*xm1+ quad1*x dwint=dquad0*xm1+dquad1*x+quad0+quad1 end subroutine whintd +!============================================================================= +subroutine v1_whintd(x,wint,dwint)! [whint] +!the same as whint +!============================================================================= +! Return the interpolation weights, wint, for smooth 4-point interpolation +! from a uniform grid to a target located a fraction, x, into the central +! of the three intervals defined by the four points. +!============================================================================= +implicit none +real(r_kind), intent(in ):: x +real(r_kind),dimension(-1:2),intent(out):: wint,dwint +!----------------------------------------------------------------------------- +real(r_kind) :: xm1,xp1,xm2 +real(r_kind),dimension(-1:2):: quad0,quad1,dquad0,dquad1 +!============================================================================= +xm2=x-u2; xm1=x-u1; xp1=x+u1 +quad0=(/-x*xm1*o2, xm1*xp1, -x*xp1*o2, u0 /) +quad1=(/ u0,xm1*xm2*o2, -xm2*x, xm1*x*o2 /) +dquad0=(/ -x+o2, u2*x, -x-o2, u0 /) +dquad1=(/ u0, xm1-o2, -u2*xm1, xm1+o2 /) +wint = quad0*xm1+ quad1*x +dwint=dquad0*xm1+dquad1*x+quad0+quad1 +end subroutine v1_whintd !============================================================================= subroutine whintvar(xs,x,wint)! [whint] @@ -144,6 +191,38 @@ subroutine whintvar(xs,x,wint)! [whint] wint=-(/ x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12),u0/)*x2/x12 & +(/u0,x2*x3/(x12*x13),-x1*x3/(x12*x23),x1*x2/(x13*x23)/)*x1/x12 end subroutine whintvar +subroutine v1_whintvar(xs,x,wint)! [whint] +!reversed xs +!0->3,1->2,2->1,3->0 +!============================================================================= +use jp_pkind, only: dp +use jp_pietc, only: u0 +implicit none +real(r_kind),dimension(0:3),intent(in ):: xs +real(r_kind), intent(in ):: x +real(r_kind),dimension(0:3),intent(out):: wint +!----------------------------------------------------------------------------- +real(r_kind):: x01,x12,x23,x02,x13,x0,x1,x2,x3 + +!============================================================================= +!0->3,1->2,2->1,3->0 +!lct x01=xs(1)-xs(0) +x01=xs(2)-xs(3) +!#x12=xs(2)-xs(1) +x12=xs(1)-xs(2) +!clt x23=xs(3)-xs(2) +x23=xs(0)-xs(1) +!clt x02=xs(2)-xs(0) +x02=xs(1)-xs(3) +!clt x13=xs(3)-xs(1) +x13=xs(0)-xs(2) +x0=x-xs(3) +x1=x-xs(2) +x2=x-xs(1) +x3=x-xs(0) +wint=-(/ x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12),u0/)*x2/x12 & + +(/u0,x2*x3/(x12*x13),-x1*x3/(x12*x23),x1*x2/(x13*x23)/)*x1/x12 +end subroutine v1_whintvar !============================================================================= subroutine whintvard(xs,x,wint,dwint)! [whint] @@ -174,6 +253,39 @@ subroutine whintvard(xs,x,wint,dwint)! [whint] +(/u0,(x2+x3)/(x12*x13),-(x1+x3)/(x12*x23),(x1+x2)/(x13*x23)/)*x1/x12 & +(q1+q2)/x12 end subroutine whintvard +subroutine v1_whintvard(xs,x,wint,dwint)! [whint] +!reversed xs,wint,dwint +!0->3,1->2,2->1,3->0 +!============================================================================= +use jp_pkind, only: dp +use jp_pietc, only: u0 +implicit none +real(r_kind),dimension(0:3),intent(in ):: xs +real(r_kind), intent(in ):: x +real(r_kind),dimension(0:3),intent(out):: wint,dwint +!----------------------------------------------------------------------------- +real(r_kind),dimension(0:3):: q1,q2 +real(r_kind) :: x01,x12,x23,x02,x13,x0,x1,x2,x3 +!============================================================================= +!0->3,1->2,2->1,3->0 +x01=xs(2)-xs(3) +x12=xs(1)-xs(2) +x23=xs(0)-xs(1) +x02=xs(1)-xs(3) +x13=xs(0)-xs(2) +x0=x-xs(3) +x1=x-xs(2) +x2=x-xs(1) +x3=x-xs(0) +q1=-(/x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12),u0/) +q2= (/u0,x2*x3/(x12*x13),-x1*x3/(x12*x23),x1*x2/(x13*x23)/) +wint=q1*x2/x12+q2*x1/x12 +dwint=-(/(x1+x2)/(x01*x02),-(x0+x2)/(x01*x12),(x0+x1)/(x02*x12),u0/)*x2/x12 & + +(/u0,(x2+x3)/(x12*x13),-(x1+x3)/(x12*x23),(x1+x2)/(x13*x23)/)*x1/x12 & + +(q1+q2)/x12 +wint=wint(3:0:-1) +dwint=dwint(3:0:-1) +end subroutine v1_whintvard !============================================================================= subroutine wint3(xs,x,wint)! [wint3] @@ -197,6 +309,29 @@ subroutine wint3(xs,x,wint)! [wint3] x2=x-xs(2) wint=(/x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12)/) end subroutine wint3 +subroutine v1_wint3(xs,x,wint)! [wint3] +!the reversed order of xs +!============================================================================= +! Get the weights, wint, for Lagrange 3-point interpolation to x from a +! variable-spaced grid xs +!============================================================================= +use jp_pkind, only: dp +implicit none +real(r_kind),dimension(0:2),intent(in ):: xs +real(r_kind), intent(in ):: x +real(r_kind),dimension(0:2),intent(out):: wint +!----------------------------------------------------------------------------- +real(r_kind):: x01,x12,x02,x0,x1,x2 +!clt 0 -> 2, 1->1,2->0 +!============================================================================= +x01=xs(1)-xs(2) +x12=xs(0)-xs(1) +x02=xs(0)-xs(2) +x0=x-xs(2) +x1=x-xs(1) +x2=x-xs(0) +wint=(/x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12)/) +end subroutine v1_wint3 !============================================================================= subroutine wint3d(xs,x,wint,dwint)! [wint3] @@ -221,6 +356,30 @@ subroutine wint3d(xs,x,wint,dwint)! [wint3] wint=(/x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12)/) dwint=(/(x1+x2)/(x01*x02),-(x0+x2)/(x01*x12),(x0+x1)/(x02*x12)/) end subroutine wint3d +subroutine v1_wint3d(xs,x,wint,dwint)! [wint3] +!============================================================================= +! Get the weights, wint, for Lagrange 3-point interpolation to x from a +! variable-spaced grid xs and the derivative weights dwint. +!============================================================================= +!the reversed order of xs +!clt 0 -> 2, 1->1,2->0 +use jp_pkind, only: dp +implicit none +real(r_kind),dimension(0:2),intent(in ):: xs +real(r_kind), intent(in ):: x +real(r_kind),dimension(0:2),intent(out):: wint,dwint +!----------------------------------------------------------------------------- +real(r_kind):: x01,x12,x02,x0,x1,x2 +!============================================================================= +x01=xs(1)-xs(0) +x12=xs(0)-xs(1) +x02=xs(0)-xs(2) +x0=x-xs(2) +x1=x-xs(1) +x2=x-xs(0) +wint=(/x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12)/) +dwint=(/(x1+x2)/(x01*x02),-(x0+x2)/(x01*x12),(x0+x1)/(x02*x12)/) +end subroutine v1_wint3d end module phint !# diff --git a/src/saber/mgbf/mgbf_lib/phint1.f90 b/src/saber/mgbf/mgbf_lib/phint1.f90 index 4f66a62d0..eda10952d 100644 --- a/src/saber/mgbf/mgbf_lib/phint1.f90 +++ b/src/saber/mgbf/mgbf_lib/phint1.f90 @@ -22,6 +22,9 @@ module phint1 public public:: make_ssf, make_ssgrid, intftos, sstosig, logintgrid, zsigtossig + +!============================================================================ + interface make_ssf module procedure make_ssf end interface make_ssf @@ -60,6 +63,7 @@ subroutine make_ssgrid(nz,nf,ns,sigofz,sstop,dss,isofz,zofis)! [make_ssgrid] ! out new scale-grid. All grids are assumed to go from index 0. !============================================================================ use jp_pietc, only: u1,o2 +use phint, only: wint3,whint implicit none integer(i_kind), intent(in ):: nz,nf,ns real(r_kind),dimension(0:nz),intent(in ):: sigofz @@ -118,15 +122,15 @@ subroutine zsigtossig(nz,nf,ns,zofs,sigofz,sigofs)! [zsigtossig] ! where nf is a positive integer refinement factor to ensure that the ! intermediate calculations have only small truncation errors. ! sigofz is the z-grid sigma, sigofs is the computed s-grid sigma. -!=========================================================================== +!============================================================================ implicit none integer(i_kind), intent(in ):: nz,nf,ns real(r_kind),dimension(0:ns),intent(in ):: zofs real(r_kind),dimension(0:nz),intent(in ):: sigofz real(r_kind),dimension(0:ns),intent(out):: sigofs -!--------------------------------------------------------------------------- +!---------------------------------------------------------------------------- real(r_kind),dimension(0:nz*nf):: ssf,sss -!========================================================================== +!============================================================================ call make_ssf(nz,nf,sigofz,ssf) call intftos(nz,nf,ns,zofs,ssf,sss) call sstosig(ns,sss,sigofs) @@ -135,15 +139,16 @@ end subroutine zsigtossig !============================================================================ subroutine intftos(nz,nf,ns,zofs,ssf,sss)! [intftos] !============================================================================ -! Linearly interpolate values ssf on the fine grid [0:nz*nf] to the ss grid [0:ns] -! whose coordinates in fine grid index units are zofs*nf, where nf is the -! refinement factor that was used to generate the fine grid for the original -! [0:nz] grid. (zofs are the index coordinate in that original [0:nz] grid.) +! Linearly interpolate values ssf on the fine grid [0:nz*nf] to the ss grid +! [0:ns] whose coordinates in fine grid index units are zofs*nf, where nf +! is the refinement factor that was used to generate the fine grid for the +! original [0:nz] grid. (zofs are the index coordinate in that original +! [0:nz] grid.) !============================================================================ implicit none integer(i_kind), intent(in ):: nz,nf,ns real(r_kind),dimension(0:ns), intent(in ):: zofs -real(r_kind),dimension(0:nz*ns),intent(in ):: ssf +real(r_kind),dimension(0:nz*nf),intent(in ):: ssf real(r_kind),dimension(0:ns), intent(out):: sss !---------------------------------------------------------------------------- real(r_kind) :: w1,w2,zf @@ -165,9 +170,9 @@ subroutine sstosig(ns,ss,sig)! [sstosig] !=========================================================================== ! Given the effective distance in correlation scale units ss of each grid ! s-gridpoint in [0:ns], from the datum (usually from gridpoint 0), use -! simple finite differences to convert the information in ss to the corresponding -! sigma values, sig, at each grid point, where sig measures the correlation -! scale at each point in the grid units. +! simple finite differences to convert the information in ss to the +! corresponding sigma values, sig, at each grid point, where sig measures +! the correlation scale at each point in the grid units. !=========================================================================== use jp_pietc, only: u1,u2 implicit none @@ -192,6 +197,7 @@ subroutine logintgrid(nz,ns,zofs,az, as)! [logintgrid] ! of target values, as, all remain positive. The array zofs ! defines the index z-grid coordinates of each of the s-grid points. !============================================================================ +use phint, only: wint3,whint implicit none integer(i_kind), intent(in ):: nz,ns real(r_kind),dimension(0:ns),intent(in ):: zofs @@ -224,18 +230,22 @@ subroutine logintgrid(nz,ns,zofs,az, as)! [logintgrid] as(is)=exp(logas) enddo end subroutine logintgrid + +!============================================================================ subroutine make_ssf(nz,nf,sigofz,ssf)! [make_ssf] !============================================================================ -! Use the scales, in original [0:nz] "z-grid" units, sigofz, to define an effective -! integrated distance, ss, in these scale units, for every level of a refined version -! [0:nz*nf] of that original z grid. This is done by regarding each sigofz as the -! inverse of the derivative of ss wrt the z-index, and integrating the interpolated -! inverse of sigofz on a uniformly refined version [0:nz*nf] of the z grid. To avoid -! small or negative values occurring in the interpolation, it is actually the -! logarithm of (1/sigofz) (i.e., -log(sigofz) ) that we interpolate. The fine grid -! of values of ss are returns as the array ssf. +! Use the scales, in original [0:nz] "z-grid" units, sigofz, to define an +! effective integrated distance, ss, in these scale units, for every level +! of a refined version [0:nz*nf] of that original z grid. This is done by +! regarding each sigofz as the inverse of the derivative of ss wrt the +! z-index, and integrating the interpolated inverse of sigofz on a uniformly +! refined version [0:nz*nf] of the z grid. To avoid small or negative values +! occurring in the interpolation, it is actually the logarithm of (1/sigofz) +! (i.e., -log(sigofz) ) that we interpolate. The fine grid of values of ss +! are returned as the array ssf. !============================================================================ use jp_pietc, only: u1,o2 +use phint, only: wint3,whint implicit none integer(i_kind), intent(in ):: nz,nf real(r_kind),dimension(0:nz), intent(in ):: sigofz @@ -248,7 +258,9 @@ subroutine make_ssf(nz,nf,sigofz,ssf)! [make_ssf] real(r_kind) :: dzf,z integer(i_kind) :: izf,izfm,iz,nzf !============================================================================= -! Interpolate the log of the sigofz distribution to a finer grid: +! Interpolate the log of the sigofz distribution to logsigf on a finer grid: +! (interpolating the logarithm avoids the possibility of negative undershoots +! of the interpolated values). do iz=0,nz zs(iz)=iz logsig(iz)=log(sigofz(iz)) @@ -274,12 +286,17 @@ subroutine make_ssf(nz,nf,sigofz,ssf)! [make_ssf] endif enddo +! Integrate exp(-logsigf), which approximates 1/sigofz, on the fine grid, +! to get ssf: ssf(0)=0 do izf=1,nzf izfm=izf-1 ssf(izf)=ssf(izfm)+exp(-(logsigf(izfm)+logsigf(izf))*o2)*dzf enddo end subroutine make_ssf + + + subroutine intgrid(nz,ns,zofs,az, as)! [logintgrid] !clt modified from logintgrid, but don't do the log transformation !============================================================================ @@ -394,7 +411,7 @@ subroutine intgrid_f2a(nz, ns, zofs, as, az) ! Search for the coarse grid interval that contains z is = 0 - do while (is < ns .and. zofs(is+1) < z) + do while (is < ns-1 .and. zofs(is+1) < z) is = is + 1 end do @@ -443,7 +460,7 @@ subroutine intgrid_f2a_ad(nz, ns, zofs, az_ad, as_ad) ! Find interpolation interval (same logic as in synthesis) is = 0 - do while (is < ns .and. zofs(is+1) < z) + do while (is < ns-1 .and. zofs(is+1) < z) is = is + 1 end do @@ -488,7 +505,7 @@ subroutine intgrid_f2a_3d(nz, ns, nx, ny, zofs, az,as) ! Find s such that zofs(s+1,i,j) > z ≥ zofs(s,i,j) s = 0 - do while (s < ns .and. zofs(s+1) < z) + do while (s < ns-1 .and. zofs(s+1) < z) s = s + 1 end do @@ -531,11 +548,11 @@ subroutine intgrid_f2a_3d_top2bot(nz, ns, nx, ny, zofs, az, as) do j = 1, ny do i = 1, nx do k = 0, nz - z = real(nz - k, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) + z = real(nz - k+1, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) ! Find s such that zofs(s+1) < z ≤ zofs(s) s = 0 - do while (s < ns .and. zofs(s+1) < z) + do while (s < ns-1 .and. zofs(s+1) > z) s = s + 1 end do @@ -561,11 +578,12 @@ subroutine intgrid_f2a_3d_top2bot_fast(nz, ns, nx, ny, zofs, az, as) ! Optimized vertical interpolation (top-to-bottom storage) ! Precomputes mapping and weights, then applies to all horizontal points !------------------------------------------------------------------------------ -use phint, only: wint3, whint +use phint, only: v1_wint3, v1_whint implicit none integer(i_kind), intent(in) :: nz, ns, nx, ny real(r_kind), dimension(0:ns), intent(in) :: zofs +!clt real(r_kind), dimension(0:ns,nx,ny), intent(in) :: as real(r_kind), dimension(0:ns,nx,ny), intent(in) :: as real(r_kind), dimension(0:nz,nx,ny), intent(out) :: az @@ -580,29 +598,32 @@ subroutine intgrid_f2a_3d_top2bot_fast(nz, ns, nx, ny, zofs, az, as) real(r_kind), dimension(4) :: w4 !------------------ Precompute indices and weights ---------------------------- +do k=0,nz +az(k,:,:)=k +enddo do k = 0, nz - z = real(nz - k, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) + z = real(nz - k+1, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) s = 0 - do while (s < ns .and. zofs(s+1) < z) + do while (s < ns-1 .and. zofs(s+1) > z) s = s + 1 end do if (s <= 1) then - call wint3(zofs(0:2), z, w3) + call v1_wint3(zofs(0:2), z, w3) interp_type(k) = wint3_type src_inds(1:3,k) = (/0,1,2/) weights(1:3,k) = w3 src_inds(4,k) = -1 weights(4,k) = 0.0_r_kind elseif (s >= ns-1) then - call wint3(zofs(ns-2:ns), z, w3) + call v1_wint3(zofs(ns-2:ns), z, w3) interp_type(k) = wint3_top_type src_inds(1:3,k) = (/ns-2, ns-1, ns/) weights(1:3,k) = w3 src_inds(4,k) = -1 weights(4,k) = 0.0_r_kind else - call whint(zofs(s-1:s+2), z, w4) + call v1_whint(zofs(s-1:s+2), z, w4) interp_type(k) = whint_type src_inds(1:4,k) = (/s-1, s, s+1, s+2/) weights(1:4,k) = w4 @@ -658,28 +679,28 @@ subroutine intgrid_f2a_3d_ad_top2bot_fast(nz, ns, nx, ny, zofs, az_ad, as_ad) !------------------ Precompute indices and weights ---------------------------- do k = 0, nz - z = real(nz - k, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) + z = real(nz - k+1, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) s = 0 - do while (s < ns .and. zofs(s+1) < z) + do while (s < ns-1 .and. zofs(s+1) > z) s = s + 1 end do if (s <= 1) then - call wint3(zofs(0:2), z, w3) + call v1_wint3(zofs(0:2), z, w3) interp_type(k) = wint3_type src_inds(1:3,k) = (/0,1,2/) weights(1:3,k) = w3 src_inds(4,k) = -1 weights(4,k) = 0.0_r_kind elseif (s >= ns-1) then - call wint3(zofs(ns-2:ns), z, w3) + call v1_wint3(zofs(ns-2:ns), z, w3) interp_type(k) = wint3_top_type src_inds(1:3,k) = (/ns-2, ns-1, ns/) weights(1:3,k) = w3 src_inds(4,k) = -1 weights(4,k) = 0.0_r_kind else - call whint(zofs(s-1:s+2), z, w4) + call v1_whint(zofs(s-1:s+2), z, w4) interp_type(k) = whint_type src_inds(1:4,k) = (/s-1, s, s+1, s+2/) weights(1:4,k) = w4 @@ -742,7 +763,7 @@ subroutine intgrid_f2a_3d_ad(nz, ns, nx, ny, zofs, az_ad, as_ad) z = real(k, r_kind) s = 0 - do while (s < ns .and. zofs(s+1) < z) + do while (s < ns-1 .and. zofs(s+1) < z) s = s + 1 end do @@ -791,11 +812,12 @@ subroutine intgrid_f2a_3d_ad_top2bot(nz, ns, nx, ny, zofs, az, as) do j = 1, ny do i = 1, nx do k = 0, nz - z = real(nz - k, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) +!clttothink + z = real(nz - k+1, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) ! Find s such that zofs(s+1) < z ≤ zofs(s) s = 0 - do while (s < ns .and. zofs(s+1) < z) + do while (s < ns-1 .and. zofs(s+1) > z) s = s + 1 end do From e4d35be8291f3d98461f734ec8ebdf776b33f094 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 29 Jul 2025 19:45:32 +0000 Subject: [PATCH 042/199] an version with Jim's stretched grid function working --- src/saber/mgbf/mgbf_lib/phint.f90 | 7 +++++++ src/saber/mgbf/mgbf_lib/phint1.f90 | 4 ---- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/phint.f90 b/src/saber/mgbf/mgbf_lib/phint.f90 index 9387b9b8f..1063e6919 100644 --- a/src/saber/mgbf/mgbf_lib/phint.f90 +++ b/src/saber/mgbf/mgbf_lib/phint.f90 @@ -120,6 +120,7 @@ subroutine v1_whint(x,wint)! [whint xm2=x-u2; xm1=x-u1; xp1=x+u1 wint=(/-x*xm1*o2, xm1*xp1, -x*xp1*o2, u0 /)*xm1+ & (/ u0, xm1*xm2*o2, -xm2*x, xm1*x*o2 /)*x +wint=wint(2:-1:-1) end subroutine v1_whint !============================================================================= subroutine whintd(x,wint,dwint)! [whint] @@ -165,6 +166,8 @@ subroutine v1_whintd(x,wint,dwint)! [whint dquad1=(/ u0, xm1-o2, -u2*xm1, xm1+o2 /) wint = quad0*xm1+ quad1*x dwint=dquad0*xm1+dquad1*x+quad0+quad1 +wint=wint(2:-1:-1) +dwint=dwint(2:-1:-1) end subroutine v1_whintd !============================================================================= @@ -222,6 +225,7 @@ subroutine v1_whintvar(xs,x,wint)! [whint x3=x-xs(0) wint=-(/ x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12),u0/)*x2/x12 & +(/u0,x2*x3/(x12*x13),-x1*x3/(x12*x23),x1*x2/(x13*x23)/)*x1/x12 +wint=wint(3:0:-1) end subroutine v1_whintvar !============================================================================= @@ -331,6 +335,7 @@ subroutine v1_wint3(xs,x,wint)! [wint3 x1=x-xs(1) x2=x-xs(0) wint=(/x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12)/) +wint=wint(2:0:-1) end subroutine v1_wint3 !============================================================================= @@ -379,6 +384,8 @@ subroutine v1_wint3d(xs,x,wint,dwint)! [wint3 x2=x-xs(0) wint=(/x1*x2/(x01*x02),-x0*x2/(x01*x12),x0*x1/(x02*x12)/) dwint=(/(x1+x2)/(x01*x02),-(x0+x2)/(x01*x12),(x0+x1)/(x02*x12)/) +wint=wint(2:0:-1) +dwint=dwint(2:0:-1) end subroutine v1_wint3d end module phint diff --git a/src/saber/mgbf/mgbf_lib/phint1.f90 b/src/saber/mgbf/mgbf_lib/phint1.f90 index eda10952d..24f1ac75b 100644 --- a/src/saber/mgbf/mgbf_lib/phint1.f90 +++ b/src/saber/mgbf/mgbf_lib/phint1.f90 @@ -583,7 +583,6 @@ subroutine intgrid_f2a_3d_top2bot_fast(nz, ns, nx, ny, zofs, az, as) integer(i_kind), intent(in) :: nz, ns, nx, ny real(r_kind), dimension(0:ns), intent(in) :: zofs -!clt real(r_kind), dimension(0:ns,nx,ny), intent(in) :: as real(r_kind), dimension(0:ns,nx,ny), intent(in) :: as real(r_kind), dimension(0:nz,nx,ny), intent(out) :: az @@ -598,9 +597,6 @@ subroutine intgrid_f2a_3d_top2bot_fast(nz, ns, nx, ny, zofs, az, as) real(r_kind), dimension(4) :: w4 !------------------ Precompute indices and weights ---------------------------- -do k=0,nz -az(k,:,:)=k -enddo do k = 0, nz z = real(nz - k+1, r_kind) ! Map k (top-to-bottom) to physical z (bottom-to-top) s = 0 From c4a56e236ea6a6aedb5f720e2ac48bf1280dc49f Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 31 Jul 2025 18:50:56 +0000 Subject: [PATCH 043/199] initial changes in mgbf_covariance_mod.f90 for sdl/vdl --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 524 +++++++++--------- 1 file changed, 276 insertions(+), 248 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 4aa6f6108..118b44dfd 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -33,7 +33,9 @@ module mgbf_covariance_mod ! Fortran class header type :: mgbf_covariance - type(mg_intstate_type) :: intstate + type(mg_intstate_type) :: intstate(:,:) + integer :: nscale=1 + integer :: nvargrp=1 logical :: noMGBF logical :: bypassMGBFbe logical :: cv ! cv=.true.; sv=.false. @@ -42,6 +44,8 @@ module mgbf_covariance_mod logical :: l_2dvar_last_vertical_level=.true. !when used for localization,2dvars are put on the last vertical level !when the fields in fset are stored from top to bottom !clt integer :: lat2,lon2 ! these belog to mgbf_grid + character(len=:), allocatable :: mgbf_nml + character(len=:), allocatable :: mgbf_nml_group(:,:) contains procedure, public :: create procedure, public :: delete @@ -74,6 +78,7 @@ subroutine create(self, comm, config, background, firstguess) integer :: layout(2) type(atlas_field) :: afield +namelist /parameters_init_mgbf/ nscale,nvargrp,mgbf_nml_group ! Hold communicator ! ----------------- @@ -87,7 +92,7 @@ subroutine create(self, comm, config, background, firstguess) !clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) call config%get_or_die("mgbf namelist file ", mgbf_nml) !if (.not. self%noMGBF) then - call config%get_or_die("saber block name", centralblockname) +call config%get_or_die("saber block name", centralblockname) ! if (.not. central) then ! call abor1_ftn(myname_//": not ready to handle sqrt(B) case") ! endif @@ -102,7 +107,17 @@ subroutine create(self, comm, config, background, firstguess) ! -------------------------------- ! layout=-1 !clt endif -call self%intstate%mg_initialize(mgbf_nml) !mgbf_nml like mgbeta.nml + open(newunit=myunit,file=trim(mgbf_nml),status='old') +!# open(unit=10,file=mgbf_nml,status='old',action='read') + read(myunit,nml=parameters_mgbf_initial) + close(unit=myunit) + this%nscale=nscale + this%nvargrp=nvargrp +do iscale=1,nscale + do ivargrp=1,nvargrp + call self%intstate(iscale,ivargrp)%mg_initialize(mgbf_nml_group(iscale,ivargrp) !mgbf_nml like mgbeta.nml + enddo +enddo ! Get background (temporary test of the functionality) !cltafield = background%field('air_temperature') !clt call afield%data(t) @@ -120,7 +135,12 @@ subroutine delete(self) !clt //if (.not. self%noMGBF) then call print_mg_timers("mg_timer_output",999,self%rank) - call self%intstate%mg_finalize() + +do iscale=1,self%nscale + do ivargrp=1,self%nvargrp + call self%intstate(iscale,ivargrp)%mg_finalize() + enddo +enddo !clt endif ! Delete the grid @@ -184,6 +204,7 @@ subroutine multiply(self, fields) ! Arguments class(mgbf_covariance), intent(inout) :: self type(atlas_fieldset), intent(inout) :: fields +type(atlas_fieldset), intent(inout) :: fields_tmp type(atlas_functionspace) :: afunctionspace ! Locals @@ -220,7 +241,7 @@ subroutine multiply(self, fields) !*** From the analysis to first generation of filter grid call btim(mg_multiply_time) call btim(mg_preprocess_time) - if(self%intstate%l_for_localization .and. self%intstate%km2) then + if(self%intstate(1,1)%l_for_localization .and. self%intstate(iscale,ivargrp)%km2 > 0) then write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & & "in which, the first level contains the 2d variables and others zeros " @@ -228,7 +249,7 @@ subroutine multiply(self, fields) endif myrank=self%rank write(str_rank,"(I4.4)")myrank - if(self%intstate%l_for_localization) then + if(self%intstate(iscale,ivargrp)%l_for_localization) then fileoutput="mgbftest_loc_"//str_rank//".txt" else fileoutput="mgbftest_static_"//str_rank//".txt" @@ -236,267 +257,274 @@ subroutine multiply(self, fields) - - n2d=0 - l3d_encountered=.false. - allocate(work_mgbf(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) - allocate(work_mgbf2(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) - allocate(work2d_mgbf(self%intstate%km_a_all,self%intstate%nm*self%intstate%mm)) - allocate(rnormalization(self%intstate%km_a_all)) - work2d_mgbf=0.0 - rnormalization=1.0 - - dim2d=shape(work2d_mgbf) - - dim3d=shape(work_mgbf) - nxloc=dim3d(2) - nyloc=dim3d(3) - nzloc=dim3d(1) - nz3d=self%intstate%lm_a - nvar=fields%size() - - allocate( varvlev_index(nvar,3)) - ilev=1 - do isize=1,fields%size() - - afield= fields%field(isize) !clttodo - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - if(afield%rank() == 2) then - nz=afield%levels() - call afield%data(ptr_2d) -!clt do k=1,nz -!clt do i=1,n_owned_size - !clt val=ptr_2d(k,i) -!clt if (ieee_is_nan(val)) then - !clt print *, '[Fortran] ❗ NaN detected in value' - !clt elseif (ieee_is_finite(val) .eqv. .false.) then - !clt print *, '[Fortran] ❗ Inf detected in value' - !clt elseif (abs(val) > 1.0e20) then - !clt print *, '[Fortran] ⚠️ Suspicious large value:', val - !clt endif -!clt enddo -!clt do i=n_owned_size+1,size(ptr_2d,2) - !clt val=ptr_2d(k,i) -! if (ieee_is_nan(val)) then -! print *, '[Fortran]2 ❗ NaN detected in value' -!j elseif (ieee_is_finite(val) .eqv. .false.) then -! print *, '[Fortran]2 ❗ Inf detected in value' -! elseif (abs(val) > 1.0e20) then -! print *, '[Fortran]2 ⚠️ Suspicious large value:', val -! endif -! enddo -! enddo - - if(nz == 1) then - if(self%intstate%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - if(n_owned_size >0 ) then - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d - endif + do iscal=1,this%nscale + do ivargrp=1,this%nvargrp + n2d=0 + l3d_encountered=.false. + allocate(work_mgbf(self%intstate(iscale,ivargrp)%km_a_all,self%intstate(iscale,ivargrp)%nm,self%intstate(iscale,ivargrp)%mm)) + allocate(work_mgbf2(self%intstate(iscale,ivargrp)%km_a_all,self%intstate(iscale,ivargrp)%nm,self%intstate(iscale,ivargrp)%mm)) + allocate(work2d_mgbf(self%intstate(iscale,ivargrp)%km_a_all,self%intstate(iscale,ivargrp)%nm*self%intstate(iscale,ivargrp)%mm)) + allocate(rnormalization(self%intstate(iscale,ivargrp)%km_a_all)) + work2d_mgbf=0.0 + rnormalization=1.0 + + dim2d=shape(work2d_mgbf) + + dim3d=shape(work_mgbf) + nxloc=dim3d(2) + nyloc=dim3d(3) + nzloc=dim3d(1) + nz3d=self%intstate(iscale,ivargrp)%lm_a + nvar=fields%size() + + allocate( varvlev_index(nvar,3)) + ilev=1 + isize_used=0 + do isize=1,fields%size() + + afield= fields%field(isize) !clttodo + if(afield.field_name not in this%intstate(iscale,ivargrp)%vargrpnames()) cycle + isize_used=isize_used+1 + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + if(afield%rank() == 2) then + nz=afield%levels() + call afield%data(ptr_2d) + !clt do k=1,nz + !clt do i=1,n_owned_size + !clt val=ptr_2d(k,i) + !clt if (ieee_is_nan(val)) then + !clt print *, '[Fortran] ❗ NaN detected in value' + !clt elseif (ieee_is_finite(val) .eqv. .false.) then + !clt print *, '[Fortran] ❗ Inf detected in value' + !clt elseif (abs(val) > 1.0e20) then + !clt print *, '[Fortran] ⚠️ Suspicious large value:', val + !clt endif + !clt enddo + !clt do i=n_owned_size+1,size(ptr_2d,2) + !clt val=ptr_2d(k,i) + ! if (ieee_is_nan(val)) then + ! print *, '[Fortran]2 ❗ NaN detected in value' + !j elseif (ieee_is_finite(val) .eqv. .false.) then + ! print *, '[Fortran]2 ❗ Inf detected in value' + ! elseif (abs(val) > 1.0e20) then + ! print *, '[Fortran]2 ⚠️ Suspicious large value:', val + ! endif + ! enddo + ! enddo + + if(nz == 1) then + if(self%intstate(iscale,ivargrp)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + if(n_owned_size >0 ) then + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + endif + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + + + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d endif - + endif + if(nz > 1) l3d_encountered=.true. + if(nz == 1) then + if(l3d_encountered ) then + write(6,*)"l3d_encountered is true , 2dvariable is not put in the begining, stop" + stop ! is required 2d fields are saved consecutively + endif + n2d=n2d+1 + endif + if(isize==1) then + varvlev_index(isize,1)= 1 + if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + varvlev_index(isize,2)= nz + else + varvlev_index(isize,2)= nz3d + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d + varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 + if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 endif - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - - if(nz > 1) l3d_encountered=.true. - if(nz == 1) then - if(l3d_encountered ) then - write(6,*)"l3d_encountered is true , 2dvariable is not put in the begining, stop" - stop ! is required 2d fields are saved consecutively - endif - n2d=n2d+1 - endif - if(isize==1) then - varvlev_index(isize,1)= 1 - if(.not.self%intstate%l_for_localization )then - varvlev_index(isize,2)= nz - else - varvlev_index(isize,2)= nz3d - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - else -!cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d - varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 - if(.not.self%intstate%l_for_localization )then - varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 - else - varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - endif - rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) - - ilev=varvlev_index(isize,2)+1 - elseif (afield%rank() == 3) then - write(6,*)'this case needs more work, stop' ! a better exption handling to be added - call flush(6) - stop - call afield%data(ptr_3d) - nz=afield%levels() - work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - stop - endif - enddo - do k=1,nzloc - work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) - work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) - enddo - if(self%intstate%km2.ne.n2d.and. .not.self%intstate%l_for_localization ) then - write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' - stop ! a better exception handling is to be added - endif - if(test_once.and..1.gt.2) then - open(iounit,file=trim(fileoutput), status='replace',form="formatted") - write(iounit,*) work_mgbf - test_once=.false. - close(iounit) - endif - call etim(mg_preprocess_time) - - call btim(mg_anal_to_filt_time) - call self%intstate%anal_to_filt_allmap(work_mgbf) - call etim(mg_anal_to_filt_time) - call btim(mg_filtering_time) - call self%intstate%filtering_procedure(self%intstate%mgbf_proc,1) - call etim(mg_filtering_time) - -!cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) - call btim(mg_filt_to_anal_time) - call self%intstate%filt_to_anal_allmap(work_mgbf2) - call etim(mg_filt_to_anal_time) -!clt# work_mgbf=999.0 !thinkdeb for debug - - call btim(mg_postprocess_time) - if(.not. self%intstate%l_for_localization ) then !clthinkdebxxx - work_mgbf=work_mgbf2 - else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures - allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - work1var_mgbf=0.0 - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) + rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate(iscale,ivargrp)%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) + + ilev=varvlev_index(isize,2)+1 + elseif (afield%rank() == 3) then + write(6,*)'this case needs more work, stop' ! a better exption handling to be added + call flush(6) + stop + call afield%data(ptr_3d) + nz=afield%levels() + work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + stop + endif + enddo + do k=1,nzloc + work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) + work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) enddo - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - deallocate(work1var_mgbf) - endif - do k=1,nzloc - work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) - enddo - ilev=1 - n_owned_size=0 - do isize=1,fields%size() - - afield=fields%field(isize) !clttodo - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - if(afield%rank() == 2) then - call afield%data(ptr_2d) - nz=afield%levels() - lev1=varvlev_index(isize,1) - if(nz.gt.1) then -! if(n_owned_size == 0) then -! do i = 1, size(ghost) -! if (ghost(i) == 0) then - ! This point is owned (not a halo point) -! n_owned_size=n_owned_size+1 -! endif -! end do -!! write(6,*)'thinkdeb2552 dimension of ptr_2d are ',size(ptr_2d,1), ' ',size(ptr_2d,2) -! endif -!clt write(6,*)'thinkdeb2552 n_owned_size ',n_owned_size,' ','total size is ' ,size(ptr_2d,2) - if(n_owned_size >0 ) then - ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(self%intstate%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - - call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + if(self%intstate(iscale,ivargrp)%km2.ne.n2d.and. .not.self%intstate(iscale,ivargrp)%l_for_localization ) then + write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' + stop ! a better exception handling is to be added + endif + if(test_once.and..1.gt.2) then + open(iounit,file=trim(fileoutput), status='replace',form="formatted") + write(iounit,*) work_mgbf + test_once=.false. + close(iounit) + endif + call etim(mg_preprocess_time) + + call btim(mg_anal_to_filt_time) + call self%intstate(iscale,ivargrp)%anal_to_filt_allmap(work_mgbf) + call etim(mg_anal_to_filt_time) + call btim(mg_filtering_time) + call self%intstate(iscale,ivargrp)%filtering_procedure(self%intstate(iscale,ivargrp)%mgbf_proc,1) + call etim(mg_filtering_time) + + !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) + call btim(mg_filt_to_anal_time) + call self%intstate(iscale,ivargrp)%filt_to_anal_allmap(work_mgbf2) + call etim(mg_filt_to_anal_time) + !clt# work_mgbf=999.0 !thinkdeb for debug + + call btim(mg_postprocess_time) + if(.not. self%intstate(iscale,ivargrp)%l_for_localization ) then !clthinkdebxxx + work_mgbf=work_mgbf2 + else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures + allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + work1var_mgbf=0.0 + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) + enddo + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + deallocate(work1var_mgbf) + endif + do k=1,nzloc + work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + enddo + ilev=1 + n_owned_size=0 + do isize=1,fields%size() + + afield=fields%field(isize) !clttodo + if(afield.field_name not in this%intstate(iscale,ivargrp)%vargrpnames()) cycle + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + if(afield%rank() == 2) then + call afield%data(ptr_2d) + nz=afield%levels() + lev1=varvlev_index(isize,1) + if(nz.gt.1) then + ! if(n_owned_size == 0) then + ! do i = 1, size(ghost) + ! if (ghost(i) == 0) then + ! This point is owned (not a halo point) + ! n_owned_size=n_owned_size+1 + ! endif + ! end do + !! write(6,*)'thinkdeb2552 dimension of ptr_2d are ',size(ptr_2d,1), ' ',size(ptr_2d,2) + ! endif + !clt write(6,*)'thinkdeb2552 n_owned_size ',n_owned_size,' ','total size is ' ,size(ptr_2d,2) + if(n_owned_size >0 ) then + ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(self%intstate%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + + call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif endif - else - if(n_owned_size >0 ) then + else + if(n_owned_size >0 ) then ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else + else !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + endif - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - endif - endif - - elseif (afield%rank() == 3) then - call afield%data(ptr_3d) - nz=afield%levels() - write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo - call flush(6) - stop - - -!clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - call flush(6) - stop - endif - enddo + + elseif (afield%rank() == 3) then + call afield%data(ptr_3d) + nz=afield%levels() + write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo + call flush(6) + stop + + + !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + call flush(6) + stop + endif + enddo - call etim(mg_postprocess_time) + call etim(mg_postprocess_time) - deallocate(work_mgbf) - deallocate(work_mgbf2) - deallocate(work2d_mgbf) - deallocate(rnormalization) - deallocate( varvlev_index) + deallocate(work_mgbf) + deallocate(work_mgbf2) + deallocate(work2d_mgbf) + deallocate(rnormalization) + deallocate( varvlev_index) + enddo !for ivargrp + enddo !for iscale call etim(mg_multiply_time) end subroutine multiply From df7cb4e9dc357b8bbf8fc606b3b684c83d05e587 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 5 Aug 2025 02:11:12 +0000 Subject: [PATCH 044/199] WIP : a basic version to be compiled/debugged --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 34 +++++++++++++------ 1 file changed, 23 insertions(+), 11 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 118b44dfd..bfc9b3c3e 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -46,12 +46,14 @@ module mgbf_covariance_mod !clt integer :: lat2,lon2 ! these belog to mgbf_grid character(len=:), allocatable :: mgbf_nml character(len=:), allocatable :: mgbf_nml_group(:,:) + contains procedure, public :: create procedure, public :: delete procedure, public :: randomize procedure, public :: multiply procedure, public :: multiply_ad + procedure, private :: member2scale end type mgbf_covariance character(len=*), parameter :: myname='mgbf_covariance_mod' @@ -204,7 +206,7 @@ subroutine multiply(self, fields) ! Arguments class(mgbf_covariance), intent(inout) :: self type(atlas_fieldset), intent(inout) :: fields -type(atlas_fieldset), intent(inout) :: fields_tmp +type(atlas_fieldset) :: fields_tmp type(atlas_functionspace) :: afunctionspace ! Locals @@ -239,6 +241,8 @@ subroutine multiply(self, fields) ! afield = fields%field('air_temperature') ! call afield%data(t) !*** From the analysis to first generation of filter grid + member_index=fields%metadata().get("mem_index") + iscale=self%mem2scale() call btim(mg_multiply_time) call btim(mg_preprocess_time) if(self%intstate(1,1)%l_for_localization .and. self%intstate(iscale,ivargrp)%km2 > 0) then @@ -254,9 +258,9 @@ subroutine multiply(self, fields) else fileoutput="mgbftest_static_"//str_rank//".txt" endif + - - + do iscal=1,this%nscale do ivargrp=1,this%nvargrp n2d=0 @@ -422,14 +426,14 @@ subroutine multiply(self, fields) else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures allocate(work1var_mgbf(nz3d,nxloc,nyloc)) work1var_mgbf=0.0 - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) - enddo - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) + do jvar=1,nvar + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+self%multscale_parameter%corvar(jvar,ivar)*work_mgbf2(lev1:lev2,:,:) + enddo + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) work_mgbf(lev1:lev2,:,:)=work1var_mgbf enddo deallocate(work1var_mgbf) @@ -547,6 +551,14 @@ subroutine multiply_ad(self, fields) ! var3d=0.0_r_kind end subroutine multiply_ad +function imem2scale(self,imem) result(iscale) + class(mgbf_covariance),intent(in)::this + iscale=1 + do 100, while (imem > self%iscalegroup(iscale) ) + iscale=iscale+1 + break + +end function imem2scale ! -------------------------------------------------------------------------------------------------- From bb0ea982c3e976ce2f6d2153b5058b8478fd8808 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 5 Aug 2025 12:34:36 -0500 Subject: [PATCH 045/199] an initial succesfully built version of MGBF based sdl/vdl --- src/saber/mgbf/covariance/MGBF_Covariance.h | 3 +- .../covariance/MGBF_Covariance.interface.F90 | 7 +- .../covariance/MGBF_Covariance.interface.h | 2 +- .../mgbf/covariance/mgbf_covariance_mod.f90 | 78 +++++++++++++------ 4 files changed, 62 insertions(+), 28 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index 84caaebb4..946e0df45 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -202,7 +202,8 @@ void MGBF_Covariance::randomize(oops::FieldSet3D & fset) const { void MGBF_Covariance::multiply(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiply starting" << std::endl; util::Timer timer(classname(), "multiply"); - mgbf_covariance_multiply_f90(keySelf_, fset.get()); + int index_scale=fset.get()->metadata().get("ensemble member index"); + mgbf_covariance_multiply_f90(keySelf_, fset.get(),index_scale); // Mark all fields as having dirty halos after modification for (const auto & fieldname : fset.field_names()) { atlas::Field field = fset[fieldname]; diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 index 38694be2c..a63b3aa9f 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 +++ b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 @@ -141,19 +141,22 @@ end subroutine mgbf_covariance_randomize_cpp ! -------------------------------------------------------------------------------------------------- -subroutine mgbf_covariance_multiply_cpp(c_self, c_afieldset) & +subroutine mgbf_covariance_multiply_cpp(c_self, c_afieldset,c_index_member_in) & bind(c,name='mgbf_covariance_multiply_f90') implicit none !Arguments integer(c_int), intent(in) :: c_self +integer(c_int), intent(in) :: c_index_member_in type(c_ptr), value, intent(in) :: c_afieldset type(mgbf_covariance), pointer :: f_self type(atlas_fieldset) :: f_fieldset +integer :: index_member_in !cltthink type(fieldset_type) :: f_fieldset call btim(mg_interface_multiply_time) +index_member_in=int(c_index_member_in,kind=kind(index_member_in)) ! LinkedList ! ---------- call btim(mg_interface_registry_get_time) @@ -168,7 +171,7 @@ subroutine mgbf_covariance_multiply_cpp(c_self, c_afieldset) & ! Call implementation ! ------------------- -call f_self%multiply(f_fieldset) +call f_self%multiply(f_fieldset,index_member_in) call etim(mg_interface_multiply_time) end subroutine mgbf_covariance_multiply_cpp diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.h b/src/saber/mgbf/covariance/MGBF_Covariance.interface.h index a944393d7..bfe14a24b 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.interface.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.interface.h @@ -30,7 +30,7 @@ namespace saber { void mgbf_covariance_delete_f90(CovarianceKey &); void mgbf_covariance_randomize_f90(const CovarianceKey &, const atlas::field::FieldSetImpl *); - void mgbf_covariance_multiply_f90(const CovarianceKey &, const atlas::field::FieldSetImpl *); + void mgbf_covariance_multiply_f90(const CovarianceKey &, const atlas::field::FieldSetImpl *,int index_scale=1); void mgbf_covariance_multiply_ad_f90(const CovarianceKey &, const atlas::FieldSet *); } diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index bfc9b3c3e..4ce77c677 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -33,7 +33,7 @@ module mgbf_covariance_mod ! Fortran class header type :: mgbf_covariance - type(mg_intstate_type) :: intstate(:,:) + type(mg_intstate_type),allocatable :: intstate(:,:) integer :: nscale=1 integer :: nvargrp=1 logical :: noMGBF @@ -45,7 +45,9 @@ module mgbf_covariance_mod !when the fields in fset are stored from top to bottom !clt integer :: lat2,lon2 ! these belog to mgbf_grid character(len=:), allocatable :: mgbf_nml - character(len=:), allocatable :: mgbf_nml_group(:,:) + character(len=80), allocatable :: mgbf_nml_group(:,:) + real, allocatable :: multigrp_cor(:,:) + integer, allocatable :: iscalegroup(:) contains procedure, public :: create @@ -53,7 +55,7 @@ module mgbf_covariance_mod procedure, public :: randomize procedure, public :: multiply procedure, public :: multiply_ad - procedure, private :: member2scale + procedure, private :: imem2scale end type mgbf_covariance character(len=*), parameter :: myname='mgbf_covariance_mod' @@ -78,9 +80,15 @@ subroutine create(self, comm, config, background, firstguess) character(len=:), allocatable :: mgbf_nml,centralblockname logical :: central integer :: layout(2) - +integer :: myunit +integer :: iscale,ivargrp +integer :: nscale, nvargrp type(atlas_field) :: afield -namelist /parameters_init_mgbf/ nscale,nvargrp,mgbf_nml_group +character(len=80) :: readin_mgbf_nml_group(99) +real :: readin_multigrp_cor(99)=1.0 +integer :: readin_iscalegroup(99)=999 +integer ::i,j, ii +namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup ! Hold communicator ! ----------------- @@ -111,13 +119,33 @@ subroutine create(self, comm, config, background, firstguess) !clt endif open(newunit=myunit,file=trim(mgbf_nml),status='old') !# open(unit=10,file=mgbf_nml,status='old',action='read') - read(myunit,nml=parameters_mgbf_initial) + read(myunit,nml=parameters_mgbf_init) close(unit=myunit) - this%nscale=nscale - this%nvargrp=nvargrp + self%nscale=nscale + self%nvargrp=nvargrp + allocate(self%mgbf_nml_group(nscale,nvargrp)) + allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + allocate(self%iscalegroup(nscale) ) + ii=1 + do iscale=1,nscale + self%iscalegroup(iscale)=readin_iscalegroup(iscale) + do ivargrp=1,nvargrp + self%mgbf_nml_group(iscale,ivargrp)=readin_mgbf_nml_group(ii) + ii=ii+1 + enddo + enddo + ii=1 + do i=1,nvargrp + do j=1,nvargrp + self%multigrp_cor(i,j)=readin_multigrp_cor(ii) + ii=ii+1 + enddo + enddo + + do iscale=1,nscale do ivargrp=1,nvargrp - call self%intstate(iscale,ivargrp)%mg_initialize(mgbf_nml_group(iscale,ivargrp) !mgbf_nml like mgbeta.nml + call self%intstate(iscale,ivargrp)%mg_initialize(self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml enddo enddo ! Get background (temporary test of the functionality) @@ -132,6 +160,7 @@ subroutine delete(self) ! Arguments class(mgbf_covariance) :: self +integer:: iscale,ivargrp ! Locals @@ -202,10 +231,11 @@ end subroutine randomize ! -------------------------------------------------------------------------------------------------- -subroutine multiply(self, fields) +subroutine multiply(self, fields,index_member_in) ! Arguments class(mgbf_covariance), intent(inout) :: self type(atlas_fieldset), intent(inout) :: fields +integer , intent(in) :: index_member_in type(atlas_fieldset) :: fields_tmp type(atlas_functionspace) :: afunctionspace @@ -222,7 +252,7 @@ subroutine multiply(self, fields) integer(kind=i_kind) :: dim2d(2),dim3d(3) integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d integer(kind=i_kind)::nvar -integer(kind=i_kind):: i,ivar,j,k,ij,lev1,lev2,iounit +integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit integer(kind=i_kind):: n2d integer(kind=i_kind),allocatable :: varvlev_index(:,:) logical :: l3d_encountered @@ -236,13 +266,15 @@ subroutine multiply(self, fields) type(atlas_functionspace_StructuredColumns) :: fs integer :: ierr real(kind=8) :: val +integer :: member_index +integer :: iscale, ivargrp !clt now noly consider t ! afield = fields%field('air_temperature') ! call afield%data(t) !*** From the analysis to first generation of filter grid - member_index=fields%metadata().get("mem_index") - iscale=self%mem2scale() + member_index=index_member_in + iscale=self%imem2scale(member_index) call btim(mg_multiply_time) call btim(mg_preprocess_time) if(self%intstate(1,1)%l_for_localization .and. self%intstate(iscale,ivargrp)%km2 > 0) then @@ -261,8 +293,8 @@ subroutine multiply(self, fields) - do iscal=1,this%nscale - do ivargrp=1,this%nvargrp + do iscale=1,self%nscale + do ivargrp=1,self%nvargrp n2d=0 l3d_encountered=.false. allocate(work_mgbf(self%intstate(iscale,ivargrp)%km_a_all,self%intstate(iscale,ivargrp)%nm,self%intstate(iscale,ivargrp)%mm)) @@ -283,12 +315,9 @@ subroutine multiply(self, fields) allocate( varvlev_index(nvar,3)) ilev=1 - isize_used=0 do isize=1,fields%size() afield= fields%field(isize) !clttodo - if(afield.field_name not in this%intstate(iscale,ivargrp)%vargrpnames()) cycle - isize_used=isize_used+1 fs= afield%functionspace() !cltthinkfore debug n_owned_size= fs%size_owned() !clt for debug if(afield%rank() == 2) then @@ -430,7 +459,7 @@ subroutine multiply(self, fields) do ivar=1,nvar lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+self%multscale_parameter%corvar(jvar,ivar)*work_mgbf2(lev1:lev2,:,:) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvar,ivar)*work_mgbf2(lev1:lev2,:,:) enddo lev1=varvlev_index(jvar,1) lev2=varvlev_index(jvar,2) @@ -446,7 +475,6 @@ subroutine multiply(self, fields) do isize=1,fields%size() afield=fields%field(isize) !clttodo - if(afield.field_name not in this%intstate(iscale,ivargrp)%vargrpnames()) cycle fs= afield%functionspace() !cltthinkfore debug n_owned_size= fs%size_owned() !clt for debug if(afield%rank() == 2) then @@ -471,7 +499,7 @@ subroutine multiply(self, fields) ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) endif else - if(self%intstate%l_for_localization) then + if(self%intstate(iscale,ivargrp)%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb @@ -552,11 +580,13 @@ subroutine multiply_ad(self, fields) end subroutine multiply_ad function imem2scale(self,imem) result(iscale) - class(mgbf_covariance),intent(in)::this + class(mgbf_covariance),intent(in)::self + integer, intent(in)::imem + integer :: iscale iscale=1 - do 100, while (imem > self%iscalegroup(iscale) ) + do while (imem > self%iscalegroup(iscale) ) iscale=iscale+1 - break + enddo end function imem2scale From 6af15ca18e483d9901a111d2dabc41db8547a626 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 5 Aug 2025 14:19:40 -0500 Subject: [PATCH 046/199] change misleading index_scale to index_member --- src/saber/mgbf/covariance/MGBF_Covariance.h | 4 ++-- src/saber/mgbf/covariance/MGBF_Covariance.interface.h | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index 946e0df45..cdf86f3d0 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -202,8 +202,8 @@ void MGBF_Covariance::randomize(oops::FieldSet3D & fset) const { void MGBF_Covariance::multiply(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiply starting" << std::endl; util::Timer timer(classname(), "multiply"); - int index_scale=fset.get()->metadata().get("ensemble member index"); - mgbf_covariance_multiply_f90(keySelf_, fset.get(),index_scale); + int index_member=fset.get()->metadata().get("ensemble member index"); + mgbf_covariance_multiply_f90(keySelf_, fset.get(),index_member); // Mark all fields as having dirty halos after modification for (const auto & fieldname : fset.field_names()) { atlas::Field field = fset[fieldname]; diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.h b/src/saber/mgbf/covariance/MGBF_Covariance.interface.h index bfe14a24b..2d1c83691 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.interface.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.interface.h @@ -30,7 +30,7 @@ namespace saber { void mgbf_covariance_delete_f90(CovarianceKey &); void mgbf_covariance_randomize_f90(const CovarianceKey &, const atlas::field::FieldSetImpl *); - void mgbf_covariance_multiply_f90(const CovarianceKey &, const atlas::field::FieldSetImpl *,int index_scale=1); + void mgbf_covariance_multiply_f90(const CovarianceKey &, const atlas::field::FieldSetImpl *,int index_member=1); void mgbf_covariance_multiply_ad_f90(const CovarianceKey &, const atlas::FieldSet *); } From 0b93b3c7b444f225f9a6d1104cef2e00d40ac6b8 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 8 Aug 2025 09:47:36 -0500 Subject: [PATCH 047/199] when non sdl/vdl cases (nscale=nvargp=1), only one mgbf namelist file is used and, hence, keep backward compatability regarding use of it --- src/saber/mgbf/covariance/MGBF_Covariance.h | 3 +- .../mgbf/covariance/mgbf_covariance_mod.f90 | 207 +++++++++++------- 2 files changed, 129 insertions(+), 81 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index cdf86f3d0..0ccf6ae71 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -42,7 +42,8 @@ namespace mgbf { class MGBF_CovarianceParameters: public SaberBlockParametersBase { OOPS_CONCRETE_PARAMETERS(MGBF_CovarianceParameters,SaberBlockParametersBase) public: - oops::RequiredParameter MGBFNML{"mgbf namelist file", this}; + oops::OptionalParameter SDL_MGBFNML{"mgbf sdl and vdl init namelist file", this}; + oops::OptionalParameter MGBFNML{"mgbf namelist file", this}; // Mandatory active variables oops::Variables mandatoryActiveVars() const override {return oops::Variables();} }; diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 4ce77c677..c28f6e940 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -48,6 +48,7 @@ module mgbf_covariance_mod character(len=80), allocatable :: mgbf_nml_group(:,:) real, allocatable :: multigrp_cor(:,:) integer, allocatable :: iscalegroup(:) + integer, allocatable :: ivargroup(:) contains procedure, public :: create @@ -56,6 +57,7 @@ module mgbf_covariance_mod procedure, public :: multiply procedure, public :: multiply_ad procedure, private :: imem2scale + procedure, private :: ivar2grp end type mgbf_covariance character(len=*), parameter :: myname='mgbf_covariance_mod' @@ -82,13 +84,14 @@ subroutine create(self, comm, config, background, firstguess) integer :: layout(2) integer :: myunit integer :: iscale,ivargrp -integer :: nscale, nvargrp +integer :: nscale=1, nvargrp=1 type(atlas_field) :: afield character(len=80) :: readin_mgbf_nml_group(99) real :: readin_multigrp_cor(99)=1.0 integer :: readin_iscalegroup(99)=999 +integer :: readin_ivargroup(99)=999 integer ::i,j, ii -namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup +namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup ! Hold communicator ! ----------------- @@ -99,24 +102,10 @@ subroutine create(self, comm, config, background, firstguess) !clt call self%grid%create(config, comm) self%rank = comm%rank() -!clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) -call config%get_or_die("mgbf namelist file ", mgbf_nml) -!if (.not. self%noMGBF) then call config%get_or_die("saber block name", centralblockname) -! if (.not. central) then -! call abor1_ftn(myname_//": not ready to handle sqrt(B) case") -! endif -! call config%get_or_die("debugging deep bypass mgbf B error", self%bypassMGBFbe) - -! Get required name of resources for MGBF B error -! ---------------------------------------------- -! call config%get_or_die("mgbf berror namelist file", mgbf_nml) -!// call config%get_or_die("mgbf error covariance file", bef) - -! Initialize MGBF-Berror components -! -------------------------------- -! layout=-1 -!clt endif +!clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) +if (config%has("mgbf sdl and vdl init namelist file")) then + call config%get_or_die("mgbf mgbf sdl and vdl init namelist file", mgbf_nml) open(newunit=myunit,file=trim(mgbf_nml),status='old') !# open(unit=10,file=mgbf_nml,status='old',action='read') read(myunit,nml=parameters_mgbf_init) @@ -126,14 +115,17 @@ subroutine create(self, comm, config, background, firstguess) allocate(self%mgbf_nml_group(nscale,nvargrp)) allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship allocate(self%iscalegroup(nscale) ) + allocate(self%ivargroup(nvargrp) ) ii=1 do iscale=1,nscale - self%iscalegroup(iscale)=readin_iscalegroup(iscale) do ivargrp=1,nvargrp self%mgbf_nml_group(iscale,ivargrp)=readin_mgbf_nml_group(ii) ii=ii+1 enddo enddo + do iscale=1,nscale + self%iscalegroup(iscale)=readin_iscalegroup(iscale) + enddo ii=1 do i=1,nvargrp do j=1,nvargrp @@ -141,8 +133,20 @@ subroutine create(self, comm, config, background, firstguess) ii=ii+1 enddo enddo + do i=1,nvargrp + self%ivargroup(i)=readin_ivargroup(iscale) + enddo +else +call config%get_or_die("mgbf namelist file ", mgbf_nml) +endif - +if(nscale == 1 .and. nvargrp ==1 ) then + self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used + !and hence, it would be backward-compatible + ! the previous namelist files could be still used,correctly, + ! by the current sdl/vdl enhanced version +endif +allocate(self%intstate(nscale,nvargrp)) do iscale=1,nscale do ivargrp=1,nvargrp call self%intstate(iscale,ivargrp)%mg_initialize(self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml @@ -246,9 +250,11 @@ subroutine multiply(self, fields,index_member_in) integer(kind=i_kind):: nz,ilev,isize real(kind=r_kind), allocatable :: work_mgbf(:,:,:) real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) real(kind=r_kind), allocatable :: work2d_mgbf(:,:) real(kind=r_kind), allocatable :: rnormalization(:) +integer(kind=i_kind), allocatable :: nlev_vargrp(:) integer(kind=i_kind) :: dim2d(2),dim3d(3) integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d integer(kind=i_kind)::nvar @@ -267,17 +273,19 @@ subroutine multiply(self, fields,index_member_in) integer :: ierr real(kind=8) :: val integer :: member_index -integer :: iscale, ivargrp +integer :: iscale,jscale, ivargrp,jvargrp +integer :: total_km_a_all,ii,nvargrp !clt now noly consider t ! afield = fields%field('air_temperature') ! call afield%data(t) !*** From the analysis to first generation of filter grid member_index=index_member_in - iscale=self%imem2scale(member_index) + jscale=self%imem2scale(member_index) + nvargrp=self%nvargrp call btim(mg_multiply_time) call btim(mg_preprocess_time) - if(self%intstate(1,1)%l_for_localization .and. self%intstate(iscale,ivargrp)%km2 > 0) then + if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,ivargrp)%km2 > 0) then write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & & "in which, the first level contains the 2d variables and others zeros " @@ -285,22 +293,30 @@ subroutine multiply(self, fields,index_member_in) endif myrank=self%rank write(str_rank,"(I4.4)")myrank - if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,ivargrp)%l_for_localization) then fileoutput="mgbftest_loc_"//str_rank//".txt" else fileoutput="mgbftest_static_"//str_rank//".txt" endif - - - do iscale=1,self%nscale + allocate(nlev_vargrp(nvargrp)) + total_km_a_all=0 +!clt do iscale=1,self%nscale do ivargrp=1,self%nvargrp + if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & + self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then + error stop "for being now, the filtering grids at the start of MGBF should be the same" + endif + total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all + enddo + + n2d=0 l3d_encountered=.false. - allocate(work_mgbf(self%intstate(iscale,ivargrp)%km_a_all,self%intstate(iscale,ivargrp)%nm,self%intstate(iscale,ivargrp)%mm)) - allocate(work_mgbf2(self%intstate(iscale,ivargrp)%km_a_all,self%intstate(iscale,ivargrp)%nm,self%intstate(iscale,ivargrp)%mm)) - allocate(work2d_mgbf(self%intstate(iscale,ivargrp)%km_a_all,self%intstate(iscale,ivargrp)%nm*self%intstate(iscale,ivargrp)%mm)) - allocate(rnormalization(self%intstate(iscale,ivargrp)%km_a_all)) + allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp)%nm,self%intstate(jscale,ivargrp)%mm)) + allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp)%nm,self%intstate(jscale,ivargrp)%mm)) + allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp)%nm*self%intstate(jscale,ivargrp)%mm)) + allocate(rnormalization(total_km_a_all)) work2d_mgbf=0.0 rnormalization=1.0 @@ -310,10 +326,12 @@ subroutine multiply(self, fields,index_member_in) nxloc=dim3d(2) nyloc=dim3d(3) nzloc=dim3d(1) - nz3d=self%intstate(iscale,ivargrp)%lm_a + nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps nvar=fields%size() allocate( varvlev_index(nvar,3)) + allocate( nlev_vargrp(nvargrp)) + nlev_vargrp=0 ilev=1 do isize=1,fields%size() @@ -347,7 +365,8 @@ subroutine multiply(self, fields,index_member_in) ! enddo if(nz == 1) then - if(self%intstate(iscale,ivargrp)%l_for_localization) then +!clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,1)%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level if(n_owned_size >0 ) then work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) @@ -388,7 +407,8 @@ subroutine multiply(self, fields,index_member_in) endif if(isize==1) then varvlev_index(isize,1)= 1 - if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,1)%l_for_localization )then varvlev_index(isize,2)= nz else varvlev_index(isize,2)= nz3d @@ -397,14 +417,17 @@ subroutine multiply(self, fields,index_member_in) else !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 - if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,ivargrp)%l_for_localization )then varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 else varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 endif varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 endif - rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate(iscale,ivargrp)%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) + jvargrp=self%ivargroup(isize) + nlev_vargrp(jvargrp)=nlev_vargrp(jvargrp)+varvlev_index(isize,2) + + rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate(jscale,jvargrp)%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) ilev=varvlev_index(isize,2)+1 elseif (afield%rank() == 3) then @@ -420,56 +443,69 @@ subroutine multiply(self, fields,index_member_in) stop endif enddo - do k=1,nzloc - work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) - work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) - enddo - if(self%intstate(iscale,ivargrp)%km2.ne.n2d.and. .not.self%intstate(iscale,ivargrp)%l_for_localization ) then + do k=1,nzloc + !cltorg work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) !clttothink should be done after the filtering + work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) + enddo + if(self%intstate(jscale,ivargrp)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp)%l_for_localization ) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added endif + if(test_once.and..1.gt.2) then open(iounit,file=trim(fileoutput), status='replace',form="formatted") write(iounit,*) work_mgbf test_once=.false. close(iounit) endif - call etim(mg_preprocess_time) - - call btim(mg_anal_to_filt_time) - call self%intstate(iscale,ivargrp)%anal_to_filt_allmap(work_mgbf) - call etim(mg_anal_to_filt_time) - call btim(mg_filtering_time) - call self%intstate(iscale,ivargrp)%filtering_procedure(self%intstate(iscale,ivargrp)%mgbf_proc,1) - call etim(mg_filtering_time) - - !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) - call btim(mg_filt_to_anal_time) - call self%intstate(iscale,ivargrp)%filt_to_anal_allmap(work_mgbf2) - call etim(mg_filt_to_anal_time) - !clt# work_mgbf=999.0 !thinkdeb for debug + ii=1 + do ivargrp=1,nvargrp + allocate(vargrp_work_mgbf(nlev_vargrp(ivar),nxloc,nyloc)) + vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp),:,:) - call btim(mg_postprocess_time) - if(.not. self%intstate(iscale,ivargrp)%l_for_localization ) then !clthinkdebxxx - work_mgbf=work_mgbf2 - else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures - allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - work1var_mgbf=0.0 - do jvar=1,nvar - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvar,ivar)*work_mgbf2(lev1:lev2,:,:) - enddo - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - deallocate(work1var_mgbf) - endif - do k=1,nzloc - work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) - enddo + call etim(mg_preprocess_time) + + call btim(mg_anal_to_filt_time) + call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) + call etim(mg_anal_to_filt_time) + call btim(mg_filtering_time) + call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) + call etim(mg_filtering_time) + + !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) + call btim(mg_filt_to_anal_time) + call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(work_mgbf2) + call etim(mg_filt_to_anal_time) + !clt# work_mgbf=999.0 !thinkdeb for debug + + call btim(mg_postprocess_time) + work_mgbf(ii:ii+nlev_vargrp(ivargrp),:,:)=vargrp_work_mgbf(:,:,:) + deallocate(vargrp_work_mgbf) + ii=ii+nlev_vargrp(ivargrp)+1 + enddo ! ivargrp + if(.not. self%intstate(jscale,ivargrp)%l_for_localization ) then !clthinkdebxxx + work_mgbf=work_mgbf2 + else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures + allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + work1var_mgbf=0.0 + do jvar=1,nvar + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvar,ivar)*work_mgbf2(lev1:lev2,:,:) + enddo + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + deallocate(work1var_mgbf) + endif + do k=1,nzloc + work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + enddo + do k=1,nzloc + work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) + enddo ilev=1 n_owned_size=0 do isize=1,fields%size() @@ -499,7 +535,7 @@ subroutine multiply(self, fields,index_member_in) ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) endif else - if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,ivargrp)%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb @@ -551,13 +587,14 @@ subroutine multiply(self, fields,index_member_in) deallocate(work_mgbf) + deallocate(vargrp_work_mgbf) deallocate(work_mgbf2) deallocate(work2d_mgbf) deallocate(rnormalization) deallocate( varvlev_index) - enddo !for ivargrp - enddo !for iscale + !clt enddo !for iscale call etim(mg_multiply_time) + deallocate(nlev_vargrp) end subroutine multiply @@ -589,6 +626,16 @@ function imem2scale(self,imem) result(iscale) enddo end function imem2scale +function ivar2grp(self,ivar) result(jvargrp) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::ivar + integer :: jvargrp + jvargrp=1 + do while (ivar > self%ivargroup(jvargrp) ) + jvargrp=jvargrp+1 + enddo + +end function ivar2grp ! -------------------------------------------------------------------------------------------------- From 050146e0f1d406e978ce3383166ab4bcdc2b3a3c Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 8 Aug 2025 09:47:36 -0500 Subject: [PATCH 048/199] WIP: when non sdl/vdl cases (nscale=nvargp=1), only one mgbf namelist file is used and, hence, keep backward compatability regarding use of it --- src/saber/mgbf/covariance/MGBF_Covariance.h | 4 +- .../mgbf/covariance/mgbf_covariance_mod.f90 | 224 +++++++++++------- 2 files changed, 147 insertions(+), 81 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index cdf86f3d0..eea13079b 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -42,7 +42,8 @@ namespace mgbf { class MGBF_CovarianceParameters: public SaberBlockParametersBase { OOPS_CONCRETE_PARAMETERS(MGBF_CovarianceParameters,SaberBlockParametersBase) public: - oops::RequiredParameter MGBFNML{"mgbf namelist file", this}; + oops::OptionalParameter SDL_MGBFNML{"mgbf sdl and vdl init namelist file", this}; + oops::OptionalParameter MGBFNML{"mgbf namelist file", this}; // Mandatory active variables oops::Variables mandatoryActiveVars() const override {return oops::Variables();} }; @@ -203,6 +204,7 @@ void MGBF_Covariance::multiply(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiply starting" << std::endl; util::Timer timer(classname(), "multiply"); int index_member=fset.get()->metadata().get("ensemble member index"); + oops::Log::trace()<<"thinkdeb999 sdl multiply index_member "< 0) then + if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,ivargrp)%km2 > 0) then write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & & "in which, the first level contains the 2d variables and others zeros " @@ -285,22 +308,32 @@ subroutine multiply(self, fields,index_member_in) endif myrank=self%rank write(str_rank,"(I4.4)")myrank - if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,ivargrp)%l_for_localization) then fileoutput="mgbftest_loc_"//str_rank//".txt" else fileoutput="mgbftest_static_"//str_rank//".txt" endif - - - do iscale=1,self%nscale +write(6,*)'thinkdeb999 multiply sdl 2 ' +call flush(6) + allocate(nlev_vargrp(nvargrp)) + total_km_a_all=0 +!clt do iscale=1,self%nscale do ivargrp=1,self%nvargrp + if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & + self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then + error stop "for being now, the filtering grids at the start of MGBF should be the same" + endif + total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all + enddo + + n2d=0 l3d_encountered=.false. - allocate(work_mgbf(self%intstate(iscale,ivargrp)%km_a_all,self%intstate(iscale,ivargrp)%nm,self%intstate(iscale,ivargrp)%mm)) - allocate(work_mgbf2(self%intstate(iscale,ivargrp)%km_a_all,self%intstate(iscale,ivargrp)%nm,self%intstate(iscale,ivargrp)%mm)) - allocate(work2d_mgbf(self%intstate(iscale,ivargrp)%km_a_all,self%intstate(iscale,ivargrp)%nm*self%intstate(iscale,ivargrp)%mm)) - allocate(rnormalization(self%intstate(iscale,ivargrp)%km_a_all)) + allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp)%nm,self%intstate(jscale,ivargrp)%mm)) + allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp)%nm,self%intstate(jscale,ivargrp)%mm)) + allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp)%nm*self%intstate(jscale,ivargrp)%mm)) + allocate(rnormalization(total_km_a_all)) work2d_mgbf=0.0 rnormalization=1.0 @@ -310,10 +343,12 @@ subroutine multiply(self, fields,index_member_in) nxloc=dim3d(2) nyloc=dim3d(3) nzloc=dim3d(1) - nz3d=self%intstate(iscale,ivargrp)%lm_a + nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps nvar=fields%size() allocate( varvlev_index(nvar,3)) + allocate( nlev_vargrp(nvargrp)) + nlev_vargrp=0 ilev=1 do isize=1,fields%size() @@ -347,7 +382,8 @@ subroutine multiply(self, fields,index_member_in) ! enddo if(nz == 1) then - if(self%intstate(iscale,ivargrp)%l_for_localization) then +!clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,1)%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level if(n_owned_size >0 ) then work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) @@ -388,7 +424,8 @@ subroutine multiply(self, fields,index_member_in) endif if(isize==1) then varvlev_index(isize,1)= 1 - if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,1)%l_for_localization )then varvlev_index(isize,2)= nz else varvlev_index(isize,2)= nz3d @@ -397,14 +434,17 @@ subroutine multiply(self, fields,index_member_in) else !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 - if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,ivargrp)%l_for_localization )then varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 else varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 endif varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 endif - rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate(iscale,ivargrp)%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) + jvargrp=self%ivargroup(isize) + nlev_vargrp(jvargrp)=nlev_vargrp(jvargrp)+varvlev_index(isize,2) + + rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate(jscale,jvargrp)%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) ilev=varvlev_index(isize,2)+1 elseif (afield%rank() == 3) then @@ -420,56 +460,69 @@ subroutine multiply(self, fields,index_member_in) stop endif enddo - do k=1,nzloc - work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) - work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) - enddo - if(self%intstate(iscale,ivargrp)%km2.ne.n2d.and. .not.self%intstate(iscale,ivargrp)%l_for_localization ) then + do k=1,nzloc + !cltorg work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) !clttothink should be done after the filtering + work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) + enddo + if(self%intstate(jscale,ivargrp)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp)%l_for_localization ) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added endif + if(test_once.and..1.gt.2) then open(iounit,file=trim(fileoutput), status='replace',form="formatted") write(iounit,*) work_mgbf test_once=.false. close(iounit) endif - call etim(mg_preprocess_time) - - call btim(mg_anal_to_filt_time) - call self%intstate(iscale,ivargrp)%anal_to_filt_allmap(work_mgbf) - call etim(mg_anal_to_filt_time) - call btim(mg_filtering_time) - call self%intstate(iscale,ivargrp)%filtering_procedure(self%intstate(iscale,ivargrp)%mgbf_proc,1) - call etim(mg_filtering_time) - - !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) - call btim(mg_filt_to_anal_time) - call self%intstate(iscale,ivargrp)%filt_to_anal_allmap(work_mgbf2) - call etim(mg_filt_to_anal_time) - !clt# work_mgbf=999.0 !thinkdeb for debug + ii=1 + do ivargrp=1,nvargrp + allocate(vargrp_work_mgbf(nlev_vargrp(ivar),nxloc,nyloc)) + vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp),:,:) - call btim(mg_postprocess_time) - if(.not. self%intstate(iscale,ivargrp)%l_for_localization ) then !clthinkdebxxx - work_mgbf=work_mgbf2 - else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures - allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - work1var_mgbf=0.0 - do jvar=1,nvar - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvar,ivar)*work_mgbf2(lev1:lev2,:,:) - enddo - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - deallocate(work1var_mgbf) - endif - do k=1,nzloc - work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) - enddo + call etim(mg_preprocess_time) + + call btim(mg_anal_to_filt_time) + call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) + call etim(mg_anal_to_filt_time) + call btim(mg_filtering_time) + call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) + call etim(mg_filtering_time) + + !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) + call btim(mg_filt_to_anal_time) + call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(work_mgbf2) + call etim(mg_filt_to_anal_time) + !clt# work_mgbf=999.0 !thinkdeb for debug + + call btim(mg_postprocess_time) + work_mgbf(ii:ii+nlev_vargrp(ivargrp),:,:)=vargrp_work_mgbf(:,:,:) + deallocate(vargrp_work_mgbf) + ii=ii+nlev_vargrp(ivargrp)+1 + enddo ! ivargrp + if(.not. self%intstate(jscale,ivargrp)%l_for_localization ) then !clthinkdebxxx + work_mgbf=work_mgbf2 + else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures + allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + work1var_mgbf=0.0 + do jvar=1,nvar + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvar,ivar)*work_mgbf2(lev1:lev2,:,:) + enddo + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + deallocate(work1var_mgbf) + endif + do k=1,nzloc + work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + enddo + do k=1,nzloc + work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) + enddo ilev=1 n_owned_size=0 do isize=1,fields%size() @@ -499,7 +552,7 @@ subroutine multiply(self, fields,index_member_in) ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) endif else - if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,ivargrp)%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb @@ -551,13 +604,14 @@ subroutine multiply(self, fields,index_member_in) deallocate(work_mgbf) + deallocate(vargrp_work_mgbf) deallocate(work_mgbf2) deallocate(work2d_mgbf) deallocate(rnormalization) deallocate( varvlev_index) - enddo !for ivargrp - enddo !for iscale + !clt enddo !for iscale call etim(mg_multiply_time) + deallocate(nlev_vargrp) end subroutine multiply @@ -589,6 +643,16 @@ function imem2scale(self,imem) result(iscale) enddo end function imem2scale +function ivar2grp(self,ivar) result(jvargrp) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::ivar + integer :: jvargrp + jvargrp=1 + do while (ivar > self%ivargroup(jvargrp) ) + jvargrp=jvargrp+1 + enddo + +end function ivar2grp ! -------------------------------------------------------------------------------------------------- From e5d9513cb0dc5c9950658a2603df1c18c3d97414 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 12 Aug 2025 19:07:08 -0500 Subject: [PATCH 049/199] WIP for debugging --- diff.1 | 877 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 877 insertions(+) create mode 100644 diff.1 diff --git a/diff.1 b/diff.1 new file mode 100644 index 000000000..047e9aff4 --- /dev/null +++ b/diff.1 @@ -0,0 +1,877 @@ +diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h +index eea13079..84caaebb 100755 +--- a/src/saber/mgbf/covariance/MGBF_Covariance.h ++++ b/src/saber/mgbf/covariance/MGBF_Covariance.h +@@ -42,8 +42,7 @@ namespace mgbf { + class MGBF_CovarianceParameters: public SaberBlockParametersBase { + OOPS_CONCRETE_PARAMETERS(MGBF_CovarianceParameters,SaberBlockParametersBase) + public: +- oops::OptionalParameter SDL_MGBFNML{"mgbf sdl and vdl init namelist file", this}; +- oops::OptionalParameter MGBFNML{"mgbf namelist file", this}; ++ oops::RequiredParameter MGBFNML{"mgbf namelist file", this}; + // Mandatory active variables + oops::Variables mandatoryActiveVars() const override {return oops::Variables();} + }; +@@ -203,9 +202,7 @@ void MGBF_Covariance::randomize(oops::FieldSet3D & fset) const { + void MGBF_Covariance::multiply(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::multiply starting" << std::endl; + util::Timer timer(classname(), "multiply"); +- int index_member=fset.get()->metadata().get("ensemble member index"); +- oops::Log::trace()<<"thinkdeb999 sdl multiply index_member "< 0) then ++ if(self%intstate%l_for_localization .and. self%intstate%km2) then + write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & + & "in which, the first level contains the 2d variables and others zeros " + +@@ -308,310 +228,276 @@ call flush(6) + endif + myrank=self%rank + write(str_rank,"(I4.4)")myrank +- if(self%intstate(jscale,ivargrp)%l_for_localization) then ++ if(self%intstate%l_for_localization) then + fileoutput="mgbftest_loc_"//str_rank//".txt" + else + fileoutput="mgbftest_static_"//str_rank//".txt" + endif +- +-write(6,*)'thinkdeb999 multiply sdl 2 ' +-call flush(6) +- allocate(nlev_vargrp(nvargrp)) +- total_km_a_all=0 +-!clt do iscale=1,self%nscale +- do ivargrp=1,self%nvargrp +- if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & +- self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then +- error stop "for being now, the filtering grids at the start of MGBF should be the same" +- endif +- total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all +- enddo +- +- +- n2d=0 +- l3d_encountered=.false. +- allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp)%nm,self%intstate(jscale,ivargrp)%mm)) +- allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp)%nm,self%intstate(jscale,ivargrp)%mm)) +- allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp)%nm*self%intstate(jscale,ivargrp)%mm)) +- allocate(rnormalization(total_km_a_all)) +- work2d_mgbf=0.0 +- rnormalization=1.0 +- +- dim2d=shape(work2d_mgbf) +- +- dim3d=shape(work_mgbf) +- nxloc=dim3d(2) +- nyloc=dim3d(3) +- nzloc=dim3d(1) +- nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps +- nvar=fields%size() +- +- allocate( varvlev_index(nvar,3)) +- allocate( nlev_vargrp(nvargrp)) +- nlev_vargrp=0 +- ilev=1 +- do isize=1,fields%size() +- +- afield= fields%field(isize) !clttodo +- fs= afield%functionspace() !cltthinkfore debug +- n_owned_size= fs%size_owned() !clt for debug +- if(afield%rank() == 2) then +- nz=afield%levels() +- call afield%data(ptr_2d) +- !clt do k=1,nz +- !clt do i=1,n_owned_size +- !clt val=ptr_2d(k,i) +- !clt if (ieee_is_nan(val)) then +- !clt print *, '[Fortran] ❗ NaN detected in value' +- !clt elseif (ieee_is_finite(val) .eqv. .false.) then +- !clt print *, '[Fortran] ❗ Inf detected in value' +- !clt elseif (abs(val) > 1.0e20) then +- !clt print *, '[Fortran] ⚠️ Suspicious large value:', val +- !clt endif +- !clt enddo +- !clt do i=n_owned_size+1,size(ptr_2d,2) +- !clt val=ptr_2d(k,i) +- ! if (ieee_is_nan(val)) then +- ! print *, '[Fortran]2 ❗ NaN detected in value' +- !j elseif (ieee_is_finite(val) .eqv. .false.) then +- ! print *, '[Fortran]2 ❗ Inf detected in value' +- ! elseif (abs(val) > 1.0e20) then +- ! print *, '[Fortran]2 ⚠️ Suspicious large value:', val +- ! endif +- ! enddo +- ! enddo +- +- if(nz == 1) then +-!clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then +- if(self%intstate(jscale,1)%l_for_localization) then +- if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level +- if(n_owned_size >0 ) then +- work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) +- else +- work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d +- endif +- else +- if(n_owned_size >0 ) then +- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) +- else +- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d +- endif +- endif +- +- +- else +- if(n_owned_size >0 ) then +- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) +- else +- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d +- endif +- endif +- else +- if(n_owned_size >0 ) then +- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) ++ ++ ++ ++ ++ n2d=0 ++ l3d_encountered=.false. ++ allocate(work_mgbf(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) ++ allocate(work_mgbf2(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) ++ allocate(work2d_mgbf(self%intstate%km_a_all,self%intstate%nm*self%intstate%mm)) ++ allocate(rnormalization(self%intstate%km_a_all)) ++ work2d_mgbf=0.0 ++ rnormalization=1.0 ++ ++ dim2d=shape(work2d_mgbf) ++ ++ dim3d=shape(work_mgbf) ++ nxloc=dim3d(2) ++ nyloc=dim3d(3) ++ nzloc=dim3d(1) ++ nz3d=self%intstate%lm_a ++ nvar=fields%size() ++ ++ allocate( varvlev_index(nvar,3)) ++ ilev=1 ++ do isize=1,fields%size() ++ ++ afield= fields%field(isize) !clttodo ++ fs= afield%functionspace() !cltthinkfore debug ++ n_owned_size= fs%size_owned() !clt for debug ++ if(afield%rank() == 2) then ++ nz=afield%levels() ++ call afield%data(ptr_2d) ++!clt do k=1,nz ++!clt do i=1,n_owned_size ++ !clt val=ptr_2d(k,i) ++!clt if (ieee_is_nan(val)) then ++ !clt print *, '[Fortran] ❗ NaN detected in value' ++ !clt elseif (ieee_is_finite(val) .eqv. .false.) then ++ !clt print *, '[Fortran] ❗ Inf detected in value' ++ !clt elseif (abs(val) > 1.0e20) then ++ !clt print *, '[Fortran] ⚠️ Suspicious large value:', val ++ !clt endif ++!clt enddo ++!clt do i=n_owned_size+1,size(ptr_2d,2) ++ !clt val=ptr_2d(k,i) ++! if (ieee_is_nan(val)) then ++! print *, '[Fortran]2 ❗ NaN detected in value' ++!j elseif (ieee_is_finite(val) .eqv. .false.) then ++! print *, '[Fortran]2 ❗ Inf detected in value' ++! elseif (abs(val) > 1.0e20) then ++! print *, '[Fortran]2 ⚠️ Suspicious large value:', val ++! endif ++! enddo ++! enddo ++ ++ if(nz == 1) then ++ if(self%intstate%l_for_localization) then ++ if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level ++ if(n_owned_size >0 ) then ++ work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) ++ else ++ work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d ++ endif + else +- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d ++ if(n_owned_size >0 ) then ++ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) ++ else ++ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d ++ endif + endif +- endif ++ + +- if(nz > 1) l3d_encountered=.true. +- if(nz == 1) then +- if(l3d_encountered ) then +- write(6,*)"l3d_encountered is true , 2dvariable is not put in the begining, stop" +- stop ! is required 2d fields are saved consecutively +- endif +- n2d=n2d+1 +- endif +- if(isize==1) then +- varvlev_index(isize,1)= 1 +- !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then +- if(.not.self%intstate(jscale,1)%l_for_localization )then +- varvlev_index(isize,2)= nz +- else +- varvlev_index(isize,2)= nz3d +- endif +- varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + else +- !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d +- varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 +- if(.not.self%intstate(jscale,ivargrp)%l_for_localization )then +- varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 ++ if(n_owned_size >0 ) then ++ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else +- varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 ++ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif +- varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + endif +- jvargrp=self%ivargroup(isize) +- nlev_vargrp(jvargrp)=nlev_vargrp(jvargrp)+varvlev_index(isize,2) +- +- rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate(jscale,jvargrp)%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) +- +- ilev=varvlev_index(isize,2)+1 +- elseif (afield%rank() == 3) then +- write(6,*)'this case needs more work, stop' ! a better exption handling to be added +- call flush(6) +- stop +- call afield%data(ptr_3d) +- nz=afield%levels() +- work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d +- ilev=ilev+nz +- else +- write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo +- stop +- endif +- enddo +- do k=1,nzloc +- !cltorg work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) !clttothink should be done after the filtering +- work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) +- enddo +- if(self%intstate(jscale,ivargrp)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp)%l_for_localization ) then +- write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' +- stop ! a better exception handling is to be added +- endif +- +- if(test_once.and..1.gt.2) then +- open(iounit,file=trim(fileoutput), status='replace',form="formatted") +- write(iounit,*) work_mgbf +- test_once=.false. +- close(iounit) +- endif +- ii=1 +- do ivargrp=1,nvargrp +- allocate(vargrp_work_mgbf(nlev_vargrp(ivar),nxloc,nyloc)) +- vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp),:,:) +- +- call etim(mg_preprocess_time) +- +- call btim(mg_anal_to_filt_time) +- call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) +- call etim(mg_anal_to_filt_time) +- call btim(mg_filtering_time) +- call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) +- call etim(mg_filtering_time) +- +- !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) +- call btim(mg_filt_to_anal_time) +- call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(work_mgbf2) +- call etim(mg_filt_to_anal_time) +- !clt# work_mgbf=999.0 !thinkdeb for debug +- +- call btim(mg_postprocess_time) +- work_mgbf(ii:ii+nlev_vargrp(ivargrp),:,:)=vargrp_work_mgbf(:,:,:) +- deallocate(vargrp_work_mgbf) +- ii=ii+nlev_vargrp(ivargrp)+1 +- enddo ! ivargrp +- if(.not. self%intstate(jscale,ivargrp)%l_for_localization ) then !clthinkdebxxx +- work_mgbf=work_mgbf2 +- else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures +- allocate(work1var_mgbf(nz3d,nxloc,nyloc)) +- work1var_mgbf=0.0 +- do jvar=1,nvar +- do ivar=1,nvar +- lev1=varvlev_index(ivar,1) +- lev2=varvlev_index(ivar,2) +- work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvar,ivar)*work_mgbf2(lev1:lev2,:,:) +- enddo +- lev1=varvlev_index(jvar,1) +- lev2=varvlev_index(jvar,2) +- work_mgbf(lev1:lev2,:,:)=work1var_mgbf +- enddo +- deallocate(work1var_mgbf) +- endif +- do k=1,nzloc +- work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) +- enddo +- do k=1,nzloc +- work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) +- enddo +- ilev=1 +- n_owned_size=0 +- do isize=1,fields%size() +- +- afield=fields%field(isize) !clttodo +- fs= afield%functionspace() !cltthinkfore debug +- n_owned_size= fs%size_owned() !clt for debug +- if(afield%rank() == 2) then +- call afield%data(ptr_2d) +- nz=afield%levels() +- lev1=varvlev_index(isize,1) +- if(nz.gt.1) then +- ! if(n_owned_size == 0) then +- ! do i = 1, size(ghost) +- ! if (ghost(i) == 0) then +- ! This point is owned (not a halo point) +- ! n_owned_size=n_owned_size+1 +- ! endif +- ! end do +- !! write(6,*)'thinkdeb2552 dimension of ptr_2d are ',size(ptr_2d,1), ' ',size(ptr_2d,2) +- ! endif +- !clt write(6,*)'thinkdeb2552 n_owned_size ',n_owned_size,' ','total size is ' ,size(ptr_2d,2) +- if(n_owned_size >0 ) then +- ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) +- else +- !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space +- ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) +- endif +- else +- if(self%intstate(jscale,ivargrp)%l_for_localization) then +- if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level +- +- call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb +- if(n_owned_size >0 ) then +- ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) +- else +- !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space +- ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) +- endif +- else +- if(n_owned_size >0 ) then +- ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) +- else +- !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space +- ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) +- endif ++ else ++ if(n_owned_size >0 ) then ++ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) ++ else ++ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d ++ endif ++ endif ++ ++ if(nz > 1) l3d_encountered=.true. ++ if(nz == 1) then ++ if(l3d_encountered ) then ++ write(6,*)"l3d_encountered is true , 2dvariable is not put in the begining, stop" ++ stop ! is required 2d fields are saved consecutively ++ endif ++ n2d=n2d+1 ++ endif ++ if(isize==1) then ++ varvlev_index(isize,1)= 1 ++ if(.not.self%intstate%l_for_localization )then ++ varvlev_index(isize,2)= nz ++ else ++ varvlev_index(isize,2)= nz3d ++ endif ++ varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 ++ else ++!cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d ++ varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 ++ if(.not.self%intstate%l_for_localization )then ++ varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 ++ else ++ varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 ++ endif ++ varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 ++ endif ++ rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) ++ ++ ilev=varvlev_index(isize,2)+1 ++ elseif (afield%rank() == 3) then ++ write(6,*)'this case needs more work, stop' ! a better exption handling to be added ++ call flush(6) ++ stop ++ call afield%data(ptr_3d) ++ nz=afield%levels() ++ work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d ++ ilev=ilev+nz ++ else ++ write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo ++ stop ++ endif ++ enddo ++ do k=1,nzloc ++ work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) ++ work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) ++ enddo ++ if(self%intstate%km2.ne.n2d.and. .not.self%intstate%l_for_localization ) then ++ write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' ++ stop ! a better exception handling is to be added ++ endif ++ if(test_once.and..1.gt.2) then ++ open(iounit,file=trim(fileoutput), status='replace',form="formatted") ++ write(iounit,*) work_mgbf ++ test_once=.false. ++ close(iounit) ++ endif ++ call etim(mg_preprocess_time) ++ ++ call btim(mg_anal_to_filt_time) ++ call self%intstate%anal_to_filt_allmap(work_mgbf) ++ call etim(mg_anal_to_filt_time) ++ call btim(mg_filtering_time) ++ call self%intstate%filtering_procedure(self%intstate%mgbf_proc,1) ++ call etim(mg_filtering_time) ++ ++!cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) ++ call btim(mg_filt_to_anal_time) ++ call self%intstate%filt_to_anal_allmap(work_mgbf2) ++ call etim(mg_filt_to_anal_time) ++!clt# work_mgbf=999.0 !thinkdeb for debug ++ ++ call btim(mg_postprocess_time) ++ if(.not. self%intstate%l_for_localization ) then !clthinkdebxxx ++ work_mgbf=work_mgbf2 ++ else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures ++ allocate(work1var_mgbf(nz3d,nxloc,nyloc)) ++ work1var_mgbf=0.0 ++ do ivar=1,nvar ++ lev1=varvlev_index(ivar,1) ++ lev2=varvlev_index(ivar,2) ++ work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) ++ enddo ++ do ivar=1,nvar ++ lev1=varvlev_index(ivar,1) ++ lev2=varvlev_index(ivar,2) ++ work_mgbf(lev1:lev2,:,:)=work1var_mgbf ++ enddo ++ deallocate(work1var_mgbf) ++ endif ++ do k=1,nzloc ++ work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) ++ enddo ++ ilev=1 ++ n_owned_size=0 ++ do isize=1,fields%size() ++ ++ afield=fields%field(isize) !clttodo ++ fs= afield%functionspace() !cltthinkfore debug ++ n_owned_size= fs%size_owned() !clt for debug ++ if(afield%rank() == 2) then ++ call afield%data(ptr_2d) ++ nz=afield%levels() ++ lev1=varvlev_index(isize,1) ++ if(nz.gt.1) then ++! if(n_owned_size == 0) then ++! do i = 1, size(ghost) ++! if (ghost(i) == 0) then ++ ! This point is owned (not a halo point) ++! n_owned_size=n_owned_size+1 ++! endif ++! end do ++!! write(6,*)'thinkdeb2552 dimension of ptr_2d are ',size(ptr_2d,1), ' ',size(ptr_2d,2) ++! endif ++!clt write(6,*)'thinkdeb2552 n_owned_size ',n_owned_size,' ','total size is ' ,size(ptr_2d,2) ++ if(n_owned_size >0 ) then ++ ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) ++ else ++ !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space ++ ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) ++ endif ++ else ++ if(self%intstate%l_for_localization) then ++ if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level ++ ++ call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb ++ if(n_owned_size >0 ) then ++ ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) ++ else ++ !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space ++ ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif +- else +- if(n_owned_size >0 ) then ++ else ++ if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) +- else ++ else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) +- endif +- + endif +- endif +- +- elseif (afield%rank() == 3) then +- call afield%data(ptr_3d) +- nz=afield%levels() +- write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo +- call flush(6) +- stop ++ endif ++ else ++ if(n_owned_size >0 ) then ++ ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) ++ else ++ !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space ++ ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) ++ endif + ++ endif ++ endif ++ ++ elseif (afield%rank() == 3) then ++ call afield%data(ptr_3d) ++ nz=afield%levels() ++ write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo ++ call flush(6) ++ stop ++ ++ ++!clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) ++ ilev=ilev+nz ++ else ++ write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo ++ call flush(6) ++ stop ++ endif ++ enddo + +- !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) +- ilev=ilev+nz +- else +- write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo +- call flush(6) +- stop +- endif +- enddo +- +- call etim(mg_postprocess_time) ++ call etim(mg_postprocess_time) + + + + +- deallocate(work_mgbf) +- deallocate(vargrp_work_mgbf) +- deallocate(work_mgbf2) +- deallocate(work2d_mgbf) +- deallocate(rnormalization) +- deallocate( varvlev_index) +- !clt enddo !for iscale ++ deallocate(work_mgbf) ++ deallocate(work_mgbf2) ++ deallocate(work2d_mgbf) ++ deallocate(rnormalization) ++ deallocate( varvlev_index) + call etim(mg_multiply_time) +- deallocate(nlev_vargrp) + + end subroutine multiply + +@@ -633,26 +519,6 @@ type(atlas_fieldset), intent(inout) :: fields + ! var3d=0.0_r_kind + + end subroutine multiply_ad +-function imem2scale(self,imem) result(iscale) +- class(mgbf_covariance),intent(in)::self +- integer, intent(in)::imem +- integer :: iscale +- iscale=1 +- do while (imem > self%iscalegroup(iscale) ) +- iscale=iscale+1 +- enddo +- +-end function imem2scale +-function ivar2grp(self,ivar) result(jvargrp) +- class(mgbf_covariance),intent(in)::self +- integer, intent(in)::ivar +- integer :: jvargrp +- jvargrp=1 +- do while (ivar > self%ivargroup(jvargrp) ) +- jvargrp=jvargrp+1 +- enddo +- +-end function ivar2grp + + ! -------------------------------------------------------------------------------------------------- + From 5cb41254a88dd2467579cd7481629fe0122bc1c6 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 12 Aug 2025 20:24:34 -0500 Subject: [PATCH 050/199] WIP: --- diff.1 | 887 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 885 insertions(+), 2 deletions(-) diff --git a/diff.1 b/diff.1 index 047e9aff4..691dc5c92 100644 --- a/diff.1 +++ b/diff.1 @@ -1,3 +1,886 @@ +diff --git a/diff.1 b/diff.1 +deleted file mode 100644 +index 047e9aff..00000000 +--- a/diff.1 ++++ /dev/null +@@ -1,877 +0,0 @@ +-diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h +-index eea13079..84caaebb 100755 +---- a/src/saber/mgbf/covariance/MGBF_Covariance.h +-+++ b/src/saber/mgbf/covariance/MGBF_Covariance.h +-@@ -42,8 +42,7 @@ namespace mgbf { +- class MGBF_CovarianceParameters: public SaberBlockParametersBase { +- OOPS_CONCRETE_PARAMETERS(MGBF_CovarianceParameters,SaberBlockParametersBase) +- public: +-- oops::OptionalParameter SDL_MGBFNML{"mgbf sdl and vdl init namelist file", this}; +-- oops::OptionalParameter MGBFNML{"mgbf namelist file", this}; +-+ oops::RequiredParameter MGBFNML{"mgbf namelist file", this}; +- // Mandatory active variables +- oops::Variables mandatoryActiveVars() const override {return oops::Variables();} +- }; +-@@ -203,9 +202,7 @@ void MGBF_Covariance::randomize(oops::FieldSet3D & fset) const { +- void MGBF_Covariance::multiply(oops::FieldSet3D & fset) const { +- oops::Log::trace() << classname() << "::multiply starting" << std::endl; +- util::Timer timer(classname(), "multiply"); +-- int index_member=fset.get()->metadata().get("ensemble member index"); +-- oops::Log::trace()<<"thinkdeb999 sdl multiply index_member "< 0) then +-+ if(self%intstate%l_for_localization .and. self%intstate%km2) then +- write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & +- & "in which, the first level contains the 2d variables and others zeros " +- +-@@ -308,310 +228,276 @@ call flush(6) +- endif +- myrank=self%rank +- write(str_rank,"(I4.4)")myrank +-- if(self%intstate(jscale,ivargrp)%l_for_localization) then +-+ if(self%intstate%l_for_localization) then +- fileoutput="mgbftest_loc_"//str_rank//".txt" +- else +- fileoutput="mgbftest_static_"//str_rank//".txt" +- endif +-- +--write(6,*)'thinkdeb999 multiply sdl 2 ' +--call flush(6) +-- allocate(nlev_vargrp(nvargrp)) +-- total_km_a_all=0 +--!clt do iscale=1,self%nscale +-- do ivargrp=1,self%nvargrp +-- if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & +-- self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then +-- error stop "for being now, the filtering grids at the start of MGBF should be the same" +-- endif +-- total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all +-- enddo +-- +-- +-- n2d=0 +-- l3d_encountered=.false. +-- allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp)%nm,self%intstate(jscale,ivargrp)%mm)) +-- allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp)%nm,self%intstate(jscale,ivargrp)%mm)) +-- allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp)%nm*self%intstate(jscale,ivargrp)%mm)) +-- allocate(rnormalization(total_km_a_all)) +-- work2d_mgbf=0.0 +-- rnormalization=1.0 +-- +-- dim2d=shape(work2d_mgbf) +-- +-- dim3d=shape(work_mgbf) +-- nxloc=dim3d(2) +-- nyloc=dim3d(3) +-- nzloc=dim3d(1) +-- nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps +-- nvar=fields%size() +-- +-- allocate( varvlev_index(nvar,3)) +-- allocate( nlev_vargrp(nvargrp)) +-- nlev_vargrp=0 +-- ilev=1 +-- do isize=1,fields%size() +-- +-- afield= fields%field(isize) !clttodo +-- fs= afield%functionspace() !cltthinkfore debug +-- n_owned_size= fs%size_owned() !clt for debug +-- if(afield%rank() == 2) then +-- nz=afield%levels() +-- call afield%data(ptr_2d) +-- !clt do k=1,nz +-- !clt do i=1,n_owned_size +-- !clt val=ptr_2d(k,i) +-- !clt if (ieee_is_nan(val)) then +-- !clt print *, '[Fortran] ❗ NaN detected in value' +-- !clt elseif (ieee_is_finite(val) .eqv. .false.) then +-- !clt print *, '[Fortran] ❗ Inf detected in value' +-- !clt elseif (abs(val) > 1.0e20) then +-- !clt print *, '[Fortran] ⚠️ Suspicious large value:', val +-- !clt endif +-- !clt enddo +-- !clt do i=n_owned_size+1,size(ptr_2d,2) +-- !clt val=ptr_2d(k,i) +-- ! if (ieee_is_nan(val)) then +-- ! print *, '[Fortran]2 ❗ NaN detected in value' +-- !j elseif (ieee_is_finite(val) .eqv. .false.) then +-- ! print *, '[Fortran]2 ❗ Inf detected in value' +-- ! elseif (abs(val) > 1.0e20) then +-- ! print *, '[Fortran]2 ⚠️ Suspicious large value:', val +-- ! endif +-- ! enddo +-- ! enddo +-- +-- if(nz == 1) then +--!clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then +-- if(self%intstate(jscale,1)%l_for_localization) then +-- if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level +-- if(n_owned_size >0 ) then +-- work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) +-- else +-- work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d +-- endif +-- else +-- if(n_owned_size >0 ) then +-- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) +-- else +-- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d +-- endif +-- endif +-- +-- +-- else +-- if(n_owned_size >0 ) then +-- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) +-- else +-- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d +-- endif +-- endif +-- else +-- if(n_owned_size >0 ) then +-- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) +-+ +-+ +-+ +-+ +-+ n2d=0 +-+ l3d_encountered=.false. +-+ allocate(work_mgbf(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) +-+ allocate(work_mgbf2(self%intstate%km_a_all,self%intstate%nm,self%intstate%mm)) +-+ allocate(work2d_mgbf(self%intstate%km_a_all,self%intstate%nm*self%intstate%mm)) +-+ allocate(rnormalization(self%intstate%km_a_all)) +-+ work2d_mgbf=0.0 +-+ rnormalization=1.0 +-+ +-+ dim2d=shape(work2d_mgbf) +-+ +-+ dim3d=shape(work_mgbf) +-+ nxloc=dim3d(2) +-+ nyloc=dim3d(3) +-+ nzloc=dim3d(1) +-+ nz3d=self%intstate%lm_a +-+ nvar=fields%size() +-+ +-+ allocate( varvlev_index(nvar,3)) +-+ ilev=1 +-+ do isize=1,fields%size() +-+ +-+ afield= fields%field(isize) !clttodo +-+ fs= afield%functionspace() !cltthinkfore debug +-+ n_owned_size= fs%size_owned() !clt for debug +-+ if(afield%rank() == 2) then +-+ nz=afield%levels() +-+ call afield%data(ptr_2d) +-+!clt do k=1,nz +-+!clt do i=1,n_owned_size +-+ !clt val=ptr_2d(k,i) +-+!clt if (ieee_is_nan(val)) then +-+ !clt print *, '[Fortran] ❗ NaN detected in value' +-+ !clt elseif (ieee_is_finite(val) .eqv. .false.) then +-+ !clt print *, '[Fortran] ❗ Inf detected in value' +-+ !clt elseif (abs(val) > 1.0e20) then +-+ !clt print *, '[Fortran] ⚠️ Suspicious large value:', val +-+ !clt endif +-+!clt enddo +-+!clt do i=n_owned_size+1,size(ptr_2d,2) +-+ !clt val=ptr_2d(k,i) +-+! if (ieee_is_nan(val)) then +-+! print *, '[Fortran]2 ❗ NaN detected in value' +-+!j elseif (ieee_is_finite(val) .eqv. .false.) then +-+! print *, '[Fortran]2 ❗ Inf detected in value' +-+! elseif (abs(val) > 1.0e20) then +-+! print *, '[Fortran]2 ⚠️ Suspicious large value:', val +-+! endif +-+! enddo +-+! enddo +-+ +-+ if(nz == 1) then +-+ if(self%intstate%l_for_localization) then +-+ if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level +-+ if(n_owned_size >0 ) then +-+ work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) +-+ else +-+ work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d +-+ endif +- else +-- work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d +-+ if(n_owned_size >0 ) then +-+ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) +-+ else +-+ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d +-+ endif +- endif +-- endif +-+ +- +-- if(nz > 1) l3d_encountered=.true. +-- if(nz == 1) then +-- if(l3d_encountered ) then +-- write(6,*)"l3d_encountered is true , 2dvariable is not put in the begining, stop" +-- stop ! is required 2d fields are saved consecutively +-- endif +-- n2d=n2d+1 +-- endif +-- if(isize==1) then +-- varvlev_index(isize,1)= 1 +-- !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then +-- if(.not.self%intstate(jscale,1)%l_for_localization )then +-- varvlev_index(isize,2)= nz +-- else +-- varvlev_index(isize,2)= nz3d +-- endif +-- varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 +- else +-- !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d +-- varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 +-- if(.not.self%intstate(jscale,ivargrp)%l_for_localization )then +-- varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 +-+ if(n_owned_size >0 ) then +-+ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) +- else +-- varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 +-+ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d +- endif +-- varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 +- endif +-- jvargrp=self%ivargroup(isize) +-- nlev_vargrp(jvargrp)=nlev_vargrp(jvargrp)+varvlev_index(isize,2) +-- +-- rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate(jscale,jvargrp)%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) +-- +-- ilev=varvlev_index(isize,2)+1 +-- elseif (afield%rank() == 3) then +-- write(6,*)'this case needs more work, stop' ! a better exption handling to be added +-- call flush(6) +-- stop +-- call afield%data(ptr_3d) +-- nz=afield%levels() +-- work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d +-- ilev=ilev+nz +-- else +-- write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo +-- stop +-- endif +-- enddo +-- do k=1,nzloc +-- !cltorg work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) !clttothink should be done after the filtering +-- work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) +-- enddo +-- if(self%intstate(jscale,ivargrp)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp)%l_for_localization ) then +-- write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' +-- stop ! a better exception handling is to be added +-- endif +-- +-- if(test_once.and..1.gt.2) then +-- open(iounit,file=trim(fileoutput), status='replace',form="formatted") +-- write(iounit,*) work_mgbf +-- test_once=.false. +-- close(iounit) +-- endif +-- ii=1 +-- do ivargrp=1,nvargrp +-- allocate(vargrp_work_mgbf(nlev_vargrp(ivar),nxloc,nyloc)) +-- vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp),:,:) +-- +-- call etim(mg_preprocess_time) +-- +-- call btim(mg_anal_to_filt_time) +-- call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) +-- call etim(mg_anal_to_filt_time) +-- call btim(mg_filtering_time) +-- call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) +-- call etim(mg_filtering_time) +-- +-- !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) +-- call btim(mg_filt_to_anal_time) +-- call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(work_mgbf2) +-- call etim(mg_filt_to_anal_time) +-- !clt# work_mgbf=999.0 !thinkdeb for debug +-- +-- call btim(mg_postprocess_time) +-- work_mgbf(ii:ii+nlev_vargrp(ivargrp),:,:)=vargrp_work_mgbf(:,:,:) +-- deallocate(vargrp_work_mgbf) +-- ii=ii+nlev_vargrp(ivargrp)+1 +-- enddo ! ivargrp +-- if(.not. self%intstate(jscale,ivargrp)%l_for_localization ) then !clthinkdebxxx +-- work_mgbf=work_mgbf2 +-- else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures +-- allocate(work1var_mgbf(nz3d,nxloc,nyloc)) +-- work1var_mgbf=0.0 +-- do jvar=1,nvar +-- do ivar=1,nvar +-- lev1=varvlev_index(ivar,1) +-- lev2=varvlev_index(ivar,2) +-- work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvar,ivar)*work_mgbf2(lev1:lev2,:,:) +-- enddo +-- lev1=varvlev_index(jvar,1) +-- lev2=varvlev_index(jvar,2) +-- work_mgbf(lev1:lev2,:,:)=work1var_mgbf +-- enddo +-- deallocate(work1var_mgbf) +-- endif +-- do k=1,nzloc +-- work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) +-- enddo +-- do k=1,nzloc +-- work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) +-- enddo +-- ilev=1 +-- n_owned_size=0 +-- do isize=1,fields%size() +-- +-- afield=fields%field(isize) !clttodo +-- fs= afield%functionspace() !cltthinkfore debug +-- n_owned_size= fs%size_owned() !clt for debug +-- if(afield%rank() == 2) then +-- call afield%data(ptr_2d) +-- nz=afield%levels() +-- lev1=varvlev_index(isize,1) +-- if(nz.gt.1) then +-- ! if(n_owned_size == 0) then +-- ! do i = 1, size(ghost) +-- ! if (ghost(i) == 0) then +-- ! This point is owned (not a halo point) +-- ! n_owned_size=n_owned_size+1 +-- ! endif +-- ! end do +-- !! write(6,*)'thinkdeb2552 dimension of ptr_2d are ',size(ptr_2d,1), ' ',size(ptr_2d,2) +-- ! endif +-- !clt write(6,*)'thinkdeb2552 n_owned_size ',n_owned_size,' ','total size is ' ,size(ptr_2d,2) +-- if(n_owned_size >0 ) then +-- ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) +-- else +-- !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space +-- ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) +-- endif +-- else +-- if(self%intstate(jscale,ivargrp)%l_for_localization) then +-- if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level +-- +-- call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb +-- if(n_owned_size >0 ) then +-- ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) +-- else +-- !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space +-- ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) +-- endif +-- else +-- if(n_owned_size >0 ) then +-- ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) +-- else +-- !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space +-- ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) +-- endif +-+ else +-+ if(n_owned_size >0 ) then +-+ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) +-+ else +-+ work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d +-+ endif +-+ endif +-+ +-+ if(nz > 1) l3d_encountered=.true. +-+ if(nz == 1) then +-+ if(l3d_encountered ) then +-+ write(6,*)"l3d_encountered is true , 2dvariable is not put in the begining, stop" +-+ stop ! is required 2d fields are saved consecutively +-+ endif +-+ n2d=n2d+1 +-+ endif +-+ if(isize==1) then +-+ varvlev_index(isize,1)= 1 +-+ if(.not.self%intstate%l_for_localization )then +-+ varvlev_index(isize,2)= nz +-+ else +-+ varvlev_index(isize,2)= nz3d +-+ endif +-+ varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 +-+ else +-+!cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d +-+ varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 +-+ if(.not.self%intstate%l_for_localization )then +-+ varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 +-+ else +-+ varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 +-+ endif +-+ varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 +-+ endif +-+ rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) +-+ +-+ ilev=varvlev_index(isize,2)+1 +-+ elseif (afield%rank() == 3) then +-+ write(6,*)'this case needs more work, stop' ! a better exption handling to be added +-+ call flush(6) +-+ stop +-+ call afield%data(ptr_3d) +-+ nz=afield%levels() +-+ work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d +-+ ilev=ilev+nz +-+ else +-+ write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo +-+ stop +-+ endif +-+ enddo +-+ do k=1,nzloc +-+ work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) +-+ work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) +-+ enddo +-+ if(self%intstate%km2.ne.n2d.and. .not.self%intstate%l_for_localization ) then +-+ write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' +-+ stop ! a better exception handling is to be added +-+ endif +-+ if(test_once.and..1.gt.2) then +-+ open(iounit,file=trim(fileoutput), status='replace',form="formatted") +-+ write(iounit,*) work_mgbf +-+ test_once=.false. +-+ close(iounit) +-+ endif +-+ call etim(mg_preprocess_time) +-+ +-+ call btim(mg_anal_to_filt_time) +-+ call self%intstate%anal_to_filt_allmap(work_mgbf) +-+ call etim(mg_anal_to_filt_time) +-+ call btim(mg_filtering_time) +-+ call self%intstate%filtering_procedure(self%intstate%mgbf_proc,1) +-+ call etim(mg_filtering_time) +-+ +-+!cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) +-+ call btim(mg_filt_to_anal_time) +-+ call self%intstate%filt_to_anal_allmap(work_mgbf2) +-+ call etim(mg_filt_to_anal_time) +-+!clt# work_mgbf=999.0 !thinkdeb for debug +-+ +-+ call btim(mg_postprocess_time) +-+ if(.not. self%intstate%l_for_localization ) then !clthinkdebxxx +-+ work_mgbf=work_mgbf2 +-+ else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures +-+ allocate(work1var_mgbf(nz3d,nxloc,nyloc)) +-+ work1var_mgbf=0.0 +-+ do ivar=1,nvar +-+ lev1=varvlev_index(ivar,1) +-+ lev2=varvlev_index(ivar,2) +-+ work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) +-+ enddo +-+ do ivar=1,nvar +-+ lev1=varvlev_index(ivar,1) +-+ lev2=varvlev_index(ivar,2) +-+ work_mgbf(lev1:lev2,:,:)=work1var_mgbf +-+ enddo +-+ deallocate(work1var_mgbf) +-+ endif +-+ do k=1,nzloc +-+ work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) +-+ enddo +-+ ilev=1 +-+ n_owned_size=0 +-+ do isize=1,fields%size() +-+ +-+ afield=fields%field(isize) !clttodo +-+ fs= afield%functionspace() !cltthinkfore debug +-+ n_owned_size= fs%size_owned() !clt for debug +-+ if(afield%rank() == 2) then +-+ call afield%data(ptr_2d) +-+ nz=afield%levels() +-+ lev1=varvlev_index(isize,1) +-+ if(nz.gt.1) then +-+! if(n_owned_size == 0) then +-+! do i = 1, size(ghost) +-+! if (ghost(i) == 0) then +-+ ! This point is owned (not a halo point) +-+! n_owned_size=n_owned_size+1 +-+! endif +-+! end do +-+!! write(6,*)'thinkdeb2552 dimension of ptr_2d are ',size(ptr_2d,1), ' ',size(ptr_2d,2) +-+! endif +-+!clt write(6,*)'thinkdeb2552 n_owned_size ',n_owned_size,' ','total size is ' ,size(ptr_2d,2) +-+ if(n_owned_size >0 ) then +-+ ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) +-+ else +-+ !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space +-+ ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) +-+ endif +-+ else +-+ if(self%intstate%l_for_localization) then +-+ if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level +-+ +-+ call mpi_barrier(MPI_COMM_WORLD,ierr) !cltthinkdeb +-+ if(n_owned_size >0 ) then +-+ ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) +-+ else +-+ !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space +-+ ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) +- endif +-- else +-- if(n_owned_size >0 ) then +-+ else +-+ if(n_owned_size >0 ) then +- ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) +-- else +-+ else +- !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space +- ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) +-- endif +-- +- endif +-- endif +-- +-- elseif (afield%rank() == 3) then +-- call afield%data(ptr_3d) +-- nz=afield%levels() +-- write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo +-- call flush(6) +-- stop +-+ endif +-+ else +-+ if(n_owned_size >0 ) then +-+ ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) +-+ else +-+ !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space +-+ ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) +-+ endif +- +-+ endif +-+ endif +-+ +-+ elseif (afield%rank() == 3) then +-+ call afield%data(ptr_3d) +-+ nz=afield%levels() +-+ write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo +-+ call flush(6) +-+ stop +-+ +-+ +-+!clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) +-+ ilev=ilev+nz +-+ else +-+ write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo +-+ call flush(6) +-+ stop +-+ endif +-+ enddo +- +-- !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) +-- ilev=ilev+nz +-- else +-- write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo +-- call flush(6) +-- stop +-- endif +-- enddo +-- +-- call etim(mg_postprocess_time) +-+ call etim(mg_postprocess_time) +- +- +- +- +-- deallocate(work_mgbf) +-- deallocate(vargrp_work_mgbf) +-- deallocate(work_mgbf2) +-- deallocate(work2d_mgbf) +-- deallocate(rnormalization) +-- deallocate( varvlev_index) +-- !clt enddo !for iscale +-+ deallocate(work_mgbf) +-+ deallocate(work_mgbf2) +-+ deallocate(work2d_mgbf) +-+ deallocate(rnormalization) +-+ deallocate( varvlev_index) +- call etim(mg_multiply_time) +-- deallocate(nlev_vargrp) +- +- end subroutine multiply +- +-@@ -633,26 +519,6 @@ type(atlas_fieldset), intent(inout) :: fields +- ! var3d=0.0_r_kind +- +- end subroutine multiply_ad +--function imem2scale(self,imem) result(iscale) +-- class(mgbf_covariance),intent(in)::self +-- integer, intent(in)::imem +-- integer :: iscale +-- iscale=1 +-- do while (imem > self%iscalegroup(iscale) ) +-- iscale=iscale+1 +-- enddo +-- +--end function imem2scale +--function ivar2grp(self,ivar) result(jvargrp) +-- class(mgbf_covariance),intent(in)::self +-- integer, intent(in)::ivar +-- integer :: jvargrp +-- jvargrp=1 +-- do while (ivar > self%ivargroup(jvargrp) ) +-- jvargrp=jvargrp+1 +-- enddo +-- +--end function ivar2grp +- +- ! -------------------------------------------------------------------------------------------------- +- diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index eea13079..84caaebb 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -74,7 +957,7 @@ index 2d1c8369..a944393d 100755 const atlas::FieldSet *); } diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 -index 61869716..4aa6f610 100755 +index a1d9b8af..4aa6f610 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -33,9 +33,7 @@ public mgbf_covariance @@ -139,7 +1022,6 @@ index 61869716..4aa6f610 100755 -if (config%has("mgbf sdl and vdl init namelist file")) then - call config%get_or_die("mgbf mgbf sdl and vdl init namelist file", mgbf_nml) -write(6,*)'thinkdeb999 begin mgbf_nml ',trim(mgbf_nml) --call flush(6) - open(newunit=myunit,file=trim(mgbf_nml),status='old') -!# open(unit=10,file=mgbf_nml,status='old',action='read') - read(myunit,nml=parameters_mgbf_init) @@ -179,6 +1061,7 @@ index 61869716..4aa6f610 100755 - -write(6,*)'thinkdeb999 begin sdl 9 ' -call flush(6) +- -if(nscale == 1 .and. nvargrp ==1 ) then - self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used - !and hence, it would be backward-compatible From 7ae26fb9feba318f9d4229d41c8c3003626736e4 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Wed, 13 Aug 2025 10:36:03 -0500 Subject: [PATCH 051/199] WIP --- src/saber/mgbf/covariance/MGBF_Covariance.h | 2 +- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 13 ++++++++----- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index eea13079b..aea9f0688 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -203,7 +203,7 @@ void MGBF_Covariance::randomize(oops::FieldSet3D & fset) const { void MGBF_Covariance::multiply(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiply starting" << std::endl; util::Timer timer(classname(), "multiply"); - int index_member=fset.get()->metadata().get("ensemble member index"); + int index_member=fset.fieldSet().metadata().get("ensemble member index"); oops::Log::trace()<<"thinkdeb999 sdl multiply index_member "<0 ) then ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) else From ee0437b9c124c7f69538b1499b1ba19fb474294c Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Wed, 13 Aug 2025 11:47:58 -0500 Subject: [PATCH 052/199] WIP --- src/saber/interpolation/Interpolation.cc | 10 ++++++++++ src/saber/mgbf/covariance/MGBF_Covariance.h | 1 + .../mgbf/covariance/MGBF_Covariance.interface.F90 | 14 +++++++++++++- .../mgbf/covariance/MGBF_Covariance.interface.h | 2 +- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 4 ++-- src/saber/oops/Localization.h | 9 +++++++++ 6 files changed, 36 insertions(+), 4 deletions(-) diff --git a/src/saber/interpolation/Interpolation.cc b/src/saber/interpolation/Interpolation.cc index ef35c0273..9a484e017 100644 --- a/src/saber/interpolation/Interpolation.cc +++ b/src/saber/interpolation/Interpolation.cc @@ -122,6 +122,8 @@ void Interpolation::multiplyAD(oops::FieldSet3D & fieldSet) const { // Temporary FieldSet of active variables for interpolation target atlas::FieldSet targetFieldSet; + atlas::FieldSet backup_input_fieldset; + backup_input_fieldset.metadata()=fieldSet.fieldSet().metadata(); for (const auto & var : activeVars_) { targetFieldSet.add(fieldSet[var.name()]); } @@ -152,6 +154,14 @@ void Interpolation::multiplyAD(oops::FieldSet3D & fieldSet) const { } fieldSet.fieldSet() = sourceFieldSet; + + auto & dst_fset = fieldSet.fieldSet(); + if (backup_input_fieldset.metadata().has("ensemble member index")) { + oops::Log::trace() << classname() << "interpolationmultiplyAD 999 yes" << std::endl; + dst_fset.metadata().template set("ensemble member index", backup_input_fieldset.metadata().template get("ensemble member index")); + } + + oops::Log::trace() << classname() << "::multiplyAD done" << std::endl; } diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index aea9f0688..e564a5ed8 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -205,6 +205,7 @@ void MGBF_Covariance::multiply(oops::FieldSet3D & fset) const { util::Timer timer(classname(), "multiply"); int index_member=fset.fieldSet().metadata().get("ensemble member index"); oops::Log::trace()<<"thinkdeb999 sdl multiply index_member "<::multiply(Increment_ & dx) const { // SABER block chain multiplication oops::FieldSet4D fset4d({dx.validTime(), dx.geometry().getComm()}); fset4d[0].shallowCopy(dx.fieldSet()); + auto & src_fset = dx.fieldSet().fieldSet(); + auto & dst_fset = fset4d[0].fieldSet(); + if (src_fset.metadata().has("ensemble member index")) { + oops::Log::trace() << "Localization:multiply starting 2 999yes" << std::endl; + dst_fset.metadata().template set("ensemble member index", src_fset.metadata().template get("ensemble member index")); +} + if (dst_fset.metadata().has("ensemble member index")) { + oops::Log::trace() << "Localization:multiply startign 3 999 yes" << std::endl; } + oops::Log::trace()<multiply(fset4d); dx.fromFieldSet(fset4d[0].fieldSet()); From 16fb655b28147d142ed5c112179b851ae89b20d8 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Wed, 13 Aug 2025 21:18:36 -0500 Subject: [PATCH 053/199] A version of SDL/VDL passing the initial verifications --- .../covariance/MGBF_Covariance.interface.F90 | 6 +- .../mgbf/covariance/mgbf_covariance_mod.f90 | 74 ++++++++++++------- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 4 +- 3 files changed, 52 insertions(+), 32 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 index 842e69fa1..b28d5e0d3 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 +++ b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 @@ -148,7 +148,7 @@ subroutine mgbf_covariance_multiply_cpp(c_self, c_afieldset,c_index_member_in) & !Arguments integer(c_int), intent(in) :: c_self -integer(c_int), intent(in) :: c_index_member_in +integer(c_int),value, intent(in) :: c_index_member_in type(c_ptr), value, intent(in) :: c_afieldset type(mgbf_covariance), pointer :: f_self @@ -158,10 +158,6 @@ subroutine mgbf_covariance_multiply_cpp(c_self, c_afieldset,c_index_member_in) & write(6,*)'thinkdeb 999 in inteface f90 star' call flush(6) call btim(mg_interface_multiply_time) -write(6,*) 'c_selfd999:', c_self -call flush(6) -write(6,*) 'c_afieldsetd999:', transfer(c_afieldset,0_c_intptr_t) -call flush(6) write(6,*)'thinkdeb 999 in inteface f90 star0.5 c_index_member_in ',c_index_member_in call flush(6) index_member_in=int(c_index_member_in,kind=kind(index_member_in)) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 54d22a6d9..485f7338d 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -107,8 +107,9 @@ subroutine create(self, comm, config, background, firstguess) call config%get_or_die("saber block name", centralblockname) !clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) if (config%has("mgbf sdl and vdl init namelist file")) then - call config%get_or_die("mgbf mgbf sdl and vdl init namelist file", mgbf_nml) + call config%get_or_die("mgbf sdl and vdl init namelist file", mgbf_nml) write(6,*)'thinkdeb999 begin mgbf_nml ',trim(mgbf_nml) + call flush(6) open(newunit=myunit,file=trim(mgbf_nml),status='old') !# open(unit=10,file=mgbf_nml,status='old',action='read') read(myunit,nml=parameters_mgbf_init) @@ -147,8 +148,11 @@ subroutine create(self, comm, config, background, firstguess) !still need allocate them though nscale=nvargrp=1 allocate(self%mgbf_nml_group(nscale,nvargrp)) allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + self%multigrp_cor=1.0 allocate(self%iscalegroup(nscale) ) + self%iscalegroup(nscale) =1 allocate(self%ivargroup(nvargrp) ) + self%ivargroup=1 endif write(6,*)'thinkdeb999 begin sdl 9 ' @@ -164,6 +168,8 @@ subroutine create(self, comm, config, background, firstguess) call flush(6) do iscale=1,nscale do ivargrp=1,nvargrp + write(6,*)'the999 nml is ', trim(self%mgbf_nml_group(iscale,ivargrp)) + call flush(6) call self%intstate(iscale,ivargrp)%mg_initialize(self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml enddo enddo @@ -268,6 +274,7 @@ subroutine multiply(self, fields,index_member_in) real(kind=r_kind), allocatable :: work_mgbf(:,:,:) real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) real(kind=r_kind), allocatable :: work2d_mgbf(:,:) real(kind=r_kind), allocatable :: rnormalization(:) @@ -290,8 +297,9 @@ subroutine multiply(self, fields,index_member_in) integer :: ierr real(kind=8) :: val integer :: member_index -integer :: iscale,jscale, ivargrp,jvargrp +integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp integer :: total_km_a_all,ii,nvargrp +integer :: ilev1,ilev2 !clt now noly consider t ! afield = fields%field('air_temperature') @@ -304,7 +312,7 @@ subroutine multiply(self, fields,index_member_in) nvargrp=self%nvargrp call btim(mg_multiply_time) call btim(mg_preprocess_time) - if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,ivargrp)%km2 > 0) then + if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,1)%km2 > 0) then write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & & "in which, the first level contains the 2d variables and others zeros " @@ -312,7 +320,7 @@ subroutine multiply(self, fields,index_member_in) endif myrank=self%rank write(str_rank,"(I4.4)")myrank - if(self%intstate(jscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,1)%l_for_localization) then fileoutput="mgbftest_loc_"//str_rank//".txt" else fileoutput="mgbftest_static_"//str_rank//".txt" @@ -321,6 +329,7 @@ subroutine multiply(self, fields,index_member_in) write(6,*)'thinkdeb999 multiply sdl 2 ' call flush(6) allocate(nlev_vargrp(nvargrp)) + nlev_vargrp=0 total_km_a_all=0 !clt do iscale=1,self%nscale do ivargrp=1,self%nvargrp @@ -328,18 +337,32 @@ subroutine multiply(self, fields,index_member_in) self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then error stop "for being now, the filtering grids at the start of MGBF should be the same" endif + write(6,*)'thinkdeb999 1 ivargrp s km_all ',self%intstate(jscale,ivargrp)%km_a_all total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all + write(6,*)'thinkdeb999 1 km_all ',total_km_a_all + nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all enddo + nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps n2d=0 l3d_encountered=.false. - allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp)%nm,self%intstate(jscale,ivargrp)%mm)) - allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp)%nm,self%intstate(jscale,ivargrp)%mm)) - allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp)%nm*self%intstate(jscale,ivargrp)%mm)) + ivargrp0=1 + allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) + allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) + allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) allocate(rnormalization(total_km_a_all)) work2d_mgbf=0.0 rnormalization=1.0 + do ivargrp=1,nvargrp + ilev1=1 + ilev2=ilev1+nz3d-1 + do while (ilev2.le.nlev_vargrp(ivargrp) ) + rnormalization(ilev1:ilev2)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) + ilev1=ilev1+nz3d + ilev2=ilev2+nz3d + enddo + enddo dim2d=shape(work2d_mgbf) @@ -347,12 +370,10 @@ subroutine multiply(self, fields,index_member_in) nxloc=dim3d(2) nyloc=dim3d(3) nzloc=dim3d(1) - nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps nvar=fields%size() - allocate( varvlev_index(nvar,3)) - allocate( nlev_vargrp(nvargrp)) - nlev_vargrp=0 + varvlev_index=0 + ilev=1 do isize=1,fields%size() @@ -438,17 +459,15 @@ subroutine multiply(self, fields,index_member_in) else !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 - if(.not.self%intstate(jscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 else varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 endif varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 endif - jvargrp=self%ivargroup(isize) - nlev_vargrp(jvargrp)=nlev_vargrp(jvargrp)+varvlev_index(isize,2) + jvargrp=self%ivar2grp(isize) - rnormalization(varvlev_index(isize,1):varvlev_index(isize,2))=self%intstate(jscale,jvargrp)%coef_normalization(1:(varvlev_index(isize,2)-varvlev_index(isize,1)+1)) ilev=varvlev_index(isize,2)+1 elseif (afield%rank() == 3) then @@ -468,7 +487,7 @@ subroutine multiply(self, fields,index_member_in) !cltorg work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) !clttothink should be done after the filtering work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) enddo - if(self%intstate(jscale,ivargrp)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp)%l_for_localization ) then + if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added endif @@ -481,8 +500,9 @@ subroutine multiply(self, fields,index_member_in) endif ii=1 do ivargrp=1,nvargrp - allocate(vargrp_work_mgbf(nlev_vargrp(ivar),nxloc,nyloc)) - vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp),:,:) + allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) + allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) + vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) call etim(mg_preprocess_time) @@ -495,25 +515,28 @@ subroutine multiply(self, fields,index_member_in) !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) call btim(mg_filt_to_anal_time) - call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(work_mgbf2) + call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) call etim(mg_filt_to_anal_time) !clt# work_mgbf=999.0 !thinkdeb for debug call btim(mg_postprocess_time) - work_mgbf(ii:ii+nlev_vargrp(ivargrp),:,:)=vargrp_work_mgbf(:,:,:) + work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf(:,:,:) + ii=ii+nlev_vargrp(ivargrp) deallocate(vargrp_work_mgbf) - ii=ii+nlev_vargrp(ivargrp)+1 + deallocate(vargrp_work_mgbf2) enddo ! ivargrp - if(.not. self%intstate(jscale,ivargrp)%l_for_localization ) then !clthinkdebxxx + if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx work_mgbf=work_mgbf2 else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures allocate(work1var_mgbf(nz3d,nxloc,nyloc)) work1var_mgbf=0.0 do jvar=1,nvar + jvargrp=self%ivar2grp(jvar) do ivar=1,nvar lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvar,ivar)*work_mgbf2(lev1:lev2,:,:) + ivargrp=self%ivar2grp(ivar) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) enddo lev1=varvlev_index(jvar,1) lev2=varvlev_index(jvar,2) @@ -607,7 +630,6 @@ subroutine multiply(self, fields,index_member_in) deallocate(work_mgbf) - deallocate(vargrp_work_mgbf) deallocate(work_mgbf2) deallocate(work2d_mgbf) deallocate(rnormalization) @@ -641,7 +663,7 @@ function imem2scale(self,imem) result(iscale) integer, intent(in)::imem integer :: iscale iscale=1 - do while (imem > self%iscalegroup(iscale) ) + do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) iscale=iscale+1 enddo @@ -651,7 +673,7 @@ function ivar2grp(self,ivar) result(jvargrp) integer, intent(in)::ivar integer :: jvargrp jvargrp=1 - do while (ivar > self%ivargroup(jvargrp) ) + do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) jvargrp=jvargrp+1 enddo diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 52bc71073..09b770999 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -556,8 +556,10 @@ subroutine init_mg_parameter(this,inputfilename) ,nm0,mm0 & ,nxPE,nyPE,im_filt,jm_filt , & l_mg_weig_readin + write(6,*)'thinkdeb999 in mg_parameter, inputfile ',trim(inputfilename) + call flush(6) - open(unit=10,file=inputfilename,status='old',action='read') + open(unit=10,file=trim(inputfilename),status='old',action='read') read(10,nml=parameters_mgbeta) close(unit=10) ! From 50c0991245938adc328ac5f221f86de310ec1c1d Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 18 Aug 2025 01:30:40 +0000 Subject: [PATCH 054/199] a MGBF/SABER based SDL/VDL passing more verifications and incorporated changed phints.f90 from myfork_mgbf_jim_vert_varied_aspt --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 39 +- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 26 +- src/saber/mgbf/mgbf_lib/phint1.f90 | 675 ++++++++++-------- 3 files changed, 400 insertions(+), 340 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 485f7338d..aec0da7c1 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -101,15 +101,11 @@ subroutine create(self, comm, config, background, firstguess) ! --------------- !clt call self%grid%create(config, comm) self%rank = comm%rank() -write(6,*)'thinkdeb999 begin sdl 0 ' -call flush(6) call config%get_or_die("saber block name", centralblockname) !clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) if (config%has("mgbf sdl and vdl init namelist file")) then call config%get_or_die("mgbf sdl and vdl init namelist file", mgbf_nml) -write(6,*)'thinkdeb999 begin mgbf_nml ',trim(mgbf_nml) - call flush(6) open(newunit=myunit,file=trim(mgbf_nml),status='old') !# open(unit=10,file=mgbf_nml,status='old',action='read') read(myunit,nml=parameters_mgbf_init) @@ -141,10 +137,7 @@ subroutine create(self, comm, config, background, firstguess) self%ivargroup(i)=readin_ivargroup(iscale) enddo else -write(6,*)'thinkdeb999 begin no sdl 2 ' call config%get_or_die("mgbf namelist file ", mgbf_nml) -write(6,*)'thinkdeb999 begin no sdl 3 ' -call flush(6) !still need allocate them though nscale=nvargrp=1 allocate(self%mgbf_nml_group(nscale,nvargrp)) allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship @@ -155,8 +148,6 @@ subroutine create(self, comm, config, background, firstguess) self%ivargroup=1 endif -write(6,*)'thinkdeb999 begin sdl 9 ' -call flush(6) if(nscale == 1 .and. nvargrp ==1 ) then self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used @@ -173,8 +164,6 @@ subroutine create(self, comm, config, background, firstguess) call self%intstate(iscale,ivargrp)%mg_initialize(self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml enddo enddo -write(6,*)'thinkdeb999 begin allocate sdl end ' -call flush(6) ! Get background (temporary test of the functionality) !cltafield = background%field('air_temperature') !clt call afield%data(t) @@ -305,8 +294,6 @@ subroutine multiply(self, fields,index_member_in) ! afield = fields%field('air_temperature') ! call afield%data(t) !*** From the analysis to first generation of filter grid -write(6,*)'thinkdeb999 multiply sdl 1 ' -call flush(6) member_index=index_member_in+1 ! the privous ensemble index starts from 0) jscale=self%imem2scale(member_index) nvargrp=self%nvargrp @@ -326,8 +313,6 @@ subroutine multiply(self, fields,index_member_in) fileoutput="mgbftest_static_"//str_rank//".txt" endif -write(6,*)'thinkdeb999 multiply sdl 2 ' -call flush(6) allocate(nlev_vargrp(nvargrp)) nlev_vargrp=0 total_km_a_all=0 @@ -337,9 +322,7 @@ subroutine multiply(self, fields,index_member_in) self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then error stop "for being now, the filtering grids at the start of MGBF should be the same" endif - write(6,*)'thinkdeb999 1 ivargrp s km_all ',self%intstate(jscale,ivargrp)%km_a_all total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all - write(6,*)'thinkdeb999 1 km_all ',total_km_a_all nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all enddo @@ -353,14 +336,14 @@ subroutine multiply(self, fields,index_member_in) allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) allocate(rnormalization(total_km_a_all)) work2d_mgbf=0.0 - rnormalization=1.0 + ii=1 do ivargrp=1,nvargrp - ilev1=1 - ilev2=ilev1+nz3d-1 - do while (ilev2.le.nlev_vargrp(ivargrp) ) - rnormalization(ilev1:ilev2)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) - ilev1=ilev1+nz3d + ilev1=1 + ilev2=ilev1+nz3d-1 + do while (ilev2.le.nlev_vargrp(ivargrp) ) !todo optimization of tihs llop + rnormalization(ii:ii+nz3d-1)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) ilev2=ilev2+nz3d + ii=ii+nz3d enddo enddo @@ -520,17 +503,20 @@ subroutine multiply(self, fields,index_member_in) !clt# work_mgbf=999.0 !thinkdeb for debug call btim(mg_postprocess_time) - work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf(:,:,:) + work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) ii=ii+nlev_vargrp(ivargrp) deallocate(vargrp_work_mgbf) deallocate(vargrp_work_mgbf2) enddo ! ivargrp + do k=1,nzloc + work_mgbf2(k,:,:)=work_mgbf2(k,:,:)/rnormalization(k) + enddo if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx work_mgbf=work_mgbf2 else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - work1var_mgbf=0.0 do jvar=1,nvar + work1var_mgbf=0.0 jvargrp=self%ivar2grp(jvar) do ivar=1,nvar lev1=varvlev_index(ivar,1) @@ -546,9 +532,6 @@ subroutine multiply(self, fields,index_member_in) endif do k=1,nzloc work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) - enddo - do k=1,nzloc - work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) enddo ilev=1 n_owned_size=0 diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 09b770999..29cee9aea 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -145,7 +145,8 @@ module mg_parameter 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 -real(r_kind):: coef_normalization(lm_max)=1.0 !normalizaton coefficients +!cltreal(r_kind):: coef_normalization(lm_max)=1.0 !normalizaton coefficients +real(r_kind):: coef_normalization(lm_max)=1 !normalizaton coefficients real(r_kind):: coef_normalization_const=-9999.0 ! constant, if set, this contant will be ! assigned to all elements of coef_normalization @@ -507,7 +508,8 @@ subroutine init_mg_parameter(this,inputfilename) integer(i_kind):: lm_a ! number of vertical layers in analysis fields integer(i_kind):: lm ! number of vertical layers in filter grids -real(r_kind):: coef_normalization(lm_max)=1.0 !normalizaton coefficients +!clthhhreal(r_kind):: coef_normalization(lm_max)=1.0 !normalizaton coefficients +real(r_kind):: coef_normalization(lm_max)=1 !normalizaton coefficients real(r_kind):: coef_normalization_const=-9999.0 ! constant, if set, this contant will be integer(i_kind):: km2 ! number of 2d variables for filtering integer(i_kind):: km3 ! number of 3d variables for filtering @@ -556,8 +558,6 @@ subroutine init_mg_parameter(this,inputfilename) ,nm0,mm0 & ,nxPE,nyPE,im_filt,jm_filt , & l_mg_weig_readin - write(6,*)'thinkdeb999 in mg_parameter, inputfile ',trim(inputfilename) - call flush(6) open(unit=10,file=trim(inputfilename),status='old',action='read') read(10,nml=parameters_mgbeta) @@ -949,9 +949,6 @@ subroutine convert_vert_varied_aspt allocate(this%aspect_vert_profile_angrid(lm_a),this%aspect_vert_profile_filtgrid(lm)) allocate(sigofz(lm_a),sigofis(lm)) call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr) - write(6,*)'thinkdeb mype is ',mype, l_vert_stretched_filtgrid - write(6,*)'thinkdeb mype is lm_a ',mype, lm_a,lm - call flush(6) if(this%l_vert_stretched_filtgrid) then if(mype.eq.0) then open(newunit=myunit,file="mgbf_vert_aspt_profile.txt",status='old') @@ -964,9 +961,6 @@ subroutine convert_vert_varied_aspt enddo close(myunit) endif - write(6,*)'thinkdeb mype is 1.1.0 ',mype - write(6,*) 'DEBUG: lm_a=', lm_a -write(6,*) 'DEBUG: allocated=', allocated(this%aspect_vert_profile_angrid) if (allocated(this%aspect_vert_profile_angrid)) then write(6,*) 'DEBUG: size=', size(this%aspect_vert_profile_angrid) write(6,*) 'DEBUG: kind1=', kind(this%aspect_vert_profile_angrid(1)) @@ -976,27 +970,18 @@ subroutine convert_vert_varied_aspt write(6,*) "ERROR: No matching MPI type for real kind =", kind(this%aspect_vert_profile_angrid(1)) call MPI_Abort(MPI_COMM_WORLD, 1, ierr) endif - write(6,*)'thinkdeb mype is 1.2 ',mype - call flush(6) call MPI_Bcast(this%aspect_vert_profile_angrid, lm_a, user_mpi_real, 0, MPI_COMM_WORLD, ierr) ! nz=lm_a-1 ! ns=lm-1 - write(6,*)'thinkdeb mype is 1 ',mype - call flush(6) ! calibrate sigscale to make sigofz go to sigbottom at z=0: sigofz=sqrt(this%aspect_vert_profile_angrid) - print'('' list the levels and sigofz from the top down:'')' - write(6,*)'thinkdeb mype is 3 ',mype - call flush(6) if(mype==0) then do iz=lm_a,1,-1 write(6,*)iz,sigofz(iz) enddo endif - write(6,*)'thinkdeb mype is 3 ',mype - call flush(6) ! Make the new grid whose resolution of the correlation scale sigofz ! is uniform throughout. @@ -1004,8 +989,6 @@ subroutine convert_vert_varied_aspt ! zofis is the z-index coordinate of each of the new s-grid points. !cltorg call make_ssgrid(nz,nf,ns,sigofz, sstop,dss,isofz,zofis) call make_ssgrid(lm_a-1,nf,lm-1,sigofz, sstop,dss,this%isofz,this%zofis) - write(6,*)'thinkdeb mype is after make_ssgrid ',mype - call flush(6) ! Use the new s-grid locations zofis, and the original profile of ! correlation scales sigofz, to interpolate, smoothly and positively, @@ -1024,7 +1007,6 @@ subroutine convert_vert_varied_aspt close(myunit) endif mg_ampl01=(sum(sigofis**2)/size(sigofis)) - write(6,*)'thinkdeb999 the converted mg_mapl01 is ',mg_ampl01 !clt if(this%l_2dvar_last_vertical_level == .true. ) then !the fieldset passed into mgbf will be top-down,so !clttodo need to access this from mgbf lib too this%zofis=this%zofis(lm:1:-1) diff --git a/src/saber/mgbf/mgbf_lib/phint1.f90 b/src/saber/mgbf/mgbf_lib/phint1.f90 index 24f1ac75b..2cf6dd850 100644 --- a/src/saber/mgbf/mgbf_lib/phint1.f90 +++ b/src/saber/mgbf/mgbf_lib/phint1.f90 @@ -19,35 +19,103 @@ module phint1 use mgbf_kinds, only: i_kind,r_kind use phint, only: wint3,whint,v1_wint3,v1_whint implicit none -public -public:: make_ssf, make_ssgrid, intftos, sstosig, logintgrid, zsigtossig - - -!============================================================================ +public:: make_ssf, make_ssgrid, zsigtossig, interpftos, sstosig, intgrid, & + logintgrid, wintgrid, monotonicrefine,sofztozofs interface make_ssf module procedure make_ssf end interface make_ssf interface make_ssgrid - module procedure make_ssgrid + module procedure make_ssgrid, make_sfgrid end interface make_ssgrid interface zsigtossig - module procedure zsigtossig + module procedure zsigtossig, zsigtosfsig end interface zsigtossig -interface intftos - module procedure intftos -end interface intftos +interface interpftos + module procedure interpftos +end interface interpftos interface sstosig module procedure sstosig end interface sstosig +interface intgrid + module procedure intgrid, intgridw +end interface intgrid +interface wintgrid + module procedure wintgrid +end interface wintgrid interface logintgrid - module procedure logintgrid + module procedure logintgrid, logintgridw end interface logintgrid - +interface sofztozofs + module procedure sofztozofs, sofztozofs_f +end interface sofztozofs +interface monotonicrefine + module procedure monotonicrefine +end interface monotonicrefine contains !============================================================================ -subroutine make_ssgrid(nz,nf,ns,sigofz,sstop,dss,isofz,zofis)! [make_ssgrid] +subroutine make_ssf(nz,nf,sigofz,ssofzf)! [make_ssf] +!============================================================================ +! Use the scales, in original [0:nz] "z-grid" units, sigofz, to define an +! effective integrated distance, ss, in these scale units, for every level +! of a refined version [0:nz*nf] of that original z grid. This is done by +! regarding each sigofz as the inverse of the derivative of ss wrt the +! z-index, and integrating the interpolated inverse of sigofz on a uniformly +! refined version [0:nz*nf] of the z grid. To avoid small or negative values +! occurring in the interpolation, it is actually the logarithm of (1/sigofz) +! (i.e., -log(sigofz) ) that we interpolate. The fine grid of values of ss +! are returned as the array ssf. +!============================================================================ +use jp_pietc, only: u1,o2 +implicit none +integer(i_kind), intent(in ):: nz,nf +real(r_kind),dimension(0:nz), intent(in ):: sigofz +real(r_kind),dimension(0:nz*nf),intent(out):: ssofzf +!----------------------------------------------------------------------------- +real(r_kind),dimension(0:nz*nf):: zofzf,sigiofzf +real(r_kind) :: dzf,s +integer(i_kind) :: izf,nzf +!============================================================================= +! Assume sigofz is given on a unit grid, [0:nz] +! Logarithmically Interpolate the 1/sigofz distribution to a uniform finer grid, +! [0:nz*nf] and integrate it along this finer grid to get ssofzf. +! (interpolating the logarithm avoids the possibility of negative undershoots +! of the interpolated values). +!============================================================================= +nzf=nz*nf +dzf=u1/nf +do izf=0,nzf + zofzf(izf)=izf*dzf +enddo +call logintgrid(nz,nzf,zofzf,u1/sigofz, sigiofzf) +! Integrate sigiofzf +s=0; ssofzf(0)=s +do izf=1,nzf + s=s+sigiofzf(izf-1)+sigiofzf(izf); ssofzf(izf)=s +enddo +ssofzf=ssofzf*dzf*o2 +end subroutine make_ssf + +!============================================================================ +subroutine make_sfgrid(nz,nfz,ns,nfs,sigofz, sstop,dssf,sfofz,& + zofsf)! [make_ssgrid] +!============================================================================ +use jp_pietc, only: u1,o2 +implicit none +integer(i_kind), intent(in ):: nz,nfz,ns,nfs +real(r_kind),dimension(0:nz), intent(in ):: sigofz +real(r_kind), intent(out):: sstop,dssf +real(r_kind),dimension(0:nz), intent(out):: sfofz +real(r_kind),dimension(0:ns*nfs),intent(out):: zofsf +!---------------------------------------------------------------------------- +integer(i_kind) :: nsf +!============================================================================ +nsf=ns*nfs +call make_ssgrid(nz,nfz,nsf,sigofz, sstop,dssf,sfofz,zofsf) +end subroutine make_sfgrid +!============================================================================ +subroutine make_ssgrid(nz,nf,ns,sigofz, sstop,dss,sofz,zofs)! [make_ssgrid] !============================================================================ ! Use the vertical profile, sigofs, of idealized correlation scale ! on the unit-spaced model grid of nz spaces to derive the total integrated @@ -55,30 +123,27 @@ subroutine make_ssgrid(nz,nf,ns,sigofz,sstop,dss,isofz,zofis)! [make_ssgrid] ! by using careful interpolations of the log of sigofz on the grid refined ! in the vertical by a factor of nf, divide the vertical domain into ! a new grid whose spacing is uniform in these scale units and which -! possesses ns grid spaces. On this grid, the correslation scale is +! possesses ns grid spaces. On this grid, the correlation scale is ! constant, and can be taken to be sstopons=sstop/ns. -! Also, output the array, isofz, defining the index-coordinate of +! Also, output the array, sofz, defining the index-coordinate of ! the new grid that corresponds to each model grid level, and the -! model grid index coordinate, zofis, that corresponds to each level of +! model grid index coordinate, zofs, that corresponds to each level of ! out new scale-grid. All grids are assumed to go from index 0. !============================================================================ use jp_pietc, only: u1,o2 -use phint, only: wint3,whint implicit none integer(i_kind), intent(in ):: nz,nf,ns real(r_kind),dimension(0:nz),intent(in ):: sigofz real(r_kind), intent(out):: sstop,dss -real(r_kind),dimension(0:nz),intent(out):: isofz -real(r_kind),dimension(0:ns),intent(out):: zofis +real(r_kind),dimension(0:nz),intent(out):: sofz +real(r_kind),dimension(0:ns),intent(out):: zofs !---------------------------------------------------------------------------- -real(r_kind),dimension(0:nz) :: zs,logsig -real(r_kind),dimension(0:nz*nf):: zsf,logsigf,ssf +real(r_kind),dimension(0:nz) :: zs +real(r_kind),dimension(0:nz*nf):: zsf,ssf real(r_kind),dimension(0:ns) :: ss -real(r_kind),dimension(3) :: w3 -real(r_kind),dimension(4) :: w4 real(r_kind) :: r,s,z,dzf integer(i_kind) :: iz,izf,izfm,izfp,is,nzf -!============================================================================ +!============================================================================ ! Interpolate the log of the sigofz distribution to a finer grid: dzf=u1/nf nzf=nz*nf @@ -87,17 +152,17 @@ subroutine make_ssgrid(nz,nf,ns,sigofz,sstop,dss,isofz,zofis)! [make_ssgrid] ! define the new grid of ns spaces that uniformly divides the ! range of ss: dss=sstop/ns -isofz(0)=0 -isofz(nz)=ns +sofz(0)=0 +sofz(nz)=ns do iz=1,nz-1 izf=iz*nf - isofz(iz)=ssf(izf)/dss + sofz(iz)=ssf(izf)/dss enddo do is=0,ns ss(is)=is*dss enddo -zofis(0)=0 -zofis(ns)=nz +zofs(0)=0 +zofs(ns)=nz izfp=1 do is=1,ns-1 s=ss(is) @@ -107,21 +172,28 @@ subroutine make_ssgrid(nz,nf,ns,sigofz,sstop,dss,isofz,zofis)! [make_ssgrid] enddo izf=izfp-1 r=(s-ssf(izf))/(ssf(izfp)-ssf(izf)) - zofis(is)=(izf+r)/nf + zofs(is)=(izf+r)/nf enddo end subroutine make_ssgrid !=========================================================================== -subroutine zsigtossig(nz,nf,ns,zofs,sigofz,sigofs)! [zsigtossig] +subroutine zsigtossig(nz,nf,ns,zofs,sigofz, sigofs)! [zsigtossig] !=========================================================================== ! Interpolate the sigma in z-grid units from the z-grid to the ! equivalent sigma in s-grid unit in the s-grid. The z-grid index -! coordinates of the each s-grid level is given by zofs. The index -! range of the z-grid is [0:nz], of the s-grid it is [0:ns] and an +! coordinates of the each s-grid level is given by zofs. zofs is prepared +! beforehand by calling subroutine make_ssgrid with, in general, a +! possibly different profile of sigma. +! The index range of the z-grid is [0:nz], of the s-grid it is [0:ns] and an ! intermediate refined version of the z-grid has index range, [0:nz*nf] ! where nf is a positive integer refinement factor to ensure that the ! intermediate calculations have only small truncation errors. -! sigofz is the z-grid sigma, sigofs is the computed s-grid sigma. +! sigofz is the z-grid sigma that is being interpolated, but note that +! it is generally not the same sigma that was used to construct the +! regularized s-grid. sigofs is the interpolated s-grid sigma. A version +! of this algorithm that goes through an intermediate refined s-grid (to +! further reduce truncation errors in the final part of the computation) +! is found in the overloaded subroutine zsigtosfsig. !============================================================================ implicit none integer(i_kind), intent(in ):: nz,nf,ns @@ -129,15 +201,54 @@ subroutine zsigtossig(nz,nf,ns,zofs,sigofz,sigofs)! [zsigtossig] real(r_kind),dimension(0:nz),intent(in ):: sigofz real(r_kind),dimension(0:ns),intent(out):: sigofs !---------------------------------------------------------------------------- -real(r_kind),dimension(0:nz*nf):: ssf,sss +real(r_kind),dimension(0:nz*nf):: ssf +real(r_kind),dimension(0:ns) :: sss !============================================================================ call make_ssf(nz,nf,sigofz,ssf) -call intftos(nz,nf,ns,zofs,ssf,sss) +call interpftos(nz,nf,ns,zofs,ssf,sss) call sstosig(ns,sss,sigofs) end subroutine zsigtossig +!=========================================================================== +subroutine zsigtosfsig(nz,nfz,ns,nfs,zofsf,sigofz, sigofs)! [zsigtossig] +!=========================================================================== +! Interpolate the sigma in z-grid units from the z-grid to the +! equivalent sigma in s-grid unit in the s-grid, via a refined version, +! sf, of the final s-grid. The z-grid index +! coordinates of the each sf-grid level is given by zofsf, and this zofsf +! array musy have been constructed prior by a call to the make_sfgrid +! version of make_ssgrid. The index range of the z-grid is [0:nz], of the +! sf-grid it is [0:ns*nfs] and an intermediate refined version of the +! z-grid has index range, [0:nz*nfz] where nfz and nfs are both positive +! integer refinement factors to ensure that the intermediate calculations +! have only small truncation errors. +! sigofz is the z-grid sigma being interpolated (not generally the same as +! the sigma that was used to construct the sf and s grids). +! sigofs is the computed s-grid sigma obtained finally by picking every +! nfs_th value of the inetrmediate refined-grid (sf) version of the +! corresponding quantity (rescaled by the factor of nsf, though). +!============================================================================ +implicit none +integer(i_kind), intent(in ):: nz,nfz,ns,nfs +real(r_kind),dimension(0:ns*nfs),intent(in ):: zofsf +real(r_kind),dimension(0:nz), intent(in ):: sigofz +real(r_kind),dimension(0:ns), intent(out):: sigofs +!---------------------------------------------------------------------------- +real(r_kind),dimension(0:nz*nfz):: ssf +real(r_kind),dimension(0:ns*nfs):: sss,sigofsf +integer(i_kind) :: is,isf,nsf +!============================================================================ +nsf=ns*nfs +call make_ssf(nz,nfz,sigofz,ssf) +call interpftos(nz,nfz,nsf,zofsf,ssf,sss) +call sstosig(nsf,sss,sigofsf) +do is=0,ns + isf=is*nfs + sigofs(is)=sigofsf(isf)/nfs +enddo +end subroutine zsigtosfsig !============================================================================ -subroutine intftos(nz,nf,ns,zofs,ssf,sss)! [intftos] +subroutine interpftos(nz,nf,ns,zofs,ssf,sss)! [interpftos] !============================================================================ ! Linearly interpolate values ssf on the fine grid [0:nz*nf] to the ss grid ! [0:ns] whose coordinates in fine grid index units are zofs*nf, where nf @@ -163,7 +274,7 @@ subroutine intftos(nz,nf,ns,zofs,ssf,sss)! [intftos] w2=zf-izf sss(is)=w1*ssf(izf)+w2*ssf(izfp)! <- linearly interpolate enddo -end subroutine intftos +end subroutine interpftos !=========================================================================== subroutine sstosig(ns,ss,sig)! [sstosig] @@ -189,13 +300,13 @@ subroutine sstosig(ns,ss,sig)! [sstosig] sig(ns)=u1/(ss(ns)-ss(ns-1)) end subroutine sstosig -!============================================================================ -subroutine logintgrid(nz,ns,zofs,az, as)! [logintgrid] -!============================================================================ -! From a grid [0:nz] of positive values, az, use logarithms -! to ensure that the smooth interpolation to a new grid [0:ns] -! of target values, as, all remain positive. The array zofs -! defines the index z-grid coordinates of each of the s-grid points. +!=========================================================================== +subroutine intgrid(nz,ns,zofs,az, as)! [intgrid] +!=========================================================================== +! From a source grid [0:nz] of values, az, interpolate to a target grid [0:ns] +! of values as using smooth linearly-weighted quadratic (4-point) except +! near ends where 3-point quadratic is necessitated to avoid overshooting. +! Array zofs defines the index z-grid coordinates of each of the s-grid points. !============================================================================ use phint, only: wint3,whint implicit none @@ -204,280 +315,269 @@ subroutine logintgrid(nz,ns,zofs,az, as)! [logintgrid] real(r_kind),dimension(0:nz),intent(in ):: az real(r_kind),dimension(0:ns),intent(out):: as !---------------------------------------------------------------------------- -real(r_kind),dimension(0:nz):: zs,logaz +real(r_kind),dimension(0:nz):: zs real(r_kind),dimension(3) :: w3! 3-point interpolation weights (at ends) real(r_kind),dimension(4) :: w4! 4-point interpolation weights (interior) -real(r_kind) :: logas,z -integer(i_kind) :: is,iz +real(r_kind) :: z +integer(i_kind) :: is,iz,liz,miz !============================================================================ do iz=0,nz zs(iz)=iz - logaz(iz)=log(az(iz)) enddo do is=0,ns - z=zofs(is) - iz=min(nz-1,max(0,floor(z))) - if(iz==0)then - call wint3(zs(0:2),z,w3) - logas=dot_product(w3,logaz(0:2)) - elseif(iz==nz-1)then - call wint3(zs(nz-2:nz),z,w3) - logas=dot_product(w3,logaz(nz-2:nz)) + z=zofs(is); iz=min(nz-1,max(0,floor(z))) + if(iz==0) then; liz=0; miz=2 + elseif(iz==nz-1)then; liz=nz-2; miz=nz + else; liz=iz-1; miz=iz+2 + endif + if(miz==liz+2)then + call wint3(zs(liz:miz),z,w3);as(is)=dot_product(w3,az(liz:miz)) else - call whint(zs(iz-1:iz+2),z,w4) - logas=dot_product(w4,logaz(iz-1:iz+2)) + call whint(zs(liz:miz),z,w4);as(is)=dot_product(w4,az(liz:miz)) endif - as(is)=exp(logas) enddo -end subroutine logintgrid +end subroutine intgrid +!=========================================================================== +subroutine intgridw(nz,ns,lizs,mizs,ws,az,as)! [intgrid] +!=========================================================================== +implicit none +integer(i_kind), intent(in ):: nz,ns +integer(i_kind),dimension(0:ns),intent(in ):: lizs,mizs +real(r_kind),dimension(4,0:ns), intent(in ):: ws +real(r_kind),dimension(0:nz), intent(in ):: az +real(r_kind),dimension(0:ns), intent(out):: as +!--------------------------------------------------------------------------- +integer(i_kind):: is,liz,miz +!=========================================================================== +do is=0,ns + liz=lizs(is); miz=mizs(is) + if(liz+2==miz)then; as(is)=dot_product(ws(1:3,is),az(liz:miz)) + else ; as(is)=dot_product(ws(: ,is),az(liz:miz)) + endif +enddo +end subroutine intgridw -!============================================================================ -subroutine make_ssf(nz,nf,sigofz,ssf)! [make_ssf] -!============================================================================ -! Use the scales, in original [0:nz] "z-grid" units, sigofz, to define an -! effective integrated distance, ss, in these scale units, for every level -! of a refined version [0:nz*nf] of that original z grid. This is done by -! regarding each sigofz as the inverse of the derivative of ss wrt the -! z-index, and integrating the interpolated inverse of sigofz on a uniformly -! refined version [0:nz*nf] of the z grid. To avoid small or negative values -! occurring in the interpolation, it is actually the logarithm of (1/sigofz) -! (i.e., -log(sigofz) ) that we interpolate. The fine grid of values of ss -! are returned as the array ssf. -!============================================================================ -use jp_pietc, only: u1,o2 -use phint, only: wint3,whint +!=========================================================================== +subroutine wintgrid(nz,ns,zofs, lizs,mizs,ws)! [wintgrid] +!=========================================================================== +! Collect the stencil index limits lizs and mizs and the weights ws for +! smooth interpolation from the z-grid [0:nz] to the s-grid [0:ns] +!=========================================================================== + use phint, only: wint3,whint implicit none -integer(i_kind), intent(in ):: nz,nf -real(r_kind),dimension(0:nz), intent(in ):: sigofz -real(r_kind),dimension(0:nz*nf),intent(out):: ssf -!----------------------------------------------------------------------------- -real(r_kind),dimension(0:nz*nf):: zsf,logsigf -real(r_kind),dimension(0:nz) :: zs,logsig -real(r_kind),dimension(3) :: w3 -real(r_kind),dimension(4) :: w4 -real(r_kind) :: dzf,z -integer(i_kind) :: izf,izfm,iz,nzf -!============================================================================= -! Interpolate the log of the sigofz distribution to logsigf on a finer grid: -! (interpolating the logarithm avoids the possibility of negative undershoots -! of the interpolated values). +integer(i_kind), intent(in ):: nz,ns +real(r_kind),dimension(0:ns), intent(in ):: zofs +integer(i_kind),dimension(0:ns),intent(out):: lizs,mizs +real(r_kind),dimension(4,0:ns), intent(out):: ws +!--------------------------------------------------------------------------- +real(r_kind),dimension(0:nz):: zs +real(r_kind) :: z +integer(i_kind) :: is,iz,liz,miz +!=========================================================================== do iz=0,nz zs(iz)=iz - logsig(iz)=log(sigofz(iz)) -enddo -dzf=u1/nf -nzf=nz*nf -do izf=0,nzf - zsf(izf)=izf*dzf enddo - -do izf=0,nzf - z=zsf(izf) - iz=min(nz-1,max(0,floor(z))) - if(iz==0)then - call wint3(zs(0:2),z,w3) - logsigf(izf)=dot_product(w3,logsig(0:2)) - elseif(iz==nz-1)then - call wint3(zs(nz-2:nz),z,w3) - logsigf(izf)=dot_product(w3,logsig(nz-2:nz)) - else - call whint(zs(iz-1:iz+2),z,w4) - logsigf(izf)=dot_product(w4,logsig(iz-1:iz+2)) +do is=0,ns + z=zofs(is); iz=min(nz-1,max(0,floor(z))) + if(iz==0) then; liz=0; miz=2 + elseif(iz==nz-1)then; liz=nz-2; miz=nz + else; liz=iz-1; miz=iz+2 + endif + if(miz==liz+2)then; call wint3(zs(liz:miz),z,ws(1:3,is)); ws(4,is)=0 + else; call whint(zs(liz:miz),z,ws(:,is)) endif + lizs(is)=liz + mizs(is)=miz enddo +end subroutine wintgrid -! Integrate exp(-logsigf), which approximates 1/sigofz, on the fine grid, -! to get ssf: -ssf(0)=0 -do izf=1,nzf - izfm=izf-1 - ssf(izf)=ssf(izfm)+exp(-(logsigf(izfm)+logsigf(izf))*o2)*dzf -enddo -end subroutine make_ssf - - - -subroutine intgrid(nz,ns,zofs,az, as)! [logintgrid] -!clt modified from logintgrid, but don't do the log transformation -!============================================================================ +!=========================================================================== +subroutine logintgrid(nz,ns,zofs,az, as)! [logintgrid] +!=========================================================================== ! From a grid [0:nz] of positive values, az, use logarithms ! to ensure that the smooth interpolation to a new grid [0:ns] ! of target values, as, all remain positive. The array zofs ! defines the index z-grid coordinates of each of the s-grid points. !============================================================================ +use phint, only: wint3,whint implicit none integer(i_kind), intent(in ):: nz,ns real(r_kind),dimension(0:ns),intent(in ):: zofs real(r_kind),dimension(0:nz),intent(in ):: az real(r_kind),dimension(0:ns),intent(out):: as !---------------------------------------------------------------------------- -real(r_kind),dimension(0:nz):: zs,logaz -real(r_kind),dimension(3) :: w3! 3-point interpolation weights (at ends) -real(r_kind),dimension(4) :: w4! 4-point interpolation weights (interior) -real(r_kind) :: z -integer(i_kind) :: is,iz +real(r_kind),dimension(0:nz):: logaz !============================================================================ -do iz=0,nz - zs(iz)=iz -enddo -do is=0,ns - z=zofs(is) - iz=min(nz-1,max(0,floor(z))) - if(iz==0)then - call wint3(zs(0:2),z,w3) - as=dot_product(w3,az(0:2)) - elseif(iz==nz-1)then - call wint3(zs(nz-2:nz),z,w3) - as=dot_product(w3,az(nz-2:nz)) - else - call whint(zs(iz-1:iz+2),z,w4) - as=dot_product(w4,az(iz-1:iz+2)) - endif -enddo -end subroutine intgrid -subroutine intgrid_ad(nz, ns, zofs, az_ad, as_ad) -!--------------------------------------------------------------------- -! Adjoint of intgrid: propagate adjoint variables from as_ad to az_ad -!--------------------------------------------------------------------- +logaz=log(az) +call intgrid(nz,ns,zofs,logaz, as) +as=exp(as) +end subroutine logintgrid +!=========================================================================== +subroutine logintgridw(nz,ns,lizs,mizs,ws,az, as)! [logintgrid] +!=========================================================================== +! From a grid [0:nz] of positive values, az, use logarithms +! to ensure that the smooth interpolation to a new grid [0:ns] +! of target values, as, all remain positive. The interpolation parameters +! are supplied in the arrays of stencil index limits, lizs, mizs, and +! associated interpolation weights, ws. +!============================================================================ +use phint, only: wint3,whint implicit none -integer(i_kind), intent(in) :: nz, ns -real(r_kind), dimension(0:ns),intent(in) :: zofs -real(r_kind), dimension(0:nz),intent(inout):: az_ad ! inout for accumulation -real(r_kind), dimension(0:ns),intent(in) :: as_ad - -! local variables -real(r_kind), dimension(0:nz) :: zs -real(r_kind), dimension(3) :: w3 -real(r_kind), dimension(4) :: w4 -real(r_kind) :: z -integer(i_kind) :: is, iz - -!------------------------------------------------------------- -! Build zs same as in forward -do iz = 0, nz - zs(iz) = iz -enddo - -! Initialize az_ad if needed -! az_ad = 0.0_dp ! if not already initialized outside - -do is = 0, ns - z = zofs(is) - iz = min(nz - 1, max(0, floor(z))) - - if (iz == 0) then - call wint3(zs(0:2), z, w3) - az_ad(0:2) = az_ad(0:2) + as_ad(is) * w3 - elseif (iz == nz - 1) then - call wint3(zs(nz-2:nz), z, w3) - az_ad(nz-2:nz) = az_ad(nz-2:nz) + as_ad(is) * w3 - else - call whint(zs(iz-1:iz+2), z, w4) - az_ad(iz-1:iz+2) = az_ad(iz-1:iz+2) + as_ad(is) * w4 - endif -enddo +integer(i_kind), intent(in ):: nz,ns +integer(i_kind),dimension(0:ns),intent(in ):: lizs,mizs +real(r_kind), dimension(4,0:ns),intent(in ):: ws +real(r_kind),dimension(0:nz), intent(in ):: az +real(r_kind),dimension(0:ns), intent(out):: as +!---------------------------------------------------------------------------- +real(r_kind),dimension(0:nz):: logaz +!============================================================================ +logaz=log(az) +call intgridw(nz,ns,lizs,mizs,ws,logaz, as) +as=exp(as) +end subroutine logintgridw -end subroutine intgrid_ad -subroutine intgrid_f2a(nz, ns, zofs, as, az) -!------------------------------------------------------------------------------- -! This routine interpolates from reduced-resolution `as` to high-resolution `az`, -! using the same stencil logic as in the original `intgrid` routine. -! -! Input: -! - as(0:ns) : values on coarse grid (positions given by zofs) -! - zofs(0:ns): coarse grid index positions (e.g., fractional positions in fine grid) -! -! Output: -! - az(0:nz) : interpolated values on full fine grid -!------------------------------------------------------------------------------- +!============================================================================ +subroutine sofztozofs_f(nz,nfz,ns,sofz,s0,ds,zofs)! [sofztoztos] +!============================================================================ +! From monotonic profile sofz, use smooth interpolation and a z-grid +! refined by a factor of nfz, to derive the inverse monotonic profile +! zofs of the index-coordinate of z in a grid that uniformly resolves +! the range of s. The s grid starts at s=s0 (at index is =0) and +! increases by increments ds. +!============================================================================ implicit none - -integer(i_kind), intent(in) :: nz, ns -real(r_kind), dimension(0:ns),intent(in) :: zofs -real(r_kind), dimension(0:ns),intent(in) :: as -real(r_kind), dimension(0:nz),intent(out) :: az - -! Local variables -real(r_kind), dimension(3) :: w3 -real(r_kind), dimension(4) :: w4 -real(r_kind) :: z -integer(i_kind) :: iz, is - -!------------------------------------------------------------------------------- -! Loop over fine grid points and interpolate from coarse `as` at `zofs` - -do iz = 0, nz - z = real(iz, r_kind) ! The fine grid point we want to interpolate - - ! Search for the coarse grid interval that contains z - is = 0 - do while (is < ns-1 .and. zofs(is+1) < z) - is = is + 1 - end do - - ! Boundary handling - if (is <= 1) then - call wint3(zofs(0:2), z, w3) - az(iz) = dot_product(w3, as(0:2)) - elseif (is >= ns-1) then - call wint3(zofs(ns-2:ns), z, w3) - az(iz) = dot_product(w3, as(ns-2:ns)) - else - call whint(zofs(is-1:is+2), z, w4) - az(iz) = dot_product(w4, as(is-1:is+2)) - end if -end do - -end subroutine intgrid_f2a -subroutine intgrid_f2a_ad(nz, ns, zofs, az_ad, as_ad) -!------------------------------------------------------------------------------- -! Adjoint of intgrid_synthesis. -! Accumulates contributions from fine-grid adjoint az_ad into coarse-grid adjoint as_ad -! -! Input: -! - az_ad(0:nz) : adjoint values on fine grid -! - zofs(0:ns) : coarse grid locations (same as in forward) -! -! Output: -! - as_ad(0:ns) : adjoint values on coarse grid (to be accumulated) -!------------------------------------------------------------------------------- +integer(i_kind) ,intent(in ):: nz,nfz,ns +real(r_kind),dimension(0:nz),intent(in ):: sofz +real(r_kind), intent(out):: s0,ds +real(r_kind),dimension(0:ns),intent(out):: zofs +!--------------------------------------------------------------------------- +real(r_kind),dimension(0:nz*nfz):: sofzf +integer(i_kind) :: nzf +!============================================================================ +nzf=nz*nfz +call monotonicrefine(nz,nfz,sofz,sofzf) +call sofztozofs(nzf,ns,sofzf, s0,ds,zofs) +zofs=zofs/nfz +end subroutine sofztozofs_f +!============================================================================ +subroutine sofztozofs(nz,ns,sofzu, s0,ds,zofs)! [sofztozofs] +!============================================================================ +! Given a monotonic profile, sofzu, on the z-grid [0:nz], and assuming +! piecewise linearity in each interval, get the reciprocal relationship, +! a profile of z index coordinates zofs at each of a uniform grid [0:ns] of +! the s spanning the range sofzu(0):sofzu(nz), and return s0=sofzu(0) +! and the s-grid interval ds=(sofzu(nz)-s0)/ns. +!============================================================================ implicit none +integer(i_kind), intent(in ):: nz,ns +real(r_kind),dimension(0:nz),intent(in ):: sofzu +real(r_kind), intent(out):: s0,ds +real(r_kind),dimension(0:ns),intent(out):: zofs +!---------------------------------------------------------------------------- +real(r_kind),dimension(0:nz):: sofz +real(r_kind) :: s +integer(i_kind) :: iz,izp,is,jzp +!============================================================================ +s0=sofzu(0); ds=(sofzu(nz)-s0)/ns +sofz=(sofzu-s0)/ds +zofs(0)=0 +zofs(ns)=nz +jzp=1 +do is=1,ns-1 + s=is + ! Search izp=iz+1 that ensures s belongs in interval sofz[iz,izp] + do izp=jzp,nz-1 + if(sofz(izp)>=s)exit + enddo + jzp=izp; iz=izp-1 + zofs(is)=iz+(s-sofz(iz))/(sofz(izp)-sofz(iz))! <- Linear interpolation +enddo +end subroutine sofztozofs -integer(i_kind), intent(in) :: nz, ns -real(r_kind), dimension(0:ns), intent(in) :: zofs -real(r_kind), dimension(0:nz), intent(in) :: az_ad -real(r_kind), dimension(0:ns), intent(inout) :: as_ad ! inout to allow accumulation - -! Local -real(r_kind), dimension(3) :: w3 -real(r_kind), dimension(4) :: w4 -real(r_kind) :: z -integer(i_kind) :: iz, is - -!------------------------------------------------------------------------------- -do iz = 0, nz - z = real(iz, r_kind) - - ! Find interpolation interval (same logic as in synthesis) - is = 0 - do while (is < ns-1 .and. zofs(is+1) < z) - is = is + 1 - end do - - ! Accumulate az_ad(iz) into as_ad via adjoint of interpolation - if (is <= 1) then - call wint3(zofs(0:2), z, w3) - as_ad(0:2) = as_ad(0:2) + az_ad(iz) * w3 - elseif (is >= ns-1) then - call wint3(zofs(ns-2:ns), z, w3) - as_ad(ns-2:ns) = as_ad(ns-2:ns) + az_ad(iz) * w3 - else - call whint(zofs(is-1:is+2), z, w4) - as_ad(is-1:is+2) = as_ad(is-1:is+2) + az_ad(iz) * w4 - end if -end do - -end subroutine intgrid_f2a_ad +!============================================================================ +subroutine monotonicrefine(nz,nfz,sofz,sofzf)! [monotonicrefine] +!============================================================================ +! Refine the monotonic gridded values sofz from z-grid [0:nz] to a +! uniformly refined zf-grid [0:nzf], nzf=nz*nfz. The method involves +! iterative interpolations and corrections of logarithms of finite +! differences, and the numerical integration of the exponentials +! of the interpolated values in such a way that non-positive amounts +! in the integration are not possible, thus preserving monotonicity. +! The nonlinearity of exponentials and logarithms necessitates the +! iterations. Once a convergence criterion, slightly larger than +! typical roundoff, is attained, we continue to allow a few +! additional iterations to let the final result get closer to its +! own characteristic round-off limit. +!============================================================================ +use jp_pietc, only: u1,o2 +implicit none +integer(i_kind), intent(in ):: nz,nfz +real(r_kind),dimension(0:nz), intent(in ):: sofz +real(r_kind),dimension(0:nz*nfz),intent(out):: sofzf +!---------------------------------------------------------------------------- +integer(i_kind),parameter :: nit=100 +real(r_kind),parameter :: eps=1.e-12 +real(r_kind),dimension(nz) :: dsdz,dsdzt,ldsdz,ldsdzt +real(r_kind),dimension(4,nz*nfz) :: wzf +real(r_kind),dimension(nz*nfz) :: zofzf,dsdzf,ldsdzf +real(r_kind) :: dzf,norm,r +integer(i_kind),dimension(nz*nfz):: lizzf,mizzf +integer(i_kind) :: iz,izm,izf,it,nzm,nzf,nzfm,lizf,mizf,mit +!============================================================================ +nzm=nz-1; nzf=nz*nfz; nzfm=nzf-1 +dzf=u1/nfz! <- interval of uniform fine grid zf +! Set up fine staggered z-grid: +do izf=1,nzf + zofzf(izf)=dzf*(izf-o2)-o2 +enddo +! Set up weights and index parameters for interpolation to zofzf targets: +call wintgrid(nzm,nzfm,zofzf, lizzf,mizzf,wzf) +! compute coarse finite difference dsdz on staggered grid and take its log: +do iz=1,nz + dsdz(iz)=sofz(iz)-sofz(iz-1) + ldsdz(iz)=log(dsdz(iz)) +enddo +ldsdzt=0 +! Iterative adjust an approximation ldsdzt of staggered log(dsdz) such that, +! when interpolated to a finer grid, exponentiated, and intergated in +! each successive coarse interval, it reproduces the staggered dsdz +! (if possible) +mit=nit+1 +do it=1,nit ! Iterate up to nit times, but exit early if possible + +! Increment profile ldsdzt by ldsdz to improve match of next dsdzt to dsdz: + do iz=1,nz + ldsdzt(iz)=ldsdzt(iz)+ldsdz(iz) + enddo + + ! Interpolate ldsdzt to a staggered refined grid: + call intgrid(nzm,nzfm,lizzf,mizzf,wzf,ldsdzt,ldsdzf) + dsdzf=exp(ldsdzf)! <-get corresponding dsdzf by taking the exponential + + ! integrate to get dsdzt in each is interval for comparison with dsdz: + do iz=1,nz + mizf=iz*nfz; lizf=mizf-nfz+1 + dsdzt(iz)=dzf*sum(dsdzf(lizf:mizf)) + ldsdz(iz)=log(dsdz(iz)/dsdzt(iz)) + enddo + norm=sum(abs(ldsdz))/nz + if(norm=mit)exit ! <- Full convergence presumed achieved at this point +enddo! it + +! Integrate dsdzf on the fine grid to get monotonic sofzf consitent with +! the original coarse grid sofz +do iz=1,nz + izm=iz-1 + r=dzf*dsdz(iz)/dsdzt(iz)! <- r approximates dzf if convergence succeeded. + sofzf(izm*nfz)=sofz(izm)! <- Match fine grid sofzf to coarse grid sofz + ! Integrate fine-grid dsdzf across the interior of coarse interval iz: + do izf=izm*nfz+1,iz*nfz-1 + sofzf(izf)=sofzf(izf-1)+r*dsdzf(izf) + enddo +enddo +sofzf(nzf)=sofz(nz)! <- Match last fine grid sofzf to last coarse grid sofz +end subroutine monotonicrefine subroutine intgrid_f2a_3d(nz, ns, nx, ny, zofs, az,as) !------------------------------------------------------------------------------ ! Interpolates in vertical (first) dimension using zofs(0:ns,nx,ny) @@ -840,11 +940,6 @@ subroutine intgrid_f2a_3d_ad_top2bot(nz, ns, nx, ny, zofs, az, as) end subroutine intgrid_f2a_3d_ad_top2bot - - - - - - end module phint1 !# + From 57e336d0c01b8164d9a45a319a3fbcbeeba93cc6 Mon Sep 17 00:00:00 2001 From: Masanori-NOAA Date: Tue, 19 Aug 2025 15:38:33 -0500 Subject: [PATCH 055/199] To use GSIbec for regional FV3-JEDI --- .../gsi/covariance/gsi_covariance_mod.f90 | 3 +- src/saber/gsi/grid/gsi_grid_mod.f90 | 39 +++++++--- src/saber/interpolation/Geometry.cc | 74 +++++++++++++++++-- 3 files changed, 97 insertions(+), 19 deletions(-) diff --git a/src/saber/gsi/covariance/gsi_covariance_mod.f90 b/src/saber/gsi/covariance/gsi_covariance_mod.f90 index fd3504443..f86f97531 100644 --- a/src/saber/gsi/covariance/gsi_covariance_mod.f90 +++ b/src/saber/gsi/covariance/gsi_covariance_mod.f90 @@ -129,7 +129,7 @@ subroutine create(self, comm, config, ntimes, background, firstguess, valid_time ! Sanity-check the GSI grid (specified from gsibec namelists) matches SABER grid (from JEDI yaml) ! ----------------------------------------------------------------------------------------------- -if (nchecks .gt. 0) then ! only run checks if data was passed in from JEDI +if (nchecks .gt. 0 .and. .not. self%grid%regional) then ! only run checks if data was passed in from JEDI gsi_jedi_grid_error = .false. gsi_nx = self%grid%iec - self%grid%isc + 1 jedi_nx = nint(checks(1)) @@ -600,7 +600,6 @@ subroutine multiply(self, ntimes, fields) call abor1_ftn(myname_//": missing fields in cv(tlm) ") endif - ! Release pointer ! --------------- if (self%cv) then diff --git a/src/saber/gsi/grid/gsi_grid_mod.f90 b/src/saber/gsi/grid/gsi_grid_mod.f90 index 2d1cc5a52..323d01de7 100644 --- a/src/saber/gsi/grid/gsi_grid_mod.f90 +++ b/src/saber/gsi/grid/gsi_grid_mod.f90 @@ -42,9 +42,11 @@ module gsi_grid_mod logical :: vflip ! Flip vertical grid (gsi k=1=top) logical :: noGSI real(kind=kind_real), allocatable :: lats(:), lons(:) + real(kind=kind_real), allocatable :: lats2(:,:), lons2(:,:) real(kind=kind_real), allocatable :: grid_lats(:,:), grid_lons(:,:) integer :: ngrid ! Number of grid points for each processor logical :: debug + logical :: regional contains procedure, public :: create procedure, public :: delete @@ -116,12 +118,21 @@ subroutine create(self, conf, comm) if(.not.allocated(self%grid_lons)) allocate(self%grid_lons(self%isc:self%iec, self%jsc:self%jec)) if(.not.allocated(self%grid_lats)) allocate(self%grid_lats(self%isc:self%iec, self%jsc:self%jec)) -do i = self%isc, self%iec - self%grid_lons(i,:) = self%lons(i) -enddo -do j = self%jsc, self%jec - self%grid_lats(:,j) = self%lats(j) -enddo +if(self%regional) then + do i = self%isc, self%iec + do j = self%jsc, self%jec + self%grid_lons(i,j) = self%lons2(i,j) + self%grid_lats(i,j) = self%lats2(i,j) + enddo + enddo +else + do i = self%isc, self%iec + self%grid_lons(i,:) = self%lons(i) + enddo + do j = self%jsc, self%jec + self%grid_lats(:,j) = self%lats(j) + enddo +endif if ( self%debug ) then if(self%comm%rank() == 0) then @@ -157,6 +168,7 @@ subroutine wGSI ! ---------------------------------------------- call conf%get_or_die("gsi berror namelist file", nml) call conf%get_or_die("gsi akbk", vgrdfn) + if(nml=='gsiparm_regional.anl') self%regional = .true. ! Initialize GSIbec grid ! ---------------------- @@ -167,12 +179,21 @@ subroutine wGSI ! Allocate the lat/lon arrays ! --------------------------- - if(.not.allocated(self%lons)) allocate(self%lons(self%npx)) - if(.not.allocated(self%lats)) allocate(self%lats(self%npy)) + if(self%regional) then + if(.not.allocated(self%lons2)) allocate(self%lons2(self%npx,self%npy)) + if(.not.allocated(self%lats2)) allocate(self%lats2(self%npx,self%npy)) + else + if(.not.allocated(self%lons)) allocate(self%lons(self%npx)) + if(.not.allocated(self%lats)) allocate(self%lats(self%npy)) + endif ! Read the latitudes and longitudes per GSIbec ! -------------------------------------------- - call gsibec_get_grid (eqspace,'degree',self%lats,self%lons) + if(self%regional) then + call gsibec_get_grid ('degree',self%lats2,self%lons2) + else + call gsibec_get_grid (eqspace,'degree',self%lats,self%lons) + endif call gsibec_set_grid (comm%rank(),vgrdfn) ! If debugging, read the latitude and longitude from file diff --git a/src/saber/interpolation/Geometry.cc b/src/saber/interpolation/Geometry.cc index 37c765e13..dafc0ec3c 100644 --- a/src/saber/interpolation/Geometry.cc +++ b/src/saber/interpolation/Geometry.cc @@ -75,15 +75,25 @@ std::vector computeS2NCheckerboardPartition(const atlas::RegularGrid & rg, return partition; } +constexpr double deg2rad(double deg) { return deg * M_PI / 180.0; } +constexpr double rad2deg(double rad) { return rad * 180.0 / M_PI; } + void setupGsiMatchingGrid(const eckit::Configuration & config, const eckit::mpi::Comm & comm, atlas::Grid & grid, atlas::FunctionSpace & functionSpace, atlas::FieldSet & fieldSet) { const std::string grid_type = config.getString(GsiGridKey + ".type"); - ASSERT(grid_type == "gaussian" || grid_type == "latlon"); + ASSERT(grid_type == "gaussian" || grid_type == "latlon" || grid_type == "rotated_lonlat"); const int nlats = config.getInt(GsiGridKey + ".lats"); // pole to pole const int nlons = config.getInt(GsiGridKey + ".lons"); + const double lat_start = config.has(GsiGridKey + ".lat_start") ? config.getDouble(GsiGridKey + ".lat_start") : 0.0; + const double lat_end = config.has(GsiGridKey + ".lat_end") ? config.getDouble(GsiGridKey + ".lat_end") : 0.0; + const double lon_start = config.has(GsiGridKey + ".lon_start") ? config.getDouble(GsiGridKey + ".lon_start") : 0.0; + const double lon_end = config.has(GsiGridKey + ".lon_end") ? config.getDouble(GsiGridKey + ".lon_end") : 0.0; + const double north_pole_lat = config.has(GsiGridKey + ".north_pole_lat") ? config.getDouble(GsiGridKey + ".north_pole_lat") : 0.0; + const double north_pole_lon = config.has(GsiGridKey + ".north_pole_lon") ? config.getDouble(GsiGridKey + ".north_pole_lon") : 0.0; + const auto gsi_gaussian_points = [](const int N) -> std::vector { ASSERT(N % 2 == 0); // code below would need verification, probably fixing, in odd case @@ -99,18 +109,30 @@ void setupGsiMatchingGrid(const eckit::Configuration & config, return result; }; - const auto build_xspace_config = [&]() -> eckit::LocalConfiguration { + const auto build_xspace_config = [&](const std::string & grid_type) -> eckit::LocalConfiguration { eckit::LocalConfiguration lc{}; - lc.set("type", "linear"); - lc.set("N", nlons); - lc.set("interval", std::vector{{0.0, 360.0}}); - lc.set("endpoint", false); + if (grid_type == "rotated_lonlat") { + lc.set("type", "linear"); + lc.set("N", nlons); + lc.set("start", lon_start); + lc.set("end", lon_end); + } else { + lc.set("type", "linear"); + lc.set("N", nlons); + lc.set("interval", std::vector{{0.0, 360.0}}); + lc.set("endpoint", false); + } return lc; }; const auto build_yspace_config = [&](const std::string & grid_type) -> eckit::LocalConfiguration { eckit::LocalConfiguration lc{}; - if (grid_type == "gaussian") { + if (grid_type == "rotated_lonlat") { + lc.set("type", "linear"); + lc.set("N", nlats); + lc.set("start", lat_start); + lc.set("end", lat_end); + } else if (grid_type == "gaussian") { lc.set("type", "custom"); lc.set("N", nlats); lc.set("values", gsi_gaussian_points(nlats)); @@ -122,10 +144,18 @@ void setupGsiMatchingGrid(const eckit::Configuration & config, return lc; }; + const auto build_projection_config = [&](const std::string & grid_type) -> eckit::LocalConfiguration { + eckit::LocalConfiguration lc{}; + lc.set("type", "rotated_lonlat"); + lc.set("north_pole", std::vector{{north_pole_lon, north_pole_lat}}); + return lc; + }; + eckit::LocalConfiguration testconfig{}; testconfig.set("type", "structured"); - testconfig.set("xspace", build_xspace_config()); + testconfig.set("xspace", build_xspace_config(grid_type)); testconfig.set("yspace", build_yspace_config(grid_type)); + if (grid_type == "rotated_lonlat") testconfig.set("projection", build_projection_config(grid_type)); grid = atlas::Grid{testconfig}; const atlas::RegularGrid rg{grid}; @@ -141,6 +171,34 @@ void setupGsiMatchingGrid(const eckit::Configuration & config, functionSpace = atlas::functionspace::StructuredColumns(grid, distribution, atlas::option::halo(halo)); + // Get rotated_lonlat on the Earth coordinate + if (grid_type == "rotated_lonlat") { + atlas::Field lonlatField = functionSpace.lonlat(); + auto lonlatView = atlas::array::make_view(lonlatField); + for (int j = 0; j < lonlatView.shape(0); ++j) { + double rlon = lonlatView(j, 0); + double rlat = lonlatView(j, 1); + double rlon0 = north_pole_lon - 180.0; + double rlat0 = north_pole_lat - 90.0; + + double xtt = std::cos(deg2rad(rlat)) * std::cos(deg2rad(rlon)); + double ytt = std::cos(deg2rad(rlat)) * std::sin(deg2rad(rlon)); + double ztt = std::sin(deg2rad(rlat)); + + double xt = xtt*std::cos(deg2rad(rlat0)) - ztt*std::sin(deg2rad(rlat0)); + double yt = ytt; + double zt = xtt*std::sin(deg2rad(rlat0)) + ztt*std::cos(deg2rad(rlat0)); + + double x = xt*std::cos(deg2rad(rlon0)) - yt*std::sin(deg2rad(rlon0)); + double y = xt*std::sin(deg2rad(rlon0)) + yt*std::cos(deg2rad(rlon0)); + double z = zt; + + lonlatView(j, 0) = rad2deg(std::atan2(y,x)); + lonlatView(j, 1) = rad2deg(std::asin(z)); + } + lonlatField.set_dirty(); + } + // Using atlas::mpi::Scope in the call to atlas::functionspace::StructuredColumns // may have reverted the default communicator to the world communicator. // We set back the default communicator to `comm` to fix this. From fdfaad004d58ef8c16a63a338a3f43e627a9b4ba Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 21 Aug 2025 15:49:31 +0000 Subject: [PATCH 056/199] reduced the final multivariabe calculation when nvargrp==1 --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 38 +++++++++++++------ 1 file changed, 26 insertions(+), 12 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index aec0da7c1..d0e4571a3 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -515,21 +515,35 @@ subroutine multiply(self, fields,index_member_in) work_mgbf=work_mgbf2 else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - do jvar=1,nvar + if(nvargrp == 1 ) then work1var_mgbf=0.0 - jvargrp=self%ivar2grp(jvar) - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - ivargrp=self%ivar2grp(ivar) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) + enddo + do jvar=1,nvar + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf enddo - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - deallocate(work1var_mgbf) + else + do jvar=1,nvar + work1var_mgbf=0.0 + jvargrp=self%ivar2grp(jvar) + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + ivargrp=self%ivar2grp(ivar) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) + enddo + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + endif endif + deallocate(work1var_mgbf) do k=1,nzloc work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) enddo From 326684dc733076b314f7539529d74415da4280f5 Mon Sep 17 00:00:00 2001 From: Masanori-NOAA Date: Thu, 21 Aug 2025 11:44:03 -0500 Subject: [PATCH 057/199] Grid check for regional grids --- .../gsi/covariance/gsi_covariance_mod.f90 | 19 ++++++++++++++----- src/saber/gsi/utils/GridCheckHelper.cc | 2 +- 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/src/saber/gsi/covariance/gsi_covariance_mod.f90 b/src/saber/gsi/covariance/gsi_covariance_mod.f90 index f86f97531..2a59848ff 100644 --- a/src/saber/gsi/covariance/gsi_covariance_mod.f90 +++ b/src/saber/gsi/covariance/gsi_covariance_mod.f90 @@ -129,7 +129,7 @@ subroutine create(self, comm, config, ntimes, background, firstguess, valid_time ! Sanity-check the GSI grid (specified from gsibec namelists) matches SABER grid (from JEDI yaml) ! ----------------------------------------------------------------------------------------------- -if (nchecks .gt. 0 .and. .not. self%grid%regional) then ! only run checks if data was passed in from JEDI +if (nchecks .gt. 0) then ! only run checks if data was passed in from JEDI gsi_jedi_grid_error = .false. gsi_nx = self%grid%iec - self%grid%isc + 1 jedi_nx = nint(checks(1)) @@ -146,18 +146,27 @@ subroutine create(self, comm, config, ntimes, background, firstguess, valid_time endif do ix = 1, gsi_nx - gsi_lon = self%grid%lons(self%grid%isc-1 + ix) + if(self%grid%regional) then + gsi_lon = self%grid%lons2(self%grid%isc-1 + ix,self%grid%jsc) + else + gsi_lon = self%grid%lons(self%grid%isc-1 + ix) + endif jedi_lon = checks(2+ix) - if (abs(gsi_lon - jedi_lon) > 1e-8) then + if(jedi_lon .lt. 0.) jedi_lon = jedi_lon + 360. + if (abs(gsi_lon - jedi_lon) > 1e-6) then write (*,*) 'ERROR connecting GSI-block to JEDI -- inconsistent lon with gsi, atlas = ', gsi_lon, jedi_lon gsi_jedi_grid_error = .true. endif enddo do iy = 1, gsi_ny - gsi_lat = self%grid%lats(self%grid%jsc-1 + iy) + if(self%grid%regional) then + gsi_lat = self%grid%lats2(self%grid%iec,self%grid%jsc-1 + iy) + else + gsi_lat = self%grid%lats(self%grid%jsc-1 + iy) + endif jedi_lat = checks(2+gsi_nx+iy) - if (abs(gsi_lat - jedi_lat) > 1e-8) then + if (abs(gsi_lat - jedi_lat) > 1e-6) then write (*,*) 'ERROR connecting GSI-block to JEDI -- inconsistent lat with gsi, atlas = ', gsi_lat, jedi_lat gsi_jedi_grid_error = .true. endif diff --git a/src/saber/gsi/utils/GridCheckHelper.cc b/src/saber/gsi/utils/GridCheckHelper.cc index 819b38685..19af45ed6 100644 --- a/src/saber/gsi/utils/GridCheckHelper.cc +++ b/src/saber/gsi/utils/GridCheckHelper.cc @@ -39,7 +39,7 @@ std::vector functionspaceToGridChecks(const atlas::FunctionSpace & fspac gridChecks[2 + (i - ib)] = lonlatView(index, 0); } for (int j = jb; j < je; ++j) { - const int index = sc.index(ie, j); + const int index = sc.index(ie-1, j); gridChecks[2 + nx + (j - jb)] = lonlatView(index, 1); } } else { From 8f8f603aa0fd6c2133eb7ca904c4cde98ef4b120 Mon Sep 17 00:00:00 2001 From: Masanori-NOAA Date: Thu, 21 Aug 2025 11:47:47 -0500 Subject: [PATCH 058/199] Adding optional yaml parameter --- src/saber/gsi/grid/gsi_grid_mod.f90 | 8 +++++++- src/saber/gsi/utils/GSIParameters.h | 3 +++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/src/saber/gsi/grid/gsi_grid_mod.f90 b/src/saber/gsi/grid/gsi_grid_mod.f90 index 323d01de7..a7ad35c86 100644 --- a/src/saber/gsi/grid/gsi_grid_mod.f90 +++ b/src/saber/gsi/grid/gsi_grid_mod.f90 @@ -84,6 +84,13 @@ subroutine create(self, conf, comm) call conf%get_or_die("debugging mode", self%debug) call conf%get_or_die("debugging bypass gsi", self%noGSI) +! Regional mode +! ------------- +self%regional = .false. +if (conf%has("regional mode")) then + call conf%get_or_die("regional mode", self%regional) +end if + ! Domain decomposition ! -------------------- if (conf%has("processor layout x direction").and.conf%has("processor layout y direction")) then @@ -168,7 +175,6 @@ subroutine wGSI ! ---------------------------------------------- call conf%get_or_die("gsi berror namelist file", nml) call conf%get_or_die("gsi akbk", vgrdfn) - if(nml=='gsiparm_regional.anl') self%regional = .true. ! Initialize GSIbec grid ! ---------------------- diff --git a/src/saber/gsi/utils/GSIParameters.h b/src/saber/gsi/utils/GSIParameters.h index f2b843dbe..5b4fde15f 100644 --- a/src/saber/gsi/utils/GSIParameters.h +++ b/src/saber/gsi/utils/GSIParameters.h @@ -42,6 +42,9 @@ class GSIParameters : public oops::Parameters { oops::Parameter debugMode{"debugging mode", false, this}; oops::Parameter bypassGSI{"debugging bypass gsi", false, this}; oops::Parameter bypassGSIbe{"debugging deep bypass gsi B error", false, this}; + + // Regional mode + oops::OptionalParameter regionalMode{"regional mode", this}; }; // ----------------------------------------------------------------------------- From 944c59287b6a42ead7cca36eed6ab49aecdcf006 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 25 Aug 2025 21:13:56 +0000 Subject: [PATCH 059/199] added the treatment when /ensemble member index/ is not present in fset --- src/saber/mgbf/covariance/MGBF_Covariance.h | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index e564a5ed8..9580fda4e 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -203,7 +203,14 @@ void MGBF_Covariance::randomize(oops::FieldSet3D & fset) const { void MGBF_Covariance::multiply(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiply starting" << std::endl; util::Timer timer(classname(), "multiply"); - int index_member=fset.fieldSet().metadata().get("ensemble member index"); + int index_member; + if (fset.fieldSet().metadata().has("ensemble member index")){ + index_member=fset.fieldSet().metadata().get("ensemble member index"); + } + else { + index_member=9999; + } + oops::Log::trace()<<"thinkdeb999 sdl multiply index_member "< Date: Tue, 26 Aug 2025 14:42:33 +0000 Subject: [PATCH 060/199] a fix for deallocating un-allocated array mgbf_covariance_mod.f90 --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 2 +- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index d0e4571a3..96ab7cd8f 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -542,8 +542,8 @@ subroutine multiply(self, fields,index_member_in) work_mgbf(lev1:lev2,:,:)=work1var_mgbf enddo endif + deallocate(work1var_mgbf) endif - deallocate(work1var_mgbf) do k=1,nzloc work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) enddo diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 29cee9aea..f6d6319b2 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -621,8 +621,8 @@ subroutine init_mg_parameter(this,inputfilename) this%nxm = nxPE this%nym = nyPE - this%im = im_filt - this%jm = jm_filt + this%im = im_filt + this%jm = jm_filt !----------------------------------------------------------------- ! From bdfee2625a225d8dac85e2c996a51ecaff96b3b6 Mon Sep 17 00:00:00 2001 From: Evan Parker Date: Thu, 28 Aug 2025 15:28:08 -0600 Subject: [PATCH 061/199] add jedi-ci action (#1090) Add jedi-ci action Parent issue: JCSDA-internal/jedi-ci#16 Admin merge justification: JCSDA-internal/jedi-ci#17 --- .github/workflows/start-jedi-ci.yaml | 49 ++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) create mode 100644 .github/workflows/start-jedi-ci.yaml diff --git a/.github/workflows/start-jedi-ci.yaml b/.github/workflows/start-jedi-ci.yaml new file mode 100644 index 000000000..8e5e710e5 --- /dev/null +++ b/.github/workflows/start-jedi-ci.yaml @@ -0,0 +1,49 @@ +name: start-jedi-ci + +on: + pull_request: + branches: + - 'master' + - 'main' + - 'develop' + +jobs: + launch-tests: + runs-on: ubuntu-latest + permissions: + id-token: write + contents: read + steps: + + - name: Generate CI App token + id: generate-token + uses: actions/create-github-app-token@v1 + with: + # Owner is specified to scope the token to the org install + # otherwise the token will be scoped to the repository. + app-id: 321361 + private-key: ${{ secrets.CI_APP_PRIVATE_KEY }} + owner: ${{ github.repository_owner }} + + - name: checkout repository + uses: actions/checkout@v4 + with: + path: target_repository + + - name: Configure AWS credentials + uses: aws-actions/configure-aws-credentials@v4 + with: + # This role only has the permission to write to our lfs archive s3 bucket path. + role-to-assume: arn:aws:iam::747101682576:role/service-role/jedi-ci-action-runner-backend-GitHubActionsIAMRole-HkHdJRVEFw3x + aws-region: us-east-2 + + - name: Run JEDI CI + uses: JCSDA-internal/jedi-ci@develop + with: + container_version: 'latest' + unittest_tag: 'vader' + unittest_dependencies: oops vader + test_script: run_tests.sh + target_repo_dir: target_repository + bundle_branch: develop + jedi_ci_token: ${{ steps.generate-token.outputs.token }} From 307755eb40588d91d2db981b245ed2876fa3dad7 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 2 Sep 2025 18:25:00 +0000 Subject: [PATCH 062/199] fix for unsafe use of ivargrp --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 96ab7cd8f..a2f615746 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -576,7 +576,7 @@ subroutine multiply(self, fields,index_member_in) ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) endif else - if(self%intstate(jscale,ivargrp)%l_for_localization) then + if(self%intstate(1,1)%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level if(n_owned_size >0 ) then From 82017daa0f17de9b1e91207b6bcf510917fedca5 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 4 Sep 2025 02:26:21 +0000 Subject: [PATCH 063/199] some cleaning --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 69 +++++++------------ 1 file changed, 25 insertions(+), 44 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index a2f615746..0194ce6c7 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -363,58 +363,39 @@ subroutine multiply(self, fields,index_member_in) afield= fields%field(isize) !clttodo fs= afield%functionspace() !cltthinkfore debug n_owned_size= fs%size_owned() !clt for debug + write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() if(afield%rank() == 2) then + write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() nz=afield%levels() + write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz call afield%data(ptr_2d) - !clt do k=1,nz - !clt do i=1,n_owned_size - !clt val=ptr_2d(k,i) - !clt if (ieee_is_nan(val)) then - !clt print *, '[Fortran] ❗ NaN detected in value' - !clt elseif (ieee_is_finite(val) .eqv. .false.) then - !clt print *, '[Fortran] ❗ Inf detected in value' - !clt elseif (abs(val) > 1.0e20) then - !clt print *, '[Fortran] ⚠️ Suspicious large value:', val - !clt endif - !clt enddo - !clt do i=n_owned_size+1,size(ptr_2d,2) - !clt val=ptr_2d(k,i) - ! if (ieee_is_nan(val)) then - ! print *, '[Fortran]2 ❗ NaN detected in value' - !j elseif (ieee_is_finite(val) .eqv. .false.) then - ! print *, '[Fortran]2 ❗ Inf detected in value' - ! elseif (abs(val) > 1.0e20) then - ! print *, '[Fortran]2 ⚠️ Suspicious large value:', val - ! endif - ! enddo - ! enddo if(nz == 1) then !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then - if(self%intstate(jscale,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - if(n_owned_size >0 ) then - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d - endif - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif + if(self%intstate(jscale,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + if(n_owned_size >0 ) then + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + endif + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - else + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + else if(n_owned_size >0 ) then work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) else From a0ed78bc09ed89d6c737daf62a26f536cfdb59a5 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 5 Sep 2025 02:09:05 +0000 Subject: [PATCH 064/199] refactored the use of rnormalization array --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 25 +++++++++++-------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 0194ce6c7..e873a5528 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -266,7 +266,7 @@ subroutine multiply(self, fields,index_member_in) real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) real(kind=r_kind), allocatable :: work2d_mgbf(:,:) -real(kind=r_kind), allocatable :: rnormalization(:) +real(kind=r_kind), allocatable :: rnormalization(:,:) integer(kind=i_kind), allocatable :: nlev_vargrp(:) integer(kind=i_kind) :: dim2d(2),dim3d(3) integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d @@ -334,15 +334,20 @@ subroutine multiply(self, fields,index_member_in) allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) - allocate(rnormalization(total_km_a_all)) + allocate(rnormalization(total_km_a_all,nvargrp)) + rnormalization=0.0 work2d_mgbf=0.0 ii=1 do ivargrp=1,nvargrp - ilev1=1 - ilev2=ilev1+nz3d-1 - do while (ilev2.le.nlev_vargrp(ivargrp) ) !todo optimization of tihs llop - rnormalization(ii:ii+nz3d-1)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) - ilev2=ilev2+nz3d + do k=1,self%intstate(jscale,ivargrp)%km2 +!clt if for localization , km2=0 only for +!clt only for l_2dvar_last_vertical_lev + rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) + ii=ii+1 + enddo +!clt if for localization , km2=0 + do k=1,self%intstate(jscale,ivargrp)%km3 + rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) ii=ii+nz3d enddo enddo @@ -484,14 +489,14 @@ subroutine multiply(self, fields,index_member_in) !clt# work_mgbf=999.0 !thinkdeb for debug call btim(mg_postprocess_time) + do k=1,nlev_vargrp(ivargrp) + vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) + enddo work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) ii=ii+nlev_vargrp(ivargrp) deallocate(vargrp_work_mgbf) deallocate(vargrp_work_mgbf2) enddo ! ivargrp - do k=1,nzloc - work_mgbf2(k,:,:)=work_mgbf2(k,:,:)/rnormalization(k) - enddo if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx work_mgbf=work_mgbf2 else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures From dbf91b38037834af8a63aa27e79962aa4caf6ffe Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 16 Sep 2025 13:32:40 +0000 Subject: [PATCH 065/199] add l_use_aspt_nml and l_use_aspt_nml_input --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 23 ++-- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 122 +++++++++++------- 2 files changed, 91 insertions(+), 54 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index e873a5528..ddcfa0d45 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -274,7 +274,7 @@ subroutine multiply(self, fields,index_member_in) integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit integer(kind=i_kind):: n2d integer(kind=i_kind),allocatable :: varvlev_index(:,:) -logical :: l3d_encountered +logical :: l2d_encountered logical :: test_once=.false. integer(kind=i_kind)::itest=0 character(len=32) :: fileoutput @@ -329,7 +329,7 @@ subroutine multiply(self, fields,index_member_in) nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps n2d=0 - l3d_encountered=.false. + l2d_encountered=.false. ivargrp0=1 allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) @@ -408,14 +408,17 @@ subroutine multiply(self, fields,index_member_in) endif endif - if(nz > 1) l3d_encountered=.true. - if(nz == 1) then - if(l3d_encountered ) then - write(6,*)"l3d_encountered is true , 2dvariable is not put in the begining, stop" - stop ! is required 2d fields are saved consecutively - endif + if(nz == 1) then + l2d_encountered=.true. n2d=n2d+1 endif + if(nz > 1) then + if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then + write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" + call flush(6) + error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending + endif + endif if(isize==1) then varvlev_index(isize,1)= 1 !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then @@ -453,9 +456,9 @@ subroutine multiply(self, fields,index_member_in) endif enddo do k=1,nzloc - !cltorg work2d_mgbf(k,:)=work2d_mgbf(k,:)/rnormalization(k) !clttothink should be done after the filtering work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) enddo + if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added @@ -490,7 +493,7 @@ subroutine multiply(self, fields,index_member_in) call btim(mg_postprocess_time) do k=1,nlev_vargrp(ivargrp) - vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) + vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) enddo work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) ii=ii+nlev_vargrp(ivargrp) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index f6d6319b2..b586c67ac 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -165,9 +165,14 @@ module mg_parameter logical :: l_quad_horizontal=.false. ! 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 +logical :: l_vert_stretched_filtgrid=.true. ! true : filtering grids are stretched in tems of analysis grid unit +logical :: l_use_aspt_nml=.true. !when l_vertical_filter=.true., still use the mg_ampl01 in the namelist + !and a uniformly vertical filtering grids are supposed to be generated + !hence, the veritcal interpolation sub with the Jim's sub for original l_vertical_filter=.ture. + ! is supposed to be used in the following maping + ! in the future, maybe cleaner (while more efforts are needed) logics might be added +logical :: l_use_aspt_nml_input=.false. !when l_vertical_filter=.true., use the namlies as the input to get new vertcal aspt logical :: l_anal_sub_of_filt ! true : analysis grids and filtering grids are the same excpet for later has boundary points -logical :: l_vert_stretched_filtgrid ! true : filtering grids are stretched in tems of analysis grid unit -!logical :: l_vert_varied_ampl01 ! true, ampl01 is varied over the vertical analysis levels integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) integer(i_kind):: km_4 integer(i_kind):: km_16 @@ -522,7 +527,9 @@ subroutine init_mg_parameter(this,inputfilename) logical :: l_new_map=.false. ! logical flag for new mapping between analysis and filter grid logical :: l_vertical_filter=.true. ! logical flag for vertical filtering logical :: l_anal_sub_of_filt=.false. -logical :: l_vert_stretched_filtgrid=.false. +logical :: l_vert_stretched_filtgrid=.true. +logical :: l_use_aspt_nml=.true. +logical :: l_use_aspt_nml_input=.false. !cltlogical :: l_vert_varied_ampl01=.false. ! true, ampl01 is varied over the vertical analysis levels integer(i_kind):: gm_max=4 !clt by defaul @@ -552,6 +559,8 @@ subroutine init_mg_parameter(this,inputfilename) ,l_vertical_filter & ,l_anal_sub_of_filt & ,l_vert_stretched_filtgrid & + ,l_use_aspt_nml & + ,l_use_aspt_nml_input & ,l_for_localization,ldelta,lquart,lhelm & , l_mgbf_inhomogeneous & ,gm_max & @@ -565,9 +574,14 @@ subroutine init_mg_parameter(this,inputfilename) ! allocate(this%zofis(lm)) allocate(this%isofz(lm_a)) + write(6,*)"thinkdeb999 filgrid is ",l_vert_stretched_filtgrid this%l_vert_stretched_filtgrid=l_vert_stretched_filtgrid + this%l_use_aspt_nml=l_use_aspt_nml + this%l_use_aspt_nml_input=l_use_aspt_nml_input #if 1 + if(this%l_vert_stretched_filtgrid ) then + write(6,*)'thinkdeb999 l_vert_stretched_filtgrid ',this%l_vert_stretched_filtgrid call convert_vert_varied_aspt !in which the mg_ampl01 will be re-defined endif @@ -605,7 +619,6 @@ subroutine init_mg_parameter(this,inputfilename) this%l_new_map=l_new_map this%l_vertical_filter=l_vertical_filter this%l_anal_sub_of_filt=l_anal_sub_of_filt - this%l_vert_stretched_filtgrid=l_vert_stretched_filtgrid !clt this%l_vert_varied_ampl01=l_vert_varied_ampl01 this%l_for_localization=l_for_localization this%l_mgbf_inhomogeneous = l_mgbf_inhomogeneous @@ -945,43 +958,50 @@ subroutine convert_vert_varied_aspt real (r_kind),allocatable,dimension(:)::sigofz real (r_kind),allocatable,dimension(:)::sigofis integer(i_kind):: user_mpi_real + real (r_kind) :: mg_ampl01_org allocate(this%aspect_vert_profile_angrid(lm_a),this%aspect_vert_profile_filtgrid(lm)) allocate(sigofz(lm_a),sigofis(lm)) call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr) + write(6,*)'thinkdeb999 2 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid if(this%l_vert_stretched_filtgrid) then - if(mype.eq.0) then - open(newunit=myunit,file="mgbf_vert_aspt_profile.txt",status='old') - read(myunit,*)lm_tmp - if(lm_tmp.ne.lm_a) then - error stop " the lm_a is not the same as the size in mgbf_vert_aspt_profile.txt, stop" - endif - do i=1,lm_a - read(myunit,*)this%aspect_vert_profile_angrid(i) - enddo - close(myunit) - endif -if (allocated(this%aspect_vert_profile_angrid)) then - write(6,*) 'DEBUG: size=', size(this%aspect_vert_profile_angrid) - write(6,*) 'DEBUG: kind1=', kind(this%aspect_vert_profile_angrid(1)) -endif - call MPI_Type_match_size(MPI_TYPECLASS_REAL, kind(this%aspect_vert_profile_angrid(1)), user_mpi_real, ierr) - if (ierr /= MPI_SUCCESS) then - write(6,*) "ERROR: No matching MPI type for real kind =", kind(this%aspect_vert_profile_angrid(1)) - call MPI_Abort(MPI_COMM_WORLD, 1, ierr) - endif - call MPI_Bcast(this%aspect_vert_profile_angrid, lm_a, user_mpi_real, 0, MPI_COMM_WORLD, ierr) - -! nz=lm_a-1 -! ns=lm-1 - -! calibrate sigscale to make sigofz go to sigbottom at z=0: - sigofz=sqrt(this%aspect_vert_profile_angrid) - if(mype==0) then - do iz=lm_a,1,-1 - write(6,*)iz,sigofz(iz) - enddo - endif + if(.not.this%l_use_aspt_nml_input) then + if(mype.eq.0) then + open(newunit=myunit,file="mgbf_vert_aspt_profile.txt",status='old') + read(myunit,*)lm_tmp + if(lm_tmp.ne.lm_a) then + error stop " the lm_a is not the same as the size in mgbf_vert_aspt_profile.txt, stop" + endif + do i=1,lm_a + read(myunit,*)this%aspect_vert_profile_angrid(i) + enddo + close(myunit) + endif + if (allocated(this%aspect_vert_profile_angrid)) then + write(6,*) 'DEBUG: size=', size(this%aspect_vert_profile_angrid) + write(6,*) 'DEBUG: kind1=', kind(this%aspect_vert_profile_angrid(1)) + endif + call MPI_Type_match_size(MPI_TYPECLASS_REAL, kind(this%aspect_vert_profile_angrid(1)), user_mpi_real, ierr) + if (ierr /= MPI_SUCCESS) then + write(6,*) "ERROR: No matching MPI type for real kind =", kind(this%aspect_vert_profile_angrid(1)) + call MPI_Abort(MPI_COMM_WORLD, 1, ierr) + endif + call MPI_Bcast(this%aspect_vert_profile_angrid, lm_a, user_mpi_real, 0, MPI_COMM_WORLD, ierr) + + ! nz=lm_a-1 + ! ns=lm-1 + + ! calibrate sigscale to make sigofz go to sigbottom at z=0: + sigofz=sqrt(this%aspect_vert_profile_angrid) + if(mype==0) then + do iz=lm_a,1,-1 + write(6,*)iz,sigofz(iz) + enddo + endif + else + sigofz=sqrt(mg_ampl01) + + endif ! Make the new grid whose resolution of the correlation scale sigofz ! is uniform throughout. @@ -996,17 +1016,31 @@ subroutine convert_vert_varied_aspt !clt call logintgrid(nz,ns,zofis,sigofz,sigofis) call zsigtossig(lm_a-1,nf,lm-1,this%zofis,sigofz,sigofis) print'('' list the profile coordinates of zofis,sigofis, for each is:'')' +! if(this%l_use_aspt_nml) then +!j sigofis=sqrt(mg_amp01) +! else + mg_ampl01_org=mg_ampl01 + mg_ampl01=(sum(sigofis**2)/size(sigofis)) + if(this%l_use_aspt_nml.and.this%l_use_aspt_nml_input) then !the former could be only true when the latter is in effect + write(6,*)' suggested and actual/original ampl01 is ',mg_ampl01,' ' ,mg_ampl01_org + mg_ampl01=mg_ampl01_org +! if (abs(mg_ampl01_org-mg_ampl01)/mg_ampl01_org .gt.0.001) then +! write(6,*)'thinkdeb the new ampl01 is too much difference from the original one ,when this%l_use_aspt_nml' +! stop +! endif + endif + write(6,*)' the original and final ampl01 is ',mg_ampl01_org,' ' ,mg_ampl01 + do is=1,lm write(6,*)is,this%zofis(is),(sigofis(is))**2 enddo - if(mype==6) then - open(newunit=myunit,file="converted_mgbf_vert_aspt_profile.txt",status='replace') - do is=1,lm - write(myunit,*)is,this%zofis(is),(sigofis(is))**2 - enddo - close(myunit) - endif - mg_ampl01=(sum(sigofis**2)/size(sigofis)) + if(mype==6) then + open(newunit=myunit,file="converted_mgbf_vert_aspt_profile.txt",status='replace') + do is=1,lm + write(myunit,*)is,this%zofis(is),(sigofis(is))**2 + enddo + close(myunit) + endif !clt if(this%l_2dvar_last_vertical_level == .true. ) then !the fieldset passed into mgbf will be top-down,so !clttodo need to access this from mgbf lib too this%zofis=this%zofis(lm:1:-1) From c55f7441f8fa20fe2a2a4ea4a438ca3ec708a099 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 20 Sep 2025 01:02:11 +0000 Subject: [PATCH 066/199] fix for vertical layout in transfer when km2!=0 (when 2d variables exist in static B cases) --- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 46 ++++++++++++++++++------ src/saber/mgbf/mgbf_lib/mg_timers.f90 | 7 +++- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 12 +++---- 3 files changed, 48 insertions(+), 17 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index b586c67ac..b05c72f94 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -166,12 +166,12 @@ module mg_parameter logical :: l_new_map ! logical flag for new mapping between analysis and filter grid logical :: l_vertical_filter ! logical flag for vertical filtering logical :: l_vert_stretched_filtgrid=.true. ! true : filtering grids are stretched in tems of analysis grid unit -logical :: l_use_aspt_nml=.true. !when l_vertical_filter=.true., still use the mg_ampl01 in the namelist +logical :: l_use_aspt_nml=.false. !when l_vertical_filter=.true., still use the mg_ampl01 in the namelist !and a uniformly vertical filtering grids are supposed to be generated !hence, the veritcal interpolation sub with the Jim's sub for original l_vertical_filter=.ture. ! is supposed to be used in the following maping ! in the future, maybe cleaner (while more efforts are needed) logics might be added -logical :: l_use_aspt_nml_input=.false. !when l_vertical_filter=.true., use the namlies as the input to get new vertcal aspt +logical :: l_use_aspt_nml_input=.true. !when l_vertical_filter=.true., use the namlies as the input to get new vertcal aspt logical :: l_anal_sub_of_filt ! true : analysis grids and filtering grids are the same excpet for later has boundary points integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) integer(i_kind):: km_4 @@ -528,8 +528,8 @@ subroutine init_mg_parameter(this,inputfilename) logical :: l_vertical_filter=.true. ! logical flag for vertical filtering logical :: l_anal_sub_of_filt=.false. logical :: l_vert_stretched_filtgrid=.true. -logical :: l_use_aspt_nml=.true. -logical :: l_use_aspt_nml_input=.false. +logical :: l_use_aspt_nml=.false. +logical :: l_use_aspt_nml_input=.true. !cltlogical :: l_vert_varied_ampl01=.false. ! true, ampl01 is varied over the vertical analysis levels integer(i_kind):: gm_max=4 !clt by defaul @@ -586,6 +586,8 @@ subroutine init_mg_parameter(this,inputfilename) !in which the mg_ampl01 will be re-defined endif #endif + write(6,*)'thinkdeb999 2 4 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + call flush(6) !----------------------------------------------------------------- !for safety, copy all namelist loc vars to them of this object this%mg_ampl01=mg_ampl01 @@ -753,6 +755,8 @@ subroutine init_mg_parameter(this,inputfilename) ! this%nm = this%nm0/this%nxm this%mm = this%mm0/this%nym + write(6,*)'thinkdeb999 2 6 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + call flush(6) if(this%l_anal_sub_of_filt ) then if(this%im_filt.ne.this%nm.or.this%jm_filt.ne.this%mm) then write(6,*)'l_anal_sub_of_filter is true but the numbers of analysis/filtering grids are wrong, stop' @@ -763,6 +767,8 @@ subroutine init_mg_parameter(this,inputfilename) stop endif endif + write(6,*)'thinkdeb999 2 7 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + call flush(6) !*** !*** Filter grid @@ -861,6 +867,8 @@ subroutine init_mg_parameter(this,inputfilename) ! Set number of processors at higher generations ! + write(6,*)'thinkdeb999 2 8 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + call flush(6) allocate(this%ixm(this%gm)) allocate(this%jym(this%gm)) allocate(this%nxy(this%gm)) @@ -875,6 +883,8 @@ subroutine init_mg_parameter(this,inputfilename) call def_ngens(this%ixm,this%gm,this%nxm) call def_ngens(this%jym,this%gm,this%nym) + write(6,*)'thinkdeb999 2 9 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + call flush(6) do g=1,this%gm this%nxy(g)=this%ixm(g)*this%jym(g) enddo @@ -949,6 +959,8 @@ subroutine init_mg_parameter(this,inputfilename) this%rmom2_4=u1/sqrt(this%pee2+6) #if 1 + write(6,*)'thinkdeb999 2 10 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + call flush(6) contains subroutine convert_vert_varied_aspt @@ -963,11 +975,17 @@ subroutine convert_vert_varied_aspt allocate(this%aspect_vert_profile_angrid(lm_a),this%aspect_vert_profile_filtgrid(lm)) allocate(sigofz(lm_a),sigofis(lm)) call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr) - write(6,*)'thinkdeb999 2 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + write(6,*)'thinkdeb999 2.0 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + call flush(6) if(this%l_vert_stretched_filtgrid) then if(.not.this%l_use_aspt_nml_input) then if(mype.eq.0) then - open(newunit=myunit,file="mgbf_vert_aspt_profile.txt",status='old') + write(6,*)'thinkdeb999 2.001 before open ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_use_aspt_nml_input + call flush(6) + open(newunit=myunit,file="mgbf_vert_aspt_profile.txt",status='old',iostat=ierr) + write(6,*)'thinkdeb999 2.001 after open ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + call flush(6) + if(ierr /= 0) error stop "wrong with open file mgbf_vert_aspt_profile.txt ,stop" read(myunit,*)lm_tmp if(lm_tmp.ne.lm_a) then error stop " the lm_a is not the same as the size in mgbf_vert_aspt_profile.txt, stop" @@ -977,16 +995,18 @@ subroutine convert_vert_varied_aspt enddo close(myunit) endif - if (allocated(this%aspect_vert_profile_angrid)) then - write(6,*) 'DEBUG: size=', size(this%aspect_vert_profile_angrid) - write(6,*) 'DEBUG: kind1=', kind(this%aspect_vert_profile_angrid(1)) - endif + write(6,*) 'DEBUG: size=', size(this%aspect_vert_profile_angrid) + write(6,*) 'DEBUG: kind1=', kind(this%aspect_vert_profile_angrid(1)) call MPI_Type_match_size(MPI_TYPECLASS_REAL, kind(this%aspect_vert_profile_angrid(1)), user_mpi_real, ierr) + write(6,*)'thinkdeb999 2 0.2 ' + call flush(6) if (ierr /= MPI_SUCCESS) then write(6,*) "ERROR: No matching MPI type for real kind =", kind(this%aspect_vert_profile_angrid(1)) call MPI_Abort(MPI_COMM_WORLD, 1, ierr) endif call MPI_Bcast(this%aspect_vert_profile_angrid, lm_a, user_mpi_real, 0, MPI_COMM_WORLD, ierr) + write(6,*)'thinkdeb999 2 0.3 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + call flush(6) ! nz=lm_a-1 ! ns=lm-1 @@ -999,6 +1019,8 @@ subroutine convert_vert_varied_aspt enddo endif else + write(6,*)'thinkdeb999 2 0.1 ',this%l_vert_stretched_filtgrid ,' ' + call flush(6) sigofz=sqrt(mg_ampl01) endif @@ -1008,6 +1030,8 @@ subroutine convert_vert_varied_aspt ! isofz is the s-index coordinate of each of the original z-grid points. ! zofis is the z-index coordinate of each of the new s-grid points. !cltorg call make_ssgrid(nz,nf,ns,sigofz, sstop,dss,isofz,zofis) + write(6,*)'thinkdeb999 2 1 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + call flush(6) call make_ssgrid(lm_a-1,nf,lm-1,sigofz, sstop,dss,this%isofz,this%zofis) ! Use the new s-grid locations zofis, and the original profile of @@ -1049,6 +1073,8 @@ subroutine convert_vert_varied_aspt endif + write(6,*)'thinkdeb999 2 3 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid + call flush(6) deallocate(sigofz,sigofis) end subroutine convert_vert_varied_aspt diff --git a/src/saber/mgbf/mgbf_lib/mg_timers.f90 b/src/saber/mgbf/mgbf_lib/mg_timers.f90 index 66a9f415b..9a90a90e9 100755 --- a/src/saber/mgbf/mgbf_lib/mg_timers.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_timers.f90 @@ -125,16 +125,21 @@ subroutine etim(t) ct = ctime() if (.not.t%running) then - write(0,*)'etim: timer is not running' + write(6,*)'etim: timer is not running' + call flush(6) STOP end if !clt t%running = .true. t%time_clock = t%time_clock + (wt - t%start_clock) + t%time_cpu = t%time_cpu + (ct - t%start_cpu) t%icount = t%icount+1 !clt noneed t%start_clock = 0.0 !clt noneed t%start_cpu = 0.0 + write(6,*)'etim: timer is done' + call flush(6) + endsubroutine etim !----------------------------------------------------------------------- diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index 9817b2993..0590a6119 100755 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -148,12 +148,12 @@ module subroutine anal_to_filt_all(this,WORKA) endif !2.gt.3 if(lm_a>lm) then do ivar=1,this%km2 !2dvar is directly passed - work(ivar,:,:)=worka(ivar,:,:) + work(this%km_all-ivar+1,:,:)=worka(this%km_all-ivar+1,:,:) enddo do ivar=1,this%km3 - lev1_a=this%km2+1+(ivar-1)*this%lm_a - lev1_f=this%km2+1+(ivar-1)*this%lm + lev1_a=1+(ivar-1)*this%lm_a + lev1_f=1+(ivar-1)*this%lm lev2_a=lev1_a+this%lm_a-1 lev2_f=lev1_f+this%lm-1 @@ -206,12 +206,12 @@ module subroutine filt_to_anal_all(this,WORKA) call this%filt_to_anal(WORK) !cltadded if(lm_a>lm) then do ivar=1,this%km2 !2dvar is directly passed - worka(ivar,:,:)=work(ivar,:,:) + worka(this%km_a_all-ivar+1,:,:)=work(this%km_all-ivar+1,:,:) enddo do ivar=1,this%km3 - lev1_a=this%km2+1+(ivar-1)*this%lm_a - lev1_f=this%km2+1+(ivar-1)*this%lm + lev1_a=1+(ivar-1)*this%lm_a + lev1_f=1+(ivar-1)*this%lm lev2_a=lev1_a+this%lm_a-1 lev2_f=lev1_f+this%lm-1 !clt call this%lwq_vertical_direct(this%lm,this%lm_a,1,nm,1,mm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref, & From d9e8ba3d0c0684feeaba463ebb269ae917957e88 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 23 Sep 2025 21:03:33 +0000 Subject: [PATCH 067/199] use of the normalization coefficients profile and fix for km2!=0 on reduced vertical grids --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 233 +++++++++--------- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 67 +++-- src/saber/mgbf/mgbf_lib/mg_timers.f90 | 2 - src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 23 +- 4 files changed, 158 insertions(+), 167 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index ddcfa0d45..8a2fd87c4 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -370,89 +370,94 @@ subroutine multiply(self, fields,index_member_in) n_owned_size= fs%size_owned() !clt for debug write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() if(afield%rank() == 2) then - write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() - nz=afield%levels() - write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz - call afield%data(ptr_2d) + write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() + nz=afield%levels() + write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz + call afield%data(ptr_2d) + if(nz /= 1 .and. nz /= nz3d ) then + write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d + call flush(6) + stop + endif - if(nz == 1) then -!clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then - if(self%intstate(jscale,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - if(n_owned_size >0 ) then - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d - endif - else + if(nz == 1) then + !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + if(n_owned_size >0 ) then + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + endif + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + + + else if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d endif - endif - - - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif endif - endif - - if(nz == 1) then - l2d_encountered=.true. - n2d=n2d+1 - endif - if(nz > 1) then - if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then - write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" - call flush(6) - error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending - endif - endif - if(isize==1) then - varvlev_index(isize,1)= 1 - !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then - if(.not.self%intstate(jscale,1)%l_for_localization )then - varvlev_index(isize,2)= nz - else - varvlev_index(isize,2)= nz3d + + if(nz == 1) then + l2d_encountered=.true. + n2d=n2d+1 endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - else - !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d - varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 - if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then - varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 + if(nz > 1) then + if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then + write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" + call flush(6) + error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending + endif + endif + if(isize==1) then + varvlev_index(isize,1)= 1 + !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,1)%l_for_localization )then + varvlev_index(isize,2)= nz + else + varvlev_index(isize,2)= nz3d + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 else - varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 + !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d + varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 + if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then + varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 + else + varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - endif - jvargrp=self%ivar2grp(isize) + jvargrp=self%ivar2grp(isize) - - ilev=varvlev_index(isize,2)+1 + + ilev=varvlev_index(isize,2)+1 elseif (afield%rank() == 3) then - write(6,*)'this case needs more work, stop' ! a better exption handling to be added - call flush(6) - stop - call afield%data(ptr_3d) - nz=afield%levels() - work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d - ilev=ilev+nz + write(6,*)'this case needs more work, stop' ! a better exption handling to be added + call flush(6) + stop + call afield%data(ptr_3d) + nz=afield%levels() + work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d + ilev=ilev+nz else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - stop + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + stop endif enddo do k=1,nzloc @@ -504,31 +509,30 @@ subroutine multiply(self, fields,index_member_in) work_mgbf=work_mgbf2 else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + work1var_mgbf=0.0 if(nvargrp == 1 ) then - work1var_mgbf=0.0 do ivar=1,nvar lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) enddo - do jvar=1,nvar - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo + do jvar=1,nvar + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo else do jvar=1,nvar - work1var_mgbf=0.0 jvargrp=self%ivar2grp(jvar) do ivar=1,nvar lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) - ivargrp=self%ivar2grp(ivar) + ivargrp=self%ivar2grp(ivar) work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) enddo lev1=varvlev_index(jvar,1) lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf + work_mgbf(lev1:lev2,:,:)=work1var_mgbf enddo endif deallocate(work1var_mgbf) @@ -548,50 +552,43 @@ subroutine multiply(self, fields,index_member_in) nz=afield%levels() lev1=varvlev_index(isize,1) if(nz.gt.1) then - ! if(n_owned_size == 0) then - ! do i = 1, size(ghost) - ! if (ghost(i) == 0) then - ! This point is owned (not a halo point) - ! n_owned_size=n_owned_size+1 - ! endif - ! end do - !! write(6,*)'thinkdeb2552 dimension of ptr_2d are ',size(ptr_2d,1), ' ',size(ptr_2d,2) - ! endif - !clt write(6,*)'thinkdeb2552 n_owned_size ',n_owned_size,' ','total size is ' ,size(ptr_2d,2) - if(n_owned_size >0 ) then - ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif + if(n_owned_size >0 ) then + ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif else if(self%intstate(1,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + endif + else if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + write(6,*)'suspicous situation while n_owned_szie =0 ,stop' + call flush(6) + stop + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) endif - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif endif - endif + endif !nz >1 or not elseif (afield%rank() == 3) then call afield%data(ptr_3d) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index b05c72f94..52b752171 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -165,13 +165,7 @@ module mg_parameter logical :: l_quad_horizontal=.false. ! 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 -logical :: l_vert_stretched_filtgrid=.true. ! true : filtering grids are stretched in tems of analysis grid unit -logical :: l_use_aspt_nml=.false. !when l_vertical_filter=.true., still use the mg_ampl01 in the namelist - !and a uniformly vertical filtering grids are supposed to be generated - !hence, the veritcal interpolation sub with the Jim's sub for original l_vertical_filter=.ture. - ! is supposed to be used in the following maping - ! in the future, maybe cleaner (while more efforts are needed) logics might be added -logical :: l_use_aspt_nml_input=.true. !when l_vertical_filter=.true., use the namlies as the input to get new vertcal aspt +logical :: l_vert_stretched_filtgrid=.false. ! true : filtering grids are stretched in tems of analysis grid unit logical :: l_anal_sub_of_filt ! true : analysis grids and filtering grids are the same excpet for later has boundary points integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) integer(i_kind):: km_4 @@ -516,6 +510,7 @@ subroutine init_mg_parameter(this,inputfilename) !clthhhreal(r_kind):: coef_normalization(lm_max)=1.0 !normalizaton coefficients real(r_kind):: coef_normalization(lm_max)=1 !normalizaton coefficients real(r_kind):: coef_normalization_const=-9999.0 ! constant, if set, this contant will be +character(len=256) ::file_coef_normalization="XXXX" 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=1 ! number of ensemble members @@ -527,9 +522,7 @@ subroutine init_mg_parameter(this,inputfilename) logical :: l_new_map=.false. ! logical flag for new mapping between analysis and filter grid logical :: l_vertical_filter=.true. ! logical flag for vertical filtering logical :: l_anal_sub_of_filt=.false. -logical :: l_vert_stretched_filtgrid=.true. -logical :: l_use_aspt_nml=.false. -logical :: l_use_aspt_nml_input=.true. +logical :: l_vert_stretched_filtgrid=.false. !cltlogical :: l_vert_varied_ampl01=.false. ! true, ampl01 is varied over the vertical analysis levels integer(i_kind):: gm_max=4 !clt by defaul @@ -541,6 +534,8 @@ subroutine init_mg_parameter(this,inputfilename) integer(i_kind):: p logical:: l_mg_weig_readin=.false. integer(i_kind), parameter :: nf=20! refinement factor for z grid,used in make_ssgrid +integer(i_kind) :: myunit,i +logical :: l_exist namelist /parameters_mgbeta/ mg_ampl01,mg_ampl02,mg_ampl03 & ,mg_weig1,mg_weig2,mg_weig3,mg_weig4 & @@ -548,6 +543,7 @@ subroutine init_mg_parameter(this,inputfilename) ,mgbf_line,mgbf_proc & ,lm_a,lm,coef_normalization & ,coef_normalization_const & + ,file_coef_normalization & ,km2,km3 & ,n_ens & ,l_loc & @@ -559,8 +555,6 @@ subroutine init_mg_parameter(this,inputfilename) ,l_vertical_filter & ,l_anal_sub_of_filt & ,l_vert_stretched_filtgrid & - ,l_use_aspt_nml & - ,l_use_aspt_nml_input & ,l_for_localization,ldelta,lquart,lhelm & , l_mgbf_inhomogeneous & ,gm_max & @@ -576,18 +570,14 @@ subroutine init_mg_parameter(this,inputfilename) allocate(this%isofz(lm_a)) write(6,*)"thinkdeb999 filgrid is ",l_vert_stretched_filtgrid this%l_vert_stretched_filtgrid=l_vert_stretched_filtgrid - this%l_use_aspt_nml=l_use_aspt_nml - this%l_use_aspt_nml_input=l_use_aspt_nml_input #if 1 - if(this%l_vert_stretched_filtgrid ) then + if(lm_a .ne. lm ) then write(6,*)'thinkdeb999 l_vert_stretched_filtgrid ',this%l_vert_stretched_filtgrid call convert_vert_varied_aspt !in which the mg_ampl01 will be re-defined endif #endif - write(6,*)'thinkdeb999 2 4 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid - call flush(6) !----------------------------------------------------------------- !for safety, copy all namelist loc vars to them of this object this%mg_ampl01=mg_ampl01 @@ -607,7 +597,30 @@ subroutine init_mg_parameter(this,inputfilename) this%lm=lm if (coef_normalization_const >0 ) then ! constant, if set, this contant will be + coef_normalization=coef_normalization_const + if(trim(file_coef_normalization)=="XXXX" ) then + l_exist=.false. + else + inquire(file=trim(file_coef_normalization),exist=l_exist) + endif + if(l_exist) then + write(6,*)'the normalization profile file is ',trim(file_coef_normalization) +!clt in the ../covairance/mgbf_covariance_mod.f90 the fldset is reversed in the vertical direction + open(newunit=myunit,file=trim(file_coef_normalization),status='old',action='read') + read(myunit,*)(coef_normalization(i),i=lm_a,1,-1) + close (myunit) + coef_normalization(1:lm_a)=coef_normalization*coef_normalization_const !re-calc + + + else + coef_normalization=coef_normalization_const !re-calc + endif + else + coef_normalization=1.0 + + + endif this%coef_normalization=coef_normalization this%km2=km2 @@ -965,7 +978,7 @@ subroutine init_mg_parameter(this,inputfilename) subroutine convert_vert_varied_aspt - integer(i_kind) :: myunit,lm_tmp,i,iz,is,mype,ierr + integer(i_kind) :: lm_tmp,iz,is,mype,ierr real(r_kind)::sstop,dss real (r_kind),allocatable,dimension(:)::sigofz real (r_kind),allocatable,dimension(:)::sigofis @@ -978,13 +991,8 @@ subroutine convert_vert_varied_aspt write(6,*)'thinkdeb999 2.0 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid call flush(6) if(this%l_vert_stretched_filtgrid) then - if(.not.this%l_use_aspt_nml_input) then if(mype.eq.0) then - write(6,*)'thinkdeb999 2.001 before open ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_use_aspt_nml_input - call flush(6) open(newunit=myunit,file="mgbf_vert_aspt_profile.txt",status='old',iostat=ierr) - write(6,*)'thinkdeb999 2.001 after open ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid - call flush(6) if(ierr /= 0) error stop "wrong with open file mgbf_vert_aspt_profile.txt ,stop" read(myunit,*)lm_tmp if(lm_tmp.ne.lm_a) then @@ -995,18 +1003,12 @@ subroutine convert_vert_varied_aspt enddo close(myunit) endif - write(6,*) 'DEBUG: size=', size(this%aspect_vert_profile_angrid) - write(6,*) 'DEBUG: kind1=', kind(this%aspect_vert_profile_angrid(1)) call MPI_Type_match_size(MPI_TYPECLASS_REAL, kind(this%aspect_vert_profile_angrid(1)), user_mpi_real, ierr) - write(6,*)'thinkdeb999 2 0.2 ' - call flush(6) if (ierr /= MPI_SUCCESS) then write(6,*) "ERROR: No matching MPI type for real kind =", kind(this%aspect_vert_profile_angrid(1)) call MPI_Abort(MPI_COMM_WORLD, 1, ierr) endif call MPI_Bcast(this%aspect_vert_profile_angrid, lm_a, user_mpi_real, 0, MPI_COMM_WORLD, ierr) - write(6,*)'thinkdeb999 2 0.3 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid - call flush(6) ! nz=lm_a-1 ! ns=lm-1 @@ -1030,8 +1032,6 @@ subroutine convert_vert_varied_aspt ! isofz is the s-index coordinate of each of the original z-grid points. ! zofis is the z-index coordinate of each of the new s-grid points. !cltorg call make_ssgrid(nz,nf,ns,sigofz, sstop,dss,isofz,zofis) - write(6,*)'thinkdeb999 2 1 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid - call flush(6) call make_ssgrid(lm_a-1,nf,lm-1,sigofz, sstop,dss,this%isofz,this%zofis) ! Use the new s-grid locations zofis, and the original profile of @@ -1045,7 +1045,7 @@ subroutine convert_vert_varied_aspt ! else mg_ampl01_org=mg_ampl01 mg_ampl01=(sum(sigofis**2)/size(sigofis)) - if(this%l_use_aspt_nml.and.this%l_use_aspt_nml_input) then !the former could be only true when the latter is in effect + if(.not.this%l_vert_stretched_filtgrid) then !the former could be only true when the latter is in effect write(6,*)' suggested and actual/original ampl01 is ',mg_ampl01,' ' ,mg_ampl01_org mg_ampl01=mg_ampl01_org ! if (abs(mg_ampl01_org-mg_ampl01)/mg_ampl01_org .gt.0.001) then @@ -1071,10 +1071,7 @@ subroutine convert_vert_varied_aspt !# endif - endif - write(6,*)'thinkdeb999 2 3 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid - call flush(6) deallocate(sigofz,sigofis) end subroutine convert_vert_varied_aspt diff --git a/src/saber/mgbf/mgbf_lib/mg_timers.f90 b/src/saber/mgbf/mgbf_lib/mg_timers.f90 index 9a90a90e9..dcabe43c0 100755 --- a/src/saber/mgbf/mgbf_lib/mg_timers.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_timers.f90 @@ -137,8 +137,6 @@ subroutine etim(t) t%icount = t%icount+1 !clt noneed t%start_clock = 0.0 !clt noneed t%start_cpu = 0.0 - write(6,*)'etim: timer is done' - call flush(6) endsubroutine etim diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index 0590a6119..2e6ea9576 100755 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -160,15 +160,14 @@ module subroutine anal_to_filt_all(this,WORKA) !clt call this%lwq_vertical_adjoint(nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) !cltorg call this%lwq_vertical_adjoint(this%lm_a,this%lm,1,nm,1,mm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref, & !clt worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) - write(6,*)'thinkdeb999 l_vert_stretched_filtgrid is ',this%l_vert_stretched_filtgrid - if (this%l_vert_stretched_filtgrid) then - write(6,*)'thinkdeb999 l_vert_stretched_filtgrid 2 is ',this%l_vert_stretched_filtgrid +!# if (this%l_vert_stretched_filtgrid) then +! write(6,*)'thinkdeb999 l_vert_stretched_filtgrid 2 is ',this%l_vert_stretched_filtgrid call intgrid_f2a_3d_ad_top2bot_fast(this%lm_a-1,this%lm-1,nm,mm,this%zofis,worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) - else - call this%test_vertical_interpolation_adj(this%lm,this%lm_a,1,nm,1,mm, work(lev1_f:lev2_f,:,:), & - worka(lev1_a:lev2_a,:,:)) - endif +! else +! call this%test_vertical_interpolation_adj(this%lm,this%lm_a,1,nm,1,mm, work(lev1_f:lev2_f,:,:), & +! worka(lev1_a:lev2_a,:,:)) +! endif enddo else work=worka @@ -216,12 +215,12 @@ module subroutine filt_to_anal_all(this,WORKA) lev2_f=lev1_f+this%lm-1 !clt call this%lwq_vertical_direct(this%lm,this%lm_a,1,nm,1,mm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref, & !clt work(lev1_f:lev2_f,:,:),worka(lev1_a:lev2_a,:,:)) - if (this%l_vert_stretched_filtgrid) then +! if (this%l_vert_stretched_filtgrid) then call intgrid_f2a_3d_top2bot_fast(this%lm_a-1,this%lm-1,nm,mm,this%zofis,worka(lev1_a:lev2_a,:,:),work(lev1_f:lev2_f,:,:)) - else - call this%test_vertical_interpolation(this%lm,this%lm_a,1,nm,1,mm, work(lev1_f:lev2_f,:,:), & - worka(lev1_a:lev2_a,:,:)) - endif +! else +! call this%test_vertical_interpolation(this%lm,this%lm_a,1,nm,1,mm, work(lev1_f:lev2_f,:,:), & +! worka(lev1_a:lev2_a,:,:)) +! endif enddo else worka=work From 1b775ed599e0b7b629ad25ed70b0053db16a6b9e Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 6 Oct 2025 15:16:03 +0000 Subject: [PATCH 068/199] optimization of the parameters controling the vertical interpolation schemes --- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 52b752171..3dcf800e5 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -610,11 +610,13 @@ subroutine init_mg_parameter(this,inputfilename) open(newunit=myunit,file=trim(file_coef_normalization),status='old',action='read') read(myunit,*)(coef_normalization(i),i=lm_a,1,-1) close (myunit) - coef_normalization(1:lm_a)=coef_normalization*coef_normalization_const !re-calc + coef_normalization(1:lm_a)=coef_normalization(1:lm_a)*coef_normalization_const !re-calc else - coef_normalization=coef_normalization_const !re-calc + write(6,*)'the normalization profile file does not exist ,stop ',trim(file_coef_normalization) + call flush(6) + stop endif else coef_normalization=1.0 From fff2ef5fa60c10cf0f377103edf569a299cfda23 Mon Sep 17 00:00:00 2001 From: Masanori-NOAA Date: Wed, 8 Oct 2025 10:46:25 -0500 Subject: [PATCH 069/199] Update based on PR comments --- CMakeLists.txt | 2 +- .../gsi/covariance/gsi_covariance_mod.f90 | 4 +-- src/saber/interpolation/Geometry.cc | 32 ++----------------- 3 files changed, 6 insertions(+), 32 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 073a36e05..4421cdf2e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -69,7 +69,7 @@ find_package( vader 1.7.0 REQUIRED ) # Optionals find_package( FFTW 3.3.8 QUIET ) -find_package( gsibec 1.2.1 QUIET ) +find_package( gsibec 1.3.2 QUIET ) find_package( eccodes 2.24 QUIET ) if( eccodes_FOUND ) set( ECCODES_LIBRARIES eccodes ) diff --git a/src/saber/gsi/covariance/gsi_covariance_mod.f90 b/src/saber/gsi/covariance/gsi_covariance_mod.f90 index 8757766b8..4d9651162 100644 --- a/src/saber/gsi/covariance/gsi_covariance_mod.f90 +++ b/src/saber/gsi/covariance/gsi_covariance_mod.f90 @@ -153,7 +153,7 @@ subroutine create(self, comm, config, ntimes, background, firstguess, valid_time endif jedi_lon = checks(2+ix) if(jedi_lon .lt. 0.) jedi_lon = jedi_lon + 360. - if (abs(gsi_lon - jedi_lon) > 1e-6) then + if (abs(gsi_lon - jedi_lon) > 1e-5) then write (*,*) 'ERROR connecting GSI-block to JEDI -- inconsistent lon with gsi, atlas = ', gsi_lon, jedi_lon gsi_jedi_grid_error = .true. endif @@ -166,7 +166,7 @@ subroutine create(self, comm, config, ntimes, background, firstguess, valid_time gsi_lat = self%grid%lats(self%grid%jsc-1 + iy) endif jedi_lat = checks(2+gsi_nx+iy) - if (abs(gsi_lat - jedi_lat) > 1e-6) then + if (abs(gsi_lat - jedi_lat) > 1e-5) then write (*,*) 'ERROR connecting GSI-block to JEDI -- inconsistent lat with gsi, atlas = ', gsi_lat, jedi_lat gsi_jedi_grid_error = .true. endif diff --git a/src/saber/interpolation/Geometry.cc b/src/saber/interpolation/Geometry.cc index dafc0ec3c..33faeed03 100644 --- a/src/saber/interpolation/Geometry.cc +++ b/src/saber/interpolation/Geometry.cc @@ -155,7 +155,9 @@ void setupGsiMatchingGrid(const eckit::Configuration & config, testconfig.set("type", "structured"); testconfig.set("xspace", build_xspace_config(grid_type)); testconfig.set("yspace", build_yspace_config(grid_type)); - if (grid_type == "rotated_lonlat") testconfig.set("projection", build_projection_config(grid_type)); + if (grid_type == "rotated_lonlat") { + testconfig.set("projection", build_projection_config(grid_type)); + } grid = atlas::Grid{testconfig}; const atlas::RegularGrid rg{grid}; @@ -171,34 +173,6 @@ void setupGsiMatchingGrid(const eckit::Configuration & config, functionSpace = atlas::functionspace::StructuredColumns(grid, distribution, atlas::option::halo(halo)); - // Get rotated_lonlat on the Earth coordinate - if (grid_type == "rotated_lonlat") { - atlas::Field lonlatField = functionSpace.lonlat(); - auto lonlatView = atlas::array::make_view(lonlatField); - for (int j = 0; j < lonlatView.shape(0); ++j) { - double rlon = lonlatView(j, 0); - double rlat = lonlatView(j, 1); - double rlon0 = north_pole_lon - 180.0; - double rlat0 = north_pole_lat - 90.0; - - double xtt = std::cos(deg2rad(rlat)) * std::cos(deg2rad(rlon)); - double ytt = std::cos(deg2rad(rlat)) * std::sin(deg2rad(rlon)); - double ztt = std::sin(deg2rad(rlat)); - - double xt = xtt*std::cos(deg2rad(rlat0)) - ztt*std::sin(deg2rad(rlat0)); - double yt = ytt; - double zt = xtt*std::sin(deg2rad(rlat0)) + ztt*std::cos(deg2rad(rlat0)); - - double x = xt*std::cos(deg2rad(rlon0)) - yt*std::sin(deg2rad(rlon0)); - double y = xt*std::sin(deg2rad(rlon0)) + yt*std::cos(deg2rad(rlon0)); - double z = zt; - - lonlatView(j, 0) = rad2deg(std::atan2(y,x)); - lonlatView(j, 1) = rad2deg(std::asin(z)); - } - lonlatField.set_dirty(); - } - // Using atlas::mpi::Scope in the call to atlas::functionspace::StructuredColumns // may have reverted the default communicator to the world communicator. // We set back the default communicator to `comm` to fix this. From 7b9b5d570c339a41503f4d063e9511f48d7e4caf Mon Sep 17 00:00:00 2001 From: Masanori-NOAA Date: Wed, 8 Oct 2025 14:18:18 -0500 Subject: [PATCH 070/199] Remove redundant code --- src/saber/interpolation/Geometry.cc | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/saber/interpolation/Geometry.cc b/src/saber/interpolation/Geometry.cc index 33faeed03..ed0012f33 100644 --- a/src/saber/interpolation/Geometry.cc +++ b/src/saber/interpolation/Geometry.cc @@ -75,9 +75,6 @@ std::vector computeS2NCheckerboardPartition(const atlas::RegularGrid & rg, return partition; } -constexpr double deg2rad(double deg) { return deg * M_PI / 180.0; } -constexpr double rad2deg(double rad) { return rad * 180.0 / M_PI; } - void setupGsiMatchingGrid(const eckit::Configuration & config, const eckit::mpi::Comm & comm, atlas::Grid & grid, From 0fd1dc49305e45d64643a935c489779e83a1771a Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Thu, 16 Oct 2025 18:09:11 +0000 Subject: [PATCH 071/199] change to ignore missing mgbf normalization profile --- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 45 ++++++++++++------------ 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 3dcf800e5..6d1c25ece 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -595,35 +595,36 @@ subroutine init_mg_parameter(this,inputfilename) this%mgbf_proc=mgbf_proc this%lm_a=lm_a this%lm=lm - - if (coef_normalization_const >0 ) then ! constant, if set, this contant will be - - coef_normalization=coef_normalization_const + if (coef_normalization_const >0 ) then ! constant, if set, this contant will be + if(trim(file_coef_normalization)=="XXXX" ) then l_exist=.false. + coef_normalization=coef_normalization_const else inquire(file=trim(file_coef_normalization),exist=l_exist) - endif - if(l_exist) then - write(6,*)'the normalization profile file is ',trim(file_coef_normalization) + if(l_exist) then + write(6,*)'the normalization profile file is ',trim(file_coef_normalization) !clt in the ../covairance/mgbf_covariance_mod.f90 the fldset is reversed in the vertical direction - open(newunit=myunit,file=trim(file_coef_normalization),status='old',action='read') - read(myunit,*)(coef_normalization(i),i=lm_a,1,-1) - close (myunit) - coef_normalization(1:lm_a)=coef_normalization(1:lm_a)*coef_normalization_const !re-calc - - - else - write(6,*)'the normalization profile file does not exist ,stop ',trim(file_coef_normalization) - call flush(6) - stop - endif + open(newunit=myunit,file=trim(file_coef_normalization),status='old',action='read') + read(myunit,*)(coef_normalization(i),i=lm_a,1,-1) + close (myunit) + coef_normalization(1:lm_a)=coef_normalization(1:lm_a)*coef_normalization_const !re-calc + else + + write(6,*)'the normalization profile file does not exist ,stop ',trim(file_coef_normalization) + call flush(6) + stop + endif + endif else - coef_normalization=1.0 - - - + coef_normalization=1.0 + + endif + + + + this%coef_normalization=coef_normalization this%km2=km2 this%km3=km3 From 284754090d7efa48ff6398f5fa224b25f7bb78b2 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 27 Oct 2025 22:43:04 +0000 Subject: [PATCH 072/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 46 +++++++ src/saber/mgbf/mgbf_lib/jp_pbfil.f90 | 36 +++++ src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 125 ++++++++++++++++-- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 65 ++++++++- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 11 +- src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 12 +- 6 files changed, 274 insertions(+), 21 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 8a2fd87c4..bb6f3075b 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -10,6 +10,14 @@ module mgbf_covariance_mod use atlas_module, only: atlas_fieldset, atlas_field use atlas_module, only: atlas_functionspace use atlas_module, only: atlas_functionspace_StructuredColumns +use atlas_module, only : atlas_functionspace, & + atlas_functionspace_nodecolumns, & + atlas_functionspace_pointcloud, & + atlas_functionspace_structuredcolumns, & + atlas_mesh_nodes, atlas_field + +use tools_func, only : sphere_dist +use tools_const, only : req ! Earth radius (m) ! fckit use fckit_mpi_module, only: fckit_mpi_comm @@ -78,6 +86,10 @@ subroutine create(self, comm, config, background, firstguess) type(atlas_fieldset), intent(in) :: firstguess ! Locals +real(r_kind) :: dist_rad, dist_m +integer :: ipt + + character(len=*), parameter :: myname_=myname//'*create' character(len=:), allocatable :: mgbf_nml,centralblockname logical :: central @@ -155,6 +167,40 @@ subroutine create(self, comm, config, background, firstguess) ! the previous namelist files could be still used,correctly, ! by the current sdl/vdl enhanced version endif + +! grab the generic handle from an atlas field +afield= firstguess%field(1) +fs_generic = afield%functionspace() +select case (trim(fs_generic%name())) +case ('NodeColumns') + fs_nc = atlas_functionspace_nodecolumns(fs_generic%c_ptr()) + nodes = fs_nc%nodes() + lonlat_field = nodes%lonlat() + call lonlat_field%data(lonlat_ptr) + +case ('PointCloud') + fs_pc = atlas_functionspace_pointcloud(fs_generic%c_ptr()) + lonlat_field = fs_pc%lonlat() + call lonlat_field%data(lonlat_ptr) + +case ('StructuredColumns') + fs_sc = atlas_functionspace_structuredcolumns(fs_generic%c_ptr()) + lonlat_field = fs_sc%xy() + call lonlat_field%data(lonlat_ptr) + +case default + call mpl%abort('mgbf_covariance:get_lonlat', & + 'unsupported Atlas function space: '//fs_generic%name()) +end select + +do ipt = 1, npts_owned + call sphere_dist(lon_ref, lat_ref, lonlat_ptr(1, ipt), lonlat_ptr(2, ipt), dist_rad) + dist_m = dist_rad * req + ! …store or use dist_m as needed… +end do + + + allocate(self%intstate(nscale,nvargrp)) call flush(6) do iscale=1,nscale diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 index b62a66951..1b3666903 100755 --- a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 @@ -176,6 +176,42 @@ module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [getlinesum] !clt write(6,*)'thinkdebss is ',ss(ix) enddo end subroutine getlinesum1 +module subroutine getlinesum1d(this,hx,lx,mx, el, ss) ! [getlinesum] +!============================================================================= +!clt from getlinesum1, just reduce e1 to a 1d array +! 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(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 +!============================================================================= +!clt write(6,*)'thinkdebss Lx,MX = ',Lx, ' ',Mx +do ix=Lx,Mx + s=0 + exx=el(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 +!clt write(6,*)'thinkdebss is ',ss(ix) +enddo +end subroutine getlinesum1d !============================================================================= module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum] !============================================================================= diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index cb08af508..f5ecbc37d 100755 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -989,7 +989,21 @@ module subroutine filtering_fast_bkg(this) !*** call btim(hfiltT_tim) do i=im,1,-1 - call this%rbetaT(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) + do k=1,km3 + lev1=(k-1)*km3+1 + lev2=k*km3 + + call this%rbetaT(lm_f,hy,1,jm,this%paspy4d(k,i,1:jm,1),this%ssy4d(k,i,1:jm,1),VALL(lev1:lev2,i,:)) + enddo + !cltorg call this%rbetaT(km,hy,1,jm,paspy(1,i,1:jm),ssy(1,i,1:jm),VALL(:,i,:)) +!clt assuming 2d variables are suface variable + do k=1,km2 + lev1=lev2+1 + lev2=lev1 + call this%rbetaT(1,hy,1,jm,this%paspy4d(lm_f,i,1:jm,1),this%ssy4d(lm_f,i,1:jm,1),VALL(lev1:lev2,i,:)) + lev1=lev1+1 + lev2=lev2+1 + enddo enddo call etim(hfiltT_tim) call btim(bocoT_tim) @@ -997,7 +1011,21 @@ module subroutine filtering_fast_bkg(this) call etim(bocoT_tim) call btim(hfiltT_tim) do j=jm,1,-1 - call this%rbetaT(km,hx,1,im,paspx,ssx,VALL(:,:,j)) + do k=1,km3 + lev1=(k-1)*km3+1 + lev2=k*km3 + + call this%rbetaT(lm_f,hx,1,im,this%paspx4d(k,1:im,j,1),this%ssx4d(k,1:im,j,1),ALL(lev1:lev2,:,j)) + enddo +!cltorg call this%rbetaT(km,hx,1,im,paspx(1,:,1:im,j),ssx(1,1:im,j),VALL(:,:,j)) +!clt assuming 2d variables are suface variable + do k=1,km2 + lev1=lev2+1 + lev2=lev1 + call this%rbetaT(1,hx,1,im,this%paspx4d(lm_f,1:im,j,1),this%ssx4d(lm_f,1:im,j,1),ALL(lev1:lev2,:,j)) + lev1=lev1+1 + lev2=lev2+1 + enddo enddo call etim(hfiltT_tim) call btim(bocoT_tim) @@ -1006,8 +1034,22 @@ module subroutine filtering_fast_bkg(this) if(l_hgen) then call btim(hfiltT_tim) do i=im,1,-1 - call this%rbetaT(km,hy,1,jm,paspy,ssy,HALL(:,i,:)) + do k=1,km3 + lev1=(k-1)*km3+1 + lev2=k*km3 + + call this%rbetaT(lm_f,hy,1,jm,this%paspy4d(k,i,1:jm,2),this%ssy4d(k,i,1:jm,2),HALL(lev1:lev2,i,:)) + enddo +!clt assuming 2d variables are suface variable + do k=1,km2 + lev1=lev2+1 + lev2=lev1 + call this%rbetaT(1,hy,1,jm,this%paspy4d(lm_f,i,1:jm,2),this%ssy4d(lm_f,i,1:jm,2),HALL(lev1:lev2,i,:)) + lev1=lev1+1 + lev2=lev2+1 + enddo enddo + call etim(hfiltT_tim) endif call btim(bocoT_tim) @@ -1016,7 +1058,20 @@ module subroutine filtering_fast_bkg(this) if(l_hgen) then call btim(hfiltT_tim) do j=jm,1,-1 - call this%rbetaT(km,hx,1,im,paspx,ssx,HALL(:,:,j)) + do k=1,km3 + lev1=(k-1)*km3+1 + lev2=k*km3 + + call this%rbetaT(lm_f,hx,1,im,this%paspx4d(k,1:im,j,2),this%ssx4d(k,1:im,j,2),HALL(lev1:lev2,:,j)) + enddo +!cltorg call this%rbetaT(km,hx,1,im,paspx(:,2),ssx(:,,HALL(:,:,j)) + do k=1,km2 + lev1=lev2+1 + lev2=lev1 + call this%rbetaT(1,hx,1,im,this%paspx4d(lm_f,1:im,j,2),this%ssx4d(lm_f,1:im,j,2),HALL(lev1:lev2,:,j)) + lev1=lev1+1 + lev2=lev2+1 + enddo enddo call etim(hfiltT_tim) endif @@ -1037,7 +1092,20 @@ module subroutine filtering_fast_bkg(this) call etim(boco_tim) call btim(hfilt_tim) do j=1,jm - call this%rbeta(km,hx,1,im,paspx,ssx,VALL(:,:,j)) + do k=1,km3 + lev1=(k-1)*km3+1 + lev2=k*km3 + + call this%rbeta(lm_f,hx,1,im,this%paspx4d(k,1:im,j,1),this%ssx4d(k,1:im,j,1),VALL(lev1:lev2,:,j)) + enddo +!cltorg call this%rbeta(km,hx,1,im,paspx,ssx,VALL(:,:,j)) + do k=1,km2 + lev1=lev2+1 + lev2=lev1 + call this%rbetaT(1,hx,1,im,this%paspx4d(lm_f,1:im,j,1),this%ssx4d(lm_f,1:im,j,1),VALL(lev1:lev2,:,j)) + lev1=lev1+1 + lev2=lev2+1 + enddo enddo call etim(hfilt_tim) call btim(boco_tim) @@ -1045,7 +1113,21 @@ module subroutine filtering_fast_bkg(this) call etim(boco_tim) call btim(hfilt_tim) do i=1,im - call this%rbeta(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) + do k=1,km3 + lev1=(k-1)*km3+1 + lev2=k*km3 + + call this%rbeta(lm_f,hy,1,jm,this%paspy4d(k,i,1:jm,1),this%ssy4d(k,i,1:jm,1),VALL(lev1:lev2,i,:)) + enddo +!cltorg call this%rbeta(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) +!clt assuming 2d variables are suface variable + do k=1,km2 + lev1=lev2+1 + lev2=lev1 + call this%rbeta(1,hy,1,jm,this%paspy4d(lm_f,i,1:jm,1),this%ssy4d(lm_f,i,1:jm,1),VALL(lev1:lev2,i,:)) + lev1=lev1+1 + lev2=lev2+1 + enddo enddo call etim(hfilt_tim) call btim(boco_tim) @@ -1054,7 +1136,20 @@ module subroutine filtering_fast_bkg(this) if(l_hgen) then call btim(hfilt_tim) do j=1,jm - call this%rbeta(km,hx,1,im,paspx,ssx,HALL(:,:,j)) + do k=1,km3 + lev1=(k-1)*km3+1 + lev2=k*km3 + + call this%rbeta(lm_f,hx,1,im,this%paspx4d(k,1:im,j,2),this%ssx4d(k,1:im,j,2),HALL(lev1:lev2,:,j)) + enddo +!cltorg call this%rbeta(km,hx,1,im,paspx,ssx,HALL(:,:,j)) + do k=1,km2 + lev1=lev2+1 + lev2=lev1 + call this%rbeta(1,hx,1,im,this%paspx4d(lm_f,1:im,j,1),this%ssx4d(lm_f,1:im,j,2),HALL(lev1:lev2,:,j)) + lev1=lev1+1 + lev2=lev2+1 + enddo enddo call etim(hfilt_tim) endif @@ -1064,7 +1159,21 @@ module subroutine filtering_fast_bkg(this) if(l_hgen) then call btim(hfilt_tim) do i=1,im - call this%rbeta(km,hy,1,jm,paspy,ssy,HALL(:,i,:)) + do k=1,km3 + lev1=(k-1)*km3+1 + lev2=k*km3 + + call this%rbeta(lm_f,hy,1,jm,this%paspy4d(k,i,1:jm,2),this%ssy4d(k,i,1:jm,2),HALL(lev1:lev2,i,:)) + enddo +!cltorg call this%rbeta(km,hy,1,jm,paspy,ssy,HALL(:,i,:)) +!clt assuming 2d variables are suface variable + do k=1,km2 + lev1=lev2+1 + lev2=lev1 + call this%rbeta(1,hy,1,jm,this%paspy4d(lm_f,i,1:jm,2),this%ssy4d(lm_f,i,1:jm,2),HALL(lev1:lev2,i,:)) + lev1=lev1+1 + lev2=lev2+1 + enddo enddo call etim(hfilt_tim) endif diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 9bb3b1c2c..6b5993bb6 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -65,7 +65,9 @@ module mg_intstate real(r_kind), allocatable,dimension(:,:):: p_rho real(r_kind), allocatable,dimension(:,:,:):: paspx +real(r_kind), allocatable,dimension(:,:,:,:):: paspx4d real(r_kind), allocatable,dimension(:,:,:):: paspy +real(r_kind), allocatable,dimension(:,:,:,:):: paspy4d real(r_kind), allocatable,dimension(:,:,:):: pasp1 real(r_kind), allocatable,dimension(:,:,:,:):: pasp2 real(r_kind), allocatable,dimension(:,:,:,:,:):: pasp3 @@ -76,7 +78,9 @@ module mg_intstate real(r_kind), allocatable,dimension(:,:,:,:):: hss3 real(r_kind), allocatable,dimension(:):: ssx +real(r_kind), allocatable,dimension(:,:,:,:):: ssx4d real(r_kind), allocatable,dimension(:):: ssy +real(r_kind), allocatable,dimension(:,:,:,:):: ssy4d real(r_kind), allocatable,dimension(:):: ss1 real(r_kind), allocatable,dimension(:,:):: ss2 real(r_kind), allocatable,dimension(:,:,:):: ss3 @@ -1128,7 +1132,9 @@ subroutine allocate_mg_intstate(this) 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%paspx4d(this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,2)) ; this%paspx4d=0. allocate(this%paspy(1,1,1:this%jm)) ; this%paspy=0. +allocate(this%paspy4d(this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,2)) ; this%paspy4d=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. @@ -1139,9 +1145,11 @@ subroutine allocate_mg_intstate(this) 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. - +!clt ssx and ssy are all 0 for filtering_fast_bkg, hence, they are not changed for the inhomogeneous case allocate(this%ssx(1:this%im)) ; this%ssx=0. +allocate(this%ssx4d(this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,2)) ; this%ssx=0. allocate(this%ssy(1:this%jm)) ; this%ssy=0. +allocate(this%ssy4d(this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,2)) ; 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. @@ -1400,12 +1408,37 @@ subroutine def_mg_weights(this) 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 +!tothink +!cltorg do i=1,this%im +!cltorg this%paspx(1,1,i)=this%pasp02 +!cltorg enddo + do i=1,this%im + do j=1,this%jm + do k=1,this%lm + this%paspx4d(:,:,:,1)=this%pasp02 !for first generation + enddo + enddo + enddo + + !to initialize halo points + call this%boco_2d(this%paspx4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) + call this%upsending_normalized(this%paspx4d(:,:,:,1),this%paspx4d(:,:,:,2)) + + + +!cltorg do j=1,this%jm +!cltorg this%paspy(1,1,j)=this%pasp02 +!cltorg enddo +!lct this%paspy(:,:,:,1)=this%pasp02 !for first generation + do i=1,this%im + do j=1,this%jm + do k=1,this%lm + this%paspy4d(:,:,:,1)=this%pasp02 !for first generation + enddo + enddo + enddo + !to initialize halo points + call this%boco_2d(this%paspy4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) do j=1,this%jm do i=1,this%im @@ -1476,6 +1509,16 @@ subroutine def_mg_weights(this) 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) + do k=1,this%lm + do j=1,this%jm + call this%getlinesum(this%hx,1,this%im,this%paspx4d(k,1:this%im,j,1),this%ssx4d(k,1:this%im,j,1)) + end do + enddo + do k=1,this%lm + do i=1,this%im + call this%getlinesum(this%hy,1,this%jm,this%paspy4d(k,i,1:this%jm,1),this%ssy4d(k,i,1:this%jm,1)) + end do + enddo 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) @@ -1502,6 +1545,14 @@ subroutine def_mg_weights(this) this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy)=0. end if !cltorg end if + call this%upsending_normalized(this%paspx4d(:,:,:,1),this%paspx4d(:,:,:,2)) + call this%upsending_normalized(this%paspy4d(:,:,:,1),this%paspy4d(:,:,:,2)) + call this%upsending_normalized(this%ssx4d(:,:,:,1),this%ssx4d(:,:,:,2)) + call this%upsending_normalized(this%ssy4d(:,:,:,1),this%ssy4d(:,:,:,2)) + + + + !----------------------------------------------------------------------- endsubroutine def_mg_weights diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 6d1c25ece..21df1e6a3 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -244,8 +244,8 @@ module mg_parameter !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 :: getlinesum => getlinesum1,getlinesum1d,getlinesum2,getlinesum3 + procedure :: getlinesum1,getlinesum1d,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 @@ -327,6 +327,13 @@ module subroutine getlinesum1(this,hx,lx,mx, el, ss) real(dp),dimension(1,1,Lx:Mx),intent(in ):: el real(dp),dimension( lx:mx),intent( out):: ss end subroutine + module subroutine getlinesum1d(this,hx,lx,mx, el, ss) + use mgbf_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( out):: ss + end subroutine module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) use mgbf_kinds, only: dp=>r_kind class(mg_parameter_type)::this diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index 2e6ea9576..039d55f7c 100755 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -477,8 +477,10 @@ module subroutine anal_to_filt(this,WORK) call this%lsqr_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm) endif else - ibm=3 - jbm=3 +!clttothink + ibm=1 + jbm=1 ! to make the following bocoT_2d still work with 0 values of 1 bank of halo points to be + ! exchanged. VALL(1:km_all,1:im,1:jm)=WORK !clt call this%lin_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm) @@ -488,7 +490,8 @@ module subroutine anal_to_filt(this,WORK) !*** !cltthinkdeb555 !clt if(.not.this%l_anal_sub_of_filt) then - call this%bocoT_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) +!cltorg call this%bocoT_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) + call this%bocoT_2d(VALL(1:km_all,1-this%hx:im+this%hx,1-this%hy:jm+this%hy),km_all,im,jm,this%hx,this%hy) !clt endif !---------------------------------------------------------------------- @@ -527,7 +530,8 @@ module subroutine filt_to_anal(this,WORK) !*** !cltthinkdeb255 ! if(.not.this%l_anal_sub_of_filt) then - call this%boco_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) +!cltorg call this%boco_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) + call this%boco_2d(VALL(1:km_all,1-this%hx:im+this%hx,1-this%hy:jm+this%hy),km_all,im,jm,this%hx,this%hy) ! endif if(this%l_anal_sub_of_filt) then WORK(:,:,:)=VALL(:,1:im,1:jm) From 5e768a97302af9d1054c4a25df5a0516110b6f4c Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 27 Oct 2025 19:23:32 -0400 Subject: [PATCH 073/199] WIP --- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index 0bc4e4974..147a917c2 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -2967,7 +2967,7 @@ module subroutine upsend_all_g1 & 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 +integer(i_kind):: g_ind include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" include "type_parameter_point2this.inc" @@ -3268,7 +3268,7 @@ module subroutine upsend_all_gh & logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne,flag_up integer(i_kind):: itarg_up -integer:: g_ind +integer(i_kind):: g_ind include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" include "type_parameter_point2this.inc" @@ -3510,7 +3510,7 @@ module subroutine downsend_all_gh & 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 +integer(i_kind), intent(in):: mygen_up,mygen_dn !----------------------------------------------------------------------- real(r_kind), allocatable, dimension(:,:,:):: & sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & @@ -3775,7 +3775,7 @@ module subroutine downsend_all_g2 & integer(i_kind) isend,irecv,nebpe logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne -integer:: mygen_up,mygen_dn +integer(i_kind):: mygen_up,mygen_dn integer(i_kind):: itarg_up integer(i_kind):: g_ind !----------------------------------------------------------------------- From 0dd0364ae6ba7d41f16a43557618ea6be6b2195a Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 31 Oct 2025 01:35:51 +0000 Subject: [PATCH 074/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 30 ++++-- src/saber/mgbf/mgbf_lib/mg_entrymod.f90 | 12 ++- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 102 ++++++++++++++++-- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 5 + 4 files changed, 129 insertions(+), 20 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index bb6f3075b..594b450de 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -86,6 +86,10 @@ subroutine create(self, comm, config, background, firstguess) type(atlas_fieldset), intent(in) :: firstguess ! Locals +type(atlas_functionspace) :: fs_generic +type(atlas_functionspace_nodecolumns) :: fs_nc +type(atlas_functionspace_pointcloud) :: fs_pc +type(atlas_functionspace_structuredcolumns) :: fs_sc real(r_kind) :: dist_rad, dist_m integer :: ipt @@ -97,7 +101,14 @@ subroutine create(self, comm, config, background, firstguess) integer :: myunit integer :: iscale,ivargrp integer :: nscale=1, nvargrp=1 -type(atlas_field) :: afield +type(atlas_field) :: afield,lonlat_field +type(atlas_mesh_nodes) :: nodes +real,pointer :: lonlat_ptr (:,:) +integer :: npts_owned + + + + character(len=80) :: readin_mgbf_nml_group(99) real :: readin_multigrp_cor(99)=1.0 integer :: readin_iscalegroup(99)=999 @@ -177,27 +188,29 @@ subroutine create(self, comm, config, background, firstguess) nodes = fs_nc%nodes() lonlat_field = nodes%lonlat() call lonlat_field%data(lonlat_ptr) +!clt npts_owned= fs_nc%size_owned() case ('PointCloud') fs_pc = atlas_functionspace_pointcloud(fs_generic%c_ptr()) lonlat_field = fs_pc%lonlat() call lonlat_field%data(lonlat_ptr) +!clt npts_owned= fs_pc%size_owned() case ('StructuredColumns') fs_sc = atlas_functionspace_structuredcolumns(fs_generic%c_ptr()) lonlat_field = fs_sc%xy() call lonlat_field%data(lonlat_ptr) + npts_owned= fs_sc%size_owned() case default - call mpl%abort('mgbf_covariance:get_lonlat', & - 'unsupported Atlas function space: '//fs_generic%name()) + error stop 'mgbf_covariance:get_lonlat & + unsupported Atlas function space: '//fs_generic%name() end select -do ipt = 1, npts_owned - call sphere_dist(lon_ref, lat_ref, lonlat_ptr(1, ipt), lonlat_ptr(2, ipt), dist_rad) - dist_m = dist_rad * req - ! …store or use dist_m as needed… -end do +if (trim(fs_generic%name()).ne."StructuredColumns") then + error stop 'For mgbf filtering grids,only StructuredColumns functionspace is supported now' +endif + @@ -328,6 +341,7 @@ subroutine multiply(self, fields,index_member_in) integer :: n_owned_size integer, pointer :: ghost(:) !clttype(atlas_FunctionSpace) :: fs +type(atlas_functionspace) :: fs_generic type(atlas_functionspace_StructuredColumns) :: fs integer :: ierr real(kind=8) :: val diff --git a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 index 84ee42217..49a62c491 100755 --- a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 @@ -34,7 +34,7 @@ !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -module subroutine mg_initialize(this,inputfilename,obj_parameter) +module subroutine mg_initialize(this,n_owned_anl,anl_lonlat1d,inputfilename,obj_parameter) implicit none !**********************************************************************! ! ! @@ -42,7 +42,10 @@ module subroutine mg_initialize(this,inputfilename,obj_parameter) ! M. Rancic (2020) ! !*********************************************************************** class (mg_intstate_type):: this +integer(i_kind),optional,intent(in)::n_owned_anl +real(r_kind),optional,intent(in)::anl_lonlat1d(:,:) character*(*),optional,intent(in) :: inputfilename + class(mg_parameter_type),optional,intent(in)::obj_parameter !--------------------------------------------------------------------------- @@ -61,6 +64,13 @@ module subroutine mg_initialize(this,inputfilename,obj_parameter) this%mg_parameter_type=obj_parameter endif + if (present(anl_lonlat1d)) then + if (size(anl_lonlat1d,2) /= 2 .or. size(anl_lonlat1d,1) <= n_owned_anl) then + error stop "anl_lonlat1d has wrong shape" + end if + + end if + !**** !**** Initialize MPI !**** diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 6b5993bb6..70a6e2fb5 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -33,6 +33,9 @@ module mg_intstate 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 +use mg_tools,only : interp_analysis_to_filter +use tools_func, only:sphere_dist +use tools_const, only: req implicit none type,extends( mg_parameter_type):: mg_intstate_type real(r_kind), allocatable,dimension(:,:,:):: V @@ -1082,8 +1085,10 @@ module subroutine filt_to_anal(this,WORK) 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) + module subroutine mg_initialize(this,n_owned_anl,anl_lonlat1d,inputfilename,obj_parameter) class (mg_intstate_type):: this + integer(i_kind),intent(in)::n_owned_anl + real(r_kind),intent(in)::anl_lonlat1d(:,:) character*(*),optional,intent(in) :: inputfilename class(mg_parameter_type),optional,intent(in)::obj_parameter end subroutine @@ -1107,6 +1112,9 @@ subroutine allocate_mg_intstate(this) 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. @@ -1240,13 +1248,15 @@ subroutine allocate_mg_intstate(this) endsubroutine allocate_mg_intstate !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& -subroutine def_mg_weights(this) +subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) !*********************************************************************** ! ! ! Define weights and scales ! ! ! implicit none class (mg_intstate_type),target::this +integer(i_kind),optional,intent(in)::n_owned_anl +real(r_kind),optional,intent(in)::lonlat1d_anl(:,:) !*********************************************************************** integer(i_kind):: i,j,k,L @@ -1255,12 +1265,20 @@ subroutine def_mg_weights(this) real(r_kind),allocatable, dimension(:,:,:,:):: loc_a real(r_kind),allocatable, dimension(:,:,:):: weigh_tmp real(r_kind),allocatable, dimension(:):: par_weig_g +real(r_kind),allocatable :: lonlat2d_anl(:,:,:) +real(r_kind),allocatable :: lonlat2d_filt(:,:,:) + ! +! Allocate internal state variables ! +! ! +!*************************************************real(r_kind),allocatable :: lonlat2d_filt(:,:,:) integer :: rank, size, ierr, comm2d integer,allocatable,dimension(:) :: sendcounts, displs integer :: dims(2), periods(2), coords(2) integer(i_kind):: nxloc,nyloc,nz,nt,start_idx,end_idx integer(i_kind):: ig character*72 tmpfilename +real (r_kind)::rtem1 +real (r_kind) :: dist_rad !----------------------------------------------------------------------- start_idx=Lbound(this%weig_var,4) end_idx=Ubound(this%weig_var,4) @@ -1268,6 +1286,23 @@ subroutine def_mg_weights(this) write(6,*)'the expected begin index of weig_var is 1, stop' stop endif + + if (present(lonlat1d_anl)) then + if (size(lonlat1d_anl,2) /= 2 .or. size(lonlat1d_anl,1) /= n_owned_anl) then + error stop "lonlat1d_anl has wrong shape" + end if + this%l_constant_aspt2=.false. + + end if + if (present(n_owned_anl)) then + if(this%nm*this%mm /= n_owned_anl) then + error stop "the input grid number is not as expected , stop " + endif + endif + + + + allocate(sendcounts(this%nxpe*this%nype), displs(this%nxpe*this%nype)) allocate(weigh_tmp(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%weig_var=0. !clt first transform/upsend original mg_weigh_var to their correct locations @@ -1412,21 +1447,15 @@ subroutine def_mg_weights(this) !cltorg do i=1,this%im !cltorg this%paspx(1,1,i)=this%pasp02 !cltorg enddo +if (this%l_constant_aspt2 ) then do i=1,this%im do j=1,this%jm do k=1,this%lm - this%paspx4d(:,:,:,1)=this%pasp02 !for first generation + this%paspx4d(:,:,:,2)=this%pasp02 !for first generation enddo enddo enddo - !to initialize halo points - call this%boco_2d(this%paspx4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) - call this%upsending_normalized(this%paspx4d(:,:,:,1),this%paspx4d(:,:,:,2)) - - - -!cltorg do j=1,this%jm !cltorg this%paspy(1,1,j)=this%pasp02 !cltorg enddo !lct this%paspy(:,:,:,1)=this%pasp02 !for first generation @@ -1437,9 +1466,57 @@ subroutine def_mg_weights(this) enddo enddo enddo + else !clt inhomogeneous and anisotropic aspect tensors !to initialize halo points - call this%boco_2d(this%paspy4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) + !to initialize halo points + + allocate (lonlat2d_anl(this%nm,this%mm,2)) + allocate (lonlat2d_filt(this%im,this%jm,2)) + lonlat2d_anl(:,:,1)=reshape(lonlat1d_anl(:,1),[size(lonlat2d_anl,1),size(lonlat2d_anl,2)]) + lonlat2d_anl(:,:,2)=reshape(lonlat1d_anl(:,2),[size(lonlat2d_anl,1),size(lonlat2d_anl,2)]) + call interp_analysis_to_filter(lonlat2d_anl(:,:,1),this%nm,this%mm,this%im,this%jm,lonlat2d_filt(:,:,1)) + call interp_analysis_to_filter(lonlat2d_anl(:,:,2),this%nm,this%mm,this%im,this%jm,lonlat2d_filt(:,:,2)) + + do j=1,this%jm + do i=1,this%im + if (i.le.this%im-1) then + call sphere_dist(lonlat2d_filt(i,j,1), lonlat2d_filt(i,j,2), lonlat2d_filt(i+1,j,1),lonlat2d_filt(i+1,j,2), dist_rad) + else + call sphere_dist(lonlat2d_filt(i-1,j,1), lonlat2d_filt(i-1,j,2), lonlat2d_filt(i,j,1),lonlat2d_filt(i,j,2), dist_rad) + endif + this%dxfm(i,j)=dist_rad*req + if (j.le.this%jm-1) then + call sphere_dist(lonlat2d_filt(i,j,1), lonlat2d_filt(i,j,2), lonlat2d_filt(i,j+1,1),lonlat2d_filt(i,j+1,2), dist_rad) + else + call sphere_dist(lonlat2d_filt(i,j-1,1), lonlat2d_filt(i,j-1,2), lonlat2d_filt(i,j,1),lonlat2d_filt(i,j,2), dist_rad) + endif + this%dyfm(i,j)=dist_rad*req + enddo + enddo + + rtem1=sqrt(this%pasp02) + + do i=1,this%im + do j=1,this%jm + do k=1,this%lm + this%paspx4d(k,i,j,1)=(rtem1*this%dxfmctrl/this%dxfm(i,j))**2 ! + this%paspy4d(k,i,j,1)=(rtem1*this%dyfmctrl/this%dyfm(i,j))**2 ! + enddo + enddo + enddo + + + + + + call this%boco_2d(this%paspx4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) + call this%upsending_normalized(this%paspx4d(:,:,:,1),this%paspx4d(:,:,:,2)) + call this%boco_2d(this%paspy4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) + call this%upsending_normalized(this%paspy4d(:,:,:,1),this%paspy4d(:,:,:,2)) + deallocate (lonlat2d_anl) + deallocate (lonlat2d_filt) +endif do j=1,this%jm do i=1,this%im this%pasp2(1,1,i,j)=this%pasp02*(1.+this%p_del(i,j)) @@ -1463,6 +1540,8 @@ subroutine def_mg_weights(this) this%pasp3(3,1,i,j,l)=this%pasp03*this%p_rho(i,j) end do end do + + end do @@ -1654,6 +1733,7 @@ subroutine deallocate_mg_intstate(this) endif if (allocated(this%aspect_vert_profile_angrid) ) deallocate( this%aspect_vert_profile_angrid) if (allocated(this%aspect_vert_profile_filtgrid) ) deallocate( this%aspect_vert_profile_filtgrid) +deallocate(this%dxfm,this%dyfm) end subroutine deallocate_mg_intstate diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 21df1e6a3..8288d61b7 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -174,6 +174,9 @@ module mg_parameter real(r_kind):: lengthx,lengthy,xa0,ya0,xf0,yf0 real(r_kind):: dxf,dyf,dxa,dya +real(r_kind),allocatable,dimension (:,:):: dxfm,dyfm ! actual filtering grid intervals in meters +real(r_kind):: dxfmctrl=13000,dyfmctrl=13000 !the control filtering grid intervals corresponding to the contstant horizontal aspect tensor +logical :: l_constant_aspt2 =.true. ! using constant horizontal aspect tensor : ampl02 integer(i_kind):: npadx ! x padding on analysis grid integer(i_kind):: mpady ! y padding on analysis grid @@ -951,10 +954,12 @@ subroutine init_mg_parameter(this,inputfilename) this%dxa =this%lengthx/this%nm this%dxf = this%lengthx/this%im + allocate(this%dxfm(this%im,this%jm)) this%nb = 2*this%dxf/this%dxa this%dya = this%lengthy/this%mm this%dyf = this%lengthy/this%jm + allocate(this%dyfm(this%im,this%jm)) this%mb = 2*this%dyf/this%dya this%xa0 = this%dxa*0.5 From 7c36533052f5edd9732f12152065295b8810c006 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 31 Oct 2025 02:34:46 +0000 Subject: [PATCH 075/199] WIP --- src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 6 +++--- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index f5ecbc37d..78d9c8142 100755 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -964,7 +964,7 @@ module subroutine filtering_fast_bkg(this) !*********************************************************************** implicit none class (mg_intstate_type),target::this -integer(i_kind) L,i,j +integer(i_kind) L,i,j,k,lev1,lev2 include "type_parameter_locpointer.inc" include "type_intstat_locpointer.inc" include "type_parameter_point2this.inc" @@ -1015,14 +1015,14 @@ module subroutine filtering_fast_bkg(this) lev1=(k-1)*km3+1 lev2=k*km3 - call this%rbetaT(lm_f,hx,1,im,this%paspx4d(k,1:im,j,1),this%ssx4d(k,1:im,j,1),ALL(lev1:lev2,:,j)) + call this%rbetaT(lm_f,hx,1,im,this%paspx4d(k,1:im,j,1),this%ssx4d(k,1:im,j,1),VALL(lev1:lev2,:,j)) enddo !cltorg call this%rbetaT(km,hx,1,im,paspx(1,:,1:im,j),ssx(1,1:im,j),VALL(:,:,j)) !clt assuming 2d variables are suface variable do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hx,1,im,this%paspx4d(lm_f,1:im,j,1),this%ssx4d(lm_f,1:im,j,1),ALL(lev1:lev2,:,j)) + call this%rbetaT(1,hx,1,im,this%paspx4d(lm_f,1:im,j,1),this%ssx4d(lm_f,1:im,j,1),VALL(lev1:lev2,:,j)) lev1=lev1+1 lev2=lev2+1 enddo diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 70a6e2fb5..a0794a597 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1087,8 +1087,8 @@ module subroutine filt_to_anal(this,WORK) !from mg_entrymod.f90 module subroutine mg_initialize(this,n_owned_anl,anl_lonlat1d,inputfilename,obj_parameter) class (mg_intstate_type):: this - integer(i_kind),intent(in)::n_owned_anl - real(r_kind),intent(in)::anl_lonlat1d(:,:) + integer(i_kind),optional,intent(in)::n_owned_anl + real(r_kind),optional,intent(in)::anl_lonlat1d(:,:) character*(*),optional,intent(in) :: inputfilename class(mg_parameter_type),optional,intent(in)::obj_parameter end subroutine From 67ec47a4b5558185a9af6107a758a8735b4022b1 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 30 Oct 2025 22:45:28 -0400 Subject: [PATCH 076/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 594b450de..8e53d1f70 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -1,4 +1,4 @@ -! (C) Copyright 2022 United States Government as represented by the Administrator of the National +! (C) Copyright 2022 United States Government as represented by the Administrator of the National ! Aeronautics and Space Administration ! ! This software is licensed under the terms of the Apache Licence Version 2.0 @@ -220,7 +220,7 @@ unsupported Atlas function space: '//fs_generic%name() do ivargrp=1,nvargrp write(6,*)'the999 nml is ', trim(self%mgbf_nml_group(iscale,ivargrp)) call flush(6) - call self%intstate(iscale,ivargrp)%mg_initialize(self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml + call self%intstate(iscale,ivargrp)%mg_initialize(inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml enddo enddo ! Get background (temporary test of the functionality) From b4a5e0d26ccae47f2f1bc1217051bbc61ce662af Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 31 Oct 2025 03:07:23 +0000 Subject: [PATCH 077/199] WIP --- src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 64 ++++++++++++------------ 1 file changed, 32 insertions(+), 32 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index 78d9c8142..b07502f3d 100755 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -990,17 +990,17 @@ module subroutine filtering_fast_bkg(this) call btim(hfiltT_tim) do i=im,1,-1 do k=1,km3 - lev1=(k-1)*km3+1 - lev2=k*km3 + lev1=(k-1)*lm+1 + lev2=k*lm - call this%rbetaT(lm_f,hy,1,jm,this%paspy4d(k,i,1:jm,1),this%ssy4d(k,i,1:jm,1),VALL(lev1:lev2,i,:)) + call this%rbetaT(lm,hy,1,jm,this%paspy4d(:,i,1:jm,1),this%ssy4d(:,i,1:jm,1),VALL(lev1:lev2,i,:)) enddo !cltorg call this%rbetaT(km,hy,1,jm,paspy(1,i,1:jm),ssy(1,i,1:jm),VALL(:,i,:)) !clt assuming 2d variables are suface variable do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hy,1,jm,this%paspy4d(lm_f,i,1:jm,1),this%ssy4d(lm_f,i,1:jm,1),VALL(lev1:lev2,i,:)) + call this%rbetaT(1,hy,1,jm,this%paspy4d(lm,i,1:jm,1),this%ssy4d(lm,i,1:jm,1),VALL(lev1:lev2,i,:)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1012,17 +1012,17 @@ module subroutine filtering_fast_bkg(this) call btim(hfiltT_tim) do j=jm,1,-1 do k=1,km3 - lev1=(k-1)*km3+1 - lev2=k*km3 + lev1=(k-1)*lm+1 + lev2=k*lm - call this%rbetaT(lm_f,hx,1,im,this%paspx4d(k,1:im,j,1),this%ssx4d(k,1:im,j,1),VALL(lev1:lev2,:,j)) + call this%rbetaT(lm,hx,1,im,this%paspx4d(:,1:im,j,1),this%ssx4d(:,1:im,j,1),VALL(lev1:lev2,:,j)) enddo !cltorg call this%rbetaT(km,hx,1,im,paspx(1,:,1:im,j),ssx(1,1:im,j),VALL(:,:,j)) !clt assuming 2d variables are suface variable do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hx,1,im,this%paspx4d(lm_f,1:im,j,1),this%ssx4d(lm_f,1:im,j,1),VALL(lev1:lev2,:,j)) + call this%rbetaT(1,hx,1,im,this%paspx4d(lm,1:im,j,1),this%ssx4d(lm,1:im,j,1),VALL(lev1:lev2,:,j)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1035,16 +1035,16 @@ module subroutine filtering_fast_bkg(this) call btim(hfiltT_tim) do i=im,1,-1 do k=1,km3 - lev1=(k-1)*km3+1 - lev2=k*km3 + lev1=(k-1)*lm+1 + lev2=k*lm - call this%rbetaT(lm_f,hy,1,jm,this%paspy4d(k,i,1:jm,2),this%ssy4d(k,i,1:jm,2),HALL(lev1:lev2,i,:)) + call this%rbetaT(lm,hy,1,jm,this%paspy4d(:,i,1:jm,2),this%ssy4d(:,i,1:jm,2),HALL(lev1:lev2,i,:)) enddo !clt assuming 2d variables are suface variable do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hy,1,jm,this%paspy4d(lm_f,i,1:jm,2),this%ssy4d(lm_f,i,1:jm,2),HALL(lev1:lev2,i,:)) + call this%rbetaT(1,hy,1,jm,this%paspy4d(lm,i,1:jm,2),this%ssy4d(lm,i,1:jm,2),HALL(lev1:lev2,i,:)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1059,16 +1059,16 @@ module subroutine filtering_fast_bkg(this) call btim(hfiltT_tim) do j=jm,1,-1 do k=1,km3 - lev1=(k-1)*km3+1 - lev2=k*km3 + lev1=(k-1)*lm+1 + lev2=k*lm - call this%rbetaT(lm_f,hx,1,im,this%paspx4d(k,1:im,j,2),this%ssx4d(k,1:im,j,2),HALL(lev1:lev2,:,j)) + call this%rbetaT(lm,hx,1,im,this%paspx4d(:,1:im,j,2),this%ssx4d(:,1:im,j,2),HALL(lev1:lev2,:,j)) enddo !cltorg call this%rbetaT(km,hx,1,im,paspx(:,2),ssx(:,,HALL(:,:,j)) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hx,1,im,this%paspx4d(lm_f,1:im,j,2),this%ssx4d(lm_f,1:im,j,2),HALL(lev1:lev2,:,j)) + call this%rbetaT(1,hx,1,im,this%paspx4d(lm,1:im,j,2),this%ssx4d(lm,1:im,j,2),HALL(lev1:lev2,:,j)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1093,16 +1093,16 @@ module subroutine filtering_fast_bkg(this) call btim(hfilt_tim) do j=1,jm do k=1,km3 - lev1=(k-1)*km3+1 - lev2=k*km3 + lev1=(k-1)*lm+1 + lev2=k*lm - call this%rbeta(lm_f,hx,1,im,this%paspx4d(k,1:im,j,1),this%ssx4d(k,1:im,j,1),VALL(lev1:lev2,:,j)) + call this%rbeta(lm,hx,1,im,this%paspx4d(:,1:im,j,1),this%ssx4d(:,1:im,j,1),VALL(lev1:lev2,:,j)) enddo !cltorg call this%rbeta(km,hx,1,im,paspx,ssx,VALL(:,:,j)) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hx,1,im,this%paspx4d(lm_f,1:im,j,1),this%ssx4d(lm_f,1:im,j,1),VALL(lev1:lev2,:,j)) + call this%rbetaT(1,hx,1,im,this%paspx4d(lm,1:im,j,1),this%ssx4d(lm,1:im,j,1),VALL(lev1:lev2,:,j)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1114,17 +1114,17 @@ module subroutine filtering_fast_bkg(this) call btim(hfilt_tim) do i=1,im do k=1,km3 - lev1=(k-1)*km3+1 - lev2=k*km3 + lev1=(k-1)*lm+1 + lev2=k*lm - call this%rbeta(lm_f,hy,1,jm,this%paspy4d(k,i,1:jm,1),this%ssy4d(k,i,1:jm,1),VALL(lev1:lev2,i,:)) + call this%rbeta(lm,hy,1,jm,this%paspy4d(:,i,1:jm,1),this%ssy4d(:,i,1:jm,1),VALL(lev1:lev2,i,:)) enddo !cltorg call this%rbeta(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) !clt assuming 2d variables are suface variable do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbeta(1,hy,1,jm,this%paspy4d(lm_f,i,1:jm,1),this%ssy4d(lm_f,i,1:jm,1),VALL(lev1:lev2,i,:)) + call this%rbeta(1,hy,1,jm,this%paspy4d(lm,i,1:jm,1),this%ssy4d(lm,i,1:jm,1),VALL(lev1:lev2,i,:)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1137,16 +1137,16 @@ module subroutine filtering_fast_bkg(this) call btim(hfilt_tim) do j=1,jm do k=1,km3 - lev1=(k-1)*km3+1 - lev2=k*km3 + lev1=(k-1)*lm+1 + lev2=k*lm - call this%rbeta(lm_f,hx,1,im,this%paspx4d(k,1:im,j,2),this%ssx4d(k,1:im,j,2),HALL(lev1:lev2,:,j)) + call this%rbeta(lm,hx,1,im,this%paspx4d(:,1:im,j,2),this%ssx4d(:,1:im,j,2),HALL(lev1:lev2,:,j)) enddo !cltorg call this%rbeta(km,hx,1,im,paspx,ssx,HALL(:,:,j)) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbeta(1,hx,1,im,this%paspx4d(lm_f,1:im,j,1),this%ssx4d(lm_f,1:im,j,2),HALL(lev1:lev2,:,j)) + call this%rbeta(1,hx,1,im,this%paspx4d(lm,1:im,j,1),this%ssx4d(lm,1:im,j,2),HALL(lev1:lev2,:,j)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1160,17 +1160,17 @@ module subroutine filtering_fast_bkg(this) call btim(hfilt_tim) do i=1,im do k=1,km3 - lev1=(k-1)*km3+1 - lev2=k*km3 + lev1=(k-1)*lm+1 + lev2=k*lm - call this%rbeta(lm_f,hy,1,jm,this%paspy4d(k,i,1:jm,2),this%ssy4d(k,i,1:jm,2),HALL(lev1:lev2,i,:)) + call this%rbeta(lm,hy,1,jm,this%paspy4d(:,i,1:jm,2),this%ssy4d(:,i,1:jm,2),HALL(lev1:lev2,i,:)) enddo !cltorg call this%rbeta(km,hy,1,jm,paspy,ssy,HALL(:,i,:)) !clt assuming 2d variables are suface variable do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbeta(1,hy,1,jm,this%paspy4d(lm_f,i,1:jm,2),this%ssy4d(lm_f,i,1:jm,2),HALL(lev1:lev2,i,:)) + call this%rbeta(1,hy,1,jm,this%paspy4d(lm,i,1:jm,2),this%ssy4d(lm,i,1:jm,2),HALL(lev1:lev2,i,:)) lev1=lev1+1 lev2=lev2+1 enddo From 7d07cc3aa22aa14ba29816476262f9f1a5964f4d Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 31 Oct 2025 03:48:47 +0000 Subject: [PATCH 078/199] WIP --- src/saber/mgbf/mgbf_lib/jp_pbfil.f90 | 78 ++++++++++++++++++++++++ src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 24 ++++++-- 2 files changed, 98 insertions(+), 4 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 index 1b3666903..ace0a6276 100755 --- a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 @@ -404,6 +404,46 @@ module subroutine rbeta1(this,hx,lx,mx, el,ss, a) ! [rbeta] enddo a=b end subroutine rbeta1 +module subroutine rbeta3d_1(this,nz,hx,lx,mx, el,ss, a) ! [rbeta] +!============================================================================= +!clt modified from rbeta1 to treat files of vertical dimension nz +! 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 ):: nz,hx,Lx,mx +real(dp),dimension(nz, Lx:Mx), intent(in ):: el +real(dp),dimension(nz, Lx:Mx), intent(in ):: ss +real(dp),dimension(nz,lx-hx:mx+hx),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nz,lx-hx:mx+hx):: b +real(dp) :: x,tb,s,rr,rrc,frow,exx +integer :: ix,jx,gx,k +!============================================================================= +b=0 +do k=1,nz +do ix=Lx,Mx + tb=0; s=ss(k,ix) + exx=el(k,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(k,jx) + enddo + b(k,ix)=tb +enddo +enddo +a=b +end subroutine rbeta3d_1 !============================================================================= module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] !============================================================================= @@ -673,6 +713,44 @@ module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) ! [rbetat] enddo a=b end subroutine rbeta1t +module subroutine rbeta3d_1T(this,nz,hx,lx,mx, el,ss, a) ! [rbetat] +!clt modified from rbeta1T to add a vertical dimension +!============================================================================= +! 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 )::nz, hx,Lx,mx +real(dp),dimension(nz,Lx:Mx), intent(in ):: el +real(dp),dimension(nz, Lx:Mx), intent(in ):: ss +real(dp),dimension(nz,lx-hx:mx+hx),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nz,lx-hx:mx+hx):: b +real(dp) :: ta,s,rr,rrc,frow,exx,x +integer :: ix,jx,gx,k +!============================================================================= +b=0 +do k=1,nz +do ix=Lx,Mx + ta=a(k,ix); s=ss(k,ix) + exx=el(k,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(k,jx)=b(k,jx)+frow*ta + enddo +enddo +enddo +a=b +end subroutine rbeta3d_1t !============================================================================= module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] !============================================================================= diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 8288d61b7..63e58f53b 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -249,10 +249,10 @@ module mg_parameter procedure,nopass :: cholaspect1,cholaspect2,cholaspect3,cholaspect4 generic :: getlinesum => getlinesum1,getlinesum1d,getlinesum2,getlinesum3 procedure :: getlinesum1,getlinesum1d,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 + generic :: rbeta => rbeta1,rbeta3d_1,rbeta2,rbeta3,rbeta4,vrbeta1,vrbeta2,vrbeta3,vrbeta4 + procedure:: rbeta1,rbeta3d_1,rbeta2,rbeta3,rbeta4,vrbeta1,vrbeta2,vrbeta3,vrbeta4 + generic :: rbetaT => rbeta1t,rbeta3d_1t,rbeta2t,rbeta3t,rbeta4t,vrbeta1t,vrbeta2t,vrbeta3t,vrbeta4t + procedure:: rbeta1t,rbeta3d_1t,rbeta2t,rbeta3t,rbeta4t,vrbeta1t,vrbeta2t,vrbeta3t,vrbeta4t end type mg_parameter_type interface @@ -366,6 +366,14 @@ module subroutine rbeta1(this,hx,lx,mx, el,ss, a) real(dp),dimension(Lx:Mx),intent(in ):: ss real(dp),dimension(lx-hx:mx+hx),intent(inout):: a end subroutine + module subroutine rbeta3d_1(this,nz,hx,lx,mx, el,ss, a) + use mgbf_kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in )::nz, hx,Lx,mx + real(dp),dimension(nz,Lx:Mx),intent(in ):: el + real(dp),dimension(nz,Lx:Mx),intent(in ):: ss + real(dp),dimension(nz,lx-hx:mx+hx),intent(inout):: a + end subroutine module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) use mgbf_kinds, only: dp=>r_kind class(mg_parameter_type)::this @@ -398,6 +406,14 @@ module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) real(dp),dimension( Lx:Mx),intent(in ):: ss real(dp),dimension(lx-hx:mx+hx),intent(inout):: a end subroutine + module subroutine rbeta3d_1T(this,nz,hx,lx,mx, el,ss, a) + use mgbf_kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in )::nz, hx,Lx,mx + real(dp),dimension(nz,Lx:Mx),intent(in ):: el + real(dp),dimension(nz, Lx:Mx),intent(in ):: ss + real(dp),dimension(nz,lx-hx:mx+hx),intent(inout):: a + end subroutine module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) use mgbf_kinds, only: dp=>r_kind class(mg_parameter_type)::this From 5060c919358e378f2218e4b1e34be74f98dd60f7 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 31 Oct 2025 04:15:19 +0000 Subject: [PATCH 079/199] first successfully compiled version for inhomogeneous/anisotropic horziontal aspect tensor --- src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index b07502f3d..74adfd4c4 100755 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -1000,7 +1000,7 @@ module subroutine filtering_fast_bkg(this) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hy,1,jm,this%paspy4d(lm,i,1:jm,1),this%ssy4d(lm,i,1:jm,1),VALL(lev1:lev2,i,:)) + call this%rbetaT(1,hy,1,jm,this%paspy4d(lm:lm,i,1:jm,1),this%ssy4d(lm:lm,i,1:jm,1),VALL(lev1:lev2,i,:)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1022,7 +1022,7 @@ module subroutine filtering_fast_bkg(this) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hx,1,im,this%paspx4d(lm,1:im,j,1),this%ssx4d(lm,1:im,j,1),VALL(lev1:lev2,:,j)) + call this%rbetaT(1,hx,1,im,this%paspx4d(lm:lm,1:im,j,1),this%ssx4d(lm:lm,1:im,j,1),VALL(lev1:lev2,:,j)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1044,7 +1044,7 @@ module subroutine filtering_fast_bkg(this) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hy,1,jm,this%paspy4d(lm,i,1:jm,2),this%ssy4d(lm,i,1:jm,2),HALL(lev1:lev2,i,:)) + call this%rbetaT(1,hy,1,jm,this%paspy4d(lm:lm,i,1:jm,2),this%ssy4d(lm:lm,i,1:jm,2),HALL(lev1:lev2,i,:)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1068,7 +1068,7 @@ module subroutine filtering_fast_bkg(this) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hx,1,im,this%paspx4d(lm,1:im,j,2),this%ssx4d(lm,1:im,j,2),HALL(lev1:lev2,:,j)) + call this%rbetaT(1,hx,1,im,this%paspx4d(lm:lm,1:im,j,2),this%ssx4d(lm:lm,1:im,j,2),HALL(lev1:lev2,:,j)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1102,7 +1102,7 @@ module subroutine filtering_fast_bkg(this) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hx,1,im,this%paspx4d(lm,1:im,j,1),this%ssx4d(lm,1:im,j,1),VALL(lev1:lev2,:,j)) + call this%rbetaT(1,hx,1,im,this%paspx4d(lm:lm,1:im,j,1),this%ssx4d(lm:lm,1:im,j,1),VALL(lev1:lev2,:,j)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1124,7 +1124,7 @@ module subroutine filtering_fast_bkg(this) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbeta(1,hy,1,jm,this%paspy4d(lm,i,1:jm,1),this%ssy4d(lm,i,1:jm,1),VALL(lev1:lev2,i,:)) + call this%rbeta(1,hy,1,jm,this%paspy4d(lm:lm,i,1:jm,1),this%ssy4d(lm:lm,i,1:jm,1),VALL(lev1:lev2,i,:)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1146,7 +1146,7 @@ module subroutine filtering_fast_bkg(this) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbeta(1,hx,1,im,this%paspx4d(lm,1:im,j,1),this%ssx4d(lm,1:im,j,2),HALL(lev1:lev2,:,j)) + call this%rbeta(1,hx,1,im,this%paspx4d(lm:lm,1:im,j,1),this%ssx4d(lm:lm,1:im,j,2),HALL(lev1:lev2,:,j)) lev1=lev1+1 lev2=lev2+1 enddo @@ -1170,7 +1170,7 @@ module subroutine filtering_fast_bkg(this) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbeta(1,hy,1,jm,this%paspy4d(lm,i,1:jm,2),this%ssy4d(lm,i,1:jm,2),HALL(lev1:lev2,i,:)) + call this%rbeta(1,hy,1,jm,this%paspy4d(lm:lm,i,1:jm,2),this%ssy4d(lm:lm,i,1:jm,2),HALL(lev1:lev2,i,:)) lev1=lev1+1 lev2=lev2+1 enddo From b0415535265f6255b7573e19cc1f0c43cbbc21b7 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 31 Oct 2025 19:03:23 +0000 Subject: [PATCH 080/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 30 +++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 8e53d1f70..7c5cd098c 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -125,6 +125,8 @@ subroutine create(self, comm, config, background, firstguess) !clt call self%grid%create(config, comm) self%rank = comm%rank() +write(6,*)'thinkdeb mgbf create999 ' +call flush(6) call config%get_or_die("saber block name", centralblockname) !clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) if (config%has("mgbf sdl and vdl init namelist file")) then @@ -180,15 +182,31 @@ subroutine create(self, comm, config, background, firstguess) endif ! grab the generic handle from an atlas field +write(6,*)'thinkdeb mgbf create999 1 ' +call flush(6) afield= firstguess%field(1) +write(6,*)'thinkdeb mgbf create999 2 ' +call flush(6) fs_generic = afield%functionspace() +write(6,*)'thinkdeb mgbf create999 2.1iname ',trim(fs_generic%name()) +call flush(6) select case (trim(fs_generic%name())) case ('NodeColumns') +write(6,*)'thinkdeb mgbf create999 2.10 ' +call flush(6) fs_nc = atlas_functionspace_nodecolumns(fs_generic%c_ptr()) +write(6,*)'thinkdeb mgbf create999 2.11 ' +call flush(6) nodes = fs_nc%nodes() +write(6,*)'thinkdeb mgbf create999 2.12 ' +call flush(6) lonlat_field = nodes%lonlat() +write(6,*)'thinkdeb mgbf create999 2.13 ' +call flush(6) call lonlat_field%data(lonlat_ptr) !clt npts_owned= fs_nc%size_owned() +write(6,*)'thinkdeb mgbf create999 2.14 ' +call flush(6) case ('PointCloud') fs_pc = atlas_functionspace_pointcloud(fs_generic%c_ptr()) @@ -197,10 +215,20 @@ subroutine create(self, comm, config, background, firstguess) !clt npts_owned= fs_pc%size_owned() case ('StructuredColumns') +write(6,*)'thinkdeb mgbf create999 2.2 ' +call flush(6) fs_sc = atlas_functionspace_structuredcolumns(fs_generic%c_ptr()) +write(6,*)'thinkdeb mgbf create999 2.3 ' +call flush(6) lonlat_field = fs_sc%xy() +write(6,*)'thinkdeb mgbf create999 2.4 ' +call flush(6) call lonlat_field%data(lonlat_ptr) +write(6,*)'thinkdeb mgbf create999 2.5 ' +call flush(6) npts_owned= fs_sc%size_owned() +write(6,*)'thinkdeb mgbf create999 2.6 ' +call flush(6) case default error stop 'mgbf_covariance:get_lonlat & @@ -213,6 +241,8 @@ unsupported Atlas function space: '//fs_generic%name() +write(6,*)'thinkdeb mgbf create999 4 ' +call flush(6) allocate(self%intstate(nscale,nvargrp)) call flush(6) From a540f95424e18127d1dd1af049b7db28b110d087 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 1 Nov 2025 02:11:07 +0000 Subject: [PATCH 081/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 7c5cd098c..5fa4cdd02 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -103,7 +103,7 @@ subroutine create(self, comm, config, background, firstguess) integer :: nscale=1, nvargrp=1 type(atlas_field) :: afield,lonlat_field type(atlas_mesh_nodes) :: nodes -real,pointer :: lonlat_ptr (:,:) +real(r_kind),pointer :: lonlat_ptr (:,:) integer :: npts_owned @@ -204,7 +204,7 @@ subroutine create(self, comm, config, background, firstguess) write(6,*)'thinkdeb mgbf create999 2.13 ' call flush(6) call lonlat_field%data(lonlat_ptr) -!clt npts_owned= fs_nc%size_owned() + npts_owned= fs_nc%size_owned() write(6,*)'thinkdeb mgbf create999 2.14 ' call flush(6) @@ -235,7 +235,7 @@ subroutine create(self, comm, config, background, firstguess) unsupported Atlas function space: '//fs_generic%name() end select -if (trim(fs_generic%name()).ne."StructuredColumns") then +if (trim(fs_generic%name()).ne."StructuredColumns".or.trim(fs_generic%name()).ne."NodeColumns") then error stop 'For mgbf filtering grids,only StructuredColumns functionspace is supported now' endif From 543a17485fc617c99f526966d9ee5e49a976294e Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 31 Oct 2025 23:15:05 -0400 Subject: [PATCH 082/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 57 ++++++------------- 1 file changed, 17 insertions(+), 40 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 5fa4cdd02..21b96a334 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -87,8 +87,6 @@ subroutine create(self, comm, config, background, firstguess) ! Locals type(atlas_functionspace) :: fs_generic -type(atlas_functionspace_nodecolumns) :: fs_nc -type(atlas_functionspace_pointcloud) :: fs_pc type(atlas_functionspace_structuredcolumns) :: fs_sc real(r_kind) :: dist_rad, dist_m integer :: ipt @@ -102,9 +100,10 @@ subroutine create(self, comm, config, background, firstguess) integer :: iscale,ivargrp integer :: nscale=1, nvargrp=1 type(atlas_field) :: afield,lonlat_field -type(atlas_mesh_nodes) :: nodes -real(r_kind),pointer :: lonlat_ptr (:,:) +real(r_kind), pointer, contiguous :: lonlat_ptr(:,:) +real(r_kind), allocatable :: lonlat_anl(:,:) integer :: npts_owned +integer :: npts_total @@ -190,53 +189,28 @@ subroutine create(self, comm, config, background, firstguess) fs_generic = afield%functionspace() write(6,*)'thinkdeb mgbf create999 2.1iname ',trim(fs_generic%name()) call flush(6) -select case (trim(fs_generic%name())) -case ('NodeColumns') -write(6,*)'thinkdeb mgbf create999 2.10 ' -call flush(6) - fs_nc = atlas_functionspace_nodecolumns(fs_generic%c_ptr()) -write(6,*)'thinkdeb mgbf create999 2.11 ' -call flush(6) - nodes = fs_nc%nodes() -write(6,*)'thinkdeb mgbf create999 2.12 ' -call flush(6) - lonlat_field = nodes%lonlat() -write(6,*)'thinkdeb mgbf create999 2.13 ' -call flush(6) - call lonlat_field%data(lonlat_ptr) - npts_owned= fs_nc%size_owned() -write(6,*)'thinkdeb mgbf create999 2.14 ' -call flush(6) - -case ('PointCloud') - fs_pc = atlas_functionspace_pointcloud(fs_generic%c_ptr()) - lonlat_field = fs_pc%lonlat() - call lonlat_field%data(lonlat_ptr) -!clt npts_owned= fs_pc%size_owned() - -case ('StructuredColumns') +if (trim(fs_generic%name()) == 'StructuredColumns') then write(6,*)'thinkdeb mgbf create999 2.2 ' call flush(6) fs_sc = atlas_functionspace_structuredcolumns(fs_generic%c_ptr()) write(6,*)'thinkdeb mgbf create999 2.3 ' call flush(6) - lonlat_field = fs_sc%xy() + lonlat_field = fs_sc%lonlat() write(6,*)'thinkdeb mgbf create999 2.4 ' call flush(6) call lonlat_field%data(lonlat_ptr) write(6,*)'thinkdeb mgbf create999 2.5 ' call flush(6) - npts_owned= fs_sc%size_owned() -write(6,*)'thinkdeb mgbf create999 2.6 ' + npts_owned = fs_sc%size_owned() + npts_total = size(lonlat_ptr,2) + allocate(lonlat_anl(npts_total,2)) + lonlat_anl(:,1) = lonlat_ptr(1,1:npts_total) + lonlat_anl(:,2) = lonlat_ptr(2,1:npts_total) +write(6,*)'thinkdeb mgbf create999 2.6 ',npts_owned,npts_total call flush(6) -case default - error stop 'mgbf_covariance:get_lonlat & - unsupported Atlas function space: '//fs_generic%name() -end select - -if (trim(fs_generic%name()).ne."StructuredColumns".or.trim(fs_generic%name()).ne."NodeColumns") then - error stop 'For mgbf filtering grids,only StructuredColumns functionspace is supported now' +else + error stop 'mgbf_covariance:get_lonlat unsupported Atlas function space: '//fs_generic%name() endif @@ -250,9 +224,12 @@ unsupported Atlas function space: '//fs_generic%name() do ivargrp=1,nvargrp write(6,*)'the999 nml is ', trim(self%mgbf_nml_group(iscale,ivargrp)) call flush(6) - call self%intstate(iscale,ivargrp)%mg_initialize(inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml + call self%intstate(iscale,ivargrp)%mg_initialize(n_owned_anl=npts_owned, & + anl_lonlat1d=lonlat_anl, inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml enddo enddo +if (allocated(lonlat_anl)) deallocate(lonlat_anl) +if (allocated(owned_idx)) deallocate(owned_idx) ! Get background (temporary test of the functionality) !cltafield = background%field('air_temperature') !clt call afield%data(t) From 345481b3c159c39a355241071a22eb6b7e28fb32 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 1 Nov 2025 10:05:16 -0400 Subject: [PATCH 083/199] add MGBF_GeometryBridge part --- src/saber/mgbf/CMakeLists.txt | 112 +++++++++--------- .../mgbf/covariance/mgbf_covariance_mod.f90 | 76 ++++++------ src/saber/mgbf/utils/MGBF_GeometryBridge.cc | 106 +++++++++++++++++ src/saber/mgbf/utils/MGBF_GeometryBridge.h | 28 +++++ 4 files changed, 228 insertions(+), 94 deletions(-) create mode 100644 src/saber/mgbf/utils/MGBF_GeometryBridge.cc create mode 100644 src/saber/mgbf/utils/MGBF_GeometryBridge.h diff --git a/src/saber/mgbf/CMakeLists.txt b/src/saber/mgbf/CMakeLists.txt index 132314786..345e8bae0 100755 --- a/src/saber/mgbf/CMakeLists.txt +++ b/src/saber/mgbf/CMakeLists.txt @@ -1,58 +1,60 @@ -# (C) Copyright 2022 United States Government as represented by the Administrator of the National -# Aeronautics and Space Administration -# -# This software is licensed under the terms of the Apache Licence Version 2.0 -# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -file(GLOB jbfiles mgbf_lib/*.f90) - message(STATUS "thinkdeb-2 " ${jbfiles} ) -set (jbfilenames "") -foreach ( _fname ${jbfiles} ) - get_filename_component( basefilename ${_fname} NAME ) - list ( APPEND jbfilenames mgbf_lib/${basefilename} ) - message(STATUS "thinkdeb-1 " ${basefilename}) - message(STATUS "thinkdeb0 " ${jbfilenames}) -endforeach () -message(STATUS "thinkdeb " ${jbfilenames}) -#set (jbfilenames "mgbf_lib/jp_pbfil.f90" ) -set (build_saber_mgbf 1) -if( build_saber_mgbf ) - list(APPEND mgbf_src_files_list - - # Covariance block - covariance/MGBF_Covariance.h - covariance/MGBF_Covariance.cc +# (C) Copyright 2022 United States Government as represented by the Administrator of the National +# Aeronautics and Space Administration +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +file(GLOB jbfiles mgbf_lib/*.f90) + message(STATUS "thinkdeb-2 " ${jbfiles} ) +set (jbfilenames "") +foreach ( _fname ${jbfiles} ) + get_filename_component( basefilename ${_fname} NAME ) + list ( APPEND jbfilenames mgbf_lib/${basefilename} ) + message(STATUS "thinkdeb-1 " ${basefilename}) + message(STATUS "thinkdeb0 " ${jbfilenames}) +endforeach () +message(STATUS "thinkdeb " ${jbfilenames}) +#set (jbfilenames "mgbf_lib/jp_pbfil.f90" ) +set (build_saber_mgbf 1) +if( build_saber_mgbf ) + list(APPEND mgbf_src_files_list + + # Covariance block + covariance/MGBF_Covariance.h + covariance/MGBF_Covariance.cc covariance/MGBF_Covariance.interface.F90 covariance/MGBF_Covariance.interface.h covariance/mgbf_covariance_mod.f90 - -#clth # Grid -# covariance/mgbf_Grid.h -# covariance/mgbf_Grid.cc - # Interpolation block -# covariance/mgbf_Interpolation.h -# covariance/mgbf_Interpolation.cc -# interpolation/MGBF_Interpolation.h - - # Unstructured interpolation code ported from oops (until new interp code can be used) -# interpolation/unstructured_interp/saber_unstructured_interpolation_mod.F90 -# interpolation/unstructured_interp/UnstructuredInterpolation.cc -# interpolation/unstructured_interp/UnstructuredInterpolation.h -# interpolation/unstructured_interp/UnstructuredInterpolation.interface.F90 -# interpolation/unstructured_interp/UnstructuredInterpolation.interface.h - - # Utilities -# utils/mgbf_utils_mod.f90 - - ) -endif() -#clt find_package(mgbf_lib REQUIRED ) -message (STATUS "thinkdeb1 " ${mgbf_src_files_list} ) - -set( mgbf_src_files - -${mgbf_src_files_list} -${jbfilenames} - -PARENT_SCOPE -) - message (STATUS "thinkdeb2.4" ${mgbf_src_files} ) + utils/MGBF_GeometryBridge.cc + utils/MGBF_GeometryBridge.h + +#clth # Grid +# covariance/mgbf_Grid.h +# covariance/mgbf_Grid.cc + # Interpolation block +# covariance/mgbf_Interpolation.h +# covariance/mgbf_Interpolation.cc +# interpolation/MGBF_Interpolation.h + + # Unstructured interpolation code ported from oops (until new interp code can be used) +# interpolation/unstructured_interp/saber_unstructured_interpolation_mod.F90 +# interpolation/unstructured_interp/UnstructuredInterpolation.cc +# interpolation/unstructured_interp/UnstructuredInterpolation.h +# interpolation/unstructured_interp/UnstructuredInterpolation.interface.F90 +# interpolation/unstructured_interp/UnstructuredInterpolation.interface.h + + # Utilities +# utils/mgbf_utils_mod.f90 + + ) +endif() +#clt find_package(mgbf_lib REQUIRED ) +message (STATUS "thinkdeb1 " ${mgbf_src_files_list} ) + +set( mgbf_src_files + +${mgbf_src_files_list} +${jbfilenames} + +PARENT_SCOPE +) + message (STATUS "thinkdeb2.4" ${mgbf_src_files} ) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 21b96a334..28e62568b 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -31,13 +31,31 @@ module mgbf_covariance_mod !clt use mgbf_grid_mod, only: mgbf_grid use mg_intstate , only: mg_intstate_type use mg_timers -use iso_c_binding +use iso_c_binding, only: c_double, c_int, c_null_ptr, c_ptr use mpi use, intrinsic :: ieee_arithmetic implicit none private public mgbf_covariance +interface + subroutine saber_mgbf_inner_geom_build(conf_ptr, comm_ptr, lonlat_ptr, npts_total, npts_owned, status) & + bind(C, name="saber_mgbf_inner_geom_build") + use iso_c_binding, only: c_ptr, c_int + type(c_ptr), value :: conf_ptr + type(c_ptr), value :: comm_ptr + type(c_ptr) :: lonlat_ptr + integer(c_int) :: npts_total + integer(c_int) :: npts_owned + integer(c_int) :: status + end subroutine saber_mgbf_inner_geom_build + + subroutine saber_mgbf_inner_geom_free(lonlat_ptr) bind(C, name="saber_mgbf_inner_geom_free") + use iso_c_binding, only: c_ptr + type(c_ptr), value :: lonlat_ptr + end subroutine saber_mgbf_inner_geom_free +end interface + ! Fortran class header type :: mgbf_covariance @@ -86,12 +104,8 @@ subroutine create(self, comm, config, background, firstguess) type(atlas_fieldset), intent(in) :: firstguess ! Locals -type(atlas_functionspace) :: fs_generic -type(atlas_functionspace_structuredcolumns) :: fs_sc real(r_kind) :: dist_rad, dist_m integer :: ipt - - character(len=*), parameter :: myname_=myname//'*create' character(len=:), allocatable :: mgbf_nml,centralblockname logical :: central @@ -99,13 +113,12 @@ subroutine create(self, comm, config, background, firstguess) integer :: myunit integer :: iscale,ivargrp integer :: nscale=1, nvargrp=1 -type(atlas_field) :: afield,lonlat_field -real(r_kind), pointer, contiguous :: lonlat_ptr(:,:) +real(c_double), pointer :: lonlat_c_view(:,:) real(r_kind), allocatable :: lonlat_anl(:,:) integer :: npts_owned integer :: npts_total - - +type(c_ptr) :: config_cptr, comm_cptr, lonlat_cptr +integer(c_int) :: n_total_c, n_owned_c, status_c character(len=80) :: readin_mgbf_nml_group(99) @@ -181,38 +194,23 @@ subroutine create(self, comm, config, background, firstguess) endif ! grab the generic handle from an atlas field -write(6,*)'thinkdeb mgbf create999 1 ' -call flush(6) -afield= firstguess%field(1) -write(6,*)'thinkdeb mgbf create999 2 ' -call flush(6) -fs_generic = afield%functionspace() -write(6,*)'thinkdeb mgbf create999 2.1iname ',trim(fs_generic%name()) -call flush(6) -if (trim(fs_generic%name()) == 'StructuredColumns') then -write(6,*)'thinkdeb mgbf create999 2.2 ' -call flush(6) - fs_sc = atlas_functionspace_structuredcolumns(fs_generic%c_ptr()) -write(6,*)'thinkdeb mgbf create999 2.3 ' -call flush(6) - lonlat_field = fs_sc%lonlat() -write(6,*)'thinkdeb mgbf create999 2.4 ' -call flush(6) - call lonlat_field%data(lonlat_ptr) -write(6,*)'thinkdeb mgbf create999 2.5 ' -call flush(6) - npts_owned = fs_sc%size_owned() - npts_total = size(lonlat_ptr,2) - allocate(lonlat_anl(npts_total,2)) - lonlat_anl(:,1) = lonlat_ptr(1,1:npts_total) - lonlat_anl(:,2) = lonlat_ptr(2,1:npts_total) -write(6,*)'thinkdeb mgbf create999 2.6 ',npts_owned,npts_total -call flush(6) - -else - error stop 'mgbf_covariance:get_lonlat unsupported Atlas function space: '//fs_generic%name() +config_cptr = config%c_ptr() +comm_cptr = comm%c_ptr() +lonlat_cptr = c_null_ptr +call saber_mgbf_inner_geom_build(config_cptr, comm_cptr, lonlat_cptr, n_total_c, n_owned_c, status_c) +if (status_c /= 0 .or. lonlat_cptr == c_null_ptr) then + call saber_mgbf_inner_geom_free(lonlat_cptr) + error stop 'Failed to construct inner geometry for MGBF covariance' endif +call c_f_pointer(lonlat_cptr, lonlat_c_view, (/ n_total_c, 2 /)) +npts_total = n_total_c +npts_owned = n_owned_c +allocate(lonlat_anl(npts_total,2)) +lonlat_anl(:,1) = real(lonlat_c_view(:,1), kind=r_kind) +lonlat_anl(:,2) = real(lonlat_c_view(:,2), kind=r_kind) +call saber_mgbf_inner_geom_free(lonlat_cptr) + write(6,*)'thinkdeb mgbf create999 4 ' diff --git a/src/saber/mgbf/utils/MGBF_GeometryBridge.cc b/src/saber/mgbf/utils/MGBF_GeometryBridge.cc new file mode 100644 index 000000000..53ae632b5 --- /dev/null +++ b/src/saber/mgbf/utils/MGBF_GeometryBridge.cc @@ -0,0 +1,106 @@ +#include "saber/mgbf/utils/MGBF_GeometryBridge.h" + +#include +#include + +#include "atlas/array.h" +#include "atlas/functionspace/StructuredColumns.h" +#include "atlas/functionspace/FunctionSpace.h" +#include "atlas/field.h" + +#include "eckit/config/LocalConfiguration.h" +#include "eckit/exception/Exceptions.h" +#include "eckit/log/Log.h" + +#include "fckit/config/Configuration.h" +#include "fckit/mpi/Comm.h" + +#include "saber/interpolation/Geometry.h" + +namespace saber { +namespace mgbf { + +namespace { + +const char *kInnerGeometryKey = "inner geometry"; + +const eckit::Configuration &ensureInnerGeometry(const fckit::Configuration &conf, + std::unique_ptr &holder) { + if (!conf.has(kInnerGeometryKey)) { + throw eckit::BadParameter("inner geometry section missing in SABER configuration"); + } + holder.reset(new eckit::LocalConfiguration(conf.getSubConfiguration(kInnerGeometryKey))); + return *holder; +} + +} // namespace + +extern "C" void saber_mgbf_inner_geom_build(const void *conf_ptr, + const void *comm_ptr, + double **lonlat_out, + int *npts_total_out, + int *npts_owned_out, + int *status_out) { + if (lonlat_out == nullptr || npts_total_out == nullptr || + npts_owned_out == nullptr || status_out == nullptr) { + if (status_out != nullptr) *status_out = 1; + return; + } + + *lonlat_out = nullptr; + *npts_total_out = 0; + *npts_owned_out = 0; + *status_out = 0; + + try { + const auto *conf_wrapper = reinterpret_cast(conf_ptr); + const auto *comm_wrapper = reinterpret_cast(comm_ptr); + + if (conf_wrapper == nullptr || comm_wrapper == nullptr) { + throw eckit::SeriousBug("Null configuration or communicator pointer passed to geometry bridge"); + } + + std::unique_ptr inner_holder; + const eckit::Configuration &inner_conf = ensureInnerGeometry(*conf_wrapper, inner_holder); + + saber::interpolation::Geometry geom(inner_conf, comm_wrapper->mpiComm()); + + const atlas::FunctionSpace &fs = geom.functionSpace(); + if (fs.type() != "StructuredColumns") { + throw eckit::BadParameter("Inner geometry must be StructuredColumns for MGBF"); + } + + atlas::functionspace::StructuredColumns structured(fs); + const atlas::Field lonlatField = structured.lonlat(); + auto lonlatView = atlas::array::make_view(lonlatField); + + const std::size_t npts_total = lonlatView.shape(0); + const std::size_t ncoords = lonlatView.shape(1); + if (ncoords != 2) { + throw eckit::SeriousBug("Unexpected lonlat field rank in geometry bridge"); + } + + std::unique_ptr buffer(new double[npts_total * 2]); + for (std::size_t i = 0; i < npts_total; ++i) { + buffer[i + 0 * npts_total] = lonlatView(i, 0); + buffer[i + 1 * npts_total] = lonlatView(i, 1); + } + + *npts_total_out = static_cast(npts_total); + *npts_owned_out = static_cast(structured.sizeOwned()); + *lonlat_out = buffer.release(); + } catch (const std::exception &e) { + *status_out = 1; + *lonlat_out = nullptr; + *npts_total_out = 0; + *npts_owned_out = 0; + eckit::Log::error() << "saber_mgbf_inner_geom_build: " << e.what() << std::endl; + } +} + +extern "C" void saber_mgbf_inner_geom_free(double *lonlat) { + delete[] lonlat; +} + +} // namespace mgbf +} // namespace saber diff --git a/src/saber/mgbf/utils/MGBF_GeometryBridge.h b/src/saber/mgbf/utils/MGBF_GeometryBridge.h new file mode 100644 index 000000000..46e518b2f --- /dev/null +++ b/src/saber/mgbf/utils/MGBF_GeometryBridge.h @@ -0,0 +1,28 @@ +#pragma once + +#include + +namespace saber { +namespace mgbf { + +/// Build the inner SABER geometry and return lon/lat coordinates together with +/// the number of owned points. +/// \param[in] conf_ptr Pointer to the fckit configuration (C handle) +/// \param[in] comm_ptr Pointer to the fckit MPI communicator (C handle) +/// \param[out] lonlat Newly allocated array of size (npts_total * 2) +/// \param[out] npts_total Total number of grid points (owned + halo) +/// \param[out] npts_owned Number of locally owned grid points +/// \param[out] status 0 on success, non-zero otherwise +extern "C" void saber_mgbf_inner_geom_build(const void *conf_ptr, + const void *comm_ptr, + double **lonlat, + int *npts_total, + int *npts_owned, + int *status); + +/// Release the lon/lat array allocated by saber_mgbf_inner_geom_build. +extern "C" void saber_mgbf_inner_geom_free(double *lonlat); + +} // namespace mgbf +} // namespace saber + From fca9c528c6d48db6c5b1acb7a879b6856589abd0 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 1 Nov 2025 11:41:53 -0400 Subject: [PATCH 084/199] WIP --- src/saber/mgbf/utils/MGBF_GeometryBridge.cc | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/src/saber/mgbf/utils/MGBF_GeometryBridge.cc b/src/saber/mgbf/utils/MGBF_GeometryBridge.cc index 53ae632b5..34ac1922b 100644 --- a/src/saber/mgbf/utils/MGBF_GeometryBridge.cc +++ b/src/saber/mgbf/utils/MGBF_GeometryBridge.cc @@ -4,16 +4,15 @@ #include #include "atlas/array.h" -#include "atlas/functionspace/StructuredColumns.h" -#include "atlas/functionspace/FunctionSpace.h" #include "atlas/field.h" +#include "atlas/functionspace/FunctionSpace.h" +#include "atlas/functionspace/StructuredColumns.h" +#include "eckit/log/Log.h" +#include "eckit/config/Configuration.h" #include "eckit/config/LocalConfiguration.h" #include "eckit/exception/Exceptions.h" -#include "eckit/log/Log.h" - -#include "fckit/config/Configuration.h" -#include "fckit/mpi/Comm.h" +#include "eckit/mpi/Comm.h" #include "saber/interpolation/Geometry.h" @@ -24,7 +23,7 @@ namespace { const char *kInnerGeometryKey = "inner geometry"; -const eckit::Configuration &ensureInnerGeometry(const fckit::Configuration &conf, +const eckit::Configuration &ensureInnerGeometry(const eckit::Configuration &conf, std::unique_ptr &holder) { if (!conf.has(kInnerGeometryKey)) { throw eckit::BadParameter("inner geometry section missing in SABER configuration"); @@ -53,8 +52,8 @@ extern "C" void saber_mgbf_inner_geom_build(const void *conf_ptr, *status_out = 0; try { - const auto *conf_wrapper = reinterpret_cast(conf_ptr); - const auto *comm_wrapper = reinterpret_cast(comm_ptr); + const auto *conf_wrapper = reinterpret_cast(conf_ptr); + const auto *comm_wrapper = reinterpret_cast(comm_ptr); if (conf_wrapper == nullptr || comm_wrapper == nullptr) { throw eckit::SeriousBug("Null configuration or communicator pointer passed to geometry bridge"); @@ -63,7 +62,7 @@ extern "C" void saber_mgbf_inner_geom_build(const void *conf_ptr, std::unique_ptr inner_holder; const eckit::Configuration &inner_conf = ensureInnerGeometry(*conf_wrapper, inner_holder); - saber::interpolation::Geometry geom(inner_conf, comm_wrapper->mpiComm()); + saber::interpolation::Geometry geom(inner_conf, *comm_wrapper); const atlas::FunctionSpace &fs = geom.functionSpace(); if (fs.type() != "StructuredColumns") { From a5c012de5607e885489ef0c575ba667e5953a8f2 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 1 Nov 2025 12:10:09 -0400 Subject: [PATCH 085/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 28e62568b..c8d2c5fdf 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -31,7 +31,7 @@ module mgbf_covariance_mod !clt use mgbf_grid_mod, only: mgbf_grid use mg_intstate , only: mg_intstate_type use mg_timers -use iso_c_binding, only: c_double, c_int, c_null_ptr, c_ptr +use iso_c_binding, only: c_double, c_int, c_null_ptr, c_ptr, c_f_pointer, c_associated use mpi use, intrinsic :: ieee_arithmetic implicit none @@ -113,7 +113,7 @@ subroutine create(self, comm, config, background, firstguess) integer :: myunit integer :: iscale,ivargrp integer :: nscale=1, nvargrp=1 -real(c_double), pointer :: lonlat_c_view(:,:) +real(c_double), pointer :: lonlat_c_view(:,:) => null() real(r_kind), allocatable :: lonlat_anl(:,:) integer :: npts_owned integer :: npts_total @@ -198,14 +198,14 @@ subroutine create(self, comm, config, background, firstguess) comm_cptr = comm%c_ptr() lonlat_cptr = c_null_ptr call saber_mgbf_inner_geom_build(config_cptr, comm_cptr, lonlat_cptr, n_total_c, n_owned_c, status_c) -if (status_c /= 0 .or. lonlat_cptr == c_null_ptr) then +if (status_c /= 0 .or. .not. c_associated(lonlat_cptr)) then call saber_mgbf_inner_geom_free(lonlat_cptr) error stop 'Failed to construct inner geometry for MGBF covariance' endif call c_f_pointer(lonlat_cptr, lonlat_c_view, (/ n_total_c, 2 /)) -npts_total = n_total_c -npts_owned = n_owned_c +npts_total = int(n_total_c, kind=kind(npts_total)) +npts_owned = int(n_owned_c, kind=kind(npts_owned)) allocate(lonlat_anl(npts_total,2)) lonlat_anl(:,1) = real(lonlat_c_view(:,1), kind=r_kind) lonlat_anl(:,2) = real(lonlat_c_view(:,2), kind=r_kind) @@ -227,7 +227,6 @@ subroutine create(self, comm, config, background, firstguess) enddo enddo if (allocated(lonlat_anl)) deallocate(lonlat_anl) -if (allocated(owned_idx)) deallocate(owned_idx) ! Get background (temporary test of the functionality) !cltafield = background%field('air_temperature') !clt call afield%data(t) From 49f1b64787a67e7a2e539ecf7f07cd6d6fb14d86 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 3 Nov 2025 02:47:06 +0000 Subject: [PATCH 086/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index c8d2c5fdf..8cde8eb6e 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -128,6 +128,8 @@ subroutine create(self, comm, config, background, firstguess) integer ::i,j, ii namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup +character(len=:), allocatable :: dump_json + ! Hold communicator ! ----------------- !self%mp_comm_world=comm%communicator() @@ -138,6 +140,9 @@ subroutine create(self, comm, config, background, firstguess) self%rank = comm%rank() write(6,*)'thinkdeb mgbf create999 ' +write(6,*)'thinkdeb mgbf create999 config' + dump_json=config%json() ! serialize to a JSON string +write(6,'(A)')trim(dump_json) call flush(6) call config%get_or_die("saber block name", centralblockname) !clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) From f616af6b2bb320615d5f13bc136cf28a90e7ed63 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sun, 2 Nov 2025 22:54:11 -0500 Subject: [PATCH 087/199] WIP --- src/saber/mgbf/covariance/MGBF_Covariance.h | 2 +- .../covariance/MGBF_Covariance.interface.F90 | 9 ++- .../covariance/MGBF_Covariance.interface.h | 1 + .../mgbf/covariance/mgbf_covariance_mod.f90 | 59 +++++-------------- 4 files changed, 25 insertions(+), 46 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index 9580fda4e..38a6e56b8 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -150,7 +150,7 @@ throw eckit::UserError("doCalibration=.true. is not implemented ", Here()); // Create covariance module //cltwhy not working mgbf_covariance_create_f90(keySelf_, *comm_, params_.MGBFNML.value()->toConfiguration(), mgbf_covariance_create_f90(keySelf_, *comm_, mgbf_config, - xb.get(), fg.get()); + mgbfGridFuncSpace_.get(), xb.get(), fg.get()); oops::Log::trace() << classname() << "::Covariance done" << std::endl; } diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 index b28d5e0d3..5108a3142 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 +++ b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 @@ -50,13 +50,14 @@ module mgbf_covariance_interface_mod ! -------------------------------------------------------------------------------------------------- -subroutine mgbf_covariance_create_cpp(c_self, c_comm, c_conf, c_bg, c_fg) & +subroutine mgbf_covariance_create_cpp(c_self, c_comm, c_conf, c_fs, c_bg, c_fg) & bind(c, name='mgbf_covariance_create_f90') ! Arguments integer(c_int), intent(inout) :: c_self type(c_ptr), value, intent(in) :: c_conf type(c_ptr), value, intent(in) :: c_comm +type(c_ptr), value, intent(in) :: c_fs type(c_ptr), value, intent(in) :: c_bg type(c_ptr), value, intent(in) :: c_fg @@ -64,6 +65,7 @@ subroutine mgbf_covariance_create_cpp(c_self, c_comm, c_conf, c_bg, c_fg) & type(mgbf_covariance), pointer :: f_self type(fckit_mpi_comm) :: f_comm type(fckit_configuration) :: f_conf +type(atlas_functionspace) :: f_fs type(atlas_fieldset) :: f_bg type(atlas_fieldset) :: f_fg @@ -78,12 +80,15 @@ subroutine mgbf_covariance_create_cpp(c_self, c_comm, c_conf, c_bg, c_fg) & ! ------------ f_conf = fckit_configuration(c_conf) f_comm = fckit_mpi_comm(c_comm) +f_fs = atlas_functionspace(c_fs) f_bg = atlas_fieldset(c_bg) f_fg = atlas_fieldset(c_fg) ! Call implementation ! ------------------- -call f_self%create(f_comm, f_conf, f_bg, f_fg) +call f_self%create(f_comm, f_conf, f_fs, f_bg, f_fg) + +call f_fs%final() end subroutine mgbf_covariance_create_cpp diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.h b/src/saber/mgbf/covariance/MGBF_Covariance.interface.h index f31fef70c..b8e3c648a 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.interface.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.interface.h @@ -24,6 +24,7 @@ namespace saber { extern "C" { void mgbf_covariance_create_f90(CovarianceKey &, const eckit::mpi::Comm &, const eckit::Configuration &, + const atlas::functionspace::FunctionSpaceImpl *, const atlas::field::FieldSetImpl *, const atlas::field::FieldSetImpl *); diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 8cde8eb6e..a307e1689 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -1,4 +1,4 @@ -! (C) Copyright 2022 United States Government as represented by the Administrator of the National +! (C) Copyright 2022 United States Government as represented by the Administrator of the National ! Aeronautics and Space Administration ! ! This software is licensed under the terms of the Apache Licence Version 2.0 @@ -31,32 +31,13 @@ module mgbf_covariance_mod !clt use mgbf_grid_mod, only: mgbf_grid use mg_intstate , only: mg_intstate_type use mg_timers -use iso_c_binding, only: c_double, c_int, c_null_ptr, c_ptr, c_f_pointer, c_associated +use iso_c_binding, only: c_ptr use mpi use, intrinsic :: ieee_arithmetic implicit none private public mgbf_covariance -interface - subroutine saber_mgbf_inner_geom_build(conf_ptr, comm_ptr, lonlat_ptr, npts_total, npts_owned, status) & - bind(C, name="saber_mgbf_inner_geom_build") - use iso_c_binding, only: c_ptr, c_int - type(c_ptr), value :: conf_ptr - type(c_ptr), value :: comm_ptr - type(c_ptr) :: lonlat_ptr - integer(c_int) :: npts_total - integer(c_int) :: npts_owned - integer(c_int) :: status - end subroutine saber_mgbf_inner_geom_build - - subroutine saber_mgbf_inner_geom_free(lonlat_ptr) bind(C, name="saber_mgbf_inner_geom_free") - use iso_c_binding, only: c_ptr - type(c_ptr), value :: lonlat_ptr - end subroutine saber_mgbf_inner_geom_free -end interface - - ! Fortran class header type :: mgbf_covariance type(mg_intstate_type),allocatable :: intstate(:,:) @@ -94,12 +75,13 @@ end subroutine saber_mgbf_inner_geom_free ! -------------------------------------------------------------------------------------------------- -subroutine create(self, comm, config, background, firstguess) +subroutine create(self, comm, config, funcspace, background, firstguess) ! Arguments class(mgbf_covariance), intent(inout) :: self type(fckit_mpi_comm), intent(in) :: comm type(fckit_configuration), intent(in) :: config +type(atlas_functionspace), intent(in) :: funcspace type(atlas_fieldset), intent(in) :: background type(atlas_fieldset), intent(in) :: firstguess @@ -113,12 +95,12 @@ subroutine create(self, comm, config, background, firstguess) integer :: myunit integer :: iscale,ivargrp integer :: nscale=1, nvargrp=1 -real(c_double), pointer :: lonlat_c_view(:,:) => null() +type(atlas_field) :: afield, lonlat_field +type(atlas_functionspace_structuredcolumns) :: fs_sc +real(r_kind), pointer :: lonlat_ptr(:,:) real(r_kind), allocatable :: lonlat_anl(:,:) integer :: npts_owned integer :: npts_total -type(c_ptr) :: config_cptr, comm_cptr, lonlat_cptr -integer(c_int) :: n_total_c, n_owned_c, status_c character(len=80) :: readin_mgbf_nml_group(99) @@ -198,25 +180,15 @@ subroutine create(self, comm, config, background, firstguess) ! by the current sdl/vdl enhanced version endif -! grab the generic handle from an atlas field -config_cptr = config%c_ptr() -comm_cptr = comm%c_ptr() -lonlat_cptr = c_null_ptr -call saber_mgbf_inner_geom_build(config_cptr, comm_cptr, lonlat_cptr, n_total_c, n_owned_c, status_c) -if (status_c /= 0 .or. .not. c_associated(lonlat_cptr)) then - call saber_mgbf_inner_geom_free(lonlat_cptr) - error stop 'Failed to construct inner geometry for MGBF covariance' -endif - -call c_f_pointer(lonlat_cptr, lonlat_c_view, (/ n_total_c, 2 /)) -npts_total = int(n_total_c, kind=kind(npts_total)) -npts_owned = int(n_owned_c, kind=kind(npts_owned)) +fs_sc = atlas_functionspace_structuredcolumns(funcspace%c_ptr()) +lonlat_field = fs_sc%lonlat() +call lonlat_field%data(lonlat_ptr) +npts_owned = fs_sc%size_owned() +npts_total = size(lonlat_ptr,2) allocate(lonlat_anl(npts_total,2)) -lonlat_anl(:,1) = real(lonlat_c_view(:,1), kind=r_kind) -lonlat_anl(:,2) = real(lonlat_c_view(:,2), kind=r_kind) -call saber_mgbf_inner_geom_free(lonlat_cptr) - - +lonlat_anl(:,1) = lonlat_ptr(1,1:npts_total) +lonlat_anl(:,2) = lonlat_ptr(2,1:npts_total) +call fs_sc%final() write(6,*)'thinkdeb mgbf create999 4 ' call flush(6) @@ -734,3 +706,4 @@ end function ivar2grp ! -------------------------------------------------------------------------------------------------- end module mgbf_covariance_mod + From bf42e5f9b3f281028d7f1ba70083c14fa8ec7f55 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sun, 2 Nov 2025 23:17:05 -0500 Subject: [PATCH 088/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 1417 +++++++++-------- 1 file changed, 709 insertions(+), 708 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index a307e1689..3604638cc 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -1,709 +1,710 @@ -! (C) Copyright 2022 United States Government as represented by the Administrator of the National -! Aeronautics and Space Administration -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. - -module mgbf_covariance_mod - -! atlas -use atlas_module, only: atlas_fieldset, atlas_field -use atlas_module, only: atlas_functionspace -use atlas_module, only: atlas_functionspace_StructuredColumns -use atlas_module, only : atlas_functionspace, & - atlas_functionspace_nodecolumns, & - atlas_functionspace_pointcloud, & - atlas_functionspace_structuredcolumns, & - atlas_mesh_nodes, atlas_field - -use tools_func, only : sphere_dist -use tools_const, only : req ! Earth radius (m) - -! fckit -use fckit_mpi_module, only: fckit_mpi_comm -use fckit_configuration_module, only: fckit_configuration - -! oops -use mgbf_kinds, only: r_kind,i_kind -use random_mod - -! saber -!clt use mgbf_grid_mod, only: mgbf_grid -use mg_intstate , only: mg_intstate_type -use mg_timers -use iso_c_binding, only: c_ptr -use mpi -use, intrinsic :: ieee_arithmetic -implicit none -private -public mgbf_covariance - -! Fortran class header -type :: mgbf_covariance - type(mg_intstate_type),allocatable :: intstate(:,:) - integer :: nscale=1 - integer :: nvargrp=1 - logical :: noMGBF - logical :: bypassMGBFbe - logical :: cv ! cv=.true.; sv=.false. - integer :: mp_comm_world - integer :: rank - logical :: l_2dvar_last_vertical_level=.true. !when used for localization,2dvars are put on the last vertical level - !when the fields in fset are stored from top to bottom -!clt integer :: lat2,lon2 ! these belog to mgbf_grid - character(len=:), allocatable :: mgbf_nml - character(len=80), allocatable :: mgbf_nml_group(:,:) - real, allocatable :: multigrp_cor(:,:) - integer, allocatable :: iscalegroup(:) - integer, allocatable :: ivargroup(:) - - contains - procedure, public :: create - procedure, public :: delete - procedure, public :: randomize - procedure, public :: multiply - procedure, public :: multiply_ad - procedure, private :: imem2scale - procedure, private :: ivar2grp -end type mgbf_covariance - -character(len=*), parameter :: myname='mgbf_covariance_mod' - -! -------------------------------------------------------------------------------------------------- - -contains - -! -------------------------------------------------------------------------------------------------- - -subroutine create(self, comm, config, funcspace, background, firstguess) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(fckit_mpi_comm), intent(in) :: comm -type(fckit_configuration), intent(in) :: config -type(atlas_functionspace), intent(in) :: funcspace -type(atlas_fieldset), intent(in) :: background -type(atlas_fieldset), intent(in) :: firstguess - -! Locals -real(r_kind) :: dist_rad, dist_m -integer :: ipt -character(len=*), parameter :: myname_=myname//'*create' -character(len=:), allocatable :: mgbf_nml,centralblockname -logical :: central -integer :: layout(2) -integer :: myunit -integer :: iscale,ivargrp -integer :: nscale=1, nvargrp=1 -type(atlas_field) :: afield, lonlat_field -type(atlas_functionspace_structuredcolumns) :: fs_sc -real(r_kind), pointer :: lonlat_ptr(:,:) -real(r_kind), allocatable :: lonlat_anl(:,:) -integer :: npts_owned -integer :: npts_total - - -character(len=80) :: readin_mgbf_nml_group(99) -real :: readin_multigrp_cor(99)=1.0 -integer :: readin_iscalegroup(99)=999 -integer :: readin_ivargroup(99)=999 -integer ::i,j, ii -namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup - -character(len=:), allocatable :: dump_json - -! Hold communicator -! ----------------- -!self%mp_comm_world=comm%communicator() - -! Create the grid -! --------------- -!clt call self%grid%create(config, comm) -self%rank = comm%rank() - -write(6,*)'thinkdeb mgbf create999 ' -write(6,*)'thinkdeb mgbf create999 config' - dump_json=config%json() ! serialize to a JSON string -write(6,'(A)')trim(dump_json) -call flush(6) -call config%get_or_die("saber block name", centralblockname) -!clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) -if (config%has("mgbf sdl and vdl init namelist file")) then - call config%get_or_die("mgbf sdl and vdl init namelist file", mgbf_nml) - open(newunit=myunit,file=trim(mgbf_nml),status='old') -!# open(unit=10,file=mgbf_nml,status='old',action='read') - read(myunit,nml=parameters_mgbf_init) - close(unit=myunit) - self%nscale=nscale - self%nvargrp=nvargrp - allocate(self%mgbf_nml_group(nscale,nvargrp)) - allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship - allocate(self%iscalegroup(nscale) ) - allocate(self%ivargroup(nvargrp) ) - ii=1 - do iscale=1,nscale - do ivargrp=1,nvargrp - self%mgbf_nml_group(iscale,ivargrp)=readin_mgbf_nml_group(ii) - ii=ii+1 - enddo - enddo - do iscale=1,nscale - self%iscalegroup(iscale)=readin_iscalegroup(iscale) - enddo - ii=1 - do i=1,nvargrp - do j=1,nvargrp - self%multigrp_cor(i,j)=readin_multigrp_cor(ii) - ii=ii+1 - enddo - enddo - do i=1,nvargrp - self%ivargroup(i)=readin_ivargroup(iscale) - enddo -else -call config%get_or_die("mgbf namelist file ", mgbf_nml) -!still need allocate them though nscale=nvargrp=1 - allocate(self%mgbf_nml_group(nscale,nvargrp)) - allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship - self%multigrp_cor=1.0 - allocate(self%iscalegroup(nscale) ) - self%iscalegroup(nscale) =1 - allocate(self%ivargroup(nvargrp) ) - self%ivargroup=1 -endif - - -if(nscale == 1 .and. nvargrp ==1 ) then - self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used - !and hence, it would be backward-compatible - ! the previous namelist files could be still used,correctly, - ! by the current sdl/vdl enhanced version -endif - -fs_sc = atlas_functionspace_structuredcolumns(funcspace%c_ptr()) -lonlat_field = fs_sc%lonlat() -call lonlat_field%data(lonlat_ptr) -npts_owned = fs_sc%size_owned() -npts_total = size(lonlat_ptr,2) -allocate(lonlat_anl(npts_total,2)) -lonlat_anl(:,1) = lonlat_ptr(1,1:npts_total) -lonlat_anl(:,2) = lonlat_ptr(2,1:npts_total) -call fs_sc%final() - -write(6,*)'thinkdeb mgbf create999 4 ' -call flush(6) - -allocate(self%intstate(nscale,nvargrp)) -call flush(6) -do iscale=1,nscale - do ivargrp=1,nvargrp - write(6,*)'the999 nml is ', trim(self%mgbf_nml_group(iscale,ivargrp)) - call flush(6) - call self%intstate(iscale,ivargrp)%mg_initialize(n_owned_anl=npts_owned, & - anl_lonlat1d=lonlat_anl, inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml - enddo -enddo -if (allocated(lonlat_anl)) deallocate(lonlat_anl) -! Get background (temporary test of the functionality) -!cltafield = background%field('air_temperature') -!clt call afield%data(t) - -end subroutine create - -! -------------------------------------------------------------------------------------------------- - -subroutine delete(self) - -! Arguments -class(mgbf_covariance) :: self -integer:: iscale,ivargrp - -! Locals - -!clt //if (.not. self%noMGBF) then - call print_mg_timers("mg_timer_output",999,self%rank) - -do iscale=1,self%nscale - do ivargrp=1,self%nvargrp - call self%intstate(iscale,ivargrp)%mg_finalize() - enddo -enddo -!clt endif - -! Delete the grid -! --------------- -!clt call self%grid%delete() - -end subroutine delete - -! -------------------------------------------------------------------------------------------------- - -subroutine randomize(self, fields) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields - -! Locals -type(atlas_field) :: afield -real(kind=r_kind), pointer :: psi(:,:), chi(:,:), t(:,:), q(:,:), qi(:,:), ql(:,:), o3(:,:) -real(kind=r_kind), pointer :: ps(:) - -integer, parameter :: rseed = 3 -write(6,*)'thinkdeb this is to be implemente' -call flush(6) -stop -! Get Atlas field -afield = fields%field('stream_function') -call afield%data(psi) - -afield = fields%field('velocity_potential') -call afield%data(chi) - -afield = fields%field('air_temperature') -call afield%data(t) - -afield = fields%field('surface_pressure') -call afield%data(ps) - -afield = fields%field('specific_humidity') -call afield%data(q) - -afield = fields%field('cloud_liquid_ice') -call afield%data(qi) - -afield = fields%field('cloud_liquid_water') -call afield%data(ql) - -afield = fields%field('ozone_mass_mixing_ratio') -call afield%data(o3) - - -! Set fields to random numbers -call normal_distribution(psi, 0.0_r_kind, 1.0_r_kind, rseed) - - -end subroutine randomize - -! -------------------------------------------------------------------------------------------------- - -subroutine multiply(self, fields,index_member_in) -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields -integer , intent(in) :: index_member_in -type(atlas_fieldset) :: fields_tmp -type(atlas_functionspace) :: afunctionspace - -! Locals -type(atlas_field) :: afield -real(kind=r_kind), pointer :: ptr_2d(:,:) -real(kind=r_kind), pointer :: ptr_3d(:,:,:) -integer(kind=i_kind):: nz,ilev,isize -real(kind=r_kind), allocatable :: work_mgbf(:,:,:) -real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) -real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) -real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) -real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) -real(kind=r_kind), allocatable :: work2d_mgbf(:,:) -real(kind=r_kind), allocatable :: rnormalization(:,:) -integer(kind=i_kind), allocatable :: nlev_vargrp(:) -integer(kind=i_kind) :: dim2d(2),dim3d(3) -integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d -integer(kind=i_kind)::nvar -integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit -integer(kind=i_kind):: n2d -integer(kind=i_kind),allocatable :: varvlev_index(:,:) -logical :: l2d_encountered -logical :: test_once=.false. -integer(kind=i_kind)::itest=0 -character(len=32) :: fileoutput -character(len=4) :: str_rank -integer :: n_owned_size -integer, pointer :: ghost(:) -!clttype(atlas_FunctionSpace) :: fs -type(atlas_functionspace) :: fs_generic -type(atlas_functionspace_StructuredColumns) :: fs -integer :: ierr -real(kind=8) :: val -integer :: member_index -integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp -integer :: total_km_a_all,ii,nvargrp -integer :: ilev1,ilev2 - -!clt now noly consider t -! afield = fields%field('air_temperature') -! call afield%data(t) -!*** From the analysis to first generation of filter grid - member_index=index_member_in+1 ! the privous ensemble index starts from 0) - jscale=self%imem2scale(member_index) - nvargrp=self%nvargrp - call btim(mg_multiply_time) - call btim(mg_preprocess_time) - if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,1)%km2 > 0) then - write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & -& "in which, the first level contains the 2d variables and others zeros " - - stop !to use a better exit procdure - endif - myrank=self%rank - write(str_rank,"(I4.4)")myrank - if(self%intstate(jscale,1)%l_for_localization) then - fileoutput="mgbftest_loc_"//str_rank//".txt" - else - fileoutput="mgbftest_static_"//str_rank//".txt" - endif - - allocate(nlev_vargrp(nvargrp)) - nlev_vargrp=0 - total_km_a_all=0 -!clt do iscale=1,self%nscale - do ivargrp=1,self%nvargrp - if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & - self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then - error stop "for being now, the filtering grids at the start of MGBF should be the same" - endif - total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all - nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all - enddo - - nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps - - n2d=0 - l2d_encountered=.false. - ivargrp0=1 - allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) - allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) - allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) - allocate(rnormalization(total_km_a_all,nvargrp)) - rnormalization=0.0 - work2d_mgbf=0.0 - ii=1 - do ivargrp=1,nvargrp - do k=1,self%intstate(jscale,ivargrp)%km2 -!clt if for localization , km2=0 only for -!clt only for l_2dvar_last_vertical_lev - rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) - ii=ii+1 - enddo -!clt if for localization , km2=0 - do k=1,self%intstate(jscale,ivargrp)%km3 - rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) - ii=ii+nz3d - enddo - enddo - - dim2d=shape(work2d_mgbf) - - dim3d=shape(work_mgbf) - nxloc=dim3d(2) - nyloc=dim3d(3) - nzloc=dim3d(1) - nvar=fields%size() - allocate( varvlev_index(nvar,3)) - varvlev_index=0 - - ilev=1 - do isize=1,fields%size() - - afield= fields%field(isize) !clttodo - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() - if(afield%rank() == 2) then - write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() - nz=afield%levels() - write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz - call afield%data(ptr_2d) - if(nz /= 1 .and. nz /= nz3d ) then - write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d - call flush(6) - stop - endif - - if(nz == 1) then - !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then - if(self%intstate(jscale,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - if(n_owned_size >0 ) then - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d - endif - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - - - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - - if(nz == 1) then - l2d_encountered=.true. - n2d=n2d+1 - endif - if(nz > 1) then - if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then - write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" - call flush(6) - error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending - endif - endif - if(isize==1) then - varvlev_index(isize,1)= 1 - !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then - if(.not.self%intstate(jscale,1)%l_for_localization )then - varvlev_index(isize,2)= nz - else - varvlev_index(isize,2)= nz3d - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - else - !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d - varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 - if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then - varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 - else - varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - endif - jvargrp=self%ivar2grp(isize) - - - ilev=varvlev_index(isize,2)+1 - elseif (afield%rank() == 3) then - write(6,*)'this case needs more work, stop' ! a better exption handling to be added - call flush(6) - stop - call afield%data(ptr_3d) - nz=afield%levels() - work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - stop - endif - enddo - do k=1,nzloc - work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) - enddo - - if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then - write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' - stop ! a better exception handling is to be added - endif - - if(test_once.and..1.gt.2) then - open(iounit,file=trim(fileoutput), status='replace',form="formatted") - write(iounit,*) work_mgbf - test_once=.false. - close(iounit) - endif - ii=1 - do ivargrp=1,nvargrp - allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) - allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) - vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) - - call etim(mg_preprocess_time) - - call btim(mg_anal_to_filt_time) - call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) - call etim(mg_anal_to_filt_time) - call btim(mg_filtering_time) - call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) - call etim(mg_filtering_time) - - !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) - call btim(mg_filt_to_anal_time) - call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) - call etim(mg_filt_to_anal_time) - !clt# work_mgbf=999.0 !thinkdeb for debug - - call btim(mg_postprocess_time) - do k=1,nlev_vargrp(ivargrp) - vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) - enddo - work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) - ii=ii+nlev_vargrp(ivargrp) - deallocate(vargrp_work_mgbf) - deallocate(vargrp_work_mgbf2) - enddo ! ivargrp - if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx - work_mgbf=work_mgbf2 - else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures - allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - work1var_mgbf=0.0 - if(nvargrp == 1 ) then - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) - enddo - do jvar=1,nvar - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - else - do jvar=1,nvar - jvargrp=self%ivar2grp(jvar) - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - ivargrp=self%ivar2grp(ivar) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) - enddo - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - endif - deallocate(work1var_mgbf) - endif - do k=1,nzloc - work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) - enddo - ilev=1 - n_owned_size=0 - do isize=1,fields%size() - - afield=fields%field(isize) !clttodo - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - if(afield%rank() == 2) then - call afield%data(ptr_2d) - nz=afield%levels() - lev1=varvlev_index(isize,1) - if(nz.gt.1) then - if(n_owned_size >0 ) then - ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(self%intstate(1,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - write(6,*)'suspicous situation while n_owned_szie =0 ,stop' - call flush(6) - stop - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - - endif - endif !nz >1 or not - - elseif (afield%rank() == 3) then - call afield%data(ptr_3d) - nz=afield%levels() - write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo - call flush(6) - stop - - - !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - call flush(6) - stop - endif - enddo - - call etim(mg_postprocess_time) - - - - - deallocate(work_mgbf) - deallocate(work_mgbf2) - deallocate(work2d_mgbf) - deallocate(rnormalization) - deallocate( varvlev_index) - !clt enddo !for iscale - call etim(mg_multiply_time) - deallocate(nlev_vargrp) - -end subroutine multiply - -! -------------------------------------------------------------------------------------------------- - -subroutine multiply_ad(self, fields) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields - -! This routine only needed when B = G^T G (sqrt-factored) - -! To do list for this method -! 1. Convert fields (Atlas fieldsets) to MGBF bundle -! 2. Call MGBF covariance operator adjoint (sqrt version) -! afield = fields%field('stream_function') -! call afield%data(var3d) -! var3d=0.0_r_kind - -end subroutine multiply_ad -function imem2scale(self,imem) result(iscale) - class(mgbf_covariance),intent(in)::self - integer, intent(in)::imem - integer :: iscale - iscale=1 - do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) - iscale=iscale+1 - enddo - -end function imem2scale -function ivar2grp(self,ivar) result(jvargrp) - class(mgbf_covariance),intent(in)::self - integer, intent(in)::ivar - integer :: jvargrp - jvargrp=1 - do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) - jvargrp=jvargrp+1 - enddo - -end function ivar2grp - -! -------------------------------------------------------------------------------------------------- - -end module mgbf_covariance_mod +! (C) Copyright 2022 United States Government as represented by the Administrator of the National +! Aeronautics and Space Administration +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + +module mgbf_covariance_mod + +! atlas +use atlas_module, only: atlas_fieldset, atlas_field +use atlas_module, only: atlas_functionspace +use atlas_module, only: atlas_functionspace_StructuredColumns +use atlas_module, only : atlas_functionspace, & + atlas_functionspace_nodecolumns, & + atlas_functionspace_pointcloud, & + atlas_functionspace_structuredcolumns, & + atlas_mesh_nodes, atlas_field + +use tools_func, only : sphere_dist +use tools_const, only : req ! Earth radius (m) + +! fckit +use fckit_mpi_module, only: fckit_mpi_comm +use fckit_configuration_module, only: fckit_configuration + +! oops +use mgbf_kinds, only: r_kind,i_kind +use random_mod + +! saber +!clt use mgbf_grid_mod, only: mgbf_grid +use mg_intstate , only: mg_intstate_type +use mg_timers +use mpi +use, intrinsic :: ieee_arithmetic +implicit none +private +public mgbf_covariance + +! Fortran class header +type :: mgbf_covariance + type(mg_intstate_type),allocatable :: intstate(:,:) + integer :: nscale=1 + integer :: nvargrp=1 + logical :: noMGBF + logical :: bypassMGBFbe + logical :: cv ! cv=.true.; sv=.false. + integer :: mp_comm_world + integer :: rank + logical :: l_2dvar_last_vertical_level=.true. !when used for localization,2dvars are put on the last vertical level + !when the fields in fset are stored from top to bottom +!clt integer :: lat2,lon2 ! these belog to mgbf_grid + character(len=:), allocatable :: mgbf_nml + character(len=80), allocatable :: mgbf_nml_group(:,:) + real, allocatable :: multigrp_cor(:,:) + integer, allocatable :: iscalegroup(:) + integer, allocatable :: ivargroup(:) + + contains + procedure, public :: create + procedure, public :: delete + procedure, public :: randomize + procedure, public :: multiply + procedure, public :: multiply_ad + procedure, private :: imem2scale + procedure, private :: ivar2grp +end type mgbf_covariance + +character(len=*), parameter :: myname='mgbf_covariance_mod' + +! -------------------------------------------------------------------------------------------------- + +contains + +! -------------------------------------------------------------------------------------------------- + +subroutine create(self, comm, config, funcspace, background, firstguess) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(fckit_mpi_comm), intent(in) :: comm +type(fckit_configuration), intent(in) :: config +type(atlas_functionspace), intent(in) :: funcspace +type(atlas_fieldset), intent(in) :: background +type(atlas_fieldset), intent(in) :: firstguess + +! Locals +real(r_kind) :: dist_rad, dist_m +integer :: ipt +character(len=*), parameter :: myname_=myname//'*create' +character(len=:), allocatable :: mgbf_nml,centralblockname +logical :: central +integer :: layout(2) +integer :: myunit +integer :: iscale,ivargrp +integer :: nscale=1, nvargrp=1 +type(atlas_field) :: afield, lonlat_field +type(atlas_functionspace_structuredcolumns) :: fs_sc +real(r_kind), pointer :: lonlat_ptr(:,:) +real(r_kind), allocatable :: lonlat_anl(:,:) +integer :: npts_owned +integer :: npts_total + + +character(len=80) :: readin_mgbf_nml_group(99) +real :: readin_multigrp_cor(99)=1.0 +integer :: readin_iscalegroup(99)=999 +integer :: readin_ivargroup(99)=999 +integer ::i,j, ii +namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup + +character(len=:), allocatable :: dump_json + +! Hold communicator +! ----------------- +!self%mp_comm_world=comm%communicator() + +! Create the grid +! --------------- +!clt call self%grid%create(config, comm) +self%rank = comm%rank() + +write(6,*)'thinkdeb mgbf create999 ' +write(6,*)'thinkdeb mgbf create999 config' + dump_json=config%json() ! serialize to a JSON string +write(6,'(A)')trim(dump_json) +call flush(6) +call config%get_or_die("saber block name", centralblockname) +!clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) +if (config%has("mgbf sdl and vdl init namelist file")) then + call config%get_or_die("mgbf sdl and vdl init namelist file", mgbf_nml) + open(newunit=myunit,file=trim(mgbf_nml),status='old') +!# open(unit=10,file=mgbf_nml,status='old',action='read') + read(myunit,nml=parameters_mgbf_init) + close(unit=myunit) + self%nscale=nscale + self%nvargrp=nvargrp + allocate(self%mgbf_nml_group(nscale,nvargrp)) + allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + allocate(self%iscalegroup(nscale) ) + allocate(self%ivargroup(nvargrp) ) + ii=1 + do iscale=1,nscale + do ivargrp=1,nvargrp + self%mgbf_nml_group(iscale,ivargrp)=readin_mgbf_nml_group(ii) + ii=ii+1 + enddo + enddo + do iscale=1,nscale + self%iscalegroup(iscale)=readin_iscalegroup(iscale) + enddo + ii=1 + do i=1,nvargrp + do j=1,nvargrp + self%multigrp_cor(i,j)=readin_multigrp_cor(ii) + ii=ii+1 + enddo + enddo + do i=1,nvargrp + self%ivargroup(i)=readin_ivargroup(iscale) + enddo +else +call config%get_or_die("mgbf namelist file ", mgbf_nml) +!still need allocate them though nscale=nvargrp=1 + allocate(self%mgbf_nml_group(nscale,nvargrp)) + allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + self%multigrp_cor=1.0 + allocate(self%iscalegroup(nscale) ) + self%iscalegroup(nscale) =1 + allocate(self%ivargroup(nvargrp) ) + self%ivargroup=1 +endif + + +if(nscale == 1 .and. nvargrp ==1 ) then + self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used + !and hence, it would be backward-compatible + ! the previous namelist files could be still used,correctly, + ! by the current sdl/vdl enhanced version +endif + +if (trim(funcspace%name()) /= 'StructuredColumns') then + error stop 'MGBF requires StructuredColumns function space' +end if +fs_sc = funcspace +lonlat_field = fs_sc%xy() +call lonlat_field%data(lonlat_ptr) +npts_owned = fs_sc%size_owned() +npts_total = size(lonlat_ptr,2) +allocate(lonlat_anl(npts_total,2)) +lonlat_anl(:,1) = lonlat_ptr(1,1:npts_total) +lonlat_anl(:,2) = lonlat_ptr(2,1:npts_total) +call lonlat_field%final() + +write(6,*)'thinkdeb mgbf create999 4 ' +call flush(6) + +allocate(self%intstate(nscale,nvargrp)) +call flush(6) +do iscale=1,nscale + do ivargrp=1,nvargrp + write(6,*)'the999 nml is ', trim(self%mgbf_nml_group(iscale,ivargrp)) + call flush(6) + call self%intstate(iscale,ivargrp)%mg_initialize(n_owned_anl=npts_owned, & + anl_lonlat1d=lonlat_anl, inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml + enddo +enddo +if (allocated(lonlat_anl)) deallocate(lonlat_anl) +! Get background (temporary test of the functionality) +!cltafield = background%field('air_temperature') +!clt call afield%data(t) + +end subroutine create + +! -------------------------------------------------------------------------------------------------- + +subroutine delete(self) + +! Arguments +class(mgbf_covariance) :: self +integer:: iscale,ivargrp + +! Locals + +!clt //if (.not. self%noMGBF) then + call print_mg_timers("mg_timer_output",999,self%rank) + +do iscale=1,self%nscale + do ivargrp=1,self%nvargrp + call self%intstate(iscale,ivargrp)%mg_finalize() + enddo +enddo +!clt endif + +! Delete the grid +! --------------- +!clt call self%grid%delete() + +end subroutine delete + +! -------------------------------------------------------------------------------------------------- + +subroutine randomize(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: psi(:,:), chi(:,:), t(:,:), q(:,:), qi(:,:), ql(:,:), o3(:,:) +real(kind=r_kind), pointer :: ps(:) + +integer, parameter :: rseed = 3 +write(6,*)'thinkdeb this is to be implemente' +call flush(6) +stop +! Get Atlas field +afield = fields%field('stream_function') +call afield%data(psi) + +afield = fields%field('velocity_potential') +call afield%data(chi) + +afield = fields%field('air_temperature') +call afield%data(t) + +afield = fields%field('surface_pressure') +call afield%data(ps) + +afield = fields%field('specific_humidity') +call afield%data(q) + +afield = fields%field('cloud_liquid_ice') +call afield%data(qi) + +afield = fields%field('cloud_liquid_water') +call afield%data(ql) + +afield = fields%field('ozone_mass_mixing_ratio') +call afield%data(o3) + + +! Set fields to random numbers +call normal_distribution(psi, 0.0_r_kind, 1.0_r_kind, rseed) + + +end subroutine randomize + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply(self, fields,index_member_in) +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields +integer , intent(in) :: index_member_in +type(atlas_fieldset) :: fields_tmp +type(atlas_functionspace) :: afunctionspace + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: ptr_2d(:,:) +real(kind=r_kind), pointer :: ptr_3d(:,:,:) +integer(kind=i_kind):: nz,ilev,isize +real(kind=r_kind), allocatable :: work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) +real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) +real(kind=r_kind), allocatable :: work2d_mgbf(:,:) +real(kind=r_kind), allocatable :: rnormalization(:,:) +integer(kind=i_kind), allocatable :: nlev_vargrp(:) +integer(kind=i_kind) :: dim2d(2),dim3d(3) +integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d +integer(kind=i_kind)::nvar +integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit +integer(kind=i_kind):: n2d +integer(kind=i_kind),allocatable :: varvlev_index(:,:) +logical :: l2d_encountered +logical :: test_once=.false. +integer(kind=i_kind)::itest=0 +character(len=32) :: fileoutput +character(len=4) :: str_rank +integer :: n_owned_size +integer, pointer :: ghost(:) +!clttype(atlas_FunctionSpace) :: fs +type(atlas_functionspace) :: fs_generic +type(atlas_functionspace_StructuredColumns) :: fs +integer :: ierr +integer :: member_index +integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp +integer :: total_km_a_all,ii,nvargrp +integer :: ilev1,ilev2 + +!clt now noly consider t +! afield = fields%field('air_temperature') +! call afield%data(t) +!*** From the analysis to first generation of filter grid + member_index=index_member_in+1 ! the privous ensemble index starts from 0) + jscale=self%imem2scale(member_index) + nvargrp=self%nvargrp + call btim(mg_multiply_time) + call btim(mg_preprocess_time) + if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,1)%km2 > 0) then + write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & +& "in which, the first level contains the 2d variables and others zeros " + + stop !to use a better exit procdure + endif + myrank=self%rank + write(str_rank,"(I4.4)")myrank + if(self%intstate(jscale,1)%l_for_localization) then + fileoutput="mgbftest_loc_"//str_rank//".txt" + else + fileoutput="mgbftest_static_"//str_rank//".txt" + endif + + allocate(nlev_vargrp(nvargrp)) + nlev_vargrp=0 + total_km_a_all=0 +!clt do iscale=1,self%nscale + do ivargrp=1,self%nvargrp + if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & + self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then + error stop "for being now, the filtering grids at the start of MGBF should be the same" + endif + total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all + nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all + enddo + + nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps + + n2d=0 + l2d_encountered=.false. + ivargrp0=1 + allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) + allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) + allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) + allocate(rnormalization(total_km_a_all,nvargrp)) + rnormalization=0.0 + work2d_mgbf=0.0 + ii=1 + do ivargrp=1,nvargrp + do k=1,self%intstate(jscale,ivargrp)%km2 +!clt if for localization , km2=0 only for +!clt only for l_2dvar_last_vertical_lev + rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) + ii=ii+1 + enddo +!clt if for localization , km2=0 + do k=1,self%intstate(jscale,ivargrp)%km3 + rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) + ii=ii+nz3d + enddo + enddo + + dim2d=shape(work2d_mgbf) + + dim3d=shape(work_mgbf) + nxloc=dim3d(2) + nyloc=dim3d(3) + nzloc=dim3d(1) + nvar=fields%size() + allocate( varvlev_index(nvar,3)) + varvlev_index=0 + + ilev=1 + do isize=1,fields%size() + + afield= fields%field(isize) !clttodo + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() + if(afield%rank() == 2) then + write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() + nz=afield%levels() + write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz + call afield%data(ptr_2d) + if(nz /= 1 .and. nz /= nz3d ) then + write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d + call flush(6) + stop + endif + + if(nz == 1) then + !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + if(n_owned_size >0 ) then + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + endif + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + + + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + + if(nz == 1) then + l2d_encountered=.true. + n2d=n2d+1 + endif + if(nz > 1) then + if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then + write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" + call flush(6) + error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending + endif + endif + if(isize==1) then + varvlev_index(isize,1)= 1 + !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,1)%l_for_localization )then + varvlev_index(isize,2)= nz + else + varvlev_index(isize,2)= nz3d + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + else + !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d + varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 + if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then + varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 + else + varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + endif + jvargrp=self%ivar2grp(isize) + + + ilev=varvlev_index(isize,2)+1 + elseif (afield%rank() == 3) then + write(6,*)'this case needs more work, stop' ! a better exption handling to be added + call flush(6) + stop + call afield%data(ptr_3d) + nz=afield%levels() + work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + stop + endif + enddo + do k=1,nzloc + work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) + enddo + + if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then + write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' + stop ! a better exception handling is to be added + endif + + if(test_once.and..1.gt.2) then + open(iounit,file=trim(fileoutput), status='replace',form="formatted") + write(iounit,*) work_mgbf + test_once=.false. + close(iounit) + endif + ii=1 + do ivargrp=1,nvargrp + allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) + allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) + vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) + + call etim(mg_preprocess_time) + + call btim(mg_anal_to_filt_time) + call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) + call etim(mg_anal_to_filt_time) + call btim(mg_filtering_time) + call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) + call etim(mg_filtering_time) + + !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) + call btim(mg_filt_to_anal_time) + call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) + call etim(mg_filt_to_anal_time) + !clt# work_mgbf=999.0 !thinkdeb for debug + + call btim(mg_postprocess_time) + do k=1,nlev_vargrp(ivargrp) + vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) + enddo + work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) + ii=ii+nlev_vargrp(ivargrp) + deallocate(vargrp_work_mgbf) + deallocate(vargrp_work_mgbf2) + enddo ! ivargrp + if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx + work_mgbf=work_mgbf2 + else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures + allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + work1var_mgbf=0.0 + if(nvargrp == 1 ) then + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) + enddo + do jvar=1,nvar + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + else + do jvar=1,nvar + jvargrp=self%ivar2grp(jvar) + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + ivargrp=self%ivar2grp(ivar) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) + enddo + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + endif + deallocate(work1var_mgbf) + endif + do k=1,nzloc + work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + enddo + ilev=1 + n_owned_size=0 + do isize=1,fields%size() + + afield=fields%field(isize) !clttodo + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + if(afield%rank() == 2) then + call afield%data(ptr_2d) + nz=afield%levels() + lev1=varvlev_index(isize,1) + if(nz.gt.1) then + if(n_owned_size >0 ) then + ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(self%intstate(1,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + write(6,*)'suspicous situation while n_owned_szie =0 ,stop' + call flush(6) + stop + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + + endif + endif !nz >1 or not + + elseif (afield%rank() == 3) then + call afield%data(ptr_3d) + nz=afield%levels() + write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo + call flush(6) + stop + + + !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + call flush(6) + stop + endif + enddo + + call etim(mg_postprocess_time) + + + + + deallocate(work_mgbf) + deallocate(work_mgbf2) + deallocate(work2d_mgbf) + deallocate(rnormalization) + deallocate( varvlev_index) + !clt enddo !for iscale + call etim(mg_multiply_time) + deallocate(nlev_vargrp) + +end subroutine multiply + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply_ad(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! This routine only needed when B = G^T G (sqrt-factored) + +! To do list for this method +! 1. Convert fields (Atlas fieldsets) to MGBF bundle +! 2. Call MGBF covariance operator adjoint (sqrt version) +! afield = fields%field('stream_function') +! call afield%data(var3d) +! var3d=0.0_r_kind + +end subroutine multiply_ad +function imem2scale(self,imem) result(iscale) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::imem + integer :: iscale + iscale=1 + do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) + iscale=iscale+1 + enddo + +end function imem2scale +function ivar2grp(self,ivar) result(jvargrp) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::ivar + integer :: jvargrp + jvargrp=1 + do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) + jvargrp=jvargrp+1 + enddo + +end function ivar2grp + +! -------------------------------------------------------------------------------------------------- + +end module mgbf_covariance_mod From 9bc40de74c72165807246fc521b9d419ecee8654 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 4 Nov 2025 18:16:16 +0000 Subject: [PATCH 089/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 2 + src/saber/mgbf/mgbf_lib/mg_entrymod.f90 | 16 +++++++ src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 47 +++++++++++-------- src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 | 2 + 4 files changed, 48 insertions(+), 19 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 3604638cc..a30390962 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -205,6 +205,8 @@ subroutine create(self, comm, config, funcspace, background, firstguess) anl_lonlat1d=lonlat_anl, inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml enddo enddo +write(6,*)'thinkdeb mgbf create999 10 ' +call flush(6) if (allocated(lonlat_anl)) deallocate(lonlat_anl) ! Get background (temporary test of the functionality) !cltafield = background%field('air_temperature') diff --git a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 index 49a62c491..2bc5c92ed 100755 --- a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 @@ -79,11 +79,15 @@ module subroutine mg_initialize(this,n_owned_anl,anl_lonlat1d,inputfilename,obj_ !*** !*** Initialize integration domain !*** + write(6,*)'thinkdeb in mg_entry, ', 3 + call flush(6) call this%init_mg_domain if(this%l_loc) then call this%init_domain_loc endif + write(6,*)'thinkdeb in mg_entry, ', 4 + call flush(6) !--------------------------------------------------------------------------- ! ! All others are function of km2,km3,km,nm,mm,im,jm @@ -101,20 +105,32 @@ module subroutine mg_initialize(this,n_owned_anl,anl_lonlat1d,inputfilename,obj_ !*** call this%allocate_mg_intstate + write(6,*)'thinkdeb in mg_entry, ', 5 + call flush(6) call this%def_offset_coef + write(6,*)'thinkdeb in mg_entry, ', 6 + call flush(6) call this%def_mg_weights + write(6,*)'thinkdeb in mg_entry, ', 7 + call flush(6) if(this%mgbf_line) then write(6,*)'thinkdeb init_mg_line is called' call this%init_mg_line endif + write(6,*)'thinkdeb in mg_entry, ', 8 + call flush(6) call this%lsqr_mg_coef + write(6,*)'thinkdeb in mg_entry, ', 9 + call flush(6) call this%lwq_vertical_coef(this%lm_a,this%lm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref) + write(6,*)'thinkdeb in mg_entry, ', 10 + call flush(6) !*** !*** Just for testing of standalone version. In GSI WORKA will be given !*** through a separate subroutine diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index a0794a597..97bba7798 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1280,12 +1280,16 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) real (r_kind)::rtem1 real (r_kind) :: dist_rad !----------------------------------------------------------------------- + write(6,*)'thinkdeb in def_mg_weights, ', 01 + call flush(6) start_idx=Lbound(this%weig_var,4) end_idx=Ubound(this%weig_var,4) if(start_idx /=1 ) then write(6,*)'the expected begin index of weig_var is 1, stop' stop endif + write(6,*)'thinkdeb in def_mg_weights, ', 02 + call flush(6) if (present(lonlat1d_anl)) then if (size(lonlat1d_anl,2) /= 2 .or. size(lonlat1d_anl,1) /= n_owned_anl) then @@ -1302,10 +1306,14 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) + write(6,*)'thinkdeb in def_mg_weights, ', 03 + call flush(6) allocate(sendcounts(this%nxpe*this%nype), displs(this%nxpe*this%nype)) allocate(weigh_tmp(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%weig_var=0. !clt first transform/upsend original mg_weigh_var to their correct locations + write(6,*)'thinkdeb in def_mg_weights, ', 04 + call flush(6) if(this%l_mgbf_inhomogeneous ) then if(this%l_mg_weig_readin) then dims=(/this%nxpe,this%nype/) @@ -1397,6 +1405,8 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) !-------------------------------------------------------- gen_fac=1. !cltorg this%a_diff_f(:,:,:)=this%mg_weig1 + write(6,*)'thinkdeb in def_mg_weights, ', 05 + call flush(6) write(tmpfilename, '("mgbf_tmpfile_", I0, ".txt")') this%mype open(12,file=trim(tmpfilename),form="formatted") if(this%l_mgbf_inhomogeneous ) then @@ -1447,28 +1457,22 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) !cltorg do i=1,this%im !cltorg this%paspx(1,1,i)=this%pasp02 !cltorg enddo + write(6,*)'thinkdeb in def_mg_weights, l_constant_aspt2 ', this%l_constant_aspt2 + call flush(6) if (this%l_constant_aspt2 ) then - do i=1,this%im - do j=1,this%jm - do k=1,this%lm - this%paspx4d(:,:,:,2)=this%pasp02 !for first generation - enddo - enddo - enddo - + this%paspx=this%pasp02 + this%paspy=this%pasp02 + this%paspx4d(:,:,:,:)=this%pasp02 !for first generation !cltorg this%paspy(1,1,j)=this%pasp02 !cltorg enddo !lct this%paspy(:,:,:,1)=this%pasp02 !for first generation - do i=1,this%im - do j=1,this%jm - do k=1,this%lm - this%paspy4d(:,:,:,1)=this%pasp02 !for first generation - enddo - enddo - enddo + this%paspy4d(:,:,:,:)=this%pasp02 !for first generation else !clt inhomogeneous and anisotropic aspect tensors !to initialize halo points !to initialize halo points + this%paspx=this%pasp02 + this%paspy=this%pasp02 !paspx and paspy will be replaced by paspx4d/paspy4d when the x/y filter + ! is used ( filtering_fast_bkg ) allocate (lonlat2d_anl(this%nm,this%mm,2)) allocate (lonlat2d_filt(this%im,this%jm,2)) @@ -1510,10 +1514,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) - call this%boco_2d(this%paspx4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) - call this%upsending_normalized(this%paspx4d(:,:,:,1),this%paspx4d(:,:,:,2)) - call this%boco_2d(this%paspy4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) - call this%upsending_normalized(this%paspy4d(:,:,:,1),this%paspy4d(:,:,:,2)) deallocate (lonlat2d_anl) deallocate (lonlat2d_filt) endif @@ -1544,6 +1544,8 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) end do + write(6,*)'thinkdeb in def_mg_weights, ', 08 + call flush(6) !cltorg if(.not.this%mgbf_line) then if(this%nxm*this%nym>1) then @@ -1624,10 +1626,17 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy)=0. end if !cltorg end if + call this%boco_2d(this%paspx4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) call this%upsending_normalized(this%paspx4d(:,:,:,1),this%paspx4d(:,:,:,2)) + call this%boco_2d(this%paspy4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) call this%upsending_normalized(this%paspy4d(:,:,:,1),this%paspy4d(:,:,:,2)) + + call this%boco_2d(this%ssx4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) call this%upsending_normalized(this%ssx4d(:,:,:,1),this%ssx4d(:,:,:,2)) + call this%boco_2d(this%ssy4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) call this%upsending_normalized(this%ssy4d(:,:,:,1),this%ssy4d(:,:,:,2)) + write(6,*)'thinkdeb999 end of def_mg_weights' + call flush(6) diff --git a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 index 5236571ff..4cac6f2fa 100755 --- a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 @@ -148,6 +148,8 @@ module subroutine init_mg_MPI(this) !----------------------------------------------------------------------- ! call MPI_BARRIER(mpi_comm_comp,ierr) + write(6,*)'thinkdeb in mg_mppstuff 3, end of init_mg_MPI ',npes_filt + call flush(6) ! !----------------------------------------------------------------------- endsubroutine init_mg_MPI From 00d3d220492accdbe0c7554d5a4122a403877fd6 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 4 Nov 2025 20:10:41 +0000 Subject: [PATCH 090/199] WIP --- src/saber/mgbf/mgbf_lib/mg_generations.f90 | 23 +++++++++++----------- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 12 +++++------ 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index ec927a38a..8826096ee 100755 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -217,28 +217,29 @@ module subroutine upsending_normalized & ! Then from g2->...->gn (H -> H) ! ! ! !*********************************************************************** -(this,V,H) +(this,nz,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):: nz +real(r_kind),dimension(nz,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(nz,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(nz,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(nz,-1:this%imL+2,-1:this%jmL+2):: H_INT integer(i_kind):: g,L !----------------------------------------------------------------------- ! ! From generation 1 to generation 2 ! write(6,*)'thinkdeb144 before adjoint_nral min/max input ', minval(V),maxval(V) - call this%adjoint_normalized(V(1:this%km,0:this%im+1,0:this%jm+1),V_INT,this%km,1) + call this%adjoint_normalized(V(1:nz,0:this%im+1,0:this%jm+1),V_INT,nz,1) write(6,*)'thinkdeb144 after adjoint_nral min/max output ', minval(V_INT),maxval(V_INT) - call this%bocoT_2d(V_INT,this%km,this%imL,this%jmL,2,2) + call this%bocoT_2d(V_INT,nz,this%imL,this%jmL,2,2) write(6,*)'thinkdeb144 after 2 min/max output ', minval(V_INT),maxval(V_INT) !clttothink - call this%upsend_all(V_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km) + call this%upsend_all(nz,V_INT(1:this%km,1:this%imL,1:this%jmL),H,nz) write(6,*)'thinkdeb144 after 2 min/max output ', minval(H),maxval(H) ! ! From generation 2 sequentially to higher generations @@ -247,14 +248,14 @@ module subroutine upsending_normalized & if(g==this%my_hgen) then write(6,*)'thinkdeb144 before second adjoint min/max input ', minval(H),maxval(H) - call this%adjoint_normalized(H(1:this%km,0:this%im+1,0:this%jm+1),H_INT,this%km,g) + call this%adjoint_normalized(H(1:this%km,0:this%im+1,0:this%jm+1),H_INT,nz,g) write(6,*)'thinkdeb144 after second adjoint min/max input ', minval(H_INT),maxval(H_INT) endif - call this%bocoT_2d(H_INT,this%km,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) + call this%bocoT_2d(H_INT,nz,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) write(6,*)'thinkdeb144 before final upsend_all min/max input ', minval(H_INT),maxval(H_INT) - call this%upsend_all(H_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km,g,g+1) + call this%upsend_all(H_INT(1:this%km,1:this%imL,1:this%jmL),H,nz,g,g+1) write(6,*)'thinkdeb144 after final upsend_all min/max input ', minval(H_INT),maxval(H_INT) end do diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 97bba7798..dca226c13 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1368,7 +1368,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) !clt to convert data in weigt_var to their correct locations do ig=start_idx,end_idx weigh_tmp=this%weig_var(:,:,:,ig) - call this%upsending_normalized(weigh_tmp,this%weig_var(:,:,:,ig)) + call this%upsending_normalized(this%km_all,weigh_tmp,this%weig_var(:,:,:,ig)) enddo deallocate(weig_g,weigh_tmp) @@ -1378,7 +1378,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) do ig=start_idx,end_idx write(6,*)'thinkdeb255 par_weig_g(ig) ',par_weig_g(ig) weigh_tmp=par_weig_g(ig) - call this%upsending_normalized(weigh_tmp,this%weig_var(:,:,:,ig)) + call this%upsending_normalized(this%km_all,weigh_tmp,this%weig_var(:,:,:,ig)) !clto call this%upsending(weigh_tmp,this%weig_var(:,:,:,ig)) enddo @@ -1627,14 +1627,14 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) end if !cltorg end if call this%boco_2d(this%paspx4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) - call this%upsending_normalized(this%paspx4d(:,:,:,1),this%paspx4d(:,:,:,2)) + call this%upsending_normalized(this%lm,this%paspx4d(:,:,:,1),this%paspx4d(:,:,:,2)) call this%boco_2d(this%paspy4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) - call this%upsending_normalized(this%paspy4d(:,:,:,1),this%paspy4d(:,:,:,2)) + call this%upsending_normalized(this%lm,this%paspy4d(:,:,:,1),this%paspy4d(:,:,:,2)) call this%boco_2d(this%ssx4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) - call this%upsending_normalized(this%ssx4d(:,:,:,1),this%ssx4d(:,:,:,2)) + call this%upsending_normalized(this%lm,this%ssx4d(:,:,:,1),this%ssx4d(:,:,:,2)) call this%boco_2d(this%ssy4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) - call this%upsending_normalized(this%ssy4d(:,:,:,1),this%ssy4d(:,:,:,2)) + call this%upsending_normalized(this%lm,this%ssy4d(:,:,:,1),this%ssy4d(:,:,:,2)) write(6,*)'thinkdeb999 end of def_mg_weights' call flush(6) From a393f3dda7aa06befc4c6e3c9a2389db0ed4cf31 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 7 Nov 2025 00:36:47 +0000 Subject: [PATCH 091/199] WIP --- src/saber/mgbf/mgbf_lib/mg_entrymod.f90 | 5 ++++- src/saber/mgbf/mgbf_lib/mg_generations.f90 | 6 +++--- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 20 +++++++++++++------- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 7 +++++++ 4 files changed, 27 insertions(+), 11 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 index 2bc5c92ed..9933c002b 100755 --- a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 @@ -111,8 +111,11 @@ module subroutine mg_initialize(this,n_owned_anl,anl_lonlat1d,inputfilename,obj_ call this%def_offset_coef write(6,*)'thinkdeb in mg_entry, ', 6 call flush(6) - +if(present(n_owned_anl).and.present(anl_lonlat1d)) then +call this%def_mg_weights(n_owned_anl=n_owned_anl,lonlat1d_anl=anl_lonlat1d) +else call this%def_mg_weights +endif write(6,*)'thinkdeb in mg_entry, ', 7 call flush(6) diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index 8826096ee..b73ec4532 100755 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -239,7 +239,7 @@ module subroutine upsending_normalized & write(6,*)'thinkdeb144 after 2 min/max output ', minval(V_INT),maxval(V_INT) !clttothink - call this%upsend_all(nz,V_INT(1:this%km,1:this%imL,1:this%jmL),H,nz) + call this%upsend_all(V_INT(1:nz,1:this%imL,1:this%jmL),H,nz) write(6,*)'thinkdeb144 after 2 min/max output ', minval(H),maxval(H) ! ! From generation 2 sequentially to higher generations @@ -248,14 +248,14 @@ module subroutine upsending_normalized & if(g==this%my_hgen) then write(6,*)'thinkdeb144 before second adjoint min/max input ', minval(H),maxval(H) - call this%adjoint_normalized(H(1:this%km,0:this%im+1,0:this%jm+1),H_INT,nz,g) + call this%adjoint_normalized(H(1:nz,0:this%im+1,0:this%jm+1),H_INT,nz,g) write(6,*)'thinkdeb144 after second adjoint min/max input ', minval(H_INT),maxval(H_INT) endif call this%bocoT_2d(H_INT,nz,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) write(6,*)'thinkdeb144 before final upsend_all min/max input ', minval(H_INT),maxval(H_INT) - call this%upsend_all(H_INT(1:this%km,1:this%imL,1:this%jmL),H,nz,g,g+1) + call this%upsend_all(H_INT(1:nz,1:this%imL,1:this%jmL),H,nz,g,g+1) write(6,*)'thinkdeb144 after final upsend_all min/max input ', minval(H_INT),maxval(H_INT) end do diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index dca226c13..d3c60edbe 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -658,13 +658,14 @@ module subroutine upsending & real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT end subroutine module subroutine upsending_normalized & - (this,V,H) + (this,nz,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):: nz + real(r_kind),dimension(nz,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(nz,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + real(r_kind),dimension(nz,-1:this%imL+2,-1:this%jmL+2):: V_INT + real(r_kind),dimension(nz,-1:this%imL+2,-1:this%jmL+2):: H_INT end subroutine module subroutine downsending & (this,H,V) @@ -1292,16 +1293,21 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) call flush(6) if (present(lonlat1d_anl)) then - if (size(lonlat1d_anl,2) /= 2 .or. size(lonlat1d_anl,1) /= n_owned_anl) then + if (size(lonlat1d_anl,2) /= 2 .or. size(lonlat1d_anl,1) < n_owned_anl) then error stop "lonlat1d_anl has wrong shape" end if - this%l_constant_aspt2=.false. + else + this%l_constant_aspt2=.true. end if + write(6,*)'thinkdeb in def_mg_weights, changed l_constant_aspt2 ', this%l_constant_aspt2 if (present(n_owned_anl)) then if(this%nm*this%mm /= n_owned_anl) then error stop "the input grid number is not as expected , stop " endif + else + this%l_constant_aspt2=.true. + endif diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 63e58f53b..60dc86635 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -536,6 +536,8 @@ subroutine init_mg_parameter(this,inputfilename) !clthhhreal(r_kind):: coef_normalization(lm_max)=1.0 !normalizaton coefficients real(r_kind):: coef_normalization(lm_max)=1 !normalizaton coefficients real(r_kind):: coef_normalization_const=-9999.0 ! constant, if set, this contant will be +real(r_kind):: dxfmctrl=13000,dyfmctrl=13000 !the control filtering grid intervals corresponding to the contstant horizontal aspect tensor +logical :: l_constant_aspt2 =.true. ! using constant horizontal aspect tensor : ampl02 character(len=256) ::file_coef_normalization="XXXX" integer(i_kind):: km2 ! number of 2d variables for filtering integer(i_kind):: km3 ! number of 3d variables for filtering @@ -570,6 +572,8 @@ subroutine init_mg_parameter(this,inputfilename) ,lm_a,lm,coef_normalization & ,coef_normalization_const & ,file_coef_normalization & + , dxfmctrl,dyfmctrl & + , l_constant_aspt2 & ,km2,km3 & ,n_ens & ,l_loc & @@ -652,6 +656,9 @@ subroutine init_mg_parameter(this,inputfilename) this%coef_normalization=coef_normalization + this%dxfmctrl=dxfmctrl; this%dyfmctrl=dyfmctrl + write(6,*)'thinkdeb999 readin l_constant_aspt2 ',l_constant_aspt2 + this%l_constant_aspt2 = l_constant_aspt2 this%km2=km2 this%km3=km3 this%n_ens=n_ens From 4edabb98083b4cb69ce515264e31e788472e13e6 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 8 Nov 2025 03:53:53 +0000 Subject: [PATCH 092/199] WIP --- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 27 ++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index d3c60edbe..4e4061617 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -33,7 +33,7 @@ module mg_intstate 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 -use mg_tools,only : interp_analysis_to_filter +use mg_tools,only : interp_analysis_to_filter,mg_sphere_dist use tools_func, only:sphere_dist use tools_const, only: req implicit none @@ -1484,21 +1484,29 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) allocate (lonlat2d_filt(this%im,this%jm,2)) lonlat2d_anl(:,:,1)=reshape(lonlat1d_anl(:,1),[size(lonlat2d_anl,1),size(lonlat2d_anl,2)]) lonlat2d_anl(:,:,2)=reshape(lonlat1d_anl(:,2),[size(lonlat2d_anl,1),size(lonlat2d_anl,2)]) + if(this%mype.eq.0) then + open(13,file='latlon.txt',form="formatted") + write(13,*)"lon " + write(13,*)lonlat2d_anl(:,:,1) + write(13,*)"lat " + write(13,*)lonlat2d_anl(:,:,2) + endif + stop call interp_analysis_to_filter(lonlat2d_anl(:,:,1),this%nm,this%mm,this%im,this%jm,lonlat2d_filt(:,:,1)) call interp_analysis_to_filter(lonlat2d_anl(:,:,2),this%nm,this%mm,this%im,this%jm,lonlat2d_filt(:,:,2)) do j=1,this%jm do i=1,this%im if (i.le.this%im-1) then - call sphere_dist(lonlat2d_filt(i,j,1), lonlat2d_filt(i,j,2), lonlat2d_filt(i+1,j,1),lonlat2d_filt(i+1,j,2), dist_rad) + call mg_sphere_dist(lonlat2d_filt(i,j,1), lonlat2d_filt(i,j,2), lonlat2d_filt(i+1,j,1),lonlat2d_filt(i+1,j,2), dist_rad) else - call sphere_dist(lonlat2d_filt(i-1,j,1), lonlat2d_filt(i-1,j,2), lonlat2d_filt(i,j,1),lonlat2d_filt(i,j,2), dist_rad) + call mg_sphere_dist(lonlat2d_filt(i-1,j,1), lonlat2d_filt(i-1,j,2), lonlat2d_filt(i,j,1),lonlat2d_filt(i,j,2), dist_rad) endif this%dxfm(i,j)=dist_rad*req if (j.le.this%jm-1) then - call sphere_dist(lonlat2d_filt(i,j,1), lonlat2d_filt(i,j,2), lonlat2d_filt(i,j+1,1),lonlat2d_filt(i,j+1,2), dist_rad) + call mg_sphere_dist(lonlat2d_filt(i,j,1), lonlat2d_filt(i,j,2), lonlat2d_filt(i,j+1,1),lonlat2d_filt(i,j+1,2), dist_rad) else - call sphere_dist(lonlat2d_filt(i,j-1,1), lonlat2d_filt(i,j-1,2), lonlat2d_filt(i,j,1),lonlat2d_filt(i,j,2), dist_rad) + call mg_sphere_dist(lonlat2d_filt(i,j-1,1), lonlat2d_filt(i,j-1,2), lonlat2d_filt(i,j,1),lonlat2d_filt(i,j,2), dist_rad) endif this%dyfm(i,j)=dist_rad*req enddo @@ -1508,12 +1516,13 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) do i=1,this%im do j=1,this%jm - do k=1,this%lm - this%paspx4d(k,i,j,1)=(rtem1*this%dxfmctrl/this%dxfm(i,j))**2 ! - this%paspy4d(k,i,j,1)=(rtem1*this%dyfmctrl/this%dyfm(i,j))**2 ! - enddo + write(6,*)'thinkdebx99999 dxfm/dyfm = ',this%dxfm(i,j) + write(6,*)'thinkdebx99999 dxfm/dyfm = ',this%dxfm(i,j) + this%paspx4d(1,i,j,1)=(rtem1*this%dxfmctrl/this%dxfm(i,j))**2 ! + this%paspy4d(1,i,j,1)=(rtem1*this%dyfmctrl/this%dyfm(i,j))**2 ! enddo enddo + this%paspx4d(2:this%lm,:,:,1)=spread(this%paspx4d(1,:,:,1),dim=1,ncopies=this%lm-1) From 7b752ad03a0276e87c59472b1bb70412494c5353 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 13 Nov 2025 20:17:37 +0000 Subject: [PATCH 093/199] the inhomogeneous function passed a dirac sainity test --- src/saber/mgbf/mgbf_lib/jp_pbfil.f90 | 10 ++++++-- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 29 ++++++++++++++++-------- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 4 ++-- 3 files changed, 30 insertions(+), 13 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 index ace0a6276..f730d06bb 100755 --- a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 @@ -61,6 +61,7 @@ use mpi use mgbf_kinds, only: dp=>r_kind use jp_pietc, only: u1 +use, intrinsic :: iso_fortran_env, only: output_unit, error_unit implicit none contains @@ -201,8 +202,13 @@ module subroutine getlinesum1d(this,hx,lx,mx, el, ss) ! [getlinesum] exx=el(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' + if(gxl<-hx.or.gxm>hx) then + write(error_unit,*) 'thinkdeb7777 exx =',exx,' ',this%rmom2_1,' ',hx,' ',el(ix) + call flush(error_unit) + write(error_unit,*) 'In getlinesum1dxx; filter reach fx becomes too large for hx' + call flush(error_unit) + stop 'In getlinesum1d; filter reach becomes too large for hy' + endif do gx=gxl,gxm x=gx rr=(x*exx)**2; rrc=u1-rr diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 4e4061617..d25a255bf 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -35,7 +35,7 @@ module mg_intstate use mg_parameter,only: mg_parameter_type use mg_tools,only : interp_analysis_to_filter,mg_sphere_dist use tools_func, only:sphere_dist -use tools_const, only: req +use tools_const, only: req,deg2rad implicit none type,extends( mg_parameter_type):: mg_intstate_type real(r_kind), allocatable,dimension(:,:,:):: V @@ -1281,7 +1281,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) real (r_kind)::rtem1 real (r_kind) :: dist_rad !----------------------------------------------------------------------- - write(6,*)'thinkdeb in def_mg_weights, ', 01 + write(6,*)'thinkdeb in def_mg_weights, 01' call flush(6) start_idx=Lbound(this%weig_var,4) end_idx=Ubound(this%weig_var,4) @@ -1289,7 +1289,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) write(6,*)'the expected begin index of weig_var is 1, stop' stop endif - write(6,*)'thinkdeb in def_mg_weights, ', 02 + write(6,*)'thinkdeb in def_mg_weights, 02' call flush(6) if (present(lonlat1d_anl)) then @@ -1312,13 +1312,13 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) - write(6,*)'thinkdeb in def_mg_weights, ', 03 + write(6,*)'thinkdeb in def_mg_weights, 03' call flush(6) allocate(sendcounts(this%nxpe*this%nype), displs(this%nxpe*this%nype)) allocate(weigh_tmp(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%weig_var=0. !clt first transform/upsend original mg_weigh_var to their correct locations - write(6,*)'thinkdeb in def_mg_weights, ', 04 + write(6,*)'thinkdeb in def_mg_weights, 04 ' call flush(6) if(this%l_mgbf_inhomogeneous ) then if(this%l_mg_weig_readin) then @@ -1411,7 +1411,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) !-------------------------------------------------------- gen_fac=1. !cltorg this%a_diff_f(:,:,:)=this%mg_weig1 - write(6,*)'thinkdeb in def_mg_weights, ', 05 + write(6,*)'thinkdeb in def_mg_weights, 05' call flush(6) write(tmpfilename, '("mgbf_tmpfile_", I0, ".txt")') this%mype open(12,file=trim(tmpfilename),form="formatted") @@ -1484,14 +1484,15 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) allocate (lonlat2d_filt(this%im,this%jm,2)) lonlat2d_anl(:,:,1)=reshape(lonlat1d_anl(:,1),[size(lonlat2d_anl,1),size(lonlat2d_anl,2)]) lonlat2d_anl(:,:,2)=reshape(lonlat1d_anl(:,2),[size(lonlat2d_anl,1),size(lonlat2d_anl,2)]) + lonlat2d_anl=lonlat2d_anl*deg2rad if(this%mype.eq.0) then open(13,file='latlon.txt',form="formatted") write(13,*)"lon " write(13,*)lonlat2d_anl(:,:,1) write(13,*)"lat " write(13,*)lonlat2d_anl(:,:,2) + close(13) endif - stop call interp_analysis_to_filter(lonlat2d_anl(:,:,1),this%nm,this%mm,this%im,this%jm,lonlat2d_filt(:,:,1)) call interp_analysis_to_filter(lonlat2d_anl(:,:,2),this%nm,this%mm,this%im,this%jm,lonlat2d_filt(:,:,2)) @@ -1517,12 +1518,16 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) do i=1,this%im do j=1,this%jm write(6,*)'thinkdebx99999 dxfm/dyfm = ',this%dxfm(i,j) - write(6,*)'thinkdebx99999 dxfm/dyfm = ',this%dxfm(i,j) + write(6,*)'thinkdebx99999 dxfm/dyfm = ',this%dyfm(i,j) this%paspx4d(1,i,j,1)=(rtem1*this%dxfmctrl/this%dxfm(i,j))**2 ! this%paspy4d(1,i,j,1)=(rtem1*this%dyfmctrl/this%dyfm(i,j))**2 ! enddo enddo + + + this%paspx4d(2:this%lm,:,:,1)=spread(this%paspx4d(1,:,:,1),dim=1,ncopies=this%lm-1) + this%paspy4d(2:this%lm,:,:,1)=spread(this%paspy4d(1,:,:,1),dim=1,ncopies=this%lm-1) @@ -1559,7 +1564,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) end do - write(6,*)'thinkdeb in def_mg_weights, ', 08 + write(6,*)'thinkdeb in def_mg_weights, 08' call flush(6) !cltorg if(.not.this%mgbf_line) then @@ -1605,6 +1610,12 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) 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) + write(6,*)'thinkdeb888 min/max dxfm ',minval(this%dxfm) ,maxval(this%dxfm) + write(6,*)'thinkdeb888 min/max dyfm ',minval(this%dyfm) ,maxval(this%dyfm) + write(6,*)'thinkdeb888 min/max dyfm',minval(this%paspx4d(:,1:this%im,1:this%jm,1)),' ',& + maxval(this%paspx4d(:,1:this%im,1:this%jm,1)) + write(6,*)'thinkdeb888 min/max papy4d ',minval(this%paspy4d(:,1:this%im,1:this%jm,1)),' ', & + maxval(this%paspy4d(:,1:this%im,1:this%jm,1)) do k=1,this%lm do j=1,this%jm call this%getlinesum(this%hx,1,this%im,this%paspx4d(k,1:this%im,j,1),this%ssx4d(k,1:this%im,j,1)) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 60dc86635..535e389f2 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -175,7 +175,7 @@ module mg_parameter real(r_kind):: lengthx,lengthy,xa0,ya0,xf0,yf0 real(r_kind):: dxf,dyf,dxa,dya real(r_kind),allocatable,dimension (:,:):: dxfm,dyfm ! actual filtering grid intervals in meters -real(r_kind):: dxfmctrl=13000,dyfmctrl=13000 !the control filtering grid intervals corresponding to the contstant horizontal aspect tensor +real(r_kind):: dxfmctrl=35000,dyfmctrl=35000 !the control filtering grid intervals corresponding to the contstant horizontal aspect tensor logical :: l_constant_aspt2 =.true. ! using constant horizontal aspect tensor : ampl02 integer(i_kind):: npadx ! x padding on analysis grid @@ -536,7 +536,7 @@ subroutine init_mg_parameter(this,inputfilename) !clthhhreal(r_kind):: coef_normalization(lm_max)=1.0 !normalizaton coefficients real(r_kind):: coef_normalization(lm_max)=1 !normalizaton coefficients real(r_kind):: coef_normalization_const=-9999.0 ! constant, if set, this contant will be -real(r_kind):: dxfmctrl=13000,dyfmctrl=13000 !the control filtering grid intervals corresponding to the contstant horizontal aspect tensor +real(r_kind):: dxfmctrl=35000,dyfmctrl=35000 !the control filtering grid intervals corresponding to the contstant horizontal aspect tensor logical :: l_constant_aspt2 =.true. ! using constant horizontal aspect tensor : ampl02 character(len=256) ::file_coef_normalization="XXXX" integer(i_kind):: km2 ! number of 2d variables for filtering From 5b5670b152f92a5360bf0419b544357f61b56971 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Wed, 19 Nov 2025 20:29:40 +0000 Subject: [PATCH 094/199] WIP hardwired debug test --- src/saber/mgbf/mgbf_lib/mg_generations.f90 | 17 +++++++++-------- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 8 ++++++-- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index b73ec4532..bcf6435a3 100755 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -234,29 +234,30 @@ module subroutine upsending_normalized & write(6,*)'thinkdeb144 before adjoint_nral min/max input ', minval(V),maxval(V) call this%adjoint_normalized(V(1:nz,0:this%im+1,0:this%jm+1),V_INT,nz,1) write(6,*)'thinkdeb144 after adjoint_nral min/max output ', minval(V_INT),maxval(V_INT) + write(6,*)'thinkdeb144 after adjoint_nral2 min/max output ', minval(V_INT(:,1:this%imL,1:this%jmL)) call this%bocoT_2d(V_INT,nz,this%imL,this%jmL,2,2) - write(6,*)'thinkdeb144 after 2 min/max output ', minval(V_INT),maxval(V_INT) + write(6,*)'thinkdeb144 after 2 min/max output ', maxval(V_INT(:,1:this%imL,1:this%jmL)),minval(V_INT(:,1:this%imL,1:this%jmL)) !clttothink call this%upsend_all(V_INT(1:nz,1:this%imL,1:this%jmL),H,nz) - write(6,*)'thinkdeb144 after 2 min/max output ', minval(H),maxval(H) + write(6,*)'thinkdeb144 after 2xx min/max output ', maxval(H(:,1:this%imL,1:this%jmL)),minval(H(:,1:this%imL,1:this%jmL)) ! ! From generation 2 sequentially to higher generations ! do g=2,this%gm-1 if(g==this%my_hgen) then - write(6,*)'thinkdeb144 before second adjoint min/max input ', minval(H),maxval(H) + write(6,*)'thinkdeb144 before second adjoint min/max input ', maxval(H(:,1:this%imL,1:this%jmL)),minval(H(:,1:this%imL,1:this%jmL)) call this%adjoint_normalized(H(1:nz,0:this%im+1,0:this%jm+1),H_INT,nz,g) - write(6,*)'thinkdeb144 after second adjoint min/max input ', minval(H_INT),maxval(H_INT) + write(6,*)'thinkdeb144 after second adjoint min/max input ', maxval(H_INT(:,1:this%imL,1:this%jmL)),minval(H_INT(:,1:this%imL,1:this%jmL)) endif call this%bocoT_2d(H_INT,nz,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) - write(6,*)'thinkdeb144 before final upsend_all min/max input ', minval(H_INT),maxval(H_INT) + write(6,*)'thinkdeb144 before final upsend_all min/max input ', maxval(H_INT(:,1:this%imL,1:this%jmL)),minval(H_INT(:,1:this%imL,1:this%jmL)) call this%upsend_all(H_INT(1:nz,1:this%imL,1:this%jmL),H,nz,g,g+1) - write(6,*)'thinkdeb144 after final upsend_all min/max input ', minval(H_INT),maxval(H_INT) + write(6,*)'thinkdeb144 after final upsend_all min/max input ', maxval(H_INT),minval(H_INT) end do @@ -1456,8 +1457,8 @@ module subroutine adjoint_normalized & W(:,:,this%jmL+1:this%jmL+2)=0 endif - write(6,*)'thinkdeb253 4 W is ',minval(W),' ',maxval(W)! - write(6,*)'thinkdeb253 4 Wnorm is ',minval(Wnorm),' ',maxval(Wnorm)! + write(6,*)'thinkdeb253 4 W is ',minval(W(:,1:this%imL,1:this%jmL)),' ',maxval(W(:,1:this%imL,1:this%jmL))! + write(6,*)'thinkdeb253 4 Wnorm is ',minval(Wnorm(:,1:this%imL,1:this%jmL)),' ',maxval(Wnorm(:,1:this%imL,1:this%jmL))! endif !----------------------------------------------------------------------- diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index d25a255bf..7da36c9e6 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1479,7 +1479,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) this%paspx=this%pasp02 this%paspy=this%pasp02 !paspx and paspy will be replaced by paspx4d/paspy4d when the x/y filter ! is used ( filtering_fast_bkg ) - +#if 0 allocate (lonlat2d_anl(this%nm,this%mm,2)) allocate (lonlat2d_filt(this%im,this%jm,2)) lonlat2d_anl(:,:,1)=reshape(lonlat1d_anl(:,1),[size(lonlat2d_anl,1),size(lonlat2d_anl,2)]) @@ -1536,6 +1536,11 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) deallocate (lonlat2d_anl) deallocate (lonlat2d_filt) +#else + this%paspx4d(:,:,:,1)=this%pasp02 + this%paspy4d(:,:,:,1)=this%pasp02 +#endif + endif do j=1,this%jm do i=1,this%im @@ -1661,7 +1666,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) call this%upsending_normalized(this%lm,this%ssx4d(:,:,:,1),this%ssx4d(:,:,:,2)) call this%boco_2d(this%ssy4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) call this%upsending_normalized(this%lm,this%ssy4d(:,:,:,1),this%ssy4d(:,:,:,2)) - write(6,*)'thinkdeb999 end of def_mg_weights' call flush(6) From 4fe529bd166a383d8d429bfbf1b0e4b7ad5f1ef9 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 21 Nov 2025 16:32:01 +0000 Subject: [PATCH 095/199] WIP : passed first validation for the inhomogeneous mgbf --- src/saber/mgbf/mgbf_lib/mg_generations.f90 | 52 +++++++++------------- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 35 +++------------ src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 | 10 ----- 3 files changed, 25 insertions(+), 72 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index bcf6435a3..127c35afa 100755 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -231,33 +231,25 @@ module subroutine upsending_normalized & ! ! From generation 1 to generation 2 ! - write(6,*)'thinkdeb144 before adjoint_nral min/max input ', minval(V),maxval(V) - call this%adjoint_normalized(V(1:nz,0:this%im+1,0:this%jm+1),V_INT,nz,1) - write(6,*)'thinkdeb144 after adjoint_nral min/max output ', minval(V_INT),maxval(V_INT) - write(6,*)'thinkdeb144 after adjoint_nral2 min/max output ', minval(V_INT(:,1:this%imL,1:this%jmL)) + call this%adjoint_normalized(V(1:nz,1:this%im,1:this%jm),V_INT,nz,1) call this%bocoT_2d(V_INT,nz,this%imL,this%jmL,2,2) - write(6,*)'thinkdeb144 after 2 min/max output ', maxval(V_INT(:,1:this%imL,1:this%jmL)),minval(V_INT(:,1:this%imL,1:this%jmL)) !clttothink call this%upsend_all(V_INT(1:nz,1:this%imL,1:this%jmL),H,nz) - write(6,*)'thinkdeb144 after 2xx min/max output ', maxval(H(:,1:this%imL,1:this%jmL)),minval(H(:,1:this%imL,1:this%jmL)) ! ! From generation 2 sequentially to higher generations ! do g=2,this%gm-1 if(g==this%my_hgen) then - write(6,*)'thinkdeb144 before second adjoint min/max input ', maxval(H(:,1:this%imL,1:this%jmL)),minval(H(:,1:this%imL,1:this%jmL)) - call this%adjoint_normalized(H(1:nz,0:this%im+1,0:this%jm+1),H_INT,nz,g) - write(6,*)'thinkdeb144 after second adjoint min/max input ', maxval(H_INT(:,1:this%imL,1:this%jmL)),minval(H_INT(:,1:this%imL,1:this%jmL)) + call this%adjoint_normalized(H(1:nz,1:this%im,1:this%jm),H_INT,nz,g) endif call this%bocoT_2d(H_INT,nz,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) - write(6,*)'thinkdeb144 before final upsend_all min/max input ', maxval(H_INT(:,1:this%imL,1:this%jmL)),minval(H_INT(:,1:this%imL,1:this%jmL)) +!clt tothink ,problem on rank =20 call this%upsend_all(H_INT(1:nz,1:this%imL,1:this%jmL),H,nz,g,g+1) - write(6,*)'thinkdeb144 after final upsend_all min/max input ', maxval(H_INT),minval(H_INT) end do @@ -1391,17 +1383,18 @@ module subroutine adjoint_normalized & 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%im+1,0:this%jm+1), intent(in):: F +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%imL+2,-1:this%jmL+2) :: Wnorm integer(i_kind):: i,j,iL,jL real(r_kind):: r1_16,r3_16,r9_16 integer(i_kind):: k real(r_kind), parameter :: eps = 1.0e-10_r_kind ! Add epsilon for safety check +integer(i_kind):: im1, ip0, ip1, ip2 +integer(i_kind):: jm1, jp0, jp1, jp2 !----------------------------------------------------------------------- ! ! 3) - write(6,*)'thinkdeb253 f is ',minval(F),' ',maxval(F)! W(:,:,:)=0. Wnorm=0.! @@ -1410,24 +1403,21 @@ module subroutine adjoint_normalized & r3_16 = 3.*r1_16 r9_16 = 9.*r1_16 - - - do jL=1,this%jmL + do jL=1,this%jmL j = 2*jL - 1 - do iL=1,this%imL - i = 2*iL - 1 - W(:,iL,jL) = r1_16*(F(:,i-1,j-1)+F(:,i+2,j-1)+F(:,i-1,j+2)+F(:,i+2,j+2))+ & - + r3_16*(F(:,i,j-1)+F(:,i+1,j-1) & - + F(:,i-1,j)+F(:,i-1,j+1) & - + F(:,i+2,j)+F(:,i+2,j+1) & - + F(:,i,j+2)+F(:,i+1,j+2)) & - + r9_16*(F(:,i,j)+F(:,i+1,j)+F(:,i,j+1)+F(:,i+1,j+1)) - wnorm(:,iL,jL) =wnorm(:,iL,jL)+ r1_16*4+ & - + r3_16*8 & - + r9_16*4 - enddo - enddo - + jm1 = max(j-1,1); jp0 = j; jp1 = min(j+1,this%jm); jp2 = min(j+2,this%jm) + do iL=1,this%imL + i = 2*iL - 1 + im1 = max(i-1,1); ip0 = i; ip1 = min(i+1,this%im); ip2 = min(i+2,this%im) + W(:,iL,jL) = r1_16*(F(:,im1,jm1)+F(:,ip2,jm1)+F(:,im1,jp2)+F(:,ip2,jp2))+ & + + r3_16*(F(:,ip0,jm1)+F(:,ip1,jm1) & + + F(:,im1,jp0)+F(:,im1,jp1) & + + F(:,ip2,jp0)+F(:,ip2,jp1) & + + F(:,ip0,jp2)+F(:,ip1,jp2)) & + + r9_16*(F(:,ip0,jp0)+F(:,ip1,jp0)+F(:,ip0,jp1)+F(:,ip1,jp1)) + wnorm(:,iL,jL) = wnorm(:,iL,jL) + r1_16*4 + r3_16*8 + r9_16*4 + enddo + enddo ! if (1.gt.0) then do jL=1,this%jmL @@ -1457,8 +1447,6 @@ module subroutine adjoint_normalized & W(:,:,this%jmL+1:this%jmL+2)=0 endif - write(6,*)'thinkdeb253 4 W is ',minval(W(:,1:this%imL,1:this%jmL)),' ',maxval(W(:,1:this%imL,1:this%jmL))! - write(6,*)'thinkdeb253 4 Wnorm is ',minval(Wnorm(:,1:this%imL,1:this%jmL)),' ',maxval(Wnorm(:,1:this%imL,1:this%jmL))! endif !----------------------------------------------------------------------- diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 7da36c9e6..91385cf3c 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -850,7 +850,7 @@ module subroutine adjoint_normalized & 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%im+1,0:this%jm+1), intent(in):: F + 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 & @@ -1281,16 +1281,12 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) real (r_kind)::rtem1 real (r_kind) :: dist_rad !----------------------------------------------------------------------- - write(6,*)'thinkdeb in def_mg_weights, 01' - call flush(6) start_idx=Lbound(this%weig_var,4) end_idx=Ubound(this%weig_var,4) if(start_idx /=1 ) then write(6,*)'the expected begin index of weig_var is 1, stop' stop endif - write(6,*)'thinkdeb in def_mg_weights, 02' - call flush(6) if (present(lonlat1d_anl)) then if (size(lonlat1d_anl,2) /= 2 .or. size(lonlat1d_anl,1) < n_owned_anl) then @@ -1300,7 +1296,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) this%l_constant_aspt2=.true. end if - write(6,*)'thinkdeb in def_mg_weights, changed l_constant_aspt2 ', this%l_constant_aspt2 if (present(n_owned_anl)) then if(this%nm*this%mm /= n_owned_anl) then error stop "the input grid number is not as expected , stop " @@ -1312,14 +1307,10 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) - write(6,*)'thinkdeb in def_mg_weights, 03' - call flush(6) allocate(sendcounts(this%nxpe*this%nype), displs(this%nxpe*this%nype)) allocate(weigh_tmp(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%weig_var=0. !clt first transform/upsend original mg_weigh_var to their correct locations - write(6,*)'thinkdeb in def_mg_weights, 04 ' - call flush(6) if(this%l_mgbf_inhomogeneous ) then if(this%l_mg_weig_readin) then dims=(/this%nxpe,this%nype/) @@ -1382,7 +1373,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) allocate(par_weig_g(4)) par_weig_g=(/this%mg_weig1,this%mg_weig2,this%mg_weig3,this%mg_weig4/) do ig=start_idx,end_idx - write(6,*)'thinkdeb255 par_weig_g(ig) ',par_weig_g(ig) weigh_tmp=par_weig_g(ig) call this%upsending_normalized(this%km_all,weigh_tmp,this%weig_var(:,:,:,ig)) !clto call this%upsending(weigh_tmp,this%weig_var(:,:,:,ig)) @@ -1411,8 +1401,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) !-------------------------------------------------------- gen_fac=1. !cltorg this%a_diff_f(:,:,:)=this%mg_weig1 - write(6,*)'thinkdeb in def_mg_weights, 05' - call flush(6) write(tmpfilename, '("mgbf_tmpfile_", I0, ".txt")') this%mype open(12,file=trim(tmpfilename),form="formatted") if(this%l_mgbf_inhomogeneous ) then @@ -1426,15 +1414,11 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) select case(this%my_hgen) case(2) !cltorg this%a_diff_h(:,:,:)=this%mg_weig2 -write(12,*)'thinkdeb256 weigh2 ',this%mg_weig2,minval(this%weig_var(:,:,:,2)),(this%weig_var(:,:,:,2)) this%a_diff_h(:,:,:)=this%weig_var(:,:,:,2) case(3) !cltorg this%a_diff_h(:,:,:)=this%mg_weig3 -write(12,*)'thinkdeb256 weigh3 ',this%mg_weig3,minval(this%weig_var(:,:,:,3)),(this%weig_var(:,:,:,3)) this%a_diff_h(:,:,:)=this%weig_var(:,:,:,3) -write(6,*)'thinkdeb256 weigh3 1 ',this%weig_var(:,:,:,3) case default -write(12,*)'thinkdeb256 weigh4 ',this%mg_weig1,minval(this%weig_var(:,:,:,4)),(this%weig_var(:,:,:,4)) !cltorg this%a_diff_h(:,:,:)=this%mg_weig4 this%a_diff_h(:,:,:)=this%weig_var(:,:,:,4) end select @@ -1463,8 +1447,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) !cltorg do i=1,this%im !cltorg this%paspx(1,1,i)=this%pasp02 !cltorg enddo - write(6,*)'thinkdeb in def_mg_weights, l_constant_aspt2 ', this%l_constant_aspt2 - call flush(6) if (this%l_constant_aspt2 ) then this%paspx=this%pasp02 this%paspy=this%pasp02 @@ -1517,8 +1499,8 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) do i=1,this%im do j=1,this%jm - write(6,*)'thinkdebx99999 dxfm/dyfm = ',this%dxfm(i,j) - write(6,*)'thinkdebx99999 dxfm/dyfm = ',this%dyfm(i,j) +!clt write(6,*)'thinkdebx99999 dxfm/dyfm = ',this%dxfm(i,j) +!clt write(6,*)'thinkdebx99999 dxfm/dyfm = ',this%dyfm(i,j) this%paspx4d(1,i,j,1)=(rtem1*this%dxfmctrl/this%dxfm(i,j))**2 ! this%paspy4d(1,i,j,1)=(rtem1*this%dyfmctrl/this%dyfm(i,j))**2 ! enddo @@ -1569,8 +1551,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) end do - write(6,*)'thinkdeb in def_mg_weights, 08' - call flush(6) !cltorg if(.not.this%mgbf_line) then if(this%nxm*this%nym>1) then @@ -1615,12 +1595,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) 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) - write(6,*)'thinkdeb888 min/max dxfm ',minval(this%dxfm) ,maxval(this%dxfm) - write(6,*)'thinkdeb888 min/max dyfm ',minval(this%dyfm) ,maxval(this%dyfm) - write(6,*)'thinkdeb888 min/max dyfm',minval(this%paspx4d(:,1:this%im,1:this%jm,1)),' ',& - maxval(this%paspx4d(:,1:this%im,1:this%jm,1)) - write(6,*)'thinkdeb888 min/max papy4d ',minval(this%paspy4d(:,1:this%im,1:this%jm,1)),' ', & - maxval(this%paspy4d(:,1:this%im,1:this%jm,1)) do k=1,this%lm do j=1,this%jm call this%getlinesum(this%hx,1,this%im,this%paspx4d(k,1:this%im,j,1),this%ssx4d(k,1:this%im,j,1)) @@ -1657,8 +1631,10 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy)=0. end if !cltorg end if +!cltthinkdeb10000 call this%boco_2d(this%paspx4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) call this%upsending_normalized(this%lm,this%paspx4d(:,:,:,1),this%paspx4d(:,:,:,2)) + call this%boco_2d(this%paspy4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) call this%upsending_normalized(this%lm,this%paspy4d(:,:,:,1),this%paspy4d(:,:,:,2)) @@ -1666,7 +1642,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) call this%upsending_normalized(this%lm,this%ssx4d(:,:,:,1),this%ssx4d(:,:,:,2)) call this%boco_2d(this%ssy4d(1:this%lm,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,1),this%lm,this%im,this%jm,this%hx,this%hy) call this%upsending_normalized(this%lm,this%ssy4d(:,:,:,1),this%ssy4d(:,:,:,2)) - call flush(6) diff --git a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 index 4cac6f2fa..c2bdaf72f 100755 --- a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 @@ -59,16 +59,12 @@ module subroutine init_mg_MPI(this) !*** call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr) call MPI_COMM_SIZE(MPI_COMM_WORLD,npes,ierr) - write(6,*)'thinkdeb in mg_mppstuff npes,mype is ',npes,mype - call flush(6) ! 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) - write(6,*)'thinkdeb in mg_mppstuff new npes, world is ',npes,' ',mpi_comm_comp - call flush(6) rTYPE = MPI_REAL dTYPE = MPI_DOUBLE @@ -107,8 +103,6 @@ module subroutine init_mg_MPI(this) !----------------------------------------------------------------------- ! call MPI_BARRIER(mpi_comm_comp,ierr) - write(6,*)'thinkdeb in mg_mppstuff 2 ' - call flush(6) ! !----------------------------------------------------------------------- !*** @@ -118,8 +112,6 @@ module subroutine init_mg_MPI(this) ! Associate a group with communicator this@mpi_comm_comp ! call MPI_COMM_GROUP(mpi_comm_comp,group_world,ierr) - write(6,*)'thinkdeb in mg_mppstuff 3, npes_filt ',npes_filt - call flush(6) ! ! Create a new group out of exising group ! @@ -148,8 +140,6 @@ module subroutine init_mg_MPI(this) !----------------------------------------------------------------------- ! call MPI_BARRIER(mpi_comm_comp,ierr) - write(6,*)'thinkdeb in mg_mppstuff 3, end of init_mg_MPI ',npes_filt - call flush(6) ! !----------------------------------------------------------------------- endsubroutine init_mg_MPI From 4faf5f2c1180ddaec1b85f92811a48b562c53885 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 24 Nov 2025 14:58:36 +0000 Subject: [PATCH 096/199] WIP --- src/saber/mgbf/mgbf_lib/mg_tools.f90 | 85 ++++++++++++++++++++++++++++ 1 file changed, 85 insertions(+) create mode 100644 src/saber/mgbf/mgbf_lib/mg_tools.f90 diff --git a/src/saber/mgbf/mgbf_lib/mg_tools.f90 b/src/saber/mgbf/mgbf_lib/mg_tools.f90 new file mode 100644 index 000000000..cdd26839a --- /dev/null +++ b/src/saber/mgbf/mgbf_lib/mg_tools.f90 @@ -0,0 +1,85 @@ +module mg_tools +!!from codex : +!the filtering grid is anchored to the same physical domain as the analysis grid, +!with both sharing the left/right boundaries at 0 and lengthx (and top/bottom at lengthy). +! In init_mg_parameter, the domain length is set to lengthx = nm and +!lengthy = mm (src/saber/mgbf/mgbf_lib/mg_parameter.f90:946-957). +!Analysis points sit at midpoints of unit cells: xa(n) = xa0 + dxa*(n-1) with xa0 = dxa/2 = 0.5 +!(src/saber/mgbf/mgbf_lib/mg_parameter.f90:952-961). Filtering points use the same origin convention: xf(i) = xf0 + dxf*(i-1) with xf0 = dxf/2 (src/saber/mgbf/mgbf_lib/mg_parameter.f90:952-964). +!So both grids start half a grid spacing from the boundary; no global offset is applied. +use mgbf_kinds, only: r_kind,i_kind + +contains +subroutine interp_analysis_to_filter(yy, nm, mm, im, jm, zz) + ! Bilinear interpolation from analysis grid (nm×mm) to filter grid (im×jm). + ! Assumes both grids span the same physical domain and are cell-centered. + + implicit none + integer(i_kind), intent(in) :: nm, mm ! analysis grid dimensions + integer(i_kind), intent(in) :: im, jm ! filter grid dimensions + real(r_kind), intent(in) :: yy(nm, mm) ! analysis field + real(r_kind), intent(out):: zz(im, jm) ! interpolated field on filter grid + + integer(i_kind) :: i, j, n0, n1, m0, m1 + real(r_kind) :: dxA, dyA, dxF, dyF + real(r_kind) :: xa0, ya0, xf0, yf0 + real(r_kind) :: xf, yf, xa, ya, tx, ty + real(r_kind) :: w00, w10, w01, w11 + + dxA = 1.0 ! analysis spacing (arbitrary scale) + dyA = 1.0 + xa0 = 0.5*dxA ! analysis centers + ya0 = 0.5*dyA + + dxF = (nm*dxA)/im ! filter spacing so domains align + dyF = (mm*dyA)/jm + xf0 = 0.5*dxF + yf0 = 0.5*dyF + + do j = 1, jm + yf = yf0 + (j-1)*dyF + ya = (yf - ya0)/dyA + 1.0 ! fractional analysis index + m0 = max(1, min(mm-1, int(floor(ya)))) + m1 = m0 + 1 + ty = ya - m0 + + do i = 1, im + xf = xf0 + (i-1)*dxF + xa = (xf - xa0)/dxA + 1.0 ! fractional analysis index + n0 = max(1, min(nm-1, int(floor(xa)))) + n1 = n0 + 1 + tx = xa - n0 + + w00 = (1.0-tx)*(1.0-ty) + w10 = tx*(1.0-ty) + w01 = (1.0-tx)*ty + w11 = tx*ty + + zz(i,j) = w00*yy(n0,m0) + w10*yy(n1,m0) & + + w01*yy(n0,m1) + w11*yy(n1,m1) + end do + end do +end subroutine interp_analysis_to_filter +subroutine mg_sphere_dist(lon_i, lat_i, lon_f, lat_f, dist) + implicit none + real(r_kind), intent(in) :: lon_i ! radians + real(r_kind), intent(in) :: lat_i ! radians + real(r_kind), intent(in) :: lon_f ! radians + real(r_kind), intent(in) :: lat_f ! radians + real(r_kind), intent(out) :: dist ! radians on the unit sphere + real(r_kind) :: dlon, dlat, sin_half_dlon, sin_half_dlat + real(r_kind) :: cos_lat_i, cos_lat_f, hav + + dlon = lon_f - lon_i + dlat = lat_f - lat_i + sin_half_dlon = sin(0.5_r_kind * dlon) + sin_half_dlat = sin(0.5_r_kind * dlat) + cos_lat_i = cos(lat_i) + cos_lat_f = cos(lat_f) + + hav = sin_half_dlat*sin_half_dlat + cos_lat_i*cos_lat_f*sin_half_dlon*sin_half_dlon + hav = min(1.0_r_kind, max(0.0_r_kind, hav)) ! numerical safety + dist = 2.0_r_kind * atan2(sqrt(hav), sqrt(max(0.0_r_kind, 1.0_r_kind - hav))) +end subroutine mg_sphere_dist + +end module mg_tools From 604ca0bdb8d48d4eaca8fd84c9275992891bab26 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Fri, 21 Nov 2025 16:45:47 +0000 Subject: [PATCH 097/199] WIP --- .../gsi/covariance/Covariance.interface.F90 | 14 +- .../gsi/covariance/gsi_covariance_mod.f90 | 14 + .../mgbf/covariance/mgbf_covariance_mod.f90 | 1374 ++++++++--------- 3 files changed, 689 insertions(+), 713 deletions(-) diff --git a/src/saber/gsi/covariance/Covariance.interface.F90 b/src/saber/gsi/covariance/Covariance.interface.F90 index df82fcfae..d7f9993d2 100644 --- a/src/saber/gsi/covariance/Covariance.interface.F90 +++ b/src/saber/gsi/covariance/Covariance.interface.F90 @@ -23,6 +23,7 @@ module gsi_covariance_interface_mod ! saber use gsi_covariance_mod, only: gsi_covariance +use mpi implicit none private @@ -186,6 +187,10 @@ subroutine gsi_covariance_multiply_cpp(c_self, c_ntimes, c_inc) & type(gsi_covariance), pointer :: f_self type(atlas_fieldset), dimension(:), allocatable :: f_inc integer :: ntimes, itime +integer :: mype +real(kind=8) :: time_beg,time_end,walltime +integer:: ierr + ! LinkedList ! ---------- @@ -201,7 +206,14 @@ subroutine gsi_covariance_multiply_cpp(c_self, c_ntimes, c_inc) & ! Call implementation ! ------------------- -call f_self%multiply(ntimes, f_inc) + call mpi_comm_rank(mpi_comm_world,mype,ierr) + time_beg=MPI_Wtime() + call f_self%multiply(ntimes, f_inc) + time_end=MPI_Wtime() !now use the existing variable + call MPI_Reduce(time_end-time_beg, walltime, 1, MPI_REAL8, MPI_MAX, 0, MPI_COMM_WORLD, ierr) + if (mype == 0) then + print '(A,F10.6,A)', 'thinkdeb999GSIBEC interface time (max over ranks)',walltime + end if ! Release memory ! -------------- diff --git a/src/saber/gsi/covariance/gsi_covariance_mod.f90 b/src/saber/gsi/covariance/gsi_covariance_mod.f90 index 4d9651162..57e88baaa 100644 --- a/src/saber/gsi/covariance/gsi_covariance_mod.f90 +++ b/src/saber/gsi/covariance/gsi_covariance_mod.f90 @@ -53,6 +53,8 @@ module gsi_covariance_mod use constants, only: grav +use mpi + implicit none private public gsi_covariance @@ -430,10 +432,14 @@ subroutine multiply(self, ntimes, fields) type(gsi_bundle),allocatable :: gsisv(:) integer :: isc,iec,jsc,jec,npz integer :: iv,k,ier,itbd,ii +integer :: mype +real(kind=8) :: time_beg,time_end,walltime character(len=32),allocatable :: gvars2d(:),gvars3d(:) character(len=30),allocatable :: tbdvars(:),needvrs(:) +integer :: ierr + ! afield = fields%field('air_pressure_at_surface') ! call afield%data(rank2) ! rank2 = 0.0_kind_real @@ -549,11 +555,19 @@ subroutine multiply(self, ntimes, fields) ! Apply GSI B-error operator ! -------------------------- + time_beg=MPI_Wtime() if (self%cv) then call gsibec_cv_space(gsicv,internalcv=.false.,bypassbe=self%bypassGSIbe) else call gsibec_sv_space(gsisv,internalsv=.false.,bypassbe=self%bypassGSIbe) endif + call mpi_comm_rank(mpi_comm_world,mype,ierr) + + time_end=MPI_Wtime() !now use the existing variable + call MPI_Reduce(time_end-time_beg, walltime, 1, MPI_REAL8, MPI_MAX, 0, MPI_COMM_WORLD, ierr) + if (mype == 0) then + print '(A,F10.6,A)', 'thinkdeb999gsi_covariance_mod.f90 multiply time (max over ranks)',walltime + end if ! Convert back to Atlas Fields ! ---------------------------- diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index a30390962..8b8979738 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -1,712 +1,662 @@ -! (C) Copyright 2022 United States Government as represented by the Administrator of the National -! Aeronautics and Space Administration -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. - -module mgbf_covariance_mod - -! atlas -use atlas_module, only: atlas_fieldset, atlas_field -use atlas_module, only: atlas_functionspace -use atlas_module, only: atlas_functionspace_StructuredColumns -use atlas_module, only : atlas_functionspace, & - atlas_functionspace_nodecolumns, & - atlas_functionspace_pointcloud, & - atlas_functionspace_structuredcolumns, & - atlas_mesh_nodes, atlas_field - -use tools_func, only : sphere_dist -use tools_const, only : req ! Earth radius (m) - -! fckit -use fckit_mpi_module, only: fckit_mpi_comm -use fckit_configuration_module, only: fckit_configuration - -! oops -use mgbf_kinds, only: r_kind,i_kind -use random_mod - -! saber -!clt use mgbf_grid_mod, only: mgbf_grid -use mg_intstate , only: mg_intstate_type -use mg_timers -use mpi -use, intrinsic :: ieee_arithmetic -implicit none -private -public mgbf_covariance - -! Fortran class header -type :: mgbf_covariance - type(mg_intstate_type),allocatable :: intstate(:,:) - integer :: nscale=1 - integer :: nvargrp=1 - logical :: noMGBF - logical :: bypassMGBFbe - logical :: cv ! cv=.true.; sv=.false. - integer :: mp_comm_world - integer :: rank - logical :: l_2dvar_last_vertical_level=.true. !when used for localization,2dvars are put on the last vertical level - !when the fields in fset are stored from top to bottom -!clt integer :: lat2,lon2 ! these belog to mgbf_grid - character(len=:), allocatable :: mgbf_nml - character(len=80), allocatable :: mgbf_nml_group(:,:) - real, allocatable :: multigrp_cor(:,:) - integer, allocatable :: iscalegroup(:) - integer, allocatable :: ivargroup(:) - - contains - procedure, public :: create - procedure, public :: delete - procedure, public :: randomize - procedure, public :: multiply - procedure, public :: multiply_ad - procedure, private :: imem2scale - procedure, private :: ivar2grp -end type mgbf_covariance - -character(len=*), parameter :: myname='mgbf_covariance_mod' - -! -------------------------------------------------------------------------------------------------- - -contains - -! -------------------------------------------------------------------------------------------------- - -subroutine create(self, comm, config, funcspace, background, firstguess) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(fckit_mpi_comm), intent(in) :: comm -type(fckit_configuration), intent(in) :: config -type(atlas_functionspace), intent(in) :: funcspace -type(atlas_fieldset), intent(in) :: background -type(atlas_fieldset), intent(in) :: firstguess - -! Locals -real(r_kind) :: dist_rad, dist_m -integer :: ipt -character(len=*), parameter :: myname_=myname//'*create' -character(len=:), allocatable :: mgbf_nml,centralblockname -logical :: central -integer :: layout(2) -integer :: myunit -integer :: iscale,ivargrp -integer :: nscale=1, nvargrp=1 -type(atlas_field) :: afield, lonlat_field -type(atlas_functionspace_structuredcolumns) :: fs_sc -real(r_kind), pointer :: lonlat_ptr(:,:) -real(r_kind), allocatable :: lonlat_anl(:,:) -integer :: npts_owned -integer :: npts_total - - -character(len=80) :: readin_mgbf_nml_group(99) -real :: readin_multigrp_cor(99)=1.0 -integer :: readin_iscalegroup(99)=999 -integer :: readin_ivargroup(99)=999 -integer ::i,j, ii -namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup - -character(len=:), allocatable :: dump_json - -! Hold communicator -! ----------------- -!self%mp_comm_world=comm%communicator() - -! Create the grid -! --------------- -!clt call self%grid%create(config, comm) -self%rank = comm%rank() - -write(6,*)'thinkdeb mgbf create999 ' -write(6,*)'thinkdeb mgbf create999 config' - dump_json=config%json() ! serialize to a JSON string -write(6,'(A)')trim(dump_json) -call flush(6) -call config%get_or_die("saber block name", centralblockname) -!clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) -if (config%has("mgbf sdl and vdl init namelist file")) then - call config%get_or_die("mgbf sdl and vdl init namelist file", mgbf_nml) - open(newunit=myunit,file=trim(mgbf_nml),status='old') -!# open(unit=10,file=mgbf_nml,status='old',action='read') - read(myunit,nml=parameters_mgbf_init) - close(unit=myunit) - self%nscale=nscale - self%nvargrp=nvargrp - allocate(self%mgbf_nml_group(nscale,nvargrp)) - allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship - allocate(self%iscalegroup(nscale) ) - allocate(self%ivargroup(nvargrp) ) - ii=1 - do iscale=1,nscale - do ivargrp=1,nvargrp - self%mgbf_nml_group(iscale,ivargrp)=readin_mgbf_nml_group(ii) - ii=ii+1 - enddo - enddo - do iscale=1,nscale - self%iscalegroup(iscale)=readin_iscalegroup(iscale) - enddo - ii=1 - do i=1,nvargrp - do j=1,nvargrp - self%multigrp_cor(i,j)=readin_multigrp_cor(ii) - ii=ii+1 - enddo - enddo - do i=1,nvargrp - self%ivargroup(i)=readin_ivargroup(iscale) - enddo -else -call config%get_or_die("mgbf namelist file ", mgbf_nml) -!still need allocate them though nscale=nvargrp=1 - allocate(self%mgbf_nml_group(nscale,nvargrp)) - allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship - self%multigrp_cor=1.0 - allocate(self%iscalegroup(nscale) ) - self%iscalegroup(nscale) =1 - allocate(self%ivargroup(nvargrp) ) - self%ivargroup=1 -endif - - -if(nscale == 1 .and. nvargrp ==1 ) then - self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used - !and hence, it would be backward-compatible - ! the previous namelist files could be still used,correctly, - ! by the current sdl/vdl enhanced version -endif - -if (trim(funcspace%name()) /= 'StructuredColumns') then - error stop 'MGBF requires StructuredColumns function space' -end if -fs_sc = funcspace -lonlat_field = fs_sc%xy() -call lonlat_field%data(lonlat_ptr) -npts_owned = fs_sc%size_owned() -npts_total = size(lonlat_ptr,2) -allocate(lonlat_anl(npts_total,2)) -lonlat_anl(:,1) = lonlat_ptr(1,1:npts_total) -lonlat_anl(:,2) = lonlat_ptr(2,1:npts_total) -call lonlat_field%final() - -write(6,*)'thinkdeb mgbf create999 4 ' -call flush(6) - -allocate(self%intstate(nscale,nvargrp)) -call flush(6) -do iscale=1,nscale - do ivargrp=1,nvargrp - write(6,*)'the999 nml is ', trim(self%mgbf_nml_group(iscale,ivargrp)) - call flush(6) - call self%intstate(iscale,ivargrp)%mg_initialize(n_owned_anl=npts_owned, & - anl_lonlat1d=lonlat_anl, inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml - enddo -enddo -write(6,*)'thinkdeb mgbf create999 10 ' -call flush(6) -if (allocated(lonlat_anl)) deallocate(lonlat_anl) -! Get background (temporary test of the functionality) -!cltafield = background%field('air_temperature') -!clt call afield%data(t) - -end subroutine create - -! -------------------------------------------------------------------------------------------------- - -subroutine delete(self) - -! Arguments -class(mgbf_covariance) :: self -integer:: iscale,ivargrp - -! Locals - -!clt //if (.not. self%noMGBF) then - call print_mg_timers("mg_timer_output",999,self%rank) - -do iscale=1,self%nscale - do ivargrp=1,self%nvargrp - call self%intstate(iscale,ivargrp)%mg_finalize() - enddo -enddo -!clt endif - -! Delete the grid -! --------------- -!clt call self%grid%delete() - -end subroutine delete - -! -------------------------------------------------------------------------------------------------- - -subroutine randomize(self, fields) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields - -! Locals -type(atlas_field) :: afield -real(kind=r_kind), pointer :: psi(:,:), chi(:,:), t(:,:), q(:,:), qi(:,:), ql(:,:), o3(:,:) -real(kind=r_kind), pointer :: ps(:) - -integer, parameter :: rseed = 3 -write(6,*)'thinkdeb this is to be implemente' -call flush(6) -stop -! Get Atlas field -afield = fields%field('stream_function') -call afield%data(psi) - -afield = fields%field('velocity_potential') -call afield%data(chi) - -afield = fields%field('air_temperature') -call afield%data(t) - -afield = fields%field('surface_pressure') -call afield%data(ps) - -afield = fields%field('specific_humidity') -call afield%data(q) - -afield = fields%field('cloud_liquid_ice') -call afield%data(qi) - -afield = fields%field('cloud_liquid_water') -call afield%data(ql) - -afield = fields%field('ozone_mass_mixing_ratio') -call afield%data(o3) - - -! Set fields to random numbers -call normal_distribution(psi, 0.0_r_kind, 1.0_r_kind, rseed) - - -end subroutine randomize - -! -------------------------------------------------------------------------------------------------- - -subroutine multiply(self, fields,index_member_in) -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields -integer , intent(in) :: index_member_in -type(atlas_fieldset) :: fields_tmp -type(atlas_functionspace) :: afunctionspace - -! Locals -type(atlas_field) :: afield -real(kind=r_kind), pointer :: ptr_2d(:,:) -real(kind=r_kind), pointer :: ptr_3d(:,:,:) -integer(kind=i_kind):: nz,ilev,isize -real(kind=r_kind), allocatable :: work_mgbf(:,:,:) -real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) -real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) -real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) -real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) -real(kind=r_kind), allocatable :: work2d_mgbf(:,:) -real(kind=r_kind), allocatable :: rnormalization(:,:) -integer(kind=i_kind), allocatable :: nlev_vargrp(:) -integer(kind=i_kind) :: dim2d(2),dim3d(3) -integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d -integer(kind=i_kind)::nvar -integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit -integer(kind=i_kind):: n2d -integer(kind=i_kind),allocatable :: varvlev_index(:,:) -logical :: l2d_encountered -logical :: test_once=.false. -integer(kind=i_kind)::itest=0 -character(len=32) :: fileoutput -character(len=4) :: str_rank -integer :: n_owned_size -integer, pointer :: ghost(:) -!clttype(atlas_FunctionSpace) :: fs -type(atlas_functionspace) :: fs_generic -type(atlas_functionspace_StructuredColumns) :: fs -integer :: ierr -integer :: member_index -integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp -integer :: total_km_a_all,ii,nvargrp -integer :: ilev1,ilev2 - -!clt now noly consider t -! afield = fields%field('air_temperature') -! call afield%data(t) -!*** From the analysis to first generation of filter grid - member_index=index_member_in+1 ! the privous ensemble index starts from 0) - jscale=self%imem2scale(member_index) - nvargrp=self%nvargrp - call btim(mg_multiply_time) - call btim(mg_preprocess_time) - if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,1)%km2 > 0) then - write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & -& "in which, the first level contains the 2d variables and others zeros " - - stop !to use a better exit procdure - endif - myrank=self%rank - write(str_rank,"(I4.4)")myrank - if(self%intstate(jscale,1)%l_for_localization) then - fileoutput="mgbftest_loc_"//str_rank//".txt" - else - fileoutput="mgbftest_static_"//str_rank//".txt" - endif - - allocate(nlev_vargrp(nvargrp)) - nlev_vargrp=0 - total_km_a_all=0 -!clt do iscale=1,self%nscale - do ivargrp=1,self%nvargrp - if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & - self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then - error stop "for being now, the filtering grids at the start of MGBF should be the same" - endif - total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all - nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all - enddo - - nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps - - n2d=0 - l2d_encountered=.false. - ivargrp0=1 - allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) - allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) - allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) - allocate(rnormalization(total_km_a_all,nvargrp)) - rnormalization=0.0 - work2d_mgbf=0.0 - ii=1 - do ivargrp=1,nvargrp - do k=1,self%intstate(jscale,ivargrp)%km2 -!clt if for localization , km2=0 only for -!clt only for l_2dvar_last_vertical_lev - rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) - ii=ii+1 - enddo -!clt if for localization , km2=0 - do k=1,self%intstate(jscale,ivargrp)%km3 - rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) - ii=ii+nz3d - enddo - enddo - - dim2d=shape(work2d_mgbf) - - dim3d=shape(work_mgbf) - nxloc=dim3d(2) - nyloc=dim3d(3) - nzloc=dim3d(1) - nvar=fields%size() - allocate( varvlev_index(nvar,3)) - varvlev_index=0 - - ilev=1 - do isize=1,fields%size() - - afield= fields%field(isize) !clttodo - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() - if(afield%rank() == 2) then - write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() - nz=afield%levels() - write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz - call afield%data(ptr_2d) - if(nz /= 1 .and. nz /= nz3d ) then - write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d - call flush(6) - stop - endif - - if(nz == 1) then - !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then - if(self%intstate(jscale,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - if(n_owned_size >0 ) then - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d - endif - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - - - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - - if(nz == 1) then - l2d_encountered=.true. - n2d=n2d+1 - endif - if(nz > 1) then - if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then - write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" - call flush(6) - error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending - endif - endif - if(isize==1) then - varvlev_index(isize,1)= 1 - !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then - if(.not.self%intstate(jscale,1)%l_for_localization )then - varvlev_index(isize,2)= nz - else - varvlev_index(isize,2)= nz3d - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - else - !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d - varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 - if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then - varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 - else - varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - endif - jvargrp=self%ivar2grp(isize) - - - ilev=varvlev_index(isize,2)+1 - elseif (afield%rank() == 3) then - write(6,*)'this case needs more work, stop' ! a better exption handling to be added - call flush(6) - stop - call afield%data(ptr_3d) - nz=afield%levels() - work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - stop - endif - enddo - do k=1,nzloc - work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) - enddo - - if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then - write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' - stop ! a better exception handling is to be added - endif - - if(test_once.and..1.gt.2) then - open(iounit,file=trim(fileoutput), status='replace',form="formatted") - write(iounit,*) work_mgbf - test_once=.false. - close(iounit) - endif - ii=1 - do ivargrp=1,nvargrp - allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) - allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) - vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) - - call etim(mg_preprocess_time) - - call btim(mg_anal_to_filt_time) - call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) - call etim(mg_anal_to_filt_time) - call btim(mg_filtering_time) - call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) - call etim(mg_filtering_time) - - !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) - call btim(mg_filt_to_anal_time) - call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) - call etim(mg_filt_to_anal_time) - !clt# work_mgbf=999.0 !thinkdeb for debug - - call btim(mg_postprocess_time) - do k=1,nlev_vargrp(ivargrp) - vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) - enddo - work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) - ii=ii+nlev_vargrp(ivargrp) - deallocate(vargrp_work_mgbf) - deallocate(vargrp_work_mgbf2) - enddo ! ivargrp - if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx - work_mgbf=work_mgbf2 - else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures - allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - work1var_mgbf=0.0 - if(nvargrp == 1 ) then - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) - enddo - do jvar=1,nvar - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - else - do jvar=1,nvar - jvargrp=self%ivar2grp(jvar) - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - ivargrp=self%ivar2grp(ivar) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) - enddo - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - endif - deallocate(work1var_mgbf) - endif - do k=1,nzloc - work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) - enddo - ilev=1 - n_owned_size=0 - do isize=1,fields%size() - - afield=fields%field(isize) !clttodo - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - if(afield%rank() == 2) then - call afield%data(ptr_2d) - nz=afield%levels() - lev1=varvlev_index(isize,1) - if(nz.gt.1) then - if(n_owned_size >0 ) then - ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(self%intstate(1,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - write(6,*)'suspicous situation while n_owned_szie =0 ,stop' - call flush(6) - stop - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - - endif - endif !nz >1 or not - - elseif (afield%rank() == 3) then - call afield%data(ptr_3d) - nz=afield%levels() - write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo - call flush(6) - stop - - - !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - call flush(6) - stop - endif - enddo - - call etim(mg_postprocess_time) - - - - - deallocate(work_mgbf) - deallocate(work_mgbf2) - deallocate(work2d_mgbf) - deallocate(rnormalization) - deallocate( varvlev_index) - !clt enddo !for iscale - call etim(mg_multiply_time) - deallocate(nlev_vargrp) - -end subroutine multiply - -! -------------------------------------------------------------------------------------------------- - -subroutine multiply_ad(self, fields) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields - -! This routine only needed when B = G^T G (sqrt-factored) - -! To do list for this method -! 1. Convert fields (Atlas fieldsets) to MGBF bundle -! 2. Call MGBF covariance operator adjoint (sqrt version) -! afield = fields%field('stream_function') -! call afield%data(var3d) -! var3d=0.0_r_kind - -end subroutine multiply_ad -function imem2scale(self,imem) result(iscale) - class(mgbf_covariance),intent(in)::self - integer, intent(in)::imem - integer :: iscale - iscale=1 - do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) - iscale=iscale+1 - enddo - -end function imem2scale -function ivar2grp(self,ivar) result(jvargrp) - class(mgbf_covariance),intent(in)::self - integer, intent(in)::ivar - integer :: jvargrp - jvargrp=1 - do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) - jvargrp=jvargrp+1 - enddo - -end function ivar2grp - -! -------------------------------------------------------------------------------------------------- - -end module mgbf_covariance_mod - +! (C) Copyright 2022 United States Government as represented by the Administrator of the National +! Aeronautics and Space Administration +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + +module mgbf_covariance_mod + +! atlas +use atlas_module, only: atlas_fieldset, atlas_field +use atlas_module, only: atlas_functionspace +use atlas_module, only: atlas_functionspace_StructuredColumns + +! fckit +use fckit_mpi_module, only: fckit_mpi_comm +use fckit_configuration_module, only: fckit_configuration + +! oops +use mgbf_kinds, only: r_kind,i_kind +use random_mod + +! saber +!clt use mgbf_grid_mod, only: mgbf_grid +use mg_intstate , only: mg_intstate_type +use mg_timers +use iso_c_binding +use mpi +use, intrinsic :: ieee_arithmetic +implicit none +private +public mgbf_covariance + + +! Fortran class header +type :: mgbf_covariance + type(mg_intstate_type),allocatable :: intstate(:,:) + integer :: nscale=1 + integer :: nvargrp=1 + logical :: noMGBF + logical :: bypassMGBFbe + logical :: cv ! cv=.true.; sv=.false. + integer :: mp_comm_world + integer :: rank + logical :: l_2dvar_last_vertical_level=.true. !when used for localization,2dvars are put on the last vertical level + !when the fields in fset are stored from top to bottom +!clt integer :: lat2,lon2 ! these belog to mgbf_grid + character(len=:), allocatable :: mgbf_nml + character(len=80), allocatable :: mgbf_nml_group(:,:) + real, allocatable :: multigrp_cor(:,:) + integer, allocatable :: iscalegroup(:) + integer, allocatable :: ivargroup(:) + + contains + procedure, public :: create + procedure, public :: delete + procedure, public :: randomize + procedure, public :: multiply + procedure, public :: multiply_ad + procedure, private :: imem2scale + procedure, private :: ivar2grp +end type mgbf_covariance + +character(len=*), parameter :: myname='mgbf_covariance_mod' + +! -------------------------------------------------------------------------------------------------- + +contains + +! -------------------------------------------------------------------------------------------------- + +subroutine create(self, comm, config, background, firstguess) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(fckit_mpi_comm), intent(in) :: comm +type(fckit_configuration), intent(in) :: config +type(atlas_fieldset), intent(in) :: background +type(atlas_fieldset), intent(in) :: firstguess + +! Locals +character(len=*), parameter :: myname_=myname//'*create' +character(len=:), allocatable :: mgbf_nml,centralblockname +logical :: central +integer :: layout(2) +integer :: myunit +integer :: iscale,ivargrp +integer :: nscale=1, nvargrp=1 +type(atlas_field) :: afield +character(len=80) :: readin_mgbf_nml_group(99) +real :: readin_multigrp_cor(99)=1.0 +integer :: readin_iscalegroup(99)=999 +integer :: readin_ivargroup(99)=999 +integer ::i,j, ii +namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup + +! Hold communicator +! ----------------- +!self%mp_comm_world=comm%communicator() + +! Create the grid +! --------------- +!clt call self%grid%create(config, comm) +self%rank = comm%rank() + +call config%get_or_die("saber block name", centralblockname) +!clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) +if (config%has("mgbf sdl and vdl init namelist file")) then + call config%get_or_die("mgbf sdl and vdl init namelist file", mgbf_nml) + open(newunit=myunit,file=trim(mgbf_nml),status='old') +!# open(unit=10,file=mgbf_nml,status='old',action='read') + read(myunit,nml=parameters_mgbf_init) + close(unit=myunit) + self%nscale=nscale + self%nvargrp=nvargrp + allocate(self%mgbf_nml_group(nscale,nvargrp)) + allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + allocate(self%iscalegroup(nscale) ) + allocate(self%ivargroup(nvargrp) ) + ii=1 + do iscale=1,nscale + do ivargrp=1,nvargrp + self%mgbf_nml_group(iscale,ivargrp)=readin_mgbf_nml_group(ii) + ii=ii+1 + enddo + enddo + do iscale=1,nscale + self%iscalegroup(iscale)=readin_iscalegroup(iscale) + enddo + ii=1 + do i=1,nvargrp + do j=1,nvargrp + self%multigrp_cor(i,j)=readin_multigrp_cor(ii) + ii=ii+1 + enddo + enddo + do i=1,nvargrp + self%ivargroup(i)=readin_ivargroup(iscale) + enddo +else +call config%get_or_die("mgbf namelist file ", mgbf_nml) +!still need allocate them though nscale=nvargrp=1 + allocate(self%mgbf_nml_group(nscale,nvargrp)) + allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + self%multigrp_cor=1.0 + allocate(self%iscalegroup(nscale) ) + self%iscalegroup(nscale) =1 + allocate(self%ivargroup(nvargrp) ) + self%ivargroup=1 +endif + + +if(nscale == 1 .and. nvargrp ==1 ) then + self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used + !and hence, it would be backward-compatible + ! the previous namelist files could be still used,correctly, + ! by the current sdl/vdl enhanced version +endif +allocate(self%intstate(nscale,nvargrp)) +do iscale=1,nscale + do ivargrp=1,nvargrp + call self%intstate(iscale,ivargrp)%mg_initialize(self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml + enddo +enddo +! Get background (temporary test of the functionality) +!cltafield = background%field('air_temperature') +!clt call afield%data(t) + +end subroutine create + +! -------------------------------------------------------------------------------------------------- + +subroutine delete(self) + +! Arguments +class(mgbf_covariance) :: self +integer:: iscale,ivargrp + +! Locals + +!clt //if (.not. self%noMGBF) then + call print_mg_timers("mg_timer_output",999,self%rank) + +do iscale=1,self%nscale + do ivargrp=1,self%nvargrp + call self%intstate(iscale,ivargrp)%mg_finalize() + enddo +enddo +!clt endif + +! Delete the grid +! --------------- +!clt call self%grid%delete() + +end subroutine delete + +! -------------------------------------------------------------------------------------------------- + +subroutine randomize(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: psi(:,:), chi(:,:), t(:,:), q(:,:), qi(:,:), ql(:,:), o3(:,:) +real(kind=r_kind), pointer :: ps(:) + +integer, parameter :: rseed = 3 +write(6,*)'thinkdeb this is to be implemente' +call flush(6) +stop +! Get Atlas field +afield = fields%field('stream_function') +call afield%data(psi) + +afield = fields%field('velocity_potential') +call afield%data(chi) + +afield = fields%field('air_temperature') +call afield%data(t) + +afield = fields%field('surface_pressure') +call afield%data(ps) + +afield = fields%field('specific_humidity') +call afield%data(q) + +afield = fields%field('cloud_liquid_ice') +call afield%data(qi) + +afield = fields%field('cloud_liquid_water') +call afield%data(ql) + +afield = fields%field('ozone_mass_mixing_ratio') +call afield%data(o3) + + +! Set fields to random numbers +call normal_distribution(psi, 0.0_r_kind, 1.0_r_kind, rseed) + + +end subroutine randomize + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply(self, fields,index_member_in) +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields +integer , intent(in) :: index_member_in +type(atlas_fieldset) :: fields_tmp +type(atlas_functionspace) :: afunctionspace + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: ptr_2d(:,:) +real(kind=r_kind), pointer :: ptr_3d(:,:,:) +integer(kind=i_kind):: nz,ilev,isize +real(kind=r_kind), allocatable :: work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) +real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) +real(kind=r_kind), allocatable :: work2d_mgbf(:,:) +real(kind=r_kind), allocatable :: rnormalization(:,:) +integer(kind=i_kind), allocatable :: nlev_vargrp(:) +integer(kind=i_kind) :: dim2d(2),dim3d(3) +integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d +integer(kind=i_kind)::nvar +integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit +integer(kind=i_kind):: n2d +integer(kind=i_kind),allocatable :: varvlev_index(:,:) +logical :: l2d_encountered +logical :: test_once=.false. +integer(kind=i_kind)::itest=0 +character(len=32) :: fileoutput +character(len=4) :: str_rank +integer :: n_owned_size +integer, pointer :: ghost(:) +!clttype(atlas_FunctionSpace) :: fs +type(atlas_functionspace_StructuredColumns) :: fs +integer :: ierr +real(kind=8) :: val +integer :: member_index +integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp +integer :: total_km_a_all,ii,nvargrp +integer :: ilev1,ilev2 + +!clt now noly consider t +! afield = fields%field('air_temperature') +! call afield%data(t) +!*** From the analysis to first generation of filter grid + member_index=index_member_in+1 ! the privous ensemble index starts from 0) + jscale=self%imem2scale(member_index) + nvargrp=self%nvargrp + call btim(mg_multiply_time) + call btim(mg_preprocess_time) + if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,1)%km2 > 0) then + write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & +& "in which, the first level contains the 2d variables and others zeros " + + stop !to use a better exit procdure + endif + myrank=self%rank + write(str_rank,"(I4.4)")myrank + if(self%intstate(jscale,1)%l_for_localization) then + fileoutput="mgbftest_loc_"//str_rank//".txt" + else + fileoutput="mgbftest_static_"//str_rank//".txt" + endif + + allocate(nlev_vargrp(nvargrp)) + nlev_vargrp=0 + total_km_a_all=0 +!clt do iscale=1,self%nscale + do ivargrp=1,self%nvargrp + if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & + self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then + error stop "for being now, the filtering grids at the start of MGBF should be the same" + endif + total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all + nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all + enddo + + nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps + + n2d=0 + l2d_encountered=.false. + ivargrp0=1 + allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) + allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) + allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) + allocate(rnormalization(total_km_a_all,nvargrp)) + rnormalization=0.0 + work2d_mgbf=0.0 + ii=1 + do ivargrp=1,nvargrp + do k=1,self%intstate(jscale,ivargrp)%km2 +!clt if for localization , km2=0 only for +!clt only for l_2dvar_last_vertical_lev + rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) + ii=ii+1 + enddo +!clt if for localization , km2=0 + do k=1,self%intstate(jscale,ivargrp)%km3 + rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) + ii=ii+nz3d + enddo + enddo + + dim2d=shape(work2d_mgbf) + + dim3d=shape(work_mgbf) + nxloc=dim3d(2) + nyloc=dim3d(3) + nzloc=dim3d(1) + nvar=fields%size() + allocate( varvlev_index(nvar,3)) + varvlev_index=0 + + ilev=1 + do isize=1,fields%size() + + afield= fields%field(isize) !clttodo + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() + if(afield%rank() == 2) then + nz=afield%levels() + call afield%data(ptr_2d) + if(nz /= 1 .and. nz /= nz3d ) then + write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d + call flush(6) + stop + endif + + if(nz == 1) then + !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + if(n_owned_size >0 ) then + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + endif + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + + + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + + if(nz == 1) then + l2d_encountered=.true. + n2d=n2d+1 + endif + if(nz > 1) then + if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then + write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" + call flush(6) + error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending + endif + endif + if(isize==1) then + varvlev_index(isize,1)= 1 + !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,1)%l_for_localization )then + varvlev_index(isize,2)= nz + else + varvlev_index(isize,2)= nz3d + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + else + !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d + varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 + if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then + varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 + else + varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + endif + jvargrp=self%ivar2grp(isize) + + + ilev=varvlev_index(isize,2)+1 + elseif (afield%rank() == 3) then + write(6,*)'this case needs more work, stop' ! a better exption handling to be added + call flush(6) + stop + call afield%data(ptr_3d) + nz=afield%levels() + work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + stop + endif + enddo + do k=1,nzloc + work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) + enddo + + if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then + write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' + stop ! a better exception handling is to be added + endif + + if(test_once.and..1.gt.2) then + open(iounit,file=trim(fileoutput), status='replace',form="formatted") + write(iounit,*) work_mgbf + test_once=.false. + close(iounit) + endif + ii=1 + do ivargrp=1,nvargrp + allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) + allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) + vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) + + call etim(mg_preprocess_time) + + call btim(mg_anal_to_filt_time) + call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) + call etim(mg_anal_to_filt_time) + call btim(mg_filtering_time) + call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) + call etim(mg_filtering_time) + + !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) + call btim(mg_filt_to_anal_time) + call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) + call etim(mg_filt_to_anal_time) + !clt# work_mgbf=999.0 !thinkdeb for debug + + call btim(mg_postprocess_time) + do k=1,nlev_vargrp(ivargrp) + vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) + enddo + work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) + ii=ii+nlev_vargrp(ivargrp) + deallocate(vargrp_work_mgbf) + deallocate(vargrp_work_mgbf2) + enddo ! ivargrp + if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx + work_mgbf=work_mgbf2 + else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures + allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + work1var_mgbf=0.0 + if(nvargrp == 1 ) then + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) + enddo + do jvar=1,nvar + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + else + do jvar=1,nvar + jvargrp=self%ivar2grp(jvar) + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + ivargrp=self%ivar2grp(ivar) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) + enddo + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + endif + deallocate(work1var_mgbf) + endif + do k=1,nzloc + work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + enddo + ilev=1 + n_owned_size=0 + do isize=1,fields%size() + + afield=fields%field(isize) !clttodo + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + if(afield%rank() == 2) then + call afield%data(ptr_2d) + nz=afield%levels() + lev1=varvlev_index(isize,1) + if(nz.gt.1) then + if(n_owned_size >0 ) then + ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(self%intstate(1,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + write(6,*)'suspicous situation while n_owned_szie =0 ,stop' + call flush(6) + stop + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + + endif + endif !nz >1 or not + + elseif (afield%rank() == 3) then + call afield%data(ptr_3d) + nz=afield%levels() + write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo + call flush(6) + stop + + + !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + call flush(6) + stop + endif + enddo + + call etim(mg_postprocess_time) + + call afield%final() + + + deallocate(work_mgbf) + deallocate(work_mgbf2) + deallocate(work2d_mgbf) + deallocate(rnormalization) + deallocate( varvlev_index) + !clt enddo !for iscale + call etim(mg_multiply_time) + deallocate(nlev_vargrp) + +end subroutine multiply + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply_ad(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! This routine only needed when B = G^T G (sqrt-factored) + +! To do list for this method +! 1. Convert fields (Atlas fieldsets) to MGBF bundle +! 2. Call MGBF covariance operator adjoint (sqrt version) +! afield = fields%field('stream_function') +! call afield%data(var3d) +! var3d=0.0_r_kind + +end subroutine multiply_ad +function imem2scale(self,imem) result(iscale) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::imem + integer :: iscale + iscale=1 + do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) + iscale=iscale+1 + enddo + +end function imem2scale +function ivar2grp(self,ivar) result(jvargrp) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::ivar + integer :: jvargrp + jvargrp=1 + do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) + jvargrp=jvargrp+1 + enddo + +end function ivar2grp + +! -------------------------------------------------------------------------------------------------- + +end module mgbf_covariance_mod From 9363dca8d6b5403ab268d6c3edc2d826f1570aa2 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Mon, 24 Nov 2025 14:59:12 +0000 Subject: [PATCH 098/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 8b8979738..20d398761 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -291,6 +291,10 @@ subroutine multiply(self, fields,index_member_in) ! afield = fields%field('air_temperature') ! call afield%data(t) !*** From the analysis to first generation of filter grid + if(index_member >= 999) then ! not set previously and should not be used, + ! namely, it is not a sdl/vdl run. + index_member= 0 + enddif member_index=index_member_in+1 ! the privous ensemble index starts from 0) jscale=self%imem2scale(member_index) nvargrp=self%nvargrp From 67f43bb127306af1b980adb1e419eaa6aedd0260 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Wed, 26 Nov 2025 16:33:02 +0000 Subject: [PATCH 099/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 1383 +++++++++-------- src/saber/mgbf/mgbf_lib/mg_entrymod.f90 | 6 +- 2 files changed, 722 insertions(+), 667 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 20d398761..769cf8c0b 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -1,666 +1,717 @@ -! (C) Copyright 2022 United States Government as represented by the Administrator of the National -! Aeronautics and Space Administration -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. - -module mgbf_covariance_mod - -! atlas -use atlas_module, only: atlas_fieldset, atlas_field -use atlas_module, only: atlas_functionspace -use atlas_module, only: atlas_functionspace_StructuredColumns - -! fckit -use fckit_mpi_module, only: fckit_mpi_comm -use fckit_configuration_module, only: fckit_configuration - -! oops -use mgbf_kinds, only: r_kind,i_kind -use random_mod - -! saber -!clt use mgbf_grid_mod, only: mgbf_grid -use mg_intstate , only: mg_intstate_type -use mg_timers -use iso_c_binding -use mpi -use, intrinsic :: ieee_arithmetic -implicit none -private -public mgbf_covariance - - -! Fortran class header -type :: mgbf_covariance - type(mg_intstate_type),allocatable :: intstate(:,:) - integer :: nscale=1 - integer :: nvargrp=1 - logical :: noMGBF - logical :: bypassMGBFbe - logical :: cv ! cv=.true.; sv=.false. - integer :: mp_comm_world - integer :: rank - logical :: l_2dvar_last_vertical_level=.true. !when used for localization,2dvars are put on the last vertical level - !when the fields in fset are stored from top to bottom -!clt integer :: lat2,lon2 ! these belog to mgbf_grid - character(len=:), allocatable :: mgbf_nml - character(len=80), allocatable :: mgbf_nml_group(:,:) - real, allocatable :: multigrp_cor(:,:) - integer, allocatable :: iscalegroup(:) - integer, allocatable :: ivargroup(:) - - contains - procedure, public :: create - procedure, public :: delete - procedure, public :: randomize - procedure, public :: multiply - procedure, public :: multiply_ad - procedure, private :: imem2scale - procedure, private :: ivar2grp -end type mgbf_covariance - -character(len=*), parameter :: myname='mgbf_covariance_mod' - -! -------------------------------------------------------------------------------------------------- - -contains - -! -------------------------------------------------------------------------------------------------- - -subroutine create(self, comm, config, background, firstguess) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(fckit_mpi_comm), intent(in) :: comm -type(fckit_configuration), intent(in) :: config -type(atlas_fieldset), intent(in) :: background -type(atlas_fieldset), intent(in) :: firstguess - -! Locals -character(len=*), parameter :: myname_=myname//'*create' -character(len=:), allocatable :: mgbf_nml,centralblockname -logical :: central -integer :: layout(2) -integer :: myunit -integer :: iscale,ivargrp -integer :: nscale=1, nvargrp=1 -type(atlas_field) :: afield -character(len=80) :: readin_mgbf_nml_group(99) -real :: readin_multigrp_cor(99)=1.0 -integer :: readin_iscalegroup(99)=999 -integer :: readin_ivargroup(99)=999 -integer ::i,j, ii -namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup - -! Hold communicator -! ----------------- -!self%mp_comm_world=comm%communicator() - -! Create the grid -! --------------- -!clt call self%grid%create(config, comm) -self%rank = comm%rank() - -call config%get_or_die("saber block name", centralblockname) -!clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) -if (config%has("mgbf sdl and vdl init namelist file")) then - call config%get_or_die("mgbf sdl and vdl init namelist file", mgbf_nml) - open(newunit=myunit,file=trim(mgbf_nml),status='old') -!# open(unit=10,file=mgbf_nml,status='old',action='read') - read(myunit,nml=parameters_mgbf_init) - close(unit=myunit) - self%nscale=nscale - self%nvargrp=nvargrp - allocate(self%mgbf_nml_group(nscale,nvargrp)) - allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship - allocate(self%iscalegroup(nscale) ) - allocate(self%ivargroup(nvargrp) ) - ii=1 - do iscale=1,nscale - do ivargrp=1,nvargrp - self%mgbf_nml_group(iscale,ivargrp)=readin_mgbf_nml_group(ii) - ii=ii+1 - enddo - enddo - do iscale=1,nscale - self%iscalegroup(iscale)=readin_iscalegroup(iscale) - enddo - ii=1 - do i=1,nvargrp - do j=1,nvargrp - self%multigrp_cor(i,j)=readin_multigrp_cor(ii) - ii=ii+1 - enddo - enddo - do i=1,nvargrp - self%ivargroup(i)=readin_ivargroup(iscale) - enddo -else -call config%get_or_die("mgbf namelist file ", mgbf_nml) -!still need allocate them though nscale=nvargrp=1 - allocate(self%mgbf_nml_group(nscale,nvargrp)) - allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship - self%multigrp_cor=1.0 - allocate(self%iscalegroup(nscale) ) - self%iscalegroup(nscale) =1 - allocate(self%ivargroup(nvargrp) ) - self%ivargroup=1 -endif - - -if(nscale == 1 .and. nvargrp ==1 ) then - self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used - !and hence, it would be backward-compatible - ! the previous namelist files could be still used,correctly, - ! by the current sdl/vdl enhanced version -endif -allocate(self%intstate(nscale,nvargrp)) -do iscale=1,nscale - do ivargrp=1,nvargrp - call self%intstate(iscale,ivargrp)%mg_initialize(self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml - enddo -enddo -! Get background (temporary test of the functionality) -!cltafield = background%field('air_temperature') -!clt call afield%data(t) - -end subroutine create - -! -------------------------------------------------------------------------------------------------- - -subroutine delete(self) - -! Arguments -class(mgbf_covariance) :: self -integer:: iscale,ivargrp - -! Locals - -!clt //if (.not. self%noMGBF) then - call print_mg_timers("mg_timer_output",999,self%rank) - -do iscale=1,self%nscale - do ivargrp=1,self%nvargrp - call self%intstate(iscale,ivargrp)%mg_finalize() - enddo -enddo -!clt endif - -! Delete the grid -! --------------- -!clt call self%grid%delete() - -end subroutine delete - -! -------------------------------------------------------------------------------------------------- - -subroutine randomize(self, fields) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields - -! Locals -type(atlas_field) :: afield -real(kind=r_kind), pointer :: psi(:,:), chi(:,:), t(:,:), q(:,:), qi(:,:), ql(:,:), o3(:,:) -real(kind=r_kind), pointer :: ps(:) - -integer, parameter :: rseed = 3 -write(6,*)'thinkdeb this is to be implemente' -call flush(6) -stop -! Get Atlas field -afield = fields%field('stream_function') -call afield%data(psi) - -afield = fields%field('velocity_potential') -call afield%data(chi) - -afield = fields%field('air_temperature') -call afield%data(t) - -afield = fields%field('surface_pressure') -call afield%data(ps) - -afield = fields%field('specific_humidity') -call afield%data(q) - -afield = fields%field('cloud_liquid_ice') -call afield%data(qi) - -afield = fields%field('cloud_liquid_water') -call afield%data(ql) - -afield = fields%field('ozone_mass_mixing_ratio') -call afield%data(o3) - - -! Set fields to random numbers -call normal_distribution(psi, 0.0_r_kind, 1.0_r_kind, rseed) - - -end subroutine randomize - -! -------------------------------------------------------------------------------------------------- - -subroutine multiply(self, fields,index_member_in) -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields -integer , intent(in) :: index_member_in -type(atlas_fieldset) :: fields_tmp -type(atlas_functionspace) :: afunctionspace - -! Locals -type(atlas_field) :: afield -real(kind=r_kind), pointer :: ptr_2d(:,:) -real(kind=r_kind), pointer :: ptr_3d(:,:,:) -integer(kind=i_kind):: nz,ilev,isize -real(kind=r_kind), allocatable :: work_mgbf(:,:,:) -real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) -real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) -real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) -real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) -real(kind=r_kind), allocatable :: work2d_mgbf(:,:) -real(kind=r_kind), allocatable :: rnormalization(:,:) -integer(kind=i_kind), allocatable :: nlev_vargrp(:) -integer(kind=i_kind) :: dim2d(2),dim3d(3) -integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d -integer(kind=i_kind)::nvar -integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit -integer(kind=i_kind):: n2d -integer(kind=i_kind),allocatable :: varvlev_index(:,:) -logical :: l2d_encountered -logical :: test_once=.false. -integer(kind=i_kind)::itest=0 -character(len=32) :: fileoutput -character(len=4) :: str_rank -integer :: n_owned_size -integer, pointer :: ghost(:) -!clttype(atlas_FunctionSpace) :: fs -type(atlas_functionspace_StructuredColumns) :: fs -integer :: ierr -real(kind=8) :: val -integer :: member_index -integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp -integer :: total_km_a_all,ii,nvargrp -integer :: ilev1,ilev2 - -!clt now noly consider t -! afield = fields%field('air_temperature') -! call afield%data(t) -!*** From the analysis to first generation of filter grid - if(index_member >= 999) then ! not set previously and should not be used, - ! namely, it is not a sdl/vdl run. - index_member= 0 - enddif - member_index=index_member_in+1 ! the privous ensemble index starts from 0) - jscale=self%imem2scale(member_index) - nvargrp=self%nvargrp - call btim(mg_multiply_time) - call btim(mg_preprocess_time) - if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,1)%km2 > 0) then - write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & -& "in which, the first level contains the 2d variables and others zeros " - - stop !to use a better exit procdure - endif - myrank=self%rank - write(str_rank,"(I4.4)")myrank - if(self%intstate(jscale,1)%l_for_localization) then - fileoutput="mgbftest_loc_"//str_rank//".txt" - else - fileoutput="mgbftest_static_"//str_rank//".txt" - endif - - allocate(nlev_vargrp(nvargrp)) - nlev_vargrp=0 - total_km_a_all=0 -!clt do iscale=1,self%nscale - do ivargrp=1,self%nvargrp - if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & - self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then - error stop "for being now, the filtering grids at the start of MGBF should be the same" - endif - total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all - nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all - enddo - - nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps - - n2d=0 - l2d_encountered=.false. - ivargrp0=1 - allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) - allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) - allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) - allocate(rnormalization(total_km_a_all,nvargrp)) - rnormalization=0.0 - work2d_mgbf=0.0 - ii=1 - do ivargrp=1,nvargrp - do k=1,self%intstate(jscale,ivargrp)%km2 -!clt if for localization , km2=0 only for -!clt only for l_2dvar_last_vertical_lev - rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) - ii=ii+1 - enddo -!clt if for localization , km2=0 - do k=1,self%intstate(jscale,ivargrp)%km3 - rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) - ii=ii+nz3d - enddo - enddo - - dim2d=shape(work2d_mgbf) - - dim3d=shape(work_mgbf) - nxloc=dim3d(2) - nyloc=dim3d(3) - nzloc=dim3d(1) - nvar=fields%size() - allocate( varvlev_index(nvar,3)) - varvlev_index=0 - - ilev=1 - do isize=1,fields%size() - - afield= fields%field(isize) !clttodo - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() - if(afield%rank() == 2) then - nz=afield%levels() - call afield%data(ptr_2d) - if(nz /= 1 .and. nz /= nz3d ) then - write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d - call flush(6) - stop - endif - - if(nz == 1) then - !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then - if(self%intstate(jscale,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - if(n_owned_size >0 ) then - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d - endif - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - - - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - else - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - - if(nz == 1) then - l2d_encountered=.true. - n2d=n2d+1 - endif - if(nz > 1) then - if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then - write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" - call flush(6) - error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending - endif - endif - if(isize==1) then - varvlev_index(isize,1)= 1 - !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then - if(.not.self%intstate(jscale,1)%l_for_localization )then - varvlev_index(isize,2)= nz - else - varvlev_index(isize,2)= nz3d - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - else - !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d - varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 - if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then - varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 - else - varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - endif - jvargrp=self%ivar2grp(isize) - - - ilev=varvlev_index(isize,2)+1 - elseif (afield%rank() == 3) then - write(6,*)'this case needs more work, stop' ! a better exption handling to be added - call flush(6) - stop - call afield%data(ptr_3d) - nz=afield%levels() - work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - stop - endif - enddo - do k=1,nzloc - work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) - enddo - - if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then - write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' - stop ! a better exception handling is to be added - endif - - if(test_once.and..1.gt.2) then - open(iounit,file=trim(fileoutput), status='replace',form="formatted") - write(iounit,*) work_mgbf - test_once=.false. - close(iounit) - endif - ii=1 - do ivargrp=1,nvargrp - allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) - allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) - vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) - - call etim(mg_preprocess_time) - - call btim(mg_anal_to_filt_time) - call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) - call etim(mg_anal_to_filt_time) - call btim(mg_filtering_time) - call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) - call etim(mg_filtering_time) - - !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) - call btim(mg_filt_to_anal_time) - call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) - call etim(mg_filt_to_anal_time) - !clt# work_mgbf=999.0 !thinkdeb for debug - - call btim(mg_postprocess_time) - do k=1,nlev_vargrp(ivargrp) - vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) - enddo - work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) - ii=ii+nlev_vargrp(ivargrp) - deallocate(vargrp_work_mgbf) - deallocate(vargrp_work_mgbf2) - enddo ! ivargrp - if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx - work_mgbf=work_mgbf2 - else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures - allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - work1var_mgbf=0.0 - if(nvargrp == 1 ) then - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) - enddo - do jvar=1,nvar - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - else - do jvar=1,nvar - jvargrp=self%ivar2grp(jvar) - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - ivargrp=self%ivar2grp(ivar) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) - enddo - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - endif - deallocate(work1var_mgbf) - endif - do k=1,nzloc - work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) - enddo - ilev=1 - n_owned_size=0 - do isize=1,fields%size() - - afield=fields%field(isize) !clttodo - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - if(afield%rank() == 2) then - call afield%data(ptr_2d) - nz=afield%levels() - lev1=varvlev_index(isize,1) - if(nz.gt.1) then - if(n_owned_size >0 ) then - ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(self%intstate(1,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - write(6,*)'suspicous situation while n_owned_szie =0 ,stop' - call flush(6) - stop - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - - endif - endif !nz >1 or not - - elseif (afield%rank() == 3) then - call afield%data(ptr_3d) - nz=afield%levels() - write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo - call flush(6) - stop - - - !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - call flush(6) - stop - endif - enddo - - call etim(mg_postprocess_time) - - call afield%final() - - - deallocate(work_mgbf) - deallocate(work_mgbf2) - deallocate(work2d_mgbf) - deallocate(rnormalization) - deallocate( varvlev_index) - !clt enddo !for iscale - call etim(mg_multiply_time) - deallocate(nlev_vargrp) - -end subroutine multiply - -! -------------------------------------------------------------------------------------------------- - -subroutine multiply_ad(self, fields) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields - -! This routine only needed when B = G^T G (sqrt-factored) - -! To do list for this method -! 1. Convert fields (Atlas fieldsets) to MGBF bundle -! 2. Call MGBF covariance operator adjoint (sqrt version) -! afield = fields%field('stream_function') -! call afield%data(var3d) -! var3d=0.0_r_kind - -end subroutine multiply_ad -function imem2scale(self,imem) result(iscale) - class(mgbf_covariance),intent(in)::self - integer, intent(in)::imem - integer :: iscale - iscale=1 - do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) - iscale=iscale+1 - enddo - -end function imem2scale -function ivar2grp(self,ivar) result(jvargrp) - class(mgbf_covariance),intent(in)::self - integer, intent(in)::ivar - integer :: jvargrp - jvargrp=1 - do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) - jvargrp=jvargrp+1 - enddo - -end function ivar2grp - -! -------------------------------------------------------------------------------------------------- - -end module mgbf_covariance_mod +! (C) Copyright 2022 United States Government as represented by the Administrator of the National +! Aeronautics and Space Administration +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + +module mgbf_covariance_mod + +! atlas +use atlas_module, only: atlas_fieldset, atlas_field +use atlas_module, only: atlas_functionspace +use atlas_module, only: atlas_functionspace_StructuredColumns +use atlas_module, only : atlas_functionspace, & + atlas_functionspace_nodecolumns, & + atlas_functionspace_pointcloud, & + atlas_functionspace_structuredcolumns, & + atlas_mesh_nodes, atlas_field + +use tools_func, only : sphere_dist +use tools_const, only : req ! Earth radius (m) + +! fckit +use fckit_mpi_module, only: fckit_mpi_comm +use fckit_configuration_module, only: fckit_configuration + +! oops +use mgbf_kinds, only: r_kind,i_kind +use random_mod + +! saber +!clt use mgbf_grid_mod, only: mgbf_grid +use mg_intstate , only: mg_intstate_type +use mg_timers +use mpi +use, intrinsic :: ieee_arithmetic +implicit none +private +public mgbf_covariance + +! Fortran class header +type :: mgbf_covariance + type(mg_intstate_type),allocatable :: intstate(:,:) + integer :: nscale=1 + integer :: nvargrp=1 + logical :: noMGBF + logical :: bypassMGBFbe + logical :: cv ! cv=.true.; sv=.false. + integer :: mp_comm_world + integer :: rank + logical :: l_2dvar_last_vertical_level=.true. !when used for localization,2dvars are put on the last vertical level + !when the fields in fset are stored from top to bottom +!clt integer :: lat2,lon2 ! these belog to mgbf_grid + character(len=:), allocatable :: mgbf_nml + character(len=80), allocatable :: mgbf_nml_group(:,:) + real, allocatable :: multigrp_cor(:,:) + integer, allocatable :: iscalegroup(:) + integer, allocatable :: ivargroup(:) + + contains + procedure, public :: create + procedure, public :: delete + procedure, public :: randomize + procedure, public :: multiply + procedure, public :: multiply_ad + procedure, private :: imem2scale + procedure, private :: ivar2grp +end type mgbf_covariance + +character(len=*), parameter :: myname='mgbf_covariance_mod' + +! -------------------------------------------------------------------------------------------------- + +contains + +! -------------------------------------------------------------------------------------------------- + +subroutine create(self, comm, config, funcspace, background, firstguess) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(fckit_mpi_comm), intent(in) :: comm +type(fckit_configuration), intent(in) :: config +type(atlas_functionspace), intent(in) :: funcspace +type(atlas_fieldset), intent(in) :: background +type(atlas_fieldset), intent(in) :: firstguess + +! Locals +real(r_kind) :: dist_rad, dist_m +integer :: ipt +character(len=*), parameter :: myname_=myname//'*create' +character(len=:), allocatable :: mgbf_nml,centralblockname +logical :: central +integer :: layout(2) +integer :: myunit +integer :: iscale,ivargrp +integer :: nscale=1, nvargrp=1 +type(atlas_field) :: afield, lonlat_field +type(atlas_functionspace_structuredcolumns) :: fs_sc +real(r_kind), pointer :: lonlat_ptr(:,:) +real(r_kind), allocatable :: lonlat_anl(:,:) +integer :: npts_owned +integer :: npts_total + + +character(len=80) :: readin_mgbf_nml_group(99) +real :: readin_multigrp_cor(99)=1.0 +integer :: readin_iscalegroup(99)=999 +integer :: readin_ivargroup(99)=999 +integer ::i,j, ii +namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup + +character(len=:), allocatable :: dump_json + +! Hold communicator +! ----------------- +!self%mp_comm_world=comm%communicator() + +! Create the grid +! --------------- +!clt call self%grid%create(config, comm) +self%rank = comm%rank() + +write(6,*)'thinkdeb mgbf create999 ' +write(6,*)'thinkdeb mgbf create999 config' + dump_json=config%json() ! serialize to a JSON string +write(6,'(A)')trim(dump_json) +call flush(6) +call config%get_or_die("saber block name", centralblockname) +!clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) +if (config%has("mgbf sdl and vdl init namelist file")) then + call config%get_or_die("mgbf sdl and vdl init namelist file", mgbf_nml) + open(newunit=myunit,file=trim(mgbf_nml),status='old') +!# open(unit=10,file=mgbf_nml,status='old',action='read') + read(myunit,nml=parameters_mgbf_init) + close(unit=myunit) + self%nscale=nscale + self%nvargrp=nvargrp + allocate(self%mgbf_nml_group(nscale,nvargrp)) + allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + allocate(self%iscalegroup(nscale) ) + allocate(self%ivargroup(nvargrp) ) + ii=1 + do iscale=1,nscale + do ivargrp=1,nvargrp + self%mgbf_nml_group(iscale,ivargrp)=readin_mgbf_nml_group(ii) + ii=ii+1 + enddo + enddo + do iscale=1,nscale + self%iscalegroup(iscale)=readin_iscalegroup(iscale) + enddo + ii=1 + do i=1,nvargrp + do j=1,nvargrp + self%multigrp_cor(i,j)=readin_multigrp_cor(ii) + ii=ii+1 + enddo + enddo + do i=1,nvargrp + self%ivargroup(i)=readin_ivargroup(iscale) + enddo +else +call config%get_or_die("mgbf namelist file ", mgbf_nml) +!still need allocate them though nscale=nvargrp=1 + allocate(self%mgbf_nml_group(nscale,nvargrp)) + allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + self%multigrp_cor=1.0 + allocate(self%iscalegroup(nscale) ) + self%iscalegroup(nscale) =1 + allocate(self%ivargroup(nvargrp) ) + self%ivargroup=1 +endif + + +if(nscale == 1 .and. nvargrp ==1 ) then + self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used + !and hence, it would be backward-compatible + ! the previous namelist files could be still used,correctly, + ! by the current sdl/vdl enhanced version +endif + +if (trim(funcspace%name()) /= 'StructuredColumns') then + error stop 'MGBF requires StructuredColumns function space' +end if +fs_sc = funcspace +lonlat_field = fs_sc%xy() +call lonlat_field%data(lonlat_ptr) +npts_owned = fs_sc%size_owned() +npts_total = size(lonlat_ptr,2) +write(6,*)'thinkdeb mgbf create npts_owned/_total ',npts_owned, ' ',npts_total +allocate(lonlat_anl(npts_total,2)) +lonlat_anl(:,1) = lonlat_ptr(1,1:npts_total) +lonlat_anl(:,2) = lonlat_ptr(2,1:npts_total) +call lonlat_field%final() + +write(6,*)'thinkdeb mgbf create999 4 ' +call flush(6) + +allocate(self%intstate(nscale,nvargrp)) +call flush(6) +do iscale=1,nscale + do ivargrp=1,nvargrp + write(6,*)'the999 nml is ', trim(self%mgbf_nml_group(iscale,ivargrp)) + call flush(6) + call self%intstate(iscale,ivargrp)%mg_initialize(n_owned_anl=npts_owned, & + anl_lonlat1d=lonlat_anl, inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml + enddo +enddo +write(6,*)'thinkdeb mgbf create999 10 ' +call flush(6) +if (allocated(lonlat_anl)) deallocate(lonlat_anl) +! Get background (temporary test of the functionality) +!cltafield = background%field('air_temperature') +!clt call afield%data(t) + +end subroutine create + +! -------------------------------------------------------------------------------------------------- + +subroutine delete(self) + +! Arguments +class(mgbf_covariance) :: self +integer:: iscale,ivargrp + +! Locals + +!clt //if (.not. self%noMGBF) then + call print_mg_timers("mg_timer_output",999,self%rank) + +do iscale=1,self%nscale + do ivargrp=1,self%nvargrp + call self%intstate(iscale,ivargrp)%mg_finalize() + enddo +enddo +!clt endif + +! Delete the grid +! --------------- +!clt call self%grid%delete() + +end subroutine delete + +! -------------------------------------------------------------------------------------------------- + +subroutine randomize(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: psi(:,:), chi(:,:), t(:,:), q(:,:), qi(:,:), ql(:,:), o3(:,:) +real(kind=r_kind), pointer :: ps(:) + +integer, parameter :: rseed = 3 +write(6,*)'thinkdeb this is to be implemente' +call flush(6) +stop +! Get Atlas field +afield = fields%field('stream_function') +call afield%data(psi) + +afield = fields%field('velocity_potential') +call afield%data(chi) + +afield = fields%field('air_temperature') +call afield%data(t) + +afield = fields%field('surface_pressure') +call afield%data(ps) + +afield = fields%field('specific_humidity') +call afield%data(q) + +afield = fields%field('cloud_liquid_ice') +call afield%data(qi) + +afield = fields%field('cloud_liquid_water') +call afield%data(ql) + +afield = fields%field('ozone_mass_mixing_ratio') +call afield%data(o3) + + +! Set fields to random numbers +call normal_distribution(psi, 0.0_r_kind, 1.0_r_kind, rseed) + + +end subroutine randomize + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply(self, fields,index_member_in) +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields +integer , intent(in) :: index_member_in +type(atlas_fieldset) :: fields_tmp +type(atlas_functionspace) :: afunctionspace + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: ptr_2d(:,:) +real(kind=r_kind), pointer :: ptr_3d(:,:,:) +integer(kind=i_kind):: nz,ilev,isize +real(kind=r_kind), allocatable :: work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) +real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) +real(kind=r_kind), allocatable :: work2d_mgbf(:,:) +real(kind=r_kind), allocatable :: rnormalization(:,:) +integer(kind=i_kind), allocatable :: nlev_vargrp(:) +integer(kind=i_kind) :: dim2d(2),dim3d(3) +integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d +integer(kind=i_kind)::nvar +integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit +integer(kind=i_kind):: n2d +integer(kind=i_kind),allocatable :: varvlev_index(:,:) +logical :: l2d_encountered +logical :: test_once=.false. +integer(kind=i_kind)::itest=0 +character(len=32) :: fileoutput +character(len=4) :: str_rank +integer :: n_owned_size +integer, pointer :: ghost(:) +!clttype(atlas_FunctionSpace) :: fs +type(atlas_functionspace) :: fs_generic +type(atlas_functionspace_StructuredColumns) :: fs +integer :: ierr +integer :: member_index +integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp +integer :: total_km_a_all,ii,nvargrp +integer :: ilev1,ilev2 + +!clt now noly consider t +! afield = fields%field('air_temperature') +! call afield%data(t) + if(index_member_in >= 999) then ! not set previously and should not be used, + member_index=1 ! the privous ensemble index starts from 0) + else + ! namely, it is not a sdl/vdl run. + member_index=index_member_in+1 ! the privous ensemble index starts from 0) + endif + jscale=self%imem2scale(member_index) + nvargrp=self%nvargrp + call btim(mg_multiply_time) + call btim(mg_preprocess_time) + if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,1)%km2 > 0) then + write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & +& "in which, the first level contains the 2d variables and others zeros " + + stop !to use a better exit procdure + endif + myrank=self%rank + write(str_rank,"(I4.4)")myrank + if(self%intstate(jscale,1)%l_for_localization) then + fileoutput="mgbftest_loc_"//str_rank//".txt" + else + fileoutput="mgbftest_static_"//str_rank//".txt" + endif + + allocate(nlev_vargrp(nvargrp)) + nlev_vargrp=0 + total_km_a_all=0 +!clt do iscale=1,self%nscale + do ivargrp=1,self%nvargrp + if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & + self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then + error stop "for being now, the filtering grids at the start of MGBF should be the same" + endif + total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all + nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all + enddo + + nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps + + n2d=0 + l2d_encountered=.false. + ivargrp0=1 + allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) + allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) + allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) + allocate(rnormalization(total_km_a_all,nvargrp)) + rnormalization=0.0 + work2d_mgbf=0.0 + ii=1 + do ivargrp=1,nvargrp + do k=1,self%intstate(jscale,ivargrp)%km2 +!clt if for localization , km2=0 only for +!clt only for l_2dvar_last_vertical_lev + rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) + ii=ii+1 + enddo +!clt if for localization , km2=0 + do k=1,self%intstate(jscale,ivargrp)%km3 + rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) + ii=ii+nz3d + enddo + enddo + + dim2d=shape(work2d_mgbf) + + dim3d=shape(work_mgbf) + nxloc=dim3d(2) + nyloc=dim3d(3) + nzloc=dim3d(1) + nvar=fields%size() + allocate( varvlev_index(nvar,3)) + varvlev_index=0 + + ilev=1 + do isize=1,fields%size() + + afield= fields%field(isize) !clttodo + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() + if(afield%rank() == 2) then + write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() + nz=afield%levels() + write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz + call afield%data(ptr_2d) + if(nz /= 1 .and. nz /= nz3d ) then + write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d + call flush(6) + stop + endif + + if(nz == 1) then + !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + if(n_owned_size >0 ) then + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + endif + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + + + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + else + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + + if(nz == 1) then + l2d_encountered=.true. + n2d=n2d+1 + endif + if(nz > 1) then + if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then + write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" + call flush(6) + error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending + endif + endif + if(isize==1) then + varvlev_index(isize,1)= 1 + !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,1)%l_for_localization )then + varvlev_index(isize,2)= nz + else + varvlev_index(isize,2)= nz3d + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + else + !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d + varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 + if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then + varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 + else + varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + endif + jvargrp=self%ivar2grp(isize) + + + ilev=varvlev_index(isize,2)+1 + elseif (afield%rank() == 3) then + write(6,*)'this case needs more work, stop' ! a better exption handling to be added + call flush(6) + stop + call afield%data(ptr_3d) + nz=afield%levels() + work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + stop + endif + enddo + do k=1,nzloc + work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) + enddo + + if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then + write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' + stop ! a better exception handling is to be added + endif + + if(test_once.and..1.gt.2) then + open(iounit,file=trim(fileoutput), status='replace',form="formatted") + write(iounit,*) work_mgbf + test_once=.false. + close(iounit) + endif + ii=1 + do ivargrp=1,nvargrp + allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) + allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) + vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) + + call etim(mg_preprocess_time) + + call btim(mg_anal_to_filt_time) + call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) + call etim(mg_anal_to_filt_time) + call btim(mg_filtering_time) + call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) + call etim(mg_filtering_time) + + !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) + call btim(mg_filt_to_anal_time) + call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) + call etim(mg_filt_to_anal_time) + !clt# work_mgbf=999.0 !thinkdeb for debug + + call btim(mg_postprocess_time) + do k=1,nlev_vargrp(ivargrp) + vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) + enddo + work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) + ii=ii+nlev_vargrp(ivargrp) + deallocate(vargrp_work_mgbf) + deallocate(vargrp_work_mgbf2) + enddo ! ivargrp + if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx + work_mgbf=work_mgbf2 + else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures + allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + work1var_mgbf=0.0 + if(nvargrp == 1 ) then + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) + enddo + do jvar=1,nvar + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + else + do jvar=1,nvar + jvargrp=self%ivar2grp(jvar) + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + ivargrp=self%ivar2grp(ivar) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) + enddo + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + endif + deallocate(work1var_mgbf) + endif + do k=1,nzloc + work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + enddo + ilev=1 + n_owned_size=0 + do isize=1,fields%size() + + afield=fields%field(isize) !clttodo + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + if(afield%rank() == 2) then + call afield%data(ptr_2d) + nz=afield%levels() + lev1=varvlev_index(isize,1) + if(nz.gt.1) then + if(n_owned_size >0 ) then + ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(self%intstate(1,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + write(6,*)'suspicous situation while n_owned_szie =0 ,stop' + call flush(6) + stop + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + + endif + endif !nz >1 or not + + elseif (afield%rank() == 3) then + call afield%data(ptr_3d) + nz=afield%levels() + write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo + call flush(6) + stop + + + !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + call flush(6) + stop + endif + enddo + + call etim(mg_postprocess_time) + + + + + deallocate(work_mgbf) + deallocate(work_mgbf2) + deallocate(work2d_mgbf) + deallocate(rnormalization) + deallocate( varvlev_index) + !clt enddo !for iscale + call etim(mg_multiply_time) + deallocate(nlev_vargrp) + +end subroutine multiply + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply_ad(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! This routine only needed when B = G^T G (sqrt-factored) + +! To do list for this method +! 1. Convert fields (Atlas fieldsets) to MGBF bundle +! 2. Call MGBF covariance operator adjoint (sqrt version) +! afield = fields%field('stream_function') +! call afield%data(var3d) +! var3d=0.0_r_kind + +end subroutine multiply_ad +function imem2scale(self,imem) result(iscale) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::imem + integer :: iscale + iscale=1 + do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) + iscale=iscale+1 + enddo + +end function imem2scale +function ivar2grp(self,ivar) result(jvargrp) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::ivar + integer :: jvargrp + jvargrp=1 + do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) + jvargrp=jvargrp+1 + enddo + +end function ivar2grp + +! -------------------------------------------------------------------------------------------------- + +end module mgbf_covariance_mod + diff --git a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 index 9933c002b..f0b5e7da3 100755 --- a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 @@ -65,7 +65,11 @@ module subroutine mg_initialize(this,n_owned_anl,anl_lonlat1d,inputfilename,obj_ endif if (present(anl_lonlat1d)) then - if (size(anl_lonlat1d,2) /= 2 .or. size(anl_lonlat1d,1) <= n_owned_anl) then + if (size(anl_lonlat1d,2) /= 2 .or. size(anl_lonlat1d,1) < n_owned_anl) then + write(6,*)'thinkdeb size(anl_lonlat1d,2) ',size(anl_lonlat1d,2) + write(6,*)'thinkdeb size(anl_lonlat1d,1) ',size(anl_lonlat1d,1) + write(6,*)'thinkdeb n_owned_anl ) ', n_owned_anl + call flush(6) error stop "anl_lonlat1d has wrong shape" end if From b06cad9520ddce28431203cb1c76e24108ad93ea Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Mon, 1 Dec 2025 18:59:37 +0000 Subject: [PATCH 100/199] WIP --- src/saber/mgbf/covariance/MGBF_Covariance.h | 2 ++ .../mgbf/covariance/mgbf_covariance_mod.f90 | 29 +++++++++++++++---- 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index 38a6e56b8..2a5fb251a 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -214,12 +214,14 @@ void MGBF_Covariance::multiply(oops::FieldSet3D & fset) const { oops::Log::trace()<<"thinkdeb999 sdl multiply index_member "<= 999) then ! not set previously and should not be used, member_index=1 ! the privous ensemble index starts from 0) else @@ -433,12 +430,22 @@ subroutine multiply(self, fields,index_member_in) !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then if(self%intstate(jscale,1)%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + if(ilev+nz3d-1 > total_km_a_all) then + write(6,*)'MGBF abort 1 : the dimensions are not as expected' + call flush(6) + stop + endif if(n_owned_size >0 ) then work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) else work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d endif else + if(ilev+nz-1 > total_km_a_all) then + write(6,*)'MGBF abort 2 : the dimensions are not as expected' + call flush(6) + stop + endif if(n_owned_size >0 ) then work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) else @@ -448,6 +455,11 @@ subroutine multiply(self, fields,index_member_in) else + if(ilev+nz-1 > total_km_a_all) then + write(6,*)'MGBF abort 3 : the dimensions are not as expected' + call flush(6) + stop + endif if(n_owned_size >0 ) then work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) else @@ -455,6 +467,11 @@ subroutine multiply(self, fields,index_member_in) endif endif else + if(ilev+nz-1 > total_km_a_all) then + write(6,*)'MGBF abort 4 : the dimensions are not as expected' + call flush(6) + stop + endif if(n_owned_size >0 ) then work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) else @@ -524,13 +541,13 @@ subroutine multiply(self, fields,index_member_in) test_once=.false. close(iounit) endif + call etim(mg_preprocess_time) ii=1 do ivargrp=1,nvargrp allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) - call etim(mg_preprocess_time) call btim(mg_anal_to_filt_time) call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) @@ -596,6 +613,8 @@ subroutine multiply(self, fields,index_member_in) afield=fields%field(isize) !clttodo fs= afield%functionspace() !cltthinkfore debug n_owned_size= fs%size_owned() !clt for debug + + if(afield%rank() == 2) then call afield%data(ptr_2d) nz=afield%levels() From d0a9ed1f98b7ebab254c9adb0d68cfd05ca958b3 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Wed, 3 Dec 2025 20:28:17 +0000 Subject: [PATCH 101/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 14 +++++++++++--- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 2 +- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index e8b9a0a46..9a2c2376b 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -183,11 +183,19 @@ subroutine create(self, comm, config, funcspace, background, firstguess) error stop 'MGBF requires StructuredColumns function space' end if fs_sc = funcspace -lonlat_field = fs_sc%xy() -call lonlat_field%data(lonlat_ptr) npts_owned = fs_sc%size_owned() -npts_total = size(lonlat_ptr,2) +npts_total = fs_sc%size() write(6,*)'thinkdeb mgbf create npts_owned/_total ',npts_owned, ' ',npts_total +call flush(6) +if(npts_owned.ge.npts_total) then + write(6,*)'the halo points are not present, on which the outer block interpolator would be problematic, stop' + call flush(6) + stop +endif + + +lonlat_field = fs_sc%xy() +call lonlat_field%data(lonlat_ptr) allocate(lonlat_anl(npts_total,2)) lonlat_anl(:,1) = lonlat_ptr(1,1:npts_total) lonlat_anl(:,2) = lonlat_ptr(2,1:npts_total) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 91385cf3c..195e3ffb8 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1461,7 +1461,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) this%paspx=this%pasp02 this%paspy=this%pasp02 !paspx and paspy will be replaced by paspx4d/paspy4d when the x/y filter ! is used ( filtering_fast_bkg ) -#if 0 +#if 1 allocate (lonlat2d_anl(this%nm,this%mm,2)) allocate (lonlat2d_filt(this%im,this%jm,2)) lonlat2d_anl(:,:,1)=reshape(lonlat1d_anl(:,1),[size(lonlat2d_anl,1),size(lonlat2d_anl,2)]) From ecb05299ddd540a0764396ceaf1bfad9e1c1bbd7 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Thu, 4 Dec 2025 01:02:42 +0000 Subject: [PATCH 102/199] WIP --- src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index 74adfd4c4..eca1c8862 100755 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -1146,7 +1146,7 @@ module subroutine filtering_fast_bkg(this) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbeta(1,hx,1,im,this%paspx4d(lm:lm,1:im,j,1),this%ssx4d(lm:lm,1:im,j,2),HALL(lev1:lev2,:,j)) + call this%rbeta(1,hx,1,im,this%paspx4d(lm:lm,1:im,j,2),this%ssx4d(lm:lm,1:im,j,2),HALL(lev1:lev2,:,j)) lev1=lev1+1 lev2=lev2+1 enddo From 306e6436bb72edced24020b18d26863c74672e9b Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 11 Dec 2025 17:59:32 +0000 Subject: [PATCH 103/199] WIP validated for l_constant_aspt2=.false. --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 7 +++-- src/saber/mgbf/mgbf_lib/mg_interpolate.f90 | 2 +- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 29 +++++++++++-------- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 8 ++--- 4 files changed, 26 insertions(+), 20 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 9a2c2376b..59104154b 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -196,9 +196,10 @@ subroutine create(self, comm, config, funcspace, background, firstguess) lonlat_field = fs_sc%xy() call lonlat_field%data(lonlat_ptr) -allocate(lonlat_anl(npts_total,2)) -lonlat_anl(:,1) = lonlat_ptr(1,1:npts_total) -lonlat_anl(:,2) = lonlat_ptr(2,1:npts_total) +!bug allocate(lonlat_anl(npts_total,2)) +allocate(lonlat_anl(npts_owned,2)) +lonlat_anl(:,1) = lonlat_ptr(1,1:npts_owned) +lonlat_anl(:,2) = lonlat_ptr(2,1:npts_owned) call lonlat_field%final() write(6,*)'thinkdeb mgbf create999 4 ' diff --git a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 index a1eca3d8b..f66da76e2 100755 --- a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 @@ -347,7 +347,7 @@ module subroutine lwq_vertical_coef & 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. + iref_out(nm_in)=im_in; c1(nm_in)=0.; c2(nm_in)=1.; c3(nm_in)=0.; c4(nm_in)=0. !----------------------------------------------------------------------- endsubroutine lwq_vertical_coef diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 195e3ffb8..37188ba44 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1278,7 +1278,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) integer(i_kind):: nxloc,nyloc,nz,nt,start_idx,end_idx integer(i_kind):: ig character*72 tmpfilename -real (r_kind)::rtem1 +real (r_kind)::rtem1,rtem2 real (r_kind) :: dist_rad !----------------------------------------------------------------------- start_idx=Lbound(this%weig_var,4) @@ -1469,10 +1469,16 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) lonlat2d_anl=lonlat2d_anl*deg2rad if(this%mype.eq.0) then open(13,file='latlon.txt',form="formatted") - write(13,*)"lon " - write(13,*)lonlat2d_anl(:,:,1) - write(13,*)"lat " - write(13,*)lonlat2d_anl(:,:,2) + write(13,*)"lon and lat " + do j = 1, this%mm + do i = 1, this%nm + write(13,'(2I5, 2ES20.10)') i, j, & + lonlat2d_anl(i, j, 1), lonlat2d_anl(i, j, 2) + end do + end do +!# write(13,*)lonlat2d_anl(:,:,1) +! write(13,*)"lat " +! write(13,*)lonlat2d_anl(:,:,2) close(13) endif call interp_analysis_to_filter(lonlat2d_anl(:,:,1),this%nm,this%mm,this%im,this%jm,lonlat2d_filt(:,:,1)) @@ -1495,16 +1501,15 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) enddo enddo - rtem1=sqrt(this%pasp02) + rtem1=this%pasp02/this%dx_a2f_ratio + rtem2=this%pasp02/this%dx_a2f_ratio - do i=1,this%im + do i=1,this%im do j=1,this%jm -!clt write(6,*)'thinkdebx99999 dxfm/dyfm = ',this%dxfm(i,j) -!clt write(6,*)'thinkdebx99999 dxfm/dyfm = ',this%dyfm(i,j) - this%paspx4d(1,i,j,1)=(rtem1*this%dxfmctrl/this%dxfm(i,j))**2 ! - this%paspy4d(1,i,j,1)=(rtem1*this%dyfmctrl/this%dyfm(i,j))**2 ! + this%paspx4d(1,i,j,1)=(rtem1/this%dxfmctrl*this%dxfm(i,j)) ! !cltthinkdeb9999 + this%paspy4d(1,i,j,1)=(rtem1/this%dyfmctrl*this%dyfm(i,j)) ! + enddo enddo - enddo diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 535e389f2..4610cc10b 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -176,6 +176,8 @@ module mg_parameter real(r_kind):: dxf,dyf,dxa,dya real(r_kind),allocatable,dimension (:,:):: dxfm,dyfm ! actual filtering grid intervals in meters real(r_kind):: dxfmctrl=35000,dyfmctrl=35000 !the control filtering grid intervals corresponding to the contstant horizontal aspect tensor +real(r_kind):: dx_a2f_ratio=1,dy_a2f_ratio=1 !ratio between analsysis grids to filtering grids in x and y + !it will be derived from other namelist parameters logical :: l_constant_aspt2 =.true. ! using constant horizontal aspect tensor : ampl02 integer(i_kind):: npadx ! x padding on analysis grid @@ -804,8 +806,8 @@ subroutine init_mg_parameter(this,inputfilename) ! this%nm = this%nm0/this%nxm this%mm = this%mm0/this%nym - write(6,*)'thinkdeb999 2 6 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid - call flush(6) + this%dx_a2f_ratio=this%nm/this%im_filt + this%dy_a2f_ratio=this%mm/this%jm_filt if(this%l_anal_sub_of_filt ) then if(this%im_filt.ne.this%nm.or.this%jm_filt.ne.this%mm) then write(6,*)'l_anal_sub_of_filter is true but the numbers of analysis/filtering grids are wrong, stop' @@ -816,8 +818,6 @@ subroutine init_mg_parameter(this,inputfilename) stop endif endif - write(6,*)'thinkdeb999 2 7 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid - call flush(6) !*** !*** Filter grid From d4419f4d16700e5aec99ca8e60a97b889f620c22 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 19 Dec 2025 20:26:53 +0000 Subject: [PATCH 104/199] WIP: for debugging --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 59104154b..cc777e74a 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -343,6 +343,7 @@ subroutine multiply(self, fields,index_member_in) integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp integer :: total_km_a_all,ii,nvargrp integer :: ilev1,ilev2 +integer :: loc(2) if(index_member_in >= 999) then ! not set previously and should not be used, member_index=1 ! the privous ensemble index starts from 0) @@ -487,6 +488,11 @@ subroutine multiply(self, fields,index_member_in) work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d endif endif + if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then + write(6,*)'thinkdeb333 before max is large 0.5' + loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) + write(6,*)'thinkdeb333 before large 0.5 loc ',loc + endif if(nz == 1) then l2d_encountered=.true. @@ -619,7 +625,9 @@ subroutine multiply(self, fields,index_member_in) n_owned_size=0 do isize=1,fields%size() + afield=fields%field(isize) !clttodo + write(6,*)'thinkdeb333-2 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() fs= afield%functionspace() !cltthinkfore debug n_owned_size= fs%size_owned() !clt for debug @@ -628,6 +636,11 @@ subroutine multiply(self, fields,index_member_in) call afield%data(ptr_2d) nz=afield%levels() lev1=varvlev_index(isize,1) + write(6,*)'thinkdeb333-3 leve: leve2 ',lev1,' ',lev1+nz + if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then + loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) + write(6,*)'thinkdeb333 max is large 0.5 loc ',loc + endif if(nz.gt.1) then if(n_owned_size >0 ) then ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) From cff4e0a9bc32cc77105b7ed97fa4dc4aecba644e Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 19 Dec 2025 21:32:04 -0500 Subject: [PATCH 105/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 61 +++++++++++-------- 1 file changed, 34 insertions(+), 27 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index cc777e74a..fe719aca9 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -545,37 +545,44 @@ subroutine multiply(self, fields,index_member_in) work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) enddo - if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then - write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' - stop ! a better exception handling is to be added - endif - - if(test_once.and..1.gt.2) then + if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then + write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' + stop ! a better exception handling is to be added + endif + + if(test_once.and..1.gt.2) then open(iounit,file=trim(fileoutput), status='replace',form="formatted") write(iounit,*) work_mgbf test_once=.false. close(iounit) - endif - call etim(mg_preprocess_time) - ii=1 - do ivargrp=1,nvargrp - allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) - allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) - vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) - - - call btim(mg_anal_to_filt_time) - call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) - call etim(mg_anal_to_filt_time) - call btim(mg_filtering_time) - call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) - call etim(mg_filtering_time) - - !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) - call btim(mg_filt_to_anal_time) - call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) - call etim(mg_filt_to_anal_time) - !clt# work_mgbf=999.0 !thinkdeb for debug + endif + call etim(mg_preprocess_time) + ii=1 + write(6,*)'codexdebug km2/km3/total/nvar/nz3d ', self%intstate(jscale,1)%km2, & + & self%intstate(jscale,1)%km3, total_km_a_all, nvar, nz3d + do i=1,min(4,nvar) + write(6,*)'codexdebug varvlev_index ', i, varvlev_index(i,1), varvlev_index(i,2) + enddo + do ivargrp=1,nvargrp + allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) + allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) + vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) + + + call btim(mg_anal_to_filt_time) + call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) + write(6,*)'codexdebug max_in_grp ', ivargrp, maxval(vargrp_work_mgbf) + call etim(mg_anal_to_filt_time) + call btim(mg_filtering_time) + call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) + call etim(mg_filtering_time) + + !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) + call btim(mg_filt_to_anal_time) + call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) + write(6,*)'codexdebug max_out_grp ', ivargrp, maxval(vargrp_work_mgbf2) + call etim(mg_filt_to_anal_time) + !clt# work_mgbf=999.0 !thinkdeb for debug call btim(mg_postprocess_time) do k=1,nlev_vargrp(ivargrp) From 7f8e3a80ffdca4a9c600bba802c016244d0912b7 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 5 Jan 2026 17:31:40 +0000 Subject: [PATCH 106/199] mgbf to read in normalization profiles one for each subdomain --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 2 +- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 61 +++++++++++++------ 2 files changed, 45 insertions(+), 18 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index fe719aca9..4cf1de50d 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -157,7 +157,7 @@ subroutine create(self, comm, config, funcspace, background, firstguess) enddo enddo do i=1,nvargrp - self%ivargroup(i)=readin_ivargroup(iscale) + self%ivargroup(i)=readin_ivargroup(i) enddo else call config%get_or_die("mgbf namelist file ", mgbf_nml) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 4610cc10b..b5b2e2680 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -541,6 +541,7 @@ subroutine init_mg_parameter(this,inputfilename) real(r_kind):: dxfmctrl=35000,dyfmctrl=35000 !the control filtering grid intervals corresponding to the contstant horizontal aspect tensor logical :: l_constant_aspt2 =.true. ! using constant horizontal aspect tensor : ampl02 character(len=256) ::file_coef_normalization="XXXX" +character(len=256) ::dir_coef_normalization="XXXX" 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=1 ! number of ensemble members @@ -564,7 +565,9 @@ subroutine init_mg_parameter(this,inputfilename) integer(i_kind):: p logical:: l_mg_weig_readin=.false. integer(i_kind), parameter :: nf=20! refinement factor for z grid,used in make_ssgrid -integer(i_kind) :: myunit,i +integer(i_kind) :: myunit,i,item,mype,ierr +character*4 :: str_rank +integer :: n_sample_levelsx4normalization logical :: l_exist namelist /parameters_mgbeta/ mg_ampl01,mg_ampl02,mg_ampl03 & @@ -573,6 +576,7 @@ subroutine init_mg_parameter(this,inputfilename) ,mgbf_line,mgbf_proc & ,lm_a,lm,coef_normalization & ,coef_normalization_const & + ,dir_coef_normalization & ,file_coef_normalization & , dxfmctrl,dyfmctrl & , l_constant_aspt2 & @@ -629,25 +633,48 @@ subroutine init_mg_parameter(this,inputfilename) this%lm=lm if (coef_normalization_const >0 ) then ! constant, if set, this contant will be - if(trim(file_coef_normalization)=="XXXX" ) then + if(trim(file_coef_normalization)=="XXXX" .and. trim(dir_coef_normalization)=="XXXX" ) then l_exist=.false. coef_normalization=coef_normalization_const else - inquire(file=trim(file_coef_normalization),exist=l_exist) - if(l_exist) then - write(6,*)'the normalization profile file is ',trim(file_coef_normalization) -!clt in the ../covairance/mgbf_covariance_mod.f90 the fldset is reversed in the vertical direction - open(newunit=myunit,file=trim(file_coef_normalization),status='old',action='read') - read(myunit,*)(coef_normalization(i),i=lm_a,1,-1) - close (myunit) - coef_normalization(1:lm_a)=coef_normalization(1:lm_a)*coef_normalization_const !re-calc - else - - write(6,*)'the normalization profile file does not exist ,stop ',trim(file_coef_normalization) - call flush(6) - stop - endif - endif + if (trim(dir_coef_normalization) /= "XXXX") then + call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr) + write(str_rank, '(I4.4)') mype + this%mype=mype + file_coef_normalization=trim(dir_coef_normalization)//"/profile_subdomain_"//str_rank//".txt" + endif + write(6,*)'thinkdeb888 normalization file is ',trim(file_coef_normalization) + inquire(file=trim(file_coef_normalization),exist=l_exist) + if(l_exist) then + open(newunit=myunit,file=trim(file_coef_normalization),status='old',action='read') + if(trim(dir_coef_normalization) /= "XXXX") then + ! to use file slike profiles_out/profile_subdomain_0475.txt + read(myunit,*) + read(myunit,*)i,n_sample_levelsx4normalization + read(myunit,*) + do i=1,n_sample_levelsx4normalization + read(myunit,*) + enddo + read(myunit,*) + do i=1,lm_a + read(myunit,*)item, coef_normalization(i) !notice, the data in the file is reversed already + enddo + close (myunit) + else + write(6,*)'the normalization profile file is ',trim(file_coef_normalization) + !clt in the ../covairance/mgbf_covariance_mod.f90 the fldset is reversed in the vertical direction + open(newunit=myunit,file=trim(file_coef_normalization),status='old',action='read') + read(myunit,*)(coef_normalization(i),i=lm_a,1,-1) + close (myunit) + endif + coef_normalization(1:lm_a)=coef_normalization(1:lm_a)*coef_normalization_const !re-calc + else + + write(6,*)'the normalization profile file does not exist ,stop ',trim(file_coef_normalization) + call flush(6) + stop + endif + endif else coef_normalization=1.0 From 7585a8d06d35000c21bb48969b78a6c7e52610ff Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 9 Jan 2026 17:30:05 +0000 Subject: [PATCH 107/199] add call of afield%final() in mgbf --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 4cf1de50d..a6ac25835 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -716,6 +716,7 @@ subroutine multiply(self, fields,index_member_in) deallocate( varvlev_index) !clt enddo !for iscale call etim(mg_multiply_time) + call afield%final() deallocate(nlev_vargrp) end subroutine multiply From d330644651978ad9112033633d2598248c688f38 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 10 Jan 2026 00:07:08 +0000 Subject: [PATCH 108/199] remove work_mgbf2 --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index a6ac25835..a22534e41 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -315,7 +315,6 @@ subroutine multiply(self, fields,index_member_in) real(kind=r_kind), pointer :: ptr_3d(:,:,:) integer(kind=i_kind):: nz,ilev,isize real(kind=r_kind), allocatable :: work_mgbf(:,:,:) -real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) @@ -388,7 +387,6 @@ subroutine multiply(self, fields,index_member_in) l2d_encountered=.false. ivargrp0=1 allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) - allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) allocate(rnormalization(total_km_a_all,nvargrp)) rnormalization=0.0 @@ -588,21 +586,19 @@ subroutine multiply(self, fields,index_member_in) do k=1,nlev_vargrp(ivargrp) vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) enddo - work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) + work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) ii=ii+nlev_vargrp(ivargrp) deallocate(vargrp_work_mgbf) deallocate(vargrp_work_mgbf2) enddo ! ivargrp - if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx - work_mgbf=work_mgbf2 - else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures + if(self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx allocate(work1var_mgbf(nz3d,nxloc,nyloc)) work1var_mgbf=0.0 if(nvargrp == 1 ) then do ivar=1,nvar lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) + work1var_mgbf=work1var_mgbf+work_mgbf(lev1:lev2,:,:) enddo do jvar=1,nvar lev1=varvlev_index(jvar,1) @@ -616,7 +612,7 @@ subroutine multiply(self, fields,index_member_in) lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) ivargrp=self%ivar2grp(ivar) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf(lev1:lev2,:,:) enddo lev1=varvlev_index(jvar,1) lev2=varvlev_index(jvar,2) From 8ca2c308095f0a50a8e47d2b1f3ee149f2b47667 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 10 Jan 2026 00:16:05 +0000 Subject: [PATCH 109/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index a22534e41..f3d8e2cb2 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -706,7 +706,6 @@ subroutine multiply(self, fields,index_member_in) deallocate(work_mgbf) - deallocate(work_mgbf2) deallocate(work2d_mgbf) deallocate(rnormalization) deallocate( varvlev_index) From 3540bd970253582646a4757fffbb1a2848bbd6d2 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 10 Jan 2026 00:33:04 +0000 Subject: [PATCH 110/199] make weig_var local --- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 37188ba44..a8b192fa5 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1124,7 +1124,6 @@ subroutine allocate_mg_intstate(this) endif -allocate(this%weig_var(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%gm)) ; this%weig_var=0. 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. @@ -1281,6 +1280,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) real (r_kind)::rtem1,rtem2 real (r_kind) :: dist_rad !----------------------------------------------------------------------- +allocate(this%weig_var(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%gm)) ; this%weig_var=0. start_idx=Lbound(this%weig_var,4) end_idx=Ubound(this%weig_var,4) if(start_idx /=1 ) then @@ -1649,6 +1649,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) call this%upsending_normalized(this%lm,this%ssy4d(:,:,:,1),this%ssy4d(:,:,:,2)) +deallocate(this%weig_var) !----------------------------------------------------------------------- From 9ab6ab294d82c629798872c9ccb2135f40c41961 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 10 Jan 2026 00:53:01 +0000 Subject: [PATCH 111/199] Normalize line endings to LF --- src/saber/mgbf/CMakeLists.txt | 110 +- .../mgbf/covariance/mgbf_covariance_mod.f90 | 1452 +++++------ src/saber/mgbf/mgbf_lib/jp_pietc.f90 | 222 +- src/saber/mgbf/mgbf_lib/jp_pmat.f90 | 2192 ++++++++--------- 4 files changed, 1988 insertions(+), 1988 deletions(-) diff --git a/src/saber/mgbf/CMakeLists.txt b/src/saber/mgbf/CMakeLists.txt index 345e8bae0..dee75d524 100755 --- a/src/saber/mgbf/CMakeLists.txt +++ b/src/saber/mgbf/CMakeLists.txt @@ -1,60 +1,60 @@ -# (C) Copyright 2022 United States Government as represented by the Administrator of the National -# Aeronautics and Space Administration -# -# This software is licensed under the terms of the Apache Licence Version 2.0 -# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -file(GLOB jbfiles mgbf_lib/*.f90) - message(STATUS "thinkdeb-2 " ${jbfiles} ) -set (jbfilenames "") -foreach ( _fname ${jbfiles} ) - get_filename_component( basefilename ${_fname} NAME ) - list ( APPEND jbfilenames mgbf_lib/${basefilename} ) - message(STATUS "thinkdeb-1 " ${basefilename}) - message(STATUS "thinkdeb0 " ${jbfilenames}) -endforeach () -message(STATUS "thinkdeb " ${jbfilenames}) -#set (jbfilenames "mgbf_lib/jp_pbfil.f90" ) -set (build_saber_mgbf 1) -if( build_saber_mgbf ) - list(APPEND mgbf_src_files_list - - # Covariance block - covariance/MGBF_Covariance.h - covariance/MGBF_Covariance.cc +# (C) Copyright 2022 United States Government as represented by the Administrator of the National +# Aeronautics and Space Administration +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +file(GLOB jbfiles mgbf_lib/*.f90) + message(STATUS "thinkdeb-2 " ${jbfiles} ) +set (jbfilenames "") +foreach ( _fname ${jbfiles} ) + get_filename_component( basefilename ${_fname} NAME ) + list ( APPEND jbfilenames mgbf_lib/${basefilename} ) + message(STATUS "thinkdeb-1 " ${basefilename}) + message(STATUS "thinkdeb0 " ${jbfilenames}) +endforeach () +message(STATUS "thinkdeb " ${jbfilenames}) +#set (jbfilenames "mgbf_lib/jp_pbfil.f90" ) +set (build_saber_mgbf 1) +if( build_saber_mgbf ) + list(APPEND mgbf_src_files_list + + # Covariance block + covariance/MGBF_Covariance.h + covariance/MGBF_Covariance.cc covariance/MGBF_Covariance.interface.F90 covariance/MGBF_Covariance.interface.h covariance/mgbf_covariance_mod.f90 utils/MGBF_GeometryBridge.cc utils/MGBF_GeometryBridge.h - -#clth # Grid -# covariance/mgbf_Grid.h -# covariance/mgbf_Grid.cc - # Interpolation block -# covariance/mgbf_Interpolation.h -# covariance/mgbf_Interpolation.cc -# interpolation/MGBF_Interpolation.h - - # Unstructured interpolation code ported from oops (until new interp code can be used) -# interpolation/unstructured_interp/saber_unstructured_interpolation_mod.F90 -# interpolation/unstructured_interp/UnstructuredInterpolation.cc -# interpolation/unstructured_interp/UnstructuredInterpolation.h -# interpolation/unstructured_interp/UnstructuredInterpolation.interface.F90 -# interpolation/unstructured_interp/UnstructuredInterpolation.interface.h - - # Utilities -# utils/mgbf_utils_mod.f90 - - ) -endif() -#clt find_package(mgbf_lib REQUIRED ) -message (STATUS "thinkdeb1 " ${mgbf_src_files_list} ) - -set( mgbf_src_files - -${mgbf_src_files_list} -${jbfilenames} - -PARENT_SCOPE -) - message (STATUS "thinkdeb2.4" ${mgbf_src_files} ) + +#clth # Grid +# covariance/mgbf_Grid.h +# covariance/mgbf_Grid.cc + # Interpolation block +# covariance/mgbf_Interpolation.h +# covariance/mgbf_Interpolation.cc +# interpolation/MGBF_Interpolation.h + + # Unstructured interpolation code ported from oops (until new interp code can be used) +# interpolation/unstructured_interp/saber_unstructured_interpolation_mod.F90 +# interpolation/unstructured_interp/UnstructuredInterpolation.cc +# interpolation/unstructured_interp/UnstructuredInterpolation.h +# interpolation/unstructured_interp/UnstructuredInterpolation.interface.F90 +# interpolation/unstructured_interp/UnstructuredInterpolation.interface.h + + # Utilities +# utils/mgbf_utils_mod.f90 + + ) +endif() +#clt find_package(mgbf_lib REQUIRED ) +message (STATUS "thinkdeb1 " ${mgbf_src_files_list} ) + +set( mgbf_src_files + +${mgbf_src_files_list} +${jbfilenames} + +PARENT_SCOPE +) + message (STATUS "thinkdeb2.4" ${mgbf_src_files} ) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index f3d8e2cb2..f2a3cf094 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -1,558 +1,558 @@ -! (C) Copyright 2022 United States Government as represented by the Administrator of the National -! Aeronautics and Space Administration -! -! This software is licensed under the terms of the Apache Licence Version 2.0 -! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. - -module mgbf_covariance_mod - -! atlas -use atlas_module, only: atlas_fieldset, atlas_field -use atlas_module, only: atlas_functionspace -use atlas_module, only: atlas_functionspace_StructuredColumns -use atlas_module, only : atlas_functionspace, & - atlas_functionspace_nodecolumns, & - atlas_functionspace_pointcloud, & - atlas_functionspace_structuredcolumns, & - atlas_mesh_nodes, atlas_field - -use tools_func, only : sphere_dist -use tools_const, only : req ! Earth radius (m) - -! fckit -use fckit_mpi_module, only: fckit_mpi_comm -use fckit_configuration_module, only: fckit_configuration - -! oops -use mgbf_kinds, only: r_kind,i_kind -use random_mod - -! saber -!clt use mgbf_grid_mod, only: mgbf_grid -use mg_intstate , only: mg_intstate_type -use mg_timers -use mpi -use, intrinsic :: ieee_arithmetic -implicit none -private -public mgbf_covariance - -! Fortran class header -type :: mgbf_covariance - type(mg_intstate_type),allocatable :: intstate(:,:) - integer :: nscale=1 - integer :: nvargrp=1 - logical :: noMGBF - logical :: bypassMGBFbe - logical :: cv ! cv=.true.; sv=.false. - integer :: mp_comm_world - integer :: rank - logical :: l_2dvar_last_vertical_level=.true. !when used for localization,2dvars are put on the last vertical level - !when the fields in fset are stored from top to bottom -!clt integer :: lat2,lon2 ! these belog to mgbf_grid - character(len=:), allocatable :: mgbf_nml - character(len=80), allocatable :: mgbf_nml_group(:,:) - real, allocatable :: multigrp_cor(:,:) - integer, allocatable :: iscalegroup(:) - integer, allocatable :: ivargroup(:) - - contains - procedure, public :: create - procedure, public :: delete - procedure, public :: randomize - procedure, public :: multiply - procedure, public :: multiply_ad - procedure, private :: imem2scale - procedure, private :: ivar2grp -end type mgbf_covariance - -character(len=*), parameter :: myname='mgbf_covariance_mod' - -! -------------------------------------------------------------------------------------------------- - -contains - -! -------------------------------------------------------------------------------------------------- - -subroutine create(self, comm, config, funcspace, background, firstguess) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(fckit_mpi_comm), intent(in) :: comm -type(fckit_configuration), intent(in) :: config -type(atlas_functionspace), intent(in) :: funcspace -type(atlas_fieldset), intent(in) :: background -type(atlas_fieldset), intent(in) :: firstguess - -! Locals -real(r_kind) :: dist_rad, dist_m -integer :: ipt -character(len=*), parameter :: myname_=myname//'*create' -character(len=:), allocatable :: mgbf_nml,centralblockname -logical :: central -integer :: layout(2) -integer :: myunit -integer :: iscale,ivargrp -integer :: nscale=1, nvargrp=1 -type(atlas_field) :: afield, lonlat_field -type(atlas_functionspace_structuredcolumns) :: fs_sc -real(r_kind), pointer :: lonlat_ptr(:,:) -real(r_kind), allocatable :: lonlat_anl(:,:) -integer :: npts_owned -integer :: npts_total - - -character(len=80) :: readin_mgbf_nml_group(99) -real :: readin_multigrp_cor(99)=1.0 -integer :: readin_iscalegroup(99)=999 -integer :: readin_ivargroup(99)=999 -integer ::i,j, ii -namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup - -character(len=:), allocatable :: dump_json - -! Hold communicator -! ----------------- -!self%mp_comm_world=comm%communicator() - -! Create the grid -! --------------- -!clt call self%grid%create(config, comm) -self%rank = comm%rank() - -write(6,*)'thinkdeb mgbf create999 ' -write(6,*)'thinkdeb mgbf create999 config' - dump_json=config%json() ! serialize to a JSON string -write(6,'(A)')trim(dump_json) -call flush(6) -call config%get_or_die("saber block name", centralblockname) -!clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) -if (config%has("mgbf sdl and vdl init namelist file")) then - call config%get_or_die("mgbf sdl and vdl init namelist file", mgbf_nml) - open(newunit=myunit,file=trim(mgbf_nml),status='old') -!# open(unit=10,file=mgbf_nml,status='old',action='read') - read(myunit,nml=parameters_mgbf_init) - close(unit=myunit) - self%nscale=nscale - self%nvargrp=nvargrp - allocate(self%mgbf_nml_group(nscale,nvargrp)) - allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship - allocate(self%iscalegroup(nscale) ) - allocate(self%ivargroup(nvargrp) ) - ii=1 - do iscale=1,nscale - do ivargrp=1,nvargrp - self%mgbf_nml_group(iscale,ivargrp)=readin_mgbf_nml_group(ii) - ii=ii+1 - enddo - enddo - do iscale=1,nscale - self%iscalegroup(iscale)=readin_iscalegroup(iscale) - enddo - ii=1 - do i=1,nvargrp - do j=1,nvargrp - self%multigrp_cor(i,j)=readin_multigrp_cor(ii) - ii=ii+1 - enddo - enddo - do i=1,nvargrp - self%ivargroup(i)=readin_ivargroup(i) - enddo -else -call config%get_or_die("mgbf namelist file ", mgbf_nml) -!still need allocate them though nscale=nvargrp=1 - allocate(self%mgbf_nml_group(nscale,nvargrp)) - allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship - self%multigrp_cor=1.0 - allocate(self%iscalegroup(nscale) ) - self%iscalegroup(nscale) =1 - allocate(self%ivargroup(nvargrp) ) - self%ivargroup=1 -endif - - -if(nscale == 1 .and. nvargrp ==1 ) then - self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used - !and hence, it would be backward-compatible - ! the previous namelist files could be still used,correctly, - ! by the current sdl/vdl enhanced version -endif - -if (trim(funcspace%name()) /= 'StructuredColumns') then - error stop 'MGBF requires StructuredColumns function space' -end if -fs_sc = funcspace -npts_owned = fs_sc%size_owned() -npts_total = fs_sc%size() -write(6,*)'thinkdeb mgbf create npts_owned/_total ',npts_owned, ' ',npts_total -call flush(6) -if(npts_owned.ge.npts_total) then - write(6,*)'the halo points are not present, on which the outer block interpolator would be problematic, stop' - call flush(6) - stop -endif - - -lonlat_field = fs_sc%xy() -call lonlat_field%data(lonlat_ptr) -!bug allocate(lonlat_anl(npts_total,2)) -allocate(lonlat_anl(npts_owned,2)) -lonlat_anl(:,1) = lonlat_ptr(1,1:npts_owned) -lonlat_anl(:,2) = lonlat_ptr(2,1:npts_owned) -call lonlat_field%final() - -write(6,*)'thinkdeb mgbf create999 4 ' -call flush(6) - -allocate(self%intstate(nscale,nvargrp)) -call flush(6) -do iscale=1,nscale - do ivargrp=1,nvargrp - write(6,*)'the999 nml is ', trim(self%mgbf_nml_group(iscale,ivargrp)) - call flush(6) - call self%intstate(iscale,ivargrp)%mg_initialize(n_owned_anl=npts_owned, & - anl_lonlat1d=lonlat_anl, inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml - enddo -enddo -write(6,*)'thinkdeb mgbf create999 10 ' -call flush(6) -if (allocated(lonlat_anl)) deallocate(lonlat_anl) -! Get background (temporary test of the functionality) -!cltafield = background%field('air_temperature') -!clt call afield%data(t) - -end subroutine create - -! -------------------------------------------------------------------------------------------------- - -subroutine delete(self) - -! Arguments -class(mgbf_covariance) :: self -integer:: iscale,ivargrp - -! Locals - -!clt //if (.not. self%noMGBF) then - call print_mg_timers("mg_timer_output",999,self%rank) - -do iscale=1,self%nscale - do ivargrp=1,self%nvargrp - call self%intstate(iscale,ivargrp)%mg_finalize() - enddo -enddo -!clt endif - -! Delete the grid -! --------------- -!clt call self%grid%delete() - -end subroutine delete - -! -------------------------------------------------------------------------------------------------- - -subroutine randomize(self, fields) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields - -! Locals -type(atlas_field) :: afield -real(kind=r_kind), pointer :: psi(:,:), chi(:,:), t(:,:), q(:,:), qi(:,:), ql(:,:), o3(:,:) -real(kind=r_kind), pointer :: ps(:) - -integer, parameter :: rseed = 3 -write(6,*)'thinkdeb this is to be implemente' -call flush(6) -stop -! Get Atlas field -afield = fields%field('stream_function') -call afield%data(psi) - -afield = fields%field('velocity_potential') -call afield%data(chi) - -afield = fields%field('air_temperature') -call afield%data(t) - -afield = fields%field('surface_pressure') -call afield%data(ps) - -afield = fields%field('specific_humidity') -call afield%data(q) - -afield = fields%field('cloud_liquid_ice') -call afield%data(qi) - -afield = fields%field('cloud_liquid_water') -call afield%data(ql) - -afield = fields%field('ozone_mass_mixing_ratio') -call afield%data(o3) - - -! Set fields to random numbers -call normal_distribution(psi, 0.0_r_kind, 1.0_r_kind, rseed) - - -end subroutine randomize - -! -------------------------------------------------------------------------------------------------- - -subroutine multiply(self, fields,index_member_in) -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields -integer , intent(in) :: index_member_in -type(atlas_fieldset) :: fields_tmp -type(atlas_functionspace) :: afunctionspace - -! Locals -type(atlas_field) :: afield -real(kind=r_kind), pointer :: ptr_2d(:,:) -real(kind=r_kind), pointer :: ptr_3d(:,:,:) -integer(kind=i_kind):: nz,ilev,isize -real(kind=r_kind), allocatable :: work_mgbf(:,:,:) -real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) -real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) -real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) -real(kind=r_kind), allocatable :: work2d_mgbf(:,:) -real(kind=r_kind), allocatable :: rnormalization(:,:) -integer(kind=i_kind), allocatable :: nlev_vargrp(:) -integer(kind=i_kind) :: dim2d(2),dim3d(3) -integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d -integer(kind=i_kind)::nvar -integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit -integer(kind=i_kind):: n2d -integer(kind=i_kind),allocatable :: varvlev_index(:,:) -logical :: l2d_encountered -logical :: test_once=.false. -integer(kind=i_kind)::itest=0 -character(len=32) :: fileoutput -character(len=4) :: str_rank -integer :: n_owned_size -integer, pointer :: ghost(:) -!clttype(atlas_FunctionSpace) :: fs -type(atlas_functionspace) :: fs_generic -type(atlas_functionspace_StructuredColumns) :: fs -integer :: ierr -integer :: member_index -integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp -integer :: total_km_a_all,ii,nvargrp -integer :: ilev1,ilev2 -integer :: loc(2) - - if(index_member_in >= 999) then ! not set previously and should not be used, - member_index=1 ! the privous ensemble index starts from 0) - else - ! namely, it is not a sdl/vdl run. - member_index=index_member_in+1 ! the privous ensemble index starts from 0) - endif - jscale=self%imem2scale(member_index) - nvargrp=self%nvargrp - call btim(mg_multiply_time) - call btim(mg_preprocess_time) - if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,1)%km2 > 0) then - write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & -& "in which, the first level contains the 2d variables and others zeros " - - stop !to use a better exit procdure - endif - myrank=self%rank - write(str_rank,"(I4.4)")myrank - if(self%intstate(jscale,1)%l_for_localization) then - fileoutput="mgbftest_loc_"//str_rank//".txt" - else - fileoutput="mgbftest_static_"//str_rank//".txt" - endif - - allocate(nlev_vargrp(nvargrp)) - nlev_vargrp=0 - total_km_a_all=0 -!clt do iscale=1,self%nscale - do ivargrp=1,self%nvargrp - if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & - self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then - error stop "for being now, the filtering grids at the start of MGBF should be the same" - endif - total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all - nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all - enddo - - nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps - - n2d=0 - l2d_encountered=.false. - ivargrp0=1 - allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) - allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) - allocate(rnormalization(total_km_a_all,nvargrp)) - rnormalization=0.0 - work2d_mgbf=0.0 - ii=1 - do ivargrp=1,nvargrp - do k=1,self%intstate(jscale,ivargrp)%km2 -!clt if for localization , km2=0 only for -!clt only for l_2dvar_last_vertical_lev - rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) - ii=ii+1 - enddo -!clt if for localization , km2=0 - do k=1,self%intstate(jscale,ivargrp)%km3 - rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) - ii=ii+nz3d - enddo - enddo - - dim2d=shape(work2d_mgbf) - - dim3d=shape(work_mgbf) - nxloc=dim3d(2) - nyloc=dim3d(3) - nzloc=dim3d(1) - nvar=fields%size() - allocate( varvlev_index(nvar,3)) - varvlev_index=0 - - ilev=1 - do isize=1,fields%size() - - afield= fields%field(isize) !clttodo - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() - if(afield%rank() == 2) then - write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() - nz=afield%levels() - write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz - call afield%data(ptr_2d) - if(nz /= 1 .and. nz /= nz3d ) then - write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d - call flush(6) - stop - endif - - if(nz == 1) then - !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then - if(self%intstate(jscale,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - if(ilev+nz3d-1 > total_km_a_all) then - write(6,*)'MGBF abort 1 : the dimensions are not as expected' - call flush(6) - stop - endif - if(n_owned_size >0 ) then - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d - endif - else - if(ilev+nz-1 > total_km_a_all) then - write(6,*)'MGBF abort 2 : the dimensions are not as expected' - call flush(6) - stop - endif - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - - - else - if(ilev+nz-1 > total_km_a_all) then - write(6,*)'MGBF abort 3 : the dimensions are not as expected' - call flush(6) - stop - endif - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - else - if(ilev+nz-1 > total_km_a_all) then - write(6,*)'MGBF abort 4 : the dimensions are not as expected' - call flush(6) - stop - endif - if(n_owned_size >0 ) then - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) - else - work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d - endif - endif - if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then - write(6,*)'thinkdeb333 before max is large 0.5' - loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) - write(6,*)'thinkdeb333 before large 0.5 loc ',loc - endif - - if(nz == 1) then - l2d_encountered=.true. - n2d=n2d+1 - endif - if(nz > 1) then - if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then - write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" - call flush(6) - error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending - endif - endif - if(isize==1) then - varvlev_index(isize,1)= 1 - !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then - if(.not.self%intstate(jscale,1)%l_for_localization )then - varvlev_index(isize,2)= nz - else - varvlev_index(isize,2)= nz3d - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - else - !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d - varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 - if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then - varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 - else - varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - endif - jvargrp=self%ivar2grp(isize) - - - ilev=varvlev_index(isize,2)+1 - elseif (afield%rank() == 3) then - write(6,*)'this case needs more work, stop' ! a better exption handling to be added - call flush(6) - stop - call afield%data(ptr_3d) - nz=afield%levels() - work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - stop - endif - enddo - do k=1,nzloc - work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) - enddo - +! (C) Copyright 2022 United States Government as represented by the Administrator of the National +! Aeronautics and Space Administration +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + +module mgbf_covariance_mod + +! atlas +use atlas_module, only: atlas_fieldset, atlas_field +use atlas_module, only: atlas_functionspace +use atlas_module, only: atlas_functionspace_StructuredColumns +use atlas_module, only : atlas_functionspace, & + atlas_functionspace_nodecolumns, & + atlas_functionspace_pointcloud, & + atlas_functionspace_structuredcolumns, & + atlas_mesh_nodes, atlas_field + +use tools_func, only : sphere_dist +use tools_const, only : req ! Earth radius (m) + +! fckit +use fckit_mpi_module, only: fckit_mpi_comm +use fckit_configuration_module, only: fckit_configuration + +! oops +use mgbf_kinds, only: r_kind,i_kind +use random_mod + +! saber +!clt use mgbf_grid_mod, only: mgbf_grid +use mg_intstate , only: mg_intstate_type +use mg_timers +use mpi +use, intrinsic :: ieee_arithmetic +implicit none +private +public mgbf_covariance + +! Fortran class header +type :: mgbf_covariance + type(mg_intstate_type),allocatable :: intstate(:,:) + integer :: nscale=1 + integer :: nvargrp=1 + logical :: noMGBF + logical :: bypassMGBFbe + logical :: cv ! cv=.true.; sv=.false. + integer :: mp_comm_world + integer :: rank + logical :: l_2dvar_last_vertical_level=.true. !when used for localization,2dvars are put on the last vertical level + !when the fields in fset are stored from top to bottom +!clt integer :: lat2,lon2 ! these belog to mgbf_grid + character(len=:), allocatable :: mgbf_nml + character(len=80), allocatable :: mgbf_nml_group(:,:) + real, allocatable :: multigrp_cor(:,:) + integer, allocatable :: iscalegroup(:) + integer, allocatable :: ivargroup(:) + + contains + procedure, public :: create + procedure, public :: delete + procedure, public :: randomize + procedure, public :: multiply + procedure, public :: multiply_ad + procedure, private :: imem2scale + procedure, private :: ivar2grp +end type mgbf_covariance + +character(len=*), parameter :: myname='mgbf_covariance_mod' + +! -------------------------------------------------------------------------------------------------- + +contains + +! -------------------------------------------------------------------------------------------------- + +subroutine create(self, comm, config, funcspace, background, firstguess) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(fckit_mpi_comm), intent(in) :: comm +type(fckit_configuration), intent(in) :: config +type(atlas_functionspace), intent(in) :: funcspace +type(atlas_fieldset), intent(in) :: background +type(atlas_fieldset), intent(in) :: firstguess + +! Locals +real(r_kind) :: dist_rad, dist_m +integer :: ipt +character(len=*), parameter :: myname_=myname//'*create' +character(len=:), allocatable :: mgbf_nml,centralblockname +logical :: central +integer :: layout(2) +integer :: myunit +integer :: iscale,ivargrp +integer :: nscale=1, nvargrp=1 +type(atlas_field) :: afield, lonlat_field +type(atlas_functionspace_structuredcolumns) :: fs_sc +real(r_kind), pointer :: lonlat_ptr(:,:) +real(r_kind), allocatable :: lonlat_anl(:,:) +integer :: npts_owned +integer :: npts_total + + +character(len=80) :: readin_mgbf_nml_group(99) +real :: readin_multigrp_cor(99)=1.0 +integer :: readin_iscalegroup(99)=999 +integer :: readin_ivargroup(99)=999 +integer ::i,j, ii +namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup + +character(len=:), allocatable :: dump_json + +! Hold communicator +! ----------------- +!self%mp_comm_world=comm%communicator() + +! Create the grid +! --------------- +!clt call self%grid%create(config, comm) +self%rank = comm%rank() + +write(6,*)'thinkdeb mgbf create999 ' +write(6,*)'thinkdeb mgbf create999 config' + dump_json=config%json() ! serialize to a JSON string +write(6,'(A)')trim(dump_json) +call flush(6) +call config%get_or_die("saber block name", centralblockname) +!clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) +if (config%has("mgbf sdl and vdl init namelist file")) then + call config%get_or_die("mgbf sdl and vdl init namelist file", mgbf_nml) + open(newunit=myunit,file=trim(mgbf_nml),status='old') +!# open(unit=10,file=mgbf_nml,status='old',action='read') + read(myunit,nml=parameters_mgbf_init) + close(unit=myunit) + self%nscale=nscale + self%nvargrp=nvargrp + allocate(self%mgbf_nml_group(nscale,nvargrp)) + allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + allocate(self%iscalegroup(nscale) ) + allocate(self%ivargroup(nvargrp) ) + ii=1 + do iscale=1,nscale + do ivargrp=1,nvargrp + self%mgbf_nml_group(iscale,ivargrp)=readin_mgbf_nml_group(ii) + ii=ii+1 + enddo + enddo + do iscale=1,nscale + self%iscalegroup(iscale)=readin_iscalegroup(iscale) + enddo + ii=1 + do i=1,nvargrp + do j=1,nvargrp + self%multigrp_cor(i,j)=readin_multigrp_cor(ii) + ii=ii+1 + enddo + enddo + do i=1,nvargrp + self%ivargroup(i)=readin_ivargroup(i) + enddo +else +call config%get_or_die("mgbf namelist file ", mgbf_nml) +!still need allocate them though nscale=nvargrp=1 + allocate(self%mgbf_nml_group(nscale,nvargrp)) + allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + self%multigrp_cor=1.0 + allocate(self%iscalegroup(nscale) ) + self%iscalegroup(nscale) =1 + allocate(self%ivargroup(nvargrp) ) + self%ivargroup=1 +endif + + +if(nscale == 1 .and. nvargrp ==1 ) then + self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used + !and hence, it would be backward-compatible + ! the previous namelist files could be still used,correctly, + ! by the current sdl/vdl enhanced version +endif + +if (trim(funcspace%name()) /= 'StructuredColumns') then + error stop 'MGBF requires StructuredColumns function space' +end if +fs_sc = funcspace +npts_owned = fs_sc%size_owned() +npts_total = fs_sc%size() +write(6,*)'thinkdeb mgbf create npts_owned/_total ',npts_owned, ' ',npts_total +call flush(6) +if(npts_owned.ge.npts_total) then + write(6,*)'the halo points are not present, on which the outer block interpolator would be problematic, stop' + call flush(6) + stop +endif + + +lonlat_field = fs_sc%xy() +call lonlat_field%data(lonlat_ptr) +!bug allocate(lonlat_anl(npts_total,2)) +allocate(lonlat_anl(npts_owned,2)) +lonlat_anl(:,1) = lonlat_ptr(1,1:npts_owned) +lonlat_anl(:,2) = lonlat_ptr(2,1:npts_owned) +call lonlat_field%final() + +write(6,*)'thinkdeb mgbf create999 4 ' +call flush(6) + +allocate(self%intstate(nscale,nvargrp)) +call flush(6) +do iscale=1,nscale + do ivargrp=1,nvargrp + write(6,*)'the999 nml is ', trim(self%mgbf_nml_group(iscale,ivargrp)) + call flush(6) + call self%intstate(iscale,ivargrp)%mg_initialize(n_owned_anl=npts_owned, & + anl_lonlat1d=lonlat_anl, inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml + enddo +enddo +write(6,*)'thinkdeb mgbf create999 10 ' +call flush(6) +if (allocated(lonlat_anl)) deallocate(lonlat_anl) +! Get background (temporary test of the functionality) +!cltafield = background%field('air_temperature') +!clt call afield%data(t) + +end subroutine create + +! -------------------------------------------------------------------------------------------------- + +subroutine delete(self) + +! Arguments +class(mgbf_covariance) :: self +integer:: iscale,ivargrp + +! Locals + +!clt //if (.not. self%noMGBF) then + call print_mg_timers("mg_timer_output",999,self%rank) + +do iscale=1,self%nscale + do ivargrp=1,self%nvargrp + call self%intstate(iscale,ivargrp)%mg_finalize() + enddo +enddo +!clt endif + +! Delete the grid +! --------------- +!clt call self%grid%delete() + +end subroutine delete + +! -------------------------------------------------------------------------------------------------- + +subroutine randomize(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: psi(:,:), chi(:,:), t(:,:), q(:,:), qi(:,:), ql(:,:), o3(:,:) +real(kind=r_kind), pointer :: ps(:) + +integer, parameter :: rseed = 3 +write(6,*)'thinkdeb this is to be implemente' +call flush(6) +stop +! Get Atlas field +afield = fields%field('stream_function') +call afield%data(psi) + +afield = fields%field('velocity_potential') +call afield%data(chi) + +afield = fields%field('air_temperature') +call afield%data(t) + +afield = fields%field('surface_pressure') +call afield%data(ps) + +afield = fields%field('specific_humidity') +call afield%data(q) + +afield = fields%field('cloud_liquid_ice') +call afield%data(qi) + +afield = fields%field('cloud_liquid_water') +call afield%data(ql) + +afield = fields%field('ozone_mass_mixing_ratio') +call afield%data(o3) + + +! Set fields to random numbers +call normal_distribution(psi, 0.0_r_kind, 1.0_r_kind, rseed) + + +end subroutine randomize + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply(self, fields,index_member_in) +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields +integer , intent(in) :: index_member_in +type(atlas_fieldset) :: fields_tmp +type(atlas_functionspace) :: afunctionspace + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: ptr_2d(:,:) +real(kind=r_kind), pointer :: ptr_3d(:,:,:) +integer(kind=i_kind):: nz,ilev,isize +real(kind=r_kind), allocatable :: work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) +real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) +real(kind=r_kind), allocatable :: work2d_mgbf(:,:) +real(kind=r_kind), allocatable :: rnormalization(:,:) +integer(kind=i_kind), allocatable :: nlev_vargrp(:) +integer(kind=i_kind) :: dim2d(2),dim3d(3) +integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d +integer(kind=i_kind)::nvar +integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit +integer(kind=i_kind):: n2d +integer(kind=i_kind),allocatable :: varvlev_index(:,:) +logical :: l2d_encountered +logical :: test_once=.false. +integer(kind=i_kind)::itest=0 +character(len=32) :: fileoutput +character(len=4) :: str_rank +integer :: n_owned_size +integer, pointer :: ghost(:) +!clttype(atlas_FunctionSpace) :: fs +type(atlas_functionspace) :: fs_generic +type(atlas_functionspace_StructuredColumns) :: fs +integer :: ierr +integer :: member_index +integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp +integer :: total_km_a_all,ii,nvargrp +integer :: ilev1,ilev2 +integer :: loc(2) + + if(index_member_in >= 999) then ! not set previously and should not be used, + member_index=1 ! the privous ensemble index starts from 0) + else + ! namely, it is not a sdl/vdl run. + member_index=index_member_in+1 ! the privous ensemble index starts from 0) + endif + jscale=self%imem2scale(member_index) + nvargrp=self%nvargrp + call btim(mg_multiply_time) + call btim(mg_preprocess_time) + if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,1)%km2 > 0) then + write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & +& "in which, the first level contains the 2d variables and others zeros " + + stop !to use a better exit procdure + endif + myrank=self%rank + write(str_rank,"(I4.4)")myrank + if(self%intstate(jscale,1)%l_for_localization) then + fileoutput="mgbftest_loc_"//str_rank//".txt" + else + fileoutput="mgbftest_static_"//str_rank//".txt" + endif + + allocate(nlev_vargrp(nvargrp)) + nlev_vargrp=0 + total_km_a_all=0 +!clt do iscale=1,self%nscale + do ivargrp=1,self%nvargrp + if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & + self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then + error stop "for being now, the filtering grids at the start of MGBF should be the same" + endif + total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all + nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all + enddo + + nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps + + n2d=0 + l2d_encountered=.false. + ivargrp0=1 + allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) + allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) + allocate(rnormalization(total_km_a_all,nvargrp)) + rnormalization=0.0 + work2d_mgbf=0.0 + ii=1 + do ivargrp=1,nvargrp + do k=1,self%intstate(jscale,ivargrp)%km2 +!clt if for localization , km2=0 only for +!clt only for l_2dvar_last_vertical_lev + rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) + ii=ii+1 + enddo +!clt if for localization , km2=0 + do k=1,self%intstate(jscale,ivargrp)%km3 + rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) + ii=ii+nz3d + enddo + enddo + + dim2d=shape(work2d_mgbf) + + dim3d=shape(work_mgbf) + nxloc=dim3d(2) + nyloc=dim3d(3) + nzloc=dim3d(1) + nvar=fields%size() + allocate( varvlev_index(nvar,3)) + varvlev_index=0 + + ilev=1 + do isize=1,fields%size() + + afield= fields%field(isize) !clttodo + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() + if(afield%rank() == 2) then + write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() + nz=afield%levels() + write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz + call afield%data(ptr_2d) + if(nz /= 1 .and. nz /= nz3d ) then + write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d + call flush(6) + stop + endif + + if(nz == 1) then + !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + if(ilev+nz3d-1 > total_km_a_all) then + write(6,*)'MGBF abort 1 : the dimensions are not as expected' + call flush(6) + stop + endif + if(n_owned_size >0 ) then + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + endif + else + if(ilev+nz-1 > total_km_a_all) then + write(6,*)'MGBF abort 2 : the dimensions are not as expected' + call flush(6) + stop + endif + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + + + else + if(ilev+nz-1 > total_km_a_all) then + write(6,*)'MGBF abort 3 : the dimensions are not as expected' + call flush(6) + stop + endif + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + else + if(ilev+nz-1 > total_km_a_all) then + write(6,*)'MGBF abort 4 : the dimensions are not as expected' + call flush(6) + stop + endif + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then + write(6,*)'thinkdeb333 before max is large 0.5' + loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) + write(6,*)'thinkdeb333 before large 0.5 loc ',loc + endif + + if(nz == 1) then + l2d_encountered=.true. + n2d=n2d+1 + endif + if(nz > 1) then + if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then + write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" + call flush(6) + error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending + endif + endif + if(isize==1) then + varvlev_index(isize,1)= 1 + !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,1)%l_for_localization )then + varvlev_index(isize,2)= nz + else + varvlev_index(isize,2)= nz3d + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + else + !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d + varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 + if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then + varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 + else + varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + endif + jvargrp=self%ivar2grp(isize) + + + ilev=varvlev_index(isize,2)+1 + elseif (afield%rank() == 3) then + write(6,*)'this case needs more work, stop' ! a better exption handling to be added + call flush(6) + stop + call afield%data(ptr_3d) + nz=afield%levels() + work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + stop + endif + enddo + do k=1,nzloc + work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) + enddo + if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added endif if(test_once.and..1.gt.2) then - open(iounit,file=trim(fileoutput), status='replace',form="formatted") - write(iounit,*) work_mgbf - test_once=.false. - close(iounit) + open(iounit,file=trim(fileoutput), status='replace',form="formatted") + write(iounit,*) work_mgbf + test_once=.false. + close(iounit) endif call etim(mg_preprocess_time) ii=1 @@ -581,181 +581,181 @@ subroutine multiply(self, fields,index_member_in) write(6,*)'codexdebug max_out_grp ', ivargrp, maxval(vargrp_work_mgbf2) call etim(mg_filt_to_anal_time) !clt# work_mgbf=999.0 !thinkdeb for debug - - call btim(mg_postprocess_time) - do k=1,nlev_vargrp(ivargrp) - vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) - enddo - work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) - ii=ii+nlev_vargrp(ivargrp) - deallocate(vargrp_work_mgbf) - deallocate(vargrp_work_mgbf2) - enddo ! ivargrp - if(self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx - allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - work1var_mgbf=0.0 - if(nvargrp == 1 ) then - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+work_mgbf(lev1:lev2,:,:) - enddo - do jvar=1,nvar - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - else - do jvar=1,nvar - jvargrp=self%ivar2grp(jvar) - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - ivargrp=self%ivar2grp(ivar) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf(lev1:lev2,:,:) - enddo - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - endif - deallocate(work1var_mgbf) - endif - do k=1,nzloc - work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) - enddo - ilev=1 - n_owned_size=0 - do isize=1,fields%size() - - - afield=fields%field(isize) !clttodo - write(6,*)'thinkdeb333-2 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - - - if(afield%rank() == 2) then - call afield%data(ptr_2d) - nz=afield%levels() - lev1=varvlev_index(isize,1) - write(6,*)'thinkdeb333-3 leve: leve2 ',lev1,' ',lev1+nz - if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then - loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) - write(6,*)'thinkdeb333 max is large 0.5 loc ',loc - endif - if(nz.gt.1) then - if(n_owned_size >0 ) then - ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(self%intstate(1,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - write(6,*)'suspicous situation while n_owned_szie =0 ,stop' - call flush(6) - stop - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - - endif - endif !nz >1 or not - - elseif (afield%rank() == 3) then - call afield%data(ptr_3d) - nz=afield%levels() - write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo - call flush(6) - stop - - - !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - call flush(6) - stop - endif - enddo - - call etim(mg_postprocess_time) - - - - - deallocate(work_mgbf) - deallocate(work2d_mgbf) - deallocate(rnormalization) - deallocate( varvlev_index) - !clt enddo !for iscale - call etim(mg_multiply_time) + + call btim(mg_postprocess_time) + do k=1,nlev_vargrp(ivargrp) + vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) + enddo + work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) + ii=ii+nlev_vargrp(ivargrp) + deallocate(vargrp_work_mgbf) + deallocate(vargrp_work_mgbf2) + enddo ! ivargrp + if(self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx + allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + work1var_mgbf=0.0 + if(nvargrp == 1 ) then + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+work_mgbf(lev1:lev2,:,:) + enddo + do jvar=1,nvar + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + else + do jvar=1,nvar + jvargrp=self%ivar2grp(jvar) + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + ivargrp=self%ivar2grp(ivar) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf(lev1:lev2,:,:) + enddo + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + endif + deallocate(work1var_mgbf) + endif + do k=1,nzloc + work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + enddo + ilev=1 + n_owned_size=0 + do isize=1,fields%size() + + + afield=fields%field(isize) !clttodo + write(6,*)'thinkdeb333-2 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + + + if(afield%rank() == 2) then + call afield%data(ptr_2d) + nz=afield%levels() + lev1=varvlev_index(isize,1) + write(6,*)'thinkdeb333-3 leve: leve2 ',lev1,' ',lev1+nz + if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then + loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) + write(6,*)'thinkdeb333 max is large 0.5 loc ',loc + endif + if(nz.gt.1) then + if(n_owned_size >0 ) then + ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(self%intstate(1,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + write(6,*)'suspicous situation while n_owned_szie =0 ,stop' + call flush(6) + stop + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + + endif + endif !nz >1 or not + + elseif (afield%rank() == 3) then + call afield%data(ptr_3d) + nz=afield%levels() + write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo + call flush(6) + stop + + + !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + call flush(6) + stop + endif + enddo + + call etim(mg_postprocess_time) + + + + + deallocate(work_mgbf) + deallocate(work2d_mgbf) + deallocate(rnormalization) + deallocate( varvlev_index) + !clt enddo !for iscale + call etim(mg_multiply_time) call afield%final() - deallocate(nlev_vargrp) - -end subroutine multiply - -! -------------------------------------------------------------------------------------------------- - -subroutine multiply_ad(self, fields) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields - -! This routine only needed when B = G^T G (sqrt-factored) - -! To do list for this method -! 1. Convert fields (Atlas fieldsets) to MGBF bundle -! 2. Call MGBF covariance operator adjoint (sqrt version) -! afield = fields%field('stream_function') -! call afield%data(var3d) -! var3d=0.0_r_kind - -end subroutine multiply_ad -function imem2scale(self,imem) result(iscale) - class(mgbf_covariance),intent(in)::self - integer, intent(in)::imem - integer :: iscale - iscale=1 - do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) - iscale=iscale+1 - enddo - -end function imem2scale -function ivar2grp(self,ivar) result(jvargrp) - class(mgbf_covariance),intent(in)::self - integer, intent(in)::ivar - integer :: jvargrp - jvargrp=1 - do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) - jvargrp=jvargrp+1 - enddo - -end function ivar2grp - -! -------------------------------------------------------------------------------------------------- - -end module mgbf_covariance_mod - + deallocate(nlev_vargrp) + +end subroutine multiply + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply_ad(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! This routine only needed when B = G^T G (sqrt-factored) + +! To do list for this method +! 1. Convert fields (Atlas fieldsets) to MGBF bundle +! 2. Call MGBF covariance operator adjoint (sqrt version) +! afield = fields%field('stream_function') +! call afield%data(var3d) +! var3d=0.0_r_kind + +end subroutine multiply_ad +function imem2scale(self,imem) result(iscale) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::imem + integer :: iscale + iscale=1 + do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) + iscale=iscale+1 + enddo + +end function imem2scale +function ivar2grp(self,ivar) result(jvargrp) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::ivar + integer :: jvargrp + jvargrp=1 + do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) + jvargrp=jvargrp+1 + enddo + +end function ivar2grp + +! -------------------------------------------------------------------------------------------------- + +end module mgbf_covariance_mod + diff --git a/src/saber/mgbf/mgbf_lib/jp_pietc.f90 b/src/saber/mgbf/mgbf_lib/jp_pietc.f90 index b102d22b7..0565ee185 100755 --- a/src/saber/mgbf/mgbf_lib/jp_pietc.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pietc.f90 @@ -1,111 +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 +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/saber/mgbf/mgbf_lib/jp_pmat.f90 b/src/saber/mgbf/mgbf_lib/jp_pmat.f90 index f139feea0..ef4ac4506 100755 --- a/src/saber/mgbf/mgbf_lib/jp_pmat.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pmat.f90 @@ -1,1096 +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 - +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 + From e1e86851520b0dc1a647cfcc5c458594f757f53f Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 9 Jan 2026 21:50:05 -0500 Subject: [PATCH 112/199] WIP --- codex_context.md | 54 ++++++++++ src/saber/mgbf/utils/MGBF_GeometryBridge.cc | 105 -------------------- src/saber/mgbf/utils/MGBF_GeometryBridge.h | 28 ------ 3 files changed, 54 insertions(+), 133 deletions(-) create mode 100644 codex_context.md delete mode 100644 src/saber/mgbf/utils/MGBF_GeometryBridge.cc delete mode 100644 src/saber/mgbf/utils/MGBF_GeometryBridge.h diff --git a/codex_context.md b/codex_context.md new file mode 100644 index 000000000..f177ad973 --- /dev/null +++ b/codex_context.md @@ -0,0 +1,54 @@ +# codex_context.md + +## Scope +- Package: saber (MGBF components) +- Focus: memory usage and filtering paths in mgbf_lib and covariance wrappers. + +## Key paths +- MGBF covariance wrapper: src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +- MGBF core library: src/saber/mgbf/mgbf_lib/*.f90 +- Filtering implementation: src/saber/mgbf/mgbf_lib/mg_filtering.f90 +- Parameters: src/saber/mgbf/mgbf_lib/mg_parameter.f90 +- Internal state: src/saber/mgbf/mgbf_lib/mg_intstate.f90 + +## Current configuration assumptions +- l_loc = .false. +- l_vertical_filter = .true. +- l_mgbf_inhomogeneous = .false. +- filtering_fast_bkg(this) is the active filter path +- mgbf_line may be .false. in the fast-bkg flow + +## Memory drivers (high-level) +- Large arrays scale with km_all (= km * n_ens), im/jm (plus halo), lm, and count of arrays. +- Additional multiplicative factor when nscale or nvargrp > 1. + +## Large allocations (mgbf_lib) +- VALL/HALL: (km_all, im+2*hx, jm+2*hy) +- a_diff_f/a_diff_h/b_diff_f/b_diff_h: (km_all, im+2*hx, jm+2*hy) +- paspx4d/paspy4d and ssx4d/ssy4d: (lm, im+2*hx, jm+2*hy, 2) +- pasp3 (3x3 tensor per grid point): (3,3,im,jm,lm) +- hss3: (im, jm, lm, 6) +- qcols: (0:7, im, jm, lm) +- (localization only) w1_loc..w4_loc +- (setup only; can be scoped) weig_var: (km_all, im+2*hx, jm+2*hy, gm) + +## filtering_fast_bkg usage +Used arrays in filtering_fast_bkg: +- paspx4d, paspy4d, ssx4d, ssy4d +- pasp1, ss1 (vertical filter) +- VALL, HALL + +Not used by filtering_fast_bkg: +- vpasp2, hss2, dixs, diys +- vpasp3, hss3, qcols, dixs3, diys3, dizs3 +- ss3 +- pasp2/pasp3 only needed for radial/line paths outside fast-bkg + +## Notes on mgbf_covariance_mod multiply +- work_mgbf is a full 3D buffer; work2d_mgbf is a packed 2D buffer. +- work_mgbf2 was removed by user; ensure no leftover deallocate or references. + +## Cleanup candidates +- Consider guarding allocation of line-operator arrays when only filtering_fast_bkg is used. +- Consider scoping weig_var allocation to def_mg_weights and deallocating after use. +- Add deallocation of mg_parameter allocatables (ixm/jym/nxy/im0/jm0/Fimax/Fjmax/FimaxL/FjmaxL/zofis/isofz) if reinit happens. diff --git a/src/saber/mgbf/utils/MGBF_GeometryBridge.cc b/src/saber/mgbf/utils/MGBF_GeometryBridge.cc deleted file mode 100644 index 34ac1922b..000000000 --- a/src/saber/mgbf/utils/MGBF_GeometryBridge.cc +++ /dev/null @@ -1,105 +0,0 @@ -#include "saber/mgbf/utils/MGBF_GeometryBridge.h" - -#include -#include - -#include "atlas/array.h" -#include "atlas/field.h" -#include "atlas/functionspace/FunctionSpace.h" -#include "atlas/functionspace/StructuredColumns.h" - -#include "eckit/log/Log.h" -#include "eckit/config/Configuration.h" -#include "eckit/config/LocalConfiguration.h" -#include "eckit/exception/Exceptions.h" -#include "eckit/mpi/Comm.h" - -#include "saber/interpolation/Geometry.h" - -namespace saber { -namespace mgbf { - -namespace { - -const char *kInnerGeometryKey = "inner geometry"; - -const eckit::Configuration &ensureInnerGeometry(const eckit::Configuration &conf, - std::unique_ptr &holder) { - if (!conf.has(kInnerGeometryKey)) { - throw eckit::BadParameter("inner geometry section missing in SABER configuration"); - } - holder.reset(new eckit::LocalConfiguration(conf.getSubConfiguration(kInnerGeometryKey))); - return *holder; -} - -} // namespace - -extern "C" void saber_mgbf_inner_geom_build(const void *conf_ptr, - const void *comm_ptr, - double **lonlat_out, - int *npts_total_out, - int *npts_owned_out, - int *status_out) { - if (lonlat_out == nullptr || npts_total_out == nullptr || - npts_owned_out == nullptr || status_out == nullptr) { - if (status_out != nullptr) *status_out = 1; - return; - } - - *lonlat_out = nullptr; - *npts_total_out = 0; - *npts_owned_out = 0; - *status_out = 0; - - try { - const auto *conf_wrapper = reinterpret_cast(conf_ptr); - const auto *comm_wrapper = reinterpret_cast(comm_ptr); - - if (conf_wrapper == nullptr || comm_wrapper == nullptr) { - throw eckit::SeriousBug("Null configuration or communicator pointer passed to geometry bridge"); - } - - std::unique_ptr inner_holder; - const eckit::Configuration &inner_conf = ensureInnerGeometry(*conf_wrapper, inner_holder); - - saber::interpolation::Geometry geom(inner_conf, *comm_wrapper); - - const atlas::FunctionSpace &fs = geom.functionSpace(); - if (fs.type() != "StructuredColumns") { - throw eckit::BadParameter("Inner geometry must be StructuredColumns for MGBF"); - } - - atlas::functionspace::StructuredColumns structured(fs); - const atlas::Field lonlatField = structured.lonlat(); - auto lonlatView = atlas::array::make_view(lonlatField); - - const std::size_t npts_total = lonlatView.shape(0); - const std::size_t ncoords = lonlatView.shape(1); - if (ncoords != 2) { - throw eckit::SeriousBug("Unexpected lonlat field rank in geometry bridge"); - } - - std::unique_ptr buffer(new double[npts_total * 2]); - for (std::size_t i = 0; i < npts_total; ++i) { - buffer[i + 0 * npts_total] = lonlatView(i, 0); - buffer[i + 1 * npts_total] = lonlatView(i, 1); - } - - *npts_total_out = static_cast(npts_total); - *npts_owned_out = static_cast(structured.sizeOwned()); - *lonlat_out = buffer.release(); - } catch (const std::exception &e) { - *status_out = 1; - *lonlat_out = nullptr; - *npts_total_out = 0; - *npts_owned_out = 0; - eckit::Log::error() << "saber_mgbf_inner_geom_build: " << e.what() << std::endl; - } -} - -extern "C" void saber_mgbf_inner_geom_free(double *lonlat) { - delete[] lonlat; -} - -} // namespace mgbf -} // namespace saber diff --git a/src/saber/mgbf/utils/MGBF_GeometryBridge.h b/src/saber/mgbf/utils/MGBF_GeometryBridge.h deleted file mode 100644 index 46e518b2f..000000000 --- a/src/saber/mgbf/utils/MGBF_GeometryBridge.h +++ /dev/null @@ -1,28 +0,0 @@ -#pragma once - -#include - -namespace saber { -namespace mgbf { - -/// Build the inner SABER geometry and return lon/lat coordinates together with -/// the number of owned points. -/// \param[in] conf_ptr Pointer to the fckit configuration (C handle) -/// \param[in] comm_ptr Pointer to the fckit MPI communicator (C handle) -/// \param[out] lonlat Newly allocated array of size (npts_total * 2) -/// \param[out] npts_total Total number of grid points (owned + halo) -/// \param[out] npts_owned Number of locally owned grid points -/// \param[out] status 0 on success, non-zero otherwise -extern "C" void saber_mgbf_inner_geom_build(const void *conf_ptr, - const void *comm_ptr, - double **lonlat, - int *npts_total, - int *npts_owned, - int *status); - -/// Release the lon/lat array allocated by saber_mgbf_inner_geom_build. -extern "C" void saber_mgbf_inner_geom_free(double *lonlat); - -} // namespace mgbf -} // namespace saber - From 8db2b4a15442b125bf0fba8780964aa10771aa83 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Fri, 21 Nov 2025 16:45:47 +0000 Subject: [PATCH 113/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 392 ++++++++++++++++++ 1 file changed, 392 insertions(+) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index f2a3cf094..515d48687 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -74,19 +74,29 @@ module mgbf_covariance_mod ! -------------------------------------------------------------------------------------------------- +<<<<<<< HEAD subroutine create(self, comm, config, funcspace, background, firstguess) +======= +subroutine create(self, comm, config, background, firstguess) +>>>>>>> c95a6c96 (WIP) ! Arguments class(mgbf_covariance), intent(inout) :: self type(fckit_mpi_comm), intent(in) :: comm type(fckit_configuration), intent(in) :: config +<<<<<<< HEAD type(atlas_functionspace), intent(in) :: funcspace +======= +>>>>>>> c95a6c96 (WIP) type(atlas_fieldset), intent(in) :: background type(atlas_fieldset), intent(in) :: firstguess ! Locals +<<<<<<< HEAD real(r_kind) :: dist_rad, dist_m integer :: ipt +======= +>>>>>>> c95a6c96 (WIP) character(len=*), parameter :: myname_=myname//'*create' character(len=:), allocatable :: mgbf_nml,centralblockname logical :: central @@ -94,6 +104,7 @@ subroutine create(self, comm, config, funcspace, background, firstguess) integer :: myunit integer :: iscale,ivargrp integer :: nscale=1, nvargrp=1 +<<<<<<< HEAD type(atlas_field) :: afield, lonlat_field type(atlas_functionspace_structuredcolumns) :: fs_sc real(r_kind), pointer :: lonlat_ptr(:,:) @@ -102,6 +113,9 @@ subroutine create(self, comm, config, funcspace, background, firstguess) integer :: npts_total +======= +type(atlas_field) :: afield +>>>>>>> c95a6c96 (WIP) character(len=80) :: readin_mgbf_nml_group(99) real :: readin_multigrp_cor(99)=1.0 integer :: readin_iscalegroup(99)=999 @@ -109,8 +123,11 @@ subroutine create(self, comm, config, funcspace, background, firstguess) integer ::i,j, ii namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup +<<<<<<< HEAD character(len=:), allocatable :: dump_json +======= +>>>>>>> c95a6c96 (WIP) ! Hold communicator ! ----------------- !self%mp_comm_world=comm%communicator() @@ -120,11 +137,14 @@ subroutine create(self, comm, config, funcspace, background, firstguess) !clt call self%grid%create(config, comm) self%rank = comm%rank() +<<<<<<< HEAD write(6,*)'thinkdeb mgbf create999 ' write(6,*)'thinkdeb mgbf create999 config' dump_json=config%json() ! serialize to a JSON string write(6,'(A)')trim(dump_json) call flush(6) +======= +>>>>>>> c95a6c96 (WIP) call config%get_or_die("saber block name", centralblockname) !clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) if (config%has("mgbf sdl and vdl init namelist file")) then @@ -157,7 +177,11 @@ subroutine create(self, comm, config, funcspace, background, firstguess) enddo enddo do i=1,nvargrp +<<<<<<< HEAD self%ivargroup(i)=readin_ivargroup(i) +======= + self%ivargroup(i)=readin_ivargroup(iscale) +>>>>>>> c95a6c96 (WIP) enddo else call config%get_or_die("mgbf namelist file ", mgbf_nml) @@ -178,6 +202,7 @@ subroutine create(self, comm, config, funcspace, background, firstguess) ! the previous namelist files could be still used,correctly, ! by the current sdl/vdl enhanced version endif +<<<<<<< HEAD if (trim(funcspace%name()) /= 'StructuredColumns') then error stop 'MGBF requires StructuredColumns function space' @@ -218,6 +243,14 @@ subroutine create(self, comm, config, funcspace, background, firstguess) write(6,*)'thinkdeb mgbf create999 10 ' call flush(6) if (allocated(lonlat_anl)) deallocate(lonlat_anl) +======= +allocate(self%intstate(nscale,nvargrp)) +do iscale=1,nscale + do ivargrp=1,nvargrp + call self%intstate(iscale,ivargrp)%mg_initialize(self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml + enddo +enddo +>>>>>>> c95a6c96 (WIP) ! Get background (temporary test of the functionality) !cltafield = background%field('air_temperature') !clt call afield%data(t) @@ -315,6 +348,10 @@ subroutine multiply(self, fields,index_member_in) real(kind=r_kind), pointer :: ptr_3d(:,:,:) integer(kind=i_kind):: nz,ilev,isize real(kind=r_kind), allocatable :: work_mgbf(:,:,:) +<<<<<<< HEAD +======= +real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) +>>>>>>> c95a6c96 (WIP) real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) @@ -335,13 +372,20 @@ subroutine multiply(self, fields,index_member_in) integer :: n_owned_size integer, pointer :: ghost(:) !clttype(atlas_FunctionSpace) :: fs +<<<<<<< HEAD type(atlas_functionspace) :: fs_generic type(atlas_functionspace_StructuredColumns) :: fs integer :: ierr +======= +type(atlas_functionspace_StructuredColumns) :: fs +integer :: ierr +real(kind=8) :: val +>>>>>>> c95a6c96 (WIP) integer :: member_index integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp integer :: total_km_a_all,ii,nvargrp integer :: ilev1,ilev2 +<<<<<<< HEAD integer :: loc(2) if(index_member_in >= 999) then ! not set previously and should not be used, @@ -350,6 +394,14 @@ subroutine multiply(self, fields,index_member_in) ! namely, it is not a sdl/vdl run. member_index=index_member_in+1 ! the privous ensemble index starts from 0) endif +======= + +!clt now noly consider t +! afield = fields%field('air_temperature') +! call afield%data(t) +!*** From the analysis to first generation of filter grid + member_index=index_member_in+1 ! the privous ensemble index starts from 0) +>>>>>>> c95a6c96 (WIP) jscale=self%imem2scale(member_index) nvargrp=self%nvargrp call btim(mg_multiply_time) @@ -387,6 +439,10 @@ subroutine multiply(self, fields,index_member_in) l2d_encountered=.false. ivargrp0=1 allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) +<<<<<<< HEAD +======= + allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) +>>>>>>> c95a6c96 (WIP) allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) allocate(rnormalization(total_km_a_all,nvargrp)) rnormalization=0.0 @@ -424,9 +480,13 @@ subroutine multiply(self, fields,index_member_in) n_owned_size= fs%size_owned() !clt for debug write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() if(afield%rank() == 2) then +<<<<<<< HEAD write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() nz=afield%levels() write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz +======= + nz=afield%levels() +>>>>>>> c95a6c96 (WIP) call afield%data(ptr_2d) if(nz /= 1 .and. nz /= nz3d ) then write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d @@ -438,22 +498,28 @@ subroutine multiply(self, fields,index_member_in) !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then if(self%intstate(jscale,1)%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level +<<<<<<< HEAD if(ilev+nz3d-1 > total_km_a_all) then write(6,*)'MGBF abort 1 : the dimensions are not as expected' call flush(6) stop endif +======= +>>>>>>> c95a6c96 (WIP) if(n_owned_size >0 ) then work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) else work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d endif else +<<<<<<< HEAD if(ilev+nz-1 > total_km_a_all) then write(6,*)'MGBF abort 2 : the dimensions are not as expected' call flush(6) stop endif +======= +>>>>>>> c95a6c96 (WIP) if(n_owned_size >0 ) then work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) else @@ -463,11 +529,14 @@ subroutine multiply(self, fields,index_member_in) else +<<<<<<< HEAD if(ilev+nz-1 > total_km_a_all) then write(6,*)'MGBF abort 3 : the dimensions are not as expected' call flush(6) stop endif +======= +>>>>>>> c95a6c96 (WIP) if(n_owned_size >0 ) then work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) else @@ -475,22 +544,28 @@ subroutine multiply(self, fields,index_member_in) endif endif else +<<<<<<< HEAD if(ilev+nz-1 > total_km_a_all) then write(6,*)'MGBF abort 4 : the dimensions are not as expected' call flush(6) stop endif +======= +>>>>>>> c95a6c96 (WIP) if(n_owned_size >0 ) then work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) else work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d endif endif +<<<<<<< HEAD if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then write(6,*)'thinkdeb333 before max is large 0.5' loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) write(6,*)'thinkdeb333 before large 0.5 loc ',loc endif +======= +>>>>>>> c95a6c96 (WIP) if(nz == 1) then l2d_encountered=.true. @@ -543,6 +618,10 @@ subroutine multiply(self, fields,index_member_in) work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) enddo +<<<<<<< HEAD +======= +>>>>>>> 656ae031 (WIP) +>>>>>>> c95a6c96 (WIP) if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added @@ -581,6 +660,7 @@ subroutine multiply(self, fields,index_member_in) write(6,*)'codexdebug max_out_grp ', ivargrp, maxval(vargrp_work_mgbf2) call etim(mg_filt_to_anal_time) !clt# work_mgbf=999.0 !thinkdeb for debug +<<<<<<< HEAD call btim(mg_postprocess_time) do k=1,nlev_vargrp(ivargrp) @@ -712,6 +792,315 @@ subroutine multiply(self, fields,index_member_in) !clt enddo !for iscale call etim(mg_multiply_time) call afield%final() +======= +<<<<<<< HEAD + + call btim(mg_postprocess_time) + do k=1,nlev_vargrp(ivargrp) + vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) + enddo + work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) + ii=ii+nlev_vargrp(ivargrp) + deallocate(vargrp_work_mgbf) + deallocate(vargrp_work_mgbf2) + enddo ! ivargrp + if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx + work_mgbf=work_mgbf2 + else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures + allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + work1var_mgbf=0.0 + if(nvargrp == 1 ) then + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) + enddo + do jvar=1,nvar + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + else + do jvar=1,nvar + jvargrp=self%ivar2grp(jvar) + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + ivargrp=self%ivar2grp(ivar) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) + enddo + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + endif + deallocate(work1var_mgbf) + endif + do k=1,nzloc + work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + enddo + ilev=1 + n_owned_size=0 + do isize=1,fields%size() + + + afield=fields%field(isize) !clttodo + write(6,*)'thinkdeb333-2 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + + + if(afield%rank() == 2) then + call afield%data(ptr_2d) + nz=afield%levels() + lev1=varvlev_index(isize,1) + write(6,*)'thinkdeb333-3 leve: leve2 ',lev1,' ',lev1+nz + if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then + loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) + write(6,*)'thinkdeb333 max is large 0.5 loc ',loc + endif + if(nz.gt.1) then + if(n_owned_size >0 ) then + ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(self%intstate(1,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + write(6,*)'suspicous situation while n_owned_szie =0 ,stop' + call flush(6) + stop + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + + endif + endif !nz >1 or not + + elseif (afield%rank() == 3) then + call afield%data(ptr_3d) + nz=afield%levels() + write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo + call flush(6) + stop + + + !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + call flush(6) + stop + endif + enddo + + call etim(mg_postprocess_time) + + + + + deallocate(work_mgbf) + deallocate(work_mgbf2) + deallocate(work2d_mgbf) + deallocate(rnormalization) + deallocate( varvlev_index) + !clt enddo !for iscale + call etim(mg_multiply_time) + call afield%final() + deallocate(nlev_vargrp) + +end subroutine multiply + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply_ad(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! This routine only needed when B = G^T G (sqrt-factored) + +! To do list for this method +! 1. Convert fields (Atlas fieldsets) to MGBF bundle +! 2. Call MGBF covariance operator adjoint (sqrt version) +! afield = fields%field('stream_function') +! call afield%data(var3d) +! var3d=0.0_r_kind + +end subroutine multiply_ad +function imem2scale(self,imem) result(iscale) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::imem + integer :: iscale + iscale=1 + do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) + iscale=iscale+1 + enddo + +end function imem2scale +function ivar2grp(self,ivar) result(jvargrp) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::ivar + integer :: jvargrp + jvargrp=1 + do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) + jvargrp=jvargrp+1 + enddo + +end function ivar2grp + +! -------------------------------------------------------------------------------------------------- + +end module mgbf_covariance_mod + +======= + + call btim(mg_postprocess_time) + do k=1,nlev_vargrp(ivargrp) + vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) + enddo + work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) + ii=ii+nlev_vargrp(ivargrp) + deallocate(vargrp_work_mgbf) + deallocate(vargrp_work_mgbf2) + enddo ! ivargrp + if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx + work_mgbf=work_mgbf2 + else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures + allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + work1var_mgbf=0.0 + if(nvargrp == 1 ) then + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) + enddo + do jvar=1,nvar + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + else + do jvar=1,nvar + jvargrp=self%ivar2grp(jvar) + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + ivargrp=self%ivar2grp(ivar) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) + enddo + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + endif + deallocate(work1var_mgbf) + endif + do k=1,nzloc + work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + enddo + ilev=1 + n_owned_size=0 + do isize=1,fields%size() + + afield=fields%field(isize) !clttodo + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + if(afield%rank() == 2) then + call afield%data(ptr_2d) + nz=afield%levels() + lev1=varvlev_index(isize,1) + if(nz.gt.1) then + if(n_owned_size >0 ) then + ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(self%intstate(1,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + write(6,*)'suspicous situation while n_owned_szie =0 ,stop' + call flush(6) + stop + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + + endif + endif !nz >1 or not + + elseif (afield%rank() == 3) then + call afield%data(ptr_3d) + nz=afield%levels() + write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo + call flush(6) + stop + + + !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + call flush(6) + stop + endif + enddo + + call etim(mg_postprocess_time) + + call afield%final() + + + deallocate(work_mgbf) + deallocate(work_mgbf2) + deallocate(work2d_mgbf) + deallocate(rnormalization) + deallocate( varvlev_index) + !clt enddo !for iscale + call etim(mg_multiply_time) +>>>>>>> c95a6c96 (WIP) deallocate(nlev_vargrp) end subroutine multiply @@ -758,4 +1147,7 @@ end function ivar2grp ! -------------------------------------------------------------------------------------------------- end module mgbf_covariance_mod +<<<<<<< HEAD +======= +>>>>>>> c95a6c96 (WIP) From 980719b2cb49dabae2835847c8a11d3cc9a05542 Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Mon, 12 Jan 2026 17:15:13 +0000 Subject: [PATCH 114/199] WIP --- .gitattributes | 9 + .../covariance/MGBF_Covariance.interface.F90 | 1 + .../mgbf/covariance/mgbf_covariance_mod.f90 | 397 ------------------ 3 files changed, 10 insertions(+), 397 deletions(-) create mode 100644 .gitattributes diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 000000000..ad3c7d4df --- /dev/null +++ b/.gitattributes @@ -0,0 +1,9 @@ +# Default: treat files as text and normalize to LF in the repo +* text=auto eol=lf + +# (Optional) common binary types +*.png binary +*.jpg binary +*.pdf binary +*.nc binary + diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 index 5108a3142..d75282ca3 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 +++ b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 @@ -186,6 +186,7 @@ subroutine mgbf_covariance_multiply_cpp(c_self, c_afieldset,c_index_member_in) & call flush(6) call f_self%multiply(f_fieldset,index_member_in) call etim(mg_interface_multiply_time) +call f_fieldset%final() end subroutine mgbf_covariance_multiply_cpp diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 515d48687..57722d9fa 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -74,29 +74,19 @@ module mgbf_covariance_mod ! -------------------------------------------------------------------------------------------------- -<<<<<<< HEAD subroutine create(self, comm, config, funcspace, background, firstguess) -======= -subroutine create(self, comm, config, background, firstguess) ->>>>>>> c95a6c96 (WIP) ! Arguments class(mgbf_covariance), intent(inout) :: self type(fckit_mpi_comm), intent(in) :: comm type(fckit_configuration), intent(in) :: config -<<<<<<< HEAD type(atlas_functionspace), intent(in) :: funcspace -======= ->>>>>>> c95a6c96 (WIP) type(atlas_fieldset), intent(in) :: background type(atlas_fieldset), intent(in) :: firstguess ! Locals -<<<<<<< HEAD real(r_kind) :: dist_rad, dist_m integer :: ipt -======= ->>>>>>> c95a6c96 (WIP) character(len=*), parameter :: myname_=myname//'*create' character(len=:), allocatable :: mgbf_nml,centralblockname logical :: central @@ -104,7 +94,6 @@ subroutine create(self, comm, config, background, firstguess) integer :: myunit integer :: iscale,ivargrp integer :: nscale=1, nvargrp=1 -<<<<<<< HEAD type(atlas_field) :: afield, lonlat_field type(atlas_functionspace_structuredcolumns) :: fs_sc real(r_kind), pointer :: lonlat_ptr(:,:) @@ -113,9 +102,6 @@ subroutine create(self, comm, config, background, firstguess) integer :: npts_total -======= -type(atlas_field) :: afield ->>>>>>> c95a6c96 (WIP) character(len=80) :: readin_mgbf_nml_group(99) real :: readin_multigrp_cor(99)=1.0 integer :: readin_iscalegroup(99)=999 @@ -123,11 +109,8 @@ subroutine create(self, comm, config, background, firstguess) integer ::i,j, ii namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup -<<<<<<< HEAD character(len=:), allocatable :: dump_json -======= ->>>>>>> c95a6c96 (WIP) ! Hold communicator ! ----------------- !self%mp_comm_world=comm%communicator() @@ -137,14 +120,11 @@ subroutine create(self, comm, config, background, firstguess) !clt call self%grid%create(config, comm) self%rank = comm%rank() -<<<<<<< HEAD write(6,*)'thinkdeb mgbf create999 ' write(6,*)'thinkdeb mgbf create999 config' dump_json=config%json() ! serialize to a JSON string write(6,'(A)')trim(dump_json) call flush(6) -======= ->>>>>>> c95a6c96 (WIP) call config%get_or_die("saber block name", centralblockname) !clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) if (config%has("mgbf sdl and vdl init namelist file")) then @@ -177,11 +157,7 @@ subroutine create(self, comm, config, background, firstguess) enddo enddo do i=1,nvargrp -<<<<<<< HEAD self%ivargroup(i)=readin_ivargroup(i) -======= - self%ivargroup(i)=readin_ivargroup(iscale) ->>>>>>> c95a6c96 (WIP) enddo else call config%get_or_die("mgbf namelist file ", mgbf_nml) @@ -202,7 +178,6 @@ subroutine create(self, comm, config, background, firstguess) ! the previous namelist files could be still used,correctly, ! by the current sdl/vdl enhanced version endif -<<<<<<< HEAD if (trim(funcspace%name()) /= 'StructuredColumns') then error stop 'MGBF requires StructuredColumns function space' @@ -227,8 +202,6 @@ subroutine create(self, comm, config, background, firstguess) lonlat_anl(:,2) = lonlat_ptr(2,1:npts_owned) call lonlat_field%final() -write(6,*)'thinkdeb mgbf create999 4 ' -call flush(6) allocate(self%intstate(nscale,nvargrp)) call flush(6) @@ -243,17 +216,6 @@ subroutine create(self, comm, config, background, firstguess) write(6,*)'thinkdeb mgbf create999 10 ' call flush(6) if (allocated(lonlat_anl)) deallocate(lonlat_anl) -======= -allocate(self%intstate(nscale,nvargrp)) -do iscale=1,nscale - do ivargrp=1,nvargrp - call self%intstate(iscale,ivargrp)%mg_initialize(self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml - enddo -enddo ->>>>>>> c95a6c96 (WIP) -! Get background (temporary test of the functionality) -!cltafield = background%field('air_temperature') -!clt call afield%data(t) end subroutine create @@ -348,10 +310,6 @@ subroutine multiply(self, fields,index_member_in) real(kind=r_kind), pointer :: ptr_3d(:,:,:) integer(kind=i_kind):: nz,ilev,isize real(kind=r_kind), allocatable :: work_mgbf(:,:,:) -<<<<<<< HEAD -======= -real(kind=r_kind), allocatable :: work_mgbf2(:,:,:) ->>>>>>> c95a6c96 (WIP) real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) @@ -372,20 +330,13 @@ subroutine multiply(self, fields,index_member_in) integer :: n_owned_size integer, pointer :: ghost(:) !clttype(atlas_FunctionSpace) :: fs -<<<<<<< HEAD type(atlas_functionspace) :: fs_generic type(atlas_functionspace_StructuredColumns) :: fs integer :: ierr -======= -type(atlas_functionspace_StructuredColumns) :: fs -integer :: ierr -real(kind=8) :: val ->>>>>>> c95a6c96 (WIP) integer :: member_index integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp integer :: total_km_a_all,ii,nvargrp integer :: ilev1,ilev2 -<<<<<<< HEAD integer :: loc(2) if(index_member_in >= 999) then ! not set previously and should not be used, @@ -394,14 +345,6 @@ subroutine multiply(self, fields,index_member_in) ! namely, it is not a sdl/vdl run. member_index=index_member_in+1 ! the privous ensemble index starts from 0) endif -======= - -!clt now noly consider t -! afield = fields%field('air_temperature') -! call afield%data(t) -!*** From the analysis to first generation of filter grid - member_index=index_member_in+1 ! the privous ensemble index starts from 0) ->>>>>>> c95a6c96 (WIP) jscale=self%imem2scale(member_index) nvargrp=self%nvargrp call btim(mg_multiply_time) @@ -439,10 +382,6 @@ subroutine multiply(self, fields,index_member_in) l2d_encountered=.false. ivargrp0=1 allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) -<<<<<<< HEAD -======= - allocate(work_mgbf2(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) ->>>>>>> c95a6c96 (WIP) allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) allocate(rnormalization(total_km_a_all,nvargrp)) rnormalization=0.0 @@ -480,13 +419,9 @@ subroutine multiply(self, fields,index_member_in) n_owned_size= fs%size_owned() !clt for debug write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() if(afield%rank() == 2) then -<<<<<<< HEAD write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() nz=afield%levels() write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz -======= - nz=afield%levels() ->>>>>>> c95a6c96 (WIP) call afield%data(ptr_2d) if(nz /= 1 .and. nz /= nz3d ) then write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d @@ -498,28 +433,22 @@ subroutine multiply(self, fields,index_member_in) !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then if(self%intstate(jscale,1)%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level -<<<<<<< HEAD if(ilev+nz3d-1 > total_km_a_all) then write(6,*)'MGBF abort 1 : the dimensions are not as expected' call flush(6) stop endif -======= ->>>>>>> c95a6c96 (WIP) if(n_owned_size >0 ) then work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) else work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d endif else -<<<<<<< HEAD if(ilev+nz-1 > total_km_a_all) then write(6,*)'MGBF abort 2 : the dimensions are not as expected' call flush(6) stop endif -======= ->>>>>>> c95a6c96 (WIP) if(n_owned_size >0 ) then work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) else @@ -529,14 +458,11 @@ subroutine multiply(self, fields,index_member_in) else -<<<<<<< HEAD if(ilev+nz-1 > total_km_a_all) then write(6,*)'MGBF abort 3 : the dimensions are not as expected' call flush(6) stop endif -======= ->>>>>>> c95a6c96 (WIP) if(n_owned_size >0 ) then work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) else @@ -544,28 +470,22 @@ subroutine multiply(self, fields,index_member_in) endif endif else -<<<<<<< HEAD if(ilev+nz-1 > total_km_a_all) then write(6,*)'MGBF abort 4 : the dimensions are not as expected' call flush(6) stop endif -======= ->>>>>>> c95a6c96 (WIP) if(n_owned_size >0 ) then work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) else work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d endif endif -<<<<<<< HEAD if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then write(6,*)'thinkdeb333 before max is large 0.5' loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) write(6,*)'thinkdeb333 before large 0.5 loc ',loc endif -======= ->>>>>>> c95a6c96 (WIP) if(nz == 1) then l2d_encountered=.true. @@ -618,10 +538,6 @@ subroutine multiply(self, fields,index_member_in) work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) enddo -<<<<<<< HEAD -======= ->>>>>>> 656ae031 (WIP) ->>>>>>> c95a6c96 (WIP) if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' stop ! a better exception handling is to be added @@ -660,7 +576,6 @@ subroutine multiply(self, fields,index_member_in) write(6,*)'codexdebug max_out_grp ', ivargrp, maxval(vargrp_work_mgbf2) call etim(mg_filt_to_anal_time) !clt# work_mgbf=999.0 !thinkdeb for debug -<<<<<<< HEAD call btim(mg_postprocess_time) do k=1,nlev_vargrp(ivargrp) @@ -784,323 +699,14 @@ subroutine multiply(self, fields,index_member_in) - - deallocate(work_mgbf) - deallocate(work2d_mgbf) - deallocate(rnormalization) - deallocate( varvlev_index) - !clt enddo !for iscale - call etim(mg_multiply_time) - call afield%final() -======= -<<<<<<< HEAD - - call btim(mg_postprocess_time) - do k=1,nlev_vargrp(ivargrp) - vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) - enddo - work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) - ii=ii+nlev_vargrp(ivargrp) - deallocate(vargrp_work_mgbf) - deallocate(vargrp_work_mgbf2) - enddo ! ivargrp - if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx - work_mgbf=work_mgbf2 - else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures - allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - work1var_mgbf=0.0 - if(nvargrp == 1 ) then - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) - enddo - do jvar=1,nvar - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - else - do jvar=1,nvar - jvargrp=self%ivar2grp(jvar) - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - ivargrp=self%ivar2grp(ivar) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) - enddo - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - endif - deallocate(work1var_mgbf) - endif - do k=1,nzloc - work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) - enddo - ilev=1 - n_owned_size=0 - do isize=1,fields%size() - - - afield=fields%field(isize) !clttodo - write(6,*)'thinkdeb333-2 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - - - if(afield%rank() == 2) then - call afield%data(ptr_2d) - nz=afield%levels() - lev1=varvlev_index(isize,1) - write(6,*)'thinkdeb333-3 leve: leve2 ',lev1,' ',lev1+nz - if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then - loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) - write(6,*)'thinkdeb333 max is large 0.5 loc ',loc - endif - if(nz.gt.1) then - if(n_owned_size >0 ) then - ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(self%intstate(1,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - write(6,*)'suspicous situation while n_owned_szie =0 ,stop' - call flush(6) - stop - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - - endif - endif !nz >1 or not - - elseif (afield%rank() == 3) then - call afield%data(ptr_3d) - nz=afield%levels() - write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo - call flush(6) - stop - - - !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - call flush(6) - stop - endif - enddo - - call etim(mg_postprocess_time) - - - - - deallocate(work_mgbf) - deallocate(work_mgbf2) - deallocate(work2d_mgbf) - deallocate(rnormalization) - deallocate( varvlev_index) - !clt enddo !for iscale - call etim(mg_multiply_time) - call afield%final() - deallocate(nlev_vargrp) - -end subroutine multiply - -! -------------------------------------------------------------------------------------------------- - -subroutine multiply_ad(self, fields) - -! Arguments -class(mgbf_covariance), intent(inout) :: self -type(atlas_fieldset), intent(inout) :: fields - -! This routine only needed when B = G^T G (sqrt-factored) - -! To do list for this method -! 1. Convert fields (Atlas fieldsets) to MGBF bundle -! 2. Call MGBF covariance operator adjoint (sqrt version) -! afield = fields%field('stream_function') -! call afield%data(var3d) -! var3d=0.0_r_kind - -end subroutine multiply_ad -function imem2scale(self,imem) result(iscale) - class(mgbf_covariance),intent(in)::self - integer, intent(in)::imem - integer :: iscale - iscale=1 - do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) - iscale=iscale+1 - enddo - -end function imem2scale -function ivar2grp(self,ivar) result(jvargrp) - class(mgbf_covariance),intent(in)::self - integer, intent(in)::ivar - integer :: jvargrp - jvargrp=1 - do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) - jvargrp=jvargrp+1 - enddo - -end function ivar2grp - -! -------------------------------------------------------------------------------------------------- - -end module mgbf_covariance_mod - -======= - - call btim(mg_postprocess_time) - do k=1,nlev_vargrp(ivargrp) - vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) - enddo - work_mgbf2(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) - ii=ii+nlev_vargrp(ivargrp) - deallocate(vargrp_work_mgbf) - deallocate(vargrp_work_mgbf2) - enddo ! ivargrp - if(.not. self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx - work_mgbf=work_mgbf2 - else ! if in the multivariate localization, all output for 3d or 2d variables are 3d structures - allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - work1var_mgbf=0.0 - if(nvargrp == 1 ) then - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - work1var_mgbf=work1var_mgbf+work_mgbf2(lev1:lev2,:,:) - enddo - do jvar=1,nvar - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - else - do jvar=1,nvar - jvargrp=self%ivar2grp(jvar) - do ivar=1,nvar - lev1=varvlev_index(ivar,1) - lev2=varvlev_index(ivar,2) - ivargrp=self%ivar2grp(ivar) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf2(lev1:lev2,:,:) - enddo - lev1=varvlev_index(jvar,1) - lev2=varvlev_index(jvar,2) - work_mgbf(lev1:lev2,:,:)=work1var_mgbf - enddo - endif - deallocate(work1var_mgbf) - endif - do k=1,nzloc - work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) - enddo - ilev=1 - n_owned_size=0 - do isize=1,fields%size() - - afield=fields%field(isize) !clttodo - fs= afield%functionspace() !cltthinkfore debug - n_owned_size= fs%size_owned() !clt for debug - if(afield%rank() == 2) then - call afield%data(ptr_2d) - nz=afield%levels() - lev1=varvlev_index(isize,1) - if(nz.gt.1) then - if(n_owned_size >0 ) then - ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(self%intstate(1,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - endif - else - if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space - write(6,*)'suspicous situation while n_owned_szie =0 ,stop' - call flush(6) - stop - ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) - endif - - endif - endif !nz >1 or not - - elseif (afield%rank() == 3) then - call afield%data(ptr_3d) - nz=afield%levels() - write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo - call flush(6) - stop - - - !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) - ilev=ilev+nz - else - write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo - call flush(6) - stop - endif - enddo - - call etim(mg_postprocess_time) - call afield%final() - deallocate(work_mgbf) - deallocate(work_mgbf2) deallocate(work2d_mgbf) deallocate(rnormalization) deallocate( varvlev_index) !clt enddo !for iscale call etim(mg_multiply_time) ->>>>>>> c95a6c96 (WIP) deallocate(nlev_vargrp) end subroutine multiply @@ -1147,7 +753,4 @@ end function ivar2grp ! -------------------------------------------------------------------------------------------------- end module mgbf_covariance_mod -<<<<<<< HEAD -======= ->>>>>>> c95a6c96 (WIP) From ab2bd1111c84890ab1a7e42de4e74e1f508dc7c1 Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Fri, 23 Jan 2026 00:50:11 +0000 Subject: [PATCH 115/199] Normalize line endings to LF --- codex_context.md | 2 +- .../gsi/covariance/gsi_covariance_mod.f90 | 170 ++++++++++++++---- src/saber/gsi/grid/gsi_grid_mod.f90 | 1 - src/saber/interpolation/Geometry.cc | 35 +++- src/saber/mgbf/CMakeLists.txt | 2 - 5 files changed, 166 insertions(+), 44 deletions(-) diff --git a/codex_context.md b/codex_context.md index f177ad973..fec20aea8 100644 --- a/codex_context.md +++ b/codex_context.md @@ -51,4 +51,4 @@ Not used by filtering_fast_bkg: ## Cleanup candidates - Consider guarding allocation of line-operator arrays when only filtering_fast_bkg is used. - Consider scoping weig_var allocation to def_mg_weights and deallocating after use. -- Add deallocation of mg_parameter allocatables (ixm/jym/nxy/im0/jm0/Fimax/Fjmax/FimaxL/FjmaxL/zofis/isofz) if reinit happens. +- Add deallocation of mg_parameter allocatables (ixm/jym/nxy/im0/jm0/Fimax/Fjmax/FimaxL/FjmaxL/zofis/isofz) if reinit happens. diff --git a/src/saber/gsi/covariance/gsi_covariance_mod.f90 b/src/saber/gsi/covariance/gsi_covariance_mod.f90 index 57e88baaa..db2e27170 100644 --- a/src/saber/gsi/covariance/gsi_covariance_mod.f90 +++ b/src/saber/gsi/covariance/gsi_covariance_mod.f90 @@ -53,8 +53,6 @@ module gsi_covariance_mod use constants, only: grav -use mpi - implicit none private public gsi_covariance @@ -260,8 +258,8 @@ subroutine create(self, comm, config, ntimes, background, firstguess, valid_time endif endif deallocate(tbdvars) - endif + if(jouter==1) call rf_set() endif ! noGSI @@ -276,7 +274,7 @@ subroutine bkg_set2_(varname,islot) ! print *, 'Atlas 2-dim: ', size(rank2,2), ' gsi-vec: ', self%grid%lat2,' ', self%grid%lon2 allocate(aux(self%grid%lat2,self%grid%lon2)) - call atlas_to_gsi_(rank2(1,:),aux) + call atlas_to_gsi_(rank2(1,:),aux,self%rank,self%grid%layout) call gsibec_set_guess(varname,islot,aux) deallocate(aux) @@ -294,11 +292,11 @@ subroutine bkg_set3_(varname,islot) allocate(aux(self%grid%lat2,self%grid%lon2,npz)) if (self%grid%vflip) then do k=1,npz - call atlas_to_gsi_(rank2(k,:),aux(:,:,npz-k+1)) + call atlas_to_gsi_(rank2(k,:),aux(:,:,npz-k+1),self%rank,self%grid%layout) enddo else do k=1,npz - call atlas_to_gsi_(rank2(k,:),aux(:,:,k)) + call atlas_to_gsi_(rank2(k,:),aux(:,:,k),self%rank,self%grid%layout) enddo endif call gsibec_set_guess(varname,islot,aux) @@ -432,14 +430,10 @@ subroutine multiply(self, ntimes, fields) type(gsi_bundle),allocatable :: gsisv(:) integer :: isc,iec,jsc,jec,npz integer :: iv,k,ier,itbd,ii -integer :: mype -real(kind=8) :: time_beg,time_end,walltime character(len=32),allocatable :: gvars2d(:),gvars3d(:) character(len=30),allocatable :: tbdvars(:),needvrs(:) -integer :: ierr - ! afield = fields%field('air_pressure_at_surface') ! call afield%data(rank2) ! rank2 = 0.0_kind_real @@ -503,7 +497,7 @@ subroutine multiply(self, ntimes, fields) cycle endif allocate(aux(size(gsivar2d,1),size(gsivar2d,2))) - call atlas_to_gsi_(rank2(1,:),aux) + call atlas_to_gsi_(rank2(1,:),aux,self%rank,self%grid%layout) gsivar2d=aux deallocate(aux) enddo @@ -525,12 +519,12 @@ subroutine multiply(self, ntimes, fields) allocate(aux(size(gsivar3d,1),size(gsivar3d,2))) if (self%grid%vflip) then do k=1,npz - call atlas_to_gsi_(rank2(k,:),aux) + call atlas_to_gsi_(rank2(k,:),aux,self%rank,self%grid%layout) gsivar3d(:,:,npz-k+1)=aux enddo else do k=1,npz - call atlas_to_gsi_(rank2(k,:),aux) + call atlas_to_gsi_(rank2(k,:),aux,self%rank,self%grid%layout) gsivar3d(:,:,k)=aux enddo endif @@ -555,19 +549,11 @@ subroutine multiply(self, ntimes, fields) ! Apply GSI B-error operator ! -------------------------- - time_beg=MPI_Wtime() if (self%cv) then call gsibec_cv_space(gsicv,internalcv=.false.,bypassbe=self%bypassGSIbe) else call gsibec_sv_space(gsisv,internalsv=.false.,bypassbe=self%bypassGSIbe) endif - call mpi_comm_rank(mpi_comm_world,mype,ierr) - - time_end=MPI_Wtime() !now use the existing variable - call MPI_Reduce(time_end-time_beg, walltime, 1, MPI_REAL8, MPI_MAX, 0, MPI_COMM_WORLD, ierr) - if (mype == 0) then - print '(A,F10.6,A)', 'thinkdeb999gsi_covariance_mod.f90 multiply time (max over ranks)',walltime - end if ! Convert back to Atlas Fields ! ---------------------------- @@ -816,11 +802,13 @@ end subroutine get_rank2_ ! copy atlas array into GSI array ! the atlas halos are copied as well, so it is assumed the atlas halos are up-to-date - subroutine atlas_to_gsi_(rank,var) + subroutine atlas_to_gsi_(rank,var,pe,layout) real(kind=kind_real),intent(in) :: rank(:) real(kind=kind_real),intent(inout):: var(:,:) + integer, intent(in), optional :: pe + integer, intent(in), optional :: layout(2) integer ii,jj,jnode - integer mylat2,mylon2 + integer mylat2,mylon2,mype,nxpe,nype mylat2 = size(var,1) mylon2 = size(var,2) jnode=1 @@ -836,20 +824,128 @@ subroutine atlas_to_gsi_(rank,var) ! - all x @ ymin ! - pairs of (xmin, xmax) @ each y from (ymin+1, ymax-1) ! - all x @ ymax - do ii=1,mylon2 - var(1,ii) = rank(jnode) - jnode = jnode + 1 - enddo - do jj=2,mylat2-1 - var(jj,1) = rank(jnode) - jnode = jnode + 1 - var(jj,mylon2) = rank(jnode) - jnode = jnode + 1 - enddo - do ii=1,mylon2 - var(mylat2,ii) = rank(jnode) - jnode = jnode + 1 - enddo + + if(present(pe).and.present(layout)) then + mype = pe + nxpe = layout(1) + nype = layout(2) + if(mype == 0) then + do jj=2,mylat2-1 + var(jj,mylon2) = rank(jnode) + jnode = jnode + 1 + enddo + do ii=2,mylon2 + var(mylat2,ii) = rank(jnode) + jnode = jnode + 1 + enddo + else if(mype == nxpe-1) then + do jj=2,mylat2-1 + var(jj,1) = rank(jnode) + jnode = jnode + 1 + enddo + do ii=1,mylon2-1 + var(mylat2,ii) = rank(jnode) + jnode = jnode + 1 + enddo + else if(mype == nxpe*(nype-1)) then + do ii=2,mylon2 + var(1,ii) = rank(jnode) + jnode = jnode + 1 + enddo + do jj=2,mylat2-1 + var(jj,mylon2) = rank(jnode) + jnode = jnode + 1 + enddo + else if(mype == nxpe*nype-1) then + do ii=1,mylon2-1 + var(1,ii) = rank(jnode) + jnode = jnode + 1 + enddo + do jj=2,mylat2-1 + var(jj,1) = rank(jnode) + jnode = jnode + 1 + enddo + else if(mype>0 .and. mypenxpe*(nype-1) .and. mype0 .and. mypenxpe-1 .and. mype computeS2NCheckerboardPartition(const atlas::RegularGrid & rg, return partition; } +constexpr double deg2rad(double deg) { return deg * M_PI / 180.0; } +constexpr double rad2deg(double rad) { return rad * 180.0 / M_PI; } + void setupGsiMatchingGrid(const eckit::Configuration & config, const eckit::mpi::Comm & comm, atlas::Grid & grid, @@ -152,9 +155,7 @@ void setupGsiMatchingGrid(const eckit::Configuration & config, testconfig.set("type", "structured"); testconfig.set("xspace", build_xspace_config(grid_type)); testconfig.set("yspace", build_yspace_config(grid_type)); - if (grid_type == "rotated_lonlat") { - testconfig.set("projection", build_projection_config(grid_type)); - } + if (grid_type == "rotated_lonlat") testconfig.set("projection", build_projection_config(grid_type)); grid = atlas::Grid{testconfig}; const atlas::RegularGrid rg{grid}; @@ -170,6 +171,34 @@ void setupGsiMatchingGrid(const eckit::Configuration & config, functionSpace = atlas::functionspace::StructuredColumns(grid, distribution, atlas::option::halo(halo)); + // Get rotated_lonlat on the Earth coordinate + //if (grid_type == "rotated_lonlat") { + // atlas::Field lonlatField = functionSpace.lonlat(); + // auto lonlatView = atlas::array::make_view(lonlatField); + // for (int j = 0; j < lonlatView.shape(0); ++j) { + // double rlon = lonlatView(j, 0); + // double rlat = lonlatView(j, 1); + // double rlon0 = north_pole_lon - 180.0; + // double rlat0 = 90.0 - north_pole_lat; + + // double xtt = std::cos(deg2rad(rlat)) * std::cos(deg2rad(rlon)); + // double ytt = std::cos(deg2rad(rlat)) * std::sin(deg2rad(rlon)); + // double ztt = std::sin(deg2rad(rlat)); + + // double xt = xtt*std::cos(deg2rad(rlat0)) - ztt*std::sin(deg2rad(rlat0)); + // double yt = ytt; + // double zt = xtt*std::sin(deg2rad(rlat0)) + ztt*std::cos(deg2rad(rlat0)); + + // double x = xt*std::cos(deg2rad(rlon0)) - yt*std::sin(deg2rad(rlon0)); + // double y = xt*std::sin(deg2rad(rlon0)) + yt*std::cos(deg2rad(rlon0)); + // double z = zt; + + // lonlatView(j, 0) = rad2deg(std::atan2(y,x)); + // lonlatView(j, 1) = rad2deg(std::asin(z)); + // } + // lonlatField.set_dirty(); + //} + // Using atlas::mpi::Scope in the call to atlas::functionspace::StructuredColumns // may have reverted the default communicator to the world communicator. // We set back the default communicator to `comm` to fix this. diff --git a/src/saber/mgbf/CMakeLists.txt b/src/saber/mgbf/CMakeLists.txt index dee75d524..132314786 100755 --- a/src/saber/mgbf/CMakeLists.txt +++ b/src/saber/mgbf/CMakeLists.txt @@ -24,8 +24,6 @@ if( build_saber_mgbf ) covariance/MGBF_Covariance.interface.F90 covariance/MGBF_Covariance.interface.h covariance/mgbf_covariance_mod.f90 - utils/MGBF_GeometryBridge.cc - utils/MGBF_GeometryBridge.h #clth # Grid # covariance/mgbf_Grid.h From 85b053e8d46916a34d513f0e72a0851406e51a10 Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Sat, 24 Jan 2026 21:31:37 +0000 Subject: [PATCH 116/199] WIP --- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index a8b192fa5..44cdc12a3 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1500,12 +1500,14 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) this%dyfm(i,j)=dist_rad*req enddo enddo + - rtem1=this%pasp02/this%dx_a2f_ratio - rtem2=this%pasp02/this%dx_a2f_ratio + rtem1=this%pasp02 + rtem2=this%pasp02 do i=1,this%im do j=1,this%jm + write(6,*)'thinkdeb999 dxfm/dyfm i,j = ',i,' ',j,' ',this%dxfm(i,j),' ',this%dyfm(i,j) this%paspx4d(1,i,j,1)=(rtem1/this%dxfmctrl*this%dxfm(i,j)) ! !cltthinkdeb9999 this%paspy4d(1,i,j,1)=(rtem1/this%dyfmctrl*this%dyfm(i,j)) ! enddo From b0b55035b7c1ea54ebb4b08145e8c2f9efbf7956 Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Fri, 17 Oct 2025 16:58:44 +0200 Subject: [PATCH 117/199] Use make_indexview instead of make_view to create spectral functionspace (#1117) * Use make_indexview instead of make_view to create spectral functionspace * trigger CI --------- Co-authored-by: ncrossette --- src/saber/bifourier/BifourierTransform.cc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/saber/bifourier/BifourierTransform.cc b/src/saber/bifourier/BifourierTransform.cc index 657dcf2f0..6689038b3 100644 --- a/src/saber/bifourier/BifourierTransform.cc +++ b/src/saber/bifourier/BifourierTransform.cc @@ -1643,9 +1643,9 @@ void BifourierTransform::setupLocalSpectralSpace() { flds.add(globalIndexField); auto lonlatView = make_view(lonlatField); auto ghostView = make_view(ghostField); - auto remoteIndexView = make_view(remoteIndexField); + auto remoteIndexView = make_indexview(remoteIndexField); auto partitionView = make_view(partitionField); - auto globalIndexView = make_view(globalIndexField); + auto globalIndexView = make_indexview(globalIndexField); for (size_t js = 0; js < ns_; ++js) { // Get global index From f4e4159ce0b8bfc5e33f5cd72d982704ea3c3ad8 Mon Sep 17 00:00:00 2001 From: Francois Hebert Date: Tue, 21 Oct 2025 08:03:17 -0700 Subject: [PATCH 118/199] Fix leaks of FFTW allocations (#1120) * Fix leaks of FFT allocations * Same bugfix for the FastLAM block * Add comment --------- Co-authored-by: Benjamin Menetrier --- src/saber/bifourier/BifourierTransform.cc | 19 +++++++++++++++++++ src/saber/bifourier/BifourierTransform.h | 12 ++++++------ src/saber/fastlam/LayerSpec.cc | 18 ++++++++++++++++++ src/saber/fastlam/LayerSpec.h | 10 +++++----- 4 files changed, 48 insertions(+), 11 deletions(-) diff --git a/src/saber/bifourier/BifourierTransform.cc b/src/saber/bifourier/BifourierTransform.cc index 6689038b3..fe8dd243a 100644 --- a/src/saber/bifourier/BifourierTransform.cc +++ b/src/saber/bifourier/BifourierTransform.cc @@ -189,6 +189,12 @@ BifourierTransform::BifourierTransform(const oops::GeometryData & gdata, // ----------------------------------------------------------------------------- +BifourierTransform::~BifourierTransform() { + cleanupFFT(); +} + +// ----------------------------------------------------------------------------- + void BifourierTransform::gp2sp(const atlas::FieldSet & gpFset, atlas::FieldSet & spFset, const oops::Variables & activeVars) const { @@ -1831,6 +1837,19 @@ void BifourierTransform::setupFFT() { // ----------------------------------------------------------------------------- +void BifourierTransform::cleanupFFT() { + fftw_destroy_plan(rowsPlan_r2c_); + fftw_destroy_plan(rowsPlan_c2r_); + fftw_destroy_plan(colsPlan_r2c_); + fftw_destroy_plan(colsPlan_c2r_); + fftw_free(rowsBufR_); + fftw_free(rowsBufC_); + fftw_free(colsBufR_); + fftw_free(colsBufC_); +} + +// ----------------------------------------------------------------------------- + void BifourierTransform::addSpectralCoefficient(const size_t & jk, const size_t & jl, const Quad & jq, diff --git a/src/saber/bifourier/BifourierTransform.h b/src/saber/bifourier/BifourierTransform.h index e9d3a4714..ba8723a1a 100644 --- a/src/saber/bifourier/BifourierTransform.h +++ b/src/saber/bifourier/BifourierTransform.h @@ -38,8 +38,7 @@ class BifourierTransform : public util::Printable { const eckit::Configuration &); // Destructor - ~BifourierTransform() - {} + ~BifourierTransform(); // Accessors @@ -354,14 +353,14 @@ class BifourierTransform : public util::Printable { // Rows FFT fftw_plan rowsPlan_r2c_; fftw_plan rowsPlan_c2r_; - double *rowsBufR_; - fftw_complex *rowsBufC_; + double *rowsBufR_ = nullptr; + fftw_complex *rowsBufC_ = nullptr; // Columns FFT fftw_plan colsPlan_r2c_; fftw_plan colsPlan_c2r_; - double *colsBufR_; - fftw_complex *colsBufC_; + double *colsBufR_ = nullptr; + fftw_complex *colsBufC_ = nullptr; // Private methods @@ -379,6 +378,7 @@ class BifourierTransform : public util::Printable { // Setup FFT void setupFFT(); + void cleanupFFT(); // Add spectral coefficient void addSpectralCoefficient(const size_t &, diff --git a/src/saber/fastlam/LayerSpec.cc b/src/saber/fastlam/LayerSpec.cc index d9b7a8064..3c38de836 100644 --- a/src/saber/fastlam/LayerSpec.cc +++ b/src/saber/fastlam/LayerSpec.cc @@ -24,6 +24,24 @@ static LayerMaker makerSpec_("spectral"); // ----------------------------------------------------------------------------- +LayerSpec::~LayerSpec() { + oops::Log::trace() << classname() << "::~LayerSpec starting" << std::endl; + + // Delete FFTW-related data + fftw_destroy_plan(xPlan_r2c_); + fftw_destroy_plan(xPlan_c2r_); + fftw_destroy_plan(yPlan_r2c_); + fftw_destroy_plan(yPlan_c2r_); + fftw_free(xBufR_); + fftw_free(xBufC_); + fftw_free(yBufR_); + fftw_free(yBufC_); + + oops::Log::trace() << classname() << "::~LayerSpec done" << std::endl; +} + +// ----------------------------------------------------------------------------- + void LayerSpec::setupParallelization() { oops::Log::trace() << classname() << "::setupParallelization starting" << std::endl; diff --git a/src/saber/fastlam/LayerSpec.h b/src/saber/fastlam/LayerSpec.h index 834bf9e94..20558e11e 100644 --- a/src/saber/fastlam/LayerSpec.h +++ b/src/saber/fastlam/LayerSpec.h @@ -41,7 +41,7 @@ class LayerSpec : public LayerBase { const size_t & ny0, const size_t & nz0) : LayerBase(params, fieldsMetaData, gdata, myGroup, myVars, nx0, ny0, nz0) {} - ~LayerSpec() = default; + ~LayerSpec(); // Setups void setupParallelization() override; @@ -120,8 +120,8 @@ class LayerSpec : public LayerBase { size_t nk_; fftw_plan xPlan_r2c_; fftw_plan xPlan_c2r_; - double *xBufR_; - fftw_complex *xBufC_; + double *xBufR_ = nullptr; + fftw_complex *xBufC_ = nullptr; double xNormFFT_; std::vector xSpecStdDev_; @@ -129,8 +129,8 @@ class LayerSpec : public LayerBase { size_t nl_; fftw_plan yPlan_r2c_; fftw_plan yPlan_c2r_; - double *yBufR_; - fftw_complex *yBufC_; + double *yBufR_ = nullptr; + fftw_complex *yBufC_ = nullptr; double yNormFFT_; std::vector ySpecStdDev_; }; From 3ee3b613e9ec0b0d37ce5edd6b927e66c8cfd74e Mon Sep 17 00:00:00 2001 From: Francois Hebert Date: Tue, 21 Oct 2025 14:35:14 -0700 Subject: [PATCH 119/199] Destruct statics in BifourierTransformStore before underlying Atlas statics (#1122) --- src/saber/bifourier/BifourierTransformStore.cc | 16 ++++++++++++++++ src/saber/bifourier/BifourierTransformStore.h | 6 ++---- 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/src/saber/bifourier/BifourierTransformStore.cc b/src/saber/bifourier/BifourierTransformStore.cc index d1d9522b6..a4e697419 100644 --- a/src/saber/bifourier/BifourierTransformStore.cc +++ b/src/saber/bifourier/BifourierTransformStore.cc @@ -16,6 +16,7 @@ namespace bifourier { // ----------------------------------------------------------------------------- +static int stores_in_use = 0; static std::vector> transformsVector; // ----------------------------------------------------------------------------- @@ -26,6 +27,21 @@ std::vector> & BifourierTransformStore::tran // ----------------------------------------------------------------------------- +BifourierTransformStore::BifourierTransformStore() { + ++stores_in_use; +} + +// ----------------------------------------------------------------------------- + +BifourierTransformStore::~BifourierTransformStore() { + --stores_in_use; + if (stores_in_use == 0) { + transforms().clear(); + } +} + +// ----------------------------------------------------------------------------- + std::shared_ptr BifourierTransformStore::setupTransform( const oops::GeometryData & gdata, const oops::Variables & vars, diff --git a/src/saber/bifourier/BifourierTransformStore.h b/src/saber/bifourier/BifourierTransformStore.h index 3b26669a6..6114a980c 100644 --- a/src/saber/bifourier/BifourierTransformStore.h +++ b/src/saber/bifourier/BifourierTransformStore.h @@ -22,12 +22,10 @@ class BifourierTransformStore { {return "saber::bifourier::BifourierTransform";} // Constructor - BifourierTransformStore() - {} + BifourierTransformStore(); // Destructor - ~BifourierTransformStore() - {} + ~BifourierTransformStore(); // Accessors From 611ee6ed3d48da52e92a3229f42bd9a55b26fac7 Mon Sep 17 00:00:00 2001 From: David Davies Date: Wed, 22 Oct 2025 15:21:27 +0100 Subject: [PATCH 120/199] Fix some compile warnings (#1124) Co-authored-by: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> --- .../bifourier_arome_legacy_interface.F90 | 2 -- .../bifourier/bifourier_arome_legacy_mod.F90 | 1 - src/saber/bump/tools_atlas.fypp | 8 ++++---- src/saber/bump/tools_fit.fypp | 2 +- src/saber/bump/tools_func.fypp | 6 ++---- src/saber/bump/tools_log.fypp | 2 +- src/saber/bump/tools_netcdf.fypp | 4 ++-- src/saber/bump/tools_repro.fypp | 2 +- src/saber/bump/tools_ssrfpack.fypp | 4 ++-- src/saber/bump/tools_stripack.fypp | 6 ++---- src/saber/bump/type_avg.fypp | 3 --- src/saber/bump/type_bnda.fypp | 4 ++-- src/saber/bump/type_bump.fypp | 10 +++++----- src/saber/bump/type_bump_interface.F90 | 3 +-- src/saber/bump/type_cmat.fypp | 11 ++++------- src/saber/bump/type_cmat_blk.fypp | 4 ---- src/saber/bump/type_com.fypp | 1 - src/saber/bump/type_diag.fypp | 2 +- src/saber/bump/type_diag_blk.fypp | 8 ++++---- src/saber/bump/type_ens.fypp | 7 +++---- src/saber/bump/type_fieldset.fypp | 1 - src/saber/bump/type_geom.fypp | 17 ++++++++--------- src/saber/bump/type_gsi.fypp | 4 ++-- src/saber/bump/type_hdiag.fypp | 4 +--- src/saber/bump/type_hull.fypp | 2 +- src/saber/bump/type_io.fypp | 7 +++---- src/saber/bump/type_linop.fypp | 4 ++-- src/saber/bump/type_mesh.fypp | 7 +++---- src/saber/bump/type_minim.fypp | 4 ++-- src/saber/bump/type_mom.fypp | 3 +-- src/saber/bump/type_mpl.fypp | 19 ++----------------- src/saber/bump/type_nam.fypp | 7 +++---- src/saber/bump/type_nicas.fypp | 15 ++++----------- src/saber/bump/type_nicas_blk.fypp | 15 ++++----------- src/saber/bump/type_nicas_cmp.fypp | 11 +++++------ src/saber/bump/type_samp.fypp | 14 ++------------ src/saber/bump/type_tree.fypp | 7 +++---- src/saber/bump/type_var.fypp | 14 ++++---------- src/saber/bump/type_vbal.fypp | 4 ++-- src/saber/bump/type_wind.fypp | 6 +++--- .../spectralb_covstats_interface.F90 | 12 ++++++------ .../vader/movader_covstats_interface.F90 | 16 +++++----------- 42 files changed, 101 insertions(+), 182 deletions(-) diff --git a/src/saber/bifourier/bifourier_arome_legacy_interface.F90 b/src/saber/bifourier/bifourier_arome_legacy_interface.F90 index cd319e1b2..1918d04ff 100644 --- a/src/saber/bifourier/bifourier_arome_legacy_interface.F90 +++ b/src/saber/bifourier/bifourier_arome_legacy_interface.F90 @@ -6,9 +6,7 @@ !---------------------------------------------------------------------- module bifourier_arome_legacy_interface -use atlas_module, only: atlas_fieldset use fckit_configuration_module, only: fckit_configuration -use fckit_mpi_module, only: fckit_mpi_comm use iso_c_binding, only: c_ptr, c_int, c_double use bifourier_arome_legacy_mod, only: bifourier_arome_legacy_vortopb, bifourier_arome_legacy_balance, & & bifourier_arome_legacy_covariance diff --git a/src/saber/bifourier/bifourier_arome_legacy_mod.F90 b/src/saber/bifourier/bifourier_arome_legacy_mod.F90 index c8a87d41e..8035ae917 100644 --- a/src/saber/bifourier/bifourier_arome_legacy_mod.F90 +++ b/src/saber/bifourier/bifourier_arome_legacy_mod.F90 @@ -7,7 +7,6 @@ !---------------------------------------------------------------------- module bifourier_arome_legacy_mod -use atlas_module, only: atlas_fieldset,atlas_field,atlas_real use fckit_configuration_module, only: fckit_configuration use kinds, only: kind_int, kind_real diff --git a/src/saber/bump/tools_atlas.fypp b/src/saber/bump/tools_atlas.fypp index ffbada3e0..5415212be 100644 --- a/src/saber/bump/tools_atlas.fypp +++ b/src/saber/bump/tools_atlas.fypp @@ -9,12 +9,12 @@ !---------------------------------------------------------------------- module tools_atlas -use atlas_module, only: atlas_structuredgrid,atlas_regionalgrid,atlas_field,atlas_integer,atlas_real,atlas_functionspace, & +use atlas_module, only: atlas_structuredgrid,atlas_field,atlas_integer,atlas_real,atlas_functionspace, & & atlas_functionspace_nodecolumns,atlas_functionspace_pointcloud,atlas_functionspace_structuredcolumns, & - & atlas_projection,atlas_config,atlas_json -use tools_const, only: zero,quarter,half,rad2deg + & atlas_config,atlas_json +use tools_const, only: zero,quarter use tools_kinds, only: kind_int,kind_real -use tools_func, only: sphere_dist,convert_i2l,convert_l2i +use tools_func, only: convert_i2l use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/tools_fit.fypp b/src/saber/bump/tools_fit.fypp index 566f0ebbf..dc6d57d4f 100644 --- a/src/saber/bump/tools_fit.fypp +++ b/src/saber/bump/tools_fit.fypp @@ -11,7 +11,7 @@ module tools_fit use atlas_module, only: atlas_config,atlas_json,atlas_structuredgrid use tools_const, only: zero,tenth,quarter,half,one,two,thousand,deg2rad,rad2deg use tools_func, only: sphere_dist,lonlatmod -use tools_gc99, only: naxis_inv,axis_inv,axis_invmax,func_inv_hor,func_inv_ver,fit_func,fit_func_sqrt +use tools_gc99, only: naxis_inv,axis_inv,func_inv_hor,func_inv_ver,fit_func,fit_func_sqrt use tools_kinds, only: kind_real,huge_real use tools_repro, only: inf,sup,infeq use type_mpl, only: mpl_type diff --git a/src/saber/bump/tools_func.fypp b/src/saber/bump/tools_func.fypp index 4da1b33c4..edf936b64 100644 --- a/src/saber/bump/tools_func.fypp +++ b/src/saber/bump/tools_func.fypp @@ -12,11 +12,9 @@ module tools_func use fckit_mpi_module, only: fckit_mpi_sum use iso_c_binding use tools_asa007, only: cholesky,syminv -use tools_const, only: zero,hundredth,tenth,half,one,two,three,four,five,eight,ten,pi,deg2rad,rad2deg,ageometry +use tools_const, only: zero,half,one,two,pi,deg2rad,rad2deg,ageometry use tools_kinds, only: kind_int,kind_short,kind_real,huge_int,huge_short,huge_real -use tools_qsort, only: qsort -use tools_repro, only: repro_th,inf,sup,infeq,small,eq -use tools_wrfda, only: da_eof_decomposition +use tools_repro, only: repro_th,inf,sup,infeq use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/tools_log.fypp b/src/saber/bump/tools_log.fypp index 74d234b83..e3c3180d7 100644 --- a/src/saber/bump/tools_log.fypp +++ b/src/saber/bump/tools_log.fypp @@ -10,7 +10,7 @@ module tools_log use fckit_c_interop_module, only : c_str_right_trim use fckit_log_module, only: fckit_log,fckit_logchannel -use iso_c_binding, only: c_char,c_int32_t +use iso_c_binding, only: c_int32_t @:use_probe() implicit none diff --git a/src/saber/bump/tools_netcdf.fypp b/src/saber/bump/tools_netcdf.fypp index 71717004f..7f47e200a 100644 --- a/src/saber/bump/tools_netcdf.fypp +++ b/src/saber/bump/tools_netcdf.fypp @@ -11,10 +11,10 @@ module tools_netcdf use iso_fortran_env, only: output_unit use netcdf, only: nf90_clobber,nf90_create,nf90_close,nf90_def_dim,nf90_def_grp,nf90_def_var,nf90_ebaddim,nf90_get_att, & - & nf90_get_var,nf90_global,nf90_inq_dimid,nf90_inq_grp_ncid,nf90_inquire_dimension,nf90_inquire_variable,nf90_inq_varid, & + & nf90_get_var,nf90_global,nf90_inq_dimid,nf90_inq_grp_ncid,nf90_inquire_dimension,nf90_inq_varid, & & nf90_mpiio,nf90_netcdf4,nf90_noerr,nf90_nowrite,nf90_write,nf90_open,nf90_put_att,nf90_put_var,nf90_strerror,nf90_write use tools_func, only: convert_i2l,convert_l2i -use tools_kinds, only: kind_signed_char,kind_int,kind_float,kind_double,kind_real,nc_kind_int,nc_kind_real +use tools_kinds, only: kind_signed_char,kind_int,kind_float,kind_real,nc_kind_int,nc_kind_real use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/tools_repro.fypp b/src/saber/bump/tools_repro.fypp index 2a8c99362..8928f2013 100644 --- a/src/saber/bump/tools_repro.fypp +++ b/src/saber/bump/tools_repro.fypp @@ -9,7 +9,7 @@ !---------------------------------------------------------------------- module tools_repro -use tools_const, only: zero,one,pi +use tools_const, only: zero use tools_kinds, only: kind_int,kind_real @:use_probe() diff --git a/src/saber/bump/tools_ssrfpack.fypp b/src/saber/bump/tools_ssrfpack.fypp index 830568519..abbef88a8 100644 --- a/src/saber/bump/tools_ssrfpack.fypp +++ b/src/saber/bump/tools_ssrfpack.fypp @@ -11,9 +11,9 @@ !---------------------------------------------------------------------- module tools_ssrfpack -use tools_const, only: zero,quarter,half,one,two,three,four,six,pi +use tools_const, only: zero,quarter,one,two,three,four,pi use tools_kinds, only: kind_real -use tools_repro, only: infeq,supeq +use tools_repro, only: supeq use tools_stripack, only: getnp use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/tools_stripack.fypp b/src/saber/bump/tools_stripack.fypp index d7724fe2b..5a50f727f 100644 --- a/src/saber/bump/tools_stripack.fypp +++ b/src/saber/bump/tools_stripack.fypp @@ -11,7 +11,7 @@ !---------------------------------------------------------------------- module tools_stripack -use tools_const, only: zero,one,two,four,hundred,pi +use tools_const, only: zero,one,two,four,hundred use tools_kinds, only: kind_real use tools_repro, only: eq,inf,sup,supeq,small use type_mpl, only: mpl_type @@ -271,7 +271,7 @@ integer,intent(out) :: nodes(n) !< Ordered sequence of NB boundary node inde integer,intent(out) :: nb !< Number of boundary nodes. ! Local variables -integer :: i,k,lp,n0,na,nn,nst,nt +integer :: i,k,lp,n0,nn,nst,nt ! Set name @:set_name(stripack_bnodes) @@ -295,7 +295,6 @@ end do ! The triangulation contains no boundary nodes if (nst==0) then nb = 0 - na = 3*(nn-2) nt = 2*(nn-2) @:probe_out() return @@ -322,7 +321,6 @@ end do ! Store the counts nb = k nt = 2*n-nb-2 -na = nt+n-1 ! Probe out @:probe_out() diff --git a/src/saber/bump/type_avg.fypp b/src/saber/bump/type_avg.fypp index 661450354..81eaca590 100644 --- a/src/saber/bump/type_avg.fypp +++ b/src/saber/bump/type_avg.fypp @@ -8,13 +8,10 @@ !---------------------------------------------------------------------- module type_avg -use fckit_mpi_module, only: fckit_mpi_sum !$ use omp_lib use tools_const, only: zero,one use tools_func, only: add,divide use tools_kinds, only: kind_real -use tools_netcdf, only: define_dim,define_var,put_var -use tools_wrfda, only: da_eof_decomposition use type_avg_blk, only: avg_blk_type use type_geom, only: geom_type use type_mom, only: mom_type diff --git a/src/saber/bump/type_bnda.fypp b/src/saber/bump/type_bnda.fypp index 55621f034..a33d53553 100644 --- a/src/saber/bump/type_bnda.fypp +++ b/src/saber/bump/type_bnda.fypp @@ -9,10 +9,10 @@ module type_bnda !$ use omp_lib -use tools_const, only: zero,one +use tools_const, only: zero use tools_func, only: lonlat2xyz,vector_product,det use tools_kinds, only: kind_real -use tools_repro, only: repro_th,inf +use tools_repro, only: repro_th use type_mesh, only: mesh_type use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/type_bump.fypp b/src/saber/bump/type_bump.fypp index 16a244035..9321adbaa 100644 --- a/src/saber/bump/type_bump.fypp +++ b/src/saber/bump/type_bump.fypp @@ -8,12 +8,12 @@ !---------------------------------------------------------------------- module type_bump -use atlas_module, only: atlas_field,atlas_fieldset,atlas_integer,atlas_real,atlas_functionspace +use atlas_module, only: atlas_field,atlas_real,atlas_functionspace use fckit_configuration_module, only: fckit_configuration -use fckit_mpi_module, only: fckit_mpi_comm,fckit_mpi_sum,fckit_mpi_min -use tools_const, only: initialize_constants,finalize_constants,zero,half,one,thousand,req,reqkm,deg2rad,rad2deg -use tools_func, only: fletcher32,rad2short,sphere_dist,zss_minval,zss_sum -use tools_kinds,only: kind_short,kind_real +use fckit_mpi_module, only: fckit_mpi_comm,fckit_mpi_sum +use tools_const, only: initialize_constants,finalize_constants,zero,one,req,reqkm,rad2deg +use tools_func, only: zss_sum +use tools_kinds,only: kind_real use tools_netcdf, only: registry use tools_repro,only: repro_ops,repro_th use type_cmat, only: cmat_type diff --git a/src/saber/bump/type_bump_interface.F90 b/src/saber/bump/type_bump_interface.F90 index 17714330c..1c1d62579 100644 --- a/src/saber/bump/type_bump_interface.F90 +++ b/src/saber/bump/type_bump_interface.F90 @@ -9,9 +9,8 @@ module type_bump_interface use atlas_module, only: atlas_functionspace,atlas_fieldset,atlas_field use fckit_configuration_module, only: fckit_configuration -use fckit_log_module, only: fckit_logchannel use fckit_mpi_module, only: fckit_mpi_comm -use iso_c_binding, only: c_int,c_ptr,c_double,c_char +use iso_c_binding, only: c_int,c_ptr,c_char use type_bump, only: bump_type use type_fieldset, only: fieldset_type diff --git a/src/saber/bump/type_cmat.fypp b/src/saber/bump/type_cmat.fypp index 8fb220fe5..1938526d6 100644 --- a/src/saber/bump/type_cmat.fypp +++ b/src/saber/bump/type_cmat.fypp @@ -8,21 +8,18 @@ !---------------------------------------------------------------------- module type_cmat -use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_max -use tools_const, only: zero,one,rad2deg,reqkm,req +use fckit_mpi_module, only: fckit_mpi_max +use tools_const, only: zero,one,req use tools_fit, only: tensor_d2r -use tools_func, only: convert_l2i,convert_i2l,zss_sum,zss_maxval +use tools_func, only: zss_maxval use tools_kinds, only: kind_real,huge_real -use tools_repro, only: infeq,supeq +use tools_repro, only: infeq use type_cmat_blk, only: cmat_blk_type use type_diag, only: diag_type use type_geom, only: geom_type -use type_hdiag, only: hdiag_type -use type_mom, only: mom_type use type_mpl, only: mpl_type use type_nam, only: nam_type @:use_probe() -use type_samp, only: samp_type implicit none diff --git a/src/saber/bump/type_cmat_blk.fypp b/src/saber/bump/type_cmat_blk.fypp index fd3f6e126..0bff73ec8 100644 --- a/src/saber/bump/type_cmat_blk.fypp +++ b/src/saber/bump/type_cmat_blk.fypp @@ -8,13 +8,9 @@ !---------------------------------------------------------------------- module type_cmat_blk -use fckit_mpi_module, only: fckit_mpi_sum -use tools_const, only: one -use tools_func, only: zss_sum use tools_kinds, only: kind_real use type_geom, only: geom_type use type_mpl, only: mpl_type -use type_nam, only: nam_type @:use_probe() implicit none diff --git a/src/saber/bump/type_com.fypp b/src/saber/bump/type_com.fypp index 1ebd6e5ae..2ef3f199b 100644 --- a/src/saber/bump/type_com.fypp +++ b/src/saber/bump/type_com.fypp @@ -14,7 +14,6 @@ use fckit_mpi_module, only: fckit_mpi_status use tools_kinds, only: kind_int,kind_real use tools_netcdf, only: define_grp,inquire_grp,put_att,get_att,define_dim,inquire_dim_size,define_var,inquire_var,put_var,get_var use tools_qsort, only: qsort -use tools_repro, only: eq use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/type_diag.fypp b/src/saber/bump/type_diag.fypp index da89ce64b..e72e8c1b1 100644 --- a/src/saber/bump/type_diag.fypp +++ b/src/saber/bump/type_diag.fypp @@ -9,7 +9,7 @@ module type_diag use fckit_mpi_module, only: fckit_mpi_sum -use tools_const, only: zero,half,one,two,five,reqkm,rad2deg,pi +use tools_const, only: zero,half,one,two,five,reqkm use tools_fit, only: diag_iso_full,diag_tensor_full,tensor_d2h,tensor_d2r,ver_smooth use tools_func, only: lonlatmod,sphere_dist,zss_sum,zss_count use tools_gc99, only: fit_func diff --git a/src/saber/bump/type_diag_blk.fypp b/src/saber/bump/type_diag_blk.fypp index c93b38957..514cf8cac 100644 --- a/src/saber/bump/type_diag_blk.fypp +++ b/src/saber/bump/type_diag_blk.fypp @@ -9,12 +9,12 @@ module type_diag_blk !$ use omp_lib -use tools_const, only: zero,tenth,half,one,four,ten,pi +use tools_const, only: zero,tenth,half,one,ten,pi use tools_cor_var, only: eval -use tools_fit, only: condmax,diag_iso,diag_tensor,tensor_d2h,tensor_d2r,tensor_check_cond,fast_fit +use tools_fit, only: condmax,diag_iso,diag_tensor,tensor_d2r,tensor_check_cond,fast_fit use tools_func, only: vert_interp_size,vert_interp_setup,vert_interp,zss_sum -use tools_kinds, only: kind_real,huge_real -use tools_netcdf, only: define_grp,define_dim,put_att,define_var,put_var +use tools_kinds, only: kind_real +use tools_netcdf, only: define_grp,define_dim,define_var,put_var use tools_repro, only: inf,infeq,supeq use tools_wrfda use type_avg_blk, only: avg_blk_type diff --git a/src/saber/bump/type_ens.fypp b/src/saber/bump/type_ens.fypp index 743ff4b44..ec4f59c17 100644 --- a/src/saber/bump/type_ens.fypp +++ b/src/saber/bump/type_ens.fypp @@ -8,12 +8,11 @@ !---------------------------------------------------------------------- module type_ens -use atlas_module, only: atlas_fieldset -use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_max -use tools_const, only: zero,one,deg2rad,rad2deg,req +use fckit_mpi_module, only: fckit_mpi_sum +use tools_const, only: zero,one use tools_func, only: zss_count use tools_kinds, only: kind_real -use tools_netcdf, only: create_file,define_grp,define_dim,define_var,put_var,close_file +use tools_netcdf, only: create_file,define_dim,define_var,put_var,close_file use tools_qsort, only: qsort use type_fieldset, only: fieldset_type use type_geom, only: geom_type diff --git a/src/saber/bump/type_fieldset.fypp b/src/saber/bump/type_fieldset.fypp index 8bcb12baa..d93571f5a 100644 --- a/src/saber/bump/type_fieldset.fypp +++ b/src/saber/bump/type_fieldset.fypp @@ -13,7 +13,6 @@ use atlas_module, only: atlas_fieldset,atlas_field,atlas_functionspace,atlas_rea use fckit_mpi_module, only: fckit_mpi_sum use tools_atlas, only: field_to_array,field_from_array,get_atlas_field_size use tools_const, only: zero,one -use tools_func, only: zss_sum use tools_kinds, only: kind_real use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/type_geom.fypp b/src/saber/bump/type_geom.fypp index d9d8e448e..d6c8375f3 100644 --- a/src/saber/bump/type_geom.fypp +++ b/src/saber/bump/type_geom.fypp @@ -9,25 +9,24 @@ !---------------------------------------------------------------------- module type_geom -use atlas_module, only: atlas_config,atlas_connectivity,atlas_field,atlas_functionspace, & - & atlas_functionspace_nodecolumns,atlas_functionspace_pointcloud,atlas_functionspace_structuredcolumns,atlas_json,atlas_mesh, & +use atlas_module, only: atlas_config,atlas_field,atlas_functionspace, & + & atlas_functionspace_nodecolumns,atlas_functionspace_pointcloud,atlas_functionspace_structuredcolumns, & & atlas_mesh_nodes,atlas_projection,atlas_structuredgrid -use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_min,fckit_mpi_max,fckit_mpi_status +use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_min,fckit_mpi_max !$ use omp_lib use tools_atlas, only: get_grid,field_to_array,get_atlas_functionspace_size -use tools_const, only: zero,quarter,half,one,two,three,four,hundred,pi,req,deg2rad,rad2deg,reqkm +use tools_const, only: zero,half,one,two,three,four,hundred,pi,deg2rad,rad2deg,reqkm use tools_fit, only: work_grid -use tools_func, only: fletcher32,lonlatmod,grid_hash,independent_levels,sphere_dist,lonlat2xyz,xyz2lonlat,cart_dist, & - & vector_product,area,cx_to_cxa,cx_to_proc,cx_to_cxu,convert_l2i,convert_i2l,zss_maxval,zss_minval,zss_sum,zss_count -use tools_kinds, only: kind_int,kind_real,huge_real,huge_int +use tools_func, only: lonlatmod,grid_hash,independent_levels,sphere_dist,lonlat2xyz,xyz2lonlat,cart_dist, & + & vector_product,area,cx_to_cxa,cx_to_proc,cx_to_cxu,convert_l2i,convert_i2l,zss_minval,zss_sum,zss_count +use tools_kinds, only: kind_int,kind_real,huge_real use tools_qsort, only: qsort -use tools_repro, only: inf,sup,eq,infeq,supeq,indist,repro_th +use tools_repro, only: inf,sup,eq,supeq,indist,repro_th use type_bnda, only: bnda_type use type_com, only: com_type use type_fieldset, only: fieldset_type use type_hull, only: hull_type use type_io, only: io_type -use type_linop, only: linop_type use type_mesh, only: mesh_type use type_minim, only: minim_type use type_mpl, only: mpl_type diff --git a/src/saber/bump/type_gsi.fypp b/src/saber/bump/type_gsi.fypp index 35c9d99e7..43647e1e8 100644 --- a/src/saber/bump/type_gsi.fypp +++ b/src/saber/bump/type_gsi.fypp @@ -9,9 +9,9 @@ !---------------------------------------------------------------------- module type_gsi -use tools_const, only: zero,one,three,hundred,req,deg2rad +use tools_const, only: zero,one,three,hundred,deg2rad use tools_kinds, only: kind_real -use tools_netcdf, only: open_file,inquire_grp,get_att,inquire_dim_size,inquire_var,get_var,close_file +use tools_netcdf, only: open_file,inquire_dim_size,inquire_var,get_var,close_file use tools_repro, only: inf,infeq,sup,supeq,eq use type_geom, only: geom_type use type_mpl, only: mpl_type diff --git a/src/saber/bump/type_hdiag.fypp b/src/saber/bump/type_hdiag.fypp index 39298d992..febf4e763 100644 --- a/src/saber/bump/type_hdiag.fypp +++ b/src/saber/bump/type_hdiag.fypp @@ -9,12 +9,11 @@ module type_hdiag use fckit_mpi_module, only: fckit_mpi_sum -use tools_const, only: zero,half,one,rad2deg,req,ps +use tools_const, only: zero,one,req use tools_kinds, only: kind_real use tools_netcdf, only: create_file,define_grp,define_dim,define_var,put_var,close_file use type_avg, only: avg_type use type_diag, only: diag_type -use type_ens, only: ens_type use type_geom, only: geom_type use type_gsi, only: gsi_type use type_mom, only: mom_type @@ -22,7 +21,6 @@ use type_mpl, only: mpl_type use type_nam, only: nam_type @:use_probe() use type_samp, only: samp_type -use type_tree, only: tree_type implicit none diff --git a/src/saber/bump/type_hull.fypp b/src/saber/bump/type_hull.fypp index b04354e4a..867db9a4a 100644 --- a/src/saber/bump/type_hull.fypp +++ b/src/saber/bump/type_hull.fypp @@ -11,7 +11,7 @@ module type_hull use tools_const, only: zero,two,three,pi use tools_func, only: lonlat2xyz,xyz2lonlat,sphere_dist,vector_product use tools_kinds, only: kind_real -use tools_repro, only: inf,infeq,sup,repro_th +use tools_repro, only: infeq,sup,repro_th use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/type_io.fypp b/src/saber/bump/type_io.fypp index 6451336e4..91aef7ab3 100644 --- a/src/saber/bump/type_io.fypp +++ b/src/saber/bump/type_io.fypp @@ -9,11 +9,10 @@ !---------------------------------------------------------------------- module type_io -use fckit_mpi_module, only: fckit_mpi_comm,fckit_mpi_sum,fckit_mpi_status -use tools_const, only: pi,deg2rad,rad2deg,reqkm -use tools_func, only: cx_to_proc,cx_to_cxa,convert_i2l,convert_l2i +use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_status +use tools_func, only: cx_to_proc,cx_to_cxa use tools_kinds, only: kind_int,kind_real -use tools_netcdf, only: put_att,define_dim,check_dim,define_var,inquire_var,put_var,get_var +use tools_netcdf, only: put_var,get_var use tools_qsort, only: qsort use type_com, only: com_type use type_mpl, only: mpl_type diff --git a/src/saber/bump/type_linop.fypp b/src/saber/bump/type_linop.fypp index 04721cdde..57a41a88f 100644 --- a/src/saber/bump/type_linop.fypp +++ b/src/saber/bump/type_linop.fypp @@ -10,7 +10,7 @@ module type_linop use ieee_arithmetic !$ use omp_lib -use tools_const, only: zero,half,one,two,rad2deg,pi +use tools_const, only: zero,half,one,two,pi use tools_func, only: sphere_dist,zss_maxval,zss_minval use tools_gc99, only: fit_func use tools_kinds, only: kind_real,huge_real @@ -1488,7 +1488,7 @@ logical,intent(in),optional :: spherical !< Output gradient in spherical coordin ! Local variables integer :: jj,j,j_next,km_next,i_s,im integer,allocatable :: km(:),col(:) -real(kind_real) :: a,b,c,s,ar,dist,cx,sx,cy,sy,gamma,wgt,wgt_sum +real(kind_real) :: a,b,c,s,ar,cx,sx,cy,sy,gamma,wgt,wgt_sum real(kind_real),allocatable :: xp(:),yp(:),zp(:) real(kind_real),allocatable :: Svec_tmp(:,:),Svec_x(:),Svec_y(:),Svec_z(:) logical :: lspherical,valid diff --git a/src/saber/bump/type_mesh.fypp b/src/saber/bump/type_mesh.fypp index bec8294c8..80a7c1b57 100644 --- a/src/saber/bump/type_mesh.fypp +++ b/src/saber/bump/type_mesh.fypp @@ -9,12 +9,11 @@ module type_mesh !$ use omp_lib -use tools_const, only: zero,one,two,three,five,pi,req,rad2deg,reqkm +use tools_const, only: zero,one,two use tools_func, only: fletcher32,lonlatmod,rad2short,lonlat2xyz -use tools_kinds, only: kind_short,kind_long,kind_real,huge_real +use tools_kinds, only: kind_short,kind_long,kind_real use tools_qsort, only: qsort -use tools_repro, only: repro_th,inf -use tools_ssrfpack, only: aplyr,constr,fval,fval_op,gradl +use tools_ssrfpack, only: fval,fval_op,gradl use tools_stripack, only: trfind,trmesh use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/type_minim.fypp b/src/saber/bump/type_minim.fypp index a44e306a6..addca7d49 100644 --- a/src/saber/bump/type_minim.fypp +++ b/src/saber/bump/type_minim.fypp @@ -8,10 +8,10 @@ !---------------------------------------------------------------------- module type_minim -use tools_const, only: zero,hundredth,tenth,half,one,two,ten,hundred +use tools_const, only: zero,half,one,two,ten use tools_fit, only: diag_tensor,diag_iso,work_grid use tools_kinds, only: kind_real -use tools_repro, only: repro_th,eq,inf,infeq,sup +use tools_repro, only: repro_th,inf,infeq,sup use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/type_mom.fypp b/src/saber/bump/type_mom.fypp index 72c148cce..2bb2aef62 100644 --- a/src/saber/bump/type_mom.fypp +++ b/src/saber/bump/type_mom.fypp @@ -12,9 +12,8 @@ use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_status !$ use omp_lib use tools_const, only: zero,one,two,four use tools_kinds, only: kind_real -use tools_netcdf, only: create_file,open_file,define_grp,inquire_grp,define_dim,check_dim,inquire_dim_size,define_var, & +use tools_netcdf, only: create_file,open_file,define_grp,inquire_grp,define_dim,inquire_dim_size,define_var, & & inquire_var,put_var,get_var,close_file -use tools_repro, only: eq use type_ens, only: ens_type use type_geom, only: geom_type use type_mom_blk, only: mom_blk_type diff --git a/src/saber/bump/type_mpl.fypp b/src/saber/bump/type_mpl.fypp index a1dc3d527..a4bd3dafa 100644 --- a/src/saber/bump/type_mpl.fypp +++ b/src/saber/bump/type_mpl.fypp @@ -9,14 +9,12 @@ !---------------------------------------------------------------------- module type_mpl -use fckit_configuration_module, only: fckit_configuration use fckit_log_module, only: fckit_logchannel use fckit_mpi_module, only: fckit_mpi_comm,fckit_mpi_sum,fckit_mpi_status -use iso_c_binding, only: c_ptr,c_null_ptr,c_associated use iso_fortran_env, only: output_unit !$ use omp_lib -use tools_const, only: zero,one,ten,hundred -use tools_kinds, only: kind_int,kind_float,kind_double,kind_real +use tools_const, only: zero,hundred +use tools_kinds, only: kind_int,kind_real use tools_log, only: write_log use tools_qsort, only: qsort use type_msv, only: msv_type @@ -132,19 +130,6 @@ contains #:endif end type mpl_type -interface - -subroutine c_tools_log(channel,msg,newl,flush) bind(c,name='tools_log_f') - use,intrinsic :: iso_c_binding - implicit none - type(c_ptr),value :: channel - character(kind=c_char),dimension(*) :: msg - integer(c_int32_t),value :: newl - integer(c_int32_t),value :: flush -end subroutine c_tools_log - -end interface - private public :: mpl_type diff --git a/src/saber/bump/type_nam.fypp b/src/saber/bump/type_nam.fypp index 0769ab6c2..8862e9d91 100644 --- a/src/saber/bump/type_nam.fypp +++ b/src/saber/bump/type_nam.fypp @@ -10,10 +10,9 @@ module type_nam use fckit_configuration_module, only: fckit_configuration -use tools_const, only: zero,hundredth,half,one,ten,hundred,pi,req,deg2rad,rad2deg -use tools_kinds, only: kind_real,kind_int,huge_real -use tools_func, only: cholesky,convert_i2l,zss_minval -use tools_repro, only: eq +use tools_const, only: zero,half,one,pi,req,deg2rad +use tools_kinds, only: kind_real,kind_int +use tools_func, only: cholesky,zss_minval use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/type_nicas.fypp b/src/saber/bump/type_nicas.fypp index 76d2e6edf..2e5c68545 100644 --- a/src/saber/bump/type_nicas.fypp +++ b/src/saber/bump/type_nicas.fypp @@ -8,28 +8,21 @@ !---------------------------------------------------------------------- module type_nicas -use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_min,fckit_mpi_status -use tools_const, only: zero,one,two,ten,rad2deg,reqkm,pi -use tools_func, only: fletcher32,sphere_dist,zss_sum -use tools_kinds, only: kind_real,huge_real +use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_status +use tools_const, only: zero,one,two +use tools_func, only: zss_sum +use tools_kinds, only: kind_real use tools_netcdf, only: create_file,open_file,define_dim,inquire_dim,check_dim,define_var,put_var,close_file -use tools_qsort, only: qsort use tools_repro, only: repro_th use type_cmat, only: cmat_type -use type_com, only: com_type use type_cv, only: cv_type -use type_diag, only: diag_type use type_ens, only: ens_type use type_geom, only: geom_type -use type_hdiag, only: hdiag_type -use type_linop, only: linop_type -use type_mom, only: mom_type use type_mpl, only: mpl_type use type_nam, only: nam_type use type_nicas_blk, only: nicas_blk_type @:use_probe() use type_rng, only: rng_type -use type_samp, only: samp_type implicit none diff --git a/src/saber/bump/type_nicas_blk.fypp b/src/saber/bump/type_nicas_blk.fypp index 16ab46c44..b5adfdc98 100644 --- a/src/saber/bump/type_nicas_blk.fypp +++ b/src/saber/bump/type_nicas_blk.fypp @@ -8,29 +8,22 @@ !---------------------------------------------------------------------- module type_nicas_blk -use atlas_module, only: atlas_structuredgrid use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_min,fckit_mpi_max !$ use omp_lib -use tools_const, only: zero,hundredth,quarter,half,tenth,one,two,three,four,five,hundred,pi,req,reqkm,deg2rad,rad2deg +use tools_const, only: zero,one,two,hundred,reqkm,rad2deg use tools_fit, only: tensor_d2h -use tools_func, only: lonlatmod,sphere_dist,convert_i2l,convert_l2i,zss_maxval,zss_minval,zss_sum,zss_count -use tools_gc99, only: fit_func_sqrt +use tools_func, only: zss_maxval,zss_minval use tools_kinds, only: kind_real -use tools_netcdf, only: define_grp,inquire_grp,put_att,get_att,define_dim,inquire_dim,check_dim -use tools_qsort, only: qsort -use tools_repro, only: supeq,sup,inf,infeq,eq,indist,repro_th +use tools_netcdf, only: define_grp,inquire_grp,put_att,get_att,define_dim,check_dim +use tools_repro, only: repro_th use type_cmat_blk, only: cmat_blk_type -use type_com, only: com_type use type_cv_blk, only: cv_blk_type use type_geom, only: geom_type -use type_io, only: io_type -use type_linop, only: linop_type use type_mpl, only: mpl_type use type_nam, only: nam_type use type_nicas_cmp, only: nicas_cmp_type @:use_probe() use type_rng, only: rng_type -use type_tree, only: tree_type implicit none diff --git a/src/saber/bump/type_nicas_cmp.fypp b/src/saber/bump/type_nicas_cmp.fypp index c1532ce53..d47ea3453 100644 --- a/src/saber/bump/type_nicas_cmp.fypp +++ b/src/saber/bump/type_nicas_cmp.fypp @@ -12,15 +12,14 @@ use atlas_module, only: atlas_structuredgrid use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_min,fckit_mpi_max !$ use omp_lib use tools_atlas, only: get_grid -use tools_const, only: zero,quarter,half,tenth,one,two,three,four,five,hundred,pi,req,reqkm,deg2rad,rad2deg -use tools_fit, only: tensor_d2h -use tools_func, only: lonlatmod,sphere_dist,convert_i2l,convert_l2i,zss_maxval,zss_minval,zss_sum,zss_count +use tools_const, only: zero,half,one,two,three,four,pi,reqkm,deg2rad,rad2deg +use tools_func, only: lonlatmod,zss_maxval,zss_minval,zss_sum,zss_count use tools_gc99, only: fit_func_sqrt -use tools_kinds, only: kind_int,kind_real,kind_long,huge_int,huge_real -use tools_netcdf, only: define_grp,inquire_grp,put_att,get_att,define_dim,inquire_dim,inquire_dim_size,check_dim,define_var, & +use tools_kinds, only: kind_int,kind_real,huge_int,huge_real +use tools_netcdf, only: define_grp,inquire_grp,put_att,get_att,define_dim,inquire_dim,inquire_dim_size,define_var, & & inquire_var,put_var,get_var use tools_qsort, only: qsort -use tools_repro, only: supeq,sup,inf,infeq,eq,indist,repro_th +use tools_repro, only: sup,inf,infeq,repro_th use type_com, only: com_type use type_cv_cmp, only: cv_cmp_type use type_geom, only: geom_type diff --git a/src/saber/bump/type_samp.fypp b/src/saber/bump/type_samp.fypp index 657362565..78d35f197 100644 --- a/src/saber/bump/type_samp.fypp +++ b/src/saber/bump/type_samp.fypp @@ -12,9 +12,9 @@ use atlas_module, only: atlas_structuredgrid use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_min,fckit_mpi_max,fckit_mpi_status !$ use omp_lib use tools_atlas, only: get_grid -use tools_const, only: zero,quarter,half,one,four,hundred,pi,req,reqkm,deg2rad,rad2deg +use tools_const, only: zero,half,one,four,hundred,pi,reqkm,deg2rad,rad2deg use tools_func, only: lonlatmod,independent_levels,sphere_bearing,sphere_dist,cx_to_cxa,cx_to_proc,cx_to_cxu, & - & convert_i2l,convert_l2i,zss_maxval,zss_minval,zss_sum,zss_count + & zss_maxval,zss_minval,zss_sum,zss_count use tools_gc99, only: fit_func use tools_kinds, only: kind_int,kind_real use tools_netcdf, only: create_file,open_file,put_att,get_att,define_dim,inquire_dim,inquire_dim_size,define_var,inquire_var, & @@ -1162,7 +1162,6 @@ type(geom_type),intent(in) :: geom !< Geometry integer :: il0,jc3,jc4,ic1a,ic2u,ic2a,ic2b,jc1u,jc1d,jc1e,ic0a,j,nc1max integer :: ncid,nl0_id,nc1a_id,nc3_id,nc4_id,nc2a_id,nc2b_id,nc1max_id integer :: lon_id,lat_id,lon_local_id,lat_local_id,lon_vbal_id,lat_vbal_id -integer :: igmask_c0a(geom%nc0a,geom%nl0) real(kind_real),allocatable :: lon(:,:,:,:),lat(:,:,:,:) real(kind_real),allocatable :: lon_local(:,:,:),lat_local(:,:,:) real(kind_real),allocatable :: lon_vbal(:,:,:),lat_vbal(:,:,:) @@ -1219,15 +1218,6 @@ if (samp%sc1.and.nam%new_vbal) then end if ! Convert data -do il0=1,geom%nl0 - do ic0a=1,geom%nc0a - if (geom%gmask_c0a(ic0a,il0)) then - igmask_c0a(ic0a,il0) = 1 - else - igmask_c0a(ic0a,il0) = 0 - end if - end do -end do if (samp%sc3) then ! Allocation allocate(lon(samp%nc1a,nam%nc3,nam%nc4,geom%nl0)) diff --git a/src/saber/bump/type_tree.fypp b/src/saber/bump/type_tree.fypp index 4f54eb1c7..2ca751ee1 100644 --- a/src/saber/bump/type_tree.fypp +++ b/src/saber/bump/type_tree.fypp @@ -9,12 +9,11 @@ module type_tree use atlas_module, only: atlas_geometry,atlas_indexkdtree -use iso_c_binding, only: c_ptr -use tools_const, only: zero,half,two,pi,rad2deg -use tools_func, only: lonlat2xyz,sphere_dist +use tools_const, only: half,two,pi,rad2deg +use tools_func, only: sphere_dist use tools_kinds, only: kind_real use tools_qsort, only: qsort -use tools_repro, only: repro_ops,sup,indist +use tools_repro, only: repro_ops,indist use type_mpl, only: mpl_type @:use_probe() diff --git a/src/saber/bump/type_var.fypp b/src/saber/bump/type_var.fypp index 5b0889bdf..808fc40f3 100644 --- a/src/saber/bump/type_var.fypp +++ b/src/saber/bump/type_var.fypp @@ -10,10 +10,9 @@ module type_var use fckit_mpi_module, only: fckit_mpi_sum !$ use omp_lib -use tools_const, only: zero,half,one,two,three,four,six,rad2deg,reqkm -use tools_func, only: zss_sum,zss_count,global_average -use tools_kinds, only: kind_real,huge_real -use tools_netcdf, only: create_file,open_file,define_grp,inquire_grp,put_att,get_att,define_dim,inquire_var,define_var,close_file +use tools_const, only: zero,half,one,two,three,four,six,reqkm +use tools_func, only: zss_sum,global_average +use tools_kinds, only: kind_real use type_ens, only: ens_type use type_geom, only: geom_type use type_gsi, only: gsi_type @@ -523,7 +522,7 @@ integer :: iv,il0,il0i,iter,ipass,ipass_min(geom%nl0) real(kind_real) :: P9,P20,P21,diff,diff_abs_min(geom%nl0),m2avg real(kind_real) :: m2avg_init(geom%nl0,nam%nv),m2sq(geom%nl0),m4(geom%nl0),m2sqasy(geom%nl0) real(kind_real) :: rhflt(geom%nl0),drhflt(geom%nl0),m2prod(geom%nl0),m2_ini(geom%nc0a,geom%nl0),m2(geom%nc0a,geom%nl0) -logical :: dichotomy(geom%nl0),convergence(geom%nl0) +logical :: dichotomy(geom%nl0) type(nicas_blk_type) :: nicas_blk ! Set name @@ -585,7 +584,6 @@ else if (nam%var_niter>0) then ! Dichotomy initialization - convergence = .true. dichotomy = .false. rhflt = nam%var_rhflt(1:geom%nl0,iv) drhflt = rhflt @@ -638,14 +636,10 @@ else drhflt(il0) = half*drhflt(il0) rhflt(il0) = rhflt(il0)+drhflt(il0) else - convergence(il0) = .false. rhflt(il0) = rhflt(il0)+drhflt(il0) drhflt(il0) = two*drhflt(il0) end if else - ! Convergence - convergence(il0) = .true. - ! Change dichotomy status dichotomy(il0) = .true. diff --git a/src/saber/bump/type_vbal.fypp b/src/saber/bump/type_vbal.fypp index cd247bbec..1b0d439f9 100644 --- a/src/saber/bump/type_vbal.fypp +++ b/src/saber/bump/type_vbal.fypp @@ -10,12 +10,12 @@ module type_vbal use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_status !$ use omp_lib -use tools_const, only: zero,one,two,rad2deg +use tools_const, only: zero,one,two use tools_func, only: zss_maxval,zss_sum use tools_kinds, only: kind_real use tools_netcdf, only: create_file,open_file,define_grp,inquire_grp,define_dim,define_var,inquire_dim_size,inquire_var,put_var, & & get_var,close_file -use tools_repro, only: infeq,repro_th +use tools_repro, only: repro_th use type_ens, only: ens_type use type_geom, only: geom_type use type_gsi, only: gsi_type diff --git a/src/saber/bump/type_wind.fypp b/src/saber/bump/type_wind.fypp index b80233ce3..a91f7d378 100644 --- a/src/saber/bump/type_wind.fypp +++ b/src/saber/bump/type_wind.fypp @@ -10,9 +10,9 @@ module type_wind use fckit_mpi_module, only: fckit_mpi_status,fckit_mpi_sum,fckit_mpi_max !$ use omp_lib -use tools_const, only: zero,quarter,half,one,two,eight,ten,twelve,hundred,pi,req,rad2deg -use tools_func, only: sphere_dist,zss_count,zss_maxval -use tools_kinds, only: kind_real,huge_real +use tools_const, only: zero,one,two,hundred,req +use tools_func, only: zss_count,zss_maxval +use tools_kinds, only: kind_real use tools_netcdf, only: create_file,open_file,define_dim,define_var,inquire_dim_size,inquire_var,put_att,get_att,close_file use tools_qsort, only: qsort use type_com, only: com_type diff --git a/src/saber/spectralb/spectralb_covstats_interface.F90 b/src/saber/spectralb/spectralb_covstats_interface.F90 index 44142a28c..b651c2660 100644 --- a/src/saber/spectralb/spectralb_covstats_interface.F90 +++ b/src/saber/spectralb/spectralb_covstats_interface.F90 @@ -8,7 +8,7 @@ subroutine c_calculatingSqrtB(N, inBoutU) & & bind(c,name='calculatingSqrtB_f90') use fckit_log_module, only: fckit_log -use iso_c_binding, only : c_int, c_double, c_char +use iso_c_binding, only : c_int, c_double implicit none @@ -36,12 +36,12 @@ subroutine c_covSpectralBinsLevels(c_conf, & & bins, levels) & & bind(c,name='covSpectralBinsLevels_f90') -use iso_c_binding, only : c_ptr, c_int, c_float, c_char +use iso_c_binding, only : c_ptr, c_int, c_char use fckit_configuration_module, only: fckit_configuration use netcdf, only: nf90_max_name use kinds use string_f_c_mod -use mo_netcdf_mod, only : cvt_nc_read_field_from_file, cvt_nc_err_rpt +use mo_netcdf_mod, only : cvt_nc_read_field_from_file implicit none @@ -96,12 +96,12 @@ subroutine c_covSpectralBins(c_conf, & & bins) & & bind(c,name='covSpectralBins_f90') -use iso_c_binding, only : c_ptr, c_int, c_float, c_char +use iso_c_binding, only : c_ptr, c_int, c_char use fckit_configuration_module, only: fckit_configuration use netcdf, only: nf90_max_name use kinds use string_f_c_mod -use mo_netcdf_mod, only : cvt_nc_read_field_from_file, cvt_nc_err_rpt +use mo_netcdf_mod, only : cvt_nc_read_field_from_file implicit none @@ -153,7 +153,7 @@ subroutine c_covSpectralUMatrix(c_conf, & use netcdf, only: nf90_max_name use kinds use string_f_c_mod -use mo_netcdf_mod, only : cvt_nc_read_field_from_file, cvt_nc_err_rpt +use mo_netcdf_mod, only : cvt_nc_read_field_from_file implicit none diff --git a/src/saber/vader/movader_covstats_interface.F90 b/src/saber/vader/movader_covstats_interface.F90 index 627fb6eda..0df8aafa5 100644 --- a/src/saber/vader/movader_covstats_interface.F90 +++ b/src/saber/vader/movader_covstats_interface.F90 @@ -10,8 +10,8 @@ subroutine c_covRegressionMatrices(filename_length, & & model_level, bins, values_size, values) & & bind(c,name='covRegressionMatrices_f90') -use iso_c_binding, only : c_ptr, c_int, c_float, c_char -use mo_netcdf_mod, only : cvt_nc_read_field_from_file, cvt_nc_err_rpt +use iso_c_binding, only : c_int, c_float, c_char +use mo_netcdf_mod, only : cvt_nc_read_field_from_file use netcdf, only: nf90_max_name use string_f_c_mod @@ -27,8 +27,6 @@ subroutine c_covRegressionMatrices(filename_length, & character(len=nf90_max_name) :: covariance_file character(len=nf90_max_name) :: short_name -character(len=:), allocatable :: str - integer(kind=c_int) :: start_index(3) integer(kind=c_int) :: final_index(3) real(kind=c_float), allocatable :: Field3D(:,:,:) @@ -67,9 +65,9 @@ subroutine c_covRegressionWeights(filename_length, c_filename, & & startVec, lenVec, covLatitudesVec, regressionWeights1D) & & bind(c,name='covRegressionWeights_f90') -use iso_c_binding, only: c_ptr, c_int, c_float, c_char +use iso_c_binding, only: c_int, c_float, c_char use mo_cvtcoord_mod, only: cvt_coordinate_type, cvt_initialiseadjustordealloccoord, cvt_create3dcoordinate -use mo_netcdf_mod, only: cvt_nc_read_field_from_file, cvt_nc_err_rpt +use mo_netcdf_mod, only: cvt_nc_read_field_from_file use netcdf, only: nf90_max_name use string_f_c_mod @@ -88,8 +86,6 @@ subroutine c_covRegressionWeights(filename_length, c_filename, & character(len=nf90_max_name) :: covariance_file character(len=nf90_max_name) :: short_name -character(len=:), allocatable :: str - integer(kind=c_int) :: start_index(3) integer(kind=c_int) :: final_index(3) real(kind=c_float), allocatable :: Field3D(:,:,:) @@ -102,8 +98,6 @@ subroutine c_covRegressionWeights(filename_length, c_filename, & integer :: i,j,k,n ! loop variables integer :: tally -integer :: sh(3) - ! read filename for config covariance_file = "" short_name = "" @@ -168,7 +162,7 @@ subroutine c_covMuStats(filename_length, & & modelLevels, muBins, sizeVec, mustats) & & bind(c,name='covMuStats_f90') -use iso_c_binding, only: c_ptr, c_int, c_float, c_char +use iso_c_binding, only: c_int, c_float, c_char use mo_netcdf_mod, only : cvt_nc_read_field_from_file use netcdf, only: nf90_max_name use string_f_c_mod From 1f5178869238db5dab6c81c410c574f114bfe140 Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Wed, 22 Oct 2025 21:14:45 +0200 Subject: [PATCH 121/199] QUENCH cleaning (#1103) * quench cleaning * Revert land/sea mask * Cleaning + fix Fields norm and update refs * Fix ref * Some more cleaning * Update ref * Split refs for error_covariance_training_stddev_1 and error_covariance_training_stddev_2 * Fix FastLAM outputs --------- Co-authored-by: Nate Crossette Co-authored-by: Marek Wlasak --- CMakeLists.txt | 6 +- quench/src/CMakeLists.txt | 14 +- quench/src/Covariance.h | 10 +- quench/src/Fields.cc | 404 +++++++------- quench/src/Fields.h | 32 +- quench/src/FieldsIO/FieldsIOBase.h | 32 +- quench/src/FieldsIO/FieldsIODefault.cc | 27 +- quench/src/FieldsIO/FieldsIODefault.h | 19 +- quench/src/FieldsIO/FieldsIOGmsh.cc | 11 +- quench/src/FieldsIO/FieldsIOGmsh.h | 14 +- quench/src/Geometry.cc | 187 ++++--- quench/src/Geometry.h | 155 +----- quench/src/GeometryParameters.h | 156 ++++++ quench/src/Increment.cc | 17 +- quench/src/Increment.h | 32 +- quench/src/Interpolation.cc | 48 +- quench/src/Interpolation.h | 33 +- quench/src/LinearVariableChange.cc | 6 + quench/src/LinearVariableChange.h | 24 +- quench/src/ModelData.h | 5 +- quench/src/State.cc | 10 +- quench/src/State.h | 48 +- quench/src/Traits.h | 27 +- quench/src/TraitsFwd.h | 38 -- quench/src/VariableChange.cc | 3 + quench/src/VariableChange.h | 6 +- saber-import.cmake.in | 5 - src/saber/fastlam/FastLAM.cc | 58 +- .../dirac_bifourier_vordivtouv_1.yaml | 3 + .../dirac_bifourier_vordivtouv_3.yaml | 7 + .../error_covariance_training_stddev_1.yaml | 2 +- .../error_covariance_training_stddev_2.yaml | 2 +- test/testref/dirac_bifourier_vordivtouv_3.ref | 2 +- test/testref/dirac_bump_1.ref | 76 +-- test/testref/dirac_bump_2.ref | 68 +-- test/testref/dirac_bump_3.ref | 36 +- test/testref/dirac_bump_4.ref | 14 +- test/testref/dirac_bump_5.ref | 10 +- test/testref/dirac_bump_6.ref | 28 +- test/testref/dirac_bump_7.ref | 22 +- test/testref/dirac_bump_8.ref | 8 +- test/testref/dirac_bump_9.ref | 20 +- test/testref/dirac_ens_noloc_4d.ref | 12 +- test/testref/dirac_fastlam-fftw_1.ref | 22 +- test/testref/dirac_fastlam-fftw_2.ref | 12 +- test/testref/dirac_fastlam_1.ref | 6 +- test/testref/dirac_fastlam_2.ref | 14 +- test/testref/dirac_fastlam_3.ref | 18 +- test/testref/dirac_fastlam_4.ref | 12 +- test/testref/dirac_fastlam_5.ref | 12 +- test/testref/dirac_fastlam_6.ref | 12 +- test/testref/dirac_fastlam_8.ref | 18 +- test/testref/dirac_fastlam_9.ref | 12 +- test/testref/dirac_gsi_geos_global.ref | 8 +- test/testref/dirac_gsi_geos_global_opt_1.ref | 8 +- test/testref/dirac_gsi_geos_global_opt_2.ref | 8 +- test/testref/dirac_gsi_geos_global_opt_3.ref | 8 +- test/testref/dirac_oops_ens_noloc_4d.ref | 12 +- test/testref/dirac_shadowlevels_1.ref | 12 +- test/testref/dirac_shadowlevels_2.ref | 14 +- test/testref/dirac_shadowlevels_3.ref | 10 +- test/testref/dirac_shadowlevels_4.ref | 12 +- test/testref/dirac_shadowlevels_5.ref | 10 +- test/testref/dirac_stddev_1.ref | 8 +- test/testref/dirac_stddev_2.ref | 10 +- test/testref/dirac_stddev_3.ref | 8 +- test/testref/dirac_stddev_4.ref | 8 +- test/testref/dirac_vader.ref | 16 +- ...covariance_training_bump_hdiag-nicas_1.ref | 32 +- ...covariance_training_bump_hdiag-nicas_2.ref | 12 +- ...covariance_training_bump_hdiag-nicas_3.ref | 12 +- ...covariance_training_bump_hdiag-nicas_4.ref | 18 +- ...error_covariance_training_bump_hdiag_1.ref | 24 +- ...rror_covariance_training_bump_hdiag_10.ref | 6 +- ...rror_covariance_training_bump_hdiag_11.ref | 4 +- ...rror_covariance_training_bump_hdiag_12.ref | 4 +- ...rror_covariance_training_bump_hdiag_13.ref | 2 +- ...error_covariance_training_bump_hdiag_2.ref | 24 +- ...error_covariance_training_bump_hdiag_3.ref | 22 +- ...error_covariance_training_bump_hdiag_4.ref | 4 +- ...error_covariance_training_bump_hdiag_5.ref | 12 +- ...error_covariance_training_bump_hdiag_6.ref | 12 +- ...error_covariance_training_bump_hdiag_7.ref | 12 +- ...error_covariance_training_bump_hdiag_8.ref | 8 +- ...error_covariance_training_bump_hdiag_9.ref | 8 +- ...error_covariance_training_bump_nicas_1.ref | 4 +- ...rror_covariance_training_bump_nicas_10.ref | 4 +- ...error_covariance_training_bump_nicas_2.ref | 4 +- ...error_covariance_training_bump_nicas_3.ref | 10 +- ...error_covariance_training_bump_nicas_4.ref | 12 +- ...error_covariance_training_bump_nicas_6.ref | 20 +- ...error_covariance_training_bump_nicas_8.ref | 4 +- ...error_covariance_training_bump_nicas_9.ref | 4 +- ...rror_covariance_training_bump_stddev_1.ref | 6 +- ...rror_covariance_training_bump_stddev_2.ref | 2 +- ...rror_covariance_training_bump_stddev_3.ref | 2 +- ...rror_covariance_training_bump_stddev_4.ref | 2 +- ...rror_covariance_training_bump_stddev_5.ref | 6 +- ...rror_covariance_training_bump_stddev_6.ref | 2 +- .../error_covariance_training_bump_vbal_1.ref | 20 +- .../error_covariance_training_stddev_2.ref | 1 + .../testref/optimization_bump_hdiag_gsi_2.ref | 2 +- .../randomization_bump_nicas_L10L10.ref | 100 ++-- .../randomization_bump_nicas_L10L2.ref | 500 +++++++++--------- .../randomization_bump_nicas_L10L2T18.ref | 500 +++++++++--------- .../randomization_bump_nicas_L10L2_static.ref | 100 ++-- .../randomization_bump_nicas_L12L2.ref | 200 +++---- .../randomization_increment_variables.ref | 4 +- .../testref/randomization_sqrtspectralb_3.ref | 444 ++++++++-------- .../testref/randomization_sqrtspectralb_4.ref | 128 ++--- 110 files changed, 2214 insertions(+), 2110 deletions(-) create mode 100644 quench/src/GeometryParameters.h delete mode 100644 quench/src/TraitsFwd.h create mode 100644 test/testref/error_covariance_training_stddev_2.ref diff --git a/CMakeLists.txt b/CMakeLists.txt index 582aee873..10f0c66a5 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -31,9 +31,11 @@ include( ${PROJECT_NAME}_compiler_flags ) ## Dependencies # Required -find_package( jedicmake REQUIRED ) # Prefer find modules from jedi-cmake +if( ENABLE_QUENCH ) + find_package( jedicmake REQUIRED ) # Prefer find modules from jedi-cmake +endif() if(OPENMP) - find_package( OpenMP REQUIRED COMPONENTS CXX Fortran ) + find_package( OpenMP REQUIRED COMPONENTS CXX Fortran ) endif() find_package( MPI REQUIRED COMPONENTS Fortran ) find_package( NetCDF REQUIRED COMPONENTS C Fortran ) diff --git a/quench/src/CMakeLists.txt b/quench/src/CMakeLists.txt index 1fc424e50..6677759bb 100644 --- a/quench/src/CMakeLists.txt +++ b/quench/src/CMakeLists.txt @@ -4,10 +4,6 @@ # This software is licensed under the terms of the Apache Licence Version 2.0 # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. -message( STATUS "Found quench I/O formats:" ) -message( STATUS "- Default (NetCDF)" ) -message( STATUS "- GMSH" ) - # Common sources, not obs-related list( APPEND quench_src_files @@ -16,12 +12,13 @@ Fields.cc Fields.h Geometry.cc Geometry.h +GeometryParameters.h Increment.cc Increment.h Interpolation.cc Interpolation.h -LinearVariableChange.h LinearVariableChange.cc +LinearVariableChange.h LinearVariableChangeParameters.h ModelData.h State.cc @@ -38,6 +35,10 @@ FieldsIO/FieldsIOGmsh.h ) +message( STATUS "Found quench I/O formats:" ) +message( STATUS "- Default (NetCDF)" ) +message( STATUS "- GMSH" ) + ecbuild_add_library( TARGET quench SOURCES ${quench_src_files} PUBLIC_LIBS oops saber @@ -46,9 +47,6 @@ ecbuild_add_library( TARGET quench LINKER_LANGUAGE CXX ) target_link_libraries( quench PUBLIC NetCDF::NetCDF_Fortran NetCDF::NetCDF_C ) -if( eccodes_FOUND ) - target_link_libraries( quench PUBLIC eccodes ) -endif() #Configure include directory layout for build-tree to match install-tree set(QUENCH_BUILD_DIR_INCLUDE_PATH ${CMAKE_BINARY_DIR}/${PROJECT_NAME}/include) diff --git a/quench/src/Covariance.h b/quench/src/Covariance.h index 014d09fd2..eb995371d 100644 --- a/quench/src/Covariance.h +++ b/quench/src/Covariance.h @@ -12,16 +12,22 @@ #include #include -#include "eckit/config/Configuration.h" #include "eckit/exception/Exceptions.h" #include "oops/util/ObjectCounter.h" #include "oops/util/Printable.h" -#include "src/Increment.h" +namespace eckit { + class Configuration; +} + +namespace oops { + class Variables; +} namespace quench { class Geometry; + class Increment; class State; // ----------------------------------------------------------------------------- diff --git a/quench/src/Fields.cc b/quench/src/Fields.cc index 3e4ab3545..b66c19c07 100644 --- a/quench/src/Fields.cc +++ b/quench/src/Fields.cc @@ -14,10 +14,12 @@ #include #include #include +#include #include #include "atlas/field.h" #include "atlas/functionspace.h" +#include "atlas/util/Config.h" #include "atlas/util/KDTree.h" #include "atlas/util/Point.h" @@ -25,6 +27,7 @@ #include "eckit/exception/Exceptions.h" #include "eckit/mpi/Comm.h" +#include "oops/util/ConfigFunctions.h" #include "oops/util/FieldSetHelpers.h" #include "oops/util/FieldSetOperations.h" #include "oops/util/FloatCompare.h" @@ -38,21 +41,11 @@ namespace quench { // ----------------------------------------------------------------------------- -static std::vector interpolationsVector; - -// ----------------------------------------------------------------------------- - -std::vector& Fields::interpolations() { - return interpolationsVector; -} - -// ----------------------------------------------------------------------------- - Fields::Fields(const Geometry & geom, const oops::Variables & vars, const util::DateTime & time, const bool & isState) - : geom_(new Geometry(geom)), vars_(vars), time_(time), isState_(isState) { + : geom_(geom), vars_(vars), time_(time), isState_(isState) { oops::Log::trace() << classname() << "::Fields starting" << std::endl; // Reset ATLAS fieldset @@ -60,10 +53,10 @@ Fields::Fields(const Geometry & geom, for (auto & var : vars_) { // Set number of levels - var.setLevels(geom_->levels(var.name())); + var.setLevels(geom_.levels(var.name())); // Create field - atlas::Field field = geom_->functionSpace().createField( + atlas::Field field = geom_.functionSpace().createField( atlas::option::name(var.name()) | atlas::option::levels(var.getLevels())); fset_.add(field); } @@ -74,7 +67,7 @@ Fields::Fields(const Geometry & geom, } // Set fields to zero - this->zero(); + zero(); oops::Log::trace() << classname() << "::Fields done" << std::endl; } @@ -83,7 +76,7 @@ Fields::Fields(const Geometry & geom, Fields::Fields(const Fields & other, const Geometry & geom) - : geom_(new Geometry(geom)), vars_(other.vars_), time_(other.time_), isState_(other.isState_) { + : geom_(geom), vars_(other.vars_), time_(other.time_), isState_(other.isState_) { oops::Log::trace() << classname() << "::Fields starting" << std::endl; // Reset ATLAS fieldset @@ -91,22 +84,22 @@ Fields::Fields(const Fields & other, // Check number of levels for (const auto & var : vars_) { - if (geom_->levels(var.name()) != geom.levels(var.name())) { + if (geom_.levels(var.name()) != geom_.levels(var.name())) { throw eckit::Exception("Different number of levels for variable " + var.name() + ", cannot interpolate", Here()); } } - if (geom_->grid() == other.geom_->grid() && geom_->halo() == other.geom_->halo()) { + if (geom_.grid() == other.geom_.grid() && geom_.halo() == other.geom_.halo()) { // Copy fieldset fset_ = util::copyFieldSet(other.fset_); } else { // Setup interpolation - const auto & interpolation = setupGridInterpolation(*other.geom_); + const Interpolation & interpolation = other.geom_.getInterpolation(geom_); // Create fieldset for (const auto & var : vars_) { - atlas::Field field = geom_->functionSpace().createField( + atlas::Field field = geom_.functionSpace().createField( atlas::option::name(var.name()) | atlas::option::levels(var.getLevels())); fset_.add(field); } @@ -123,7 +116,7 @@ Fields::Fields(const Fields & other, atlas::FieldSet fset = util::copyFieldSet(other.fset_); // Horizontal interpolation - interpolation->execute(fset, fset_); + interpolation.execute(fset, fset_); } oops::Log::trace() << classname() << "::Fields done" << std::endl; @@ -141,7 +134,7 @@ Fields::Fields(const Fields & other, for (const auto & var : vars_) { // Create field - atlas::Field field = geom_->functionSpace().createField( + atlas::Field field = geom_.functionSpace().createField( atlas::option::name(var.name()) | atlas::option::levels(var.getLevels())); fset_.add(field); } @@ -155,7 +148,7 @@ Fields::Fields(const Fields & other, } // Set fields to zero - this->zero(); + zero(); // Copy if necessary if (copy) { @@ -189,7 +182,7 @@ Fields::Fields(const Fields & other) // Create fields and copy data for (const auto & var : vars_) { // Create field - atlas::Field field = geom_->functionSpace().createField( + atlas::Field field = geom_.functionSpace().createField( atlas::option::name(var.name()) | atlas::option::levels(var.getLevels())); const atlas::Field fieldOther = other.fset_[var.name()]; if (field.rank() == 2) { @@ -239,8 +232,8 @@ void Fields::constantValue(const double & value) { for (const auto & var : vars_) { atlas::Field field = fset_[var.name()]; - const std::string gmaskName = "gmask_" + std::to_string(geom_->groupIndex(var.name())); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); + const std::string gmaskName = "gmask_" + std::to_string(geom_.groupIndex(var.name())); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); if (field.rank() == 2) { auto view = atlas::array::make_view(field); view.assign(0.0); @@ -263,8 +256,8 @@ void Fields::constantValue(const std::vector & profile) { for (const auto & var : vars_) { atlas::Field field = fset_[var.name()]; - const std::string gmaskName = "gmask_" + std::to_string(geom_->groupIndex(var.name())); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); + const std::string gmaskName = "gmask_" + std::to_string(geom_.groupIndex(var.name())); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); if (field.rank() == 2) { ASSERT(field.shape(1) == static_cast(profile.size())); auto view = atlas::array::make_view(field); @@ -291,8 +284,8 @@ void Fields::constantValue(const eckit::Configuration & config) { for (const auto & var : vars_) { if (std::find(vars.begin(), vars.end(), var.name()) != vars.end()) { atlas::Field field = fset_[var.name()]; - const std::string gmaskName = "gmask_" + std::to_string(geom_->groupIndex(var.name())); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); + const std::string gmaskName = "gmask_" + std::to_string(geom_.groupIndex(var.name())); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); if (field.rank() == 2) { auto view = atlas::array::make_view(field); view.assign(0.0); @@ -333,6 +326,7 @@ Fields & Fields::operator=(const Fields & rhs) { } } time_ = rhs.time_; + isState_ = rhs.isState_; oops::Log::trace() << classname() << "::operator= end" << std::endl; return *this; @@ -348,12 +342,12 @@ Fields & Fields::operator+=(const Fields & rhs) { // Right-hand side fieldset atlas::FieldSet fsetRhs; - if (geom_->grid() == rhs.geom_->grid() && geom_->halo() == rhs.geom_->halo()) { + if (geom_.grid() == rhs.geom_.grid() && geom_.halo() == rhs.geom_.halo()) { // Same geometry fsetRhs = util::shareFields(rhs.fset_); } else { // Interpolate - const Fields rhsInterp(rhs, *geom_); + const Fields rhsInterp(rhs, geom_); // Copy fieldset fsetRhs = util::copyFieldSet(rhsInterp.fset_); @@ -362,8 +356,8 @@ Fields & Fields::operator+=(const Fields & rhs) { for (const auto & var : vars_) { atlas::Field field = fset_[var.name()]; if (fsetRhs.has(var.name())) { - const std::string gmaskName = "gmask_" + std::to_string(geom_->groupIndex(var.name())); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); + const std::string gmaskName = "gmask_" + std::to_string(geom_.groupIndex(var.name())); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); const atlas::Field fieldRhs = fsetRhs[var.name()]; if (field.rank() == 2) { auto view = atlas::array::make_view(field); @@ -399,8 +393,8 @@ Fields & Fields::operator-=(const Fields & rhs) { for (const auto & var : vars_) { atlas::Field field = fset_[var.name()]; if (rhs.fset_.has(var.name())) { - const std::string gmaskName = "gmask_" + std::to_string(geom_->groupIndex(var.name())); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); + const std::string gmaskName = "gmask_" + std::to_string(geom_.groupIndex(var.name())); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); const atlas::Field fieldRhs = rhs.fset_[var.name()]; if (field.rank() == 2) { auto view = atlas::array::make_view(field); @@ -432,8 +426,8 @@ Fields & Fields::operator*=(const double & zz) { for (const auto & var : vars_) { atlas::Field field = fset_[var.name()]; - const std::string gmaskName = "gmask_" + std::to_string(geom_->groupIndex(var.name())); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); + const std::string gmaskName = "gmask_" + std::to_string(geom_.groupIndex(var.name())); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); if (field.rank() == 2) { auto view = atlas::array::make_view(field); for (atlas::idx_t jnode = 0; jnode < field.shape(0); ++jnode) { @@ -461,8 +455,8 @@ void Fields::axpy(const double & zz, for (const auto & var : vars_) { atlas::Field field = fset_[var.name()]; - const std::string gmaskName = "gmask_" + std::to_string(geom_->groupIndex(var.name())); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); + const std::string gmaskName = "gmask_" + std::to_string(geom_.groupIndex(var.name())); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); const atlas::Field fieldRhs = rhs.fset_[var.name()]; if (field.rank() == 2) { auto view = atlas::array::make_view(field); @@ -490,11 +484,11 @@ double Fields::dot_product_with(const Fields & fld2) const { ASSERT(checkFieldsCompatible(fld2)); double zz = 0; - const auto ownedView = atlas::array::make_view(geom_->fields().field("owned")); + const auto ownedView = atlas::array::make_view(geom_.fields()["owned"]); for (const auto & var : vars_) { const atlas::Field field1 = fset_[var.name()]; - const std::string gmaskName = "gmask_" + std::to_string(geom_->groupIndex(var.name())); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); + const std::string gmaskName = "gmask_" + std::to_string(geom_.groupIndex(var.name())); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); const atlas::Field field2 = fld2.fset_[var.name()]; if (field1.rank() == 2) { const auto view1 = atlas::array::make_view(field1); @@ -508,7 +502,7 @@ double Fields::dot_product_with(const Fields & fld2) const { } } } - geom_->getComm().allReduceInPlace(zz, eckit::mpi::sum()); + geom_.getComm().allReduceInPlace(zz, eckit::mpi::sum()); oops::Log::trace() << classname() << "::dot_product_with done" << std::endl; return zz; } @@ -523,8 +517,8 @@ void Fields::schur_product_with(const Fields & fld2) { for (const auto & var : vars_) { atlas::Field field = fset_[var.name()]; - const std::string gmaskName = "gmask_" + std::to_string(geom_->groupIndex(var.name())); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); + const std::string gmaskName = "gmask_" + std::to_string(geom_.groupIndex(var.name())); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); const atlas::Field field2 = fld2.fset_[var.name()]; if (field.rank() == 2) { auto view = atlas::array::make_view(field); @@ -545,20 +539,20 @@ void Fields::schur_product_with(const Fields & fld2) { // ----------------------------------------------------------------------------- -void Fields::random() { +void Fields::random(const int & seed) { oops::Log::trace() << classname() << "::random starting" << std::endl; - for (size_t groupIndex = 0; groupIndex < geom_->groups(); ++groupIndex) { - // Mask and ghost points fields + for (size_t groupIndex = 0; groupIndex < geom_.groups(); ++groupIndex) { + // Mask and owned points fields const std::string gmaskName = "gmask_" + std::to_string(groupIndex); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); - const auto ghostView = atlas::array::make_view(geom_->functionSpace().ghost()); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); + const auto ownedView = atlas::array::make_view(geom_.fields()["owned"]); // Total size size_t n = 0; oops::Variables groupVars; for (const auto & var : vars_) { - if (geom_->groupIndex(var.name()) == groupIndex) { + if (geom_.groupIndex(var.name()) == groupIndex) { groupVars.push_back(var); } } @@ -567,65 +561,66 @@ void Fields::random() { if (field.rank() == 2) { for (atlas::idx_t jnode = 0; jnode < field.shape(0); ++jnode) { for (atlas::idx_t jlevel = 0; jlevel < field.shape(1); ++jlevel) { - if (gmaskView(jnode, jlevel) == 1 && ghostView(jnode) == 0) ++n; + if (gmaskView(jnode, jlevel) == 1 && ownedView(jnode, 0) == 1) ++n; } } } } - geom_->getComm().allReduceInPlace(n, eckit::mpi::sum()); + geom_.getComm().allReduceInPlace(n, eckit::mpi::sum()); // Local masks atlas::FieldSet localMasks; - localMasks.add(geom_->fields()[gmaskName]); - localMasks.add(geom_->functionSpace().ghost()); + localMasks.add(geom_.fields()[gmaskName]); + localMasks.add(geom_.fields()["owned"]); // Global masks atlas::FieldSet globalMasks; - atlas::Field gmaskGlobal = geom_->functionSpace().createField( - atlas::option::name(gmaskName) | atlas::option::levels(geom_->levels(groupIndex)) + atlas::Field gmaskGlobal = geom_.functionSpace().createField( + atlas::option::name(gmaskName) | atlas::option::levels(geom_.levels(groupIndex)) | atlas::option::global()); globalMasks.add(gmaskGlobal); - atlas::Field ghostGlobal = geom_->functionSpace().createField(atlas::option::name("ghost") - | atlas::option::global()); - globalMasks.add(ghostGlobal); + atlas::Field ownedGlobal = geom_.functionSpace().createField( + atlas::option::name("owned") | atlas::option::levels(1) + | atlas::option::global()); + globalMasks.add(ownedGlobal); // Global data atlas::FieldSet globalData; for (const auto & var : groupVars) { - atlas::Field field = geom_->functionSpace().createField( + atlas::Field field = geom_.functionSpace().createField( atlas::option::name(var.name()) - | atlas::option::levels(geom_->levels(var.name())) | atlas::option::global()); + | atlas::option::levels(geom_.levels(var.name())) | atlas::option::global()); globalData.add(field); } // Gather masks on main processor - if (geom_->functionSpace().type() == "StructuredColumns") { + if (geom_.functionSpace().type() == "StructuredColumns") { // StructuredColumns - atlas::functionspace::StructuredColumns fs(geom_->functionSpace()); + atlas::functionspace::StructuredColumns fs(geom_.functionSpace()); fs.gather(localMasks, globalMasks); - } else if (geom_->functionSpace().type() == "NodeColumns") { + } else if (geom_.functionSpace().type() == "NodeColumns") { // NodeColumns - if (geom_->grid().name().compare(0, 2, std::string{"CS"}) == 0) { + if (geom_.grid().name().compare(0, 2, std::string{"CS"}) == 0) { // CubedSphere - atlas::functionspace::CubedSphereNodeColumns fs(geom_->functionSpace()); + atlas::functionspace::CubedSphereNodeColumns fs(geom_.functionSpace()); fs.gather(localMasks, globalMasks); } else { // Other NodeColumns - atlas::functionspace::NodeColumns fs(geom_->functionSpace()); + atlas::functionspace::NodeColumns fs(geom_.functionSpace()); fs.gather(localMasks, globalMasks); } } else { - throw eckit::NotImplemented(geom_->functionSpace().type() + + throw eckit::NotImplemented(geom_.functionSpace().type() + " function space not supported yet", Here()); } - if (geom_->getComm().rank() == 0) { + if (geom_.getComm().rank() == 0) { // Random vector - util::NormalDistribution rand_vec(n, 0.0, 1.0, 1); + util::NormalDistribution rand_vec(n, 0.0, 1.0, seed); // Copy random values n = 0; - const auto ghostView = atlas::array::make_view(globalMasks["ghost"]); + const auto ownedView = atlas::array::make_view(globalMasks["owned"]); for (const auto & var : groupVars) { atlas::Field field = globalData[var.name()]; const std::string gmaskName = "gmask_" + std::to_string(groupIndex); @@ -634,7 +629,7 @@ void Fields::random() { auto view = atlas::array::make_view(field); for (atlas::idx_t jnode = 0; jnode < field.shape(0); ++jnode) { for (atlas::idx_t jlevel = 0; jlevel < field.shape(1); ++jlevel) { - if (gmaskView(jnode, jlevel) == 1 && ghostView(jnode) == 0) { + if (gmaskView(jnode, jlevel) == 1 && ownedView(jnode, 0) == 1) { view(jnode, jlevel) = rand_vec[n]; ++n; } @@ -647,29 +642,29 @@ void Fields::random() { // Local data atlas::FieldSet localData; for (const auto & var : groupVars) { - atlas::Field field = geom_->functionSpace().createField( + atlas::Field field = geom_.functionSpace().createField( atlas::option::name(var.name()) | atlas::option::levels(var.getLevels())); localData.add(field); } // Scatter data from main processor - if (geom_->functionSpace().type() == "StructuredColumns") { + if (geom_.functionSpace().type() == "StructuredColumns") { // StructuredColumns - atlas::functionspace::StructuredColumns fs(geom_->functionSpace()); + atlas::functionspace::StructuredColumns fs(geom_.functionSpace()); fs.scatter(globalData, localData); - } else if (geom_->functionSpace().type() == "NodeColumns") { + } else if (geom_.functionSpace().type() == "NodeColumns") { // NodeColumns - if (geom_->grid().name().compare(0, 2, std::string{"CS"}) == 0) { + if (geom_.grid().name().compare(0, 2, std::string{"CS"}) == 0) { // CubedSphere - atlas::functionspace::CubedSphereNodeColumns fs(geom_->functionSpace()); + atlas::functionspace::CubedSphereNodeColumns fs(geom_.functionSpace()); fs.scatter(globalData, localData); } else { // Other NodeColumns - atlas::functionspace::NodeColumns fs(geom_->functionSpace()); + atlas::functionspace::NodeColumns fs(geom_.functionSpace()); fs.scatter(globalData, localData); } } else { - throw eckit::NotImplemented(geom_->functionSpace().type() + + throw eckit::NotImplemented(geom_.functionSpace().type() + " function space not supported yet", Here()); } @@ -707,7 +702,7 @@ void Fields::dirac(const eckit::Configuration & config) { if (config.has("file")) { // Input file const eckit::LocalConfiguration file(config, "file"); - this->read(file); + read(file); } else { // Get dirac specifications std::vector lon = config.getDoubleVector("lon"); @@ -732,10 +727,11 @@ void Fields::dirac(const eckit::Configuration & config) { if (vertCoord.size() != lon.size()) throw eckit::UserError( "Inconsistent dirac specification size", Here()); const double vertCoordTol = config.getDouble("vertical coordinate tolerance", 0.0); + level.resize(vertCoord.size()); for (size_t jdir = 0; jdir < vertCoord.size(); ++jdir) { level[jdir] = -1; - for (size_t jlev = 0; jlev < geom_->vertCoordAvg(vars[jdir]).size(); ++jlev) { - if (std::abs(geom_->vertCoordAvg(vars[jdir])[jlev]-vertCoord[jdir]) < vertCoordTol) { + for (size_t jlev = 0; jlev < geom_.vertCoordAvg(vars[jdir]).size(); ++jlev) { + if (std::abs(geom_.vertCoordAvg(vars[jdir])[jlev]-vertCoord[jdir]) <= vertCoordTol) { ASSERT(level[jdir] == -1); level[jdir] = jlev; } @@ -747,19 +743,18 @@ void Fields::dirac(const eckit::Configuration & config) { } // Build KDTree for each MPI task - const auto ghostView = atlas::array::make_view(geom_->functionSpace().ghost()); - const auto ownedView = atlas::array::make_view(geom_->fields().field("owned")); - const auto lonlatView = atlas::array::make_view(geom_->functionSpace().lonlat()); + const auto ownedView = atlas::array::make_view(geom_.fields()["owned"]); + const auto lonlatView = atlas::array::make_view(geom_.functionSpace().lonlat()); atlas::idx_t n = 0; - for (atlas::idx_t jnode = 0; jnode < geom_->functionSpace().size(); ++jnode) { - if ((ghostView(jnode) == 0) && (ownedView(jnode, 0) == 1)) { + for (atlas::idx_t jnode = 0; jnode < geom_.functionSpace().size(); ++jnode) { + if (ownedView(jnode, 0) == 1) { ++n; } } atlas::util::IndexKDTree search; search.reserve(n); - for (atlas::idx_t jnode = 0; jnode < geom_->functionSpace().size(); ++jnode) { - if ((ghostView(jnode) == 0) && (ownedView(jnode, 0) == 1)) { + for (atlas::idx_t jnode = 0; jnode < geom_.functionSpace().size(); ++jnode) { + if (ownedView(jnode, 0) == 1) { atlas::PointLonLat pointLonLat(lonlatView(jnode, 0), lonlatView(jnode, 1)); pointLonLat.normalise(); atlas::PointXY point(pointLonLat); @@ -769,7 +764,7 @@ void Fields::dirac(const eckit::Configuration & config) { search.build(); // Set fields to zero - this->zero(); + zero(); // Set dirac points for (size_t jdir = 0; jdir < lon.size(); ++jdir) { @@ -784,18 +779,18 @@ void Fields::dirac(const eckit::Configuration & config) { size_t index = std::numeric_limits::max(); double distance = std::numeric_limits::max(); bool potentialConflict = false; - if (geom_->functionSpace().size() > 0) { + if (geom_.functionSpace().size() > 0) { atlas::util::IndexKDTree::ValueList neighbor = search.closestPoints(pointLonLat, 2); index = neighbor[0].payload(); distance = neighbor[0].distance(); potentialConflict = (std::abs(neighbor[0].distance()-neighbor[1].distance()) < 1.0e-12); } - std::vector distances(geom_->getComm().size()); - geom_->getComm().allGather(distance, distances.begin(), distances.end()); + std::vector distances(geom_.getComm().size()); + geom_.getComm().allGather(distance, distances.begin(), distances.end()); const std::vector::iterator distanceMin = std::min_element(std::begin(distances), std::end(distances)); size_t sameDistanceCount = 0; - for (size_t jj = 0; jj < geom_->getComm().size(); ++jj) { + for (size_t jj = 0; jj < geom_.getComm().size(); ++jj) { if (std::abs(distances[jj]-*distanceMin) < 1.0e-12) { ++sameDistanceCount; } @@ -806,12 +801,12 @@ void Fields::dirac(const eckit::Configuration & config) { // Find local task size_t localTask(-1); - if (geom_->getComm().rank() == 0) { + if (geom_.getComm().rank() == 0) { localTask = std::distance(std::begin(distances), distanceMin); } - geom_->getComm().broadcast(localTask, 0); + geom_.getComm().broadcast(localTask, 0); - if (geom_->getComm().rank() == localTask) { + if (geom_.getComm().rank() == localTask) { // Check potential conflict if (potentialConflict) { throw eckit::UserError("requested dirac point exactly between two gridpoints", Here()); @@ -827,12 +822,12 @@ void Fields::dirac(const eckit::Configuration & config) { // Print longitude / latitude / level double lonDir = 0.0; double latDir = 0.0; - if (geom_->getComm().rank() == localTask) { + if (geom_.getComm().rank() == localTask) { lonDir = lonlatView(index, 0); latDir = lonlatView(index, 1); } - geom_->getComm().allReduceInPlace(lonDir, eckit::mpi::sum()); - geom_->getComm().allReduceInPlace(latDir, eckit::mpi::sum()); + geom_.getComm().allReduceInPlace(lonDir, eckit::mpi::sum()); + geom_.getComm().allReduceInPlace(latDir, eckit::mpi::sum()); oops::Log::info() << "Info : Dirac point #" << jdir << ": " << lonDir << " / " << latDir << " / " << level[jdir] << std::endl; } @@ -856,8 +851,8 @@ void Fields::diff(const Fields & x1, for (const auto & var : vars_) { atlas::Field field = fset_[var.name()]; - const std::string gmaskName = "gmask_" + std::to_string(geom_->groupIndex(var.name())); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); + const std::string gmaskName = "gmask_" + std::to_string(geom_.groupIndex(var.name())); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); atlas::Field fieldx1 = x1.fset_[var.name()]; atlas::Field fieldx2 = x2.fset_[var.name()]; if (field.rank() == 2) { @@ -939,7 +934,7 @@ void Fields::read(const eckit::Configuration & config) { oops::Variables vars_in_file; for (const auto & var : vars_) { std::string newVar = var.name(); - for (const auto & item : geom_->alias()) { + for (const auto & item : geom_.alias()) { if (item.getString("in code") == var.name()) { newVar = item.getString("in file"); } @@ -955,15 +950,19 @@ void Fields::read(const eckit::Configuration & config) { // Set State or Increment flag if (!updatedConfig.has("is state")) { - updatedConfig.set("is state", this->isState()); + updatedConfig.set("is state", isState()); } + // Update MPI pattern + const std::string mpiPattern = updatedConfig.getString("mpi pattern", "_MPI_"); + util::seekAndReplace(updatedConfig, mpiPattern, std::to_string(geom_.getComm().size())); + // Read fieldset - fieldsIO->read(*geom_, vars_in_file, updatedConfig, fset_); + fieldsIO->read(vars_in_file, updatedConfig, *this); // Rename fields for (auto & field : fset_) { - for (const auto & item : geom_->alias()) { + for (const auto & item : geom_.alias()) { if (item.getString("in file") == field.name()) { field.rename(item.getString("in code")); } @@ -986,8 +985,8 @@ void Fields::write(const eckit::Configuration & config) const { // Prepare updated configuration eckit::LocalConfiguration updatedConfig(config); - if (config.has("states")) { - for (const auto & confItem : config.getSubConfigurations("states")) { + if (updatedConfig.has("states")) { + for (const auto & confItem : updatedConfig.getSubConfigurations("states")) { // Get date const util::DateTime dateTime(confItem.getString("date")); @@ -998,18 +997,26 @@ void Fields::write(const eckit::Configuration & config) const { } } else { // Check date if present - if (config.has("date")) { - const util::DateTime dateTime(config.getString("date")); - ASSERT(dateTime == time_); + if (updatedConfig.has("date")) { + const util::DateTime dateTime(updatedConfig.getString("date")); + if (updatedConfig.has("range pattern")) { + const util::Duration range(time_-dateTime); + const std::string rangePattern = updatedConfig.getString("range pattern"); + util::seekAndReplace(updatedConfig, rangePattern, range.toString()); + } else { + ASSERT(dateTime == time_); + } + } else { + if (updatedConfig.has("date pattern")) { + const std::string datePattern = updatedConfig.getString("date pattern"); + util::seekAndReplace(updatedConfig, datePattern, time_.toStringIO()); + } } } - // Copy fieldset - atlas::FieldSet fset = util::copyFieldSet(fset_); - // Rename fields - for (auto & field : fset) { - for (const auto & item : geom_->alias()) { + for (auto & field : fset_) { + for (const auto & item : geom_.alias()) { if (item.getString("in code") == field.name()) { field.rename(item.getString("in file")); } @@ -1022,17 +1029,33 @@ void Fields::write(const eckit::Configuration & config) const { // Set State or Increment flag if (!updatedConfig.has("is state")) { - updatedConfig.set("is state", this->isState()); + updatedConfig.set("is state", isState()); } + // Update MPI pattern + const std::string mpiPattern = updatedConfig.getString("mpi pattern", "_MPI_"); + util::seekAndReplace(updatedConfig, mpiPattern, std::to_string(geom_.getComm().size())); + for (const auto & ioFormat : ioFormats) { - // Set FieldsIO list + // Set FieldsIO std::unique_ptr fieldsIO(FieldsIOFactory::create(ioFormat)); // Write fields - fieldsIO->write(*geom_, updatedConfig, fset); + fieldsIO->write(updatedConfig, *this); } + // Rename fields + for (auto & field : fset_) { + for (const auto & item : geom_.alias()) { + if (item.getString("in file") == field.name()) { + field.rename(item.getString("in code")); + } + } + } + + // Wait + geom_.getComm().barrier(); + oops::Log::trace() << classname() << "::write done" << std::endl; } @@ -1040,7 +1063,7 @@ void Fields::write(const eckit::Configuration & config) const { double Fields::norm() const { oops::Log::trace() << classname() << "::norm" << std::endl; - return util::normFieldSet(fset_, vars_.variables(), geom_->getComm()); + return std::sqrt(dot_product_with(*this)); } // ----------------------------------------------------------------------------- @@ -1110,73 +1133,101 @@ void Fields::deserialize(const std::vector & vect, void Fields::print(std::ostream & os) const { oops::Log::trace() << classname() << "::print starting" << std::endl; + // Print header os << std::endl; std::string prefix; if (os.rdbuf() == oops::Log::info().rdbuf()) { prefix = "Info : "; } - os << prefix << " Geometry: " << geom_->grid().name() << " [" << geom_->grid().size() << "]" + os << prefix << " Geometry: " << geom_.grid().name() << " [" << geom_.grid().size() << "]" << std::endl; os << prefix << " Fields:"; - const auto ghostView = atlas::array::make_view(geom_->functionSpace().ghost()); + + // Get owned view + const auto ownedView = atlas::array::make_view(geom_.fields()["owned"]); + for (const auto & var : vars_) { os << std::endl; + + // Initialization double zzmin = std::numeric_limits::max(); double zzmax = -std::numeric_limits::max(); double zzave = 0.0; double zzstd = 0.0; + int counter = 0; + + // Get field atlas::Field field = fset_[var.name()]; - const std::string gmaskName = "gmask_" + std::to_string(geom_->groupIndex(var.name())); - const auto gmaskView = atlas::array::make_view(geom_->fields()[gmaskName]); + + // Get mask view + const std::string gmaskName = "gmask_" + std::to_string(geom_.groupIndex(var.name())); + const auto gmaskView = atlas::array::make_view(geom_.fields()[gmaskName]); + + // Compute min/max/average if (field.rank() == 2) { auto view = atlas::array::make_view(field); for (atlas::idx_t jnode = 0; jnode < field.shape(0); ++jnode) { for (atlas::idx_t jlevel = 0; jlevel < field.shape(1); ++jlevel) { - if (gmaskView(jnode, jlevel) == 1 && ghostView(jnode) == 0) { + if (gmaskView(jnode, jlevel) == 1 && ownedView(jnode, 0) == 1) { zzmin = (view(jnode, jlevel) < zzmin) ? view(jnode, jlevel) : zzmin; zzmax = (view(jnode, jlevel) > zzmax) ? view(jnode, jlevel) : zzmax; zzave += view(jnode, jlevel); + ++counter; } } } - geom_->getComm().allReduceInPlace(zzmin, eckit::mpi::min()); - geom_->getComm().allReduceInPlace(zzmax, eckit::mpi::max()); - geom_->getComm().allReduceInPlace(zzave, eckit::mpi::sum()); - zzave /= (geom_->grid().size()*field.shape(1)); + } + + // Communication + geom_.getComm().allReduceInPlace(zzmin, eckit::mpi::min()); + geom_.getComm().allReduceInPlace(zzmax, eckit::mpi::max()); + geom_.getComm().allReduceInPlace(zzave, eckit::mpi::sum()); + geom_.getComm().allReduceInPlace(counter, eckit::mpi::sum()); + zzave /= static_cast(counter); + + // Accumulate standard-deviation + if (field.rank() == 2) { + auto view = atlas::array::make_view(field); for (atlas::idx_t jnode = 0; jnode < field.shape(0); ++jnode) { for (atlas::idx_t jlevel = 0; jlevel < field.shape(1); ++jlevel) { - if (gmaskView(jnode, jlevel) == 1 && ghostView(jnode) == 0) { + if (gmaskView(jnode, jlevel) == 1 && ownedView(jnode, 0) == 1) { zzstd += (view(jnode, jlevel)-zzave)*(view(jnode, jlevel)-zzave); } } } - geom_->getComm().allReduceInPlace(zzstd, eckit::mpi::sum()); - zzstd /= (geom_->grid().size()*field.shape(1)-1); - zzstd = std::sqrt(zzstd); - const double tiny = 1.0e-12*std::max({std::abs(zzmin), std::abs(zzmax), std::abs(zzave), - std::abs(zzstd)}); - os << prefix << " - " << var.name() << " (" << field.shape(1) << " levels):" << std::endl; - if ((std::abs(zzmin) > 0.0) && (std::abs(zzmin) < tiny)) { - os << prefix << " + min ~ 0" << std::endl; + } + + // Communication + geom_.getComm().allReduceInPlace(zzstd, eckit::mpi::sum()); + + // Normalize standard-deviation + zzstd /= static_cast(counter-1); + zzstd = std::sqrt(zzstd); + + // Print results + const double tiny = 1.0e-12*std::max({std::abs(zzmin), std::abs(zzmax), std::abs(zzave), + std::abs(zzstd)}); + os << prefix << " - " << var.name() << " (" << field.shape(1) << " levels):" << std::endl; + if ((std::abs(zzmin) > 0.0) && (std::abs(zzmin) < tiny)) { + os << prefix << " + min ~ 0" << std::endl; + } else { + os << prefix << " + min = " << zzmin << std::endl; + } + if ((std::abs(zzmax) > 0.0) && (std::abs(zzmax) < tiny)) { + os << prefix << " + max ~ 0" << std::endl; + } else { + os << prefix << " + max = " << zzmax << std::endl; + } + if (zzmin != zzmax) { + if ((std::abs(zzave) > 0.0) && (std::abs(zzave) < tiny)) { + os << prefix << " + mean ~ 0" << std::endl; } else { - os << prefix << " + min = " << zzmin << std::endl; + os << prefix << " + mean = " << zzave << std::endl; } - if ((std::abs(zzmax) > 0.0) && (std::abs(zzmax) < tiny)) { - os << prefix << " + max ~ 0" << std::endl; + if ((std::abs(zzstd) > 0.0) && (std::abs(zzstd) < tiny)) { + os << prefix << " + stddev ~ 0" << std::endl; } else { - os << prefix << " + max = " << zzmax << std::endl; - } - if (zzmin != zzmax) { - if ((std::abs(zzave) > 0.0) && (std::abs(zzave) < tiny)) { - os << prefix << " + mean ~ 0" << std::endl; - } else { - os << prefix << " + mean = " << zzave << std::endl; - } - if ((std::abs(zzstd) > 0.0) && (std::abs(zzstd) < tiny)) { - os << prefix << " + stddev ~ 0" << std::endl; - } else { - os << prefix << " + stddev = " << zzstd << std::endl; - } + os << prefix << " + stddev = " << zzstd << std::endl; } } } @@ -1186,43 +1237,11 @@ void Fields::print(std::ostream & os) const { // ----------------------------------------------------------------------------- -std::vector::iterator Fields::setupGridInterpolation(const Geometry & srcGeom) - const { - oops::Log::trace() << classname() << "::setupGridInterpolation starting" << std::endl; - - // Get geometry UIDs (grid + "_" + paritioner) - const std::string srcGeomUid = srcGeom.grid().uid() + "_" + srcGeom.partitioner().type(); - const std::string geomUid = geom_->grid().uid() + "_" + geom_->partitioner().type(); - - // Compare with existing UIDs - for (auto it = interpolations().begin(); it != interpolations().end(); ++it) { - if ((it->srcUid() == srcGeomUid) && (it->tgtUid() == geomUid)) { - oops::Log::trace() << classname() << "::setupGridInterpolation done" << std::endl; - return it; - } - } - - // Create interpolation - Interpolation interpolation(srcGeom, - srcGeomUid, - geom_->grid(), - geom_->functionSpace(), - geomUid); - - // Insert new interpolation - interpolations().emplace_back(interpolation); - - oops::Log::trace() << classname() << "::setupGridInterpolation done" << std::endl; - return std::prev(interpolations().end()); -} - -// ----------------------------------------------------------------------------- - void Fields::resetDuplicatePoints() { oops::Log::trace() << classname() << "::resetDuplicatePoints starting" << std::endl; - if (geom_->duplicatePoints()) { - if (geom_->gridType() == "regular_lonlat") { + if (geom_.duplicatePoints()) { + if ((geom_.gridType() == "structured") || (geom_.gridType() == "regular_lonlat")) { // Deal with poles for (auto field_internal : fset_) { // Get first longitude value @@ -1252,8 +1271,8 @@ void Fields::resetDuplicatePoints() { } // Reduce - geom_->getComm().allReduceInPlace(north.begin(), north.end(), eckit::mpi::sum()); - geom_->getComm().allReduceInPlace(south.begin(), south.end(), eckit::mpi::sum()); + geom_.getComm().allReduceInPlace(north.begin(), north.end(), eckit::mpi::sum()); + geom_.getComm().allReduceInPlace(south.begin(), south.end(), eckit::mpi::sum()); // Copy value for (atlas::idx_t j = fs.j_begin_halo(); j < fs.j_end_halo(); ++j) { @@ -1313,7 +1332,6 @@ bool Fields::checkFieldsCompatible(const Fields & other) const { return false; } if (fs.size() != otherFs.size()) { - std::cout << "TOTO: " << fs.size() << " " << otherFs.size() << std::endl; oops::Log::warning() << "checkFieldsCompatible: FunctionSpace sizes differ" << std::endl; return false; } diff --git a/quench/src/Fields.h b/quench/src/Fields.h index be1c45d76..796d28297 100644 --- a/quench/src/Fields.h +++ b/quench/src/Fields.h @@ -19,7 +19,6 @@ #include "oops/util/DateTime.h" #include "oops/util/ObjectCounter.h" #include "oops/util/Printable.h" -#include "oops/util/Serializable.h" #include "src/Interpolation.h" @@ -30,7 +29,6 @@ namespace quench { /// Fields class class Fields : public util::Printable, - public util::Serializable, private util::ObjectCounter { public: static const std::string classname() @@ -67,30 +65,36 @@ class Fields : public util::Printable, double dot_product_with(const Fields &) const; void schur_product_with(const Fields &); void dirac(const eckit::Configuration &); - void random(); + void random(const int &); + void random() + {random(1);} void sqrt(); void diff(const Fields &, const Fields &); - // ATLAS FieldSet - void toFieldSet(atlas::FieldSet &) const; - void fromFieldSet(const atlas::FieldSet &); + // ATLAS FieldSet accessors const atlas::FieldSet & fieldSet() const {return fset_;} atlas::FieldSet & fieldSet() {return fset_;} + // ATLAS FieldSet + void toFieldSet(atlas::FieldSet &) const; + void fromFieldSet(const atlas::FieldSet &); + void synchronizeFields() + {resetDuplicatePoints();} + // Utilities void read(const eckit::Configuration &); void write(const eckit::Configuration &) const; double norm() const; - std::shared_ptr geometry() const + const Geometry & geometry() const {return geom_;} const oops::Variables & variables() const {return vars_;} - const util::DateTime & time() const + const util::DateTime & validTime() const {return time_;} - util::DateTime & time() + util::DateTime & validTime() {return time_;} void updateTime(const util::Duration & dt) {time_ += dt;} @@ -101,16 +105,10 @@ class Fields : public util::Printable, void deserialize(const std::vector &, size_t &); - // Grid interpolations - static std::vector& interpolations(); - private: // Print void print(std::ostream &) const; - // Return grid interpolation - std::vector::iterator setupGridInterpolation(const Geometry &) const; - // Duplicate points void resetDuplicatePoints(); @@ -118,7 +116,7 @@ class Fields : public util::Printable, bool checkFieldsCompatible(const Fields &) const; // Geometry - std::shared_ptr geom_; + const Geometry & geom_; // Variables oops::Variables vars_; @@ -130,7 +128,7 @@ class Fields : public util::Printable, mutable atlas::FieldSet fset_; // State flag (false if Increment) - const bool isState_; + bool isState_; }; // ----------------------------------------------------------------------------- diff --git a/quench/src/FieldsIO/FieldsIOBase.h b/quench/src/FieldsIO/FieldsIOBase.h index ffb2e7a5b..ca86d5b8b 100644 --- a/quench/src/FieldsIO/FieldsIOBase.h +++ b/quench/src/FieldsIO/FieldsIOBase.h @@ -12,39 +12,41 @@ #include #include -#include "atlas/field.h" - -#include "eckit/config/Configuration.h" #include "eckit/exception/Exceptions.h" #include "eckit/memory/NonCopyable.h" -#include "oops/base/Variables.h" +namespace eckit { + class Configuration; +} + +namespace oops { + class Variables; +} namespace quench { - class Geometry; + class Fields; // ----------------------------------------------------------------------------- +/// FieldsIOBase class class FieldsIOBase : private eckit::NonCopyable { public: static const std::string classname() {return "quench::FieldsIOBase";} - // Constructor/destructor + // Constructor explicit FieldsIOBase(const std::string & ioFormat) : ioFormat_(ioFormat) {} // Read - virtual void read(const Geometry &, - const oops::Variables &, + virtual void read(const oops::Variables &, const eckit::Configuration &, - atlas::FieldSet &) const + Fields &) const {throw eckit::Exception("read not implemented for this format", Here());} // Write - virtual void write(const Geometry &, - const eckit::Configuration &, - const atlas::FieldSet &) const + virtual void write(const eckit::Configuration &, + const Fields &) const {throw eckit::Exception("read not implemented for this format", Here());} protected: @@ -52,10 +54,7 @@ class FieldsIOBase : private eckit::NonCopyable { }; // ----------------------------------------------------------------------------- - -class FieldsIOFactory; - -// ----------------------------------------------------------------------------- +/// FieldsIOFactory class class FieldsIOFactory { public: @@ -79,6 +78,7 @@ class FieldsIOFactory { }; // ----------------------------------------------------------------------------- +/// FieldsIOMaker class template class FieldsIOMaker : public FieldsIOFactory { diff --git a/quench/src/FieldsIO/FieldsIODefault.cc b/quench/src/FieldsIO/FieldsIODefault.cc index 63c0f8b71..e926f90a7 100644 --- a/quench/src/FieldsIO/FieldsIODefault.cc +++ b/quench/src/FieldsIO/FieldsIODefault.cc @@ -12,6 +12,7 @@ #include "oops/util/FieldSetHelpers.h" #include "oops/util/Logger.h" +#include "src/Fields.h" #include "src/Geometry.h" namespace quench { @@ -22,12 +23,14 @@ static FieldsIOMaker makerDefault_("default"); // ----------------------------------------------------------------------------- -void FieldsIODefault::read(const Geometry & geom, - const oops::Variables & vars, +void FieldsIODefault::read(const oops::Variables & vars, const eckit::Configuration & conf, - atlas::FieldSet & fset) const { + Fields & fields) const { oops::Log::trace() << classname() << "::read starting" << std::endl; + // Get geometry + const Geometry & geom(fields.geometry()); + // Create variableSizes std::vector variableSizes; for (const auto & var : vars) { @@ -37,7 +40,8 @@ void FieldsIODefault::read(const Geometry & geom, // Update configuration eckit::LocalConfiguration updatedConf(conf); if (!updatedConf.has("latitude south to north")) { - updatedConf.set("latitude south to north", geom.io().getBool("latitude south to north", true)); + updatedConf.set("latitude south to north", + geom.io().getBool("latitude south to north", true)); } // Read fieldset @@ -46,26 +50,29 @@ void FieldsIODefault::read(const Geometry & geom, variableSizes, vars.variables(), updatedConf, - fset); + fields.fieldSet()); oops::Log::trace() << classname() << "::read done" << std::endl; } // ----------------------------------------------------------------------------- -void FieldsIODefault::write(const Geometry & geom, - const eckit::Configuration & conf, - const atlas::FieldSet & fset) const { +void FieldsIODefault::write(const eckit::Configuration & conf, + const Fields & fields) const { oops::Log::trace() << classname() << "::write starting" << std::endl; + // Get geometry + const Geometry & geom(fields.geometry()); + // Update configuration eckit::LocalConfiguration updatedConf(conf); if (!updatedConf.has("latitude south to north")) { - updatedConf.set("latitude south to north", geom.io().getBool("latitude south to north", true)); + updatedConf.set("latitude south to north", + geom.io().getBool("latitude south to north", true)); } // Write fieldset - util::writeFieldSet(geom.getComm(), updatedConf, fset); + util::writeFieldSet(geom.getComm(), updatedConf, fields.fieldSet()); oops::Log::trace() << classname() << "::write done" << std::endl; } diff --git a/quench/src/FieldsIO/FieldsIODefault.h b/quench/src/FieldsIO/FieldsIODefault.h index c5e210958..b820b5537 100644 --- a/quench/src/FieldsIO/FieldsIODefault.h +++ b/quench/src/FieldsIO/FieldsIODefault.h @@ -9,18 +9,13 @@ #include -#include "atlas/field.h" - -#include "eckit/config/Configuration.h" - -#include "oops/base/Variables.h" - #include "src/FieldsIO/FieldsIOBase.h" namespace quench { - class Geometry; + class Fields; // ----------------------------------------------------------------------------- +/// FieldsIODefault class class FieldsIODefault : public FieldsIOBase { public: @@ -33,15 +28,13 @@ class FieldsIODefault : public FieldsIOBase { ~FieldsIODefault() = default; // Read - void read(const Geometry &, - const oops::Variables &, + void read(const oops::Variables &, const eckit::Configuration &, - atlas::FieldSet &) const override; + Fields &) const override; // Write - void write(const Geometry &, - const eckit::Configuration &, - const atlas::FieldSet &) const override; + void write(const eckit::Configuration &, + const Fields &) const override; }; // ----------------------------------------------------------------------------- diff --git a/quench/src/FieldsIO/FieldsIOGmsh.cc b/quench/src/FieldsIO/FieldsIOGmsh.cc index 57a8b6a4a..be4feb17b 100644 --- a/quench/src/FieldsIO/FieldsIOGmsh.cc +++ b/quench/src/FieldsIO/FieldsIOGmsh.cc @@ -17,6 +17,7 @@ #include "oops/util/FieldSetHelpers.h" #include "oops/util/Logger.h" +#include "src/Fields.h" #include "src/Geometry.h" namespace quench { @@ -27,11 +28,13 @@ static FieldsIOMaker makerGmsh_("gmsh"); // ----------------------------------------------------------------------------- -void FieldsIOGmsh::write(const Geometry & geom, - const eckit::Configuration & conf, - const atlas::FieldSet & fset) const { +void FieldsIOGmsh::write(const eckit::Configuration & conf, + const Fields & fields) const { oops::Log::trace() << classname() << "::write starting" << std::endl; + // Get geometry + const Geometry & geom(fields.geometry()); + if (!geom.mesh().generated()) { const atlas::MeshGenerator gen("delaunay"); geom.mesh() = gen(geom.grid(), geom.partitioner()); @@ -50,7 +53,7 @@ void FieldsIOGmsh::write(const Geometry & geom, // Write GMSH gmsh.write(geom.mesh()); - gmsh.write(fset, geom.functionSpace()); + gmsh.write(fields.fieldSet(), geom.functionSpace()); oops::Log::trace() << classname() << "::write done" << std::endl; } diff --git a/quench/src/FieldsIO/FieldsIOGmsh.h b/quench/src/FieldsIO/FieldsIOGmsh.h index c0349870a..d39933a92 100644 --- a/quench/src/FieldsIO/FieldsIOGmsh.h +++ b/quench/src/FieldsIO/FieldsIOGmsh.h @@ -9,18 +9,13 @@ #include -#include "atlas/field.h" - -#include "eckit/config/Configuration.h" - -#include "oops/base/Variables.h" - #include "src/FieldsIO/FieldsIOBase.h" namespace quench { - class Geometry; + class Fields; // ----------------------------------------------------------------------------- +/// FieldsIOGmsh class class FieldsIOGmsh : public FieldsIOBase { public: @@ -33,9 +28,8 @@ class FieldsIOGmsh : public FieldsIOBase { ~FieldsIOGmsh() = default; // Write - void write(const Geometry &, - const eckit::Configuration &, - const atlas::FieldSet &) const override; + void write(const eckit::Configuration &, + const Fields &) const override; }; // ----------------------------------------------------------------------------- diff --git a/quench/src/Geometry.cc b/quench/src/Geometry.cc index 65526e731..d6b633384 100644 --- a/quench/src/Geometry.cc +++ b/quench/src/Geometry.cc @@ -52,11 +52,51 @@ Geometry::Geometry(const eckit::Configuration & config, halo_ = params.halo.value(); gridType_ = params.grid.value().getString("type", "no_type"); + // Deal with poles for structured grids + if (((gridType_ == "structured") || (gridType_ == "regular_lonlat")) && grid_.domain().global()) { + // Get structured function space and grid + const atlas::functionspace::StructuredColumns fs(functionSpace_); + const atlas::StructuredGrid & grid = fs.grid(); + + // Check whether the grid has duplicated points at the poles + bool duplicated = false; + int j = 0; + if (grid.nx(j) > 1) { + double lonlatPoint[] = {0, 0}; + grid.lonlat(0, j, lonlatPoint); + double latRef = lonlatPoint[1]; + for (int i = 1; i < grid.nx(j); ++i) { + grid.lonlat(i, j, lonlatPoint); + duplicated = duplicated || (lonlatPoint[1] == latRef); + } + } + j = grid.ny()-1; + if (grid.nx(j) > 1) { + double lonlatPoint[] = {0, 0}; + grid.lonlat(0, j, lonlatPoint); + double latRef = lonlatPoint[1]; + for (int i = 1; i < grid.nx(j); ++i) { + grid.lonlat(i, j, lonlatPoint); + duplicated = duplicated || (lonlatPoint[1] == latRef); + } + } + + // Only keep the first of duplicated points in the owned mask + const auto view_i = atlas::array::make_indexview(fs.index_i()); + const auto view_j = atlas::array::make_indexview(fs.index_j()); + auto ownedView = atlas::array::make_view(fieldsetOwnedMask["owned"]); + for (int jnode = 0; jnode < fs.size(); ++jnode) { + if (((view_j(jnode) == 0) || (view_j(jnode) == grid.ny()-1)) && (view_i(jnode) > 0)) { + ownedView(jnode, 0) = 0; + } + } + } + // Setup geometry fields fields_ = atlas::FieldSet(); // Add owned points mask -- this mask does not depend on the group so was precomputed - fields_->add(fieldsetOwnedMask.field("owned")); + fields_->add(fieldsetOwnedMask["owned"]); // Levels direction levelsAreTopDown_ = params.levelsAreTopDown.value(); @@ -82,16 +122,11 @@ Geometry::Geometry(const eckit::Configuration & config, interpolation_.set("interpolation type", "unstructured"); } - // GeometryData - if (interpolation_.getString("interpolation type") == "unstructured") { - geomData_.reset(new oops::GeometryData(functionSpace_, fields_, levelsAreTopDown_, comm_)); - } - // Check for duplicate points const auto ghostView = atlas::array::make_view(functionSpace_.ghost()); - const auto ownedView = atlas::array::make_view(fields_.field("owned")); + const auto ownedView = atlas::array::make_view(fields_["owned"]); size_t duplicatedPointsCount = 0; - for (atlas::idx_t jnode = 0; jnode < fields_.field("owned").shape(0); ++jnode) { + for (atlas::idx_t jnode = 0; jnode < fields_["owned"].shape(0); ++jnode) { // Duplicate point = owned==0 and ghost==0 (see util::setupFunctionSpace in oops) if (ghostView(jnode) == 0 && ownedView(jnode, 0) == 0) { ++duplicatedPointsCount; @@ -152,74 +187,7 @@ Geometry::Geometry(const eckit::Configuration & config, } // Print summary - this->print(oops::Log::info()); - - oops::Log::trace() << classname() << "::Geometry done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -Geometry::Geometry(const Geometry & other) - : comm_(other.comm_), halo_(other.halo_), grid_(other.grid_), gridType_(other.gridType_), - partitioner_(other.partitioner_), mesh_(other.mesh_), groupIndex_(other.groupIndex_), - levelsAreTopDown_(other.levelsAreTopDown_), levelsCountFrom_(other.levelsCountFrom_), - modelData_(other.modelData_), alias_(other.alias_), - io_(other.io_), interpolation_(other.interpolation_), - duplicatePoints_(other.duplicatePoints_) { - oops::Log::trace() << classname() << "::Geometry starting" << std::endl; - - // Copy function space - if (other.functionSpace_.type() == "StructuredColumns") { - // StructuredColumns - functionSpace_ = atlas::functionspace::StructuredColumns(other.functionSpace_); - } else if (other.functionSpace_.type() == "NodeColumns") { - // NodeColumns - if (grid_.name().compare(0, 2, std::string{"CS"}) == 0) { - // CubedSphere - functionSpace_ = atlas::functionspace::CubedSphereNodeColumns(other.functionSpace_); - } else { - // Other NodeColumns - functionSpace_ = atlas::functionspace::NodeColumns(other.functionSpace_); - } - } else if (other.functionSpace_.type() == "PointCloud") { - throw eckit::NotImplemented(other.functionSpace_.type() + " function space not supported", - Here()); - } else { - throw eckit::NotImplemented(other.functionSpace_.type() + " function space not supported yet", - Here()); - } - - // Copy geometry fields - fields_ = util::shareFields(other.fields_); - - // Copy groups - for (size_t groupIndex = 0; groupIndex < other.groups_.size(); ++groupIndex) { - // Define group - groupData group; - - // Copy number of levels - group.levels_ = other.groups_[groupIndex].levels_; - - // Copy corresponding level for 2D variables (first or last) - group.lev2d_ = other.groups_[groupIndex].lev2d_; - - // Copy vertical coordinate - group.vertCoord_ = other.groups_[groupIndex].vertCoord_; - - // Copy averaged vertical coordinate - group.vertCoordAvg_ = other.groups_[groupIndex].vertCoordAvg_; - - // Copy mask size - group.gmaskSize_ = other.groups_[groupIndex].gmaskSize_; - - // Save group - groups_.push_back(group); - } - - // Geometry data - if (interpolation_.getString("interpolation type") == "unstructured") { - geomData_.reset(new oops::GeometryData(functionSpace_, fields_, levelsAreTopDown_, comm_)); - } + print(oops::Log::info()); oops::Log::trace() << classname() << "::Geometry done" << std::endl; } @@ -266,6 +234,49 @@ std::vector Geometry::variableSizes(const std::vector & var // ----------------------------------------------------------------------------- +Interpolation & Geometry::getInterpolation(const Geometry & tgtGeom) const { + oops::Log::trace() << classname() << "::getInterpolation starting" << std::endl; + + // Get target geometry UID (grid + "_" + paritioner + "@" + interpolation type) + const std::string interpolationType = tgtGeom.interpolation().getString("interpolation type"); + const std::string tgtGeomUid = tgtGeom.grid().uid() + "_" + tgtGeom.partitioner().type() + + "@" + interpolationType; + + // Look for this UID in the existing interpolations + const auto it = interpolations_.find(tgtGeomUid); + + if (it != interpolations_.end()) { + // Found existing interpolation + oops::Log::info() << "Info : Found existing interpolation for UID: " << tgtGeomUid + << std::endl; + + // Return interpolation + oops::Log::trace() << classname() << "::getInterpolation done" << std::endl; + return *(it->second); + } else { + // Create GeometryData if needed + if ((interpolationType == "unstructured") && !geomData_) { + geomData_.reset(new oops::GeometryData(functionSpace_, fields_, levelsAreTopDown_, comm_)); + } + + // Create new interpolation + std::shared_ptr interpolation(new Interpolation(*this, tgtGeom)); + + // Print interpolation type + oops::Log::info() << "Info : New interpolation created for UID: " << tgtGeomUid + << std::endl; + + // Store interpolation + interpolations_.insert({tgtGeomUid, interpolation}); + + // Return interpolation + oops::Log::trace() << classname() << "::getInterpolation done" << std::endl; + return *interpolation; + } +} + +// ----------------------------------------------------------------------------- + void Geometry::print(std::ostream & os) const { oops::Log::trace() << classname() << "::print starting" << std::endl; @@ -279,6 +290,9 @@ void Geometry::print(std::ostream & os) const { if (!grid_.domain().global()) { os << prefix << "Regional grid detected" << std::endl; } + if (duplicatePoints_) { + os << prefix << "Duplicated points detected" << std::endl; + } if (partitioner_) { os << prefix << "Partitioner:" << std::endl; os << prefix << "- type: " << partitioner_.type() << std::endl; @@ -417,9 +431,8 @@ void Geometry::setupVertCoord(groupData & group) { } } - // Get ghost and owned views - const auto ghostView = atlas::array::make_view(functionSpace_.ghost()); - const auto ownedView = atlas::array::make_view(fields_.field("owned")); + // Get owned view + const auto ownedView = atlas::array::make_view(fields_["owned"]); // Average vertical coordinate for (size_t jlevel = 0; jlevel < group.levels_; ++jlevel) { @@ -429,7 +442,7 @@ void Geometry::setupVertCoord(groupData & group) { // Loop over owned points for (atlas::idx_t jnode = 0; jnode < group.vertCoord_.shape(0); ++jnode) { - if (ghostView(jnode) == 0 && ownedView(jnode, 0) == 1) { + if (ownedView(jnode, 0) == 1) { avg += vertCoordView(jnode, jlevel); counter += 1.0; } @@ -501,8 +514,8 @@ void Geometry::setupMask(groupData & group) { auto maskView = atlas::array::make_view(gmask); maskView.assign(1); - // Ghost view - auto ghostView = atlas::array::make_view(functionSpace_.ghost()); + // Owned view + auto ownedView = atlas::array::make_view(fields_["owned"]); // Specific mask if (group.params_.maskType.value() == "none") { @@ -578,7 +591,7 @@ void Geometry::setupMask(groupData & group) { comm_.broadcast(lsm.begin(), lsm.end(), 0); // Build KD-tree - atlas::Geometry geometry(atlas::util::Earth::radius()); + const atlas::Geometry geometry(atlas::util::Earth::radius()); atlas::util::IndexKDTree2D search(geometry); search.reserve(nlat*nlon); std::vector lon2d; @@ -597,11 +610,11 @@ void Geometry::setupMask(groupData & group) { if (functionSpace_.type() == "StructuredColumns") { // StructuredColumns - atlas::functionspace::StructuredColumns fs(functionSpace_); - auto lonlatView = atlas::array::make_view(fs.xy()); + const atlas::functionspace::StructuredColumns fs(functionSpace_); + const auto lonlatView = atlas::array::make_view(fs.xy()); auto maskView = atlas::array::make_view(gmask); for (atlas::idx_t jnode = 0; jnode < fs.xy().shape(0); ++jnode) { - if (ghostView(jnode) == 0) { + if (ownedView(jnode, 0) == 1) { // Find nearest neighbor size_t nn = search.closestPoint(atlas::PointLonLat{lonlatView(jnode, 0), lonlatView(jnode, 1)}).payload(); @@ -639,7 +652,7 @@ void Geometry::setupMask(groupData & group) { size_t domainSize = 0.0; for (atlas::idx_t jnode = 0; jnode < gmask.shape(0); ++jnode) { for (atlas::idx_t jlevel = 0; jlevel < gmask.shape(1); ++jlevel) { - if (ghostView(jnode) == 0) { + if (ownedView(jnode, 0) == 1) { if (maskView(jnode, jlevel) == 1) { group.gmaskSize_ += 1.0; } diff --git a/quench/src/Geometry.h b/quench/src/Geometry.h index f0a0dc6f1..adea14573 100644 --- a/quench/src/Geometry.h +++ b/quench/src/Geometry.h @@ -21,152 +21,22 @@ #include "eckit/mpi/Comm.h" #include "oops/base/GeometryData.h" -#include "oops/base/Variables.h" #include "oops/mpi/mpi.h" #include "oops/util/ObjectCounter.h" -#include "oops/util/parameters/OptionalParameter.h" -#include "oops/util/parameters/Parameter.h" -#include "oops/util/parameters/Parameters.h" -#include "oops/util/parameters/RequiredParameter.h" #include "oops/util/Printable.h" +#include "src/GeometryParameters.h" +#include "src/Interpolation.h" + namespace eckit { class Configuration; } -namespace quench { - -// ----------------------------------------------------------------------------- -/// Orography parameters - -class OrographyParameters : public oops::Parameters { - OOPS_CONCRETE_PARAMETERS(OrographyParameters, Parameters) - - public: - // Top longitude [degrees] - oops::RequiredParameter topLon{"top longitude", this}; - - // Top latitude [degrees] - oops::RequiredParameter topLat{"top latitude", this}; - - // Zonal length [m] - oops::RequiredParameter zonalLength{"zonal length", this}; - - // Meridional length [m] - oops::RequiredParameter meridionalLength{"meridional length", this}; - - // Height (% of the bottom layer thickness, or absolute value if one level only) - oops::RequiredParameter height{"height", this}; -}; - -// ----------------------------------------------------------------------------- -/// Group parameters - -class GroupParameters : public oops::Parameters { - OOPS_CONCRETE_PARAMETERS(GroupParameters, Parameters) - - public: - // Variables - oops::RequiredParameter> variables{"variables", this}; - - // Number of levels - oops::Parameter levels{"levels", 1, this}; - - // Corresponding level for 2D variables (first or last) - oops::Parameter lev2d{"lev2d", "first", this}; - - // Orography - oops::OptionalParameter orography{"orography", this}; - - // Vertical coordinate configuration - oops::OptionalParameter vertCoordConf{ - "vertical coordinate", this}; - - // Mask type - oops::Parameter maskType{"mask type", "none", this}; - - // Mask path - oops::OptionalParameter maskPath{"mask path", this}; -}; - -// ----------------------------------------------------------------------------- -/// Alias elemental paramaters - -class AliasParameters : public oops::Parameters { - OOPS_CONCRETE_PARAMETERS(AliasParameters, oops::Parameters) - - public: - // In code - oops::RequiredParameter inCode{"in code", this}; - // In model file - oops::RequiredParameter inFile{"in file", this}; - // Optional parameters for States transformations - // Scaling factor (e.g. for units conversion) - oops::OptionalParameter scalingFactor{"scaling factor", this}; - // Toggle log10 transformation - oops::OptionalParameter logTransf{"log transform", this}; - // Additive constant (prior to log10 transformation) - oops::OptionalParameter addConst{"additive constant", this}; -}; - -// ----------------------------------------------------------------------------- -/// Interpolation paramaters - -class InterpolationParameters : public oops::Parameters { - OOPS_CONCRETE_PARAMETERS(InterpolationParameters, oops::Parameters) - - public: - // Interpolation type - oops::RequiredParameter interpType{"interpolation type", this}; -}; - -// ----------------------------------------------------------------------------- -/// Geometry parameters - -class GeometryParameters : public oops::Parameters { - OOPS_CONCRETE_PARAMETERS(GeometryParameters, Parameters) - - public: - // Function space - oops::RequiredParameter functionSpace{"function space", this}; - - // Grid - oops::RequiredParameter grid{"grid", this}; - - // Partitioner - oops::Parameter partitioner{"partitioner", "equal_regions", this}; - - // Variables groups - oops::RequiredParameter> groups{"groups", this}; - - // Halo size - oops::Parameter halo{"halo", 0, this}; - - // No point on last task - oops::Parameter noPointOnLastTask{"no point on last task", false, this}; - - // Levels top-down - oops::Parameter levelsAreTopDown{"levels are top down", true, this}; - - // Levels counter origin - oops::Parameter levelsCountFrom{"levels count from", 1, this}; - - // Model data - oops::Parameter modelData{"model data", eckit::LocalConfiguration(), - this}; - - // Variables name alias for model files - oops::Parameter> alias{"alias", {}, this}; - - // Check longitudes/latitudes from file - oops::OptionalParameter checkLonLat{"check lon/lat from file", this}; - - // IO parameters - oops::Parameter io{"io", eckit::LocalConfiguration(), this}; +namespace oops { + class Variables; +} - // Interpolation parameters - oops::OptionalParameter interpolation{"interpolation", this}; -}; +namespace quench { // ----------------------------------------------------------------------------- /// Geometry class @@ -180,7 +50,6 @@ class Geometry : public util::Printable, // Constructors Geometry(const eckit::Configuration &, const eckit::mpi::Comm & comm = oops::mpi::world()); - Geometry(const Geometry &); // Variables sizes std::vector variableSizes(const oops::Variables &) const; @@ -217,7 +86,7 @@ class Geometry : public util::Printable, {return groups_[groupIndex(var)].levels_;} size_t groups() const {return groups_.size();} - size_t groupIndex(const std::string & var) const; + size_t groupIndex(const std::string &) const; const eckit::LocalConfiguration & modelData() const {return modelData_;} const std::vector & alias() const @@ -233,6 +102,9 @@ class Geometry : public util::Printable, const oops::GeometryData & generic() const {return *geomData_;} + // Interpolation + Interpolation & getInterpolation(const Geometry &) const; + private: // Communicator const eckit::mpi::Comm & comm_; @@ -297,7 +169,10 @@ class Geometry : public util::Printable, bool duplicatePoints_; // Geometry data structure - std::unique_ptr geomData_; + mutable std::unique_ptr geomData_; + + // Interpolations vector + mutable std::unordered_map> interpolations_; // Private methods diff --git a/quench/src/GeometryParameters.h b/quench/src/GeometryParameters.h new file mode 100644 index 000000000..704050420 --- /dev/null +++ b/quench/src/GeometryParameters.h @@ -0,0 +1,156 @@ +/* + * (C) Copyright 2022 UCAR. + * (C) Copyright 2023-2024 Meteorologisk Institutt + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ + +#pragma once + +#include +#include +#include + +#include "oops/util/parameters/OptionalParameter.h" +#include "oops/util/parameters/Parameter.h" +#include "oops/util/parameters/Parameters.h" +#include "oops/util/parameters/RequiredParameter.h" + +namespace quench { + +// ----------------------------------------------------------------------------- +/// Orography parameters + +class OrographyParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(OrographyParameters, Parameters) + + public: + // Top longitude [degrees] + oops::RequiredParameter topLon{"top longitude", this}; + + // Top latitude [degrees] + oops::RequiredParameter topLat{"top latitude", this}; + + // Zonal length [m] + oops::RequiredParameter zonalLength{"zonal length", this}; + + // Meridional length [m] + oops::RequiredParameter meridionalLength{"meridional length", this}; + + // Height (% of the bottom layer thickness, or absolute value if one level only) + oops::RequiredParameter height{"height", this}; +}; + +// ----------------------------------------------------------------------------- +/// Group parameters + +class GroupParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(GroupParameters, Parameters) + + public: + // Variables + oops::RequiredParameter> variables{"variables", this}; + + // Number of levels + oops::Parameter levels{"levels", 1, this}; + + // Corresponding level for 2D variables (first or last) + oops::Parameter lev2d{"lev2d", "first", this}; + + // Orography + oops::OptionalParameter orography{"orography", this}; + + // Vertical coordinate configuration + oops::OptionalParameter vertCoordConf{ + "vertical coordinate", this}; + + // Mask type + oops::Parameter maskType{"mask type", "none", this}; + + // Mask path + oops::OptionalParameter maskPath{"mask path", this}; +}; + +// ----------------------------------------------------------------------------- +/// Alias elemental paramaters + +class AliasParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(AliasParameters, oops::Parameters) + + public: + // In code + oops::RequiredParameter inCode{"in code", this}; + // In model file + oops::RequiredParameter inFile{"in file", this}; + // Optional parameters for States transformations + // Scaling factor (e.g. for units conversion) + oops::OptionalParameter scalingFactor{"scaling factor", this}; + // Toggle log10 transformation + oops::OptionalParameter logTransf{"log transform", this}; + // Additive constant (prior to log10 transformation) + oops::OptionalParameter addConst{"additive constant", this}; +}; + +// ----------------------------------------------------------------------------- +/// Interpolation paramaters + +class InterpolationParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(InterpolationParameters, oops::Parameters) + + public: + // Interpolation type + oops::RequiredParameter interpType{"interpolation type", this}; +}; + +// ----------------------------------------------------------------------------- +/// Geometry parameters + +class GeometryParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(GeometryParameters, Parameters) + + public: + // Function space + oops::RequiredParameter functionSpace{"function space", this}; + + // Grid + oops::RequiredParameter grid{"grid", this}; + + // Partitioner + oops::Parameter partitioner{"partitioner", "equal_regions", this}; + + // Variables groups + oops::RequiredParameter> groups{"groups", this}; + + // Halo size + oops::Parameter halo{"halo", 0, this}; + + // No point on last task + oops::Parameter noPointOnLastTask{"no point on last task", false, this}; + + // Levels top-down + oops::Parameter levelsAreTopDown{"levels are top down", true, this}; + + // Levels counter origin + oops::Parameter levelsCountFrom{"levels count from", 1, this}; + + // Model data + oops::Parameter modelData{"model data", eckit::LocalConfiguration(), + this}; + + // Variables name alias for model files + oops::Parameter> alias{"alias", {}, this}; + + // Check longitudes/latitudes from file + oops::OptionalParameter checkLonLat{"check lon/lat from file", this}; + + // IO parameters + oops::Parameter io{"io", eckit::LocalConfiguration(), this}; + + // Interpolation parameters + oops::OptionalParameter interpolation{"interpolation", this}; +}; + +// ----------------------------------------------------------------------------- + +} // namespace quench diff --git a/quench/src/Increment.cc b/quench/src/Increment.cc index f012c1ea2..4213d96a9 100644 --- a/quench/src/Increment.cc +++ b/quench/src/Increment.cc @@ -17,6 +17,7 @@ //clt##include "src/Fields.h" #include #include +#include "src/Geometry.h" namespace quench { @@ -48,7 +49,7 @@ Increment::Increment(const Geometry & geom, // ----------------------------------------------------------------------------- Increment::Increment(const Increment & other, - const bool copy) + const bool & copy) : fields_(new Fields(*other.fields_, copy)) { oops::Log::trace() << classname() << "::Increment" << std::endl; } @@ -59,8 +60,8 @@ void Increment::diff(const State & x1, const State & x2) { oops::Log::trace() << classname() << "::diff starting" << std::endl; - ASSERT(this->validTime() == x1.validTime()); - ASSERT(this->validTime() == x2.validTime()); + ASSERT(validTime() == x1.validTime()); + ASSERT(validTime() == x2.validTime()); fields_->diff(x1.fields(), x2.fields()); oops::Log::trace() << classname() << "::diff done" << std::endl; @@ -82,7 +83,7 @@ Increment & Increment::operator=(const Increment & rhs) { Increment & Increment::operator+=(const Increment & dx) { oops::Log::trace() << classname() << "::operator+= starting" << std::endl; - ASSERT(this->validTime() == dx.validTime()); + ASSERT(validTime() == dx.validTime()); *fields_ += *dx.fields_; oops::Log::trace() << classname() << "::operator+= done" << std::endl; @@ -94,7 +95,7 @@ Increment & Increment::operator+=(const Increment & dx) { Increment & Increment::operator-=(const Increment & dx) { oops::Log::trace() << classname() << "::operator-= starting" << std::endl; - ASSERT(this->validTime() == dx.validTime()); + ASSERT(validTime() == dx.validTime()); *fields_ -= *dx.fields_; oops::Log::trace() << classname() << "::operator-= done" << std::endl; @@ -118,7 +119,7 @@ void Increment::zero(const util::DateTime & vt) { oops::Log::trace() << classname() << "::zero starting" << std::endl; fields_->zero(); - fields_->time() = vt; + fields_->validTime() = vt; oops::Log::trace() << classname() << "::zero done" << std::endl; } @@ -133,7 +134,7 @@ void Increment::axpy(const double & zz, const bool check) { oops::Log::trace() << classname() << "::axpy starting" << std::endl; - ASSERT(!check || this->validTime() == dx.validTime()); + ASSERT(!check || validTime() == dx.validTime()); fields_->axpy(zz, *dx.fields_); oops::Log::trace() << classname() << "::axpy done" << std::endl; @@ -144,7 +145,7 @@ void Increment::axpy(const double & zz, void Increment::print(std::ostream & os) const { oops::Log::trace() << classname() << "::print starting" << std::endl; - os << std::endl << "- Valid time: " << this->validTime(); + os << std::endl << "- Valid time: " << validTime(); os << *fields_; oops::Log::trace() << classname() << "::print done" << std::endl; diff --git a/quench/src/Increment.h b/quench/src/Increment.h index 3187d221d..1dcf5e113 100644 --- a/quench/src/Increment.h +++ b/quench/src/Increment.h @@ -15,8 +15,7 @@ #include "atlas/field.h" -#include "eckit/exception/Exceptions.h" - +#include "oops/base/Variables.h" #include "oops/util/DateTime.h" #include "oops/util/ObjectCounter.h" #include "oops/util/Printable.h" @@ -45,7 +44,7 @@ class Increment : public util::Printable, Increment(const Geometry &, const Increment &); Increment(const Increment &, - const bool); + const bool & copy = true); // Basic operators void diff(const State &, @@ -53,7 +52,8 @@ class Increment : public util::Printable, void zero() {fields_->zero();} void zero(const util::DateTime &); - void ones(); + void ones() + {fields_->constantValue(1.0);} void dirac(const eckit::Configuration & config) {fields_->dirac(config);} Increment & operator =(const Increment &); @@ -80,28 +80,36 @@ class Increment : public util::Printable, double norm() const {return fields_->norm();} const util::DateTime & validTime() const - {return fields_->time();} + {return fields_->validTime();} void updateTime(const util::Duration & dt) - {fields_->time() += dt;} + {fields_->updateTime(dt);} + + // ATLAS FieldSet accessors + const atlas::FieldSet & fieldSet() const + {return fields_->fieldSet();} + atlas::FieldSet & fieldSet() + {return fields_->fieldSet();} - // ATLAS FieldSet accessor + // ATLAS FieldSet void toFieldSet(atlas::FieldSet & fset) const {fields_->toFieldSet(fset);} void fromFieldSet(const atlas::FieldSet & fset) {fields_->fromFieldSet(fset);} + void synchronizeFields() + {fields_->synchronizeFields();} // Access to fields - Fields & fields() - {return *fields_;} const Fields & fields() const {return *fields_;} - std::shared_ptr geometry() const - {return fields_->geometry();} - // Other + // Accumulation void accumul(const double & zz, const State & xx) {fields_->axpy(zz, xx.fields());} + + // Geometry and variables accessors + const Geometry & geometry() const + {return fields_->geometry();} const oops::Variables & variables() const {return fields_->variables();} diff --git a/quench/src/Interpolation.cc b/quench/src/Interpolation.cc index e0cdc243b..c160d491d 100644 --- a/quench/src/Interpolation.cc +++ b/quench/src/Interpolation.cc @@ -11,33 +11,33 @@ #include "eckit/exception/Exceptions.h" +#include "oops/base/Variables.h" #include "oops/util/FieldSetHelpers.h" +#include "src/Geometry.h" + // ----------------------------------------------------------------------------- namespace quench { // ----------------------------------------------------------------------------- -Interpolation::Interpolation(const Geometry & geom, - const std::string & srcUid, - const atlas::Grid & tgtGrid, - const atlas::FunctionSpace & tgtFspace, - const std::string & tgtUid) - : srcUid_(srcUid), tgtUid_(tgtUid), tgtFspace_(tgtFspace) { +Interpolation::Interpolation(const Geometry & srcGeom, + const Geometry & tgtGeom) + : tgtFspace_(tgtGeom.functionSpace()) { oops::Log::trace() << classname() << "::Interpolation starting" << std::endl; // Get interpolation type - const std::string type = geom.interpolation().getString("interpolation type"); + const std::string type = srcGeom.interpolation().getString("interpolation type"); // Setup interpolation if (type == "atlas interpolation wrapper") { atlasInterpWrapper_ = std::make_shared( - geom.partitioner(), geom.functionSpace(), tgtGrid, tgtFspace_); + srcGeom.partitioner(), srcGeom.functionSpace(), tgtGeom.grid(), tgtFspace_); } else if (type == "regional") { regionalInterp_ = std::make_shared( atlas::util::Config("type", "regional-linear-2d"), - geom.functionSpace(), tgtFspace_); + srcGeom.functionSpace(), tgtFspace_); } else if (type == "unstructured") { // Get longitudes/latitudes std::vector lons; @@ -53,8 +53,8 @@ Interpolation::Interpolation(const Geometry & geom, } // Setup unstructured interpolator - unstructuredInterp_ = std::make_shared(geom.interpolation(), - geom.generic(), lats, lons); + unstructuredInterp_ = std::make_shared(srcGeom.interpolation(), + srcGeom.generic(), lats, lons); } else { throw eckit::Exception("wrong interpolation type", Here()); } @@ -89,9 +89,9 @@ void Interpolation::execute(const atlas::FieldSet & srcFieldSet, size_t index = 0; for (auto & tgtField : tgtFieldSet) { auto tgtView = atlas::array::make_view(tgtField); - for (atlas::idx_t jlevel = 0; jlevel < tgtView.shape(1); ++jlevel) { - for (atlas::idx_t jnode = 0; jnode < tgtView.shape(0); ++jnode) { - if (tgtGhostView(jnode) == 0) { + for (atlas::idx_t jnode = 0; jnode < tgtView.shape(0); ++jnode) { + if (tgtGhostView(jnode) == 0) { + for (atlas::idx_t jlevel = 0; jlevel < tgtView.shape(1); ++jlevel) { tgtView(jnode, jlevel) = vals[index]; ++index; } @@ -209,4 +209,24 @@ void Interpolation::executeVerticalAdjoint(atlas::FieldSet & srcFieldSet, // ----------------------------------------------------------------------------- +void Interpolation::print(std::ostream & os) const { + oops::Log::trace() << classname() << "::print starting" << std::endl; + +#ifdef ENABLE_SABER + if (atlasInterpWrapper_) { + os << "ATLAS interpolation wrapper from SABER"; + } +#endif + if (regionalInterp_) { + os << "Regional ATLAS interpolation"; + } + if (unstructuredInterp_) { + os << "OOPS unstructured interpolation"; + } + + oops::Log::trace() << classname() << "::print done" << std::endl; +} + +// ----------------------------------------------------------------------------- + } // namespace quench diff --git a/quench/src/Interpolation.h b/quench/src/Interpolation.h index 08ffa4239..e8749cfb4 100644 --- a/quench/src/Interpolation.h +++ b/quench/src/Interpolation.h @@ -7,7 +7,6 @@ #pragma once -#include #include #include #include @@ -16,16 +15,12 @@ #include "atlas/functionspace.h" #include "atlas/interpolation.h" -#include "eckit/config/Configuration.h" - #include "oops/generic/UnstructuredInterpolator.h" -#include "oops/util/Logger.h" #include "oops/util/ObjectCounter.h" +#include "oops/util/Printable.h" #include "saber/interpolation/AtlasInterpWrapper.h" -#include "src/Geometry.h" - namespace atlas { class Field; class Grid; @@ -35,21 +30,22 @@ namespace atlas { } namespace quench { + class Geometry; // ----------------------------------------------------------------------------- +/// Interpolation class -class Interpolation { +class Interpolation : public util::Printable, + private util::ObjectCounter { public: static const std::string classname() {return "quench::Interpolation";} // Constructor/destructor Interpolation(const Geometry &, - const std::string &, - const atlas::Grid &, - const atlas::FunctionSpace &, - const std::string &); - ~Interpolation() {} + const Geometry &); + ~Interpolation() + {} // Horizontal interpolation and adjoint void execute(const atlas::FieldSet &, @@ -67,18 +63,9 @@ class Interpolation { void executeVerticalAdjoint(atlas::FieldSet &, const atlas::FieldSet &) const; - // Accessors - const std::string & srcUid() const - {return srcUid_;} - const std::string & tgtUid() const - {return tgtUid_;} - const atlas::FunctionSpace & tgtFspace() const - {return tgtFspace_;} - private: - // Grids UID - std::string srcUid_; - std::string tgtUid_; + // Print + void print(std::ostream &) const; // Destination function space atlas::FunctionSpace tgtFspace_; diff --git a/quench/src/LinearVariableChange.cc b/quench/src/LinearVariableChange.cc index 936f4683c..48ad8e445 100644 --- a/quench/src/LinearVariableChange.cc +++ b/quench/src/LinearVariableChange.cc @@ -14,7 +14,10 @@ #include "oops/util/ConfigFunctions.h" #include "oops/util/FieldSetHelpers.h" #include "oops/util/FieldSetOperations.h" +#include "oops/util/Logger.h" +#include "src/Geometry.h" +#include "src/Increment.h" #include "src/LinearVariableChangeParameters.h" namespace quench { @@ -66,6 +69,9 @@ LinearVariableChange::LinearVariableChange(const Geometry & geom, *params.inputVariables.value(), conf, multiplierFset_); + + // Update halo + multiplierFset_.haloExchange(); } oops::Log::trace() << classname() << "::LinearVariableChange done" << std::endl; diff --git a/quench/src/LinearVariableChange.h b/quench/src/LinearVariableChange.h index 49f45c532..8ee5e5ecb 100644 --- a/quench/src/LinearVariableChange.h +++ b/quench/src/LinearVariableChange.h @@ -8,25 +8,33 @@ #pragma once -#include #include #include - -#include "eckit/config/Configuration.h" +#include #include "atlas/field.h" +#include "oops/util/ObjectCounter.h" #include "oops/util/Printable.h" -#include "src/Geometry.h" -#include "src/Increment.h" -#include "src/State.h" +namespace eckit { + class Configuration; +} + +namespace oops { + class Variables; +} namespace quench { + class Geometry; + class Increment; + class State; // ----------------------------------------------------------------------------- +/// LinearVariableChange class -class LinearVariableChange: public util::Printable { +class LinearVariableChange: public util::Printable, + private util::ObjectCounter { public: static const std::string classname() {return "quench::LinearVariableChange";} @@ -58,7 +66,7 @@ class LinearVariableChange: public util::Printable { {os << "LinearVariableChange";} // Map from output to input variables - std::map map_; + std::unordered_map map_; // Multiplicative factor atlas::FieldSet multiplierFset_; diff --git a/quench/src/ModelData.h b/quench/src/ModelData.h index 8e7aeab41..72a2bffdc 100644 --- a/quench/src/ModelData.h +++ b/quench/src/ModelData.h @@ -13,6 +13,7 @@ #include "eckit/config/LocalConfiguration.h" +#include "oops/util/ObjectCounter.h" #include "oops/util/Printable.h" #include "src/Geometry.h" @@ -20,8 +21,10 @@ namespace quench { // ------------------------------------------------------------------------------------------------- +/// ModelData class -class ModelData : public util::Printable { +class ModelData : public util::Printable, + private util::ObjectCounter { public: static const std::string classname() {return "quench::ModelData";} diff --git a/quench/src/State.cc b/quench/src/State.cc index 3ac4f4bc8..c113cc736 100644 --- a/quench/src/State.cc +++ b/quench/src/State.cc @@ -57,6 +57,10 @@ State::State(const Geometry & geom, oops::Log::info() << "Info : Create state with a constant group-specific value" << std::endl; fields_->constantValue(file); + } else if (file.has("random sigma")) { + oops::Log::info() << "Info : Create a random state" << std::endl; + fields_->random(); + *fields_ *= file.getDouble("random sigma"); } else { oops::Log::info() << "Info : Create empty state" << std::endl; fields_->zero(); @@ -81,9 +85,9 @@ State & State::operator=(const State & rhs) { State & State::operator+=(const Increment & dx) { oops::Log::trace() << classname() << "::operator+= starting" << std::endl; - ASSERT(this->validTime() == dx.validTime()); + ASSERT(validTime() == dx.validTime()); ASSERT(fields_); - *fields_+=dx.fields(); + *fields_ += dx.fields(); oops::Log::trace() << classname() << "::operator+= done" << std::endl; return *this; @@ -94,7 +98,7 @@ State & State::operator+=(const Increment & dx) { void State::print(std::ostream & os) const { oops::Log::trace() << classname() << "::print starting" << std::endl; - os << std::endl << "- Valid time: " << this->validTime(); + os << std::endl << "- Valid time: " << validTime(); os << *fields_; oops::Log::trace() << classname() << "::print done" << std::endl; diff --git a/quench/src/State.h b/quench/src/State.h index 57396109e..6e521f0cd 100644 --- a/quench/src/State.h +++ b/quench/src/State.h @@ -13,9 +13,13 @@ #include #include +#include "eckit/exception/Exceptions.h" + +#include "oops/base/Variables.h" #include "oops/util/DateTime.h" #include "oops/util/ObjectCounter.h" #include "oops/util/Printable.h" +#include "oops/util/Serializable.h" #include "src/Fields.h" @@ -31,6 +35,7 @@ namespace quench { /// State class class State : public util::Printable, + public util::Serializable, private util::ObjectCounter { public: static const std::string classname() @@ -42,9 +47,9 @@ class State : public util::Printable, const util::DateTime &); State(const Geometry &, const eckit::Configuration &); - State(const Geometry & resol, + State(const Geometry & geom, const State & other) - : fields_(new Fields(*other.fields_, resol)) {} + : fields_(new Fields(*other.fields_, geom)) {} State(const oops::Variables & vars, const State & other) : fields_(new Fields(*other.fields_)) {} @@ -65,32 +70,38 @@ class State : public util::Printable, double norm() const {return fields_->norm();} const util::DateTime & validTime() const - {return fields_->time();} - util::DateTime & validTime() - {return fields_->time();} + {return fields_->validTime();} void updateTime(const util::Duration & dt) - {fields_->time() += dt;} + {fields_->updateTime(dt);} - // Access to fields - Fields & fields() - {return *fields_;} - const Fields & fields() const - {return *fields_;} - std::shared_ptr geometry() const - {return fields_->geometry();} + // ATLAS FieldSet accessors + const atlas::FieldSet & fieldSet() const + {return fields_->fieldSet();} + atlas::FieldSet & fieldSet() + {return fields_->fieldSet();} - // ATLAS FieldSet accessor + // ATLAS FieldSet void toFieldSet(atlas::FieldSet & fset) const {fields_->toFieldSet(fset);} void fromFieldSet(const atlas::FieldSet & fset) {fields_->fromFieldSet(fset);} + void synchronizeFields() + {fields_->synchronizeFields();} - // Other + // Access to fields + const Fields & fields() const + {return *fields_;} + + // Accumulation void zero() {fields_->zero();} void accumul(const double & zz, const State & xx) - {fields_->axpy(zz, xx.fields());} + {fields_->axpy(zz, *xx.fields_);} + + // Geometry and variables accessors + const Geometry & geometry() const + {return fields_->geometry();} const oops::Variables & variables() const {return fields_->variables();} @@ -102,6 +113,11 @@ class State : public util::Printable, void deserialize(const std::vector & vect, size_t & index) {fields_->deserialize(vect, index);} + void transpose(const State &, + const eckit::mpi::Comm &, + const int, + const int) + {throw eckit::Exception("not implemented yet", Here());} private: // Print diff --git a/quench/src/Traits.h b/quench/src/Traits.h index 94fe8284c..f56c8ccb2 100644 --- a/quench/src/Traits.h +++ b/quench/src/Traits.h @@ -8,11 +8,36 @@ #pragma once +#include + +#include "oops/generic/AtlasInterpolator.h" #include "src/Covariance.h" #include "src/Geometry.h" #include "src/Increment.h" #include "src/LinearVariableChange.h" #include "src/ModelData.h" #include "src/State.h" -#include "src/TraitsFwd.h" #include "src/VariableChange.h" + +namespace oops { +class AtlasInterpolator; +} // namespace oops + +namespace quench { + +struct Traits { + static std::string name() + {return "quench";} + static std::string nameCovar() + {return "quenchCovariance";} + + typedef quench::Covariance Covariance; + typedef quench::Geometry Geometry; + typedef quench::Increment Increment; + typedef quench::LinearVariableChange LinearVariableChange; + typedef quench::ModelData ModelData; + typedef quench::State State; + typedef quench::VariableChange VariableChange; +}; + +} // namespace quench diff --git a/quench/src/TraitsFwd.h b/quench/src/TraitsFwd.h deleted file mode 100644 index cbb8f1a3d..000000000 --- a/quench/src/TraitsFwd.h +++ /dev/null @@ -1,38 +0,0 @@ -/* - * (C) Copyright 2022 UCAR. - * (C) Copyright 2023-2024 Meteorologisk Institutt - * - * This software is licensed under the terms of the Apache Licence Version 2.0 - * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. - */ - -#pragma once - -#include - -namespace quench { - -class Covariance; -class Geometry; -class Increment; -class LinearVariableChange; -class ModelData; -class State; -class VariableChange; - -struct Traits { - static std::string name() - {return "quench";} - static std::string nameCovar() - {return "quenchCovariance";} - - typedef quench::Covariance Covariance; - typedef quench::Geometry Geometry; - typedef quench::Increment Increment; - typedef quench::LinearVariableChange LinearVariableChange; - typedef quench::ModelData ModelData; - typedef quench::State State; - typedef quench::VariableChange VariableChange; -}; - -} // namespace quench diff --git a/quench/src/VariableChange.cc b/quench/src/VariableChange.cc index 49115d250..d6eaa2370 100644 --- a/quench/src/VariableChange.cc +++ b/quench/src/VariableChange.cc @@ -8,11 +8,14 @@ #include "src/VariableChange.h" +#include "oops/base/Variables.h" #include "oops/util/ConfigFunctions.h" #include "oops/util/FieldSetHelpers.h" #include "oops/util/FieldSetOperations.h" +#include "oops/util/Logger.h" #include "src/Geometry.h" +#include "src/State.h" namespace quench { diff --git a/quench/src/VariableChange.h b/quench/src/VariableChange.h index 841b63b6f..ff774d08b 100644 --- a/quench/src/VariableChange.h +++ b/quench/src/VariableChange.h @@ -17,9 +17,13 @@ #include "oops/util/Printable.h" #include "src/Geometry.h" -#include "src/State.h" + +namespace oops { + class Variables; +} namespace quench { + class State; // ----------------------------------------------------------------------------- diff --git a/saber-import.cmake.in b/saber-import.cmake.in index b2eee457d..0b1b5ce57 100644 --- a/saber-import.cmake.in +++ b/saber-import.cmake.in @@ -68,11 +68,6 @@ if(@gsibec_FOUND@) # gsibec_FOUND endif() endif() -if(@eccodes_FOUND@) # eccodes_FOUND - find_dependency(eccodes) - set(saber_eccodes_FOUND True) #COMPONENT 'eccodes' -endif() - #Export Fortran compiler version for checking module compatibility set(@PROJECT_NAME@_MODULES_Fortran_COMPILER_ID @CMAKE_Fortran_COMPILER_ID@) set(@PROJECT_NAME@_MODULES_Fortran_COMPILER_VERSION @CMAKE_Fortran_COMPILER_VERSION@) diff --git a/src/saber/fastlam/FastLAM.cc b/src/saber/fastlam/FastLAM.cc index f40da77c3..2a56b4875 100644 --- a/src/saber/fastlam/FastLAM.cc +++ b/src/saber/fastlam/FastLAM.cc @@ -1027,14 +1027,11 @@ std::vector> FastLAM::fie view.assign(util::missingValue()); fset.add(field); - for (size_t jg = 0; jg < groups_.size(); ++jg) { - // Copy field - if (groups_[jg].varInModelFile_ == var.name()) { - const atlas::Field rhField = (*rh_)[groups_[jg].name_]; - const auto rhView = atlas::array::make_view(rhField); - view.assign(rhView); - } - } + // Copy field + size_t jg = getGroupIndex(var.name()); + const atlas::Field rhField = (*rh_)[groups_[jg].name_]; + const auto rhView = atlas::array::make_view(rhField); + view.assign(rhView); } // Add pair @@ -1056,17 +1053,14 @@ std::vector> FastLAM::fie view.assign(util::missingValue()); fset.add(field); - for (size_t jg = 0; jg < groups_.size(); ++jg) { - // Copy field - if (groups_[jg].varInModelFile_ == var.name()) { - const atlas::Field wgtSqrtField = (*weight_[jBin])[groups_[jg].name_]; - const auto wgtSqrtView = atlas::array::make_view(wgtSqrtField); - for (size_t jnode0 = 0; jnode0 < nodes0_; ++jnode0) { - if (ghostView(jnode0) == 0) { - for (size_t jz0 = 0; jz0 < nz0; ++jz0) { - view(jnode0, jz0) = wgtSqrtView(jnode0, jz0)*wgtSqrtView(jnode0, jz0); - } - } + // Copy field + size_t jg = getGroupIndex(var.name()); + const atlas::Field wgtSqrtField = (*weight_[jBin])[groups_[jg].name_]; + const auto wgtSqrtView = atlas::array::make_view(wgtSqrtField); + for (size_t jnode0 = 0; jnode0 < nodes0_; ++jnode0) { + if (ghostView(jnode0) == 0) { + for (size_t jz0 = 0; jz0 < nz0; ++jz0) { + view(jnode0, jz0) = wgtSqrtView(jnode0, jz0)*wgtSqrtView(jnode0, jz0); } } } @@ -1096,14 +1090,11 @@ std::vector> FastLAM::fie view.assign(util::missingValue()); fset.add(field); - for (size_t jg = 0; jg < groups_.size(); ++jg) { - // Copy field - if (groups_[jg].varInModelFile_ == var.name()) { - const atlas::Field normField = (*normalization_[jBin])[groups_[jg].name_]; - const auto normView = atlas::array::make_view(normField); - view.assign(normView); - } - } + // Copy field + size_t jg = getGroupIndex(var.name()); + const atlas::Field normField = (*normalization_[jBin])[groups_[jg].name_]; + const auto normView = atlas::array::make_view(normField); + view.assign(normView); } // Update configuration @@ -1130,14 +1121,11 @@ std::vector> FastLAM::fie view.assign(util::missingValue()); fset.add(field); - for (size_t jg = 0; jg < groups_.size(); ++jg) { - // Copy field - if (groups_[jg].varInModelFile_ == var.name()) { - const atlas::Field normField = data_[jg][jBin]->normAcc()[groups_[jg].name_]; - const auto normView = atlas::array::make_view(normField); - view.assign(normView); - } - } + // Copy field + size_t jg = getGroupIndex(var.name()); + const atlas::Field normField = data_[jg][jBin]->normAcc()[groups_[jg].name_]; + const auto normView = atlas::array::make_view(normField); + view.assign(normView); } // Update configuration diff --git a/test/testinput/dirac_bifourier_vordivtouv_1.yaml b/test/testinput/dirac_bifourier_vordivtouv_1.yaml index 2a2d9cfd5..76ed70870 100644 --- a/test/testinput/dirac_bifourier_vordivtouv_1.yaml +++ b/test/testinput/dirac_bifourier_vordivtouv_1.yaml @@ -23,6 +23,9 @@ geometry: - geographical_x_wind - geographical_y_wind levels: 10 + - variables: + - map_factor + levels: 1 latitude south to north: false background: date: 2010-01-01T12:00:00Z diff --git a/test/testinput/dirac_bifourier_vordivtouv_3.yaml b/test/testinput/dirac_bifourier_vordivtouv_3.yaml index de9042877..a8350aaea 100644 --- a/test/testinput/dirac_bifourier_vordivtouv_3.yaml +++ b/test/testinput/dirac_bifourier_vordivtouv_3.yaml @@ -23,6 +23,13 @@ geometry: - eastward_wind - northward_wind levels: 10 + - variables: + - map_factor + - dxDlon + - dxDlat + - dyDlon + - dyDlat + levels: 1 latitude south to north: false background: date: 2010-01-01T12:00:00Z diff --git a/test/testinput/error_covariance_training_stddev_1.yaml b/test/testinput/error_covariance_training_stddev_1.yaml index c8ff3a867..edd3cb948 100644 --- a/test/testinput/error_covariance_training_stddev_1.yaml +++ b/test/testinput/error_covariance_training_stddev_1.yaml @@ -8,7 +8,7 @@ geometry: - air_horizontal_streamfunction - air_horizontal_velocity_potential levels: 2 - halo: 0 + halo: 1 background: date: 2010-01-01T12:00:00Z state variables: diff --git a/test/testinput/error_covariance_training_stddev_2.yaml b/test/testinput/error_covariance_training_stddev_2.yaml index e52a835a9..90a2d19d1 100644 --- a/test/testinput/error_covariance_training_stddev_2.yaml +++ b/test/testinput/error_covariance_training_stddev_2.yaml @@ -36,4 +36,4 @@ background error: write to model file: filepath: testdata/error_covariance_training_stddev_2/_MPI_-_OMP__stddev test: - reference filename: testref/error_covariance_training_stddev_1.ref + reference filename: testref/error_covariance_training_stddev_2.ref diff --git a/test/testref/dirac_bifourier_vordivtouv_3.ref b/test/testref/dirac_bifourier_vordivtouv_3.ref index 6cb2ebae0..a344f1698 100644 --- a/test/testref/dirac_bifourier_vordivtouv_3.ref +++ b/test/testref/dirac_bifourier_vordivtouv_3.ref @@ -13,7 +13,7 @@ Input Dirac increment: - xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] - yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] Outer grid size: 3723 -Norm of output parameter : 1.0568360561474846e+02 +Norm of output parameter : 1.0568360561474853e+02 Adjoint test for block RedWindToGeoWind passed Inner inverse test for block RedWindToGeoWind passed: U Uinv (U x) == (U x) Outer inverse test for block RedWindToGeoWind passed: Uinv U (Uinv x) == (Uinv x) diff --git a/test/testref/dirac_bump_1.ref b/test/testref/dirac_bump_1.ref index f73003de2..8dfc77b43 100644 --- a/test/testref/dirac_bump_1.ref +++ b/test/testref/dirac_bump_1.ref @@ -5,8 +5,8 @@ Input Dirac increment: - eastward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - northward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -54,7 +54,7 @@ Adjoint test for block BUMP_PsiChiToUV passed nc2 = 250 Independent levels: 1[2] Adjoint test for block BUMP_VerticalBalance passed -Norm of input parameter StdDev: 5.7680980822377037e+01 +Norm of input parameter StdDev: 5.4937700734311314e+01 Adjoint test for block StdDev passed Independent levels: 1[2] Subset Sc0 size: 762 @@ -71,7 +71,7 @@ Adjoint test for block BUMP_StdDev passed Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of input parameter stddev - 1: 5.7680980822377037e+01 +Norm of input parameter stddev - 1: 5.4937700734311314e+01 Adjoint test for block BUMP_StdDev passed Independent levels: 1[2] Subset Sc0 size: 762 @@ -96,26 +96,26 @@ Covariance(hybrid) * Increment: - eastward_wind (2 levels): + min = -1.0943930702326402e-01 + max = 8.2121864387310488e+00 - + mean = 2.4280648809627207e-02 - + stddev = 2.8516221671018199e-01 + + mean = 2.6766069553919757e-02 + + stddev = 2.9929955592822705e-01 - northward_wind (2 levels): + min = -8.6927355119742045e-01 + max = 1.5132717816596037e+00 - + mean = 2.9470116642171182e-03 - + stddev = 7.8734627446299943e-02 + + mean = 3.2486742755149334e-03 + + stddev = 8.2662780980089987e-02 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: - eastward_wind (2 levels): + min = -5.4184862762552011e-01 + max = 6.8908772408954155e-01 - + mean = 2.7517648353033554e-03 - + stddev = 4.6924570343053397e-02 + + mean = 3.0334415507281085e-03 + + stddev = 4.9260543933546758e-02 - northward_wind (2 levels): + min = -8.6554401015234295e-01 + max = 1.0379507642958299e+00 - + mean = -1.3222376772444684e-03 - + stddev = 5.5678858414002629e-02 + + mean = -1.4575848410568943e-03 + + stddev = 5.8459241436134943e-02 Independent levels: 1[2] Subset Sc0 size: 762 Domain area (% of Earth area): 0.100E+03% @@ -151,7 +151,7 @@ Adjoint test for block BUMP_PsiChiToUV passed nc2 = 250 Independent levels: 1[2] Adjoint test for block BUMP_VerticalBalance passed -Norm of input parameter StdDev: 5.7680980822377037e+01 +Norm of input parameter StdDev: 5.4937700734311314e+01 Adjoint test for block StdDev passed Independent levels: 1[2] Subset Sc0 size: 762 @@ -168,7 +168,7 @@ Adjoint test for block BUMP_StdDev passed Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of input parameter stddev - 1: 5.7680980822377037e+01 +Norm of input parameter stddev - 1: 5.4937700734311314e+01 Adjoint test for block BUMP_StdDev passed Independent levels: 1[2] Subset Sc0 size: 762 @@ -186,26 +186,26 @@ Covariance(hybrid1_SABER) * Increment: - eastward_wind (2 levels): + min = -3.5362039973425105e-13 + max = 1.3478032211140141e-12 - + mean = -4.5912057011016145e-17 - + stddev = 7.8243599529061234e-14 + + mean = -5.0611716390096536e-17 + + stddev = 8.2153148121769046e-14 - northward_wind (2 levels): + min = -3.2889066103205936e-13 + max = 3.2622646484939685e-13 - + mean = -1.6387923157531297e-17 - + stddev = 3.1304178493999455e-14 + + mean = -1.8065427102790403e-17 + + stddev = 3.2868334756832761e-14 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: - eastward_wind (2 levels): + min = -3.5362039973425105e-13 + max = 1.3478032211140141e-12 - + mean = -4.5912057011016145e-17 - + stddev = 7.8243599529061234e-14 + + mean = -5.0611716390096536e-17 + + stddev = 8.2153148121769046e-14 - northward_wind (2 levels): + min = -3.2889066103205936e-13 + max = 3.2622646484939685e-13 - + mean = -1.6387923157531297e-17 - + stddev = 3.1304178493999455e-14 + + mean = -1.8065427102790403e-17 + + stddev = 3.2868334756832761e-14 Independent levels: 1[2] Subset Sc0 size: 762 Domain area (% of Earth area): 0.100E+03% @@ -220,26 +220,26 @@ Covariance(hybrid2_ensemble) * Increment: - eastward_wind (2 levels): + min = -2.1887861404664372e-01 + max = 1.6424372877460751e+01 - + mean = 4.8561297619254401e-02 - + stddev = 5.7032443342030392e-01 + + mean = 5.3532139107839494e-02 + + stddev = 5.9859911185639147e-01 - northward_wind (2 levels): + min = -1.7385471023950549e+00 + max = 3.0265435633191187e+00 - + mean = 5.8940233284342503e-03 - + stddev = 1.5746925489260116e-01 + + mean = 6.4973485510298823e-03 + + stddev = 1.6532556196018131e-01 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: - eastward_wind (2 levels): + min = -1.0836972552517310e+00 + max = 1.3781754481787640e+00 - + mean = 5.5035296706067455e-03 - + stddev = 9.3849140686085838e-02 + + mean = 6.0668831014562552e-03 + + stddev = 9.8521087867071686e-02 - northward_wind (2 levels): + min = -1.7310880203046679e+00 + max = 2.0759015285916642e+00 - + mean = -2.6444753544889186e-03 - + stddev = 1.1135771682800187e-01 + + mean = -2.9151696821137687e-03 + + stddev = 1.1691848287226630e-01 Independent levels: 1[2] Subset Sc0 size: 762 Domain area (% of Earth area): 0.100E+03% @@ -257,23 +257,23 @@ Localization(hybrid2_ensemble) * Increment: - eastward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 9.9999999999999956e-01 - + mean = 6.4833852361952269e-03 - + stddev = 5.1766416418524037e-02 + + mean = 7.1470388430498570e-03 + + stddev = 5.4309318156277889e-02 - northward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 9.9999999999999956e-01 - + mean = 6.4833852361952269e-03 - + stddev = 5.1766416418524037e-02 + + mean = 7.1470388430498570e-03 + + stddev = 5.4309318156277889e-02 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: - eastward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 9.9999999999999956e-01 - + mean = 6.4833852361952269e-03 - + stddev = 5.1766416418524037e-02 + + mean = 7.1470388430498570e-03 + + stddev = 5.4309318156277889e-02 - northward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 9.9999999999999956e-01 - + mean = 6.4833852361952269e-03 - + stddev = 5.1766416418524037e-02 + + mean = 7.1470388430498570e-03 + + stddev = 5.4309318156277889e-02 diff --git a/test/testref/dirac_bump_2.ref b/test/testref/dirac_bump_2.ref index 28fb8bdb6..c55a38ee6 100644 --- a/test/testref/dirac_bump_2.ref +++ b/test/testref/dirac_bump_2.ref @@ -5,8 +5,8 @@ Input Dirac increment: - eastward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - northward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -54,7 +54,7 @@ Adjoint test for block BUMP_PsiChiToUV passed nc2 = 250 Independent levels: 1[2] Adjoint test for block BUMP_VerticalBalance passed -Norm of input parameter StdDev: 5.7680980822377037e+01 +Norm of input parameter StdDev: 5.4937700734311314e+01 Adjoint test for block StdDev passed Independent levels: 1[2] Subset Sc0 size: 762 @@ -71,7 +71,7 @@ Adjoint test for block BUMP_StdDev passed Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of input parameter stddev - 1: 5.7680980822377037e+01 +Norm of input parameter stddev - 1: 5.4937700734311314e+01 Adjoint test for block BUMP_StdDev passed Independent levels: 1[2] Subset Sc0 size: 762 @@ -82,8 +82,8 @@ Adjoint test for block BUMP_StdDev passed Level 2 ~> 0.200E+01 vert. coord. Adjoint test for block BUMP_NICAS passed Square-root test for block BUMP_NICAS passed -Norm of input parameter inflation: 6.9558608381710329e+01 -Norm of input parameter StdDev: 1.7389652095427326e+02 +Norm of input parameter inflation: 6.6250433960843253e+01 +Norm of input parameter StdDev: 1.6562608490210712e+02 Independent levels: 1[2] Subset Sc0 size: 762 Domain area (% of Earth area): 0.100E+03% @@ -101,26 +101,26 @@ Covariance(hybrid) * Increment: - eastward_wind (2 levels): + min = -4.9205422200514680e-02 + max = 9.3332292735982325e-01 - + mean = 2.6937821895193894e-03 - + stddev = 3.2920387220210665e-02 + + mean = 2.9695236734859410e-03 + + stddev = 3.4553445696327588e-02 - northward_wind (2 levels): + min = -1.6996745503541399e-01 + max = 1.2139154453781741e-01 - + mean = -3.6169630717027473e-04 - + stddev = 8.0296358255301115e-03 + + mean = -3.9872033861290126e-04 + + stddev = 8.4299716138385768e-03 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: - eastward_wind (2 levels): + min = -1.2452365083519630e-01 + max = 1.8426374415027613e-01 - + mean = 3.4975601127957488e-04 - + stddev = 9.1375169462998597e-03 + + mean = 3.8555780770976758e-04 + + stddev = 9.5933657787908716e-03 - northward_wind (2 levels): + min = -2.0437919265005011e-01 + max = 1.9346949982103234e-01 - + mean = 1.1398491179674831e-05 - + stddev = 1.0740295591348087e-02 + + mean = 1.2565265867358081e-05 + + stddev = 1.1276948716089460e-02 Independent levels: 1[2] Subset Sc0 size: 762 Domain area (% of Earth area): 0.100E+03% @@ -156,7 +156,7 @@ Adjoint test for block BUMP_PsiChiToUV passed nc2 = 250 Independent levels: 1[2] Adjoint test for block BUMP_VerticalBalance passed -Norm of input parameter StdDev: 5.7680980822377037e+01 +Norm of input parameter StdDev: 5.4937700734311314e+01 Adjoint test for block StdDev passed Independent levels: 1[2] Subset Sc0 size: 762 @@ -173,7 +173,7 @@ Adjoint test for block BUMP_StdDev passed Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of input parameter stddev - 1: 5.7680980822377037e+01 +Norm of input parameter stddev - 1: 5.4937700734311314e+01 Adjoint test for block BUMP_StdDev passed Independent levels: 1[2] Subset Sc0 size: 762 @@ -191,28 +191,28 @@ Covariance(hybrid1_SABER) * Increment: - eastward_wind (2 levels): + min = -3.5362039973425105e-13 + max = 1.3478032211140141e-12 - + mean = -4.5912057011016145e-17 - + stddev = 7.8243599529061234e-14 + + mean = -5.0611716390096536e-17 + + stddev = 8.2153148121769046e-14 - northward_wind (2 levels): + min = -3.2889066103205936e-13 + max = 3.2622646484939685e-13 - + mean = -1.6387923157531297e-17 - + stddev = 3.1304178493999455e-14 + + mean = -1.8065427102790403e-17 + + stddev = 3.2868334756832761e-14 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: - eastward_wind (2 levels): + min = -3.5362039973425105e-13 + max = 1.3478032211140141e-12 - + mean = -4.5912057011016145e-17 - + stddev = 7.8243599529061234e-14 + + mean = -5.0611716390096536e-17 + + stddev = 8.2153148121769046e-14 - northward_wind (2 levels): + min = -3.2889066103205936e-13 + max = 3.2622646484939685e-13 - + mean = -1.6387923157531297e-17 - + stddev = 3.1304178493999455e-14 -Norm of input parameter inflation: 6.9558608381710329e+01 -Norm of input parameter StdDev: 1.7389652095427326e+02 + + mean = -1.8065427102790403e-17 + + stddev = 3.2868334756832761e-14 +Norm of input parameter inflation: 6.6250433960843253e+01 +Norm of input parameter StdDev: 1.6562608490210712e+02 Independent levels: 1[2] Subset Sc0 size: 762 Domain area (% of Earth area): 0.100E+03% @@ -230,23 +230,23 @@ Covariance(hybrid2_SABER) * Increment: - eastward_wind (2 levels): + min = -9.8410844401244119e-02 + max = 1.8666458547182987e+00 - + mean = 5.3875643790388195e-03 - + stddev = 6.5840774440359615e-02 + + mean = 5.9390473469719271e-03 + + stddev = 6.9106891392590200e-02 - northward_wind (2 levels): + min = -3.3993491007083354e-01 + max = 2.4278308907565277e-01 - + mean = -7.2339261434053331e-04 - + stddev = 1.6059271651059630e-02 + + mean = -7.9744067722578474e-04 + + stddev = 1.6859943227676515e-02 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: - eastward_wind (2 levels): + min = -2.4904730167092012e-01 + max = 3.6852748830001930e-01 - + mean = 6.9951202255919562e-04 - + stddev = 1.8275033892585685e-02 + + mean = 7.7111561541958579e-04 + + stddev = 1.9186731557566984e-02 - northward_wind (2 levels): + min = -4.0875838530009023e-01 + max = 3.8693899964206191e-01 - + mean = 2.2796982359365996e-05 - + stddev = 2.1480591182694471e-02 + + mean = 2.5130531734734167e-05 + + stddev = 2.2553897432177131e-02 diff --git a/test/testref/dirac_bump_3.ref b/test/testref/dirac_bump_3.ref index 6f22300fd..6414c08b0 100644 --- a/test/testref/dirac_bump_3.ref +++ b/test/testref/dirac_bump_3.ref @@ -5,8 +5,8 @@ Input Dirac increment: - eastward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - northward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -62,7 +62,7 @@ Adjoint test for block BUMP_StdDev passed Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of input parameter stddev - 1: 5.7680980822377037e+01 +Norm of input parameter stddev - 1: 5.4937700734311314e+01 Adjoint test for block BUMP_StdDev passed Independent levels: 1[2] Subset Sc0 size: 762 @@ -74,7 +74,7 @@ Adjoint test for block BUMP_StdDev passed Adjoint test for block BUMP_NICAS passed Square-root test for block BUMP_NICAS passed Norm of input parameter inflation: 6.9558608381710329e+01 -Norm of input parameter StdDev: 1.7389652095427326e+02 +Norm of input parameter StdDev: 1.6562608490210712e+02 Independent levels: 1[2] Subset Sc0 size: 762 Domain area (% of Earth area): 0.100E+03% @@ -92,13 +92,13 @@ Covariance(SABER) * Increment: - eastward_wind (2 levels): + min = -4.9205422200514701e-02 + max = 9.3332292735982358e-01 - + mean = 2.6937821895193898e-03 - + stddev = 3.2920387220210678e-02 + + mean = 2.9695236734859414e-03 + + stddev = 3.4553445696327595e-02 - northward_wind (2 levels): + min = -1.6996745503541394e-01 + max = 1.2139154453781746e-01 - + mean = -3.6169630717027457e-04 - + stddev = 8.0296358255301115e-03 + + mean = -3.9872033861290110e-04 + + stddev = 8.4299716138385768e-03 Independent levels: 1[2] Subset Sc0 size: 762 Domain area (% of Earth area): 0.100E+03% @@ -151,7 +151,7 @@ Adjoint test for block BUMP_StdDev passed Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of input parameter stddev - 1: 5.7680980822377037e+01 +Norm of input parameter stddev - 1: 5.4937700734311314e+01 Adjoint test for block BUMP_StdDev passed Independent levels: 1[2] Subset Sc0 size: 762 @@ -169,15 +169,15 @@ Covariance(SABER1_SABER) * Increment: - eastward_wind (2 levels): + min = -3.5362039973425105e-13 + max = 1.3478032211140141e-12 - + mean = -4.5912057011016145e-17 - + stddev = 7.8243599529061234e-14 + + mean = -5.0611716390096536e-17 + + stddev = 8.2153148121769046e-14 - northward_wind (2 levels): + min = -3.2889066103205936e-13 + max = 3.2622646484939685e-13 - + mean = -1.6387923157531297e-17 - + stddev = 3.1304178493999455e-14 + + mean = -1.8065427102790403e-17 + + stddev = 3.2868334756832761e-14 Norm of input parameter inflation: 6.9558608381710329e+01 -Norm of input parameter StdDev: 1.7389652095427326e+02 +Norm of input parameter StdDev: 1.6562608490210712e+02 Independent levels: 1[2] Subset Sc0 size: 762 Domain area (% of Earth area): 0.100E+03% @@ -195,10 +195,10 @@ Covariance(SABER2_SABER) * Increment: - eastward_wind (2 levels): + min = -9.8410844401244119e-02 + max = 1.8666458547182987e+00 - + mean = 5.3875643790388195e-03 - + stddev = 6.5840774440359615e-02 + + mean = 5.9390473469719271e-03 + + stddev = 6.9106891392590200e-02 - northward_wind (2 levels): + min = -3.3993491007083354e-01 + max = 2.4278308907565277e-01 - + mean = -7.2339261434053331e-04 - + stddev = 1.6059271651059630e-02 + + mean = -7.9744067722578474e-04 + + stddev = 1.6859943227676515e-02 diff --git a/test/testref/dirac_bump_4.ref b/test/testref/dirac_bump_4.ref index 7f5bbf815..8ede03406 100644 --- a/test/testref/dirac_bump_4.ref +++ b/test/testref/dirac_bump_4.ref @@ -5,8 +5,8 @@ Input Dirac increment: - eastward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - northward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -45,7 +45,7 @@ Adjoint test for block BUMP_PsiChiToUV passed nc2 = 250 Independent levels: 1[2] Adjoint test for block BUMP_VerticalBalance passed -Norm of input parameter StdDev: 5.7680980822377037e+01 +Norm of input parameter StdDev: 5.4937700734311314e+01 Adjoint test for block StdDev passed Independent levels: 1[2] Subset Sc0 size: 762 @@ -73,10 +73,10 @@ Covariance(SABER) * Increment: - eastward_wind (2 levels): + min = -1.1180406851300660e-13 + max = 4.8368615066963737e-13 - + mean = -3.1447386451655583e-17 - + stddev = 2.1195330277960143e-14 + + mean = -3.4666410261667569e-17 + + stddev = 2.2254381862524519e-14 - northward_wind (2 levels): + min = -1.1317635373365775e-13 + max = 9.8194133038862649e-14 - + mean = -3.5509470889124707e-17 - + stddev = 7.0752977072541914e-15 + + mean = -3.9144298617932743e-17 + + stddev = 7.4288151939973885e-15 diff --git a/test/testref/dirac_bump_5.ref b/test/testref/dirac_bump_5.ref index ea817118a..1d4965af6 100644 --- a/test/testref/dirac_bump_5.ref +++ b/test/testref/dirac_bump_5.ref @@ -5,9 +5,9 @@ Input Dirac increment: - air_horizontal_streamfunction (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 -Norm of input parameter StdDev: 4.0927842008386371e+01 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 +Norm of input parameter StdDev: 3.8981333255790183e+01 Independent levels: 1[2] Subset Sc0 size: 762 Domain area (% of Earth area): 0.100E+03% @@ -25,5 +25,5 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction (2 levels): + min = -1.6802300728670217e-02 + max = 1.2608232812918880e+00 - + mean = 3.7303249108450731e-03 - + stddev = 4.3794802759859822e-02 + + mean = 4.1121691930575610e-03 + + stddev = 4.5965982709855774e-02 diff --git a/test/testref/dirac_bump_6.ref b/test/testref/dirac_bump_6.ref index a035c4114..d152ad82f 100644 --- a/test/testref/dirac_bump_6.ref +++ b/test/testref/dirac_bump_6.ref @@ -5,8 +5,8 @@ Input Dirac increment: - eastward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - northward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -19,13 +19,13 @@ Covariance(hybrid) * Increment: - eastward_wind (2 levels): + min = -6.0918753181843444e-01 + max = 9.0019572469053788e-01 - + mean = 5.4334171450821429e-02 - + stddev = 1.8849027087357473e-01 + + mean = 4.9944483467209110e-02 + + stddev = 1.9720463112584824e-01 - northward_wind (2 levels): + min = -5.9337315609450869e-01 + max = 5.9924954825054466e-01 - + mean = -3.0873698112460064e-02 - + stddev = 1.8998905622939607e-01 + + mean = -1.5150635424641333e-02 + + stddev = 1.9061663485918223e-01 Adjoint test for block Ensemble passed Square-root test for block Ensemble passed Covariance(hybrid1_SABER) * Increment: @@ -35,13 +35,13 @@ Covariance(hybrid1_SABER) * Increment: - eastward_wind (2 levels): + min = -6.0918753181843444e-01 + max = 9.0019572469053788e-01 - + mean = 5.4334171450821429e-02 - + stddev = 1.8849027087357473e-01 + + mean = 4.9944483467209110e-02 + + stddev = 1.9720463112584824e-01 - northward_wind (2 levels): + min = -5.9337315609450869e-01 + max = 5.9924954825054466e-01 - + mean = -3.0873698112460064e-02 - + stddev = 1.8998905622939607e-01 + + mean = -1.5150635424641333e-02 + + stddev = 1.9061663485918223e-01 Covariance(hybrid2_ensemble) * Increment: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -49,10 +49,10 @@ Covariance(hybrid2_ensemble) * Increment: - eastward_wind (2 levels): + min = -6.0918753181843444e-01 + max = 9.0019572469053788e-01 - + mean = 5.4334171450821429e-02 - + stddev = 1.8849027087357473e-01 + + mean = 4.9944483467209110e-02 + + stddev = 1.9720463112584824e-01 - northward_wind (2 levels): + min = -5.9337315609450869e-01 + max = 5.9924954825054466e-01 - + mean = -3.0873698112460064e-02 - + stddev = 1.8998905622939607e-01 + + mean = -1.5150635424641333e-02 + + stddev = 1.9061663485918223e-01 diff --git a/test/testref/dirac_bump_7.ref b/test/testref/dirac_bump_7.ref index 01e2631dd..ecb355334 100644 --- a/test/testref/dirac_bump_7.ref +++ b/test/testref/dirac_bump_7.ref @@ -5,8 +5,8 @@ Input Dirac increment: - air_horizontal_streamfunction (4 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 7.5483091787439610e-05 - + stddev = 8.6881005857098320e-03 + + mean = 7.8864353312302845e-05 + + stddev = 8.8805604165660551e-03 - air_horizontal_velocity_potential (4 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -29,7 +29,7 @@ Input Dirac increment: Level 4 ~> -0.110E+02 vert. coord. nc2 = 89 Adjoint test for block BUMP_VerticalBalance passed -Norm of input parameter StdDev: 3.2367672341787326e+08 +Norm of input parameter StdDev: 3.1578046935875434e+08 Adjoint test for block StdDev passed Independent levels: 1[4] Subset Sc0 size: 3170 @@ -56,20 +56,20 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction (4 levels): + min = 0.0000000000000000e+00 + max = 1.8469444016187473e+11 - + mean = 3.7733726706371236e+08 - + stddev = 3.3692214244892201e+09 + + mean = 3.9424007208675563e+08 + + stddev = 3.4428949422448797e+09 - air_horizontal_velocity_potential (4 levels): + min = -1.5989489025175310e+10 + max = 2.2623843579742928e+09 - + mean = -1.5181535109793458e+07 - + stddev = 3.2678163210308504e+08 + + mean = -1.5861591256667487e+07 + + stddev = 3.3400495367609161e+08 - air_temperature (4 levels): + min = -9.2229049075069884e+02 + max = 1.0906852162207463e+03 - + mean = -1.5969869438954791e+00 - + stddev = 4.2229052718745059e+01 + + mean = -1.6685238984800714e+00 + + stddev = 4.3163205906791966e+01 - air_pressure_at_surface (1 levels): + min = -9.0277267821932714e+00 + max = 4.5355755608299241e+01 - + mean = 2.4967278064801521e-01 - + stddev = 2.1839177835980430e+00 + + mean = 2.6085686104297362e-01 + + stddev = 2.2316575289774669e+00 diff --git a/test/testref/dirac_bump_8.ref b/test/testref/dirac_bump_8.ref index 1579b56f5..21143aeb1 100644 --- a/test/testref/dirac_bump_8.ref +++ b/test/testref/dirac_bump_8.ref @@ -5,8 +5,8 @@ Input Dirac increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 1.3661202185792350e-04 - + stddev = 1.1688114555304096e-02 + + mean = 1.4120304998587970e-04 + + stddev = 1.1882888957904500e-02 Independent levels: 1[1] Subset Sc0 size: 7082 Domain area (% of Earth area): 0.100E+03% @@ -40,5 +40,5 @@ Covariance(SABER) * Increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000004e+00 - + mean = 1.2785311518591958e-02 - + stddev = 8.7900170586582671e-02 + + mean = 1.3214978864175818e-02 + + stddev = 8.9333392817362800e-02 diff --git a/test/testref/dirac_bump_9.ref b/test/testref/dirac_bump_9.ref index b777c1df8..9aef5c2c2 100644 --- a/test/testref/dirac_bump_9.ref +++ b/test/testref/dirac_bump_9.ref @@ -5,8 +5,8 @@ Input Dirac increment: - eastward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - northward_wind (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -49,23 +49,23 @@ Covariance(SABER) * Increment: - eastward_wind (2 levels): + min = -3.1269741016308245e-07 + max = 3.1482951073975203e-07 - + mean = -7.5306696776678983e-12 - + stddev = 2.7067069098061718e-08 + + mean = -8.3015256289252426e-12 + + stddev = 2.8419512658076549e-08 - northward_wind (2 levels): + min = -3.1559019478626723e-07 + max = 3.0648834604559019e-07 - + mean = -1.0514706686774669e-11 - + stddev = 2.7176392011429165e-08 + + mean = -1.1591015245263414e-11 + + stddev = 2.8534297936445445e-08 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: - eastward_wind (2 levels): + min = -3.1269741016308245e-07 + max = 3.1482951073975203e-07 - + mean = -7.5306696776678983e-12 - + stddev = 2.7067069098061718e-08 + + mean = -8.3015256289252426e-12 + + stddev = 2.8419512658076549e-08 - northward_wind (2 levels): + min = -3.1559019478626723e-07 + max = 3.0648834604559019e-07 - + mean = -1.0514706686774669e-11 - + stddev = 2.7176392011429165e-08 + + mean = -1.1591015245263414e-11 + + stddev = 2.8534297936445445e-08 diff --git a/test/testref/dirac_ens_noloc_4d.ref b/test/testref/dirac_ens_noloc_4d.ref index 1e07c86c8..7626f781a 100644 --- a/test/testref/dirac_ens_noloc_4d.ref +++ b/test/testref/dirac_ens_noloc_4d.ref @@ -5,8 +5,8 @@ Input Dirac increment: - air_horizontal_streamfunction (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: @@ -27,13 +27,13 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction (2 levels): + min = -6.8765396272687607e-01 + max = 1.2673127220262925e+00 - + mean = 4.6285344144401741e-03 - + stddev = 2.0707655532132521e-01 + + mean = 6.1515759052519995e-03 + + stddev = 2.1202602661901951e-01 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: - air_horizontal_streamfunction (2 levels): + min = -6.3223223183946753e-01 + max = 8.5701257601057379e-01 - + mean = 8.9370595963012375e-02 - + stddev = 2.0431101227838760e-01 + + mean = 8.4958279386268182e-02 + + stddev = 2.1336016670123578e-01 diff --git a/test/testref/dirac_fastlam-fftw_1.ref b/test/testref/dirac_fastlam-fftw_1.ref index 64d965ce1..425082991 100644 --- a/test/testref/dirac_fastlam-fftw_1.ref +++ b/test/testref/dirac_fastlam-fftw_1.ref @@ -15,8 +15,8 @@ Input Dirac increment: + max = 1.0000000000000000e+00 + mean = 2.3917087430241827e-03 + stddev = 4.8853072639868877e-02 -Norm of input parameter rh: 6.3308838310007071e+06 -Norm of input parameter rv: 1.0775159836059709e+03 +Norm of input parameter rh: 6.3308838310007285e+06 +Norm of input parameter rv: 1.0775159836059729e+03 FastLAM interpolation accuracy test passed FastLAM interpolation adjoint test passed FastLAM redToRows test passed @@ -41,13 +41,13 @@ Norm of input parameter rv: 1.0775159836059709e+03 FastLAM interpolation adjoint test passed FastLAM redToRows test passed FastLAM rowsToCols test passed -Norm of output parameter normalized horizontal length-scale: 1.6816038008313440e+03 -Norm of output parameter weight - 0: 5.3790456634123437e+01 -Norm of output parameter weight - 1: 1.3057380787119047e+02 -Norm of output parameter weight - 2: 6.3154842282495004e+01 -Norm of output parameter normalization - 0: 2.1677233100030520e+02 -Norm of output parameter normalization - 1: 2.3007829726077927e+02 -Norm of output parameter normalization - 2: 2.3222849902864127e+02 +Norm of output parameter normalized horizontal length-scale: 2.3313233051717557e+03 +Norm of output parameter weight - 0: 7.1411305064704095e+01 +Norm of output parameter weight - 1: 1.8142158345688827e+02 +Norm of output parameter weight - 2: 8.7308306621531173e+01 +Norm of output parameter normalization - 0: 3.0036225957111645e+02 +Norm of output parameter normalization - 1: 3.1870208974438600e+02 +Norm of output parameter normalization - 2: 3.2182807170911502e+02 Adjoint test for block FastLAM passed Square-root test for block FastLAM passed Covariance(SABER) * Increment: @@ -64,6 +64,6 @@ Covariance(SABER) * Increment: + max = 0.0000000000000000e+00 - air_pressure_at_surface (1 levels): + min ~ 0 - + max = 1.0000000000000004e+00 - + mean = 7.0330510023547260e-02 + + max = 1.0000000000000002e+00 + + mean = 7.0330510023547274e-02 + stddev = 1.7302913404462233e-01 diff --git a/test/testref/dirac_fastlam-fftw_2.ref b/test/testref/dirac_fastlam-fftw_2.ref index 046748c42..7cdaf2565 100644 --- a/test/testref/dirac_fastlam-fftw_2.ref +++ b/test/testref/dirac_fastlam-fftw_2.ref @@ -15,12 +15,12 @@ Input Dirac increment: + max = 1.0000000000000000e+00 + mean = 2.3917087430241827e-03 + stddev = 4.8853072639868877e-02 -Norm of input parameter weight_0: 5.3790456634123437e+01 -Norm of input parameter weight_1: 1.3057380787119047e+02 -Norm of input parameter weight_2: 6.3154842282495004e+01 -Norm of input parameter normalization_0: 2.1677233100030520e+02 -Norm of input parameter normalization_1: 2.3007829726077927e+02 -Norm of input parameter normalization_2: 2.3222849902864127e+02 +Norm of input parameter weight_0: 7.1411305064704095e+01 +Norm of input parameter weight_1: 1.8142158345688827e+02 +Norm of input parameter weight_2: 8.7308306621531173e+01 +Norm of input parameter normalization_0: 3.0036225957111645e+02 +Norm of input parameter normalization_1: 3.1870208974438600e+02 +Norm of input parameter normalization_2: 3.2182807170911502e+02 FastLAM interpolation accuracy test passed FastLAM interpolation adjoint test passed FastLAM interpolation accuracy test passed diff --git a/test/testref/dirac_fastlam_1.ref b/test/testref/dirac_fastlam_1.ref index 3eead63f1..f10bf461c 100644 --- a/test/testref/dirac_fastlam_1.ref +++ b/test/testref/dirac_fastlam_1.ref @@ -23,9 +23,9 @@ Input Dirac increment: FastLAM interpolation adjoint test passed FastLAM redToRows test passed FastLAM rowsToCols test passed -Norm of output parameter normalized horizontal length-scale: 1.6276513347797022e+03 -Norm of output parameter weight - 0: 2.0345269720502603e+02 -Norm of output parameter normalization - 0: 2.1747388285958215e+02 +Norm of output parameter normalized horizontal length-scale: 2.2489235044958818e+03 +Norm of output parameter weight - 0: 2.8111029863738537e+02 +Norm of output parameter normalization - 0: 3.0048335065758755e+02 Adjoint test for block FastLAM passed Square-root test for block FastLAM passed Covariance(SABER) * Increment: diff --git a/test/testref/dirac_fastlam_2.ref b/test/testref/dirac_fastlam_2.ref index 7733c5169..ab902ee50 100644 --- a/test/testref/dirac_fastlam_2.ref +++ b/test/testref/dirac_fastlam_2.ref @@ -37,13 +37,13 @@ Input Dirac increment: FastLAM interpolation adjoint test passed FastLAM redToRows test passed FastLAM rowsToCols test passed -Norm of output parameter normalized horizontal length-scale: 1.6165156190671885e+03 -Norm of output parameter weight - 0: 9.0923150181530062e+01 -Norm of output parameter weight - 1: 1.0144433228980117e+02 -Norm of output parameter weight - 2: 8.3073295733448305e+01 -Norm of output parameter normalization - 0: 2.2516083858506289e+02 -Norm of output parameter normalization - 1: 2.3912664898492469e+02 -Norm of output parameter normalization - 2: 2.3882479326608188e+02 +Norm of output parameter normalized horizontal length-scale: 2.2328019811953645e+03 +Norm of output parameter weight - 0: 1.2274175180803287e+02 +Norm of output parameter weight - 1: 1.4060679485952969e+02 +Norm of output parameter weight - 2: 1.1703622545681110e+02 +Norm of output parameter normalization - 0: 3.1160107964985599e+02 +Norm of output parameter normalization - 1: 3.3175830521613460e+02 +Norm of output parameter normalization - 2: 3.3132320551859749e+02 Adjoint test for block FastLAM passed Square-root test for block FastLAM passed Covariance(SABER) * Increment: diff --git a/test/testref/dirac_fastlam_3.ref b/test/testref/dirac_fastlam_3.ref index 62a33b623..8ab635818 100644 --- a/test/testref/dirac_fastlam_3.ref +++ b/test/testref/dirac_fastlam_3.ref @@ -15,8 +15,8 @@ Input Dirac increment: + max = 1.0000000000000000e+00 + mean = 2.3917087430241827e-03 + stddev = 4.8853072639868877e-02 -Norm of input parameter rh: 6.3308838310007071e+06 -Norm of input parameter rv: 1.0775159836059709e+03 +Norm of input parameter rh: 6.3308838310007285e+06 +Norm of input parameter rv: 1.0775159836059729e+03 FastLAM interpolation accuracy test passed FastLAM interpolation adjoint test passed FastLAM redToRows test passed @@ -41,13 +41,13 @@ Norm of input parameter rv: 1.0775159836059709e+03 FastLAM interpolation adjoint test passed FastLAM redToRows test passed FastLAM rowsToCols test passed -Norm of output parameter normalized horizontal length-scale: 1.6816038008313440e+03 -Norm of output parameter weight - 0: 5.3790456634123437e+01 -Norm of output parameter weight - 1: 1.3057380787119047e+02 -Norm of output parameter weight - 2: 6.3154842282495004e+01 -Norm of output parameter normalization - 0: 2.1677233100030520e+02 -Norm of output parameter normalization - 1: 2.2989134729441452e+02 -Norm of output parameter normalization - 2: 2.3186451565831479e+02 +Norm of output parameter normalized horizontal length-scale: 2.3313233051717557e+03 +Norm of output parameter weight - 0: 7.1411305064704095e+01 +Norm of output parameter weight - 1: 1.8142158345688827e+02 +Norm of output parameter weight - 2: 8.7308306621531173e+01 +Norm of output parameter normalization - 0: 3.0036225957111645e+02 +Norm of output parameter normalization - 1: 3.1844372699504385e+02 +Norm of output parameter normalization - 2: 3.2132167485384309e+02 Adjoint test for block FastLAM passed Square-root test for block FastLAM passed Covariance(SABER) * Increment: diff --git a/test/testref/dirac_fastlam_4.ref b/test/testref/dirac_fastlam_4.ref index 3b2559893..4e8764f24 100644 --- a/test/testref/dirac_fastlam_4.ref +++ b/test/testref/dirac_fastlam_4.ref @@ -15,12 +15,12 @@ Input Dirac increment: + max = 1.0000000000000000e+00 + mean = 2.3917087430241827e-03 + stddev = 4.8853072639868877e-02 -Norm of input parameter weight_0: 5.3790456634123437e+01 -Norm of input parameter weight_1: 1.3057380787119047e+02 -Norm of input parameter weight_2: 6.3154842282495004e+01 -Norm of input parameter normalization_0: 2.1677233100030520e+02 -Norm of input parameter normalization_1: 2.2989134729441452e+02 -Norm of input parameter normalization_2: 2.3186451565831479e+02 +Norm of input parameter weight_0: 7.1411305064704095e+01 +Norm of input parameter weight_1: 1.8142158345688827e+02 +Norm of input parameter weight_2: 8.7308306621531173e+01 +Norm of input parameter normalization_0: 3.0036225957111645e+02 +Norm of input parameter normalization_1: 3.1844372699504385e+02 +Norm of input parameter normalization_2: 3.2132167485384309e+02 FastLAM interpolation accuracy test passed FastLAM interpolation adjoint test passed FastLAM redToRows test passed diff --git a/test/testref/dirac_fastlam_5.ref b/test/testref/dirac_fastlam_5.ref index 2ef68abd2..b373dc28b 100644 --- a/test/testref/dirac_fastlam_5.ref +++ b/test/testref/dirac_fastlam_5.ref @@ -13,12 +13,12 @@ Input Dirac increment: - air_pressure_at_surface (1 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 -Norm of input parameter weight_0: 5.3790456634123437e+01 -Norm of input parameter weight_1: 1.3057380787119047e+02 -Norm of input parameter weight_2: 6.3154842282495004e+01 -Norm of input parameter normalization_0: 2.1677233100030520e+02 -Norm of input parameter normalization_1: 2.2989134729441452e+02 -Norm of input parameter normalization_2: 2.3186451565831479e+02 +Norm of input parameter weight_0: 7.1411305064704095e+01 +Norm of input parameter weight_1: 1.8142158345688827e+02 +Norm of input parameter weight_2: 8.7308306621531173e+01 +Norm of input parameter normalization_0: 3.0036225957111645e+02 +Norm of input parameter normalization_1: 3.1844372699504385e+02 +Norm of input parameter normalization_2: 3.2132167485384309e+02 FastLAM interpolation accuracy test passed FastLAM interpolation adjoint test passed FastLAM redToRows test passed diff --git a/test/testref/dirac_fastlam_6.ref b/test/testref/dirac_fastlam_6.ref index 48f7338fa..13181f0b7 100644 --- a/test/testref/dirac_fastlam_6.ref +++ b/test/testref/dirac_fastlam_6.ref @@ -15,12 +15,12 @@ Input Dirac increment: + max = 1.0000000000000000e+00 + mean = 2.3917087430241827e-03 + stddev = 4.8853072639868877e-02 -Norm of input parameter weight_0: 5.3790456634123437e+01 -Norm of input parameter weight_1: 1.3057380787119047e+02 -Norm of input parameter weight_2: 6.3154842282495004e+01 -Norm of input parameter normalization_0: 2.1677233100030520e+02 -Norm of input parameter normalization_1: 2.2989134729441452e+02 -Norm of input parameter normalization_2: 2.3186451565831479e+02 +Norm of input parameter weight_0: 7.1411305064704095e+01 +Norm of input parameter weight_1: 1.8142158345688827e+02 +Norm of input parameter weight_2: 8.7308306621531173e+01 +Norm of input parameter normalization_0: 3.0036225957111645e+02 +Norm of input parameter normalization_1: 3.1844372699504385e+02 +Norm of input parameter normalization_2: 3.2132167485384309e+02 FastLAM interpolation accuracy test passed FastLAM interpolation adjoint test passed FastLAM redToRows test passed diff --git a/test/testref/dirac_fastlam_8.ref b/test/testref/dirac_fastlam_8.ref index d606ad330..46d5f2180 100644 --- a/test/testref/dirac_fastlam_8.ref +++ b/test/testref/dirac_fastlam_8.ref @@ -15,8 +15,8 @@ Input Dirac increment: + max = 1.0000000000000000e+00 + mean = 2.3917087430241827e-03 + stddev = 4.8853072639868877e-02 -Norm of input parameter rh: 6.3308838310007071e+06 -Norm of input parameter rv: 1.0775159836059709e+03 +Norm of input parameter rh: 6.3308838310007285e+06 +Norm of input parameter rv: 1.0775159836059729e+03 FastLAM interpolation accuracy test passed FastLAM interpolation adjoint test passed FastLAM interpolation accuracy test passed @@ -29,13 +29,13 @@ Norm of input parameter rv: 1.0775159836059709e+03 FastLAM interpolation adjoint test passed FastLAM interpolation accuracy test passed FastLAM interpolation adjoint test passed -Norm of output parameter normalized horizontal length-scale: 1.6816038008313440e+03 -Norm of output parameter weight - 0: 5.3790456634123437e+01 -Norm of output parameter weight - 1: 1.3057380787119047e+02 -Norm of output parameter weight - 2: 6.3154842282495004e+01 -Norm of output parameter normalization - 0: 2.1677233100030520e+02 -Norm of output parameter normalization - 1: 2.2989134729441452e+02 -Norm of output parameter normalization - 2: 2.3186451565831479e+02 +Norm of output parameter normalized horizontal length-scale: 2.3313233051717557e+03 +Norm of output parameter weight - 0: 7.1411305064704095e+01 +Norm of output parameter weight - 1: 1.8142158345688827e+02 +Norm of output parameter weight - 2: 8.7308306621531173e+01 +Norm of output parameter normalization - 0: 3.0036225957111645e+02 +Norm of output parameter normalization - 1: 3.1844372699504385e+02 +Norm of output parameter normalization - 2: 3.2132167485384309e+02 Adjoint test for block FastLAM passed Square-root test for block FastLAM passed Covariance(SABER) * Increment: diff --git a/test/testref/dirac_fastlam_9.ref b/test/testref/dirac_fastlam_9.ref index cbcca3fad..0ed5c974c 100644 --- a/test/testref/dirac_fastlam_9.ref +++ b/test/testref/dirac_fastlam_9.ref @@ -15,12 +15,12 @@ Input Dirac increment: + max = 1.0000000000000000e+00 + mean = 2.3917087430241827e-03 + stddev = 4.8853072639868877e-02 -Norm of input parameter weight_0: 5.3790456634123437e+01 -Norm of input parameter weight_1: 1.3057380787119047e+02 -Norm of input parameter weight_2: 6.3154842282495004e+01 -Norm of input parameter normalization_0: 2.1677233100030520e+02 -Norm of input parameter normalization_1: 2.2989134729441452e+02 -Norm of input parameter normalization_2: 2.3186451565831479e+02 +Norm of input parameter weight_0: 7.1411305064704095e+01 +Norm of input parameter weight_1: 1.8142158345688827e+02 +Norm of input parameter weight_2: 8.7308306621531173e+01 +Norm of input parameter normalization_0: 3.0036225957111645e+02 +Norm of input parameter normalization_1: 3.1844372699504385e+02 +Norm of input parameter normalization_2: 3.2132167485384309e+02 FastLAM interpolation accuracy test passed FastLAM interpolation adjoint test passed FastLAM interpolation accuracy test passed diff --git a/test/testref/dirac_gsi_geos_global.ref b/test/testref/dirac_gsi_geos_global.ref index 1f0db2946..eb3dbf948 100644 --- a/test/testref/dirac_gsi_geos_global.ref +++ b/test/testref/dirac_gsi_geos_global.ref @@ -5,8 +5,8 @@ Input Dirac increment: - air_horizontal_streamfunction (72 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 4.1935050993022007e-06 - + stddev = 2.0478049465962522e-03 + + mean = 4.3813529617946025e-06 + + stddev = 2.0931681637571804e-03 - air_horizontal_velocity_potential (72 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -22,8 +22,8 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction (72 levels): + min = -4.4475385881989490e+05 + max = 8.1777385772281357e+10 - + mean = 1.3587249629828656e+07 - + stddev = 5.3746442623348880e+08 + + mean = 1.4195889834067037e+07 + + stddev = 5.4936258950443614e+08 - air_horizontal_velocity_potential (72 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 diff --git a/test/testref/dirac_gsi_geos_global_opt_1.ref b/test/testref/dirac_gsi_geos_global_opt_1.ref index eba79ffc1..0666dea0e 100644 --- a/test/testref/dirac_gsi_geos_global_opt_1.ref +++ b/test/testref/dirac_gsi_geos_global_opt_1.ref @@ -5,8 +5,8 @@ Input Dirac increment: - air_horizontal_streamfunction (72 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 2.0967525496511005e-05 - + stddev = 4.5789926605260215e-03 + + mean = 2.1906764808973012e-05 + + stddev = 4.6804252886295970e-03 - air_horizontal_velocity_potential (72 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -22,8 +22,8 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction (72 levels): + min = -1.3005607204474811e-06 + max = 1.0000703458886750e+00 - + mean = 7.0196939590881410e-03 - + stddev = 4.9664916718205943e-02 + + mean = 7.3341408178233198e-03 + + stddev = 5.0742385009301789e-02 - air_horizontal_velocity_potential (72 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 diff --git a/test/testref/dirac_gsi_geos_global_opt_2.ref b/test/testref/dirac_gsi_geos_global_opt_2.ref index 1f3e3948b..c6a1b2cc3 100644 --- a/test/testref/dirac_gsi_geos_global_opt_2.ref +++ b/test/testref/dirac_gsi_geos_global_opt_2.ref @@ -5,8 +5,8 @@ Input Dirac increment: - air_horizontal_streamfunction (72 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 2.0967525496511005e-05 - + stddev = 4.5789926605260215e-03 + + mean = 2.1906764808973012e-05 + + stddev = 4.6804252886295970e-03 - air_horizontal_velocity_potential (72 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -22,8 +22,8 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction (72 levels): + min = 0.0000000000000000e+00 + max = 9.9998888073528969e-01 - + mean = 1.3368074587592572e-02 - + stddev = 5.6359040132774554e-02 + + mean = 1.3966896856185048e-02 + + stddev = 5.7534879555833383e-02 - air_horizontal_velocity_potential (72 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 diff --git a/test/testref/dirac_gsi_geos_global_opt_3.ref b/test/testref/dirac_gsi_geos_global_opt_3.ref index 18e064810..81877ebf9 100644 --- a/test/testref/dirac_gsi_geos_global_opt_3.ref +++ b/test/testref/dirac_gsi_geos_global_opt_3.ref @@ -5,8 +5,8 @@ Input Dirac increment: - air_horizontal_streamfunction (72 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 2.0967525496511005e-05 - + stddev = 4.5789926605260215e-03 + + mean = 2.1906764808973012e-05 + + stddev = 4.6804252886295970e-03 - air_horizontal_velocity_potential (72 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -22,8 +22,8 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction (72 levels): + min = -5.6713653946812356e-06 + max = 1.8938320605081864e+00 - + mean = 1.9342809448950956e-03 - + stddev = 2.3424813435276151e-02 + + mean = 2.0209269682941820e-03 + + stddev = 2.3940068023482950e-02 - air_horizontal_velocity_potential (72 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 diff --git a/test/testref/dirac_oops_ens_noloc_4d.ref b/test/testref/dirac_oops_ens_noloc_4d.ref index 77bc91df5..0667654cf 100644 --- a/test/testref/dirac_oops_ens_noloc_4d.ref +++ b/test/testref/dirac_oops_ens_noloc_4d.ref @@ -5,8 +5,8 @@ Input Dirac increment: - air_horizontal_streamfunction (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: @@ -27,13 +27,13 @@ Covariance(ensemble) * Increment: - air_horizontal_streamfunction (2 levels): + min = -6.8765396272687607e-01 + max = 1.2673127220262925e+00 - + mean = 4.6285344144401741e-03 - + stddev = 2.0707655532132521e-01 + + mean = 6.1515759052519995e-03 + + stddev = 2.1202602661901951e-01 - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] Fields: - air_horizontal_streamfunction (2 levels): + min = -6.3223223183946753e-01 + max = 8.5701257601057379e-01 - + mean = 8.9370595963012375e-02 - + stddev = 2.0431101227838760e-01 + + mean = 8.4958279386268182e-02 + + stddev = 2.1336016670123578e-01 diff --git a/test/testref/dirac_shadowlevels_1.ref b/test/testref/dirac_shadowlevels_1.ref index f0039a152..758158f1a 100644 --- a/test/testref/dirac_shadowlevels_1.ref +++ b/test/testref/dirac_shadowlevels_1.ref @@ -5,10 +5,10 @@ Input Dirac increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 1.3661202185792350e-04 - + stddev = 1.1688114555304096e-02 -Norm of output parameter rv: 5.1334199126897431e+01 -Norm of output parameter weight: 8.5556998544817148e+01 + + mean = 1.4120304998587970e-04 + + stddev = 1.1882888957904500e-02 +Norm of output parameter rv: 5.0492771759925468e+01 +Norm of output parameter weight: 8.4154619599865256e+01 Independent levels: 1[11] Subset Sc0 size: 7082 Domain area (% of Earth area): 0.100E+03% @@ -71,5 +71,5 @@ Covariance(SABER) * Increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000002e+00 - + mean = 8.9309751283082692e-03 - + stddev = 7.2568417894406059e-02 + + mean = 9.2311123890449782e-03 + + stddev = 7.3759108450242528e-02 diff --git a/test/testref/dirac_shadowlevels_2.ref b/test/testref/dirac_shadowlevels_2.ref index ccbcc788a..7802af13e 100644 --- a/test/testref/dirac_shadowlevels_2.ref +++ b/test/testref/dirac_shadowlevels_2.ref @@ -5,11 +5,11 @@ Input Dirac increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 1.3661202185792350e-04 - + stddev = 1.1688114555304096e-02 -Norm of input parameter rv: 5.1334199126897431e+01 -Norm of output parameter rv: 5.1334199126897431e+01 -Norm of output parameter weight: 8.5556998544817148e+01 + + mean = 1.4120304998587970e-04 + + stddev = 1.1882888957904500e-02 +Norm of input parameter rv: 5.0492771759925468e+01 +Norm of output parameter rv: 5.0492771759925468e+01 +Norm of output parameter weight: 8.4154619599865242e+01 Independent levels: 1[11] Subset Sc0 size: 7082 Domain area (% of Earth area): 0.100E+03% @@ -51,5 +51,5 @@ Covariance(SABER) * Increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000002e+00 - + mean = 8.9309751283082692e-03 - + stddev = 7.2568417894406059e-02 + + mean = 9.2311123890449782e-03 + + stddev = 7.3759108450242528e-02 diff --git a/test/testref/dirac_shadowlevels_3.ref b/test/testref/dirac_shadowlevels_3.ref index cfbffb43e..5154acbea 100644 --- a/test/testref/dirac_shadowlevels_3.ref +++ b/test/testref/dirac_shadowlevels_3.ref @@ -5,9 +5,9 @@ Input Dirac increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 1.3661202185792350e-04 - + stddev = 1.1688114555304096e-02 -Norm of input parameter weight: 8.5556998544817148e+01 + + mean = 1.4120304998587970e-04 + + stddev = 1.1882888957904500e-02 +Norm of input parameter weight: 8.4154619599865256e+01 Independent levels: 1[11] Subset Sc0 size: 7082 Domain area (% of Earth area): 0.100E+03% @@ -49,5 +49,5 @@ Covariance(SABER) * Increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000002e+00 - + mean = 8.9309751283082692e-03 - + stddev = 7.2568417894406059e-02 + + mean = 9.2311123890449782e-03 + + stddev = 7.3759108450242528e-02 diff --git a/test/testref/dirac_shadowlevels_4.ref b/test/testref/dirac_shadowlevels_4.ref index 953ccf331..3a5e38e64 100644 --- a/test/testref/dirac_shadowlevels_4.ref +++ b/test/testref/dirac_shadowlevels_4.ref @@ -5,10 +5,10 @@ Input Dirac increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 1.3661202185792350e-04 - + stddev = 1.1688114555304096e-02 -Norm of output parameter rv: 5.1334199126897431e+01 -Norm of output parameter weight: 8.5556998544817148e+01 + + mean = 1.4120304998587970e-04 + + stddev = 1.1882888957904500e-02 +Norm of output parameter rv: 5.0492771759925468e+01 +Norm of output parameter weight: 8.4154619599865256e+01 Independent levels: 1[11] Subset Sc0 size: 7082 Domain area (% of Earth area): 0.100E+03% @@ -61,5 +61,5 @@ Covariance(SABER) * Increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000002e+00 - + mean = 8.9309751283082692e-03 - + stddev = 7.2568417894406059e-02 + + mean = 9.2311123890449782e-03 + + stddev = 7.3759108450242528e-02 diff --git a/test/testref/dirac_shadowlevels_5.ref b/test/testref/dirac_shadowlevels_5.ref index cfbffb43e..5154acbea 100644 --- a/test/testref/dirac_shadowlevels_5.ref +++ b/test/testref/dirac_shadowlevels_5.ref @@ -5,9 +5,9 @@ Input Dirac increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 1.3661202185792350e-04 - + stddev = 1.1688114555304096e-02 -Norm of input parameter weight: 8.5556998544817148e+01 + + mean = 1.4120304998587970e-04 + + stddev = 1.1882888957904500e-02 +Norm of input parameter weight: 8.4154619599865256e+01 Independent levels: 1[11] Subset Sc0 size: 7082 Domain area (% of Earth area): 0.100E+03% @@ -49,5 +49,5 @@ Covariance(SABER) * Increment: - snow_depth (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000002e+00 - + mean = 8.9309751283082692e-03 - + stddev = 7.2568417894406059e-02 + + mean = 9.2311123890449782e-03 + + stddev = 7.3759108450242528e-02 diff --git a/test/testref/dirac_stddev_1.ref b/test/testref/dirac_stddev_1.ref index 64d0db894..871b455f8 100644 --- a/test/testref/dirac_stddev_1.ref +++ b/test/testref/dirac_stddev_1.ref @@ -5,8 +5,8 @@ Input Dirac increment: - air_horizontal_streamfunction (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - air_horizontal_velocity_potential (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -25,8 +25,8 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction (2 levels): + min = 0.0000000000000000e+00 + max = 1.2944134874642317e+00 - + mean = 7.7048421872870929e-04 - + stddev = 3.1580455421047655e-02 + + mean = 8.4935268206314419e-04 + + stddev = 3.3157405918985833e-02 - air_horizontal_velocity_potential (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 diff --git a/test/testref/dirac_stddev_2.ref b/test/testref/dirac_stddev_2.ref index 4eb2908ad..aee25f253 100644 --- a/test/testref/dirac_stddev_2.ref +++ b/test/testref/dirac_stddev_2.ref @@ -5,12 +5,12 @@ Input Dirac increment: - air_horizontal_streamfunction_alias (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - air_horizontal_velocity_potential (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 -Norm of input parameter StdDev: 5.7581328949717772e+01 +Norm of input parameter StdDev: 5.4937700734311001e+01 Adjoint test for block StdDev passed Adjoint test for block ID passed Covariance(SABER) diagnostics: @@ -25,8 +25,8 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction_alias (2 levels): + min = 0.0000000000000000e+00 + max = 1.2944134874642317e+00 - + mean = 7.7048421872870929e-04 - + stddev = 3.1580455421047655e-02 + + mean = 8.4935268206314419e-04 + + stddev = 3.3157405918985833e-02 - air_horizontal_velocity_potential (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 diff --git a/test/testref/dirac_stddev_3.ref b/test/testref/dirac_stddev_3.ref index 5559c5b08..ad0d0ff93 100644 --- a/test/testref/dirac_stddev_3.ref +++ b/test/testref/dirac_stddev_3.ref @@ -5,8 +5,8 @@ Input Dirac increment: - air_horizontal_streamfunction (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - air_horizontal_velocity_potential (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -24,8 +24,8 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction (2 levels): + min = 0.0000000000000000e+00 + max = 4.0000000000000000e+00 - + mean = 2.3809523809523812e-03 - + stddev = 9.7590007294855424e-02 + + mean = 2.6246719160104987e-03 + + stddev = 1.0246310391571045e-01 - air_horizontal_velocity_potential (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 diff --git a/test/testref/dirac_stddev_4.ref b/test/testref/dirac_stddev_4.ref index 364c6f182..41c0c24da 100644 --- a/test/testref/dirac_stddev_4.ref +++ b/test/testref/dirac_stddev_4.ref @@ -5,8 +5,8 @@ Input Dirac increment: - air_horizontal_streamfunction (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713856e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927613e-02 - air_horizontal_velocity_potential (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 @@ -25,8 +25,8 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction (2 levels): + min = 0.0000000000000000e+00 + max = 5.1776539498569267e+00 - + mean = 3.0819368749148372e-03 - + stddev = 1.2632182168419062e-01 + + mean = 3.3974107282525767e-03 + + stddev = 1.3262962367594333e-01 - air_horizontal_velocity_potential (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 diff --git a/test/testref/dirac_vader.ref b/test/testref/dirac_vader.ref index 7ce7b9850..977bd0ae9 100644 --- a/test/testref/dirac_vader.ref +++ b/test/testref/dirac_vader.ref @@ -5,13 +5,13 @@ Input Dirac increment: - virtual_temperature (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713832e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927634e-02 - water_vapor_mixing_ratio_wrt_moist_air (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713832e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927634e-02 Adjoint test for block vader variable change passed Adjoint test for block ID passed Covariance(SABER) * Increment: @@ -21,10 +21,10 @@ Covariance(SABER) * Increment: - virtual_temperature (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713832e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927634e-02 - water_vapor_mixing_ratio_wrt_moist_air (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713832e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927634e-02 diff --git a/test/testref/error_covariance_training_bump_hdiag-nicas_1.ref b/test/testref/error_covariance_training_bump_hdiag-nicas_1.ref index e3a651698..07be7e82f 100644 --- a/test/testref/error_covariance_training_bump_hdiag-nicas_1.ref +++ b/test/testref/error_covariance_training_bump_hdiag-nicas_1.ref @@ -254,20 +254,20 @@ 0.0 / 0.0: 0.0000000 Level 1: 0.0000000 - 0.0000000 Level 2: 0.0000000 - 0.0000000 -Norm of output parameter dirac_mom_cov - 1: 1.2500158242011171e+01 -Norm of output parameter dirac_mom_single_obs - 1: 9.8635151567205952e+00 -Norm of output parameter dirac_mom - 1: 1.1140868819766622e+01 +Norm of output parameter dirac_mom_cov - 1: 1.2212904526861367e+01 +Norm of output parameter dirac_mom_single_obs - 1: 9.6368515162810713e+00 +Norm of output parameter dirac_mom - 1: 1.0845447770174964e+01 Norm of output parameter dirac_diag_cor - 1: 2.1631777803087768e+00 -Norm of output parameter cor_a - 1: 4.4765456876087761e+01 -Norm of output parameter cor_a - 2: 1.3215106980456639e+01 -Norm of output parameter cor_rh1 - 1: 2.3577885766145498e+08 -Norm of output parameter cor_rh1 - 2: 1.3258819526933894e+08 -Norm of output parameter cor_rh2 - 1: 2.2702047447591832e+08 -Norm of output parameter cor_rh2 - 2: 1.2766299446225467e+08 -Norm of output parameter cor_rhc - 1: 2.3598403716974987e+00 -Norm of output parameter cor_rhc - 2: 2.3598403716974987e+00 -Norm of output parameter cor_rh - 1: 2.3099540741414040e+08 -Norm of output parameter cor_rh - 2: 1.2989826351828027e+08 -Norm of output parameter cor_rv - 1: 2.6030254068196069e+02 -Norm of output parameter cor_rv - 2: 2.6030254068299271e+01 -Norm of output parameter nicas_norm - 1: 5.8796855749647662e+01 +Norm of output parameter cor_a - 1: 4.2636432980682187e+01 +Norm of output parameter cor_a - 2: 1.2586602760794237e+01 +Norm of output parameter cor_rh1 - 1: 2.2456532702817014e+08 +Norm of output parameter cor_rh1 - 2: 1.2628236359294869e+08 +Norm of output parameter cor_rh2 - 1: 2.1622348839257264e+08 +Norm of output parameter cor_rh2 - 2: 1.2159140300008093e+08 +Norm of output parameter cor_rhc - 1: 2.2476074829636934e+00 +Norm of output parameter cor_rhc - 2: 2.2476074829636934e+00 +Norm of output parameter cor_rh - 1: 2.2000937540568423e+08 +Norm of output parameter cor_rh - 2: 1.2372036372005615e+08 +Norm of output parameter cor_rv - 1: 2.4792267531655389e+02 +Norm of output parameter cor_rv - 2: 2.4792267531753673e+01 +Norm of output parameter nicas_norm - 1: 5.6080671513490600e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag-nicas_2.ref b/test/testref/error_covariance_training_bump_hdiag-nicas_2.ref index 8db6012bf..b0d315245 100644 --- a/test/testref/error_covariance_training_bump_hdiag-nicas_2.ref +++ b/test/testref/error_covariance_training_bump_hdiag-nicas_2.ref @@ -73,10 +73,10 @@ 0.0 / 0.0: 1.0000000 Level 1: 0.0000000 - 1.0000000 Level 2: 0.0000000 - 0.9169997 -Norm of output parameter dirac_mom - 1: 7.8068320851523580e+00 +Norm of output parameter dirac_mom - 1: 7.6878267329584924e+00 Norm of output parameter dirac_diag_loc - 1: 2.7348452994402712e+00 -Norm of output parameter cor_rh - 1: 1.5260566264218614e+08 -Norm of output parameter cor_rv - 1: 1.2751131380366614e+02 -Norm of output parameter loc_rh - 1: 2.2087340516392386e+08 -Norm of output parameter loc_rv - 1: 2.3544350104096006e+02 -Norm of output parameter nicas_norm - 1: 4.2233599148489091e+01 +Norm of output parameter cor_rh - 1: 1.4700567559989282e+08 +Norm of output parameter cor_rv - 1: 1.2283222935748260e+02 +Norm of output parameter loc_rh - 1: 2.1276794919251037e+08 +Norm of output parameter loc_rv - 1: 2.2680379054766320e+02 +Norm of output parameter nicas_norm - 1: 4.0784027590857036e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag-nicas_3.ref b/test/testref/error_covariance_training_bump_hdiag-nicas_3.ref index 4eedb75d1..b8e8f15ae 100644 --- a/test/testref/error_covariance_training_bump_hdiag-nicas_3.ref +++ b/test/testref/error_covariance_training_bump_hdiag-nicas_3.ref @@ -148,9 +148,9 @@ 0.0 / 0.0: 1.0000000 Level 1: 0.0000000 - 1.0000000 Level 2: 0.0000000 - 0.9241828 -Norm of output parameter loc_rh - 1: 2.1629752432907832e+08 -Norm of output parameter loc_rv - 1: 2.0069781305357549e+02 -Norm of output parameter hyb_coef_ens - 1: 2.2874214054211610e+01 -Norm of output parameter hyb_coef_ens_lr - 1: 2.4476774687110016e+01 -Norm of output parameter loc_rh_lr - 1: 2.2164649563253525e+08 -Norm of output parameter loc_rv_lr - 1: 2.4741780353859116e+02 +Norm of output parameter loc_rh - 1: 2.0765313355080462e+08 +Norm of output parameter loc_rv - 1: 1.9267686907947714e+02 +Norm of output parameter hyb_coef_ens - 1: 2.1960039721223747e+01 +Norm of output parameter hyb_coef_ens_lr - 1: 2.3498553572266275e+01 +Norm of output parameter loc_rh_lr - 1: 2.1589887876004183e+08 +Norm of output parameter loc_rv_lr - 1: 2.4100189906820731e+02 diff --git a/test/testref/error_covariance_training_bump_hdiag-nicas_4.ref b/test/testref/error_covariance_training_bump_hdiag-nicas_4.ref index 8068f869b..a5081ef5d 100644 --- a/test/testref/error_covariance_training_bump_hdiag-nicas_4.ref +++ b/test/testref/error_covariance_training_bump_hdiag-nicas_4.ref @@ -492,13 +492,13 @@ Min / max: 1.0000000 / 1.0000000 over 10 tests Level 1: missing values Norm of output parameter dirac_diag_cor - 1: 2.2704826206090196e+00 -Norm of output parameter cor_a - 1: 9.3374728915269699e+01 -Norm of output parameter cor_a - 2: 6.2249819276845237e+01 -Norm of output parameter cor_a - 3: 5.1874849397371747e+01 -Norm of output parameter cor_rh - 1: 9.4720567632166815e+08 -Norm of output parameter cor_rh - 2: 4.4556555014170587e+08 -Norm of output parameter cor_rh - 3: 2.7847846883856916e+08 -Norm of output parameter cor_rv - 1: 1.3396492944638217e+03 -Norm of output parameter cor_rv - 2: 1.3396492944638217e+03 -Norm of output parameter cor_rv - 3: 1.3396492944638217e+03 +Norm of output parameter cor_a - 1: 9.1351108367689449e+01 +Norm of output parameter cor_a - 2: 6.0900738911788849e+01 +Norm of output parameter cor_a - 3: 5.0750615759811232e+01 +Norm of output parameter cor_rh - 1: 9.2529308367175138e+08 +Norm of output parameter cor_rh - 2: 4.3525786655918783e+08 +Norm of output parameter cor_rh - 3: 2.7203616659950030e+08 +Norm of output parameter cor_rv - 1: 1.2904833987685040e+03 +Norm of output parameter cor_rv - 2: 1.2904833987685040e+03 +Norm of output parameter cor_rv - 3: 1.2904833987685040e+03 Norm of output parameter dirac_nicas - 1: 1.7815332031684092e+00 diff --git a/test/testref/error_covariance_training_bump_hdiag_1.ref b/test/testref/error_covariance_training_bump_hdiag_1.ref index 137f9d033..0f493ec40 100644 --- a/test/testref/error_covariance_training_bump_hdiag_1.ref +++ b/test/testref/error_covariance_training_bump_hdiag_1.ref @@ -178,15 +178,15 @@ Level: 1 ~> amplitude: 0.22 cor. hor. support: 2051.93 km cor. ver. support: 0.00 vertical units -Norm of output parameter cor_a - 1: 5.2697854449896354e+01 -Norm of output parameter cor_a - 2: 1.2479353895019516e+01 -Norm of output parameter cor_rh1 - 1: 2.6801283878373799e+08 -Norm of output parameter cor_rh1 - 2: 2.3656076996689144e+08 -Norm of output parameter cor_rh2 - 1: 2.6207219546233454e+08 -Norm of output parameter cor_rh2 - 2: 2.1754805093985686e+08 -Norm of output parameter cor_rhc - 1: 6.8468082398742682e+00 -Norm of output parameter cor_rhc - 2: 6.8468082398742682e+00 -Norm of output parameter cor_rh - 1: 2.6295483142851543e+08 -Norm of output parameter cor_rh - 2: 2.2526585296569565e+08 -Norm of output parameter cor_rv - 1: 2.0132187653859617e+02 -Norm of output parameter cor_rv - 2: 5.1733570676955885e+01 +Norm of output parameter cor_a - 1: 5.0218339249789111e+01 +Norm of output parameter cor_a - 2: 1.1849155871116496e+01 +Norm of output parameter cor_rh1 - 1: 2.5455700279515421e+08 +Norm of output parameter cor_rh1 - 2: 2.2474155045620644e+08 +Norm of output parameter cor_rh2 - 1: 2.5091913683524990e+08 +Norm of output parameter cor_rh2 - 2: 2.0872229410022640e+08 +Norm of output parameter cor_rhc - 1: 6.7220454101676053e+00 +Norm of output parameter cor_rhc - 2: 6.7220454101676053e+00 +Norm of output parameter cor_rh - 1: 2.5070610316108403e+08 +Norm of output parameter cor_rh - 2: 2.1506723522072381e+08 +Norm of output parameter cor_rv - 1: 1.9171192455497220e+02 +Norm of output parameter cor_rv - 2: 4.9665743067363408e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag_10.ref b/test/testref/error_covariance_training_bump_hdiag_10.ref index c37ef57ae..f0aa7b008 100644 --- a/test/testref/error_covariance_training_bump_hdiag_10.ref +++ b/test/testref/error_covariance_training_bump_hdiag_10.ref @@ -21,7 +21,7 @@ Level 8 ~> 0.800E+01 vert. coord. Level 9 ~> 0.900E+01 vert. coord. Level 10 ~> 0.100E+02 vert. coord. -Norm of input parameter sampling_mask_field - 1: 8.5914059009630591e+01 +Norm of input parameter sampling_mask_field - 1: 8.1973157798307028e+01 Norm of air_horizontal_streamfunction: 0.80209461E+02 Norm of air_horizontal_streamfunction: 0.75456249E+02 Norm of air_horizontal_streamfunction: 0.76425346E+02 @@ -131,5 +131,5 @@ Norm of input parameter sampling_mask_field - 1: 8.5914059009630591e+01 Level: 10 ~> amplitude: 1.00 cor. hor. support: 3625.73 km cor. ver. support: 6.05 vertical units -Norm of output parameter cor_rh - 1: 4.0839101846948618e+08 -Norm of output parameter cor_rv - 1: 6.0004320754849175e+02 +Norm of output parameter cor_rh - 1: 9.2054068643549388e+39 +Norm of output parameter cor_rv - 1: 9.2054068643549388e+39 diff --git a/test/testref/error_covariance_training_bump_hdiag_11.ref b/test/testref/error_covariance_training_bump_hdiag_11.ref index 9b95c7d84..d44de8780 100644 --- a/test/testref/error_covariance_training_bump_hdiag_11.ref +++ b/test/testref/error_covariance_training_bump_hdiag_11.ref @@ -66,5 +66,5 @@ Level: 2 ~> amplitude: 1.00 loc. hor. support: 5009.99 km loc. ver. support: 6.48 vertical units -Norm of output parameter loc_rh - 1: 2.0235480045038003e+08 -Norm of output parameter loc_rv - 1: 2.6567119233970101e+02 +Norm of output parameter loc_rh - 1: 1.9273090212400866e+08 +Norm of output parameter loc_rv - 1: 2.5303599644796827e+02 diff --git a/test/testref/error_covariance_training_bump_hdiag_12.ref b/test/testref/error_covariance_training_bump_hdiag_12.ref index 83fe4b61e..fe63ab940 100644 --- a/test/testref/error_covariance_training_bump_hdiag_12.ref +++ b/test/testref/error_covariance_training_bump_hdiag_12.ref @@ -66,5 +66,5 @@ Level: 2 ~> amplitude: 1.00 loc. hor. support: 1358.56 km loc. ver. support: 1.32 vertical units -Norm of output parameter loc_rh - 1: 5.4933591433831722e+07 -Norm of output parameter loc_rv - 1: 5.4301988207034420e+01 +Norm of output parameter loc_rh - 1: 5.2320975881915011e+07 +Norm of output parameter loc_rv - 1: 5.1719411404995618e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag_13.ref b/test/testref/error_covariance_training_bump_hdiag_13.ref index d63b50d14..c3d9dcaac 100644 --- a/test/testref/error_covariance_training_bump_hdiag_13.ref +++ b/test/testref/error_covariance_training_bump_hdiag_13.ref @@ -66,5 +66,5 @@ Level: 2 ~> amplitude: 1.00 loc. hor. support: 1932.57 km loc. ver. support: 0.00 vertical units -Norm of output parameter loc_rh - 1: 7.8012512021133512e+07 +Norm of output parameter loc_rh - 1: 7.4302273953120500e+07 Norm of output parameter loc_rv - 1: 0.0000000000000000e+00 diff --git a/test/testref/error_covariance_training_bump_hdiag_2.ref b/test/testref/error_covariance_training_bump_hdiag_2.ref index a4d0b49ee..3ac486ab8 100644 --- a/test/testref/error_covariance_training_bump_hdiag_2.ref +++ b/test/testref/error_covariance_training_bump_hdiag_2.ref @@ -71,15 +71,15 @@ Level: 1 ~> amplitude: 0.22 cor. hor. support: 2051.93 km cor. ver. support: 0.00 vertical units -Norm of output parameter cor_a - 1: 4.0573138420656143e+01 -Norm of output parameter cor_a - 2: 1.0016349918835825e+01 -Norm of output parameter cor_rh1 - 1: 2.0262608044981116e+08 -Norm of output parameter cor_rh1 - 2: 1.8185631191836616e+08 -Norm of output parameter cor_rh2 - 1: 2.0514396612299821e+08 -Norm of output parameter cor_rh2 - 2: 1.7070189713099051e+08 -Norm of output parameter cor_rhc - 1: 5.3117324292301582e+00 -Norm of output parameter cor_rhc - 2: 5.3117324292301582e+00 -Norm of output parameter cor_rh - 1: 2.0233196534932756e+08 -Norm of output parameter cor_rh - 2: 1.7509058427340767e+08 -Norm of output parameter cor_rv - 1: 1.4378490992067410e+02 -Norm of output parameter cor_rv - 2: 4.0571190128920470e+01 +Norm of output parameter cor_a - 1: 3.8643581248204796e+01 +Norm of output parameter cor_a - 2: 9.5216412498636132e+00 +Norm of output parameter cor_rh1 - 1: 1.9271758922314209e+08 +Norm of output parameter cor_rh1 - 2: 1.7297366312669659e+08 +Norm of output parameter cor_rh2 - 1: 1.9650205600889534e+08 +Norm of output parameter cor_rh2 - 2: 1.6349602426208186e+08 +Norm of output parameter cor_rhc - 1: 5.2277140172035921e+00 +Norm of output parameter cor_rhc - 2: 5.2277140172035921e+00 +Norm of output parameter cor_rh - 1: 1.9306637261756381e+08 +Norm of output parameter cor_rh - 2: 1.6707994679060006e+08 +Norm of output parameter cor_rv - 1: 1.3679246353499241e+02 +Norm of output parameter cor_rv - 2: 3.8610084935056378e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag_3.ref b/test/testref/error_covariance_training_bump_hdiag_3.ref index 98c8d95d8..c3939d75a 100644 --- a/test/testref/error_covariance_training_bump_hdiag_3.ref +++ b/test/testref/error_covariance_training_bump_hdiag_3.ref @@ -90,15 +90,15 @@ Level: 2 ~> amplitude: 0.00 loc. hor. support: 5382.10 km loc. ver. support: 6.05 vertical units -Norm of output parameter loc_a - 1: 5.7965506984757752e+01 +Norm of output parameter loc_a - 1: 5.5208694967369041e+01 Norm of output parameter loc_a - 2: 0.0000000000000000e+00 -Norm of output parameter loc_rh1 - 1: 3.7223169496152741e+08 -Norm of output parameter loc_rh1 - 2: 3.5661743729671073e+08 -Norm of output parameter loc_rh2 - 1: 3.5174328525968367e+08 -Norm of output parameter loc_rh2 - 2: 3.3975339849065048e+08 -Norm of output parameter loc_rhc - 1: 1.0498589248437069e+01 -Norm of output parameter loc_rhc - 2: 1.0498589248437069e+01 -Norm of output parameter loc_rh - 1: 3.5396976920451140e+08 -Norm of output parameter loc_rh - 2: 3.4158324786085582e+08 -Norm of output parameter loc_rv - 1: 3.5609973483845113e+02 -Norm of output parameter loc_rv - 2: 3.3453969181853876e+02 +Norm of output parameter loc_rh1 - 1: 3.4518572695765907e+08 +Norm of output parameter loc_rh1 - 2: 3.3659879110409868e+08 +Norm of output parameter loc_rh2 - 1: 3.2503878505542541e+08 +Norm of output parameter loc_rh2 - 2: 3.1915453315735161e+08 +Norm of output parameter loc_rhc - 1: 7.9941219719818193e+00 +Norm of output parameter loc_rhc - 2: 7.9941219719818193e+00 +Norm of output parameter loc_rh - 1: 3.3017036623692876e+08 +Norm of output parameter loc_rh - 2: 3.2313220498183447e+08 +Norm of output parameter loc_rv - 1: 3.3832337555722393e+02 +Norm of output parameter loc_rv - 2: 3.2416042474428275e+02 diff --git a/test/testref/error_covariance_training_bump_hdiag_4.ref b/test/testref/error_covariance_training_bump_hdiag_4.ref index c0be341c3..2766dea93 100644 --- a/test/testref/error_covariance_training_bump_hdiag_4.ref +++ b/test/testref/error_covariance_training_bump_hdiag_4.ref @@ -170,5 +170,5 @@ Level: 2 ~> amplitude: 1.00 loc. hor. support: 5283.11 km loc. ver. support: 6.06 vertical units -Norm of output parameter loc_rh - 1: 3.5325376368375480e+08 -Norm of output parameter loc_rv - 1: 3.9174290285778045e+02 +Norm of output parameter loc_rh - 1: 3.3645318224198335e+08 +Norm of output parameter loc_rv - 1: 3.7311179621345985e+02 diff --git a/test/testref/error_covariance_training_bump_hdiag_5.ref b/test/testref/error_covariance_training_bump_hdiag_5.ref index d72ab696b..92c9c1b17 100644 --- a/test/testref/error_covariance_training_bump_hdiag_5.ref +++ b/test/testref/error_covariance_training_bump_hdiag_5.ref @@ -125,9 +125,9 @@ loc. ver. support: 6.04 vertical units Level: 1 ~> hybrid coefficients: 0.50 / 0.47 Level: 2 ~> hybrid coefficients: 0.43 / 0.52 -Norm of output parameter loc_rh - 1: 2.1629752432907832e+08 -Norm of output parameter loc_rv - 1: 2.0069781305357549e+02 -Norm of output parameter hyb_coef_ens - 1: 2.2874214054211610e+01 -Norm of output parameter hyb_coef_ens_lr - 1: 2.4476774687110016e+01 -Norm of output parameter loc_rh_lr - 1: 2.2164649563253525e+08 -Norm of output parameter loc_rv_lr - 1: 2.4741780353859116e+02 +Norm of output parameter loc_rh - 1: 2.0765313355080462e+08 +Norm of output parameter loc_rv - 1: 1.9267686907947714e+02 +Norm of output parameter hyb_coef_ens - 1: 2.1960039721223747e+01 +Norm of output parameter hyb_coef_ens_lr - 1: 2.3498553572266275e+01 +Norm of output parameter loc_rh_lr - 1: 2.1589887876004183e+08 +Norm of output parameter loc_rv_lr - 1: 2.4100189906820731e+02 diff --git a/test/testref/error_covariance_training_bump_hdiag_6.ref b/test/testref/error_covariance_training_bump_hdiag_6.ref index cddb73bb0..f586c9246 100644 --- a/test/testref/error_covariance_training_bump_hdiag_6.ref +++ b/test/testref/error_covariance_training_bump_hdiag_6.ref @@ -90,9 +90,9 @@ loc. ver. support: 6.04 vertical units Level: 1 ~> hybrid coefficients: 0.50 / 0.47 Level: 2 ~> hybrid coefficients: 0.43 / 0.52 -Norm of output parameter loc_rh - 1: 2.1629752432907832e+08 -Norm of output parameter loc_rv - 1: 2.0069781305357549e+02 -Norm of output parameter hyb_coef_ens - 1: 2.2874214054211606e+01 -Norm of output parameter hyb_coef_ens_lr - 1: 2.4476774687110016e+01 -Norm of output parameter loc_rh_lr - 1: 2.2164649563253525e+08 -Norm of output parameter loc_rv_lr - 1: 2.4741780353859116e+02 +Norm of output parameter loc_rh - 1: 2.0765313355080462e+08 +Norm of output parameter loc_rv - 1: 1.9267686907947714e+02 +Norm of output parameter hyb_coef_ens - 1: 2.1960039721223744e+01 +Norm of output parameter hyb_coef_ens_lr - 1: 2.3498553572266275e+01 +Norm of output parameter loc_rh_lr - 1: 2.1589887876004183e+08 +Norm of output parameter loc_rv_lr - 1: 2.4100189906820731e+02 diff --git a/test/testref/error_covariance_training_bump_hdiag_7.ref b/test/testref/error_covariance_training_bump_hdiag_7.ref index cddb73bb0..f586c9246 100644 --- a/test/testref/error_covariance_training_bump_hdiag_7.ref +++ b/test/testref/error_covariance_training_bump_hdiag_7.ref @@ -90,9 +90,9 @@ loc. ver. support: 6.04 vertical units Level: 1 ~> hybrid coefficients: 0.50 / 0.47 Level: 2 ~> hybrid coefficients: 0.43 / 0.52 -Norm of output parameter loc_rh - 1: 2.1629752432907832e+08 -Norm of output parameter loc_rv - 1: 2.0069781305357549e+02 -Norm of output parameter hyb_coef_ens - 1: 2.2874214054211606e+01 -Norm of output parameter hyb_coef_ens_lr - 1: 2.4476774687110016e+01 -Norm of output parameter loc_rh_lr - 1: 2.2164649563253525e+08 -Norm of output parameter loc_rv_lr - 1: 2.4741780353859116e+02 +Norm of output parameter loc_rh - 1: 2.0765313355080462e+08 +Norm of output parameter loc_rv - 1: 1.9267686907947714e+02 +Norm of output parameter hyb_coef_ens - 1: 2.1960039721223744e+01 +Norm of output parameter hyb_coef_ens_lr - 1: 2.3498553572266275e+01 +Norm of output parameter loc_rh_lr - 1: 2.1589887876004183e+08 +Norm of output parameter loc_rv_lr - 1: 2.4100189906820731e+02 diff --git a/test/testref/error_covariance_training_bump_hdiag_8.ref b/test/testref/error_covariance_training_bump_hdiag_8.ref index 7dcdea4ea..ae69a4598 100644 --- a/test/testref/error_covariance_training_bump_hdiag_8.ref +++ b/test/testref/error_covariance_training_bump_hdiag_8.ref @@ -116,7 +116,7 @@ loc. ver. support: 4.10 vertical units Level: 1 ~> hybrid coefficients: 0.44 / 0.53 Level: 2 ~> hybrid coefficients: 0.35 / 0.60 -Norm of output parameter loc_rh - 1: 2.1629752432907832e+08 -Norm of output parameter loc_rv - 1: 2.0069781305357549e+02 -Norm of output parameter hyb_coef_ens - 1: 1.9483759285911951e+01 -Norm of output parameter hyb_coef_sta - 1: 2.2655268342954784e+01 +Norm of output parameter loc_rh - 1: 2.0765313355080462e+08 +Norm of output parameter loc_rv - 1: 1.9267686907947714e+02 +Norm of output parameter hyb_coef_ens - 1: 1.8705085421661085e+01 +Norm of output parameter hyb_coef_sta - 1: 2.2109787911488581e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag_9.ref b/test/testref/error_covariance_training_bump_hdiag_9.ref index 54afa7b71..dccbeb387 100644 --- a/test/testref/error_covariance_training_bump_hdiag_9.ref +++ b/test/testref/error_covariance_training_bump_hdiag_9.ref @@ -114,7 +114,7 @@ loc. ver. support: 2.00 vertical units Level: 1 ~> hybrid coefficients: 0.38 / 0.59 Level: 2 ~> hybrid coefficients: 0.24 / 0.70 -Norm of output parameter loc_rh - 1: 4.8989794855663562e+08 -Norm of output parameter loc_rv - 1: 9.7979589711327122e+01 -Norm of output parameter hyb_coef_ens - 1: 1.5639364247045462e+01 -Norm of output parameter hyb_coef_sta - 1: 2.5491279844865922e+01 +Norm of output parameter loc_rh - 1: 4.7031904065219390e+08 +Norm of output parameter loc_rv - 1: 9.4063808130438773e+01 +Norm of output parameter hyb_coef_ens - 1: 1.5014332700824335e+01 +Norm of output parameter hyb_coef_sta - 1: 2.4902921786234842e+01 diff --git a/test/testref/error_covariance_training_bump_nicas_1.ref b/test/testref/error_covariance_training_bump_nicas_1.ref index 6513da370..502aeb0c3 100644 --- a/test/testref/error_covariance_training_bump_nicas_1.ref +++ b/test/testref/error_covariance_training_bump_nicas_1.ref @@ -65,5 +65,5 @@ MSE (exp. / th. / ratio): 0.85530401E+02 / 0.82812138E+02 / 1.033 MSE (exp. / th. / ratio): 0.73471868E+02 / 0.71256956E+02 / 1.031 MSE (exp. / th. / ratio): 0.64300540E+02 / 0.62531614E+02 / 1.028 -Norm of output parameter cor_rh - 1: 2.3186202793903100e+08 -Norm of output parameter cor_rv - 1: 1.7389652095427326e+02 +Norm of output parameter cor_rh - 1: 2.2083477986947617e+08 +Norm of output parameter cor_rv - 1: 1.6562608490210712e+02 diff --git a/test/testref/error_covariance_training_bump_nicas_10.ref b/test/testref/error_covariance_training_bump_nicas_10.ref index 4a55e56fd..7592d2d14 100644 --- a/test/testref/error_covariance_training_bump_nicas_10.ref +++ b/test/testref/error_covariance_training_bump_nicas_10.ref @@ -87,5 +87,5 @@ Level 1: 0.0000000 - 0.1000000 Level 2: 0.0000000 - 0.5720776 Level 3: 0.0000000 - 1.0000000 -Norm of output parameter cor_rh - 1: 3.0258882993263316e+08 -Norm of output parameter cor_rv - 1: 2.3004347415216978e+02 +Norm of output parameter cor_rh - 1: 2.8819784870814008e+08 +Norm of output parameter cor_rv - 1: 2.1910271563812256e+02 diff --git a/test/testref/error_covariance_training_bump_nicas_2.ref b/test/testref/error_covariance_training_bump_nicas_2.ref index b1124763d..9abb0cf8e 100644 --- a/test/testref/error_covariance_training_bump_nicas_2.ref +++ b/test/testref/error_covariance_training_bump_nicas_2.ref @@ -5,8 +5,8 @@ Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of input parameter nicas_a - 1: 4.4765456876087761e+01 -Norm of input parameter nicas_a - 2: 1.3215106980456639e+01 +Norm of input parameter nicas_a - 1: 4.2636432980682187e+01 +Norm of input parameter nicas_a - 2: 1.2586602760794237e+01 nc1( 1) = 637 nc1( 2) = 569 ns = 1206 diff --git a/test/testref/error_covariance_training_bump_nicas_3.ref b/test/testref/error_covariance_training_bump_nicas_3.ref index 3172441fa..d77ef0f0f 100644 --- a/test/testref/error_covariance_training_bump_nicas_3.ref +++ b/test/testref/error_covariance_training_bump_nicas_3.ref @@ -5,11 +5,11 @@ Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of input parameter nicas_a - 1: 4.4765456876087761e+01 -Norm of input parameter nicas_a - 2: 1.3215106980456639e+01 -Norm of input parameter rh - 1: 2.3099540741414040e+08 -Norm of input parameter rh - 2: 1.2989826351828027e+08 -Norm of input parameter nicas_norm - 1: 5.8796855749647662e+01 +Norm of input parameter nicas_a - 1: 4.2636432980682187e+01 +Norm of input parameter nicas_a - 2: 1.2586602760794237e+01 +Norm of input parameter rh - 1: 2.2000937540568423e+08 +Norm of input parameter rh - 2: 1.2372036372005615e+08 +Norm of input parameter nicas_norm - 1: 5.6080671513490600e+01 nc1( 1) = 637 nc1( 2) = 569 ns = 1206 diff --git a/test/testref/error_covariance_training_bump_nicas_4.ref b/test/testref/error_covariance_training_bump_nicas_4.ref index 47cd84a4c..f9f6c97e1 100644 --- a/test/testref/error_covariance_training_bump_nicas_4.ref +++ b/test/testref/error_covariance_training_bump_nicas_4.ref @@ -5,12 +5,12 @@ Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of input parameter a - 1: 4.4765456876087761e+01 -Norm of input parameter a - 2: 1.3215106980456639e+01 -Norm of input parameter rh - 1: 2.3099540741414040e+08 -Norm of input parameter rh - 2: 1.2989826351828027e+08 -Norm of input parameter rv - 1: 2.6030254068196069e+02 -Norm of input parameter rv - 2: 2.6030254068299271e+01 +Norm of input parameter a - 1: 4.2636432980682187e+01 +Norm of input parameter a - 2: 1.2586602760794237e+01 +Norm of input parameter rh - 1: 2.2000937540568423e+08 +Norm of input parameter rh - 2: 1.2372036372005615e+08 +Norm of input parameter rv - 1: 2.4792267531655389e+02 +Norm of input parameter rv - 2: 2.4792267531753673e+01 Effective levels: 1 2 Horizontal support radius: 4179.25 km ( 4179.25 km - 4179.25 km) Estimated nc1 from horizontal support radius: 539 diff --git a/test/testref/error_covariance_training_bump_nicas_6.ref b/test/testref/error_covariance_training_bump_nicas_6.ref index 753f8737f..4121b4b7f 100644 --- a/test/testref/error_covariance_training_bump_nicas_6.ref +++ b/test/testref/error_covariance_training_bump_nicas_6.ref @@ -10,16 +10,16 @@ Domain area (% of Earth area): 0.100E+03% Level 1 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. -Norm of input parameter a - 1: 5.2697854449896354e+01 -Norm of input parameter a - 2: 1.2479353895019516e+01 -Norm of input parameter rh1 - 1: 2.6801283878373799e+08 -Norm of input parameter rh1 - 2: 2.3656076996689144e+08 -Norm of input parameter rh2 - 1: 2.6207219546233454e+08 -Norm of input parameter rh2 - 2: 2.1754805093985686e+08 -Norm of input parameter rhc - 1: 6.8468082398742682e+00 -Norm of input parameter rhc - 2: 6.8468082398742682e+00 -Norm of input parameter rv - 1: 2.0132187653859617e+02 -Norm of input parameter rv - 2: 5.1733570676955885e+01 +Norm of input parameter a - 1: 5.0218339249789111e+01 +Norm of input parameter a - 2: 1.1849155871116496e+01 +Norm of input parameter rh1 - 1: 2.5455700279515421e+08 +Norm of input parameter rh1 - 2: 2.2474155045620644e+08 +Norm of input parameter rh2 - 1: 2.5091913683524990e+08 +Norm of input parameter rh2 - 2: 2.0872229410022640e+08 +Norm of input parameter rhc - 1: 6.7220454101676053e+00 +Norm of input parameter rhc - 2: 6.7220454101676053e+00 +Norm of input parameter rv - 1: 1.9171192455497220e+02 +Norm of input parameter rv - 2: 4.9665743067363408e+01 Effective levels: 1 2 Horizontal support radius: 3957.02 km ( 3558.57 km - 4344.25 km) Estimated nc1 from horizontal support radius: 601 diff --git a/test/testref/error_covariance_training_bump_nicas_8.ref b/test/testref/error_covariance_training_bump_nicas_8.ref index 10a11c2a6..2d4173c34 100644 --- a/test/testref/error_covariance_training_bump_nicas_8.ref +++ b/test/testref/error_covariance_training_bump_nicas_8.ref @@ -52,5 +52,5 @@ 0.0 / 0.0: 0.0000000 Level 1: 0.0000000 - 0.0000000 Level 2: 0.0000000 - 0.0000000 -Norm of output parameter cor_rh - 1: 1.8330302779823360e+08 -Norm of output parameter cor_rv - 1: 1.7389652095427326e+02 +Norm of output parameter cor_rh - 1: 1.7458522274236155e+08 +Norm of output parameter cor_rv - 1: 1.6562608490210712e+02 diff --git a/test/testref/error_covariance_training_bump_nicas_9.ref b/test/testref/error_covariance_training_bump_nicas_9.ref index c2b789388..cd425bb02 100644 --- a/test/testref/error_covariance_training_bump_nicas_9.ref +++ b/test/testref/error_covariance_training_bump_nicas_9.ref @@ -56,5 +56,5 @@ 0.0 / 0.0: 0.0000000 Level 1: 0.0000000 - 0.0000000 Level 2: 0.0000000 - 0.0000000 -Norm of output parameter cor_rh - 1: 2.3186202793903100e+08 -Norm of output parameter cor_rv - 1: 1.7389652095427326e+02 +Norm of output parameter cor_rh - 1: 2.2083477986947617e+08 +Norm of output parameter cor_rv - 1: 1.6562608490210712e+02 diff --git a/test/testref/error_covariance_training_bump_stddev_1.ref b/test/testref/error_covariance_training_bump_stddev_1.ref index f6028aa8b..2e0e06f88 100644 --- a/test/testref/error_covariance_training_bump_stddev_1.ref +++ b/test/testref/error_covariance_training_bump_stddev_1.ref @@ -29,6 +29,6 @@ Level 2: rhflt = 40000.00 km, rel. diff. = 0.13881E-01 Level 1 ~> 0.10260E+01 / 0.10260E+01 Level 2 ~> 0.10176E+01 / 0.10176E+01 -Norm of output parameter stddev - 1: 4.1431764132508441e+01 -Norm of output parameter var - 1: 4.3647126090373845e+01 -Norm of output parameter m4 - 1: 1.4624786490317160e+02 +Norm of output parameter stddev - 1: 3.9461289082714671e+01 +Norm of output parameter var - 1: 4.1855368372594072e+01 +Norm of output parameter m4 - 1: 1.4109985229983997e+02 diff --git a/test/testref/error_covariance_training_bump_stddev_2.ref b/test/testref/error_covariance_training_bump_stddev_2.ref index 5d91cd852..340bf6401 100644 --- a/test/testref/error_covariance_training_bump_stddev_2.ref +++ b/test/testref/error_covariance_training_bump_stddev_2.ref @@ -9,4 +9,4 @@ Level 2: 3 x 1000.00km, rel. diff. = 0.86137E-01 Level 1 ~> 0.10260E+01 / 0.10260E+01 Level 2 ~> 0.10176E+01 / 0.10176E+01 -Norm of output parameter stddev - 1: 5.0438858140470934e+01 +Norm of output parameter stddev - 1: 3.9461289082714693e+01 diff --git a/test/testref/error_covariance_training_bump_stddev_3.ref b/test/testref/error_covariance_training_bump_stddev_3.ref index 485035ebc..0735b65a4 100644 --- a/test/testref/error_covariance_training_bump_stddev_3.ref +++ b/test/testref/error_covariance_training_bump_stddev_3.ref @@ -9,4 +9,4 @@ Level 2 ~> 0.99927E+00 / 0.99927E+00 Level 1 ~> 0.95566E+00 / 0.95566E+00 Level 2 ~> 0.10110E+01 / 0.10110E+01 -Norm of output parameter stddev - 1: 5.7680980822377037e+01 +Norm of output parameter stddev - 1: 5.4937700734311314e+01 diff --git a/test/testref/error_covariance_training_bump_stddev_4.ref b/test/testref/error_covariance_training_bump_stddev_4.ref index 2488c3489..a3a75abf2 100644 --- a/test/testref/error_covariance_training_bump_stddev_4.ref +++ b/test/testref/error_covariance_training_bump_stddev_4.ref @@ -5,4 +5,4 @@ Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of output parameter stddev - 1: 4.0720584719730120e+01 +Norm of output parameter stddev - 1: 3.8981333255790027e+01 diff --git a/test/testref/error_covariance_training_bump_stddev_5.ref b/test/testref/error_covariance_training_bump_stddev_5.ref index ab1c7c1e1..34710e719 100644 --- a/test/testref/error_covariance_training_bump_stddev_5.ref +++ b/test/testref/error_covariance_training_bump_stddev_5.ref @@ -5,10 +5,10 @@ Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of input parameter var - 1: 4.3647126090373845e+01 -Norm of input parameter m4 - 1: 1.4624786490317160e+02 +Norm of input parameter var - 1: 4.1855368372594072e+01 +Norm of input parameter m4 - 1: 1.4109985229983997e+02 Level 1: rhflt = 40000.00 km, rel. diff. = 0.31326E-02 Level 2: rhflt = 40000.00 km, rel. diff. = 0.13881E-01 Level 1 ~> 0.10260E+01 / 0.10260E+01 Level 2 ~> 0.10176E+01 / 0.10176E+01 -Norm of output parameter stddev - 1: 4.1431764132508441e+01 +Norm of output parameter stddev - 1: 3.9461289082714671e+01 diff --git a/test/testref/error_covariance_training_bump_stddev_6.ref b/test/testref/error_covariance_training_bump_stddev_6.ref index 247fc1ae3..23e97993a 100644 --- a/test/testref/error_covariance_training_bump_stddev_6.ref +++ b/test/testref/error_covariance_training_bump_stddev_6.ref @@ -9,4 +9,4 @@ Level 2 ~> -0.500E+01 vert. coord. Level 3 ~> -0.900E+01 vert. coord. Level 4 ~> -0.110E+02 vert. coord. -Norm of output parameter stddev - 1: 3.2367672341787118e+08 +Norm of output parameter stddev - 1: 3.1578046935874122e+08 diff --git a/test/testref/error_covariance_training_bump_vbal_1.ref b/test/testref/error_covariance_training_bump_vbal_1.ref index 19f7addb7..1a67333dc 100644 --- a/test/testref/error_covariance_training_bump_vbal_1.ref +++ b/test/testref/error_covariance_training_bump_vbal_1.ref @@ -42,13 +42,13 @@ Vertical balance direct adjoint test results: T Vertical balance inverse adjoint test results: T Norm of output parameter dirac_vbal - 1: 1.0000000000000000e+00 -Norm of ensemble member 0: 5.0884761954672321e+01 -Norm of ensemble member 1: 5.5348888297491357e+01 -Norm of ensemble member 2: 5.1467356070440331e+01 -Norm of ensemble member 3: 5.3790996370429518e+01 -Norm of ensemble member 4: 5.1836602211869689e+01 -Norm of ensemble member 5: 5.7009162346403954e+01 -Norm of ensemble member 6: 5.2883179634558687e+01 -Norm of ensemble member 7: 5.8332860845365794e+01 -Norm of ensemble member 8: 6.1250251625331821e+01 -Norm of ensemble member 9: 5.2539642505675275e+01 +Norm of ensemble member 0: 4.8853077487352046e+01 +Norm of ensemble member 1: 5.1961174518855337e+01 +Norm of ensemble member 2: 5.0351716963317699e+01 +Norm of ensemble member 3: 5.1365841717526337e+01 +Norm of ensemble member 4: 4.9116172744273776e+01 +Norm of ensemble member 5: 5.4106175048723358e+01 +Norm of ensemble member 6: 5.0115447450157063e+01 +Norm of ensemble member 7: 5.5586448648836665e+01 +Norm of ensemble member 8: 5.6895013498248318e+01 +Norm of ensemble member 9: 5.2032820759491671e+01 diff --git a/test/testref/error_covariance_training_stddev_2.ref b/test/testref/error_covariance_training_stddev_2.ref new file mode 100644 index 000000000..a1997a0f6 --- /dev/null +++ b/test/testref/error_covariance_training_stddev_2.ref @@ -0,0 +1 @@ +Norm of output parameter StdDev: 5.4937700734311001e+01 diff --git a/test/testref/optimization_bump_hdiag_gsi_2.ref b/test/testref/optimization_bump_hdiag_gsi_2.ref index 64fca7b1a..7845de3cd 100644 --- a/test/testref/optimization_bump_hdiag_gsi_2.ref +++ b/test/testref/optimization_bump_hdiag_gsi_2.ref @@ -163,4 +163,4 @@ Norm of input parameter gsi_ref - 1: 2.8285238362553752e+01 Factor 1.60, horizontal MSE: 0.23831582E+03 / vertical MSE: 0.14162720E+02 Factor 1.70, horizontal MSE: 0.31556975E+03 / vertical MSE: 0.18082475E+02 Factor 1.80, horizontal MSE: 0.40200216E+03 / vertical MSE: 0.22245501E+02 -Norm of output parameter dirac_diag_cor - 1: 2.9371366052993590e+01 +Norm of output parameter dirac_diag_cor - 1: 2.9370843809358977e+01 diff --git a/test/testref/randomization_bump_nicas_L10L10.ref b/test/testref/randomization_bump_nicas_L10L10.ref index 3e1dbcd7f..7f94f8564 100644 --- a/test/testref/randomization_bump_nicas_L10L10.ref +++ b/test/testref/randomization_bump_nicas_L10L10.ref @@ -44,8 +44,8 @@ Member 0: - air_horizontal_streamfunction (10 levels): + min = -3.3509219607016236e+00 + max = 3.2589976298935079e+00 - + mean = 1.3753305747269931e-01 - + stddev = 9.2731027888408424e-01 + + mean = 1.8735071618470581e-01 + + stddev = 9.2024340833443274e-01 Member 1: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -53,8 +53,8 @@ Member 1: - air_horizontal_streamfunction (10 levels): + min = -3.9074118882479110e+00 + max = 2.9747062188943714e+00 - + mean = -3.2416776495075954e-02 - + stddev = 9.0533865679307868e-01 + + mean = 5.5631325659469899e-03 + + stddev = 8.9513545724930199e-01 Member 2: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -62,8 +62,8 @@ Member 2: - air_horizontal_streamfunction (10 levels): + min = -4.0247526345905600e+00 + max = 3.6849059150242383e+00 - + mean = 5.8512182259701208e-02 - + stddev = 8.7318746839659322e-01 + + mean = 3.1680295572989361e-02 + + stddev = 8.8229054748970270e-01 Member 3: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -71,8 +71,8 @@ Member 3: - air_horizontal_streamfunction (10 levels): + min = -4.3626232703046366e+00 + max = 3.3616524629377325e+00 - + mean = -2.4574964560991504e-02 - + stddev = 9.2638588624918450e-01 + + mean = -1.1207697377699170e-02 + + stddev = 9.4928165502032380e-01 Member 4: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -80,8 +80,8 @@ Member 4: - air_horizontal_streamfunction (10 levels): + min = -3.5732601893489555e+00 + max = 3.8316128490855692e+00 - + mean = -2.1534136600574107e-02 - + stddev = 9.4645603902514752e-01 + + mean = -4.5400254579860119e-02 + + stddev = 9.5050555915247870e-01 Member 5: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -89,8 +89,8 @@ Member 5: - air_horizontal_streamfunction (10 levels): + min = -3.5338361059229273e+00 + max = 3.5837459332751100e+00 - + mean = -4.9831065597498322e-02 - + stddev = 9.1818981582905412e-01 + + mean = -5.2735340763794908e-02 + + stddev = 9.3549066990620278e-01 Member 6: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -98,8 +98,8 @@ Member 6: - air_horizontal_streamfunction (10 levels): + min = -3.3945796537614070e+00 + max = 3.0690063325437018e+00 - + mean = -2.2638867289269671e-02 - + stddev = 9.3929638058606724e-01 + + mean = -1.6784430768879578e-02 + + stddev = 9.4106800592376894e-01 Member 7: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -107,8 +107,8 @@ Member 7: - air_horizontal_streamfunction (10 levels): + min = -3.4043017511655398e+00 + max = 3.3646668282981902e+00 - + mean = 6.7631569054495216e-02 - + stddev = 9.1564858312481934e-01 + + mean = 7.6123301210311287e-02 + + stddev = 9.2625581190187345e-01 Member 8: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -116,8 +116,8 @@ Member 8: - air_horizontal_streamfunction (10 levels): + min = -3.2852003804503247e+00 + max = 3.9475082843087992e+00 - + mean = 1.4255412595643296e-01 - + stddev = 9.1159259224774380e-01 + + mean = 1.1328611976421755e-01 + + stddev = 9.1498882476296106e-01 Member 9: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -125,8 +125,8 @@ Member 9: - air_horizontal_streamfunction (10 levels): + min = -3.1539110007412838e+00 + max = 3.7109175444289106e+00 - + mean = 1.4642070051036213e-01 - + stddev = 8.8074008085217925e-01 + + mean = 1.0225321936424026e-01 + + stddev = 8.8693000187945970e-01 Member 10: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -134,8 +134,8 @@ Member 10: - air_horizontal_streamfunction (10 levels): + min = -3.2759540365167577e+00 + max = 3.7467774441920279e+00 - + mean = 6.8395709972278529e-03 - + stddev = 9.3297481638516300e-01 + + mean = 3.7435963033333963e-02 + + stddev = 9.5047670369166870e-01 Member 11: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -143,8 +143,8 @@ Member 11: - air_horizontal_streamfunction (10 levels): + min = -3.4861615001058497e+00 + max = 3.6413953785301993e+00 - + mean = -3.9571449622633433e-02 - + stddev = 9.8213188458400691e-01 + + mean = -2.3972035413097548e-02 + + stddev = 9.5009214714399537e-01 Member 12: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -152,8 +152,8 @@ Member 12: - air_horizontal_streamfunction (10 levels): + min = -3.3925327832908523e+00 + max = 3.5903627621023078e+00 - + mean = 2.6708521376464345e-02 - + stddev = 9.2613891165837592e-01 + + mean = 5.4344682352110976e-03 + + stddev = 9.4459148830471329e-01 Member 13: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -161,8 +161,8 @@ Member 13: - air_horizontal_streamfunction (10 levels): + min = -3.1872933143912872e+00 + max = 3.1148656371567731e+00 - + mean = -3.1124947925772511e-02 - + stddev = 9.5709383893219602e-01 + + mean = -3.6651569254390427e-02 + + stddev = 9.7559564859067205e-01 Member 14: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -170,8 +170,8 @@ Member 14: - air_horizontal_streamfunction (10 levels): + min = -3.4776998121861888e+00 + max = 3.3997090830264041e+00 - + mean = -3.0807950864376776e-02 - + stddev = 9.7107011365903173e-01 + + mean = 7.1491909655584870e-03 + + stddev = 9.3815747929816262e-01 Member 15: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -179,8 +179,8 @@ Member 15: - air_horizontal_streamfunction (10 levels): + min = -3.9229411719326088e+00 + max = 3.2938442888331796e+00 - + mean = 3.3805285936763275e-02 - + stddev = 9.2218662280840646e-01 + + mean = -7.6183033628188616e-03 + + stddev = 9.0322024214390784e-01 Member 16: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -188,8 +188,8 @@ Member 16: - air_horizontal_streamfunction (10 levels): + min = -3.5061990362542410e+00 + max = 3.7414946721966782e+00 - + mean = -6.7961439770173590e-02 - + stddev = 9.4185820441138923e-01 + + mean = -4.7602468904010216e-02 + + stddev = 9.4650487745935630e-01 Member 17: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -197,8 +197,8 @@ Member 17: - air_horizontal_streamfunction (10 levels): + min = -3.2663819529959781e+00 + max = 3.2475421673685232e+00 - + mean = -8.5660771433556146e-02 - + stddev = 9.5492019935115202e-01 + + mean = -1.1012474477473592e-01 + + stddev = 9.3405081852582739e-01 Member 18: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -206,8 +206,8 @@ Member 18: - air_horizontal_streamfunction (10 levels): + min = -3.8867974820712528e+00 + max = 3.7889967362655734e+00 - + mean = 8.5608653262769629e-03 - + stddev = 9.6476045381375586e-01 + + mean = 7.3521652639599228e-02 + + stddev = 9.5448266581062624e-01 Member 19: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -215,8 +215,8 @@ Member 19: - air_horizontal_streamfunction (10 levels): + min = -3.7124464283326502e+00 + max = 3.5618010348207712e+00 - + mean = 3.2763286203555772e-02 - + stddev = 9.4795229636034006e-01 + + mean = 4.1207280725503850e-02 + + stddev = 9.4811031984808147e-01 Member 20: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -224,8 +224,8 @@ Member 20: - air_horizontal_streamfunction (10 levels): + min = -3.1072400297493137e+00 + max = 3.4117203925012194e+00 - + mean = 4.5272656651998325e-02 - + stddev = 9.7749527358446830e-01 + + mean = 1.0914781693888943e-02 + + stddev = 9.4980420978648161e-01 Member 21: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -233,8 +233,8 @@ Member 21: - air_horizontal_streamfunction (10 levels): + min = -3.2412245543783071e+00 + max = 3.4266560347593642e+00 - + mean = -6.8097269138922244e-03 - + stddev = 9.2289974719670287e-01 + + mean = -5.6354793859380733e-02 + + stddev = 9.1379051543727596e-01 Member 22: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -242,8 +242,8 @@ Member 22: - air_horizontal_streamfunction (10 levels): + min = -3.7586294785343917e+00 + max = 3.5403694365561784e+00 - + mean = -1.3565147689765275e-01 - + stddev = 9.0434701783831906e-01 + + mean = -1.0907800345644408e-01 + + stddev = 8.9077549714934579e-01 Member 23: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -251,8 +251,8 @@ Member 23: - air_horizontal_streamfunction (10 levels): + min = -3.1980506233736672e+00 + max = 3.5753471302072901e+00 - + mean = -2.5389801220519245e-02 - + stddev = 9.9027686479961918e-01 + + mean = -1.6449035838045273e-02 + + stddev = 9.5745892799462773e-01 Member 24: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -260,5 +260,5 @@ Member 24: - air_horizontal_streamfunction (10 levels): + min = -3.3334370333894645e+00 + max = 3.3244164574359671e+00 - + mean = 4.5176022412880518e-02 - + stddev = 9.0097468404627379e-01 + + mean = 4.4196310644520391e-02 + + stddev = 9.1637711697028745e-01 diff --git a/test/testref/randomization_bump_nicas_L10L2.ref b/test/testref/randomization_bump_nicas_L10L2.ref index e96a3ba69..cf996046e 100644 --- a/test/testref/randomization_bump_nicas_L10L2.ref +++ b/test/testref/randomization_bump_nicas_L10L2.ref @@ -76,28 +76,28 @@ Member 0: - air_horizontal_streamfunction (2 levels): + min = -3.3014956069345209e+00 + max = 3.1373302675030588e+00 - + mean = -1.0514316598245121e-01 - + stddev = 9.9347221182183421e-01 + + mean = -5.9199686363087103e-02 + + stddev = 9.9427919052578728e-01 - air_horizontal_velocity_potential (2 levels): + min = -2.9089156467417658e+00 + max = 3.1856105235436929e+00 - + mean = 7.3445423047568195e-02 - + stddev = 9.0046772222178917e-01 + + mean = 1.4335363346910746e-01 + + stddev = 8.9517275550528330e-01 - eastward_wind (2 levels): + min = -2.8934058395650784e+00 + max = 3.1592417480669908e+00 - + mean = 2.1288567426090901e-01 - + stddev = 8.7754418480017549e-01 + + mean = 2.0973614862079820e-01 + + stddev = 9.1332540696600562e-01 - northward_wind (2 levels): + min = -3.6465889577463990e+00 + max = 2.7376533369636209e+00 - + mean = -1.1671975051123105e-01 - + stddev = 1.0206113701319313e+00 + + mean = -8.8600612446044474e-02 + + stddev = 1.0660502474382267e+00 - air_pressure_at_surface (1 levels): + min = -3.0122125975586078e+00 + max = 2.9179634723599888e+00 - + mean = -1.4408091063357029e-01 - + stddev = 9.4621104019919111e-01 + + mean = -1.5885469331987045e-01 + + stddev = 9.9138224788333718e-01 Member 1: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -105,28 +105,28 @@ Member 1: - air_horizontal_streamfunction (2 levels): + min = -2.7968561380669184e+00 + max = 2.8688159510666349e+00 - + mean = -8.9669494795109730e-02 - + stddev = 9.6787470313229829e-01 + + mean = -2.7814518280306583e-02 + + stddev = 9.6401402248692791e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.4071567153096871e+00 + max = 2.7571016002431818e+00 - + mean = 2.6788185140243254e-01 - + stddev = 9.9491401688524483e-01 + + mean = 2.0999927669779431e-01 + + stddev = 9.7026210387003142e-01 - eastward_wind (2 levels): + min = -2.7760768255434489e+00 + max = 2.8153816982259947e+00 - + mean = -1.7147820695629000e-02 - + stddev = 9.0370170944579586e-01 + + mean = 9.9644466428998497e-04 + + stddev = 9.3844328409913025e-01 - northward_wind (2 levels): + min = -2.8613752364658196e+00 + max = 3.2063508541580354e+00 - + mean = 6.3069451390459844e-02 - + stddev = 8.9359337679558770e-01 + + mean = 2.8844050867668548e-02 + + stddev = 9.2532011957690796e-01 - air_pressure_at_surface (1 levels): + min = -3.4121216685877416e+00 + max = 2.6395823254508710e+00 - + mean = 8.7804396145856944e-02 - + stddev = 9.6365453241341137e-01 + + mean = 3.9084224731516314e-02 + + stddev = 9.7763477134835486e-01 Member 2: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -134,28 +134,28 @@ Member 2: - air_horizontal_streamfunction (2 levels): + min = -2.7943389627916697e+00 + max = 3.2961502082518765e+00 - + mean = 3.6346417713165720e-02 - + stddev = 8.8164361250728418e-01 + + mean = 9.6851223465777889e-02 + + stddev = 9.0035689737072411e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.1168670659090534e+00 + max = 3.4393698689653847e+00 - + mean = 1.2096809794030212e-01 - + stddev = 9.2825259028280516e-01 + + mean = 1.2846030504389816e-01 + + stddev = 9.4971480335496283e-01 - eastward_wind (2 levels): + min = -2.9548187779610253e+00 + max = 2.8689307007860214e+00 - + mean = -1.8421052950449143e-01 - + stddev = 9.8815863848350416e-01 + + mean = -1.7998049822522749e-01 + + stddev = 1.0217105530334978e+00 - northward_wind (2 levels): + min = -2.7955870107886951e+00 + max = 4.4136465027695859e+00 - + mean = -8.2865863687651059e-02 - + stddev = 1.0332318859598233e+00 + + mean = -2.7241014287194706e-02 + + stddev = 1.0476705399196555e+00 - air_pressure_at_surface (1 levels): + min = -3.2830722878910477e+00 + max = 2.5634456300954218e+00 - + mean = 4.8807803935733834e-02 - + stddev = 9.3521461689686147e-01 + + mean = 1.1665481400122776e-01 + + stddev = 9.3884894720446765e-01 Member 3: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -163,28 +163,28 @@ Member 3: - air_horizontal_streamfunction (2 levels): + min = -3.3233456087870383e+00 + max = 2.7556958851890796e+00 - + mean = -9.5258493420915358e-02 - + stddev = 1.0097898530384370e+00 + + mean = -9.9423061905551821e-02 + + stddev = 1.0153506979571891e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.3435244718936890e+00 + max = 3.0893440600113351e+00 - + mean = 1.7230585160881180e-02 - + stddev = 9.8640569532981748e-01 + + mean = -3.4454901632680821e-02 + + stddev = 9.9301735435373562e-01 - eastward_wind (2 levels): + min = -3.3043072387426440e+00 + max = 3.3726618744720360e+00 - + mean = -6.4022346710204334e-02 - + stddev = 1.0133714623199275e+00 + + mean = -2.4795144097112767e-02 + + stddev = 1.0507921376825045e+00 - northward_wind (2 levels): + min = -3.1302258452040550e+00 + max = 3.1993924036802275e+00 - + mean = -2.0093014733113077e-01 - + stddev = 9.9578261719458550e-01 + + mean = -2.0826833378974294e-01 + + stddev = 1.0428342505688148e+00 - air_pressure_at_surface (1 levels): + min = -2.7034126547722921e+00 + max = 2.7496266856378400e+00 - + mean = 2.3336154762715888e-01 - + stddev = 9.9343899336845065e-01 + + mean = 2.2135704040141216e-01 + + stddev = 1.0398482099987072e+00 Member 4: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -192,28 +192,28 @@ Member 4: - air_horizontal_streamfunction (2 levels): + min = -3.1732747420303342e+00 + max = 3.1963389577027805e+00 - + mean = -2.0978099518031573e-01 - + stddev = 9.8499552130664381e-01 + + mean = -1.1570642782357340e-01 + + stddev = 9.6270551782196623e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.3577330224325213e+00 + max = 3.1200632612216292e+00 - + mean = 1.2824972095207285e-01 - + stddev = 9.1123655707765383e-01 + + mean = 7.3860746040520439e-02 + + stddev = 9.3476793551695792e-01 - eastward_wind (2 levels): + min = -2.9300579942870564e+00 + max = 3.0570808857342624e+00 - + mean = -2.1532268257241466e-01 - + stddev = 1.0552589967868229e+00 + + mean = -1.3483121142600618e-01 + + stddev = 1.0521599300659190e+00 - northward_wind (2 levels): + min = -2.7447802488199868e+00 + max = 3.2030127207515595e+00 - + mean = 1.1331013530772829e-01 - + stddev = 9.1803160329977451e-01 + + mean = 7.6250318264853595e-02 + + stddev = 9.3569789182400764e-01 - air_pressure_at_surface (1 levels): + min = -2.4234873609720258e+00 + max = 3.0651325175824620e+00 - + mean = 1.6907800086704988e-01 - + stddev = 8.4029833559031419e-01 + + mean = 1.5740975032256321e-01 + + stddev = 8.8105678041221624e-01 Member 5: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -221,28 +221,28 @@ Member 5: - air_horizontal_streamfunction (2 levels): + min = -3.8686285342786766e+00 + max = 3.2645412866331878e+00 - + mean = -3.9253630705792308e-01 - + stddev = 1.0398005878689931e+00 + + mean = -2.8166556560200690e-01 + + stddev = 1.0165892235056040e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.4398973548184562e+00 + max = 4.0236805149517778e+00 - + mean = 1.6554029797139291e-01 - + stddev = 1.0041108848624156e+00 + + mean = 1.4374582646187098e-01 + + stddev = 1.0286097624037902e+00 - eastward_wind (2 levels): + min = -3.4485836947399986e+00 + max = 3.6945244415335581e+00 - + mean = 2.1447478629744157e-01 - + stddev = 1.1125798122288648e+00 + + mean = 2.4408752179327303e-01 + + stddev = 1.0603636556307461e+00 - northward_wind (2 levels): + min = -2.9029107206277631e+00 + max = 3.4972924138268420e+00 - + mean = 2.8738038436541363e-02 - + stddev = 9.7692807350263078e-01 + + mean = -8.7856542633636264e-03 + + stddev = 9.6641305034685265e-01 - air_pressure_at_surface (1 levels): + min = -2.7385845929589094e+00 + max = 2.9453485660905399e+00 - + mean = 2.1455961398575049e-01 - + stddev = 8.5125072510241395e-01 + + mean = 1.9011708174870273e-01 + + stddev = 8.7724970641877187e-01 Member 6: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -250,28 +250,28 @@ Member 6: - air_horizontal_streamfunction (2 levels): + min = -3.1851645364000749e+00 + max = 2.9406929764573180e+00 - + mean = 7.3675533351667530e-02 - + stddev = 9.3515651812645029e-01 + + mean = 2.7925043476654456e-02 + + stddev = 9.4876438862073453e-01 - air_horizontal_velocity_potential (2 levels): + min = -2.2917388309926987e+00 + max = 3.1999249173817454e+00 - + mean = 1.0358737375478488e-01 - + stddev = 9.5801636349806862e-01 + + mean = 1.5858440780435784e-01 + + stddev = 9.5978088702640274e-01 - eastward_wind (2 levels): + min = -2.8299795697586942e+00 + max = 3.9807865443897574e+00 - + mean = 1.5004195096974893e-01 - + stddev = 1.0437258522403332e+00 + + mean = 9.6013439272273168e-02 + + stddev = 1.0811726428307624e+00 - northward_wind (2 levels): + min = -3.0680309791607612e+00 + max = 2.8121024203280824e+00 - + mean = 1.4934296261025137e-01 - + stddev = 1.0802480606861959e+00 + + mean = 9.6635260909989196e-02 + + stddev = 1.0780503804732351e+00 - air_pressure_at_surface (1 levels): + min = -2.5292081897687164e+00 + max = 3.7208241038498371e+00 - + mean = 1.7129923811312575e-01 - + stddev = 1.0543729468443159e+00 + + mean = 7.9026790252909943e-02 + + stddev = 1.0581663976617159e+00 Member 7: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -279,28 +279,28 @@ Member 7: - air_horizontal_streamfunction (2 levels): + min = -3.3115805762288213e+00 + max = 3.3096018303165717e+00 - + mean = 1.7404642385915933e-01 - + stddev = 1.0211274704153197e+00 + + mean = 1.1701332194450124e-01 + + stddev = 1.0422261807540145e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.0636707632202524e+00 + max = 3.7736787929536857e+00 - + mean = 1.1331611471140859e-01 - + stddev = 9.8718159774757497e-01 + + mean = 1.4222135671855735e-01 + + stddev = 9.9620610232244222e-01 - eastward_wind (2 levels): + min = -2.5365338807690962e+00 + max = 3.1322982263876349e+00 - + mean = -4.4148676570451219e-02 - + stddev = 9.9426438430611730e-01 + + mean = 2.1566177048380299e-02 + + stddev = 1.0138759878233790e+00 - northward_wind (2 levels): + min = -3.2885270100841200e+00 + max = 2.3940042889831101e+00 - + mean = -2.6928057335282418e-02 - + stddev = 8.4808706316468918e-01 + + mean = -5.4897631755467621e-02 + + stddev = 8.7182960833116419e-01 - air_pressure_at_surface (1 levels): + min = -3.7600650297896765e+00 + max = 2.9747110379235004e+00 - + mean = -1.4791233551889507e-01 - + stddev = 1.1162212476017903e+00 + + mean = -1.0736979836734130e-01 + + stddev = 1.0531891424877637e+00 Member 8: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -308,28 +308,28 @@ Member 8: - air_horizontal_streamfunction (2 levels): + min = -3.4557320534375653e+00 + max = 3.7647481721538676e+00 - + mean = 1.7019198638465347e-01 - + stddev = 9.9957904822982080e-01 + + mean = 1.5243294685931980e-01 + + stddev = 1.0448298338200244e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.2403619185201955e+00 + max = 4.0348731144710763e+00 - + mean = -1.8553320086462438e-01 - + stddev = 1.1508091441765762e+00 + + mean = -7.7622808956550438e-02 + + stddev = 1.1011391864857696e+00 - eastward_wind (2 levels): + min = -3.1542810538055828e+00 + max = 3.6321703035763231e+00 - + mean = -7.3175077702199498e-02 - + stddev = 9.7586296915081039e-01 + + mean = 1.0749715569197531e-02 + + stddev = 9.8601037655616897e-01 - northward_wind (2 levels): + min = -3.1926905526114808e+00 + max = 3.1822584930114877e+00 - + mean = -3.7006648537422265e-01 - + stddev = 9.6510405790494624e-01 + + mean = -2.9831455123889744e-01 + + stddev = 9.8125720893510049e-01 - air_pressure_at_surface (1 levels): + min = -2.7559647012176316e+00 + max = 2.8462577579664994e+00 - + mean = -3.8575750973460651e-02 - + stddev = 9.3930554341889505e-01 + + mean = -5.0623813688600958e-02 + + stddev = 9.6753694004824198e-01 Member 9: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -337,28 +337,28 @@ Member 9: - air_horizontal_streamfunction (2 levels): + min = -2.7214371594988678e+00 + max = 2.4129450378103603e+00 - + mean = -1.3983185525242758e-01 - + stddev = 9.2549149651885720e-01 + + mean = -1.0029417718128687e-01 + + stddev = 9.4804280750969749e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.3374175627349789e+00 + max = 3.7840924197007113e+00 - + mean = 8.0610007405572406e-02 - + stddev = 9.6147347942862194e-01 + + mean = 4.6635486927819790e-02 + + stddev = 1.0022018957874901e+00 - eastward_wind (2 levels): + min = -2.5240607069989554e+00 + max = 3.0627564454807641e+00 - + mean = 2.5633162962857736e-01 - + stddev = 9.2386701880778932e-01 + + mean = 1.6783857057427387e-01 + + stddev = 9.1918919487215978e-01 - northward_wind (2 levels): + min = -3.1052947956509236e+00 + max = 2.9130159479250213e+00 - + mean = -1.3116386335162050e-01 - + stddev = 1.0245190858088051e+00 + + mean = -1.1842902215805309e-01 + + stddev = 9.8153277105149594e-01 - air_pressure_at_surface (1 levels): + min = -2.5814834387290633e+00 + max = 3.0415286884067778e+00 - + mean = 2.0454840194276824e-01 - + stddev = 9.9865919792915236e-01 + + mean = 1.0502037751790944e-01 + + stddev = 9.2138487860319584e-01 Member 10: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -366,28 +366,28 @@ Member 10: - air_horizontal_streamfunction (2 levels): + min = -2.9834709979734382e+00 + max = 3.1331745949851948e+00 - + mean = 7.4134211671989261e-02 - + stddev = 9.6622041640451661e-01 + + mean = 7.3526264296956897e-02 + + stddev = 1.0089984582961571e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.3545343573652575e+00 + max = 2.7042063597062524e+00 - + mean = -1.2960276805686405e-01 - + stddev = 9.5959424543554439e-01 + + mean = -7.7088114150728956e-02 + + stddev = 9.8035481573031602e-01 - eastward_wind (2 levels): + min = -3.7157522774046954e+00 + max = 3.7140221724638236e+00 - + mean = -8.1142712548695248e-02 - + stddev = 1.1211183928220234e+00 + + mean = 1.2321055723604790e-02 + + stddev = 1.0672684932288155e+00 - northward_wind (2 levels): + min = -3.2466698360710295e+00 + max = 2.6479093395256106e+00 - + mean = 2.6476641076763652e-01 - + stddev = 1.0698092844656817e+00 + + mean = 1.2342006892841861e-01 + + stddev = 1.0169786591331973e+00 - air_pressure_at_surface (1 levels): + min = -2.7156567281036081e+00 + max = 3.2216484969521555e+00 - + mean = 1.7571359948146628e-01 - + stddev = 9.8963543736957160e-01 + + mean = 2.1702047062118954e-01 + + stddev = 9.7594203792562406e-01 Member 11: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -395,28 +395,28 @@ Member 11: - air_horizontal_streamfunction (2 levels): + min = -2.7964026816521415e+00 + max = 2.8910276512916817e+00 - + mean = -9.0111125389863798e-03 - + stddev = 9.8069250771560845e-01 + + mean = 2.0637865919452037e-02 + + stddev = 1.0132515448822386e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.4469342264543754e+00 + max = 3.9182858199353179e+00 - + mean = 1.4931943466043895e-01 - + stddev = 1.0873243229643041e+00 + + mean = 7.8338294334255126e-02 + + stddev = 1.1168076034772807e+00 - eastward_wind (2 levels): + min = -3.0154723183440790e+00 + max = 3.3973405118164131e+00 - + mean = -2.1539624621421880e-01 - + stddev = 1.0552183678120621e+00 + + mean = -1.3635262057452219e-01 + + stddev = 1.0664182314555504e+00 - northward_wind (2 levels): + min = -3.6424536842896846e+00 + max = 3.4872119868771647e+00 - + mean = 8.6023123137692684e-02 - + stddev = 1.0817100794553991e+00 + + mean = 6.8119342044748024e-02 + + stddev = 1.1268889149488386e+00 - air_pressure_at_surface (1 levels): + min = -2.6622128102780498e+00 + max = 2.4240124968463954e+00 - + mean = 4.5183628988222986e-02 - + stddev = 9.0480861428763104e-01 + + mean = 5.4167771726402428e-02 + + stddev = 9.4412416122443654e-01 Member 12: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -424,28 +424,28 @@ Member 12: - air_horizontal_streamfunction (2 levels): + min = -2.7982188499217151e+00 + max = 3.7064786476517426e+00 - + mean = 1.4424243396461406e-01 - + stddev = 1.0001202619493668e+00 + + mean = 7.9057324214262523e-02 + + stddev = 1.0036992146015842e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.2203470874641527e+00 + max = 3.4700204706965883e+00 - + mean = -8.7445481461940269e-02 - + stddev = 1.0655016468701120e+00 + + mean = -1.1587254515925705e-02 + + stddev = 1.0876286252906697e+00 - eastward_wind (2 levels): + min = -3.5869145351298122e+00 + max = 3.9031733275010287e+00 - + mean = -1.6672851424464807e-01 - + stddev = 1.1706111665715371e+00 + + mean = -1.3353478775471037e-01 + + stddev = 1.1984532230651028e+00 - northward_wind (2 levels): + min = -3.4137713289771630e+00 + max = 2.8250963347285158e+00 - + mean = -1.7317669553606757e-01 - + stddev = 1.0111164925420715e+00 + + mean = -2.0131900320210669e-01 + + stddev = 1.0498267565574984e+00 - air_pressure_at_surface (1 levels): + min = -2.9556240368311850e+00 + max = 2.6515469067025763e+00 - + mean = 7.7252829648598781e-02 - + stddev = 9.7121909971516807e-01 + + mean = 8.5060322631820354e-02 + + stddev = 1.0063725527630718e+00 Member 13: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -453,28 +453,28 @@ Member 13: - air_horizontal_streamfunction (2 levels): + min = -2.6298849422912038e+00 + max = 3.5333312763027820e+00 - + mean = 8.6837875474253187e-02 - + stddev = 1.1659715517761409e+00 + + mean = 2.3960151751877951e-02 + + stddev = 1.1171611744610777e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.4055706342640675e+00 + max = 2.5086365644973307e+00 - + mean = -1.4968340330205102e-01 - + stddev = 8.7589781928213406e-01 + + mean = -1.1900232366370604e-01 + + stddev = 9.0206784048419975e-01 - eastward_wind (2 levels): + min = -2.7813012841558429e+00 + max = 3.0287527955184217e+00 - + mean = 8.1284068716674332e-02 - + stddev = 9.6283582471937879e-01 + + mean = 6.8819078968489253e-02 + + stddev = 9.9300098364470124e-01 - northward_wind (2 levels): + min = -2.8147114917506375e+00 + max = 3.1768330339425597e+00 - + mean = 1.3767712215393069e-01 - + stddev = 9.5437434962021261e-01 + + mean = 1.2961202774883765e-01 + + stddev = 9.2960266681908521e-01 - air_pressure_at_surface (1 levels): + min = -2.4685601662415100e+00 + max = 2.9264071559669138e+00 - + mean = -6.0412723574476142e-02 - + stddev = 8.4746890927235163e-01 + + mean = -3.7568346130202233e-02 + + stddev = 8.8629762867955464e-01 Member 14: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -482,28 +482,28 @@ Member 14: - air_horizontal_streamfunction (2 levels): + min = -2.5462650701585292e+00 + max = 3.3305364953831069e+00 - + mean = 2.7178485431693583e-01 - + stddev = 1.0531186628123221e+00 + + mean = 1.4594929974602175e-01 + + stddev = 9.6076007633743787e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.5400595473701686e+00 + max = 2.8754437361187084e+00 - + mean = -2.0410010126529959e-01 - + stddev = 9.9057670753687455e-01 + + mean = -1.5124094006806435e-01 + + stddev = 1.0060564062159625e+00 - eastward_wind (2 levels): + min = -3.2548012789035603e+00 + max = 2.9253558982382097e+00 - + mean = 1.8717612467238351e-01 - + stddev = 1.1655628438688925e+00 + + mean = 7.4287208822976236e-02 + + stddev = 1.1083975189809439e+00 - northward_wind (2 levels): + min = -2.3216888506636160e+00 + max = 2.9097390902955866e+00 - + mean = 4.5402798632137625e-01 - + stddev = 9.9722987004124952e-01 + + mean = 3.6539822059423671e-01 + + stddev = 9.3733209844867016e-01 - air_pressure_at_surface (1 levels): + min = -3.0435787038002839e+00 + max = 2.6309054844076245e+00 - + mean = -7.7222064305262584e-03 - + stddev = 9.4668258133776917e-01 + + mean = -7.5160231905179758e-02 + + stddev = 9.6453978664405093e-01 Member 15: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -511,28 +511,28 @@ Member 15: - air_horizontal_streamfunction (2 levels): + min = -3.6419355858255962e+00 + max = 3.5216780668966141e+00 - + mean = -1.6815193065995110e-01 - + stddev = 9.8470120624737423e-01 + + mean = -1.3904779889697050e-01 + + stddev = 1.0076350321226140e+00 - air_horizontal_velocity_potential (2 levels): + min = -2.7345384457039152e+00 + max = 2.6880180008890044e+00 - + mean = 3.4350494441322217e-02 - + stddev = 1.0317406556334536e+00 + + mean = -6.2534350269669720e-03 + + stddev = 9.9783912510302175e-01 - eastward_wind (2 levels): + min = -3.2115714601312386e+00 + max = 3.2260714985341927e+00 - + mean = -2.3902665610635013e-01 - + stddev = 1.0676538002910416e+00 + + mean = -1.2570062766982060e-01 + + stddev = 1.0411688106514256e+00 - northward_wind (2 levels): + min = -3.1645692024789409e+00 + max = 2.8359358310540079e+00 - + mean = -1.9538552197577178e-01 - + stddev = 9.0335997776821941e-01 + + mean = -1.9871905700196557e-01 + + stddev = 8.8674055342850600e-01 - air_pressure_at_surface (1 levels): + min = -2.6380650299050954e+00 + max = 2.9545817120248334e+00 - + mean = 1.1957895660167779e-01 - + stddev = 9.0800574301070414e-01 + + mean = 7.8894084312334703e-02 + + stddev = 9.4094807465593966e-01 Member 16: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -540,28 +540,28 @@ Member 16: - air_horizontal_streamfunction (2 levels): + min = -2.9487056988197895e+00 + max = 3.9080692415815701e+00 - + mean = 4.9080515050406434e-02 - + stddev = 1.0877449906573833e+00 + + mean = 4.1775384147990917e-02 + + stddev = 1.0884334102999655e+00 - air_horizontal_velocity_potential (2 levels): + min = -2.9415474995475566e+00 + max = 3.0583962866013401e+00 - + mean = 1.3616710838644333e-01 - + stddev = 1.0331640973800909e+00 + + mean = 6.4281304603943684e-02 + + stddev = 1.0482891483195025e+00 - eastward_wind (2 levels): + min = -3.1129574340418280e+00 + max = 2.4759611005887034e+00 - + mean = 1.0122754414459509e-01 - + stddev = 9.1106201996724845e-01 + + mean = 5.6741235442290712e-02 + + stddev = 9.3605131573893385e-01 - northward_wind (2 levels): + min = -3.7471390781816880e+00 + max = 2.7423748506098433e+00 - + mean = -2.1625101132726532e-01 - + stddev = 9.9061845637175361e-01 + + mean = -1.4358226994805162e-01 + + stddev = 9.9728837884833288e-01 - air_pressure_at_surface (1 levels): + min = -2.7923566982397001e+00 + max = 2.4052560551787625e+00 - + mean = -1.1367968438039296e-01 - + stddev = 8.5601051117548654e-01 + + mean = -9.3769979449111029e-02 + + stddev = 8.8896522112148291e-01 Member 17: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -569,28 +569,28 @@ Member 17: - air_horizontal_streamfunction (2 levels): + min = -3.3864983467889758e+00 + max = 3.5931499540440748e+00 - + mean = -2.8349565417599958e-02 - + stddev = 1.0446576263969352e+00 + + mean = -6.7774422804069423e-02 + + stddev = 1.0292405155094457e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.1187328756109398e+00 + max = 2.6027581761160281e+00 - + mean = -1.1198293413426959e-01 - + stddev = 9.5290723343510753e-01 + + mean = -3.2966993774180831e-02 + + stddev = 9.4508266573144928e-01 - eastward_wind (2 levels): + min = -3.4620613043549806e+00 + max = 3.8685397374489123e+00 - + mean = -4.8261192709985273e-02 - + stddev = 1.1684744490702677e+00 + + mean = -3.0577636778262030e-02 + + stddev = 1.1803636554636361e+00 - northward_wind (2 levels): + min = -2.9463696911206396e+00 + max = 2.9672178591773442e+00 - + mean = 1.8291560141681573e-01 - + stddev = 9.9325904418219713e-01 + + mean = 1.0591531613375595e-01 + + stddev = 1.0034009579254382e+00 - air_pressure_at_surface (1 levels): + min = -3.7832831173504253e+00 + max = 3.1041557747112245e+00 - + mean = 1.4227878964542418e-01 - + stddev = 1.0323812698950532e+00 + + mean = 1.6531190189021580e-01 + + stddev = 1.0739472669234364e+00 Member 18: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -598,28 +598,28 @@ Member 18: - air_horizontal_streamfunction (2 levels): + min = -2.9031792272383461e+00 + max = 4.0756604498900888e+00 - + mean = 1.4316053591179670e-02 - + stddev = 9.1386179985129345e-01 + + mean = 2.1743560857359269e-02 + + stddev = 9.4770444999147974e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.3163758323334664e+00 + max = 2.6828334095324893e+00 - + mean = 3.0228170537500442e-02 - + stddev = 8.6552416529178700e-01 + + mean = 2.5037273933494323e-03 + + stddev = 8.9048710599967940e-01 - eastward_wind (2 levels): + min = -3.4259790473928891e+00 + max = 2.8770032234989151e+00 - + mean = 1.5393150634017316e-01 - + stddev = 9.4872997957937588e-01 + + mean = 1.3036365376410952e-01 + + stddev = 9.8405064983237134e-01 - northward_wind (2 levels): + min = -2.9878366661429561e+00 + max = 3.3090770894891071e+00 - + mean = 9.4912272274620346e-02 - + stddev = 9.3495043345488626e-01 + + mean = 1.3008950813627007e-01 + + stddev = 9.5676137337869860e-01 - air_pressure_at_surface (1 levels): + min = -2.4399072533183768e+00 + max = 3.3018085276766684e+00 - + mean = 1.4771287718967413e-01 - + stddev = 9.5984077392874456e-01 + + mean = 2.0388331616484637e-01 + + stddev = 9.8452477391419524e-01 Member 19: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -627,28 +627,28 @@ Member 19: - air_horizontal_streamfunction (2 levels): + min = -2.8562537341815268e+00 + max = 3.2096245625766171e+00 - + mean = 5.1909674595063016e-02 - + stddev = 9.5377350991820598e-01 + + mean = 2.8666449741159863e-02 + + stddev = 9.9754213627594834e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.0923389550775013e+00 + max = 2.7543197965852464e+00 - + mean = -9.1493720718102314e-02 - + stddev = 8.5739228405397661e-01 + + mean = -7.7585873710038444e-02 + + stddev = 8.7523308018011259e-01 - eastward_wind (2 levels): + min = -2.8856359860634906e+00 + max = 2.8222662419318949e+00 - + mean = 5.5606767692288284e-02 - + stddev = 1.0062210793219100e+00 + + mean = 9.7400163578515539e-02 + + stddev = 9.4776972649617630e-01 - northward_wind (2 levels): + min = -3.1130298591852954e+00 + max = 3.2393136119261432e+00 - + mean = 1.5566468025639227e-01 - + stddev = 1.0323154397691774e+00 + + mean = 7.7993461847091494e-02 + + stddev = 1.0161320132944820e+00 - air_pressure_at_surface (1 levels): + min = -2.6237762191359795e+00 + max = 2.3077409656074028e+00 - + mean = -7.7817321221991517e-02 - + stddev = 8.3133824675096246e-01 + + mean = -5.1795671088394502e-02 + + stddev = 8.5892138213771707e-01 Member 20: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -656,28 +656,28 @@ Member 20: - air_horizontal_streamfunction (2 levels): + min = -3.2393176871399141e+00 + max = 2.7962347449497007e+00 - + mean = 1.1925178151305846e-01 - + stddev = 8.3236004608443359e-01 + + mean = 1.1269666828378259e-01 + + stddev = 8.6610357834604745e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.7436923042606107e+00 + max = 4.1473818389881689e+00 - + mean = -5.9359967713841751e-03 - + stddev = 9.6147681807175922e-01 + + mean = -5.4205332736154299e-02 + + stddev = 9.7476474195088814e-01 - eastward_wind (2 levels): + min = -2.9481968198789441e+00 + max = 3.0488729613717203e+00 - + mean = 2.7417211519497753e-01 - + stddev = 9.4450119583792502e-01 + + mean = 2.5769473906322465e-01 + + stddev = 9.6878402987344714e-01 - northward_wind (2 levels): + min = -4.0063049429688533e+00 + max = 3.1703814470927862e+00 - + mean = -2.6181354896893028e-01 - + stddev = 9.8042740120409533e-01 + + mean = -2.0457716600434844e-01 + + stddev = 1.0043042490406857e+00 - air_pressure_at_surface (1 levels): + min = -3.1534376174530188e+00 + max = 2.7182004888080682e+00 - + mean = -1.9994640766225849e-01 - + stddev = 9.3437725483188960e-01 + + mean = -1.2462250439969663e-01 + + stddev = 9.4824817756315238e-01 Member 21: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -685,28 +685,28 @@ Member 21: - air_horizontal_streamfunction (2 levels): + min = -3.7103584359812487e+00 + max = 2.5539667669741104e+00 - + mean = -1.0686906443517540e-01 - + stddev = 1.0064753253693048e+00 + + mean = -1.8108457425542285e-01 + + stddev = 1.0108639148964211e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.3285176603142541e+00 + max = 2.6241413644629152e+00 - + mean = -1.5313003547712198e-01 - + stddev = 9.6443963103377472e-01 + + mean = -1.2335591263629281e-01 + + stddev = 9.9363029198592112e-01 - eastward_wind (2 levels): + min = -2.8336678006103768e+00 + max = 3.4412269448435335e+00 - + mean = -2.6054055205029479e-03 - + stddev = 9.4252310258208738e-01 + + mean = -4.8732304129273166e-02 + + stddev = 9.4949324758189269e-01 - northward_wind (2 levels): + min = -2.5006955427168416e+00 + max = 3.1543119732220131e+00 - + mean = -1.6777695183053590e-01 - + stddev = 1.0352530924531638e+00 + + mean = -7.5938119850626484e-02 + + stddev = 1.0266623119719827e+00 - air_pressure_at_surface (1 levels): + min = -2.9141126235606563e+00 + max = 2.6093249846455611e+00 - + mean = -1.9133271878825547e-01 - + stddev = 9.1747726618062164e-01 + + mean = -1.3873628072384953e-01 + + stddev = 9.4587044193884562e-01 Member 22: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -714,28 +714,28 @@ Member 22: - air_horizontal_streamfunction (2 levels): + min = -2.9228220888728655e+00 + max = 3.7337812275864546e+00 - + mean = -1.3020632480994423e-01 - + stddev = 1.0477231774460349e+00 + + mean = -4.1823264916558987e-02 + + stddev = 1.0373337477451201e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.5401383297580971e+00 + max = 3.2951842002939751e+00 - + mean = 2.3761340231991755e-02 - + stddev = 1.0599874498000315e+00 + + mean = -9.6018504464260107e-02 + + stddev = 1.0269964582567015e+00 - eastward_wind (2 levels): + min = -3.0757147409730474e+00 + max = 2.9529275480526369e+00 - + mean = -3.7172724190454004e-02 - + stddev = 9.9780672151165617e-01 + + mean = -7.5526295572948432e-02 + + stddev = 9.8405836452636597e-01 - northward_wind (2 levels): + min = -2.9440795081376798e+00 + max = 3.5946374050054803e+00 - + mean = 2.7764127938287225e-01 - + stddev = 1.0968017102823313e+00 + + mean = 1.7902097599951222e-01 + + stddev = 1.0585285173814856e+00 - air_pressure_at_surface (1 levels): + min = -3.4480036947645449e+00 + max = 2.9606970820089842e+00 - + mean = 3.5895965531668614e-02 - + stddev = 1.0582293725690388e+00 + + mean = 6.0059655998130745e-03 + + stddev = 1.0600502833691710e+00 Member 23: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -743,28 +743,28 @@ Member 23: - air_horizontal_streamfunction (2 levels): + min = -3.4557528643451954e+00 + max = 2.6226951668198928e+00 - + mean = -2.3386107613221530e-01 - + stddev = 9.9206079326585950e-01 + + mean = -2.1132492864327171e-01 + + stddev = 1.0182716086561336e+00 - air_horizontal_velocity_potential (2 levels): + min = -2.9573018139754836e+00 + max = 3.0048248679432681e+00 - + mean = -5.6189293398175660e-02 - + stddev = 9.1506356431682856e-01 + + mean = -5.0013697162646226e-03 + + stddev = 9.4135120483210810e-01 - eastward_wind (2 levels): + min = -4.0078218190378001e+00 + max = 3.0019936803467369e+00 - + mean = -1.7222424876532746e-01 - + stddev = 1.0038633377562487e+00 + + mean = -7.7279435135009025e-02 + + stddev = 1.0059885249042708e+00 - northward_wind (2 levels): + min = -3.8492093981305300e+00 + max = 3.0920461431115753e+00 - + mean = -3.5029878785421653e-01 - + stddev = 1.1424420158430015e+00 + + mean = -1.8466323954439892e-01 + + stddev = 1.0479288271159499e+00 - air_pressure_at_surface (1 levels): + min = -2.4872358520435718e+00 + max = 3.0325580298960646e+00 - + mean = 2.4115108376308989e-01 - + stddev = 9.5605919984742938e-01 + + mean = 1.1606964059913109e-01 + + stddev = 9.1597078474076787e-01 Member 24: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -772,25 +772,25 @@ Member 24: - air_horizontal_streamfunction (2 levels): + min = -3.1630354651051289e+00 + max = 2.5363379836357609e+00 - + mean = -3.2592439692836517e-01 - + stddev = 9.4816618646592377e-01 + + mean = -2.4485112430288802e-01 + + stddev = 9.5703125355261409e-01 - air_horizontal_velocity_potential (2 levels): + min = -2.6053224563293043e+00 + max = 3.4738464704842826e+00 - + mean = 1.6148883101068354e-01 - + stddev = 9.6290326961474026e-01 + + mean = 8.2367079347259800e-02 + + stddev = 9.4886193702082744e-01 - eastward_wind (2 levels): + min = -3.1516666270274443e+00 + max = 2.9744650737694820e+00 - + mean = -2.3454998306903349e-01 - + stddev = 9.1179818499966858e-01 + + mean = -2.4271130484520523e-01 + + stddev = 9.4248223391590868e-01 - northward_wind (2 levels): + min = -2.6488619816200529e+00 + max = 2.8367279022302214e+00 - + mean = 2.5024633856020850e-01 - + stddev = 1.0502322434582050e+00 + + mean = 9.3907110111254369e-02 + + stddev = 9.5306771343437924e-01 - air_pressure_at_surface (1 levels): + min = -2.9042566558149367e+00 + max = 2.7639387911496556e+00 - + mean = 8.7015747280884369e-03 - + stddev = 1.0944896973281666e+00 + + mean = -8.9775150372051180e-02 + + stddev = 1.0241594496816939e+00 diff --git a/test/testref/randomization_bump_nicas_L10L2T18.ref b/test/testref/randomization_bump_nicas_L10L2T18.ref index 2ca368043..877f785e5 100644 --- a/test/testref/randomization_bump_nicas_L10L2T18.ref +++ b/test/testref/randomization_bump_nicas_L10L2T18.ref @@ -76,28 +76,28 @@ Member 0: - air_horizontal_streamfunction (2 levels): + min = -3.6759812161780161e+00 + max = 3.1581815616909217e+00 - + mean = -2.7705034019912833e-01 - + stddev = 9.6555976548259836e-01 + + mean = -2.3792257775016529e-01 + + stddev = 9.7675200790182581e-01 - air_horizontal_velocity_potential (2 levels): + min = -2.9842108445792359e+00 + max = 3.6488210705278843e+00 - + mean = 3.0012001458866028e-01 - + stddev = 1.0391213455770130e+00 + + mean = 2.4404521342414390e-01 + + stddev = 1.0137359261590737e+00 - eastward_wind (2 levels): + min = -2.8805379918377763e+00 + max = 3.2883151978479215e+00 - + mean = 2.7749911555041135e-01 - + stddev = 1.0009681237661696e+00 + + mean = 2.7634640120963461e-01 + + stddev = 1.0445943247736604e+00 - northward_wind (2 levels): + min = -2.6139798442858315e+00 + max = 3.3195023905473371e+00 - + mean = 2.5543645136195781e-01 - + stddev = 9.4794163388981600e-01 + + mean = 2.0547446916473913e-01 + + stddev = 9.2856259916701123e-01 - air_pressure_at_surface (1 levels): + min = -2.2872288283270743e+00 + max = 2.2280833670371751e+00 - + mean = 8.8892556845727305e-03 - + stddev = 1.0662083113014624e+00 + + mean = 1.5837955854804648e-02 + + stddev = 1.0168599455102987e+00 Member 1: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -105,28 +105,28 @@ Member 1: - air_horizontal_streamfunction (2 levels): + min = -2.8051836996121779e+00 + max = 2.9673704843909405e+00 - + mean = -3.4626929217702961e-02 - + stddev = 9.6658946479807617e-01 + + mean = -9.7064786729711861e-02 + + stddev = 9.6372906941424785e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.3848054213731897e+00 + max = 3.1227586534348113e+00 - + mean = 1.1683894060861148e-02 - + stddev = 9.2748959220406657e-01 + + mean = -1.4431396618432044e-02 + + stddev = 9.6259115190379752e-01 - eastward_wind (2 levels): + min = -2.8101145796177680e+00 + max = 2.4594058400897509e+00 - + mean = 3.7395637471028365e-02 - + stddev = 8.6052968994218582e-01 + + mean = 3.8778347338288721e-02 + + stddev = 8.8859567340816492e-01 - northward_wind (2 levels): + min = -3.0351080345216217e+00 + max = 3.0580296062506669e+00 - + mean = -1.9377790673493003e-03 - + stddev = 9.2319317980221116e-01 + + mean = 2.5118045493347230e-03 + + stddev = 9.5680688624508414e-01 - air_pressure_at_surface (1 levels): + min = -3.5043393583554105e+00 + max = 2.5155978089203113e+00 - + mean = -5.8583301109684172e-01 - + stddev = 1.0366830900163959e+00 + + mean = -4.7883353638554194e-01 + + stddev = 1.0268647669871476e+00 Member 2: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -134,28 +134,28 @@ Member 2: - air_horizontal_streamfunction (2 levels): + min = -3.1087428922885647e+00 + max = 2.9987700063319149e+00 - + mean = 3.3112502790595619e-02 - + stddev = 8.9967560194677720e-01 + + mean = 5.9578433452143760e-02 + + stddev = 9.1827007323856658e-01 - air_horizontal_velocity_potential (2 levels): + min = -2.8508533945953891e+00 + max = 2.9095615688849112e+00 - + mean = -1.7401122413754730e-01 - + stddev = 9.6279735126806876e-01 + + mean = -1.5168986740460183e-01 + + stddev = 9.5442086241458812e-01 - eastward_wind (2 levels): + min = -3.0032148093896263e+00 + max = 2.4107262286006446e+00 - + mean = 1.3651060863851722e-01 - + stddev = 1.0419714879193707e+00 + + mean = 8.2496768530874093e-02 + + stddev = 1.0051805596960806e+00 - northward_wind (2 levels): + min = -2.6362793767065309e+00 + max = 3.7397586889672372e+00 - + mean = 1.0477113467999252e-01 - + stddev = 9.9567301669353725e-01 + + mean = 1.7563946560966864e-01 + + stddev = 9.6701750890650284e-01 - air_pressure_at_surface (1 levels): + min = -2.8556896597345713e+00 + max = 2.3430848658440255e+00 - + mean = 2.3155881797200312e-01 - + stddev = 8.3456953566075232e-01 + + mean = 2.4696755370262907e-01 + + stddev = 8.7063700445024472e-01 Member 3: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -163,28 +163,28 @@ Member 3: - air_horizontal_streamfunction (2 levels): + min = -2.5685798462823848e+00 + max = 2.7407902575607856e+00 - + mean = 7.4995436875868932e-02 - + stddev = 9.0788241839227402e-01 + + mean = 4.8958157181325658e-02 + + stddev = 9.2718358123585087e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.3913172264655529e+00 + max = 3.8106077548324362e+00 - + mean = -9.8278698587293017e-02 - + stddev = 1.0068399494052194e+00 + + mean = -5.2521771951179574e-02 + + stddev = 1.0159292036669729e+00 - eastward_wind (2 levels): + min = -2.8977081370165969e+00 + max = 3.0154595151363894e+00 - + mean = -3.4312901185883959e-01 - + stddev = 1.0363212364625842e+00 + + mean = -2.4113625021253673e-01 + + stddev = 1.0050855044060953e+00 - northward_wind (2 levels): + min = -3.3804109326008667e+00 + max = 2.9302332836762304e+00 - + mean = -7.4112004350530128e-02 - + stddev = 9.3230286617981517e-01 + + mean = -7.9974475743040618e-02 + + stddev = 9.5668190627867344e-01 - air_pressure_at_surface (1 levels): + min = -3.0907717735650517e+00 + max = 3.1636458507873755e+00 - + mean = 6.5461115296837338e-03 - + stddev = 8.5317660251262506e-01 + + mean = 8.7156327610931172e-02 + + stddev = 8.5582238547662604e-01 Member 4: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -192,28 +192,28 @@ Member 4: - air_horizontal_streamfunction (2 levels): + min = -2.7439787079513978e+00 + max = 3.2790350867864118e+00 - + mean = -6.1682061177721299e-02 - + stddev = 9.5994803408360063e-01 + + mean = -2.5923327759373935e-02 + + stddev = 9.7676163063736687e-01 - air_horizontal_velocity_potential (2 levels): + min = -2.1912612353840322e+00 + max = 2.7234631047472142e+00 - + mean = -3.0716167215564669e-02 - + stddev = 8.1333826078388094e-01 + + mean = -5.1885123852721898e-02 + + stddev = 8.4594339099489768e-01 - eastward_wind (2 levels): + min = -3.3355227872139612e+00 + max = 3.0003475123438030e+00 - + mean = 5.9763860079576375e-02 - + stddev = 1.0102275118779058e+00 + + mean = 1.8458595013376711e-02 + + stddev = 1.0000336608589075e+00 - northward_wind (2 levels): + min = -3.2469163870543207e+00 + max = 3.2925558578752367e+00 - + mean = 5.6094164821110379e-06 - + stddev = 1.0324859712894052e+00 + + mean = -4.6205849077814443e-02 + + stddev = 1.0566021004130306e+00 - air_pressure_at_surface (1 levels): + min = -3.0535510764573521e+00 + max = 4.6214563207017214e+00 - + mean = 2.4820729972967312e-01 - + stddev = 1.0680682752580557e+00 + + mean = 2.4724510068657704e-01 + + stddev = 1.0945327120660564e+00 Member 5: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -221,28 +221,28 @@ Member 5: - air_horizontal_streamfunction (2 levels): + min = -3.5270416676147347e+00 + max = 3.8634461537969313e+00 - + mean = -1.1983765481545915e-01 - + stddev = 9.4616288778545210e-01 + + mean = -2.0157449521493029e-01 + + stddev = 9.2168378803883910e-01 - air_horizontal_velocity_potential (2 levels): + min = -2.4913836165137231e+00 + max = 2.9656219539678919e+00 - + mean = 1.7594345058811856e-01 - + stddev = 8.9934759872456072e-01 + + mean = 1.8900498758365622e-01 + + stddev = 9.1618723611502251e-01 - eastward_wind (2 levels): + min = -2.5295768635427995e+00 + max = 3.3801883140046578e+00 - + mean = 3.4970477518371353e-02 - + stddev = 9.4173018949559417e-01 + + mean = 3.2832445227626052e-02 + + stddev = 9.5968466424779852e-01 - northward_wind (2 levels): + min = -2.7738804573186853e+00 + max = 2.8829106656823251e+00 - + mean = -5.7072385643654786e-02 - + stddev = 9.1130030015878238e-01 + + mean = -6.6969707927444833e-02 + + stddev = 9.3713542925431470e-01 - air_pressure_at_surface (1 levels): + min = -2.2510342963283496e+00 + max = 2.6292994287391540e+00 - + mean = 2.0873615826193617e-01 - + stddev = 9.6489630944348825e-01 + + mean = 2.2202328557518822e-01 + + stddev = 9.2991373102294761e-01 Member 6: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -250,28 +250,28 @@ Member 6: - air_horizontal_streamfunction (2 levels): + min = -2.4227412256330645e+00 + max = 3.3095828666750511e+00 - + mean = 3.8245960261290352e-01 - + stddev = 1.0614901854961998e+00 + + mean = 2.6258057026725568e-01 + + stddev = 1.0178572094776250e+00 - air_horizontal_velocity_potential (2 levels): + min = -2.8831022303559335e+00 + max = 3.1862171866407643e+00 - + mean = -2.8295547754114792e-01 - + stddev = 9.8499517586769969e-01 + + mean = -2.3101940067591520e-01 + + stddev = 9.6737624697438784e-01 - eastward_wind (2 levels): + min = -3.7133256071649248e+00 + max = 3.4142891238283615e+00 - + mean = -2.4084010706308959e-01 - + stddev = 1.0294851549943334e+00 + + mean = -2.2306977419236829e-01 + + stddev = 1.0776895560525874e+00 - northward_wind (2 levels): + min = -2.6899386952444102e+00 + max = 3.8396829410817492e+00 - + mean = 6.6271839131461216e-02 - + stddev = 1.0540840075214473e+00 + + mean = 1.2470442303287457e-01 + + stddev = 1.0152800009461858e+00 - air_pressure_at_surface (1 levels): + min = -2.8087920451076860e+00 + max = 3.2495664813289125e+00 - + mean = 2.4547806446387394e-01 - + stddev = 1.0074241151670780e+00 + + mean = 1.6677624873582367e-01 + + stddev = 1.0256154003205413e+00 Member 7: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -279,28 +279,28 @@ Member 7: - air_horizontal_streamfunction (2 levels): + min = -2.5871876719907871e+00 + max = 2.7498566693321043e+00 - + mean = 8.7095300714861337e-02 - + stddev = 9.3667792358120583e-01 + + mean = 6.2446985183489449e-02 + + stddev = 9.5958813597283954e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.8479676226751516e+00 + max = 2.8071085863164482e+00 - + mean = 1.6426515094757096e-01 - + stddev = 9.6696281651814608e-01 + + mean = 1.1227169803498602e-01 + + stddev = 9.7491324214966046e-01 - eastward_wind (2 levels): + min = -2.6884476958769263e+00 + max = 4.1519562844342879e+00 - + mean = -5.6791091919172719e-02 - + stddev = 1.0204973702559006e+00 + + mean = -1.0869271996168364e-01 + + stddev = 1.0086292238802768e+00 - northward_wind (2 levels): + min = -2.7799850373750181e+00 + max = 2.7293494038121473e+00 - + mean = 2.7124009064647986e-01 - + stddev = 8.1487403621517929e-01 + + mean = 2.5524940964621656e-01 + + stddev = 8.3872468267974520e-01 - air_pressure_at_surface (1 levels): + min = -3.3904615165113130e+00 + max = 2.8809044561313275e+00 - + mean = 1.6623759284385628e-01 - + stddev = 9.5119081964897279e-01 + + mean = 1.4927886280139629e-01 + + stddev = 9.4490675114135725e-01 Member 8: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -308,28 +308,28 @@ Member 8: - air_horizontal_streamfunction (2 levels): + min = -2.3810560344330902e+00 + max = 3.2111306140127054e+00 - + mean = 1.3722355448355913e-01 - + stddev = 1.0199795252093991e+00 + + mean = 1.2974324027484452e-01 + + stddev = 1.0283607985845780e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.4184885213698930e+00 + max = 4.0040960808107782e+00 - + mean = 6.9042273998969839e-02 - + stddev = 1.0505618803429313e+00 + + mean = 5.2133782537527429e-02 + + stddev = 1.0713601553128673e+00 - eastward_wind (2 levels): + min = -2.4542179610464174e+00 + max = 2.8920102161922130e+00 - + mean = 1.0415653382957728e-01 - + stddev = 9.0345692262135679e-01 + + mean = 1.1677820707197531e-01 + + stddev = 9.1082499963584351e-01 - northward_wind (2 levels): + min = -2.9513069863854131e+00 + max = 2.8466306050251782e+00 - + mean = 1.3775400478614605e-01 - + stddev = 9.4674834961248322e-01 + + mean = 1.4660888059593746e-01 + + stddev = 9.7577884818639338e-01 - air_pressure_at_surface (1 levels): + min = -2.6667319191799881e+00 + max = 2.7259536653267791e+00 - + mean = -1.3631918779598942e-01 - + stddev = 9.4365589640967129e-01 + + mean = -1.2208052450918021e-01 + + stddev = 9.6105188621524962e-01 Member 9: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -337,28 +337,28 @@ Member 9: - air_horizontal_streamfunction (2 levels): + min = -3.1243446792703997e+00 + max = 2.8984003015796156e+00 - + mean = -2.7378348199439562e-01 - + stddev = 1.0289259020257711e+00 + + mean = -2.3546845227826552e-01 + + stddev = 1.0512307570099959e+00 - air_horizontal_velocity_potential (2 levels): + min = -2.6377259525098169e+00 + max = 3.1686895132066089e+00 - + mean = 3.2972769589277612e-01 - + stddev = 9.8998066344005753e-01 + + mean = 2.5688399052229616e-01 + + stddev = 1.0110037538362526e+00 - eastward_wind (2 levels): + min = -3.0134750248948974e+00 + max = 3.7716262006931882e+00 - + mean = 1.0897058748269804e-01 - + stddev = 9.6620743366682682e-01 + + mean = 1.0778453144374664e-01 + + stddev = 9.7060706447783152e-01 - northward_wind (2 levels): + min = -3.4900211029372450e+00 + max = 4.5876632211241803e+00 - + mean = 4.2559748403397706e-02 - + stddev = 9.7357573426739752e-01 + + mean = 3.7190750465460248e-02 + + stddev = 9.7816915715533559e-01 - air_pressure_at_surface (1 levels): + min = -3.3860073574993423e+00 + max = 3.6793001131834369e+00 - + mean = 7.7419752912117376e-02 - + stddev = 1.0287651795214026e+00 + + mean = 1.2052909093164330e-01 + + stddev = 1.0327002708219535e+00 Member 10: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -366,28 +366,28 @@ Member 10: - air_horizontal_streamfunction (2 levels): + min = -3.3770802457825582e+00 + max = 3.3653884442696329e+00 - + mean = -1.3141057102729359e-01 - + stddev = 9.3486185848907877e-01 + + mean = -3.8092098208104927e-02 + + stddev = 9.3098068346953644e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.3498512880236992e+00 + max = 3.3767832793243362e+00 - + mean = 4.2269372230477942e-01 - + stddev = 1.1874804967287007e+00 + + mean = 3.3106504463866709e-01 + + stddev = 1.1249555407707361e+00 - eastward_wind (2 levels): + min = -2.8760538006641139e+00 + max = 2.6466392581806644e+00 - + mean = 1.0594871721214132e-01 - + stddev = 1.0225019224546941e+00 + + mean = 6.1661798112906056e-02 + + stddev = 1.0548996622683511e+00 - northward_wind (2 levels): + min = -3.4535579897162916e+00 + max = 2.9550995901429964e+00 - + mean = 2.8056781609956005e-02 - + stddev = 9.9388463065642974e-01 + + mean = -4.4251890459326079e-03 + + stddev = 1.0316224349664760e+00 - air_pressure_at_surface (1 levels): + min = -3.0324795952384389e+00 + max = 2.9647819437798271e+00 - + mean = 2.1997924327761726e-02 - + stddev = 1.0715452205687199e+00 + + mean = -6.9105380895543911e-02 + + stddev = 1.0734697406989180e+00 Member 11: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -395,28 +395,28 @@ Member 11: - air_horizontal_streamfunction (2 levels): + min = -2.7782852502721793e+00 + max = 2.7187113365305451e+00 - + mean = -6.7914037273353739e-02 - + stddev = 9.0567351291641462e-01 + + mean = -8.7657080743928945e-02 + + stddev = 9.3031198009721028e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.8391071141277870e+00 + max = 2.2516022609400124e+00 - + mean = -2.2153837359882322e-01 - + stddev = 8.7532661989838589e-01 + + mean = -2.1786300518991272e-01 + + stddev = 8.9512395638891518e-01 - eastward_wind (2 levels): + min = -3.7972062537781142e+00 + max = 2.7314524836370881e+00 - + mean = -1.4179934822782356e-01 - + stddev = 9.8284574332527830e-01 + + mean = -1.2442194472879932e-01 + + stddev = 9.8926706046975454e-01 - northward_wind (2 levels): + min = -3.3593398939909314e+00 + max = 2.8229365273306586e+00 - + mean = 8.8530345545492328e-02 - + stddev = 1.1583631985568321e+00 + + mean = 1.0984303702040520e-01 + + stddev = 1.1394916967946125e+00 - air_pressure_at_surface (1 levels): + min = -2.6800771710538012e+00 + max = 2.6111909441404872e+00 - + mean = 1.0608588605085546e-01 - + stddev = 9.5933882376564728e-01 + + mean = 1.2704787123889164e-01 + + stddev = 9.2825218411383248e-01 Member 12: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -424,28 +424,28 @@ Member 12: - air_horizontal_streamfunction (2 levels): + min = -3.5322334624597898e+00 + max = 3.2619172511028545e+00 - + mean = -7.1952937573929246e-02 - + stddev = 9.6884388037761593e-01 + + mean = 5.1562785549504131e-03 + + stddev = 9.7489936872091720e-01 - air_horizontal_velocity_potential (2 levels): + min = -2.7334474452863340e+00 + max = 3.2131568920095370e+00 - + mean = 7.1580234674345225e-02 - + stddev = 9.1885638200416553e-01 + + mean = 5.2734235529317802e-02 + + stddev = 9.5115649799177671e-01 - eastward_wind (2 levels): + min = -2.9972736194878422e+00 + max = 2.6012925919436514e+00 - + mean = -1.5175030045196333e-01 - + stddev = 9.4642351008153514e-01 + + mean = -1.5585071314181079e-01 + + stddev = 9.3807309988153209e-01 - northward_wind (2 levels): + min = -3.1381151192787673e+00 + max = 3.4900429806649718e+00 - + mean = 3.0326361730693935e-01 - + stddev = 8.9290232237322975e-01 + + mean = 2.8320670669821774e-01 + + stddev = 9.3401701863094044e-01 - air_pressure_at_surface (1 levels): + min = -3.0137650603654786e+00 + max = 3.5820434157926058e+00 - + mean = -1.3067725212767965e-02 - + stddev = 9.4572498180361697e-01 + + mean = -1.6044632121501597e-02 + + stddev = 9.8008156800875657e-01 Member 13: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -453,28 +453,28 @@ Member 13: - air_horizontal_streamfunction (2 levels): + min = -2.5945013053480852e+00 + max = 2.3612928271433731e+00 - + mean = -3.7666565041113764e-01 - + stddev = 8.9962941982532285e-01 + + mean = -3.1442341793415862e-01 + + stddev = 9.0173906828639905e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.1281493219880048e+00 + max = 3.6982929498519459e+00 - + mean = 1.1899850115446214e-01 - + stddev = 9.9444965844628441e-01 + + mean = 1.1594366442498538e-01 + + stddev = 1.0337238102803967e+00 - eastward_wind (2 levels): + min = -2.7147896623065222e+00 + max = 2.6142091153829767e+00 - + mean = 1.2451469169030841e-02 - + stddev = 8.3891552960196802e-01 + + mean = -2.7529797382082246e-02 + + stddev = 8.4242483853743633e-01 - northward_wind (2 levels): + min = -3.3144748227408809e+00 + max = 3.2154444107197730e+00 - + mean = 5.1242158626952528e-02 - + stddev = 9.3137978886180017e-01 + + mean = 1.0715915738960732e-02 + + stddev = 9.4793924634880400e-01 - air_pressure_at_surface (1 levels): + min = -2.5435830183047625e+00 + max = 3.5845887627387474e+00 - + mean = 2.3930863019210019e-01 - + stddev = 9.1027593405782370e-01 + + mean = 1.8819303949150185e-01 + + stddev = 9.3786516582686785e-01 Member 14: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -482,28 +482,28 @@ Member 14: - air_horizontal_streamfunction (2 levels): + min = -3.1934640369493952e+00 + max = 2.5077485548619354e+00 - + mean = 1.1535152318684151e-01 - + stddev = 9.4726546845255633e-01 + + mean = 7.4542095554545468e-02 + + stddev = 9.4968498491097120e-01 - air_horizontal_velocity_potential (2 levels): + min = -2.9522550217404651e+00 + max = 3.6790777124093363e+00 - + mean = -1.1780000356186170e-01 - + stddev = 9.8750866006068216e-01 + + mean = -8.9535349310143161e-02 + + stddev = 9.7526152150617396e-01 - eastward_wind (2 levels): + min = -3.6157095230701199e+00 + max = 3.2943398190908302e+00 - + mean = -5.9775407605478476e-02 - + stddev = 9.8129040617990881e-01 + + mean = -2.1127766346097789e-02 + + stddev = 9.9666715009570594e-01 - northward_wind (2 levels): + min = -2.7245033775133551e+00 + max = 3.3113435587057238e+00 - + mean = -1.7216153517817075e-02 - + stddev = 1.0369910400512989e+00 + + mean = 3.0911588911252091e-02 + + stddev = 1.0727187374866660e+00 - air_pressure_at_surface (1 levels): + min = -3.0137652497179270e+00 + max = 2.9430398155606126e+00 - + mean = 1.9809938248425213e-01 - + stddev = 9.8172436087299042e-01 + + mean = 1.5710220349656506e-01 + + stddev = 9.9743032072817517e-01 Member 15: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -511,28 +511,28 @@ Member 15: - air_horizontal_streamfunction (2 levels): + min = -3.5325314772689627e+00 + max = 3.2041593826351029e+00 - + mean = -3.3989309682460717e-01 - + stddev = 1.1498477008819270e+00 + + mean = -2.3518260737926480e-01 + + stddev = 1.1182584226355285e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.4494998912686547e+00 + max = 3.5563920781498082e+00 - + mean = 8.0226384022241928e-02 - + stddev = 9.8024803603219668e-01 + + mean = 8.4211381837973262e-02 + + stddev = 1.0011506468838183e+00 - eastward_wind (2 levels): + min = -2.5301210988770184e+00 + max = 2.8237027160690649e+00 - + mean = 1.1661452736756431e-01 - + stddev = 1.0221265867953429e+00 + + mean = 1.3171888875029927e-01 + + stddev = 1.0190594466790077e+00 - northward_wind (2 levels): + min = -3.8969717231651746e+00 + max = 3.4894318149177725e+00 - + mean = -8.0623403783573550e-02 - + stddev = 8.8681326704186469e-01 + + mean = -6.8136592743696517e-02 + + stddev = 9.2903247841774428e-01 - air_pressure_at_surface (1 levels): + min = -3.0755934212612828e+00 + max = 2.5683706878949324e+00 - + mean = -1.8551251738113821e-02 - + stddev = 9.9873458732872489e-01 + + mean = 9.6115578020122446e-03 + + stddev = 9.8665865407196252e-01 Member 16: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -540,28 +540,28 @@ Member 16: - air_horizontal_streamfunction (2 levels): + min = -3.5355677129682777e+00 + max = 3.6439081354351610e+00 - + mean = 4.1474749241308742e-02 - + stddev = 1.0465418152871668e+00 + + mean = 2.8363647736051500e-02 + + stddev = 1.0614196932284004e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.4209511336223568e+00 + max = 2.7517361016321922e+00 - + mean = -3.5396687205037269e-01 - + stddev = 1.1073938987887677e+00 + + mean = -2.9791131714528951e-01 + + stddev = 1.0994259176156935e+00 - eastward_wind (2 levels): + min = -3.2435492853529095e+00 + max = 2.6444405559076456e+00 - + mean = 2.6167065756495550e-01 - + stddev = 1.0215967938854202e+00 + + mean = 1.3825611789954301e-01 + + stddev = 9.5911662012729304e-01 - northward_wind (2 levels): + min = -2.9982750096703756e+00 + max = 3.1080249355626597e+00 - + mean = -6.7442025844266271e-02 - + stddev = 1.0158917217890819e+00 + + mean = -6.7514853580407402e-02 + + stddev = 1.0353710033516133e+00 - air_pressure_at_surface (1 levels): + min = -2.6670991459161999e+00 + max = 2.2824336211002043e+00 - + mean = -1.5365277163142446e-01 - + stddev = 8.0284617926305302e-01 + + mean = -1.4194232306686821e-01 + + stddev = 8.2983073108746186e-01 Member 17: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -569,28 +569,28 @@ Member 17: - air_horizontal_streamfunction (2 levels): + min = -2.9671733511627272e+00 + max = 2.9165157107656694e+00 - + mean = -9.8030423768791994e-03 - + stddev = 9.3785468076546485e-01 + + mean = -4.6007861373651072e-02 + + stddev = 9.7544020271282650e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.0603013839534983e+00 + max = 2.8624833690434919e+00 - + mean = 1.2837768819139719e-01 - + stddev = 9.0073864650253121e-01 + + mean = 1.1252454279949924e-01 + + stddev = 9.2824388300524707e-01 - eastward_wind (2 levels): + min = -3.1580037475847456e+00 + max = 3.7909461378617251e+00 - + mean = 1.5176850239366710e-01 - + stddev = 9.5058011107594387e-01 + + mean = 1.3465737336757222e-01 + + stddev = 9.7002788911437765e-01 - northward_wind (2 levels): + min = -3.7138088490626879e+00 + max = 2.8443455196809109e+00 - + mean = -3.7826536827816573e-02 - + stddev = 8.1014703672547406e-01 + + mean = -4.4762110035542764e-02 + + stddev = 8.1076353296141779e-01 - air_pressure_at_surface (1 levels): + min = -2.6535733594119586e+00 + max = 2.8211591235285978e+00 - + mean = 9.7473064021009970e-02 - + stddev = 8.7972970040772347e-01 + + mean = 1.3172102991225168e-01 + + stddev = 9.0155340532666794e-01 Member 18: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -598,28 +598,28 @@ Member 18: - air_horizontal_streamfunction (2 levels): + min = -3.0317621974933888e+00 + max = 3.1276543739394640e+00 - + mean = -1.1673713047949379e-01 - + stddev = 1.0370025687959388e+00 + + mean = -6.4747686970892213e-02 + + stddev = 1.0193283462505516e+00 - air_horizontal_velocity_potential (2 levels): + min = -2.7013148058157310e+00 + max = 2.9612529548936872e+00 - + mean = -5.3242759379013065e-02 - + stddev = 9.7804641249853241e-01 + + mean = -1.0137641075706934e-01 + + stddev = 1.0077181149715941e+00 - eastward_wind (2 levels): + min = -4.2190529063378470e+00 + max = 2.5656565697752463e+00 - + mean = -1.3853798907552176e-01 - + stddev = 9.2587162339023488e-01 + + mean = -1.4005634826696176e-01 + + stddev = 9.7134035184210943e-01 - northward_wind (2 levels): + min = -2.4325645729371614e+00 + max = 3.4269299280744598e+00 - + mean = 2.5513395284808948e-01 - + stddev = 9.5098349140366600e-01 + + mean = 2.3462126953883886e-01 + + stddev = 9.5604947450881161e-01 - air_pressure_at_surface (1 levels): + min = -3.2844185025483763e+00 + max = 2.4760721895116791e+00 - + mean = -1.5158037021289861e-01 - + stddev = 8.6470063474275949e-01 + + mean = -1.9467576656976207e-01 + + stddev = 8.9665030513500565e-01 Member 19: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -627,28 +627,28 @@ Member 19: - air_horizontal_streamfunction (2 levels): + min = -3.7103333636424192e+00 + max = 3.0578197362761821e+00 - + mean = 5.8960226666662459e-02 - + stddev = 1.0639172052899870e+00 + + mean = 3.7706645604466654e-02 + + stddev = 1.0803496808796675e+00 - air_horizontal_velocity_potential (2 levels): + min = -2.7735296655640487e+00 + max = 3.2413495980074614e+00 - + mean = -3.5125167200716317e-02 - + stddev = 9.4255716811090640e-01 + + mean = -7.6297507886364233e-02 + + stddev = 9.5277794293750573e-01 - eastward_wind (2 levels): + min = -2.8080460625331258e+00 + max = 2.6766508771794606e+00 - + mean = 2.5694947525230227e-01 - + stddev = 9.4502345208098137e-01 + + mean = 1.9977839863028027e-01 + + stddev = 9.6343131350216249e-01 - northward_wind (2 levels): + min = -3.1302406039588457e+00 + max = 2.8808178295642213e+00 - + mean = -1.4675839608728340e-02 - + stddev = 9.5977235208179013e-01 + + mean = -6.7292381749636143e-02 + + stddev = 9.8394247894913012e-01 - air_pressure_at_surface (1 levels): + min = -3.4780126816161703e+00 + max = 3.0661318459087479e+00 - + mean = -5.6531235853946891e-02 - + stddev = 9.4768141031043118e-01 + + mean = 1.0093886758210323e-03 + + stddev = 9.7125638063815523e-01 Member 20: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -656,28 +656,28 @@ Member 20: - air_horizontal_streamfunction (2 levels): + min = -2.7747749422880625e+00 + max = 2.9790951130701750e+00 - + mean = -2.0822388114128115e-01 - + stddev = 9.9353370323593815e-01 + + mean = -2.1390898554801469e-01 + + stddev = 1.0335564844084524e+00 - air_horizontal_velocity_potential (2 levels): + min = -4.6458142349742904e+00 + max = 3.1056674776514872e+00 - + mean = -3.0473208633708215e-01 - + stddev = 1.1571493861576310e+00 + + mean = -2.2849523594594995e-01 + + stddev = 1.1656476762275183e+00 - eastward_wind (2 levels): + min = -2.9995328742199874e+00 + max = 3.6410478167969438e+00 - + mean = 5.2242154903310356e-01 - + stddev = 1.0924609745383158e+00 + + mean = 4.3823444198385464e-01 + + stddev = 1.0461060210660535e+00 - northward_wind (2 levels): + min = -3.0189727923792939e+00 + max = 3.0439864401033647e+00 - + mean = -8.3817582297158154e-03 - + stddev = 1.0577185488594791e+00 + + mean = -7.6997437130951224e-02 + + stddev = 1.0064949158901586e+00 - air_pressure_at_surface (1 levels): + min = -2.9110044666201302e+00 + max = 2.4403488286868740e+00 - + mean = 6.8240535948518510e-03 - + stddev = 9.1503309859757476e-01 + + mean = -4.9416403834151884e-02 + + stddev = 9.3477988660348499e-01 Member 21: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -685,28 +685,28 @@ Member 21: - air_horizontal_streamfunction (2 levels): + min = -3.1749988444497981e+00 + max = 2.7435388291307516e+00 - + mean = -1.2859480457866848e-01 - + stddev = 9.1253780548681696e-01 + + mean = -8.9346102271171318e-02 + + stddev = 9.3159435548286806e-01 - air_horizontal_velocity_potential (2 levels): + min = -3.1770768971703918e+00 + max = 2.9178355308758994e+00 - + mean = -6.9245702017108945e-02 - + stddev = 8.9540688625752451e-01 + + mean = -8.3298182905700791e-02 + + stddev = 9.3611461940627516e-01 - eastward_wind (2 levels): + min = -3.3772294449489939e+00 + max = 2.7134398936798343e+00 - + mean = -1.6536338086033114e-01 - + stddev = 9.4641471769302121e-01 + + mean = -1.6142782092859964e-01 + + stddev = 9.5497056856848384e-01 - northward_wind (2 levels): + min = -3.1860502832853625e+00 + max = 2.9601325341466924e+00 - + mean = 1.5738914097505222e-02 - + stddev = 1.0890116989916274e+00 + + mean = 1.1452936156910835e-02 + + stddev = 1.0497619677471619e+00 - air_pressure_at_surface (1 levels): + min = -3.0270433913157326e+00 + max = 2.6995630270741424e+00 - + mean = -8.0978877538560992e-02 - + stddev = 1.1374984330479765e+00 + + mean = -4.4847642337252004e-02 + + stddev = 1.1134535794950358e+00 Member 22: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -714,28 +714,28 @@ Member 22: - air_horizontal_streamfunction (2 levels): + min = -2.6383667943146754e+00 + max = 3.1217407865684637e+00 - + mean = 2.6469247775016830e-01 - + stddev = 1.0838440431904497e+00 + + mean = 2.1679416802458873e-01 + + stddev = 1.0038946628394991e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.2537435861884494e+00 + max = 2.3673931106744615e+00 - + mean = -1.5197007004503360e-01 - + stddev = 8.8020514428303420e-01 + + mean = -1.3599281789956566e-01 + + stddev = 9.0439486464385055e-01 - eastward_wind (2 levels): + min = -3.0203455680421052e+00 + max = 2.8932128022754209e+00 - + mean = -1.8782259060994960e-01 - + stddev = 9.9223940995786986e-01 + + mean = -9.4549801439468811e-02 + + stddev = 9.7772933838327158e-01 - northward_wind (2 levels): + min = -2.3763904496080412e+00 + max = 3.8359259068568217e+00 - + mean = 9.9410836315425716e-02 - + stddev = 9.8090215874602615e-01 + + mean = 8.2701405322009952e-02 + + stddev = 9.9823982684569623e-01 - air_pressure_at_surface (1 levels): + min = -2.3992780218155261e+00 + max = 2.9392169943836066e+00 - + mean = 2.2784816211436401e-01 - + stddev = 8.9386486485400585e-01 + + mean = 1.4444810178962164e-01 + + stddev = 8.8089213336762007e-01 Member 23: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -743,28 +743,28 @@ Member 23: - air_horizontal_streamfunction (2 levels): + min = -3.3161268961107027e+00 + max = 4.4775927808700686e+00 - + mean = -1.1056478377301591e-01 - + stddev = 1.0237315188456837e+00 + + mean = -7.5361206739633466e-02 + + stddev = 1.0187950798717267e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.2424090140979334e+00 + max = 2.8856326656508196e+00 - + mean = 8.7110828714034125e-02 - + stddev = 9.8775792444356270e-01 + + mean = 4.8454180979905295e-02 + + stddev = 1.0061550431705772e+00 - eastward_wind (2 levels): + min = -3.1050797672394315e+00 + max = 3.4755752931450590e+00 - + mean = 2.2544822199678785e-01 - + stddev = 9.5933007556381977e-01 + + mean = 2.1994489471501627e-01 + + stddev = 1.0018020318465117e+00 - northward_wind (2 levels): + min = -3.3017997689202825e+00 + max = 3.2265657200717088e+00 - + mean = 3.0948728328672173e-03 - + stddev = 9.8043396816516137e-01 + + mean = -1.1985150884110361e-03 + + stddev = 9.9686505128525893e-01 - air_pressure_at_surface (1 levels): + min = -2.6505072065889776e+00 + max = 3.2888607381558383e+00 - + mean = 1.5287957905818428e-01 - + stddev = 1.0387078461174313e+00 + + mean = 2.3152074701599776e-01 + + stddev = 9.9588051979478043e-01 Member 24: - Valid time: 2010-01-01T18:00:00Z Geometry: L40x21 [840] @@ -772,25 +772,25 @@ Member 24: - air_horizontal_streamfunction (2 levels): + min = -2.5432689657375152e+00 + max = 3.0720100790169842e+00 - + mean = -3.0023976809807149e-02 - + stddev = 1.0070790791622066e+00 + + mean = 3.4692472839189227e-02 + + stddev = 1.0208505074723748e+00 - air_horizontal_velocity_potential (2 levels): + min = -3.3320355149632030e+00 + max = 2.5572820333130077e+00 - + mean = -2.0526732160638933e-01 - + stddev = 9.1439938272379950e-01 + + mean = -1.5392896838699457e-01 + + stddev = 9.2469103700916555e-01 - eastward_wind (2 levels): + min = -2.9900136262077912e+00 + max = 3.9148528852135658e+00 - + mean = 1.3078097534356978e-01 - + stddev = 9.0978588531283422e-01 + + mean = 1.3815646975801241e-01 + + stddev = 9.5042426159235260e-01 - northward_wind (2 levels): + min = -2.5699128076817659e+00 + max = 3.4071341115866969e+00 - + mean = 2.6056269070430399e-01 - + stddev = 1.0063739867091017e+00 + + mean = 2.0396119844295166e-01 + + stddev = 9.9400259633155164e-01 - air_pressure_at_surface (1 levels): + min = -2.2187679914433205e+00 + max = 2.3710152440604331e+00 - + mean = 1.9806791899309107e-02 - + stddev = 7.8669682119891704e-01 + + mean = 7.2535115878437487e-02 + + stddev = 7.9866510855548134e-01 diff --git a/test/testref/randomization_bump_nicas_L10L2_static.ref b/test/testref/randomization_bump_nicas_L10L2_static.ref index b6c10ebc4..ef0766628 100644 --- a/test/testref/randomization_bump_nicas_L10L2_static.ref +++ b/test/testref/randomization_bump_nicas_L10L2_static.ref @@ -24,8 +24,8 @@ Member 0: - air_horizontal_streamfunction (2 levels): + min = -2.4222901357895501e+00 + max = 2.6389764187991602e+00 - + mean = -4.0379053950830468e-02 - + stddev = 9.7289498148833964e-01 + + mean = 7.9406554734290358e-04 + + stddev = 9.8987887974314592e-01 Member 1: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -33,8 +33,8 @@ Member 1: - air_horizontal_streamfunction (2 levels): + min = -3.4835907781572373e+00 + max = 2.2435794051115088e+00 - + mean = -5.0172052167144499e-01 - + stddev = 1.0573639354017268e+00 + + mean = -4.8743538807699471e-01 + + stddev = 1.0332089056017772e+00 Member 2: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -42,8 +42,8 @@ Member 2: - air_horizontal_streamfunction (2 levels): + min = -3.4142992736043514e+00 + max = 3.3675805040956437e+00 - + mean = 2.5235984748747214e-01 - + stddev = 9.4226155130922407e-01 + + mean = 2.4722608462463574e-01 + + stddev = 9.7674893840143506e-01 Member 3: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -51,8 +51,8 @@ Member 3: - air_horizontal_streamfunction (2 levels): + min = -2.3508789799403553e+00 + max = 2.4077319529951726e+00 - + mean = -4.3662621285003304e-02 - + stddev = 1.1329882784849208e+00 + + mean = -2.2390989129883583e-02 + + stddev = 1.0584528992659328e+00 Member 4: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -60,8 +60,8 @@ Member 4: - air_horizontal_streamfunction (2 levels): + min = -2.9659560614204810e+00 + max = 3.2831730149877068e+00 - + mean = 3.2547768981510961e-01 - + stddev = 1.0338399421256230e+00 + + mean = 2.6856484898177846e-01 + + stddev = 1.0065125101168204e+00 Member 5: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -69,8 +69,8 @@ Member 5: - air_horizontal_streamfunction (2 levels): + min = -2.6984827817514323e+00 + max = 2.8532675951309048e+00 - + mean = 2.6281134238043335e-01 - + stddev = 9.0998921123443921e-01 + + mean = 2.7285008497878777e-01 + + stddev = 9.5161864006951269e-01 Member 6: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -78,8 +78,8 @@ Member 6: - air_horizontal_streamfunction (2 levels): + min = -1.9432958573258776e+00 + max = 2.3484888511715956e+00 - + mean = 3.1420744203254847e-01 - + stddev = 7.4695169542564988e-01 + + mean = 2.9336525370660782e-01 + + stddev = 7.6154407738646601e-01 Member 7: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -87,8 +87,8 @@ Member 7: - air_horizontal_streamfunction (2 levels): + min = -3.1603870300139945e+00 + max = 2.6228905346040334e+00 - + mean = 1.5526762160976562e-01 - + stddev = 9.8822545331354483e-01 + + mean = 1.2871887733805593e-01 + + stddev = 9.7260344381123731e-01 Member 8: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -96,8 +96,8 @@ Member 8: - air_horizontal_streamfunction (2 levels): + min = -2.2927462660774447e+00 + max = 2.9974719931338480e+00 - + mean = 2.5053561586122886e-01 - + stddev = 9.5011723266508086e-01 + + mean = 2.1690404811609737e-01 + + stddev = 9.6351979976894120e-01 Member 9: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -105,8 +105,8 @@ Member 9: - air_horizontal_streamfunction (2 levels): + min = -3.3580004753423056e+00 + max = 2.8532418321127229e+00 - + mean = 1.2323099092162361e-01 - + stddev = 1.1991643949429995e+00 + + mean = 8.4114361348857178e-02 + + stddev = 1.1568500343822670e+00 Member 10: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -114,8 +114,8 @@ Member 10: - air_horizontal_streamfunction (2 levels): + min = -3.3446235017343033e+00 + max = 3.2166262270158135e+00 - + mean = 6.5005190226063506e-02 - + stddev = 1.0545322091860316e+00 + + mean = 1.9542461495009468e-02 + + stddev = 1.0523116382876279e+00 Member 11: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -123,8 +123,8 @@ Member 11: - air_horizontal_streamfunction (2 levels): + min = -2.8666644090680093e+00 + max = 2.7301049414788960e+00 - + mean = -6.8384052020814781e-02 - + stddev = 9.6309707075921658e-01 + + mean = -6.6886446622472812e-02 + + stddev = 9.6273411684374910e-01 Member 12: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -132,8 +132,8 @@ Member 12: - air_horizontal_streamfunction (2 levels): + min = -2.6680194056717617e+00 + max = 2.5226911961491747e+00 - + mean = -4.9229806052351427e-01 - + stddev = 1.0182463650049642e+00 + + mean = -4.1589794589992640e-01 + + stddev = 1.0382268193346884e+00 Member 13: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -141,8 +141,8 @@ Member 13: - air_horizontal_streamfunction (2 levels): + min = -3.3600495566426107e+00 + max = 3.0703086610810746e+00 - + mean = 3.4479839729361583e-01 - + stddev = 9.7964566252221574e-01 + + mean = 2.9316012042664219e-01 + + stddev = 1.0027490862473141e+00 Member 14: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -150,8 +150,8 @@ Member 14: - air_horizontal_streamfunction (2 levels): + min = -2.2285021635986557e+00 + max = 3.3752830727558907e+00 - + mean = 3.9452583523568029e-02 - + stddev = 8.2939468334334288e-01 + + mean = 2.9904118235644948e-02 + + stddev = 8.6699114543788258e-01 Member 15: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -159,8 +159,8 @@ Member 15: - air_horizontal_streamfunction (2 levels): + min = -3.0322956400002097e+00 + max = 2.4224919235818918e+00 - + mean = -2.1600119203352930e-01 - + stddev = 9.7167818669387018e-01 + + mean = -1.8411402897643919e-01 + + stddev = 9.9722526025247338e-01 Member 16: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -168,8 +168,8 @@ Member 16: - air_horizontal_streamfunction (2 levels): + min = -3.5148009169440551e+00 + max = 2.7177592951664677e+00 - + mean = 2.9774014743785182e-01 - + stddev = 9.8063473026201275e-01 + + mean = 2.9610045479745417e-01 + + stddev = 9.6768139317919055e-01 Member 17: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -177,8 +177,8 @@ Member 17: - air_horizontal_streamfunction (2 levels): + min = -2.5056883514989785e+00 + max = 2.9988220138306376e+00 - + mean = -1.6189373030737197e-01 - + stddev = 9.1194188363633899e-01 + + mean = -1.1587148613007309e-01 + + stddev = 9.1247266338464117e-01 Member 18: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -186,8 +186,8 @@ Member 18: - air_horizontal_streamfunction (2 levels): + min = -3.4294131971262236e+00 + max = 2.8495486282421325e+00 - + mean = -7.1748119168508526e-02 - + stddev = 1.0548897074712256e+00 + + mean = -3.6385431464444104e-02 + + stddev = 1.0925657497584891e+00 Member 19: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -195,8 +195,8 @@ Member 19: - air_horizontal_streamfunction (2 levels): + min = -2.7131880687474688e+00 + max = 3.3725886060106283e+00 - + mean = 1.5669245474651657e-02 - + stddev = 9.6134284343058674e-01 + + mean = 5.7577526814263959e-03 + + stddev = 9.8710821477582489e-01 Member 20: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -204,8 +204,8 @@ Member 20: - air_horizontal_streamfunction (2 levels): + min = -3.2206511355673668e+00 + max = 2.6596996437567162e+00 - + mean = -5.4172442372352581e-02 - + stddev = 8.9671267598314830e-01 + + mean = -3.7839440956920857e-02 + + stddev = 9.2267833553478085e-01 Member 21: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -213,8 +213,8 @@ Member 21: - air_horizontal_streamfunction (2 levels): + min = -3.6187278649627275e+00 + max = 2.5531008255476531e+00 - + mean = 2.5049070383204480e-01 - + stddev = 8.6557151634140950e-01 + + mean = 2.1150339894336473e-01 + + stddev = 8.9022142270471771e-01 Member 22: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -222,8 +222,8 @@ Member 22: - air_horizontal_streamfunction (2 levels): + min = -2.6781692872844638e+00 + max = 2.1502679476108275e+00 - + mean = -2.8102171122928882e-01 - + stddev = 1.0138315452682869e+00 + + mean = -2.4712860641087853e-01 + + stddev = 9.8632068334076428e-01 Member 23: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -231,8 +231,8 @@ Member 23: - air_horizontal_streamfunction (2 levels): + min = -2.7137539052569744e+00 + max = 2.8927488013644420e+00 - + mean = 1.2830641410286114e-01 - + stddev = 1.0622282167710571e+00 + + mean = 9.7588075003754673e-02 + + stddev = 1.0123420720665233e+00 Member 24: - Valid time: 2010-01-01T12:00:00Z Geometry: L40x21 [840] @@ -240,5 +240,5 @@ Member 24: - air_horizontal_streamfunction (2 levels): + min = -2.5249076876879513e+00 + max = 2.7463526011677488e+00 - + mean = -9.6587291881318871e-02 - + stddev = 1.0556592532126781e+00 + + mean = -6.6042253981313234e-02 + + stddev = 1.0544179606903359e+00 diff --git a/test/testref/randomization_bump_nicas_L12L2.ref b/test/testref/randomization_bump_nicas_L12L2.ref index d760ccdd5..b5e2513c0 100644 --- a/test/testref/randomization_bump_nicas_L12L2.ref +++ b/test/testref/randomization_bump_nicas_L12L2.ref @@ -40,13 +40,13 @@ Member 0: - air_horizontal_streamfunction (2 levels): + min = -3.2355295543738478e+00 + max = 2.9783271775802813e+00 - + mean = 8.5278125856292519e-02 - + stddev = 1.0732297957806785e+00 + + mean = 2.6281350862462582e-02 + + stddev = 1.0798693283546945e+00 - air_pressure_at_surface (1 levels): + min = -3.6618592670839747e+00 + max = 2.6716174626922213e+00 - + mean = -2.2878285656816671e-01 - + stddev = 1.0373115149116432e+00 + + mean = -1.8907550639226767e-01 + + stddev = 1.0345503843299488e+00 Member 1: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -54,13 +54,13 @@ Member 1: - air_horizontal_streamfunction (2 levels): + min = -3.9329836209045563e+00 + max = 3.2828948862241365e+00 - + mean = 5.5366518585268376e-01 - + stddev = 1.1190796590201608e+00 + + mean = 4.3365762942565472e-01 + + stddev = 1.0807673255720425e+00 - air_pressure_at_surface (1 levels): + min = -2.9651259764945403e+00 + max = 2.5842773390372296e+00 - + mean = 4.1297067979763555e-02 - + stddev = 8.8009195844931576e-01 + + mean = 8.5012008000881999e-04 + + stddev = 9.0528157264538034e-01 Member 2: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -68,13 +68,13 @@ Member 2: - air_horizontal_streamfunction (2 levels): + min = -2.6630003496746255e+00 + max = 3.0504426957774782e+00 - + mean = 1.9829053649115796e-01 - + stddev = 1.0899772923972035e+00 + + mean = 1.9729386987111175e-01 + + stddev = 1.0298614097134766e+00 - air_pressure_at_surface (1 levels): + min = -3.4934290763538018e+00 + max = 3.2671550680493979e+00 - + mean = 2.2610800881655160e-01 - + stddev = 1.0330409473986177e+00 + + mean = 2.1338521424982507e-01 + + stddev = 1.0419962531855516e+00 Member 3: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -82,13 +82,13 @@ Member 3: - air_horizontal_streamfunction (2 levels): + min = -2.8337683160949481e+00 + max = 2.4158388831270576e+00 - + mean = 4.9653844297403238e-03 - + stddev = 9.4933388378772210e-01 + + mean = -4.9883999285504632e-02 + + stddev = 9.4844886483928026e-01 - air_pressure_at_surface (1 levels): + min = -2.4821742594254044e+00 + max = 3.3187740897949962e+00 - + mean = 2.8513971172458680e-01 - + stddev = 9.5260594077314176e-01 + + mean = 2.6609111448781697e-01 + + stddev = 9.7716870243683795e-01 Member 4: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -96,13 +96,13 @@ Member 4: - air_horizontal_streamfunction (2 levels): + min = -2.6788404608431930e+00 + max = 2.6750060623920944e+00 - + mean = 4.1687776491459945e-02 - + stddev = 9.2740057102833418e-01 + + mean = 2.8012730153397569e-02 + + stddev = 9.4012043439378634e-01 - air_pressure_at_surface (1 levels): + min = -2.8880119962138258e+00 + max = 2.8386109734287071e+00 - + mean = 2.8957326539582806e-01 - + stddev = 9.8880847725327703e-01 + + mean = 2.3518274114350424e-01 + + stddev = 9.9988795744776315e-01 Member 5: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -110,13 +110,13 @@ Member 5: - air_horizontal_streamfunction (2 levels): + min = -2.8392719173201568e+00 + max = 2.7344111909458668e+00 - + mean = 2.8589973944330915e-01 - + stddev = 9.0317093359394507e-01 + + mean = 2.1550512674359978e-01 + + stddev = 8.9078131456856557e-01 - air_pressure_at_surface (1 levels): + min = -2.5217054529102696e+00 + max = 3.3085773751000196e+00 - + mean = 9.0067204679329771e-02 - + stddev = 8.9049103327476409e-01 + + mean = 1.0023031702760242e-01 + + stddev = 9.2240810817534646e-01 Member 6: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -124,13 +124,13 @@ Member 6: - air_horizontal_streamfunction (2 levels): + min = -3.4328489791340657e+00 + max = 3.1798807903958712e+00 - + mean = -2.7445447284897763e-02 - + stddev = 9.4832808388420442e-01 + + mean = -4.9240696830581555e-02 + + stddev = 9.6669822343137612e-01 - air_pressure_at_surface (1 levels): + min = -2.8119735172608955e+00 + max = 3.1022447705794312e+00 - + mean = 8.3553828168270075e-02 - + stddev = 1.2110772525231874e+00 + + mean = 3.4220486501484008e-02 + + stddev = 1.1105879306605333e+00 Member 7: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -138,13 +138,13 @@ Member 7: - air_horizontal_streamfunction (2 levels): + min = -2.6442063936481404e+00 + max = 2.9096708978805208e+00 - + mean = -2.1623820447592668e-01 - + stddev = 9.2607560250097953e-01 + + mean = -1.3614938136387827e-01 + + stddev = 9.0911993275489089e-01 - air_pressure_at_surface (1 levels): + min = -3.2061095421940231e+00 + max = 3.3450631800358486e+00 - + mean = -4.0121130191347130e-02 - + stddev = 8.7384950979719267e-01 + + mean = -4.6799242886082892e-02 + + stddev = 8.7403195200346118e-01 Member 8: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -152,13 +152,13 @@ Member 8: - air_horizontal_streamfunction (2 levels): + min = -2.9846084360599212e+00 + max = 3.2038777751119527e+00 - + mean = 7.9283407643395531e-02 - + stddev = 1.0494487018231058e+00 + + mean = 7.7362092769019522e-02 + + stddev = 1.0045916341904555e+00 - air_pressure_at_surface (1 levels): + min = -3.1797681340319541e+00 + max = 2.8096891345703385e+00 - + mean = 2.3907280497027960e-02 - + stddev = 9.3418727220072084e-01 + + mean = -7.5495077416743691e-03 + + stddev = 9.6636896276635953e-01 Member 9: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -166,13 +166,13 @@ Member 9: - air_horizontal_streamfunction (2 levels): + min = -2.8972881421009995e+00 + max = 2.6038558925948219e+00 - + mean = 1.7683678948712134e-01 - + stddev = 8.4985359183977627e-01 + + mean = 1.1764774757485182e-01 + + stddev = 8.4613854591480453e-01 - air_pressure_at_surface (1 levels): + min = -3.0628850320654770e+00 + max = 2.4789698275254226e+00 - + mean = -1.9370225099107208e-01 - + stddev = 9.7350109920609884e-01 + + mean = -9.3505430236011405e-02 + + stddev = 9.2818359646740545e-01 Member 10: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -180,13 +180,13 @@ Member 10: - air_horizontal_streamfunction (2 levels): + min = -3.2121443468401449e+00 + max = 2.9708258445018019e+00 - + mean = -7.7416883121374435e-03 - + stddev = 9.1594038200527916e-01 + + mean = -3.9496631007093705e-02 + + stddev = 9.2777945731091749e-01 - air_pressure_at_surface (1 levels): + min = -2.6748063427043505e+00 + max = 3.0517263353531812e+00 - + mean = 8.7923994145967230e-02 - + stddev = 8.2720765436581689e-01 + + mean = 1.0766919236055619e-01 + + stddev = 8.4467049482800882e-01 Member 11: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -194,13 +194,13 @@ Member 11: - air_horizontal_streamfunction (2 levels): + min = -3.1538008227445862e+00 + max = 3.4856651141862947e+00 - + mean = 6.5099338044478261e-02 - + stddev = 1.0025685920484497e+00 + + mean = 5.2493792482124824e-02 + + stddev = 1.0262591197756108e+00 - air_pressure_at_surface (1 levels): + min = -2.5965155154900956e+00 + max = 3.0603002845005367e+00 - + mean = 8.5601803685058375e-02 - + stddev = 9.0956349518297264e-01 + + mean = 6.2644397632097185e-02 + + stddev = 9.4332744014203462e-01 Member 12: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -208,13 +208,13 @@ Member 12: - air_horizontal_streamfunction (2 levels): + min = -2.4954958110944618e+00 + max = 3.4065447406077989e+00 - + mean = -1.3027522553454166e-01 - + stddev = 9.2216293570299979e-01 + + mean = -1.2940668837069755e-01 + + stddev = 9.3299726746081324e-01 - air_pressure_at_surface (1 levels): + min = -3.6721502282048673e+00 + max = 2.7295903484733364e+00 - + mean = 2.0711423586560643e-01 - + stddev = 1.0725278842990169e+00 + + mean = 1.1786145552755148e-01 + + stddev = 1.0500777039002580e+00 Member 13: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -222,13 +222,13 @@ Member 13: - air_horizontal_streamfunction (2 levels): + min = -3.5853932346976922e+00 + max = 3.1022619851116029e+00 - + mean = -4.9390477701121649e-02 - + stddev = 9.1603477488270624e-01 + + mean = -4.2335365476570241e-02 + + stddev = 9.4674232987867446e-01 - air_pressure_at_surface (1 levels): + min = -2.9428172751452224e+00 + max = 2.2055105245231208e+00 - + mean = -3.0645747609300066e-02 - + stddev = 8.2322158030536818e-01 + + mean = -5.3294128201045142e-02 + + stddev = 8.5204865441974986e-01 Member 14: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -236,13 +236,13 @@ Member 14: - air_horizontal_streamfunction (2 levels): + min = -3.7712659570154217e+00 + max = 3.3728354729728109e+00 - + mean = -9.8430940487539281e-03 - + stddev = 9.6863084991630322e-01 + + mean = -1.6647495585716272e-02 + + stddev = 9.8051468911887563e-01 - air_pressure_at_surface (1 levels): + min = -3.0798758436415437e+00 + max = 3.3046088361705475e+00 - + mean = -6.2223606923257659e-02 - + stddev = 9.3679543909247165e-01 + + mean = -5.2068641991969207e-02 + + stddev = 9.6609607189263613e-01 Member 15: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -250,13 +250,13 @@ Member 15: - air_horizontal_streamfunction (2 levels): + min = -3.5350983057326806e+00 + max = 2.9275800246720376e+00 - + mean = -1.9130443823619855e-01 - + stddev = 1.0089779591117871e+00 + + mean = -1.8458184124188642e-01 + + stddev = 1.0345296774718487e+00 - air_pressure_at_surface (1 levels): + min = -2.6783066361357810e+00 + max = 3.7492614869569612e+00 - + mean = -5.9598396006539857e-02 - + stddev = 9.9894326110395115e-01 + + mean = -4.0794645526758933e-02 + + stddev = 1.0109618511607004e+00 Member 16: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -264,13 +264,13 @@ Member 16: - air_horizontal_streamfunction (2 levels): + min = -3.4267332834705551e+00 + max = 3.2817204395072159e+00 - + mean = -5.9218173909455496e-02 - + stddev = 8.7282046699329785e-01 + + mean = -2.5915713712864993e-02 + + stddev = 8.9130893480393270e-01 - air_pressure_at_surface (1 levels): + min = -3.0295784482484356e+00 + max = 2.2718614745267858e+00 - + mean = -9.9910938530879123e-02 - + stddev = 9.6350192123718048e-01 + + mean = -9.6012433617219145e-02 + + stddev = 9.5205332282482003e-01 Member 17: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -278,13 +278,13 @@ Member 17: - air_horizontal_streamfunction (2 levels): + min = -2.6658247098445238e+00 + max = 2.7272323845737203e+00 - + mean = 2.3483266410011909e-02 - + stddev = 9.1432075092337217e-01 + + mean = 2.2988914715501457e-03 + + stddev = 9.1867689200076974e-01 - air_pressure_at_surface (1 levels): + min = -3.0395631082584935e+00 + max = 3.1101160063907787e+00 - + mean = -1.4902366726930761e-02 - + stddev = 1.0185916975190275e+00 + + mean = 4.6824683562503418e-02 + + stddev = 1.0327008165191909e+00 Member 18: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -292,13 +292,13 @@ Member 18: - air_horizontal_streamfunction (2 levels): + min = -2.8657966575133789e+00 + max = 2.8543911899322381e+00 - + mean = -8.5266820825785128e-02 - + stddev = 8.3146023499965760e-01 + + mean = -3.1093643806436446e-02 + + stddev = 8.3429018002731758e-01 - air_pressure_at_surface (1 levels): + min = -2.2155446435321728e+00 + max = 2.9797618398657204e+00 - + mean = 8.3811125484037477e-02 - + stddev = 9.2649588007218997e-01 + + mean = 1.3852399653529765e-01 + + stddev = 9.2661018743225421e-01 Member 19: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -306,13 +306,13 @@ Member 19: - air_horizontal_streamfunction (2 levels): + min = -2.3833813081748239e+00 + max = 3.1280193833021928e+00 - + mean = -3.4275598960447538e-02 - + stddev = 8.5764146254168194e-01 + + mean = 8.3938404824163821e-04 + + stddev = 8.7593136450858977e-01 - air_pressure_at_surface (1 levels): + min = -2.8097146233670260e+00 + max = 3.0479771859954363e+00 - + mean = 3.0004873744372742e-02 - + stddev = 9.4123720993563464e-01 + + mean = 2.9389735952034929e-03 + + stddev = 9.2678647178465023e-01 Member 20: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -320,13 +320,13 @@ Member 20: - air_horizontal_streamfunction (2 levels): + min = -3.1540701653988950e+00 + max = 3.2416178870333452e+00 - + mean = -2.2870143212971286e-01 - + stddev = 8.7741919745990704e-01 + + mean = -2.1715585575204957e-01 + + stddev = 9.0788426083906471e-01 - air_pressure_at_surface (1 levels): + min = -2.3550581919327942e+00 + max = 3.1899237577770951e+00 - + mean = 5.0649443694473377e-02 - + stddev = 8.3541178475247813e-01 + + mean = 4.0579480127812824e-02 + + stddev = 8.6380560701643938e-01 Member 21: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -334,13 +334,13 @@ Member 21: - air_horizontal_streamfunction (2 levels): + min = -2.3780993264539063e+00 + max = 2.8298826275185109e+00 - + mean = 1.7200659967826071e-01 - + stddev = 8.0526743037478721e-01 + + mean = 1.3336916668689752e-01 + + stddev = 8.1704109865033703e-01 - air_pressure_at_surface (1 levels): + min = -2.6873283711184186e+00 + max = 2.3373539321924990e+00 - + mean = -7.6990199935449186e-02 - + stddev = 9.8327859710866095e-01 + + mean = -1.0269471695645399e-01 + + stddev = 1.0070308732399473e+00 Member 22: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -348,13 +348,13 @@ Member 22: - air_horizontal_streamfunction (2 levels): + min = -2.9858147539631181e+00 + max = 3.0648921711542956e+00 - + mean = 2.0433533047512728e-01 - + stddev = 9.2444549450741176e-01 + + mean = 1.3239869155238060e-01 + + stddev = 8.9816500699010282e-01 - air_pressure_at_surface (1 levels): + min = -3.4083648905672641e+00 + max = 3.6740233824522135e+00 - + mean = -7.0017690074675329e-02 - + stddev = 1.0195945858446194e+00 + + mean = -2.5008662417543834e-02 + + stddev = 1.0493954864475070e+00 Member 23: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -362,13 +362,13 @@ Member 23: - air_horizontal_streamfunction (2 levels): + min = -2.4046128220517211e+00 + max = 2.6823926024253408e+00 - + mean = 9.0384114161691689e-02 - + stddev = 9.3517643027492259e-01 + + mean = 5.1417757311862863e-02 + + stddev = 9.5089157348045905e-01 - air_pressure_at_surface (1 levels): + min = -2.3300245187685760e+00 + max = 3.0329451356494088e+00 - + mean = -7.0686855660186182e-03 - + stddev = 1.0400883797350597e+00 + + mean = 6.5043785577896779e-02 + + stddev = 1.0503778981909000e+00 Member 24: - Valid time: 2010-01-01T12:00:00Z Geometry: L48x25 [1200] @@ -376,10 +376,10 @@ Member 24: - air_horizontal_streamfunction (2 levels): + min = -2.5699072295246230e+00 + max = 2.5964883893144419e+00 - + mean = -6.5863254375789687e-02 - + stddev = 9.1613869072007492e-01 + + mean = -6.0303000244802347e-02 + + stddev = 9.2295189945279343e-01 - air_pressure_at_surface (1 levels): + min = -2.8307006824854430e+00 + max = 2.7231488846925536e+00 - + mean = -1.0918999520936915e-01 - + stddev = 9.4318655362182002e-01 + + mean = -1.3051083604168273e-01 + + stddev = 9.7747326532716505e-01 diff --git a/test/testref/randomization_increment_variables.ref b/test/testref/randomization_increment_variables.ref index 83d472cf2..e499d1e3a 100644 --- a/test/testref/randomization_increment_variables.ref +++ b/test/testref/randomization_increment_variables.ref @@ -5,5 +5,5 @@ Member 0: - air_pressure (2 levels): + min = -2.6992226243292614e+00 + max = 2.2849294606911874e+00 - + mean = 6.5718832969267907e-02 - + stddev = 1.0897401353101939e+00 + + mean = -1.6872639470696181e-03 + + stddev = 9.7013361234092221e-01 diff --git a/test/testref/randomization_sqrtspectralb_3.ref b/test/testref/randomization_sqrtspectralb_3.ref index fd1c338af..5f38cc4bd 100644 --- a/test/testref/randomization_sqrtspectralb_3.ref +++ b/test/testref/randomization_sqrtspectralb_3.ref @@ -9,35 +9,35 @@ Member 0: + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 - eastward_wind (70 levels): - + min = -1.2126907810657190e+01 - + max = 1.0498560426713164e+01 - + mean = -1.1106773041489597e-02 - + stddev = 1.0960081116433262e+00 + + min = -1.2126907810657187e+01 + + max = 1.0498560426713173e+01 + + mean = -1.1106773041489488e-02 + + stddev = 1.0960081116433260e+00 - geostrophic_pressure_levels_minus_one (70 levels): - + min = -1.3111053417243386e+02 - + max = 1.7502864473837690e+02 - + mean = 6.6135666857215269e-01 - + stddev = 2.5584430679352945e+01 + + min = -1.3111053417243406e+02 + + max = 1.7502864473837673e+02 + + mean = 6.6135666857214881e-01 + + stddev = 2.5584430679352955e+01 - hydrostatic_pressure_levels (71 levels): - + min = -9.0852434563626957e+01 - + max = 1.0512692382418936e+02 - + mean = 6.1239184012906289e-01 - + stddev = 1.8952490110036198e+01 + + min = -9.0852434563626872e+01 + + max = 1.0512692382405312e+02 + + mean = 6.1239184013344683e-01 + + stddev = 1.8952490110026798e+01 - mu (70 levels): - + min = -2.6660244740557077e+00 - + max = 3.5079942039000862e+00 - + mean = -1.7486321187143807e-02 + + min = -2.6660244740557086e+00 + + max = 3.5079942039000844e+00 + + mean = -1.7486321187143630e-02 + stddev = 3.8952517562954997e-01 - northward_wind (70 levels): - + min = -9.4469787890784271e+00 - + max = 1.0230858690513205e+01 - + mean = 1.6552709453616050e-02 - + stddev = 1.0900687898178394e+00 + + min = -9.4469787890784360e+00 + + max = 1.0230858690513200e+01 + + mean = 1.6552709453616012e-02 + + stddev = 1.0900687898178396e+00 - unbalanced_pressure_levels_minus_one (70 levels): + min = -6.4700423638566292e+01 + max = 7.5520503780907262e+01 - + mean = -5.8234289451931792e-02 - + stddev = 1.1585261549472133e+01 + + mean = -5.8234289447549867e-02 + + stddev = 1.1585261549458250e+01 Member 1: - Valid time: 2010-01-01T12:00:00Z Geometry: F12 [1152] @@ -49,35 +49,35 @@ Member 1: + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 - eastward_wind (70 levels): - + min = -1.1533561647006362e+01 - + max = 1.2016857144150102e+01 - + mean = -2.8929550339852460e-03 - + stddev = 1.0988199525644100e+00 + + min = -1.1533561647006364e+01 + + max = 1.2016857144150103e+01 + + mean = -2.8929550339851316e-03 + + stddev = 1.0988199525644096e+00 - geostrophic_pressure_levels_minus_one (70 levels): - + min = -1.5652938522537971e+02 - + max = 1.4896639227003010e+02 - + mean = 6.5244455395340228e-01 - + stddev = 2.6019155494013475e+01 + + min = -1.5652938522537920e+02 + + max = 1.4896639227002998e+02 + + mean = 6.5244455395339884e-01 + + stddev = 2.6019155494013489e+01 - hydrostatic_pressure_levels (71 levels): - + min = -1.0820091854836910e+02 - + max = 1.5180779538526616e+02 - + mean = 2.1576905356350458e+00 - + stddev = 2.1579931135178640e+01 + + min = -1.0820091854820301e+02 + + max = 1.5180779538526593e+02 + + mean = 2.1576905356341798e+00 + + stddev = 2.1579931135177311e+01 - mu (70 levels): - + min = -2.5197206379177124e+00 - + max = 2.8067306325034851e+00 - + mean = 5.2251887446836407e-03 - + stddev = 3.9253110214904291e-01 + + min = -2.5197206379177119e+00 + + max = 2.8067306325034864e+00 + + mean = 5.2251887446836667e-03 + + stddev = 3.9253110214904297e-01 - northward_wind (70 levels): - + min = -1.3174265030511414e+01 - + max = 1.2003435599755701e+01 - + mean = -1.4124934308475244e-02 - + stddev = 1.1248388506205393e+00 + + min = -1.3174265030511405e+01 + + max = 1.2003435599755695e+01 + + mean = -1.4124934308475119e-02 + + stddev = 1.1248388506205391e+00 - unbalanced_pressure_levels_minus_one (70 levels): + min = -6.8616840251850391e+01 + max = 8.3224117038033228e+01 - + mean = 1.4576614480691226e+00 - + stddev = 1.3129887390915698e+01 + + mean = 1.4576614480682428e+00 + + stddev = 1.3129887390957048e+01 Member 2: - Valid time: 2010-01-01T12:00:00Z Geometry: F12 [1152] @@ -89,35 +89,35 @@ Member 2: + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 - eastward_wind (70 levels): - + min = -1.2528704202986017e+01 - + max = 1.1746926595634422e+01 - + mean = -1.6253651486664640e-02 - + stddev = 1.1272838659986946e+00 + + min = -1.2528704202986013e+01 + + max = 1.1746926595634431e+01 + + mean = -1.6253651486664692e-02 + + stddev = 1.1272838659986941e+00 - geostrophic_pressure_levels_minus_one (70 levels): - + min = -1.8957485126281529e+02 - + max = 1.9705914137194438e+02 - + mean = -2.6418801228747368e-01 - + stddev = 2.7136062588786540e+01 + + min = -1.8957485126281540e+02 + + max = 1.9705914137194455e+02 + + mean = -2.6418801228747779e-01 + + stddev = 2.7136062588786533e+01 - hydrostatic_pressure_levels (71 levels): - + min = -1.1572268649479405e+02 - + max = 1.6852833660405565e+02 - + mean = -1.0031683881553854e+00 - + stddev = 2.0285444202001820e+01 + + min = -1.1572268649486909e+02 + + max = 1.6852833660405577e+02 + + mean = -1.0031683881651408e+00 + + stddev = 2.0285444201998921e+01 - mu (70 levels): - + min = -2.6919805132438177e+00 - + max = 2.7553591413243281e+00 - + mean = 1.5365830352327955e-02 - + stddev = 3.8505097592874921e-01 + + min = -2.6919805132438173e+00 + + max = 2.7553591413243277e+00 + + mean = 1.5365830352328006e-02 + + stddev = 3.8505097592874932e-01 - northward_wind (70 levels): - + min = -1.3815349175892761e+01 - + max = 9.6556397741915845e+00 - + mean = -1.4713586051086308e-02 + + min = -1.3815349175892763e+01 + + max = 9.6556397741915827e+00 + + mean = -1.4713586051086348e-02 + stddev = 1.1165812614648125e+00 - unbalanced_pressure_levels_minus_one (70 levels): - + min = -6.4067175714339214e+01 + + min = -6.4067175714319362e+01 + max = 8.4793627181053708e+01 - + mean = -5.6587188688509071e-01 - + stddev = 1.1231426941120848e+01 + + mean = -5.6587188689497192e-01 + + stddev = 1.1231426941114025e+01 Member 3: - Valid time: 2010-01-01T12:00:00Z Geometry: F12 [1152] @@ -129,35 +129,35 @@ Member 3: + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 - eastward_wind (70 levels): - + min = -9.8369217468987742e+00 - + max = 1.1152360895295704e+01 - + mean = -2.5106285722811300e-03 + + min = -9.8369217468987689e+00 + + max = 1.1152360895295708e+01 + + mean = -2.5106285722808919e-03 + stddev = 1.1173226673461976e+00 - geostrophic_pressure_levels_minus_one (70 levels): - + min = -1.7668620788264863e+02 - + max = 1.4130270602407401e+02 - + mean = 1.6056964621326733e-01 - + stddev = 2.3940575014450435e+01 + + min = -1.7668620788264846e+02 + + max = 1.4130270602407447e+02 + + mean = 1.6056964621326730e-01 + + stddev = 2.3940575014450427e+01 - hydrostatic_pressure_levels (71 levels): - + min = -1.0719516679147938e+02 - + max = 1.0577166318386043e+02 - + mean = -2.7049505261649942e-01 - + stddev = 1.6537698578065793e+01 + + min = -1.0719516679126608e+02 + + max = 1.0577166318386041e+02 + + mean = -2.7049505261224444e-01 + + stddev = 1.6537698578075208e+01 - mu (70 levels): + min = -2.7288695734500790e+00 + max = 2.5854404751870423e+00 - + mean = 1.0512141873925332e-02 + + mean = 1.0512141873925289e-02 + stddev = 3.9821351677826949e-01 - northward_wind (70 levels): - + min = -1.0541939116832488e+01 - + max = 1.5539699861581772e+01 - + mean = 5.1852333829487725e-03 + + min = -1.0541939116832497e+01 + + max = 1.5539699861581767e+01 + + mean = 5.1852333829487413e-03 + stddev = 1.0882519330049043e+00 - unbalanced_pressure_levels_minus_one (70 levels): - + min = -5.8872997861683409e+01 - + max = 6.3811234125938256e+01 - + mean = -4.3515783424137355e-01 - + stddev = 1.1191587116096628e+01 + + min = -5.8872997861683402e+01 + + max = 6.3811234125938249e+01 + + mean = -4.3515783423705057e-01 + + stddev = 1.1191587116101408e+01 Member 4: - Valid time: 2010-01-01T12:00:00Z Geometry: F12 [1152] @@ -170,34 +170,34 @@ Member 4: + max = 0.0000000000000000e+00 - eastward_wind (70 levels): + min = -1.2894599113636650e+01 - + max = 1.1307701716877961e+01 - + mean = 1.5754122114932191e-02 - + stddev = 1.1006644363441795e+00 + + max = 1.1307701716877967e+01 + + mean = 1.5754122114932333e-02 + + stddev = 1.1006644363441800e+00 - geostrophic_pressure_levels_minus_one (70 levels): - + min = -1.5738128848106291e+02 - + max = 1.2703739859893717e+02 - + mean = -7.3721122680623319e-01 - + stddev = 2.6681467268298789e+01 + + min = -1.5738128848106282e+02 + + max = 1.2703739859893736e+02 + + mean = -7.3721122680623274e-01 + + stddev = 2.6681467268298782e+01 - hydrostatic_pressure_levels (71 levels): - + min = -1.0581503743707910e+02 - + max = 1.0653215769199855e+02 - + mean = -6.1389746522725319e-01 - + stddev = 1.9917880965882844e+01 + + min = -1.0581503743707911e+02 + + max = 1.0653215769212692e+02 + + mean = -6.1389746522951683e-01 + + stddev = 1.9917880965891825e+01 - mu (70 levels): + min = -2.5842363190657611e+00 - + max = 2.4044146613891404e+00 - + mean = 4.7188373144403058e-02 - + stddev = 3.9431731851545598e-01 + + max = 2.4044146613891408e+00 + + mean = 4.7188373144402947e-02 + + stddev = 3.9431731851545609e-01 - northward_wind (70 levels): - + min = -1.3370852157721529e+01 - + max = 1.1614216089382440e+01 - + mean = 5.3268112883395613e-03 + + min = -1.3370852157721522e+01 + + max = 1.1614216089382456e+01 + + mean = 5.3268112883394581e-03 + stddev = 1.1065991058702560e+00 - unbalanced_pressure_levels_minus_one (70 levels): + min = -6.3197893443283178e+01 - + max = 8.7892387919791858e+01 - + mean = 5.1082336699100539e-01 - + stddev = 1.1130354976722549e+01 + + max = 8.7892387919791844e+01 + + mean = 5.1082336698870079e-01 + + stddev = 1.1130354976718364e+01 Member 5: - Valid time: 2010-01-01T12:00:00Z Geometry: F12 [1152] @@ -209,35 +209,35 @@ Member 5: + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 - eastward_wind (70 levels): - + min = -1.1622433656756568e+01 + + min = -1.1622433656756566e+01 + max = 1.3204137335454384e+01 - + mean = 2.8517861614583806e-02 + + mean = 2.8517861614583907e-02 + stddev = 1.1165527399365895e+00 - geostrophic_pressure_levels_minus_one (70 levels): - + min = -1.6323766495610425e+02 - + max = 1.9597233546729910e+02 - + mean = 7.5077797445146299e-01 - + stddev = 2.9480646404203156e+01 + + min = -1.6323766495610465e+02 + + max = 1.9597233546730024e+02 + + mean = 7.5077797445146166e-01 + + stddev = 2.9480646404203139e+01 - hydrostatic_pressure_levels (71 levels): - + min = -1.1077486319279382e+02 - + max = 1.1791839203718592e+02 - + mean = -6.8347331944445910e-01 - + stddev = 1.9344302156178472e+01 + + min = -1.1077486319279363e+02 + + max = 1.1791839203721898e+02 + + mean = -6.8347331944192224e-01 + + stddev = 1.9344302156182263e+01 - mu (70 levels): - + min = -2.6750013913285211e+00 - + max = 2.4213864523681274e+00 - + mean = -8.9562592394499506e-03 - + stddev = 3.8662372935169231e-01 + + min = -2.6750013913285215e+00 + + max = 2.4213864523681270e+00 + + mean = -8.9562592394498118e-03 + + stddev = 3.8662372935169226e-01 - northward_wind (70 levels): - + min = -9.9595178411005882e+00 - + max = 1.0853769344790713e+01 - + mean = 6.6820904540582067e-03 + + min = -9.9595178411005811e+00 + + max = 1.0853769344790711e+01 + + mean = 6.6820904540581998e-03 + stddev = 1.0835635350592976e+00 - unbalanced_pressure_levels_minus_one (70 levels): - + min = -5.8880091024365527e+01 + + min = -5.8880091024365520e+01 + max = 5.9443556658047441e+01 - + mean = -1.6888727782135757e+00 - + stddev = 1.1180000428277774e+01 + + mean = -1.6888727782109858e+00 + + stddev = 1.1180000428268110e+01 Member 6: - Valid time: 2010-01-01T12:00:00Z Geometry: F12 [1152] @@ -249,35 +249,35 @@ Member 6: + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 - eastward_wind (70 levels): - + min = -1.1682489104839155e+01 - + max = 1.0052804965834778e+01 - + mean = -2.1151577829042860e-03 - + stddev = 1.0853468602223271e+00 + + min = -1.1682489104839163e+01 + + max = 1.0052804965834767e+01 + + mean = -2.1151577829044686e-03 + + stddev = 1.0853468602223273e+00 - geostrophic_pressure_levels_minus_one (70 levels): - + min = -1.6891852451054473e+02 - + max = 1.7829291622315804e+02 - + mean = -4.7517611664533144e-01 - + stddev = 2.6975467068624695e+01 + + min = -1.6891852451054410e+02 + + max = 1.7829291622315768e+02 + + mean = -4.7517611664532278e-01 + + stddev = 2.6975467068624685e+01 - hydrostatic_pressure_levels (71 levels): - + min = -1.3588496442542817e+02 - + max = 1.1073685669345926e+02 - + mean = -5.2461353866177096e-01 - + stddev = 2.0801270769912122e+01 + + min = -1.3588496442542822e+02 + + max = 1.1073685669345942e+02 + + mean = -5.2461353866597316e-01 + + stddev = 2.0801270769941382e+01 - mu (70 levels): + min = -2.7435235665912399e+00 + max = 2.2968206634641692e+00 - + mean = 1.6288662046973226e-02 + + mean = 1.6288662046973063e-02 + stddev = 3.8975220319125364e-01 - northward_wind (70 levels): + min = -1.1930287374375169e+01 - + max = 1.5851756871523817e+01 - + mean = 6.5920062958299865e-03 + + max = 1.5851756871523836e+01 + + mean = 6.5920062958300316e-03 + stddev = 1.1200526614386950e+00 - unbalanced_pressure_levels_minus_one (70 levels): - + min = -6.0684159250077947e+01 - + max = 8.2845326225957422e+01 - + mean = 2.0081837964793117e-01 - + stddev = 1.1963108034112883e+01 + + min = -6.0684159250077940e+01 + + max = 8.2845326225957450e+01 + + mean = 2.0081837964367349e-01 + + stddev = 1.1963108034141948e+01 Member 7: - Valid time: 2010-01-01T12:00:00Z Geometry: F12 [1152] @@ -289,35 +289,35 @@ Member 7: + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 - eastward_wind (70 levels): - + min = -1.1874830268783249e+01 - + max = 1.4351636624679898e+01 - + mean = 2.3317366153096708e-02 - + stddev = 1.1004472595369106e+00 + + min = -1.1874830268783237e+01 + + max = 1.4351636624679902e+01 + + mean = 2.3317366153096698e-02 + + stddev = 1.1004472595369110e+00 - geostrophic_pressure_levels_minus_one (70 levels): - + min = -1.6303946659923059e+02 - + max = 1.5803173299619505e+02 - + mean = -8.6399440081193712e-01 - + stddev = 2.6775421957921466e+01 + + min = -1.6303946659923082e+02 + + max = 1.5803173299619516e+02 + + mean = -8.6399440081193246e-01 + + stddev = 2.6775421957921498e+01 - hydrostatic_pressure_levels (71 levels): - + min = -1.3159523819402361e+02 - + max = 1.3477720420802149e+02 - + mean = -1.2887026060696203e+00 - + stddev = 2.1149362722027732e+01 + + min = -1.3159523819402369e+02 + + max = 1.3477720420802123e+02 + + mean = -1.2887026060698992e+00 + + stddev = 2.1149362722027096e+01 - mu (70 levels): - + min = -3.0100911076724906e+00 - + max = 2.4007879794427094e+00 - + mean = 3.8074915197997466e-02 + + min = -3.0100911076724910e+00 + + max = 2.4007879794427112e+00 + + mean = 3.8074915197997640e-02 + stddev = 3.9279190720256563e-01 - northward_wind (70 levels): - + min = -1.0541909609722195e+01 - + max = 1.0583639041145016e+01 - + mean = 1.5719054642411689e-02 + + min = -1.0541909609722202e+01 + + max = 1.0583639041145027e+01 + + mean = 1.5719054642411658e-02 + stddev = 1.0937954512867494e+00 - unbalanced_pressure_levels_minus_one (70 levels): + min = -7.0536017577364532e+01 + max = 8.2723644439552942e+01 - + mean = -3.8582849431352090e-01 - + stddev = 1.2722813286454560e+01 + + mean = -3.8582849431379540e-01 + + stddev = 1.2722813286466321e+01 Member 8: - Valid time: 2010-01-01T12:00:00Z Geometry: F12 [1152] @@ -331,33 +331,33 @@ Member 8: - eastward_wind (70 levels): + min = -1.1325680651751050e+01 + max = 1.2266789712673283e+01 - + mean = -9.0026671786491395e-03 + + mean = -9.0026671786491326e-03 + stddev = 1.1076143754917436e+00 - geostrophic_pressure_levels_minus_one (70 levels): - + min = -1.5071242025253446e+02 - + max = 1.4462722647750911e+02 - + mean = 1.3544818656216913e+00 - + stddev = 2.6407792847029071e+01 + + min = -1.5071242025253429e+02 + + max = 1.4462722647750917e+02 + + mean = 1.3544818656216946e+00 + + stddev = 2.6407792847029061e+01 - hydrostatic_pressure_levels (71 levels): - + min = -9.5683034167743628e+01 - + max = 1.1224271140054211e+02 - + mean = 1.3937360604354907e+00 - + stddev = 1.9485789282212540e+01 + + min = -9.5683034167575499e+01 + + max = 1.1224271140054199e+02 + + mean = 1.3937360604362137e+00 + + stddev = 1.9485789282203520e+01 - mu (70 levels): - + min = -2.5020219609348828e+00 + + min = -2.5020219609348824e+00 + max = 2.1501454471979073e+00 - + mean = -8.1789069101014730e-02 - + stddev = 4.0328224528718615e-01 + + mean = -8.1789069101014661e-02 + + stddev = 4.0328224528718631e-01 - northward_wind (70 levels): - + min = -1.1085963373807429e+01 - + max = 9.5999246778763041e+00 - + mean = -1.9111253609952084e-02 + + min = -1.1085963373807431e+01 + + max = 9.5999246778763094e+00 + + mean = -1.9111253609952108e-02 + stddev = 1.0825291544448898e+00 - unbalanced_pressure_levels_minus_one (70 levels): + min = -8.2678637668127848e+01 - + max = 6.3954378795489305e+01 - + mean = -2.4948643091644582e-01 - + stddev = 1.0848701239245743e+01 + + max = 6.3954378795489291e+01 + + mean = -2.4948643091568987e-01 + + stddev = 1.0848701239239313e+01 Member 9: - Valid time: 2010-01-01T12:00:00Z Geometry: F12 [1152] @@ -369,35 +369,35 @@ Member 9: + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 - eastward_wind (70 levels): - + min = -1.1337365271968867e+01 - + max = 1.0305990376874139e+01 - + mean = 3.1500361956183689e-03 + + min = -1.1337365271968864e+01 + + max = 1.0305990376874131e+01 + + mean = 3.1500361956184838e-03 + stddev = 1.0999706706011840e+00 - geostrophic_pressure_levels_minus_one (70 levels): - + min = -1.3347704330970905e+02 - + max = 1.9720661777471261e+02 - + mean = 1.3558118626047069e+00 - + stddev = 2.7301232167172621e+01 + + min = -1.3347704330970959e+02 + + max = 1.9720661777471295e+02 + + mean = 1.3558118626046980e+00 + + stddev = 2.7301232167172639e+01 - hydrostatic_pressure_levels (71 levels): - + min = -8.9570516204291295e+01 - + max = 1.4695475609875245e+02 - + mean = 1.4191457387363506e+00 - + stddev = 2.1192932776956344e+01 + + min = -8.9570516204291366e+01 + + max = 1.4695475609885784e+02 + + mean = 1.4191457387400395e+00 + + stddev = 2.1192932776960355e+01 - mu (70 levels): - + min = -2.7928412135150946e+00 - + max = 2.6625508925125705e+00 - + mean = -1.4080175535732067e-02 - + stddev = 3.9200491493178652e-01 + + min = -2.7928412135150942e+00 + + max = 2.6625508925125700e+00 + + mean = -1.4080175535731852e-02 + + stddev = 3.9200491493178646e-01 - northward_wind (70 levels): - + min = -1.0135973862183050e+01 - + max = 1.2228148195399484e+01 - + mean = -1.1976753316947839e-02 - + stddev = 1.1015968003567607e+00 + + min = -1.0135973862183043e+01 + + max = 1.2228148195399486e+01 + + mean = -1.1976753316947824e-02 + + stddev = 1.1015968003567609e+00 - unbalanced_pressure_levels_minus_one (70 levels): + min = -7.3586145041968734e+01 - + max = 8.3247037994014789e+01 - + mean = -3.9957072995176868e-01 - + stddev = 1.2333645572058561e+01 + + max = 8.3247037994014775e+01 + + mean = -3.9957072994810267e-01 + + stddev = 1.2333645572065691e+01 Randomized variance: - Valid time: 2010-01-01T12:00:00Z Geometry: F12 [1152] @@ -409,32 +409,32 @@ Randomized variance: + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 - eastward_wind (70 levels): - + min = 1.0045259858687599e-02 - + max = 3.7943552922808898e+01 - + mean = 1.2213628592481742e+00 + + min = 1.0045259858687589e-02 + + max = 3.7943552922808919e+01 + + mean = 1.2213628592481747e+00 + stddev = 2.0890587557158531e+00 - geostrophic_pressure_levels_minus_one (70 levels): - + min = 8.3202892778817339e-06 - + max = 8.9055828963805816e+03 + + min = 8.3202892778817102e-06 + + max = 8.9055828963805634e+03 + mean = 7.1160363897870945e+02 - + stddev = 8.8574465874041834e+02 + + stddev = 8.8574465874041846e+02 - hydrostatic_pressure_levels (71 levels): - + min = 1.0392739772072254e-06 - + max = 6.0741395929659102e+03 - + mean = 4.0024316740964127e+02 - + stddev = 5.9621857163733307e+02 + + min = 1.0392739772094972e-06 + + max = 6.0741395929659129e+03 + + mean = 4.0024316740977082e+02 + + stddev = 5.9621857163747904e+02 - mu (70 levels): - + min = 7.9271267354239254e-04 - + max = 1.7461530703230546e+00 - + mean = 1.5516797976425284e-01 + + min = 7.9271267354239525e-04 + + max = 1.7461530703230554e+00 + + mean = 1.5516797976425281e-01 + stddev = 1.5393159038265550e-01 - northward_wind (70 levels): - + min = 5.9312646079506450e-03 - + max = 3.9302181850642143e+01 + + min = 5.9312646079506372e-03 + + max = 3.9302181850642150e+01 + mean = 1.2120960081246430e+00 - + stddev = 2.0502738780985554e+00 + + stddev = 2.0502738780985559e+00 - unbalanced_pressure_levels_minus_one (70 levels): - + min = 4.2968353719082534e-05 + + min = 4.2968353719155656e-05 + max = 1.5450416030089955e+03 - + mean = 1.3878300074367957e+02 - + stddev = 1.8294806616694316e+02 + + mean = 1.3878300074382153e+02 + + stddev = 1.8294806616713046e+02 diff --git a/test/testref/randomization_sqrtspectralb_4.ref b/test/testref/randomization_sqrtspectralb_4.ref index ba0668005..955ca2eb2 100644 --- a/test/testref/randomization_sqrtspectralb_4.ref +++ b/test/testref/randomization_sqrtspectralb_4.ref @@ -3,86 +3,86 @@ Member 0: Geometry: F12 [1152] Fields: - air_potential_temperature (70 levels): - + min = -8.3256366181305523e+01 - + max = 8.7250337589169121e+01 - + mean = 1.7729617030332916e-02 - + stddev = 4.4022816257789827e+00 + + min = -8.3256366181269314e+01 + + max = 8.7250337589198210e+01 + + mean = 1.7729617030327997e-02 + + stddev = 4.4022816257792741e+00 - cloud_ice_mixing_ratio_wrt_moist_air_and_condensed_water (70 levels): - + min = -5.4628678241201306e-05 - + max = 4.4064143119401127e-05 - + mean = -1.1563062862950598e-08 - + stddev = 1.3407326383508859e-06 + + min = -5.4628678241243468e-05 + + max = 4.4064143119377789e-05 + + mean = -1.1563062862967151e-08 + + stddev = 1.3407326383511392e-06 - cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water (70 levels): - + min = -1.2607609138370212e-04 - + max = 1.2001845727964047e-04 - + mean = -8.4562905273090186e-09 - + stddev = 2.2178508294450474e-06 + + min = -1.2607609138379759e-04 + + max = 1.2001845727938182e-04 + + mean = -8.4562905274337260e-09 + + stddev = 2.2178508294457636e-06 - dimensionless_exner_function_levels_minus_one (70 levels): - + min = -4.7513612709758015e-04 - + max = 4.4243104341991330e-04 - + mean = 4.1609997941017900e-06 - + stddev = 9.4666071889907213e-05 + + min = -4.7513612709697224e-04 + + max = 4.4243104341952716e-04 + + mean = 4.1609997941321799e-06 + + stddev = 9.4666071889830207e-05 - dry_air_density_levels_minus_one (70 levels): - + min = -7.4575547717846647e-03 - + max = 7.8656033201452025e-03 - + mean = -5.1246933947658082e-06 - + stddev = 1.0283149377233686e-03 + + min = -7.4575547717854072e-03 + + max = 7.8656033201528388e-03 + + mean = -5.1246933948208391e-06 + + stddev = 1.0283149377234347e-03 - eastward_wind (70 levels): - + min = -1.2126907810657190e+01 - + max = 1.0498560426713164e+01 - + mean = -1.1106773041489597e-02 - + stddev = 1.0960081116433262e+00 + + min = -1.2126907810657187e+01 + + max = 1.0498560426713173e+01 + + mean = -1.1106773041489488e-02 + + stddev = 1.0960081116433260e+00 - northward_wind (70 levels): - + min = -9.4469787890784271e+00 - + max = 1.0230858690513205e+01 - + mean = 1.6552709453616050e-02 - + stddev = 1.0900687898178394e+00 + + min = -9.4469787890784360e+00 + + max = 1.0230858690513200e+01 + + mean = 1.6552709453616012e-02 + + stddev = 1.0900687898178396e+00 - water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water (70 levels): - + min = -1.7503711448207053e-03 - + max = 1.7355262861427595e-03 - + mean = -3.1686017474498902e-07 - + stddev = 1.2835180546021813e-04 + + min = -1.7503711448223350e-03 + + max = 1.7355262861415348e-03 + + mean = -3.1686017474388862e-07 + + stddev = 1.2835180546021585e-04 Member 1: - Valid time: 2010-01-01T16:00:00Z Geometry: F12 [1152] Fields: - air_potential_temperature (70 levels): - + min = -7.4199741583783378e+01 - + max = 8.2274907509525519e+01 - + mean = 1.5999654354340446e-03 - + stddev = 4.2852565855577209e+00 + + min = -7.4199741583949447e+01 + + max = 8.2274907509500963e+01 + + mean = 1.5999654351802983e-03 + + stddev = 4.2852565855581028e+00 - cloud_ice_mixing_ratio_wrt_moist_air_and_condensed_water (70 levels): - + min = -6.7474604357094600e-05 - + max = 3.4226634419643251e-05 - + mean = -2.7491701474319792e-08 - + stddev = 1.4163546467682480e-06 + + min = -6.7474604357068281e-05 + + max = 3.4226634419636482e-05 + + mean = -2.7491701474305730e-08 + + stddev = 1.4163546467685150e-06 - cloud_liquid_water_mixing_ratio_wrt_moist_air_and_condensed_water (70 levels): - + min = -1.5016211395130766e-04 - + max = 1.8510122702623794e-04 - + mean = 3.6973965096095064e-08 - + stddev = 2.7401884504113407e-06 + + min = -1.5016211395135973e-04 + + max = 1.8510122702831435e-04 + + mean = 3.6973965097337085e-08 + + stddev = 2.7401884504152323e-06 - dimensionless_exner_function_levels_minus_one (70 levels): - + min = -6.0991343452614544e-04 - + max = 5.1021613787658490e-04 - + mean = 1.1211521046691961e-05 - + stddev = 1.0794971778438781e-04 + + min = -6.0991343452448043e-04 + + max = 5.1021613787785342e-04 + + mean = 1.1211521046693396e-05 + + stddev = 1.0794971778439578e-04 - dry_air_density_levels_minus_one (70 levels): - + min = -5.8174765071333061e-03 - + max = 8.7136867369725455e-03 - + mean = 2.5690841369296804e-05 - + stddev = 1.0592880132675243e-03 + + min = -5.8174765071336513e-03 + + max = 8.7136867369926041e-03 + + mean = 2.5690841369404868e-05 + + stddev = 1.0592880132691332e-03 - eastward_wind (70 levels): - + min = -1.1533561647006362e+01 - + max = 1.2016857144150102e+01 - + mean = -2.8929550339852460e-03 - + stddev = 1.0988199525644100e+00 + + min = -1.1533561647006364e+01 + + max = 1.2016857144150103e+01 + + mean = -2.8929550339851316e-03 + + stddev = 1.0988199525644096e+00 - northward_wind (70 levels): - + min = -1.3174265030511414e+01 - + max = 1.2003435599755701e+01 - + mean = -1.4124934308475244e-02 - + stddev = 1.1248388506205393e+00 + + min = -1.3174265030511405e+01 + + max = 1.2003435599755695e+01 + + mean = -1.4124934308475119e-02 + + stddev = 1.1248388506205391e+00 - water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water (70 levels): - + min = -1.5137558606339999e-03 - + max = 1.5692647612039596e-03 - + mean = 1.4026421756818809e-06 - + stddev = 1.3284128602043788e-04 + + min = -1.5137558606376591e-03 + + max = 1.5692647612051398e-03 + + mean = 1.4026421756797280e-06 + + stddev = 1.3284128602045883e-04 From 5b76c31e4c6e885570c418a1aadbd19435f3b7c8 Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Thu, 23 Oct 2025 17:22:08 +0200 Subject: [PATCH 122/199] Option to run SABER without OpenMP (#1126) --- CMakeLists.txt | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 10f0c66a5..a7429e231 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -45,9 +45,11 @@ find_package( NetCDF REQUIRED COMPONENTS C Fortran ) #cltold find_package( atlas 0.35.0 REQUIRED COMPONENTS OMP_Fortran ) find_package( eckit 1.17.1 REQUIRED COMPONENTS MPI ) find_package( fckit 0.9.5 REQUIRED ) -set(CMAKE_FIND_DEBUG_MODE TRUE) -#clt find_package( atlas 0.35.0 REQUIRED COMPONENTS OMP_Fortran TESSELATION) -find_package( atlas 0.35.0 REQUIRED COMPONENTS OMP_Fortran ) +if(OpenMP_FOUND) + find_package( atlas 0.35.0 REQUIRED COMPONENTS OMP_Fortran TESSELATION) +else() + find_package( atlas 0.35.0 REQUIRED COMPONENTS TESSELATION) +endif() # TODO(Benjamin): check when ATLAS PR #215 is merged into a tagged version to update the version number if( atlas_VERSION VERSION_GREATER "0.38.1" ) set( ATLAS_REGIONAL_INTERP ON ) From bd1a557e3705b537e98cc367c9d55e5ac24e4881 Mon Sep 17 00:00:00 2001 From: Anna Shlyaeva Date: Fri, 24 Oct 2025 08:59:55 -0600 Subject: [PATCH 123/199] ProcessPerts with diffusion (#1118) * Allow filtering option for the central blocks; implement it for Diffusion * Add tests (and fix a coding norm) --------- Co-authored-by: Anna Shlyaeva Co-authored-by: Nate Crossette --- src/saber/blocks/SaberCentralBlockBase.h | 9 +++- src/saber/blocks/SaberParametricBlockChain.cc | 2 +- src/saber/diffusion/Diffusion.cc | 25 +++++++++ src/saber/diffusion/Diffusion.h | 1 + .../error_covariance_training_diffusion_3.txt | 0 test/testdeps/process_perts_diffusion_1.txt | 2 + ...error_covariance_training_diffusion_3.yaml | 35 +++++++++++++ test/testinput/process_perts_diffusion_1.yaml | 52 +++++++++++++++++++ test/testinput/randomization_diffusion_2.yaml | 3 +- test/testlist/saber_test_tier1.txt | 2 + .../error_covariance_training_diffusion_3.ref | 0 test/testref/process_perts_diffusion_1.ref | 6 +++ 12 files changed, 133 insertions(+), 4 deletions(-) create mode 100644 test/testdeps/error_covariance_training_diffusion_3.txt create mode 100644 test/testdeps/process_perts_diffusion_1.txt create mode 100644 test/testinput/error_covariance_training_diffusion_3.yaml create mode 100644 test/testinput/process_perts_diffusion_1.yaml create mode 100644 test/testref/error_covariance_training_diffusion_3.ref create mode 100644 test/testref/process_perts_diffusion_1.ref diff --git a/src/saber/blocks/SaberCentralBlockBase.h b/src/saber/blocks/SaberCentralBlockBase.h index 1bfea430d..c97e74d7d 100644 --- a/src/saber/blocks/SaberCentralBlockBase.h +++ b/src/saber/blocks/SaberCentralBlockBase.h @@ -51,12 +51,17 @@ class SaberCentralBlockBase : public util::Printable, // Application methods - // Block multiplication + // Block randomization virtual void randomize(oops::FieldSet3D &) const = 0; - // Block randomization + // Block multiplication virtual void multiply(oops::FieldSet3D &) const = 0; + // Block filtering; by default calls multiply + virtual void filter(oops::FieldSet3D & fset) const { + this->multiply(fset); + } + // Setup / calibration methods // Read block data diff --git a/src/saber/blocks/SaberParametricBlockChain.cc b/src/saber/blocks/SaberParametricBlockChain.cc index 325d6a931..474859ced 100644 --- a/src/saber/blocks/SaberParametricBlockChain.cc +++ b/src/saber/blocks/SaberParametricBlockChain.cc @@ -193,7 +193,7 @@ void SaberParametricBlockChain::filter(oops::FieldSet4D & fset4d) const { // No cross-time covariances: apply central block to each of the // time slots. for (size_t jtime = 0; jtime < fset4d.size(); ++jtime) { - centralBlock_->multiply(fset4d[jtime]); + centralBlock_->filter(fset4d[jtime]); } // Outer blocks forward multiplication diff --git a/src/saber/diffusion/Diffusion.cc b/src/saber/diffusion/Diffusion.cc index ec23c1694..98d64c152 100644 --- a/src/saber/diffusion/Diffusion.cc +++ b/src/saber/diffusion/Diffusion.cc @@ -244,6 +244,31 @@ void Diffusion::multiply(oops::FieldSet3D & fset) const { // -------------------------------------------------------------------------------------- +void Diffusion::filter(oops::FieldSet3D & fset) const { + const atlas::FunctionSpace & fs = geom_.functionSpace(); + + // iterate through the list of groups + for (const auto & group : groups_) { + // get the subset of fields, or create a common field if doing duplicated variable + // strategy + atlas::FieldSet fieldSubset; + for (const auto & var : group.vars.variables()) { + // TODO(Travis) make sure the variables in the active var list + fieldSubset.add(fset[var]); + } + // Do the diffusion for each field + for (auto & field : fieldSubset) { + atlas::FieldSet fset; + fset.add(field); + group.diffusion->multiplySqrtAD(fset); + group.diffusion->multiplySqrtTL(fset); + } + // end of group loop + } +} + +// -------------------------------------------------------------------------------------- + void Diffusion::read() { oops::Log::info() << "\n==================================================================================\n" diff --git a/src/saber/diffusion/Diffusion.h b/src/saber/diffusion/Diffusion.h index ce1f1f5f3..e4d6b8ae3 100644 --- a/src/saber/diffusion/Diffusion.h +++ b/src/saber/diffusion/Diffusion.h @@ -41,6 +41,7 @@ class Diffusion : public saber::SaberCentralBlockBase { void randomize(oops::FieldSet3D &) const override; void multiply(oops::FieldSet3D &) const override; + void filter(oops::FieldSet3D &) const override; void read() override; std::vector> getReadConfs() const override; diff --git a/test/testdeps/error_covariance_training_diffusion_3.txt b/test/testdeps/error_covariance_training_diffusion_3.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/testdeps/process_perts_diffusion_1.txt b/test/testdeps/process_perts_diffusion_1.txt new file mode 100644 index 000000000..919f3ae99 --- /dev/null +++ b/test/testdeps/process_perts_diffusion_1.txt @@ -0,0 +1,2 @@ +randomization_diffusion_2 +error_covariance_training_diffusion_3 diff --git a/test/testinput/error_covariance_training_diffusion_3.yaml b/test/testinput/error_covariance_training_diffusion_3.yaml new file mode 100644 index 000000000..60f9583f2 --- /dev/null +++ b/test/testinput/error_covariance_training_diffusion_3.yaml @@ -0,0 +1,35 @@ +geometry: + function space: StructuredColumns + grid: + type: regular_gaussian + N: 10 + groups: + - variables: &vars + - air_horizontal_streamfunction + levels: &levels 10 + halo: 1 + +background: + date: 2010-01-01T12:00:00Z + state variables: *vars + +background error: + covariance model: SABER + saber central block: + saber block name: diffusion + calibration: + normalization: + iterations: 1000 + groups: + - horizontal: + fixed value: 4000.0e3 + write: + filepath: testdata/error_covariance_training_diffusion_3/hz-_MPI_-_OMP_ + - vertical: + levels: *levels + fixed value: 1.0 + as gaussian: true + write: + filepath: testdata/error_covariance_training_diffusion_3/vt-_MPI_-_OMP_ +test: + reference filename: testref/error_covariance_training_diffusion_3.ref diff --git a/test/testinput/process_perts_diffusion_1.yaml b/test/testinput/process_perts_diffusion_1.yaml new file mode 100644 index 000000000..5f28b762d --- /dev/null +++ b/test/testinput/process_perts_diffusion_1.yaml @@ -0,0 +1,52 @@ +geometry: + function space: StructuredColumns + grid: + name: S10 + groups: + - variables: &vars + - air_horizontal_streamfunction + levels: &levels 10 + halo: 1 + +background: + date: &date 2010-01-01T12:00:00Z + state variables: *vars + +bands: +- band: + filter: + saber central block: + saber block name: diffusion + read: + groups: + - variables: *vars + horizontal: + filepath: testdata/error_covariance_training_diffusion_3/hz-1-1 + vertical: + levels: *levels + filepath: testdata/error_covariance_training_diffusion_3/vt-1-1 + output: + model write: + filepath: testdata/process_perts_diffusion_1/filtered_pert_mb%MEM%_wb1 + member pattern: '%MEM%' +- band: + residual increment from previous bands: true + output: + model write: + filepath: testdata/process_perts_diffusion_1/filtered_pert_mb%MEM%_wb2 + member pattern: '%MEM%' + +ensemble pert: + date: *date + members from template: + nmembers: 2 + pattern: '%MEM%' + template: + filepath: testdata/randomization_diffusion_2/1-1_member_pert_%MEM% + variables: *vars + +input variables: *vars + +test: + reference filename: testref/process_perts_diffusion_1.ref + test output filename: testref/process_perts_diffusion_1.test.out diff --git a/test/testinput/randomization_diffusion_2.yaml b/test/testinput/randomization_diffusion_2.yaml index e568020cc..0bd604ddb 100644 --- a/test/testinput/randomization_diffusion_2.yaml +++ b/test/testinput/randomization_diffusion_2.yaml @@ -27,7 +27,8 @@ background error: randomization size: 10 output perturbations: - filepath: testdata/randomization_diffusion_2/_MPI_-_OMP__member_pert + member pattern: '%MEM%' + filepath: testdata/randomization_diffusion_2/_MPI_-_OMP__member_pert_%MEM% test: reference filename: testref/randomization_diffusion_2.ref diff --git a/test/testlist/saber_test_tier1.txt b/test/testlist/saber_test_tier1.txt index 71c19e7d0..b14b74edb 100644 --- a/test/testlist/saber_test_tier1.txt +++ b/test/testlist/saber_test_tier1.txt @@ -13,6 +13,8 @@ dirac_interpolation_5 dirac_duplicate_variables error_covariance_training_diffusion_1 error_covariance_training_diffusion_2 +error_covariance_training_diffusion_3 +process_perts_diffusion_1 randomization_diffusion_1 randomization_diffusion_2 randomization_increment_variables diff --git a/test/testref/error_covariance_training_diffusion_3.ref b/test/testref/error_covariance_training_diffusion_3.ref new file mode 100644 index 000000000..e69de29bb diff --git a/test/testref/process_perts_diffusion_1.ref b/test/testref/process_perts_diffusion_1.ref new file mode 100644 index 000000000..4e31db4d5 --- /dev/null +++ b/test/testref/process_perts_diffusion_1.ref @@ -0,0 +1,6 @@ +Norm of perturbation: member 1: 2.6620275517839055e+01 +Norm of band perturbation: member 1: band 1: 8.6529517501746600e+00 +Norm of band perturbation: member 1: band 2: 2.1446912643529263e+01 +Norm of perturbation: member 2: 2.5901045342933138e+01 +Norm of band perturbation: member 2: band 1: 8.9842151461329305e+00 +Norm of band perturbation: member 2: band 2: 2.0471048859264453e+01 From 0958eeb51421435f5f01f0587472a2868865e004 Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Wed, 29 Oct 2025 15:22:51 +0100 Subject: [PATCH 124/199] Add check for geometry changes in outer blocks (#1133) * Add check for geometry changes, update Biperiodization block tests * Update comment * Simplification --- src/saber/bifourier/Biperiodization.cc | 104 +++++++++------------ src/saber/bifourier/Biperiodization.h | 12 +-- src/saber/bifourier/BiperiodizationImpl.cc | 6 ++ src/saber/bifourier/BiperiodizationImpl.h | 4 + src/saber/blocks/SaberOuterBlockBase.h | 12 ++- src/saber/blocks/SaberOuterBlockChain.h | 22 ++++- test/testref/dirac_biperiodization_1.ref | 3 - test/testref/dirac_biperiodization_2.ref | 3 - 8 files changed, 87 insertions(+), 79 deletions(-) diff --git a/src/saber/bifourier/Biperiodization.cc b/src/saber/bifourier/Biperiodization.cc index 75290fb59..83f8ca3a6 100644 --- a/src/saber/bifourier/Biperiodization.cc +++ b/src/saber/bifourier/Biperiodization.cc @@ -29,27 +29,45 @@ Biperiodization::Biperiodization(const oops::GeometryData & outerGeometryData, const oops::FieldSet3D & xb, const oops::FieldSet3D & fg) : SaberOuterBlockBase(params, xb.validTime()), - comm_(outerGeometryData.comm()), + outerGeometryData_(outerGeometryData), + comm_(outerGeometryData_.comm()), innerVars_(outerVars), params_(params) { oops::Log::trace() << classname() << "::Biperiodization starting" << std::endl; // Setup biperiodization implementation - biper_.reset(new BiperiodizationImpl(outerGeometryData, outerVars, params_.biperParams.value())); + biper_.reset(new BiperiodizationImpl(outerGeometryData_, outerVars, params_.biperParams.value())); // Empty inner FieldSet atlas::FieldSet innerFset; - // Generate inner GeometryData - innerGeometryData_.reset(new oops::GeometryData(biper_->innerFunctionSpace(), innerFset, - outerGeometryData.levelsAreTopDown(), comm_)); + if (!biper_->sameGrid()) { + // Generate inner GeometryData + innerGeometryData_.reset(new oops::GeometryData(biper_->innerFunctionSpace(), innerFset, + outerGeometryData_.levelsAreTopDown(), comm_)); + } + + if (params_.read.value() != boost::none) { + // Create input test fieldset + inputTestFset_.reset(new oops::FieldSet3D(xb.validTime(), outerGeometryData_.comm())); + } oops::Log::trace() << classname() << "::Biperiodization done" << std::endl; } // ----------------------------------------------------------------------------- +const oops::GeometryData & Biperiodization::innerGeometryData() const { + if (innerGeometryData_) { + return *innerGeometryData_; + } else { + return outerGeometryData_; + } +} + +// ----------------------------------------------------------------------------- + void Biperiodization::multiply(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiply starting" << std::endl; @@ -81,66 +99,15 @@ void Biperiodization::leftInverseMultiply(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::leftInverseMultiply done" << std::endl; } - -// ----------------------------------------------------------------------------- - -std::vector> Biperiodization::getReadConfs() - const { - oops::Log::trace() << classname() << "::getReadConfs starting" << std::endl; - - std::vector> pairs; - const auto & paramsRead = params_.read.value(); - if (paramsRead != boost::none) { - pairs.push_back(std::pair("inputTestFile", - paramsRead->inputTestFile.value())); - } - - oops::Log::trace() << classname() << "::getReadConfs done" << std::endl; - return pairs; -} - -// ----------------------------------------------------------------------------- - -void Biperiodization::setReadFields(const std::vector & fsetVec) { - oops::Log::trace() << classname() << "::setReadFields starting" << std::endl; - - if (fsetVec.size() == 1) { - // Copy input test file - inputTestFset_.reset(new oops::FieldSet3D(fsetVec[0])); - } else if (fsetVec.size() > 1) { - // Unexpected - throw eckit::Exception("wrong number of fields to read", Here()); - } - - oops::Log::trace() << classname() << "::setReadFields done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -std::vector> Biperiodization::fieldsToWrite() - const { - oops::Log::trace() << classname() << "::fieldsToWrite starting" << std::endl; - - std::vector> pairs; - const auto & paramsRead = params_.read.value(); - if (paramsRead != boost::none) { - pairs.push_back(std::pair( - paramsRead->outputInnerTestFile.value(), *outputInnerTestFset_)); - pairs.push_back(std::pair( - paramsRead->outputOuterTestFile.value(), *outputOuterTestFset_)); - } - - oops::Log::trace() << classname() << "::fieldsToWrite done" << std::endl; - return pairs; -} - // ----------------------------------------------------------------------------- void Biperiodization::read() { oops::Log::trace() << classname() << "::read starting" << std::endl; - // Check that the input test file has been read - ASSERT(inputTestFset_); + // Read input test file + inputTestFset_->read(outerGeometryData_.functionSpace(), + innerVars_, + params_.read.value()->inputTestFile.value()); // LeftInverseMultiply on input test file outputInnerTestFset_.reset(new oops::FieldSet3D(*inputTestFset_)); @@ -157,6 +124,23 @@ void Biperiodization::read() { // ----------------------------------------------------------------------------- +void Biperiodization::write() const { + oops::Log::trace() << classname() << "::write starting" << std::endl; + + const auto & paramsRead = params_.read.value(); + if (paramsRead != boost::none) { + // Write output inner test file + outputInnerTestFset_->write(paramsRead->outputInnerTestFile.value()); + + // Write output outer file + outputOuterTestFset_->write(paramsRead->outputOuterTestFile.value()); + } + + oops::Log::trace() << classname() << "::write done" << std::endl; +} + +// ----------------------------------------------------------------------------- + void Biperiodization::print(std::ostream & os) const { os << classname(); } diff --git a/src/saber/bifourier/Biperiodization.h b/src/saber/bifourier/Biperiodization.h index 7e569d01a..1ea612ef9 100644 --- a/src/saber/bifourier/Biperiodization.h +++ b/src/saber/bifourier/Biperiodization.h @@ -73,8 +73,7 @@ class Biperiodization : public SaberOuterBlockBase { const oops::FieldSet3D &); virtual ~Biperiodization() = default; - const oops::GeometryData & innerGeometryData() const override - {return *innerGeometryData_;} + const oops::GeometryData & innerGeometryData() const override; const oops::Variables & innerVars() const override {return innerVars_;} @@ -84,11 +83,7 @@ class Biperiodization : public SaberOuterBlockBase { void read() override; - std::vector> getReadConfs() const override; - void setReadFields(const std::vector &) override; - - std::vector> fieldsToWrite() const - override; + void write() const override; private: // Inner grid @@ -103,6 +98,9 @@ class Biperiodization : public SaberOuterBlockBase { // Inner geometry data std::unique_ptr innerGeometryData_; + // Outer geometry data + const oops::GeometryData & outerGeometryData_; + // Communicator const eckit::mpi::Comm & comm_; diff --git a/src/saber/bifourier/BiperiodizationImpl.cc b/src/saber/bifourier/BiperiodizationImpl.cc index c4c1a9979..ae8fb20db 100644 --- a/src/saber/bifourier/BiperiodizationImpl.cc +++ b/src/saber/bifourier/BiperiodizationImpl.cc @@ -68,10 +68,16 @@ BiperiodizationImpl::BiperiodizationImpl(const oops::GeometryData & outerGeometr const size_t physicalNy = outerNy - outerExtNy; if (innerExtNx == outerExtNx && innerExtNy == outerExtNy) { + // Same grid + sameGrid_ = true; + // Copy grid innerGrid_ = outerGrid; oops::Log::info() << "Info : Inner grid = outer grid" << std::endl; } else { + // Different grid + sameGrid_ = false; + // Define inner grid const size_t innerNx = physicalNx + innerExtNx; const size_t innerNy = physicalNy + innerExtNy; diff --git a/src/saber/bifourier/BiperiodizationImpl.h b/src/saber/bifourier/BiperiodizationImpl.h index 181969882..09582bebf 100644 --- a/src/saber/bifourier/BiperiodizationImpl.h +++ b/src/saber/bifourier/BiperiodizationImpl.h @@ -74,9 +74,13 @@ class BiperiodizationImpl { void multiplyAD(atlas::FieldSet &) const; void leftInverseMultiply(atlas::FieldSet &) const; + const bool sameGrid() const + {return sameGrid_;} + private: // Inner grid atlas::StructuredGrid innerGrid_; + bool sameGrid_; // Inner partition std::vector innerPartition_; diff --git a/src/saber/blocks/SaberOuterBlockBase.h b/src/saber/blocks/SaberOuterBlockBase.h index 63e361013..c7e38fe3f 100644 --- a/src/saber/blocks/SaberOuterBlockBase.h +++ b/src/saber/blocks/SaberOuterBlockBase.h @@ -53,7 +53,7 @@ class SaberOuterBlockBase : public util::Printable, // Accessor - // To inner Geometry data + // To inner geometry data virtual const oops::GeometryData & innerGeometryData() const = 0; // To inner variables @@ -151,11 +151,13 @@ class SaberOuterBlockBase : public util::Printable, // Read model fields template void read(const oops::Geometry &, + const bool &, const oops::Variables &); // Write model fields template void write(const oops::Geometry &, + const bool &, const oops::Variables &) const; // Adjoint test @@ -266,9 +268,13 @@ class SaberOuterBlockMaker : public SaberOuterBlockFactory { template void SaberOuterBlockBase::read(const oops::Geometry & geom, + const bool & validModelGeom, const oops::Variables & vars) { oops::Log::trace() << "SaberOuterBlockBase::read starting" << std::endl; + // Cannot read files without a valid MODEL geometry + ASSERT(validModelGeom || (this->getReadConfs().size() == 0)); + // Read fieldsets as increments std::vector fsetVec; for (const auto & input : this->getReadConfs()) { @@ -299,9 +305,13 @@ void SaberOuterBlockBase::read(const oops::Geometry & geom, template void SaberOuterBlockBase::write(const oops::Geometry & geom, + const bool & validModelGeom, const oops::Variables & vars) const { oops::Log::trace() << "SaberOuterBlockBase::write starting" << std::endl; + // Cannot write files without a valid MODEL geometry + ASSERT(validModelGeom || (this->fieldsToWrite().size() == 0)); + // Get vector of configuration/FieldSet pairs std::vector> outputs = this->fieldsToWrite(); diff --git a/src/saber/blocks/SaberOuterBlockChain.h b/src/saber/blocks/SaberOuterBlockChain.h index cfb73d335..67baf8e75 100644 --- a/src/saber/blocks/SaberOuterBlockChain.h +++ b/src/saber/blocks/SaberOuterBlockChain.h @@ -136,6 +136,7 @@ class SaberOuterBlockChain { void calibrateBlock(const eckit::LocalConfiguration & covarConf, const oops::FieldSet4D & fset4dXb, const oops::Geometry & geom, + const bool & validModelGeom, const oops::Variables & outerVars, oops::FieldSets & fsetEns); @@ -208,6 +209,9 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, // Copy vector of parameters std::vector innerParams = params; + // Flag to check if the MODEL geometry is still valid + bool validModelGeom = true; + // Loop in reverse order for (int jb = params.size()-1; jb >= 0; --jb) { // Initialize current outer geometry data @@ -227,10 +231,13 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, fset4dFg); oops::Log::trace() << "SaberOuterBlockChain after initBlock" << std::endl; - oops::Log::trace() << "SaberOuterBlockChain before read " << std::endl; + // Update MODEL geometry validity, by checking whether the inner geometry data returned by + // the last outer block shares the same reference as its own outer geometry data + validModelGeom = validModelGeom && + (&(outerBlocks_.back()->innerGeometryData()) == ¤tOuterGeometryData); + // Read and add model fields - outerBlocks_.back()->read(geom, currentOuterVars); - oops::Log::trace() << "SaberOuterBlockChain after read " << std::endl; + outerBlocks_.back()->read(geom, validModelGeom, currentOuterVars); // Remove element from inner parameters innerParams.pop_back(); @@ -240,6 +247,7 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, calibrateBlock(covarConf, fset4dXb, geom, + validModelGeom, currentOuterVars, fsetEns); } else if (saberOuterBlockParams.doRead()) { @@ -251,7 +259,7 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, if (saberOuterBlockParams.forceWrite.value()) { // Write data oops::Log::info() << "Info : Write data" << std::endl; - outerBlocks_.back()->write(geom, outerVars); + outerBlocks_.back()->write(geom, validModelGeom, outerVars); outerBlocks_.back()->write(); } @@ -312,6 +320,7 @@ void SaberOuterBlockChain::calibrateBlock( const eckit::LocalConfiguration & covarConf, const oops::FieldSet4D & fset4dXb, const oops::Geometry & geom, + const bool & validModelGeom, const oops::Variables & outerVars, oops::FieldSets & fsetEns) { oops::Log::trace() << "calibrateBlock starting" << std::endl; @@ -330,6 +339,9 @@ void SaberOuterBlockChain::calibrateBlock( // Get ensemble size const size_t nens = ensembleConf.getInt("ensemble size"); + // Cannot read ensemble members without a valid MODEL geometry + ASSERT(validModelGeom || (nens == 0)); + for (size_t ie = 0; ie < nens; ++ie) { // Read ensemble member oops::FieldSet3D fset(fset4dXb[0].validTime(), geom.getComm()); @@ -357,7 +369,7 @@ void SaberOuterBlockChain::calibrateBlock( // Write calibration data oops::Log::info() << "Info : Write calibration data" << std::endl; - outerBlocks_.back()->write(geom, outerVars); + outerBlocks_.back()->write(geom, validModelGeom, outerVars); outerBlocks_.back()->write(); oops::Log::trace() << "calibrateBlock done" << std::endl; diff --git a/test/testref/dirac_biperiodization_1.ref b/test/testref/dirac_biperiodization_1.ref index 878fec01d..98b92dce1 100644 --- a/test/testref/dirac_biperiodization_1.ref +++ b/test/testref/dirac_biperiodization_1.ref @@ -10,9 +10,6 @@ Input Dirac increment: - xspace: LocalConfiguration[root={type => linear , start => 5.2120971254055749e+05 , end => 6.9620971254055749e+05 , N => 71 , endpoint => true}] - yspace: LocalConfiguration[root={type => linear , start => -2.1173080099392682e+04 , end => 1.0882691990060732e+05 , N => 53 , endpoint => true}] Outer grid size: 3763 -Norm of input parameter inputTestFile: 8.1488556410001294e+01 -Norm of output parameter outputInnerTestFile: 7.1928660692813907e+01 -Norm of output parameter outputOuterTestFile: 8.0177487529753819e+01 Adjoint test for block Biperiodization passed Inner inverse test for block Biperiodization passed: U Uinv (U x) == (U x) Outer inverse test for block Biperiodization passed: Uinv U (Uinv x) == (Uinv x) diff --git a/test/testref/dirac_biperiodization_2.ref b/test/testref/dirac_biperiodization_2.ref index b501002ff..3e665db18 100644 --- a/test/testref/dirac_biperiodization_2.ref +++ b/test/testref/dirac_biperiodization_2.ref @@ -13,9 +13,6 @@ Outer grid size: 3763 - xspace: LocalConfiguration[root={type => linear , start => 5.2120971254055749e+05 , end => 7.1370971254055749e+05 , N => 78 , endpoint => true}] - yspace: LocalConfiguration[root={type => linear , start => -2.1173080099392682e+04 , end => 1.2132691990060732e+05 , N => 58 , endpoint => true}] Info : Inner grid size: 4524 -Norm of input parameter inputTestFile: 8.1488556410001294e+01 -Norm of output parameter outputInnerTestFile: 7.1928660692813907e+01 -Norm of output parameter outputOuterTestFile: 8.0177487529753819e+01 Adjoint test for block Biperiodization passed Inner inverse test for block Biperiodization passed: U Uinv (U x) == (U x) Outer inverse test for block Biperiodization passed: Uinv U (Uinv x) == (Uinv x) From 89bc1d5086b4e3389c93637ad86e3b1aa155f549 Mon Sep 17 00:00:00 2001 From: David Davies Date: Mon, 3 Nov 2025 16:27:13 +0000 Subject: [PATCH 125/199] Remove --fast from NVHPC options (#1135) --- cmake/compiler_flags_NVHPC_CXX.cmake | 4 ++-- cmake/compiler_flags_NVHPC_Fortran.cmake | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/cmake/compiler_flags_NVHPC_CXX.cmake b/cmake/compiler_flags_NVHPC_CXX.cmake index f5d5efc59..d626a6abf 100644 --- a/cmake/compiler_flags_NVHPC_CXX.cmake +++ b/cmake/compiler_flags_NVHPC_CXX.cmake @@ -13,7 +13,7 @@ set( CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Mpreprocess" ) # RELEASE FLAGS #################################################################### -set( CMAKE_CXX_FLAGS_RELEASE "-O3 --fast" ) +set( CMAKE_CXX_FLAGS_RELEASE "-O3" ) #################################################################### # DEBUG FLAGS @@ -25,7 +25,7 @@ set( CMAKE_CXX_FLAGS_DEBUG "-O0 -g -Mbounds -Mchkstk -traceback" ) # BIT REPRODUCIBLE FLAGS #################################################################### -set( CMAKE_CXX_FLAGS_BIT "-O2 --fast" ) +set( CMAKE_CXX_FLAGS_BIT "-O2" ) #################################################################### # LINK FLAGS diff --git a/cmake/compiler_flags_NVHPC_Fortran.cmake b/cmake/compiler_flags_NVHPC_Fortran.cmake index 182e5f967..53464d91a 100644 --- a/cmake/compiler_flags_NVHPC_Fortran.cmake +++ b/cmake/compiler_flags_NVHPC_Fortran.cmake @@ -22,7 +22,7 @@ endif() # RELEASE FLAGS #################################################################### -set( CMAKE_Fortran_FLAGS_RELEASE "-O3 --fast" ) +set( CMAKE_Fortran_FLAGS_RELEASE "-O3" ) #################################################################### # DEBUG FLAGS @@ -34,7 +34,7 @@ set( CMAKE_Fortran_FLAGS_DEBUG "-O0 -g -Mbounds -Mchkstk -traceback" ) # BIT REPRODUCIBLE FLAGS #################################################################### -set( CMAKE_Fortran_FLAGS_BIT "-O2 --fast" ) +set( CMAKE_Fortran_FLAGS_BIT "-O2" ) #################################################################### # LINK FLAGS From ee7f360b7a1cd214112e604849f255d5dfd8b22a Mon Sep 17 00:00:00 2001 From: David Davies Date: Tue, 4 Nov 2025 21:36:47 +0000 Subject: [PATCH 126/199] Hack for NAG linker issue (#1137) --- cmake/compiler_flags_NAG_Fortran.cmake | 2 ++ cmake/saber_compiler_flags.cmake | 3 +++ test/CMakeLists.txt | 2 +- 3 files changed, 6 insertions(+), 1 deletion(-) create mode 100644 cmake/compiler_flags_NAG_Fortran.cmake diff --git a/cmake/compiler_flags_NAG_Fortran.cmake b/cmake/compiler_flags_NAG_Fortran.cmake new file mode 100644 index 000000000..bb3e70226 --- /dev/null +++ b/cmake/compiler_flags_NAG_Fortran.cmake @@ -0,0 +1,2 @@ +set( FORTRAN_LINKER_LANGUAGE "CXX") + diff --git a/cmake/saber_compiler_flags.cmake b/cmake/saber_compiler_flags.cmake index 5bbdabea4..b5b731829 100644 --- a/cmake/saber_compiler_flags.cmake +++ b/cmake/saber_compiler_flags.cmake @@ -12,6 +12,7 @@ set(CMAKE_C_EXTENSIONS OFF) set(CMAKE_FORTRAN_STANDARD 08) set(CMAKE_FORTRAN_STANDARD_REQUIRED ON) set(CMAKE_FORTRAN_EXTENSIONS OFF) +set(FORTRAN_LINKER_LANGUAGE "Fortran") if( NOT CMAKE_BUILD_TYPE MATCHES "Debug" ) add_definitions( -DNDEBUG ) @@ -31,6 +32,8 @@ elseif( CMAKE_Fortran_COMPILER_ID MATCHES "Cray" ) include( compiler_flags_Cray_Fortran ) elseif( CMAKE_Fortran_COMPILER_ID MATCHES "NVHPC" ) include( compiler_flags_NVHPC_Fortran ) +elseif( CMAKE_Fortran_COMPILER_ID MATCHES "NAG" ) + include( compiler_flags_NAG_Fortran ) else() message( STATUS "Fortran compiler with ID ${CMAKE_CXX_COMPILER_ID} will be used with CMake default options") endif() diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 8c2cf6bbf..0a7cfa06f 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -406,7 +406,7 @@ if( SABER_TEST_BUMP ) add_fctest( TARGET saber_test_nicas_sqrt MPI ${mpi} OMP ${omp} - LINKER_LANGUAGE Fortran + LINKER_LANGUAGE ${FORTRAN_LINKER_LANGUAGE} SOURCES fctest/fctest_nicas_sqrt.F90 LIBS saber ) endif() From 853a66cb96134a9d2cfc4fb10c024aab6c06ccf7 Mon Sep 17 00:00:00 2001 From: Francois Hebert Date: Wed, 5 Nov 2025 10:01:42 -0800 Subject: [PATCH 127/199] Fix memory leaks (#1140) * Fix leaks in Fortran interfaces * Fix leaks of FFTW objects in FastLAM * Fix leaks from incorrect use of raw pointers * Fix leaks in Fortran-interface test * Cosmetic cleaning * Implement code review suggestions --------- Co-authored-by: Benjamin Menetrier Co-authored-by: Nate Crossette --- .../bifourier/bifourier_arome_legacy_interface.F90 | 9 +++++++++ src/saber/bump/type_geom.fypp | 1 - src/saber/bump/type_wind.fypp | 1 + src/saber/fastlam/LayerSpec.cc | 10 ++++++++++ src/saber/interpolation/Rescaling.cc | 5 +++-- src/saber/oops/ErrorCovariance.h | 6 ++++-- src/saber/spectralb/spectralb_covstats_interface.F90 | 6 ++++++ src/saber/util/HorizontalProfiles.cc | 3 ++- test/fctest/fctest_nicas_sqrt.F90 | 3 +++ 9 files changed, 38 insertions(+), 6 deletions(-) diff --git a/src/saber/bifourier/bifourier_arome_legacy_interface.F90 b/src/saber/bifourier/bifourier_arome_legacy_interface.F90 index 1918d04ff..7c6022c02 100644 --- a/src/saber/bifourier/bifourier_arome_legacy_interface.F90 +++ b/src/saber/bifourier/bifourier_arome_legacy_interface.F90 @@ -37,6 +37,9 @@ subroutine bifourier_arome_legacy_vortopb_c(c_conf,nial,fact1) & ! Call Fortran call bifourier_arome_legacy_vortopb(f_conf,nial,fact1) +! Release memory +call f_conf%final() + end subroutine bifourier_arome_legacy_vortopb_c !---------------------------------------------------------------------- @@ -65,6 +68,9 @@ subroutine bifourier_arome_legacy_balance_c(c_conf,nwglb,nflev,sdivpb,stpspb,stp ! Call Fortran call bifourier_arome_legacy_balance(f_conf,nwglb,nflev,sdivpb,stpspb,stpsdivu,sqpb,sqdivu,sqtpsu) +! Release memory +call f_conf%final() + end subroutine bifourier_arome_legacy_balance_c !---------------------------------------------------------------------- @@ -92,6 +98,9 @@ subroutine bifourier_arome_legacy_covariance_c(c_conf,nwglb,nflev,vorcov,divucov ! Call Fortran call bifourier_arome_legacy_covariance(f_conf,nwglb,nflev,vorcov,divucov,tpsucov,qucov) +! Release memory +call f_conf%final() + end subroutine bifourier_arome_legacy_covariance_c !---------------------------------------------------------------------- diff --git a/src/saber/bump/type_geom.fypp b/src/saber/bump/type_geom.fypp index d6c8375f3..38dca6a38 100644 --- a/src/saber/bump/type_geom.fypp +++ b/src/saber/bump/type_geom.fypp @@ -290,7 +290,6 @@ class(geom_type),intent(inout) :: geom !< Geometry ! Release memory call geom%partial_dealloc -call geom%afunctionspace_mg%final() if (allocated(geom%gmask_mga)) deallocate(geom%gmask_mga) if (allocated(geom%c0a_to_mga)) deallocate(geom%c0a_to_mga) if (allocated(geom%lon_c0a)) deallocate(geom%lon_c0a) diff --git a/src/saber/bump/type_wind.fypp b/src/saber/bump/type_wind.fypp index a91f7d378..19020123f 100644 --- a/src/saber/bump/type_wind.fypp +++ b/src/saber/bump/type_wind.fypp @@ -1174,6 +1174,7 @@ if (nam%new_wind) then call wind%com_c0_AM%setup(mpl,'com_c0_AM',geom%nc0a,wind%nc0m,geom%nc0,geom%c0a_to_c0,wind%c0m_to_c0) ! Release memory + call tree%dealloc() call mesh_c0u%dealloc deallocate(lcheck_c0b) deallocate(c0u_to_c0b) diff --git a/src/saber/fastlam/LayerSpec.cc b/src/saber/fastlam/LayerSpec.cc index 3c38de836..4873af615 100644 --- a/src/saber/fastlam/LayerSpec.cc +++ b/src/saber/fastlam/LayerSpec.cc @@ -276,6 +276,11 @@ void LayerSpec::setupParallelization() { xSpecStdDev_.push_back(xBufC1d[jk][0]); } + // Delete FFTW-related data + fftw_destroy_plan(xPlan_r2c1d); + fftw_free(xBufR1d); + fftw_free(xBufC1d); + // Columns FFTW setup int yRank = 1; int yN[] = {static_cast(nyExt_)}; @@ -314,6 +319,11 @@ void LayerSpec::setupParallelization() { ySpecStdDev_.push_back(yBufC1d[jl][0]); } + // Delete FFTW-related data + fftw_destroy_plan(yPlan_r2c1d); + fftw_free(yBufR1d); + fftw_free(yBufC1d); + if (!params_.skipTests.value()) { // Tests diff --git a/src/saber/interpolation/Rescaling.cc b/src/saber/interpolation/Rescaling.cc index e301de463..e4ed409a9 100644 --- a/src/saber/interpolation/Rescaling.cc +++ b/src/saber/interpolation/Rescaling.cc @@ -8,6 +8,7 @@ #include #include +#include #include #include #include @@ -82,7 +83,7 @@ auto readCovarianceProfiles(const std::string & filePath, ASSERT(netcdfDimVarIDs[pos].size() == 1); const int nLevs = dimSizes[netcdfDimVarIDs[pos][0]]; ASSERT(nLevs == var.getLevels()); - auto levArray = atlas::array::Array::create(nLevs); + std::unique_ptr levArray(atlas::array::Array::create(nLevs)); auto levView = atlas::array::make_view(*levArray); util::atlasArrayReadData(netcdfGeneralIDs, netcdfVarIDs[pos], @@ -97,7 +98,7 @@ auto readCovarianceProfiles(const std::string & filePath, pos = vars.find(distVarName); ASSERT(netcdfDimVarIDs[pos].size() == 1); const int nDist = dimSizes[netcdfDimVarIDs[pos][0]]; - auto distArray = atlas::array::Array::create(nDist); + std::unique_ptr distArray(atlas::array::Array::create(nDist)); auto distView = atlas::array::make_view(*distArray); util::atlasArrayReadData(netcdfGeneralIDs, netcdfVarIDs[pos], diff --git a/src/saber/oops/ErrorCovariance.h b/src/saber/oops/ErrorCovariance.h index 71053eae8..5a83e4fe0 100644 --- a/src/saber/oops/ErrorCovariance.h +++ b/src/saber/oops/ErrorCovariance.h @@ -172,13 +172,15 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, covarConf.set("ensemble configuration", ensembleConf); // Read dual resolution ensemble if needed const auto & dualResParams = params.dualResParams.value(); - const Geometry_ * dualResGeom = &geom; + std::unique_ptr dualResGeometry{}; // the owning pointer + const Geometry_ * dualResGeom = &geom; // the algorithm-facing handle std::unique_ptr fsetDualResEns; if (dualResParams != boost::none) { const auto & dualResGeomConf = dualResParams->geometry.value(); if (dualResGeomConf != boost::none) { // Create dualRes geometry - dualResGeom = new Geometry_(*dualResGeomConf, geom.getComm()); + dualResGeometry = std::make_unique(*dualResGeomConf, geom.getComm()); + dualResGeom = dualResGeometry.get(); } // Background and first guess at dual resolution geometry const State4D_ xbDualRes(*dualResGeom, xb); diff --git a/src/saber/spectralb/spectralb_covstats_interface.F90 b/src/saber/spectralb/spectralb_covstats_interface.F90 index b651c2660..884fe95e2 100644 --- a/src/saber/spectralb/spectralb_covstats_interface.F90 +++ b/src/saber/spectralb/spectralb_covstats_interface.F90 @@ -88,6 +88,8 @@ subroutine c_covSpectralBinsLevels(c_conf, & bins = final_index(1) - start_index(1) levels = final_index(2) - start_index(2) + 1 +call f_conf%final() + end subroutine c_covSpectralBinsLevels @@ -139,6 +141,8 @@ subroutine c_covSpectralBins(c_conf, & bins = final_index(1) - start_index(1) +call f_conf%final() + end subroutine c_covSpectralBins !------------------------------------------------------------------------------ @@ -207,4 +211,6 @@ subroutine c_covSpectralUMatrix(c_conf, & end do end do +call f_conf%final() + end subroutine c_covSpectralUMatrix diff --git a/src/saber/util/HorizontalProfiles.cc b/src/saber/util/HorizontalProfiles.cc index 460c697cf..6c01a0891 100644 --- a/src/saber/util/HorizontalProfiles.cc +++ b/src/saber/util/HorizontalProfiles.cc @@ -8,6 +8,7 @@ #include #include +#include #include "atlas/array.h" #include "atlas/util/Earth.h" @@ -402,7 +403,7 @@ void write_1d_covariances(const eckit::mpi::Comm & comm, profilesToFieldIndex.cend(), iField); const size_t iFirstProfile = iProfileIter - profilesToFieldIndex.cbegin(); - auto distArray = atlas::array::Array::create(ndist); + std::unique_ptr distArray(atlas::array::Array::create(ndist)); auto distView = atlas::array::make_view(*distArray); for (size_t jnode = 0; jnode < ndist; jnode++) { distView(jnode) = distances[iFirstProfile][jnode]; diff --git a/test/fctest/fctest_nicas_sqrt.F90 b/test/fctest/fctest_nicas_sqrt.F90 index 99b83eaa2..e33a108ef 100644 --- a/test/fctest/fctest_nicas_sqrt.F90 +++ b/test/fctest/fctest_nicas_sqrt.F90 @@ -150,6 +150,9 @@ call fset%final() call fset_out_1%final() call fset_out_2%final() + call conf%final() + call rh(1)%final() + call rv(1)%final() ! Release memory call bump%dealloc() From 777bf0d087601fda882197a50ada31ab50045019 Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Wed, 5 Nov 2025 21:38:34 +0100 Subject: [PATCH 128/199] No send/receive for arrays of zero size (#1128) Co-authored-by: Nate Crossette --- src/saber/bump/type_mpl.fypp | 90 +++++++++++++++++++----------------- 1 file changed, 47 insertions(+), 43 deletions(-) diff --git a/src/saber/bump/type_mpl.fypp b/src/saber/bump/type_mpl.fypp index a4bd3dafa..2b34ec4b1 100644 --- a/src/saber/bump/type_mpl.fypp +++ b/src/saber/bump/type_mpl.fypp @@ -818,62 +818,66 @@ if (mpl%main) then do iproc=1,mpl%nproc ! Allocation n_loc_tmp = count(glb_to_proc==iproc) - allocate(rbuf(n_loc_tmp*nl)) - - if (iproc==mpl%rootproc) then - ! Copy data - #:if rank == 1 - rbuf = loc - #:else - do il=1,nl - do i_loc=1,n_loc - rbuf((il-1)*n_loc+i_loc) = loc(i_loc,il) - end do - end do - #:endif - else - ! Receive data from iproc - call mpl%f_comm%receive(rbuf,iproc-1,mpl%tag,status) - end if + if (n_loc_tmp>0) then + allocate(rbuf(n_loc_tmp*nl)) - ! Add data to glb - do i_glb=1,n_glb - jproc = glb_to_proc(i_glb) - if (iproc==jproc) then - i_loc = glb_to_loc(i_glb) + if (iproc==mpl%rootproc) then + ! Copy data #:if rank == 1 - glb(i_glb) = rbuf(i_loc) + rbuf = loc #:else do il=1,nl - glb(i_glb,il) = rbuf((il-1)*n_loc_tmp+i_loc) + do i_loc=1,n_loc + rbuf((il-1)*n_loc+i_loc) = loc(i_loc,il) + end do end do #:endif + else + ! Receive data from iproc + call mpl%f_comm%receive(rbuf,iproc-1,mpl%tag,status) end if - end do - ! Release memory - deallocate(rbuf) + ! Add data to glb + do i_glb=1,n_glb + jproc = glb_to_proc(i_glb) + if (iproc==jproc) then + i_loc = glb_to_loc(i_glb) + #:if rank == 1 + glb(i_glb) = rbuf(i_loc) + #:else + do il=1,nl + glb(i_glb,il) = rbuf((il-1)*n_loc_tmp+i_loc) + end do + #:endif + end if + end do + + ! Release memory + deallocate(rbuf) + end if end do else - ! Allocation - allocate(sbuf(n_loc*nl)) - - ! Copy data - #:if rank == 1 - sbuf = loc - #:else - do il=1,nl - do i_loc=1,n_loc - sbuf((il-1)*n_loc+i_loc) = loc(i_loc,il) + if (n_loc>0) then + ! Allocation + allocate(sbuf(n_loc*nl)) + + ! Copy data + #:if rank == 1 + sbuf = loc + #:else + do il=1,nl + do i_loc=1,n_loc + sbuf((il-1)*n_loc+i_loc) = loc(i_loc,il) + end do end do - end do - #:endif + #:endif - ! Send data to rootproc - call mpl%f_comm%send(sbuf,mpl%rootproc-1,mpl%tag) + ! Send data to rootproc + call mpl%f_comm%send(sbuf,mpl%rootproc-1,mpl%tag) - ! Release memory - deallocate(sbuf) + ! Release memory + deallocate(sbuf) + end if end if call mpl%update_tag(1) From 76e4fa2da87bbf6073826fd87e4e9537a7f99fb3 Mon Sep 17 00:00:00 2001 From: Francois Hebert Date: Wed, 5 Nov 2025 13:20:27 -0800 Subject: [PATCH 129/199] Loosen tols of dirac_ens ctests (#1139) Co-authored-by: Nate Crossette --- test/testinput/dirac_ens_both_geom.yaml | 2 +- test/testinput/dirac_ens_other_geom_1.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/testinput/dirac_ens_both_geom.yaml b/test/testinput/dirac_ens_both_geom.yaml index 3b37245e5..8cb72eb57 100644 --- a/test/testinput/dirac_ens_both_geom.yaml +++ b/test/testinput/dirac_ens_both_geom.yaml @@ -96,5 +96,5 @@ output dirac: filepath: testdata/dirac_ens_both_geom/dirac_%id%_%MPI% test: - float relative tolerance: 3e-3 # Due to process_perts_from_csdual_states_2 outputs differing on 1/2 MPI tasks + float relative tolerance: 4e-3 # Due to process_perts_from_csdual_states_2 outputs differing on 1/2 MPI tasks reference filename: testref/dirac_ens_both_geom.ref diff --git a/test/testinput/dirac_ens_other_geom_1.yaml b/test/testinput/dirac_ens_other_geom_1.yaml index 064e96956..5a83703e6 100644 --- a/test/testinput/dirac_ens_other_geom_1.yaml +++ b/test/testinput/dirac_ens_other_geom_1.yaml @@ -96,5 +96,5 @@ output dirac: filepath: testdata/dirac_ens_other_geom_1/dirac_%id%_%MPI% test: - float relative tolerance: 3e-3 # Due to process_perts_from_csdual_states_2 outputs differing on 1/2 MPI tasks + float relative tolerance: 4e-3 # Due to process_perts_from_csdual_states_2 outputs differing on 1/2 MPI tasks reference filename: testref/dirac_ens_other_geom_1.ref From 1b5d1dfa50b20d9d71bc71cdcd9c4f827b20619b Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Thu, 6 Nov 2025 17:36:12 +0100 Subject: [PATCH 130/199] Simplification of 2D variables in BUMP (#1049) * Remove lev2d from quench, fix it in BUMP * Typo * Default level for 2d variables + fix yaml and ref * Trigger tests * Using Fields metadata (#1068) * Geographical mask bugfix * add jedi-ci action (#1090) Add jedi-ci action Parent issue: JCSDA-internal/jedi-ci#16 Admin merge justification: JCSDA-internal/jedi-ci#17 * Trigger tests * Trigger tests * trigger CI --------- Co-authored-by: Nate Crossette Co-authored-by: Evan Parker --- quench/src/Fields.cc | 30 +++++-- quench/src/Geometry.cc | 26 ++---- quench/src/Geometry.h | 1 - src/saber/bump/BUMP.cc | 81 +++++++++++-------- src/saber/bump/BUMPParameters.h | 2 - src/saber/bump/tools_atlas.fypp | 74 +++++------------ src/saber/bump/type_bump.fypp | 48 +++++------ src/saber/bump/type_bump_parameters.cc | 2 - src/saber/bump/type_bump_parameters.h | 4 - src/saber/bump/type_cmat.fypp | 2 +- src/saber/bump/type_diag_blk.fypp | 6 +- src/saber/bump/type_ens.fypp | 16 ++-- src/saber/bump/type_fieldset.fypp | 73 ++++++++--------- src/saber/bump/type_geom.fypp | 51 +++++------- src/saber/bump/type_gsi.fypp | 8 -- src/saber/bump/type_hdiag.fypp | 12 +-- src/saber/bump/type_nam.fypp | 40 ++++++--- src/saber/bump/type_nicas.fypp | 6 +- src/saber/bump/type_nicas_cmp.fypp | 2 +- src/saber/bump/type_var.fypp | 2 +- src/saber/bump/type_vbal.fypp | 6 +- test/fctest/fctest_nicas_sqrt.F90 | 21 ++--- ...ovariance_training_bump_hdiag-nicas_2.yaml | 4 - ...ror_covariance_training_bump_nicas_11.yaml | 2 - test/testref/dirac_bump_7.ref | 8 +- test/testref/dirac_bump_8.ref | 12 +-- ...covariance_training_bump_hdiag-nicas_2.ref | 78 +++++++++--------- ...error_covariance_training_bump_hdiag_1.ref | 6 +- ...error_covariance_training_bump_hdiag_2.ref | 6 +- ...error_covariance_training_bump_hdiag_4.ref | 22 ++--- 30 files changed, 306 insertions(+), 345 deletions(-) diff --git a/quench/src/Fields.cc b/quench/src/Fields.cc index b66c19c07..bcdaa0dcb 100644 --- a/quench/src/Fields.cc +++ b/quench/src/Fields.cc @@ -61,9 +61,12 @@ Fields::Fields(const Geometry & geom, fset_.add(field); } - // Set interpolation type + // Set fields metadata for (auto field : fset_) { field.metadata().set("interp_type", "default"); + if (field.levels() == 1) { + field.metadata().set("nearest 3d level", "bottom"); + } } // Set fields to zero @@ -104,12 +107,15 @@ Fields::Fields(const Fields & other, fset_.add(field); } - // Set interpolation type + // Set fields metadata for (auto field : fset_) { field.metadata() = other.fset_[field.name()].metadata(); if (!field.metadata().has("interp_type")) { field.metadata().set("interp_type", "default"); } + if (!field.metadata().has("nearest 3d level") && (field.levels() == 1)) { + field.metadata().set("nearest 3d level", "bottom"); + } } // Copy fieldset @@ -139,12 +145,15 @@ Fields::Fields(const Fields & other, fset_.add(field); } - // Set interpolation type + // Set fields metadata for (auto field : fset_) { field.metadata() = other.fset_[field.name()].metadata(); if (!field.metadata().has("interp_type")) { field.metadata().set("interp_type", "default"); } + if (!field.metadata().has("nearest 3d level") && (field.levels() == 1)) { + field.metadata().set("nearest 3d level", "bottom"); + } } // Set fields to zero @@ -197,12 +206,15 @@ Fields::Fields(const Fields & other) fset_.add(field); } - // Set interpolation type + // Set fields metadata for (auto field : fset_) { field.metadata() = other.fset_[field.name()].metadata(); if (!field.metadata().has("interp_type")) { field.metadata().set("interp_type", "default"); } + if (!field.metadata().has("nearest 3d level") && (field.levels() == 1)) { + field.metadata().set("nearest 3d level", "bottom"); + } } oops::Log::trace() << classname() << "::Fields done" << std::endl; @@ -881,11 +893,16 @@ void Fields::toFieldSet(atlas::FieldSet & fset) const { // Share internal fieldset fset.clear(); fset = util::shareFields(fset_); + + // Set fields metadata for (auto field : fset) { field.metadata() = fset_[field.name()].metadata(); if (!field.metadata().has("interp_type")) { field.metadata().set("interp_type", "default"); } + if (!field.metadata().has("nearest 3d level") && (field.levels() == 1)) { + field.metadata().set("nearest 3d level", "bottom"); + } field.set_dirty(fset_[field.name()].dirty()); } @@ -969,9 +986,12 @@ void Fields::read(const eckit::Configuration & config) { } } - // Set interpolation type + // Set fields metadata for (auto field : fset_) { field.metadata().set("interp_type", "default"); + if (field.levels() == 1) { + field.metadata().set("nearest 3d level", "bottom"); + } } oops::Log::trace() << classname() << "::read done" << std::endl; diff --git a/quench/src/Geometry.cc b/quench/src/Geometry.cc index d6b633384..72e28932b 100644 --- a/quench/src/Geometry.cc +++ b/quench/src/Geometry.cc @@ -96,7 +96,7 @@ Geometry::Geometry(const eckit::Configuration & config, fields_ = atlas::FieldSet(); // Add owned points mask -- this mask does not depend on the group so was precomputed - fields_->add(fieldsetOwnedMask["owned"]); + fields_.add(fieldsetOwnedMask["owned"]); // Levels direction levelsAreTopDown_ = params.levelsAreTopDown.value(); @@ -160,9 +160,6 @@ Geometry::Geometry(const eckit::Configuration & config, // Number of levels group.levels_ = groupParams.levels.value(); - // Corresponding level for 2D variables (first or last) - group.lev2d_ = groupParams.lev2d.value(); - // Save group groups_.push_back(group); @@ -496,7 +493,7 @@ void Geometry::setupVertCoord(groupData & group) { } // Add vertical coordinate in Geometry fields - fields_->add(group.vertCoord_); + fields_.add(group.vertCoord_); oops::Log::trace() << classname() << "::setupVertCoord starting" << std::endl; } @@ -622,18 +619,9 @@ void Geometry::setupMask(groupData & group) { // Ocean points for all levels for (size_t jlevel = 0; jlevel < group.levels_; ++jlevel) { if (lsm[nn] == 0) { - maskView(jnode, jlevel) = 1; - } else { - maskView(jnode, jlevel) = 0; - } - } - - // Ocean + small islands for: - // - the first level of 3D fields, - // - the 2D fields if lev2d = "first" - if (lsm[nn] == 3) { - if ((group.levels_ > 1) || (group.lev2d_ == "first")) { - maskView(jnode, 0) = 1; + maskView(jnode, jlevel) = 1; + } else { + maskView(jnode, jlevel) = 0; } } } @@ -645,7 +633,6 @@ void Geometry::setupMask(groupData & group) { } else { throw eckit::UserError("Wrong mask type", Here()); } - fields_->add(gmask); // Mask size group.gmaskSize_ = 0.0; @@ -666,6 +653,9 @@ void Geometry::setupMask(groupData & group) { group.gmaskSize_ = group.gmaskSize_/static_cast(domainSize); } + // Add mask in Geometry fields + fields_.add(gmask); + oops::Log::trace() << classname() << "::setupMask done" << std::endl; } diff --git a/quench/src/Geometry.h b/quench/src/Geometry.h index adea14573..46afbf496 100644 --- a/quench/src/Geometry.h +++ b/quench/src/Geometry.h @@ -135,7 +135,6 @@ class Geometry : public util::Printable, GroupParameters params_; size_t index_; size_t levels_; - std::string lev2d_; atlas::Field vertCoord_; std::vector vertCoordAvg_; double gmaskSize_; diff --git a/src/saber/bump/BUMP.cc b/src/saber/bump/BUMP.cc index 567511e05..93f9db447 100644 --- a/src/saber/bump/BUMP.cc +++ b/src/saber/bump/BUMP.cc @@ -133,53 +133,63 @@ BUMP::BUMP(const oops::GeometryData & geometryData, grid.set("model.variables", vars_str); } - // Get the number of levels and the 2D variables + // Get the number of levels and potential 2D variables int nl0 = 0; std::vector var2d; for (const auto & var : vars_str) { - bool varFound = false; - for (size_t jvar = 0; jvar < vars_.size(); ++jvar) { - if (var == vars_[jvar].name()) { - varFound = true; - int nl0_tmp = static_cast(vars_[var].getLevels()); - if (nl0 > 1) { - // Check that nl0_tmp is either 1 or nl0 - if ((nl0_tmp != 1) && (nl0_tmp != nl0)) { - oops::Log::info() << "BUMP::BUMP: inconsistent number of levels in BUMP" << std::endl; - std::abort(); - } - } - nl0 = std::max(nl0, nl0_tmp); - - // 2D variable flag - if (nl0_tmp == 1) { - var2d.push_back(var); - } + ASSERT(vars_.has(var)); + int nl0_tmp = static_cast(vars_[var].getLevels()); + if (nl0 > 1) { + // Check that nl0_tmp is either 1 or nl0 + if ((nl0_tmp != 1) && (nl0_tmp != nl0)) { + oops::Log::info() << "BUMP::BUMP: inconsistent number of levels in BUMP" << std::endl; + std::abort(); } } - if (!varFound) { - oops::Log::info() << "BUMP: inconsistent variable names" << std::endl; - std::abort(); + nl0 = std::max(nl0, nl0_tmp); + + if (nl0_tmp == 1) { + // Potential 2D variable + var2d.push_back(var); } } grid.set("model.nl0", nl0); + + // 2D variables are meaningful if 3D variables are present only + if (nl0 == 1) { + var2d.clear(); + } grid.set("model.2d variables", var2d); - // Add level index for 2D fields - if (!grid.has("model.level for 2d variables")) { - ModelDef def; - grid.set("model.level for 2d variables", def.lev2d.second); + // Add nearest 3D level for 2D fields + std::string nearest3dLevel; + for (const auto & var : var2d) { + if (xb[var].metadata().has("nearest 3d level")) { + const std::string value = xb[var].metadata().getString("nearest 3d level"); + if (nearest3dLevel.empty()) { + nearest3dLevel = value; + } else { + ASSERT(value == nearest3dLevel); + } + } } + grid.set("model.nearest 3d level", nearest3dLevel); + + // Add levels direction + grid.set("model.levels direction", geometryData.levelsAreTopDown()); // Add vertical coordinate name std::string vertCoordName; for (const auto & var : vars_str) { if (var2d.size() == vars_str.size() || vars_[var].getLevels() > 1) { const std::string key = var + ".vert_coord"; - if (vertCoordName.empty()) { - vertCoordName = fieldsMetaData.getString(key, ""); - } else { - ASSERT(fieldsMetaData.getString(key, "vert_coord") == vertCoordName); + if (fieldsMetaData.has(key)) { + const std::string value = fieldsMetaData.getString(key); + if (vertCoordName.empty()) { + vertCoordName = value; + } else { + ASSERT(value == vertCoordName); + } } } } @@ -193,10 +203,13 @@ BUMP::BUMP(const oops::GeometryData & geometryData, for (const auto & var : vars_str) { if (var2d.size() == vars_str.size() || vars_[var].getLevels() > 1) { const std::string key = var + ".gmask"; - if (gmaskName.empty()) { - gmaskName = fieldsMetaData.getString(key, ""); - } else { - ASSERT(fieldsMetaData.getString(key, "gmask") == gmaskName); + if (fieldsMetaData.has(key)) { + const std::string value = fieldsMetaData.getString(key); + if (gmaskName.empty()) { + gmaskName = value; + } else { + ASSERT(value == gmaskName); + } } } } diff --git a/src/saber/bump/BUMPParameters.h b/src/saber/bump/BUMPParameters.h index a5daeeb9c..66526fede 100644 --- a/src/saber/bump/BUMPParameters.h +++ b/src/saber/bump/BUMPParameters.h @@ -359,8 +359,6 @@ class ModelSection : public oops::Parameters { ModelDef def; public: - // Level for 2D variables ('first' or 'last') - oops::Parameter lev2d = param(def.lev2d, this); // Variables names oops::Parameter> variables{"variables", {}, this}; // 2D variables names diff --git a/src/saber/bump/tools_atlas.fypp b/src/saber/bump/tools_atlas.fypp index 5415212be..3cbcab373 100644 --- a/src/saber/bump/tools_atlas.fypp +++ b/src/saber/bump/tools_atlas.fypp @@ -157,20 +157,19 @@ end subroutine atlas_get_regional_grid ! Subroutine: atlas_field_to_array_${dtype}$ !> Convert ATLAS field to field !---------------------------------------------------------------------- -subroutine atlas_field_to_array_${dtype}$(afield,mpl,array,lev2d) +subroutine atlas_field_to_array_${dtype}$(afield,mpl,array,ilev2d) implicit none ! Passed variables -type(atlas_field),intent(in) :: afield !< ATLAS field -type(mpl_type),intent(inout) :: mpl !< MPI data -${ftype[dtype]}$,intent(out) :: array(:,:) !< Array -character(len=*),intent(in),optional :: lev2d !< Level for 2D variables +type(atlas_field),intent(in) :: afield !< ATLAS field +type(mpl_type),intent(inout) :: mpl !< MPI data +${ftype[dtype]}$,intent(out) :: array(:,:) !< Array +integer,intent(in) :: ilev2d !< Level for 2D variables ! Local variables -integer :: nmga,nnodes,nl0,nl2d,il0 +integer :: nmga,nnodes,nl0,il0 ${ftype[dtype]}$,pointer :: ptr(:,:) -character(len=1024) :: llev2d ! Set name @:set_name(atlas_field_to_array_${dtype}$) @@ -178,11 +177,6 @@ character(len=1024) :: llev2d ! Probe in @:probe_in() -! Local lev2d -llev2d = 'first' -if (present(lev2d)) llev2d = lev2d -if (.not.((trim(llev2d)=='first').or.(trim(llev2d)=='last'))) call mpl%abort('${subr}$','wrong lev2d') - ! Check kind if (afield%kind()/=${atlas_kind[dtype]}$) call mpl%abort('${subr}$','wrong kind for field '//afield%name()) @@ -200,17 +194,9 @@ if (nmga/=nnodes) call mpl%abort('${subr}$','wrong number of nodes for field '// array = ${zero[dtype]}$ ! Copy data -! For the 2D case (afield%levels()==1), the field is copied: -! - at the first level of array if (lev2d=='first') -! - at the last level of array if (lev2d=='last') call afield%data(ptr) if (afield%levels()==1) then - if (trim(llev2d)=='first') then - nl2d = 1 - else if (trim(llev2d)=='last') then - nl2d = nl0 - end if - if (nmga>0) array(:,nl2d) = ptr(1,1:nmga) + if (nmga>0) array(:,ilev2d) = ptr(1,1:nmga) else if (nl0>afield%levels()) call mpl%abort('${subr}$','not enough levels in ATLAS field') if (nmga>0) then @@ -230,19 +216,18 @@ end subroutine atlas_field_to_array_${dtype}$ ! Subroutine: atlas_field_to_array_logical !> Convert ATLAS field to field !---------------------------------------------------------------------- -subroutine atlas_field_to_array_logical(afield,mpl,array,lev2d) +subroutine atlas_field_to_array_logical(afield,mpl,array,ilev2d) implicit none ! Passed variables -type(atlas_field),intent(in) :: afield !< ATLAS field -type(mpl_type),intent(inout) :: mpl !< MPI data -logical,intent(out) :: array(:,:) !< Array -character(len=*),intent(in),optional :: lev2d !< Level for 2D variables +type(atlas_field),intent(in) :: afield !< ATLAS field +type(mpl_type),intent(inout) :: mpl !< MPI data +logical,intent(out) :: array(:,:) !< Array +integer,intent(in) :: ilev2d !< Level for 2D variables ! Local variables integer,allocatable :: array_int(:,:) -character(len=1024) :: llev2d ! Set name @:set_name(atlas_field_to_array_logical) @@ -250,16 +235,11 @@ character(len=1024) :: llev2d ! Probe in @:probe_in() -! Local lev2d -llev2d = 'first' -if (present(lev2d)) llev2d = lev2d -if (.not.((trim(llev2d)=='first').or.(trim(llev2d)=='last'))) call mpl%abort('${subr}$','wrong lev2d') - ! Allocation allocate(array_int(size(array,1),size(array,2))) ! Get integer array -call field_to_array(afield,mpl,array_int,lev2d) +call field_to_array(afield,mpl,array_int,ilev2d) ! Convert integer to logical call convert_i2l(mpl,array_int,array) @@ -277,20 +257,19 @@ end subroutine atlas_field_to_array_logical ! Subroutine: atlas_field_from_array_${dtype}$ !> Convert field to ATLAS field !---------------------------------------------------------------------- -subroutine atlas_field_from_array_${dtype}$(afield,mpl,array,lev2d) +subroutine atlas_field_from_array_${dtype}$(afield,mpl,array,ilev2d) implicit none ! Passed variables -type(atlas_field),intent(inout) :: afield !< ATLAS field -type(mpl_type),intent(inout) :: mpl !< MPI data -${ftype[dtype]}$,intent(in) :: array(:,:) !< Array -character(len=*),intent(in),optional :: lev2d !< Level for 2D variables +type(atlas_field),intent(inout) :: afield !< ATLAS field +type(mpl_type),intent(inout) :: mpl !< MPI data +${ftype[dtype]}$,intent(in) :: array(:,:) !< Array +integer,intent(in) :: ilev2d !< Level for 2D variables ! Local variables -integer :: nmga,nnodes,nl0,nl2d,il0 +integer :: nmga,nnodes,nl0,il0 ${ftype[dtype]}$,pointer :: ptr(:,:) -character(len=1024) :: llev2d ! Set name @:set_name(atlas_field_from_array_${dtype}$) @@ -298,11 +277,6 @@ character(len=1024) :: llev2d ! Probe in @:probe_in() -! Local lev2d -llev2d = 'first' -if (present(lev2d)) llev2d = lev2d -if (.not.((trim(llev2d)=='first').or.(trim(llev2d)=='last'))) call mpl%abort('${subr}$','wrong lev2d') - ! Check kind if (afield%kind()/=${atlas_kind[dtype]}$) call mpl%abort('${subr}$','wrong kind for field '//afield%name()) @@ -317,18 +291,10 @@ nl0 = size(array,2) if (nmga/=nnodes) call mpl%abort('${subr}$','wrong number of nodes for field '//afield%name()) ! Copy data -! For the 2D case (afield%levels()==1), the field is copied: -! - at the first level of array if (lev2d=='first') -! - at the last level of array if (lev2d=='last') call afield%data(ptr) ptr(:,:) = ${zero[dtype]}$ if (afield%levels()==1) then - if (trim(llev2d)=='first') then - nl2d = 1 - else if (trim(llev2d)=='last') then - nl2d = nl0 - end if - if (nmga>0) ptr(1,1:nmga) = array(:,nl2d) + if (nmga>0) ptr(1,1:nmga) = array(:,ilev2d) else if (nl0>afield%levels()) call mpl%abort('${subr}$','not enough levels in ATLAS field') if (nmga>0) then diff --git a/src/saber/bump/type_bump.fypp b/src/saber/bump/type_bump.fypp index 9321adbaa..da244d973 100644 --- a/src/saber/bump/type_bump.fypp +++ b/src/saber/bump/type_bump.fypp @@ -148,9 +148,9 @@ subroutine bump_setup(bump,afunctionspace,fieldset) implicit none ! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(atlas_functionspace),intent(in) :: afunctionspace !< Functionspace -type(fieldset_type),intent(in),optional :: fieldset !< SABER geometry fields +class(bump_type),intent(inout) :: bump !< BUMP +type(atlas_functionspace),intent(in) :: afunctionspace !< Functionspace +type(fieldset_type),intent(in) :: fieldset !< SABER geometry fields ! Local variables integer :: color,sc @@ -169,7 +169,7 @@ character(len=1024) :: cname @:print_bump_instance() if (bump%nam%load_universe_radius) then - ! Read universe radius + ! Read universe radius call bump%nam%read_universe_radius(bump%mpl) ! Print result @@ -261,11 +261,7 @@ write(bump%mpl%info,'(a)') '---------------------------------------------------- call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Initialize geometry' call bump%mpl%flush -if (present(fieldset)) then - call bump%geom(1)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace,fieldset) -else - call bump%geom(1)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace) -end if +call bump%geom(1)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace,fieldset) if (bump%nam%ens1_ne>0) then ! Initialize ensemble 1 @@ -377,7 +373,7 @@ if (.not.bump%ens(igeom)%loaded) call bump%ens(igeom)%alloc(ne,nsub) bump%ens(igeom)%loaded = .true. ! Pass fields -call bump%ens(igeom)%mem(ie)%init(bump%mpl,fieldset,bump%geom(igeom)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d, & +call bump%ens(igeom)%mem(ie)%init(bump%mpl,fieldset,bump%geom(igeom)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d, & & bump%nam%var2d,pass=.true.) ! Print norm @@ -426,7 +422,7 @@ if (ie==1) then end if ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -465,7 +461,7 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -524,7 +520,7 @@ if (ie==1) then end if ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(igeom)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(igeom)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(igeom)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -1119,7 +1115,7 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -1160,7 +1156,7 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -1201,7 +1197,7 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -1242,7 +1238,7 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -1283,7 +1279,7 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -1324,7 +1320,7 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -1422,7 +1418,7 @@ do iv=1,bump%nam%nv end do ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fortran array on subset Sc0 to fieldset call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) @@ -1460,7 +1456,7 @@ type(cv_type) :: cv @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -1508,7 +1504,7 @@ call bump%nicas(1)%random_cv(bump%mpl,bump%rng,bump%nam,bump%geom(1),cv) call bump%nicas(1)%apply_sqrt(bump%mpl,bump%nam,bump%geom(1),cv,fld_c0a) ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fortran array on subset Sc0 to fieldset call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) @@ -1561,7 +1557,7 @@ else end if ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -1632,7 +1628,7 @@ else end if ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) @@ -1970,7 +1966,7 @@ end do ! Create fieldset call fieldset%init(bump%mpl,bump%geom(igeom)%afunctionspace_mg,bump%geom(igeom)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & - & bump%nam%lev2d,bump%nam%var2d) + & bump%nam%ilev2d,bump%nam%var2d) ! Fortran array to fieldset call fieldset%from_array(bump%mpl,fld_mga) @@ -2062,7 +2058,7 @@ write(bump%mpl%info,'(a7,a,a)') '','Set ',trim(param) call bump%mpl%flush ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%lev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran array call fieldset%to_array(bump%mpl,fld_mga) diff --git a/src/saber/bump/type_bump_parameters.cc b/src/saber/bump/type_bump_parameters.cc index 470412bd2..58ab605e2 100644 --- a/src/saber/bump/type_bump_parameters.cc +++ b/src/saber/bump/type_bump_parameters.cc @@ -180,8 +180,6 @@ void bump_config_init_f90(eckit::LocalConfiguration * config) { // Model section ModelDef modelDef; eckit::LocalConfiguration modelConf; - // Level for 2D variables ('first' or 'last') - param(modelDef.lev2d, modelConf); // Check that sampling couples and interpolations do not cross mask boundaries param(modelDef.mask_check, modelConf); diff --git a/src/saber/bump/type_bump_parameters.h b/src/saber/bump/type_bump_parameters.h index 53ef07924..a821b59c9 100644 --- a/src/saber/bump/type_bump_parameters.h +++ b/src/saber/bump/type_bump_parameters.h @@ -303,10 +303,6 @@ struct DriversDef { // Model section struct ModelDef { - // Level for 2D variables ('first' or 'last') - std::pair lev2d = - std::make_pair("level for 2d variables", "first"); - // Check that sampling couples and interpolations do not cross mask boundaries std::pair mask_check = std::make_pair("do not cross mask boundaries", false); diff --git a/src/saber/bump/type_cmat.fypp b/src/saber/bump/type_cmat.fypp index 1938526d6..150e3d0f0 100644 --- a/src/saber/bump/type_cmat.fypp +++ b/src/saber/bump/type_cmat.fypp @@ -438,7 +438,7 @@ if (trim(nam%strategy)=='crossed') then igmin = 1 rhmin = huge_real do ig=1,nam%ng - if ((.not.geom%grp2d(ig)).or.(geom%nl2d==il0)) then + if ((.not.geom%grp2d(ig)).or.(nam%ilev2d==il0)) then do icmp=1,cmat%blk(ig)%ncmp if (mpl%msv%isnot(cmat%blk(ig)%rh(ic0a,il0,icmp)).and.(igmin(icmp)>0)) then if (cmat%blk(ig)%rh(ic0a,il0,icmp)zero)==1).and.(trim(nam%lev2d)=='first').and.(m2(1)>zero)) then - ilev2d = 1 -elseif ((count(m2>zero)==1).and.(trim(nam%lev2d)=='last').and.(m2(geom%nl0)>zero)) then - ilev2d = geom%nl0 +if ((count(m2>zero)==1).and.(m2(nam%ilev2d)>zero)) then + ilev2d = nam%ilev2d else ilev2d = mpl%msv%vali end if diff --git a/src/saber/bump/type_ens.fypp b/src/saber/bump/type_ens.fypp index ec4f59c17..e774f0d49 100644 --- a/src/saber/bump/type_ens.fypp +++ b/src/saber/bump/type_ens.fypp @@ -223,19 +223,19 @@ integer :: ie,isub if (allocated(ens_in%mem)) then do ie=1,ens_in%ne if (.not.ens_in%mem(ie)%is_null()) call ens_out%mem(ie)%init(mpl,ens_in%mem(ie),geom%gmask_mga, & - & nam%variables(1:nam%nv),nam%lev2d,copy=.true.) + & nam%variables(1:nam%nv),nam%ilev2d,copy=.true.) end do end if if (allocated(ens_in%mean)) then do isub=1,ens_in%nsub if (.not.ens_in%mean(isub)%is_null()) call ens_out%mean(isub)%init(mpl,ens_in%mean(isub),geom%gmask_mga, & - & nam%variables(1:nam%nv),nam%lev2d,copy=.true.) + & nam%variables(1:nam%nv),nam%ilev2d,copy=.true.) end do end if if (.not.ens_in%m2%is_null()) call ens_out%m2%init(mpl,ens_in%m2,geom%gmask_mga, & - & nam%variables(1:nam%nv),nam%lev2d,copy=.true.) + & nam%variables(1:nam%nv),nam%ilev2d,copy=.true.) if (.not.ens_in%m4%is_null()) call ens_out%m4%init(mpl,ens_in%m4,geom%gmask_mga, & - & nam%variables(1:nam%nv),nam%lev2d,copy=.true.) + & nam%variables(1:nam%nv),nam%ilev2d,copy=.true.) ! Probe out @:probe_out() @@ -267,7 +267,7 @@ integer :: isub,ie_sub,ie do isub=1,ens%nsub ! Initialization - call ens%mean(isub)%init(mpl,ens%mem(1),geom%gmask_mga,nam%variables(1:nam%nv),nam%lev2d) + call ens%mean(isub)%init(mpl,ens%mem(1),geom%gmask_mga,nam%variables(1:nam%nv),nam%ilev2d) ! Set fields at zero call ens%mean(isub)%zero_fields(mpl) @@ -310,8 +310,8 @@ type(fieldset_type) :: pert @:probe_in() ! Initialization -call ens%m2%init(mpl,ens%mem(1),geom%gmask_mga,nam%variables(1:nam%nv),nam%lev2d) -call ens%m4%init(mpl,ens%mem(1),geom%gmask_mga,nam%variables(1:nam%nv),nam%lev2d) +call ens%m2%init(mpl,ens%mem(1),geom%gmask_mga,nam%variables(1:nam%nv),nam%ilev2d) +call ens%m4%init(mpl,ens%mem(1),geom%gmask_mga,nam%variables(1:nam%nv),nam%ilev2d) ! Set fields at zero call ens%m2%zero_fields(mpl) @@ -321,7 +321,7 @@ do isub=1,ens%nsub do ie_sub=1,ens%ne/ens%nsub ! Compute perturbation ie = ie_sub+(isub-1)*ens%ne/ens%nsub - call pert%init(mpl,ens%mem(ie),geom%gmask_mga,nam%variables(1:nam%nv),nam%lev2d,copy=.true.) + call pert%init(mpl,ens%mem(ie),geom%gmask_mga,nam%variables(1:nam%nv),nam%ilev2d,copy=.true.) call pert%sub_fields(mpl,ens%mean(isub)) ! Square diff --git a/src/saber/bump/type_fieldset.fypp b/src/saber/bump/type_fieldset.fypp index d93571f5a..f2209f7ab 100644 --- a/src/saber/bump/type_fieldset.fypp +++ b/src/saber/bump/type_fieldset.fypp @@ -20,12 +20,12 @@ use type_mpl, only: mpl_type implicit none type,extends(atlas_fieldset) :: fieldset_type - integer :: nmga ! Model grid on model grid, halo A - integer :: nl0 ! Number of levels - integer :: nv ! Number of variables - logical,allocatable :: mask3d(:,:) ! 3D mask - character(len=1024),allocatable :: variables(:) ! Variables names - character(len=1024) :: lev2d ! Level for 2D variables + integer :: nmga !< Model grid on model grid, halo A + integer :: nl0 !< Number of levels + integer :: nv !< Number of variables + logical,allocatable :: mask3d(:,:) !< 3D mask + character(len=1024),allocatable :: variables(:) !< Variables names + integer :: ilev2d !< Level for 2D variables logical,allocatable :: var2d(:) !< 2D variable flag contains procedure :: fieldset_init_from_functionspace @@ -61,7 +61,7 @@ contains ! Subroutine: fieldset_init_from_functionspace !> Initialize fieldset from function space !---------------------------------------------------------------------- -subroutine fieldset_init_from_functionspace(fieldset,mpl,afunctionspace,gmask,variables,lev2d,var2d) +subroutine fieldset_init_from_functionspace(fieldset,mpl,afunctionspace,gmask,variables,ilev2d,var2d) implicit none @@ -71,7 +71,7 @@ type(mpl_type),intent(inout) :: mpl !< MPI data type(atlas_functionspace),intent(in) :: afunctionspace !< Function space logical,intent(in) :: gmask(:,:) !< Geographical mask character(len=*),intent(in) :: variables(:) !< Variables names -character(len=*),intent(in) :: lev2d !< Level for 2D variables +integer,intent(in) :: ilev2d !< Level for 2D variables logical,intent(in) :: var2d(:) !< 2D variable flag ! Local variables @@ -101,12 +101,12 @@ if (.not.allocated(fieldset%mask3d)) allocate(fieldset%mask3d(fieldset%nmga,fiel if (.not.allocated(fieldset%variables)) allocate(fieldset%variables(fieldset%nv)) if (.not.allocated(fieldset%var2d)) allocate(fieldset%var2d(fieldset%nv)) -! Copy mask, variables, lev2d and var2d +! Copy mask, variables, ilev2d and var2d fieldset%mask3d = gmask do iv=1,fieldset%nv fieldset%variables(iv) = variables(iv) end do -fieldset%lev2d = lev2d +fieldset%ilev2d = ilev2d fieldset%var2d = var2d ! Create fields if necessary @@ -140,7 +140,7 @@ end subroutine fieldset_init_from_functionspace ! Subroutine: fieldset_init_from_fieldset !> Initialize fieldset from another fieldset !---------------------------------------------------------------------- -subroutine fieldset_init_from_fieldset(fieldset_out,mpl,fieldset_in,gmask,variables,lev2d,var2d,copy,pass) +subroutine fieldset_init_from_fieldset(fieldset_out,mpl,fieldset_in,gmask,variables,ilev2d,var2d,copy,pass) implicit none @@ -150,7 +150,7 @@ type(mpl_type),intent(inout) :: mpl !< MPI data type(fieldset_type),intent(in) :: fieldset_in !< Input fieldset logical,intent(in),optional :: gmask(:,:) !< Geographical mask character(len=*),intent(in),optional :: variables(:) !< Variables names -character(len=*),intent(in),optional :: lev2d !< Level for 2D variables +integer,intent(in),optional :: ilev2d !< Level for 2D variables logical,intent(in),optional :: var2d(:) !< 2D variable flag logical,intent(in),optional :: copy !< Copy fields data logical,intent(in),optional :: pass !< Pass fields pointers @@ -177,7 +177,7 @@ if (present(pass)) lpass = pass ! Initialization if (fieldset_out%is_null()) fieldset_out = atlas_fieldset() -if (present(gmask).and.present(variables).and.present(lev2d).and.present(var2d)) then +if (present(gmask).and.present(variables).and.present(ilev2d).and.present(var2d)) then ! Get number of nodes fieldset_out%nmga = size(gmask,1) @@ -197,7 +197,7 @@ if (present(gmask).and.present(variables).and.present(lev2d).and.present(var2d)) do iv=1,fieldset_out%nv fieldset_out%variables(iv) = variables(iv) end do - fieldset_out%lev2d = lev2d + fieldset_out%ilev2d = ilev2d fieldset_out%var2d = var2d elseif (allocated(fieldset_in%mask3d).and.allocated(fieldset_in%variables).and.allocated(fieldset_in%var2d)) then ! Get number of nodes @@ -214,11 +214,11 @@ elseif (allocated(fieldset_in%mask3d).and.allocated(fieldset_in%variables).and.a if (.not.allocated(fieldset_out%variables)) allocate(fieldset_out%variables(fieldset_out%nv)) if (.not.allocated(fieldset_out%var2d)) allocate(fieldset_out%var2d(fieldset_out%nv)) - ! Copy mask, variables and lev2d + ! Copy mask, variables and ilev2d fieldset_out%mask3d = fieldset_in%mask3d fieldset_out%variables = fieldset_in%variables fieldset_out%var2d = fieldset_in%var2d - fieldset_out%lev2d = fieldset_in%lev2d + fieldset_out%ilev2d = fieldset_in%ilev2d else call mpl%abort('${subr}$','inconsistent optional arguments') end if @@ -281,7 +281,7 @@ end subroutine fieldset_init_from_fieldset ! Subroutine: fieldset_set_metadata !> Set metadata !---------------------------------------------------------------------- -subroutine fieldset_set_metadata(fieldset,mpl,gmask,variables,lev2d,var2d) +subroutine fieldset_set_metadata(fieldset,mpl,gmask,variables,ilev2d,var2d) implicit none @@ -290,7 +290,7 @@ class(fieldset_type),intent(inout) :: fieldset !< Fieldset type(mpl_type),intent(inout) :: mpl !< MPI data logical,intent(in) :: gmask(:,:) !< Geographical mask character(len=*),intent(in) :: variables(:) !< Variables names -character(len=*),intent(in) :: lev2d !< Level for 2D variables +integer,intent(in) :: ilev2d !< Level for 2D variables logical,intent(in) :: var2d(:) !< 2D variable flag ! Local variables @@ -321,7 +321,7 @@ fieldset%mask3d = gmask do iv=1,fieldset%nv fieldset%variables(iv) = variables(iv) end do -fieldset%lev2d = lev2d +fieldset%ilev2d = ilev2d fieldset%var2d = var2d ! Check fieldset @@ -366,7 +366,7 @@ do iv=1,fieldset%nv afield = fieldset%field(fieldset%variables(iv)) ! Array - call field_to_array(afield,mpl,array) + call field_to_array(afield,mpl,array,fieldset%ilev2d) ! Compute global norm norm = zero @@ -804,9 +804,6 @@ type(atlas_field) :: afield if (.not.allocated(fieldset%mask3d)) call mpl%abort('${subr}$','mask is not allocated') if (.not.allocated(fieldset%variables)) call mpl%abort('${subr}$','variables is not allocated') -! Check lev2d -if (.not.((trim(fieldset%lev2d)=='first').or.(trim(fieldset%lev2d)=='last'))) call mpl%abort('${subr}$','wrong lev2d') - do iv=1,fieldset%nv ! Check that all variables are present if (.not.fieldset%has_field(fieldset%variables(iv))) call mpl%abort('${subr}$', & @@ -816,6 +813,11 @@ do iv=1,fieldset%nv afield = fieldset%field(fieldset%variables(iv)) if (get_atlas_field_size(mpl,afield)/=fieldset%nmga) call mpl%abort('${subr}$','wrong horizontal size') if ((afield%levels()/=1).and.(afield%levels()/=fieldset%nl0)) call mpl%abort('${subr}$','wrong number of levels') + + ! Check ilev2d + if (afield%levels()/=1) then + if ((fieldset%ilev2d/=1).and.(fieldset%ilev2d/=afield%levels())) call mpl%abort('${subr}$','wrong ilev2d') + end if end do ! Release memory @@ -854,12 +856,12 @@ type(atlas_field) :: afield_in,afield_out call fieldset_in%check(mpl) call fieldset_out%check(mpl) -! Check mask, variables and lev2d consistency +! Check mask, variables and ilev2d consistency if ((size(fieldset_in%mask3d)>0).and.(size(fieldset_in%mask3d)>0)) then if (any(fieldset_in%mask3d.neqv.fieldset_out%mask3d)) call mpl%abort('${subr}$','inconsistent masks') end if if (any(fieldset_in%variables/=fieldset_out%variables)) call mpl%abort('${subr}$','inconsistent variables') -if (fieldset_in%lev2d/=fieldset_out%lev2d) call mpl%abort('${subr}$','inconsistent lev2d') +if (fieldset_in%ilev2d/=fieldset_out%ilev2d) call mpl%abort('${subr}$','inconsistent ilev2d') ! Check shapes consistency do iv=1,fieldset_in%nv @@ -924,17 +926,12 @@ if (size(fieldset%mask3d)>0) then ! Apply missing value to mask points do iv=1,fieldset%nv if (fieldset%var2d(iv)) then - if (fieldset%lev2d=='first') then - do imga=1,fieldset%nmga - if (.not.fieldset%mask3d(imga,1)) fld(imga,1,iv) = lmsvalr - end do - fld(:,2:fieldset%nl0,iv) = lmsvalr - elseif (fieldset%lev2d=='last') then - fld(:,1:fieldset%nl0-1,iv) = lmsvalr - do imga=1,fieldset%nmga - if (.not.fieldset%mask3d(imga,fieldset%nl0)) fld(imga,fieldset%nl0,iv) = lmsvalr - end do - end if + do il0=1,fieldset%nl0 + if (il0/=fieldset%ilev2d) fld(:,il0,iv) = lmsvalr + end do + do imga=1,fieldset%nmga + if (.not.fieldset%mask3d(imga,fieldset%ilev2d)) fld(imga,fieldset%ilev2d,iv) = lmsvalr + end do else do il0=1,fieldset%nl0 do imga=1,fieldset%nmga @@ -989,7 +986,7 @@ if (size(fieldset%variables) gsi_dealloc procedure :: setup => gsi_setup @@ -408,13 +407,6 @@ call mpl%f_comm%broadcast(gsi%a,mpl%rootproc-1) call mpl%f_comm%broadcast(gsi%rh,mpl%rootproc-1) call mpl%f_comm%broadcast(gsi%rv,mpl%rootproc-1) -! Level for 2D variables -if (nam%lev2d=='first') then - gsi%ilev2d = 1 -else if (nam%lev2d=='last') then - gsi%ilev2d = geom%nl0 -end if - ! Update status gsi%initialized = .true. diff --git a/src/saber/bump/type_hdiag.fypp b/src/saber/bump/type_hdiag.fypp index febf4e763..e868dcb2d 100644 --- a/src/saber/bump/type_hdiag.fypp +++ b/src/saber/bump/type_hdiag.fypp @@ -403,8 +403,8 @@ do ig=1,nam%ng hdiag%cor(1)%blk(0,ig)%rv_c0a(:,:,icmp) = mpl%msv%valr do ic0a=1,geom%nc0a call gsi%interp_lat(mpl,geom%lat_c0a(ic0a),ilatm,ilatp,rlatm,rlatp) - hdiag%cor(1)%blk(0,ig)%rh_c0a(ic0a,gsi%ilev2d,icmp) = rlatm*gsi%rh(ilatm,1,icmp,iv)+rlatp*gsi%rh(ilatp,1,icmp,iv) - hdiag%cor(1)%blk(0,ig)%rv_c0a(ic0a,gsi%ilev2d,icmp) = zero + hdiag%cor(1)%blk(0,ig)%rh_c0a(ic0a,nam%ilev2d,icmp) = rlatm*gsi%rh(ilatm,1,icmp,iv)+rlatp*gsi%rh(ilatp,1,icmp,iv) + hdiag%cor(1)%blk(0,ig)%rv_c0a(ic0a,nam%ilev2d,icmp) = zero end do else ! 3D variable @@ -428,8 +428,8 @@ do ig=1,nam%ng ! Amplitude and scaling if (gsi%var2d(iv)) then hdiag%cor(1)%blk(0,ig)%a_c0a(:,:,icmp) = mpl%msv%valr - hdiag%cor(1)%blk(0,ig)%a_c0a(:,gsi%ilev2d,icmp) = gsi%a(icmp) - hdiag%cor(1)%blk(0,ig)%rh_c0a(:,gsi%ilev2d,icmp) = hdiag%cor(1)%blk(0,ig)%rh_c0a(:,gsi%ilev2d,icmp)/req + hdiag%cor(1)%blk(0,ig)%a_c0a(:,nam%ilev2d,icmp) = gsi%a(icmp) + hdiag%cor(1)%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp) = hdiag%cor(1)%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp)/req else hdiag%cor(1)%blk(0,ig)%a_c0a(:,:,icmp) = gsi%a(icmp) hdiag%cor(1)%blk(0,ig)%rh_c0a(:,:,icmp) = hdiag%cor(1)%blk(0,ig)%rh_c0a(:,:,icmp)/req @@ -478,8 +478,8 @@ if (nam%check_dirac.and.allocated(hdiag%gsi_ref)) then do icmp=1,cor_tmp%blk(0,ig)%ncmp ! Copy and multiply length-scales if (gsi%var2d(iv)) then - cor_tmp%blk(0,ig)%rh_c0a(:,gsi%ilev2d,icmp) = hdiag%cor(1)%blk(0,ig)%rh_c0a(:,gsi%ilev2d,icmp)*fac(ifac) - cor_tmp%blk(0,ig)%rv_c0a(:,gsi%ilev2d,icmp) = hdiag%cor(1)%blk(0,ig)%rv_c0a(:,gsi%ilev2d,icmp)*fac(ifac) + cor_tmp%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp) = hdiag%cor(1)%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp)*fac(ifac) + cor_tmp%blk(0,ig)%rv_c0a(:,nam%ilev2d,icmp) = hdiag%cor(1)%blk(0,ig)%rv_c0a(:,nam%ilev2d,icmp)*fac(ifac) else cor_tmp%blk(0,ig)%rh_c0a(:,:,icmp) = hdiag%cor(1)%blk(0,ig)%rh_c0a(:,:,icmp)*fac(ifac) cor_tmp%blk(0,ig)%rv_c0a(:,:,icmp) = hdiag%cor(1)%blk(0,ig)%rv_c0a(:,:,icmp)*fac(ifac) diff --git a/src/saber/bump/type_nam.fypp b/src/saber/bump/type_nam.fypp index 8862e9d91..abb9b67f1 100644 --- a/src/saber/bump/type_nam.fypp +++ b/src/saber/bump/type_nam.fypp @@ -101,10 +101,10 @@ type nam_type ! Model section integer :: nl0 !< Number of levels - character(len=1024) :: lev2d !< Level for 2D variables ('first' or 'last') integer :: nv !< Number of variables character(len=1024),allocatable :: variables(:) !< Variables names logical,allocatable :: var2d(:) !< 2D variable flag + integer :: ilev2d !< Level for 2D variables integer :: ng !< Number of groups of variables character(len=1024),allocatable :: group_names(:) !< Group of variables names integer,allocatable :: group_index(:) !< Variables group index @@ -318,7 +318,8 @@ integer :: iv,jv,iconf,rank,itest,it,ivv,jvv,ig integer,allocatable :: vbal_order(:) real(kind_real) :: real_scalar real(kind_real),allocatable :: loc_wgt(:,:) -logical :: lverbose,color_log,found,valid +logical :: lverbose,color_log,found,valid,topdown +character(len=1024) :: lev2d character(len=:),allocatable :: str,str_bal,str_unbal character(len=:),allocatable :: str_array(:),str_array_row(:),str_array_col(:) type(fckit_configuration) :: section @@ -511,7 +512,6 @@ end if if (conf%get('model',section)) then if (lverbose) call print_section(mpl,section,'Model') call nam%get(section,'nl0',nam%nl0) - call nam%get(section,'level for 2d variables',nam%lev2d) if (section%get('variables',str_array)) then nam%nv = size(str_array) if (nam%nv>0) then @@ -536,7 +536,7 @@ if (conf%get('model',section)) then end do end do end if - + ! Groups allocate(nam%group_index(nam%nv)) if (section%get('groups',confs)) then @@ -576,6 +576,30 @@ if (conf%get('model',section)) then end if end if end if + nam%ilev2d = 1 + if (nam%nv>0) then + if (any(nam%var2d)) then + call nam%get(section,'nearest 3d level', lev2d) + call nam%get(section,'levels direction', topdown) + if (lev2d=='bottom') then + if (topdown) then + nam%ilev2d = nam%nl0 + else + nam%ilev2d = 1 + end if + else if (lev2d=='top') then + if (topdown) then + nam%ilev2d = 1 + else + nam%ilev2d = nam%nl0 + end if + else if (lev2d=='') then + call mpl%abort('${subr}$','level for 2d variables not specified but 2d variables present') + else + call mpl%abort('${subr}$','wrong level for 2d variables: '//trim(lev2d)//', should be bottom or top') + end if + end if + end if call nam%get(section,'do not cross mask boundaries',nam%mask_check) end if @@ -954,11 +978,7 @@ if (conf%get('dirac',confs)) then call confs(iconf)%get_or_die('longitude',nam%londir(nam%ndir)) call confs(iconf)%get_or_die('latitude',nam%latdir(nam%ndir)) if (nam%var2d(iv)) then - if (nam%lev2d=='first') then - nam%levdir(nam%ndir) = 1 - else - nam%levdir(nam%ndir) = nam%nl0 - end if + nam%levdir(nam%ndir) = nam%ilev2d else call confs(iconf)%get_or_die('level',nam%levdir(nam%ndir)) end if @@ -1165,11 +1185,11 @@ end if ! Model section if (nam%nl0<=0) call mpl%abort('${subr}$','nl0 should be positive') -if ((nam%lev2d/='first').and.(nam%lev2d/='last')) call mpl%abort('${subr}$','wrong lev2d value') if (nam%nv<=0) call mpl%abort('${subr}$','no variables') do iv=1,nam%nv if (nam%variables(iv)=='') call mpl%abort('${subr}$','empty variable name') end do +if ((nam%ilev2d/=1).and.(nam%ilev2d/=nam%nl0)) call mpl%abort('${subr}$','wrong ilev2d value') if (nam%ng<=0) call mpl%abort('${subr}$','no group') if (any(nam%group_index<1).or.any(nam%group_index>nam%ng)) call mpl%abort('${subr}$','wrong group index') do ig=1,nam%ng diff --git a/src/saber/bump/type_nicas.fypp b/src/saber/bump/type_nicas.fypp index 2e5c68545..a564429e3 100644 --- a/src/saber/bump/type_nicas.fypp +++ b/src/saber/bump/type_nicas.fypp @@ -331,7 +331,7 @@ if (nam%strategy=='crossed') then ! Control variable section starting and end indices if (geom%grp2d(ig)) then - if (geom%nl2d==1) then + if (nam%ilev2d==1) then ! First level only nicas%blk(ig)%cmp(icmp)%ias = 1 nicas%blk(ig)%cmp(icmp)%iae = nicas%blk(ig)%cmp(icmp)%nsa @@ -927,7 +927,7 @@ if (nam%strategy=='crossed') then ! Control variable section starting and end indices if (geom%grp2d(ig)) then - if (geom%nl2d==1) then + if (nam%ilev2d==1) then ! First level only nicas%blk(ig)%cmp(icmp)%ias = 1 nicas%blk(ig)%cmp(icmp)%iae = nicas%blk(ig)%cmp(icmp)%nsa @@ -1539,7 +1539,7 @@ do ie=1,ne call nicas%apply_sqrt(mpl,nam,geom,cv_ens(ie),fld_c0a) ! Set metadata - call ens%mem(ie)%init(mpl,geom%afunctionspace_mg,geom%gmask_mga,nam%variables(1:nam%nv),nam%lev2d,nam%var2d) + call ens%mem(ie)%init(mpl,geom%afunctionspace_mg,geom%gmask_mga,nam%variables(1:nam%nv),nam%ilev2d,nam%var2d) ! Set member from subset Sc0 call ens%set_c0(mpl,nam,geom,'member',ie,fld_c0a) diff --git a/src/saber/bump/type_nicas_cmp.fypp b/src/saber/bump/type_nicas_cmp.fypp index d47ea3453..be0a79ce6 100644 --- a/src/saber/bump/type_nicas_cmp.fypp +++ b/src/saber/bump/type_nicas_cmp.fypp @@ -2602,7 +2602,7 @@ if (.not.nam%load_nicas_global) then nicas_cmp%vlev = nicas_cmp%vlev.and.(npos>0).and.(nmis==0) if (geom%grp2d(ig)) then do il0=1,nicas_cmp%nl0 - nicas_cmp%vlev(il0) = (nicas_cmp%vlev(il0).and.(geom%nl2d==il0)) + nicas_cmp%vlev(il0) = (nicas_cmp%vlev(il0).and.(nam%ilev2d==il0)) end do end if end if diff --git a/src/saber/bump/type_var.fypp b/src/saber/bump/type_var.fypp index 808fc40f3..78aa671d5 100644 --- a/src/saber/bump/type_var.fypp +++ b/src/saber/bump/type_var.fypp @@ -480,7 +480,7 @@ do iv=1,nam%nv var%m2(:,:,iv) = mpl%msv%valr do ic0a=1,geom%nc0a call gsi%interp_lat(mpl,geom%lat_c0a(ic0a),ilatm,ilatp,rlatm,rlatp) - var%m2(ic0a,gsi%ilev2d,iv) = (rlatm*gsi%stddev(ilatm,1,iv)+rlatp*gsi%stddev(ilatp,1,iv))**2 + var%m2(ic0a,nam%ilev2d,iv) = (rlatm*gsi%stddev(ilatm,1,iv)+rlatp*gsi%stddev(ilatp,1,iv))**2 end do else ! 3D variable diff --git a/src/saber/bump/type_vbal.fypp b/src/saber/bump/type_vbal.fypp index 1b0d439f9..c2dc5bf04 100644 --- a/src/saber/bump/type_vbal.fypp +++ b/src/saber/bump/type_vbal.fypp @@ -2030,12 +2030,12 @@ do iv=1,nam%nv ic2u = samp%c2b_to_c2u(ic2b) call gsi%interp_lat(mpl,samp%lat_c2u(ic2u),ilatm,ilatp,rlatm,rlatp) do il0=1,geom%nl0 - if (il0==gsi%ilev2d) then + if (il0==nam%ilev2d) then ! Copy fist level as is - vbal%blk(iv,jv)%reg_c2b(gsi%ilev2d,il0,ic2b) = rlatm*gsi%pscon(ilatm,1)+rlatp*gsi%pscon(ilatp,1) + vbal%blk(iv,jv)%reg_c2b(nam%ilev2d,il0,ic2b) = rlatm*gsi%pscon(ilatm,1)+rlatp*gsi%pscon(ilatp,1) else ! Other levels - vbal%blk(iv,jv)%reg_c2b(gsi%ilev2d,il0,ic2b) = & + vbal%blk(iv,jv)%reg_c2b(nam%ilev2d,il0,ic2b) = & & rlatm*gsi%rlevm(il0)*gsi%pscon(ilatm,gsi%l0_to_levm(il0)) & & +rlatm*gsi%rlevp(il0)*gsi%pscon(ilatm,gsi%l0_to_levp(il0)) & & +rlatp*gsi%rlevm(il0)*gsi%pscon(ilatp,gsi%l0_to_levm(il0)) & diff --git a/test/fctest/fctest_nicas_sqrt.F90 b/test/fctest/fctest_nicas_sqrt.F90 index e33a108ef..b07e8a2b7 100644 --- a/test/fctest/fctest_nicas_sqrt.F90 +++ b/test/fctest/fctest_nicas_sqrt.F90 @@ -39,16 +39,11 @@ implicit none ! Local variables - integer,parameter :: nl0 = 5 integer :: n,nmga_out - integer,dimension(2),parameter :: var2d_int = (/0,0/) real(kind_real) :: dp_in,dp_out real(kind_real),pointer :: ptr_1(:),ptr_2(:) real(kind_real),allocatable :: array_out_1(:,:,:),array_out_2(:,:,:) logical,allocatable :: gmask_out(:,:) - logical,dimension(2),parameter :: var2d = (/.false.,.false./) - character(len=4),dimension(2),parameter :: variables = (/'var1','var2'/) - character(len=5),parameter :: lev2d = 'first' type(fckit_mpi_comm) :: f_comm type(atlas_field) :: cv_1,cv_2 type(atlas_structuredgrid) :: grid_out @@ -75,10 +70,8 @@ conf = fckit_configuration() call conf%set('drivers.multivariate strategy','crossed') call conf%set('drivers.compute nicas',.true.) - call conf%set('model.variables',variables) - call conf%set('model.nl0',nl0) - call conf%set('model.lev2d',lev2d) - call conf%set('model.var2d',var2d_int) + call conf%set('model.variables',(/'var1','var2'/)) + call conf%set('model.nl0',5) call conf%set('nicas.resolution',4.0_kind_real) call conf%set('nicas.min effective resolution',1.0_kind_real) call conf%set('nicas.explicit length-scales',.true.) @@ -114,14 +107,14 @@ ! Create output fieldset fspace_out_sc = atlas_functionspace_structuredcolumns(fspace_out%c_ptr()) nmga_out = fspace_out_sc%size_owned() - allocate(gmask_out(nmga_out,nl0)) + allocate(gmask_out(nmga_out,bump%geom(1)%nl0)) gmask_out = .true. - call fset_out_1%init(bump%mpl,fspace_out,gmask_out,variables,lev2d,var2d) - call fset_out_2%init(bump%mpl,fspace_out,gmask_out,variables,lev2d,var2d) + call fset_out_1%init(bump%mpl,fspace_out,gmask_out,bump%nam%variables,bump%nam%ilev2d,bump%nam%var2d) + call fset_out_2%init(bump%mpl,fspace_out,gmask_out,bump%nam%variables,bump%nam%ilev2d,bump%nam%var2d) ! Initialize output fieldset - allocate(array_out_1(nmga_out,nl0,2)) - allocate(array_out_2(nmga_out,nl0,2)) + allocate(array_out_1(nmga_out,bump%geom(1)%nl0,bump%nam%nv)) + allocate(array_out_2(nmga_out,bump%geom(1)%nl0,bump%nam%nv)) call bump%rng%rand_gau(array_out_1) array_out_2 = array_out_1 call fset_out_1%from_array(bump%mpl,array_out_1) diff --git a/test/testinput/error_covariance_training_bump_hdiag-nicas_2.yaml b/test/testinput/error_covariance_training_bump_hdiag-nicas_2.yaml index 3b18d6137..1dc6c01cb 100644 --- a/test/testinput/error_covariance_training_bump_hdiag-nicas_2.yaml +++ b/test/testinput/error_covariance_training_bump_hdiag-nicas_2.yaml @@ -12,7 +12,6 @@ geometry: - variables: - air_pressure_at_surface levels: 1 - lev2d: last mask type: sea mask path: ../quench/data/landsea.nc halo: 1 @@ -40,8 +39,6 @@ background error: fields metadata: air_horizontal_streamfunction: gmask: gmask_0 - air_pressure_at_surface: - gmask: gmask_1 calibration: general: testing: true @@ -62,7 +59,6 @@ background error: normalization test: 10 internal dirac test: true model: - level for 2d variables: last do not cross mask boundaries: true sampling: computation grid size: 500 diff --git a/test/testinput/error_covariance_training_bump_nicas_11.yaml b/test/testinput/error_covariance_training_bump_nicas_11.yaml index c79af5714..b7c2e3b3e 100644 --- a/test/testinput/error_covariance_training_bump_nicas_11.yaml +++ b/test/testinput/error_covariance_training_bump_nicas_11.yaml @@ -33,8 +33,6 @@ background error: adjoints test: true internal dirac test: true normalization test: 50 - model: - level for 2d variables: last nicas: resolution: 6.0 explicit length-scales: true diff --git a/test/testref/dirac_bump_7.ref b/test/testref/dirac_bump_7.ref index ecb355334..6439a29e6 100644 --- a/test/testref/dirac_bump_7.ref +++ b/test/testref/dirac_bump_7.ref @@ -69,7 +69,7 @@ Covariance(SABER) * Increment: + mean = -1.6685238984800714e+00 + stddev = 4.3163205906791966e+01 - air_pressure_at_surface (1 levels): - + min = -9.0277267821932714e+00 - + max = 4.5355755608299241e+01 - + mean = 2.6085686104297362e-01 - + stddev = 2.2316575289774669e+00 + + min = -9.1557193132846617e+00 + + max = 9.5103241712145760e+01 + + mean = 2.5758816692022646e-01 + + stddev = 3.5742050707630733e+00 diff --git a/test/testref/dirac_bump_8.ref b/test/testref/dirac_bump_8.ref index 21143aeb1..320041e21 100644 --- a/test/testref/dirac_bump_8.ref +++ b/test/testref/dirac_bump_8.ref @@ -11,7 +11,7 @@ Input Dirac increment: Subset Sc0 size: 7082 Domain area (% of Earth area): 0.100E+03% Level 1 ~> 100.0% - Level 1 ~> 0.444E-01 vert. coord. + Level 1 ~> 0.100E+01 vert. coord. Effective levels: 1 Horizontal support radius: 6000.00 km ( 6000.00 km - 6000.00 km) Estimated nc1 from horizontal support radius: 1636 @@ -22,7 +22,7 @@ Input Dirac increment: nc1( 1) = 1636 ns = 1636 v%n_s = 1 - c%n_s[global] = 132856 + c%n_s[global] = 141244 Full NICAS adjoint test result: T Block NICAS adjoint test result: T Interpolation adjoint test (horizontal) result: T @@ -32,13 +32,13 @@ Input Dirac increment: Communication AC adjoint test result: T Convolution / communication adjoint test result: T Component NICAS adjoint test result: T -Norm of output parameter vert_coord - 1: 1.2831019118921313e+01 +Norm of output parameter vert_coord - 1: 8.4154619599876980e+01 Covariance(SABER) * Increment: - Valid time: 2010-01-01T12:00:00Z Geometry: L120x61 [7320] Fields: - snow_depth (1 levels): + min = 0.0000000000000000e+00 - + max = 1.0000000000000004e+00 - + mean = 1.3214978864175818e-02 - + stddev = 8.9333392817362800e-02 + + max = 1.0000000000000002e+00 + + mean = 2.7083884586849495e-02 + + stddev = 1.1558741608103873e-01 diff --git a/test/testref/error_covariance_training_bump_hdiag-nicas_2.ref b/test/testref/error_covariance_training_bump_hdiag-nicas_2.ref index b0d315245..fe13576b3 100644 --- a/test/testref/error_covariance_training_bump_hdiag-nicas_2.ref +++ b/test/testref/error_covariance_training_bump_hdiag-nicas_2.ref @@ -1,64 +1,64 @@ - Independent levels: 1[1] 2[1] + Independent levels: 1[2] Subset Sc0 size: 762 - Domain area (% of Earth area): 0.660E+02% - Level 1 ~> 66.0% + Domain area (% of Earth area): 0.659E+02% + Level 1 ~> 65.9% Level 2 ~> 65.9% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. Level 1 ~> 100.0% Level 2 ~> 100.0% - Decimate full grid, at least 500 points required, 503 valid points found - Subgrid hash: -547664083 + Decimate full grid, at least 500 points required, 502 valid points found + Subgrid hash: 2060370530 + -90.00 deg. ~>100-99-98-93-90-87-82-71-74-64 -90.00 deg. ~>100-99-98-93-90-87-82-71-74-64 - -90.00 deg. ~>99-99-98-93-90-87-82-71-74-64 nc1 = 500 - Independent levels: 1[1] 2[1] - Independent levels for angular sector 1 / class 1: 1[1] 2[1] - Independent levels for angular sector 1 / class 2: 1[1] 2[1] - Independent levels for angular sector 1 / class 3: 1[1] 2[1] - Independent levels for angular sector 1 / class 4: 1[1] 2[1] - Independent levels for angular sector 1 / class 5: 1[1] 2[1] + Independent levels: 1[2] + Independent levels for angular sector 1 / class 1: 1[2] + Independent levels for angular sector 1 / class 2: 1[2] + Independent levels for angular sector 1 / class 3: 1[2] + Independent levels for angular sector 1 / class 4: 1[2] + Independent levels for angular sector 1 / class 5: 1[2] Independent levels for angular sector 1 / class 6: 1[2] Independent levels for angular sector 1 / class 7: 1[2] Independent levels for angular sector 1 / class 8: 1[2] Independent levels for angular sector 1 / class 9: 1[2] - Independent levels for angular sector 1 / class 10: 1[1] 2[1] + Independent levels for angular sector 1 / class 10: 1[2] Level: 1 ~> cov. at class zero: 0.10E+01 Level: 2 ~> cov. at class zero: 0.97E+00 - Block common: 0.14423083E+00 for 40 diagnostic points + Block common: 0.14430598E+00 for 40 diagnostic points Level: 1 ~> amplitude: 1.00 - cor. hor. support: 3757.50 km + cor. hor. support: 3752.43 km cor. ver. support: 3.16 vertical units Level: 2 ~> amplitude: 1.00 - cor. hor. support: 3801.46 km + cor. hor. support: 3799.61 km cor. ver. support: 3.16 vertical units - Block common: 0.28707492E+00 for 25 diagnostic points + Block common: 0.28730984E+00 for 25 diagnostic points Level: 1 ~> loc. at class zero: 0.92 Level: 2 ~> loc. at class zero: 0.92 Level: 1 ~> amplitude: 1.00 - loc. hor. support: 5256.58 km + loc. hor. support: 5256.27 km loc. ver. support: 5.84 vertical units Level: 2 ~> amplitude: 1.00 - loc. hor. support: 5589.86 km + loc. hor. support: 5595.96 km loc. ver. support: 5.84 vertical units Effective levels: 1 2 - Horizontal support radius: 5256.58 km ( 5256.58 km - 5256.58 km) - Estimated nc1 from horizontal support radius: 225 - Decimate full grid, at least 225 points required, 503 valid points found - Subgrid hash: -516241586 - Final nc1: 225 - Effective horizontal resolution: 4.00 - Horizontal support radius: 5589.86 km ( 5589.86 km - 5589.86 km) + Horizontal support radius: 5256.27 km ( 5256.27 km - 5256.27 km) + Estimated nc1 from horizontal support radius: 224 + Decimate full grid, at least 224 points required, 502 valid points found + Subgrid hash: 420041756 + Final nc1: 224 + Effective horizontal resolution: 3.99 + Horizontal support radius: 5595.96 km ( 5595.96 km - 5595.96 km) Estimated nc1 from horizontal support radius: 198 - Decimate full grid, at least 198 points required, 503 valid points found + Decimate full grid, at least 198 points required, 502 valid points found Subgrid hash: 958963916 Final nc1: 198 - Effective horizontal resolution: 3.99 - nc1( 1) = 225 + Effective horizontal resolution: 4.00 + nc1( 1) = 224 nc1( 2) = 198 - ns = 423 + ns = 422 v%n_s = 2 - c%n_s[global] = 7773 + c%n_s[global] = 7774 Full NICAS adjoint test result: T Block NICAS adjoint test result: T Interpolation adjoint test (horizontal) result: T @@ -72,11 +72,11 @@ Min / max: 1.0000000 / 1.0000000 over 10 tests 0.0 / 0.0: 1.0000000 Level 1: 0.0000000 - 1.0000000 - Level 2: 0.0000000 - 0.9169997 -Norm of output parameter dirac_mom - 1: 7.6878267329584924e+00 -Norm of output parameter dirac_diag_loc - 1: 2.7348452994402712e+00 -Norm of output parameter cor_rh - 1: 1.4700567559989282e+08 -Norm of output parameter cor_rv - 1: 1.2283222935748260e+02 -Norm of output parameter loc_rh - 1: 2.1276794919251037e+08 -Norm of output parameter loc_rv - 1: 2.2680379054766320e+02 -Norm of output parameter nicas_norm - 1: 4.0784027590857036e+01 + Level 2: 0.0000000 - 0.9169472 +Norm of output parameter dirac_mom - 1: 7.6865615586900731e+00 +Norm of output parameter dirac_diag_loc - 1: 2.7347034974796007e+00 +Norm of output parameter cor_rh - 1: 1.4684457511178359e+08 +Norm of output parameter cor_rv - 1: 1.2280268111721099e+02 +Norm of output parameter loc_rh - 1: 2.1286036558021423e+08 +Norm of output parameter loc_rv - 1: 2.2672861634787111e+02 +Norm of output parameter nicas_norm - 1: 4.0770349152697641e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag_1.ref b/test/testref/error_covariance_training_bump_hdiag_1.ref index 0f493ec40..6ae1f5b7b 100644 --- a/test/testref/error_covariance_training_bump_hdiag_1.ref +++ b/test/testref/error_covariance_training_bump_hdiag_1.ref @@ -144,7 +144,7 @@ Level: 2 ~> cov. at class zero: 0.10E+01 Level: 1 ~> cov. at class zero: 0.97E+00 Level: 2 ~> cov. at class zero: 0.10E+01 - Level: 1 ~> cov. at class zero: 0.97E+00 + Level: 2 ~> cov. at class zero: 0.97E+00 Block air_horizontal_streamfunction: 0.34331194E+00 for 37356 diagnostic points Block air_horizontal_velocity_potential: 0.34699286E+00 for 37356 diagnostic points Block air_pressure_at_surface: 0.33754527E+00 for 9339 diagnostic points @@ -172,10 +172,10 @@ Level: 2 ~> amplitude: 0.22 cor. hor. support: 2157.73 km cor. ver. support: 0.43 vertical units - Level: 1 ~> amplitude: 0.78 + Level: 2 ~> amplitude: 0.78 cor. hor. support: 3648.91 km cor. ver. support: 0.00 vertical units - Level: 1 ~> amplitude: 0.22 + Level: 2 ~> amplitude: 0.22 cor. hor. support: 2051.93 km cor. ver. support: 0.00 vertical units Norm of output parameter cor_a - 1: 5.0218339249789111e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag_2.ref b/test/testref/error_covariance_training_bump_hdiag_2.ref index 3ac486ab8..795732035 100644 --- a/test/testref/error_covariance_training_bump_hdiag_2.ref +++ b/test/testref/error_covariance_training_bump_hdiag_2.ref @@ -50,7 +50,7 @@ Independent levels for angular sector 4 / class 10: 1[2] Level: 1 ~> cov. at class zero: 0.99E+00 Level: 2 ~> cov. at class zero: 0.10E+01 - Level: 1 ~> cov. at class zero: 0.97E+00 + Level: 2 ~> cov. at class zero: 0.97E+00 Block air_horizontal_streamfunction: 0.34331194E+00 for 37356 diagnostic points Block air_pressure_at_surface: 0.33754527E+00 for 9339 diagnostic points Level: 1 ~> amplitude: 0.78 @@ -65,10 +65,10 @@ Level: 2 ~> amplitude: 0.24 cor. hor. support: 2288.34 km cor. ver. support: 0.47 vertical units - Level: 1 ~> amplitude: 0.78 + Level: 2 ~> amplitude: 0.78 cor. hor. support: 3648.91 km cor. ver. support: 0.00 vertical units - Level: 1 ~> amplitude: 0.22 + Level: 2 ~> amplitude: 0.22 cor. hor. support: 2051.93 km cor. ver. support: 0.00 vertical units Norm of output parameter cor_a - 1: 3.8643581248204796e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag_4.ref b/test/testref/error_covariance_training_bump_hdiag_4.ref index 2766dea93..669956a24 100644 --- a/test/testref/error_covariance_training_bump_hdiag_4.ref +++ b/test/testref/error_covariance_training_bump_hdiag_4.ref @@ -134,17 +134,17 @@ Independent levels for angular sector 4 / class 8: 1[2] Independent levels for angular sector 4 / class 9: 1[2] Independent levels for angular sector 4 / class 10: 1[2] - Level: 1 ~> cov. at class zero: 0.98E+00 - Level: 2 ~> cov. at class zero: 0.10E+01 + Level: 1 ~> cov. at class zero: 0.99E+00 + Level: 2 ~> cov. at class zero: 0.99E+00 Level: 1 ~> cov. at class zero: 0.97E+00 Level: 2 ~> cov. at class zero: 0.10E+01 - Block group 1: 0.17205228E+00 for 160 diagnostic points + Block group 1: 0.17278351E+00 for 160 diagnostic points Block group 2: 0.18673672E+00 for 160 diagnostic points Level: 1 ~> amplitude: 1.00 - cor. hor. support: 3539.02 km + cor. hor. support: 3547.46 km cor. ver. support: 3.21 vertical units Level: 2 ~> amplitude: 1.00 - cor. hor. support: 3690.36 km + cor. hor. support: 3604.82 km cor. ver. support: 3.21 vertical units Level: 1 ~> amplitude: 1.00 cor. hor. support: 3827.42 km @@ -152,15 +152,15 @@ Level: 2 ~> amplitude: 1.00 cor. hor. support: 3555.25 km cor. ver. support: 3.16 vertical units - Block group 1: 0.26350707E+00 for 111 diagnostic points + Block group 1: 0.26083760E+00 for 107 diagnostic points Block group 2: 0.27845780E+00 for 125 diagnostic points Level: 1 ~> loc. at class zero: 0.92 Level: 2 ~> loc. at class zero: 0.92 Level: 1 ~> amplitude: 1.00 - loc. hor. support: 5260.40 km - loc. ver. support: 6.04 vertical units + loc. hor. support: 5198.82 km + loc. ver. support: 6.03 vertical units Level: 2 ~> amplitude: 1.00 - loc. hor. support: 5500.12 km + loc. hor. support: 5457.83 km loc. ver. support: 6.03 vertical units Level: 1 ~> loc. at class zero: 0.92 Level: 2 ~> loc. at class zero: 0.92 @@ -170,5 +170,5 @@ Level: 2 ~> amplitude: 1.00 loc. hor. support: 5283.11 km loc. ver. support: 6.06 vertical units -Norm of output parameter loc_rh - 1: 3.3645318224198335e+08 -Norm of output parameter loc_rv - 1: 3.7311179621345985e+02 +Norm of output parameter loc_rh - 1: 3.3759349177248305e+08 +Norm of output parameter loc_rv - 1: 3.7296954375408131e+02 From 81453972259ca2caa76cbfc3944d9effaf0b91a4 Mon Sep 17 00:00:00 2001 From: David Davies Date: Mon, 10 Nov 2025 16:32:26 +0000 Subject: [PATCH 131/199] Remove ktrap option (#1143) Co-authored-by: Nate Crossette --- cmake/compiler_flags_Cray_CXX.cmake | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/cmake/compiler_flags_Cray_CXX.cmake b/cmake/compiler_flags_Cray_CXX.cmake index b6423484f..6138b2287 100644 --- a/cmake/compiler_flags_Cray_CXX.cmake +++ b/cmake/compiler_flags_Cray_CXX.cmake @@ -28,8 +28,8 @@ set( CMAKE_CXX_FLAGS_RELEASE "-O3 -hfp3 -hscalar3 -hvector3 -hPIC" ) # DEBUG FLAGS #################################################################### -set( CMAKE_Fortran_FLAGS_DEBUG "-O0 -Gfast -Ktrap=fp" ) -set( CMAKE_CXX_FLAGS_DEBUG "-O0 -Gfast -Ktrap=fp" ) +set( CMAKE_Fortran_FLAGS_DEBUG "-O0 -Gfast" ) +set( CMAKE_CXX_FLAGS_DEBUG "-O0 -Gfast" ) #################################################################### # BIT REPRODUCIBLE FLAGS @@ -43,7 +43,7 @@ set( CMAKE_CXX_FLAGS_BIT "-O2 -hflex_mp=conservative -hadd_paren -hfp1" #################################################################### set( CMAKE_Fortran_LINK_FLAGS "-Wl,-Map,loadmap" ) -set( CMAKE_CXX_LINK_FLAGS "-Wl,-Map,loadmap -Wl,-z,muldefs -Ktrap=fp $ENV{CRAYLIBS_X86_64}/btswap.o" ) +set( CMAKE_CXX_LINK_FLAGS "-Wl,-Map,loadmap -Wl,-z,muldefs $ENV{CRAYLIBS_X86_64}/btswap.o" ) set( CMAKE_CXX_LINK_EXECUTABLE " -o -Wl,-Bdynamic") #################################################################### @@ -51,7 +51,6 @@ set( CMAKE_CXX_LINK_EXECUTABLE " Date: Wed, 12 Nov 2025 16:15:23 +0100 Subject: [PATCH 132/199] Add argument (#1147) --- src/saber/blocks/SaberOuterBlockChain.h | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/saber/blocks/SaberOuterBlockChain.h b/src/saber/blocks/SaberOuterBlockChain.h index 67baf8e75..ace947cc6 100644 --- a/src/saber/blocks/SaberOuterBlockChain.h +++ b/src/saber/blocks/SaberOuterBlockChain.h @@ -138,6 +138,7 @@ class SaberOuterBlockChain { const oops::Geometry & geom, const bool & validModelGeom, const oops::Variables & outerVars, + const oops::Variables & currentOuterVars, oops::FieldSets & fsetEns); /// @brief Left inverse multiply (used in calibration) by all outer blocks @@ -248,6 +249,7 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, fset4dXb, geom, validModelGeom, + outerVars, currentOuterVars, fsetEns); } else if (saberOuterBlockParams.doRead()) { @@ -259,7 +261,7 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, if (saberOuterBlockParams.forceWrite.value()) { // Write data oops::Log::info() << "Info : Write data" << std::endl; - outerBlocks_.back()->write(geom, validModelGeom, outerVars); + outerBlocks_.back()->write(geom, validModelGeom, currentOuterVars); outerBlocks_.back()->write(); } @@ -322,6 +324,7 @@ void SaberOuterBlockChain::calibrateBlock( const oops::Geometry & geom, const bool & validModelGeom, const oops::Variables & outerVars, + const oops::Variables & currentOuterVars, oops::FieldSets & fsetEns) { oops::Log::trace() << "calibrateBlock starting" << std::endl; @@ -339,9 +342,6 @@ void SaberOuterBlockChain::calibrateBlock( // Get ensemble size const size_t nens = ensembleConf.getInt("ensemble size"); - // Cannot read ensemble members without a valid MODEL geometry - ASSERT(validModelGeom || (nens == 0)); - for (size_t ie = 0; ie < nens; ++ie) { // Read ensemble member oops::FieldSet3D fset(fset4dXb[0].validTime(), geom.getComm()); @@ -350,6 +350,7 @@ void SaberOuterBlockChain::calibrateBlock( ensembleConf, ie, fset); + // Apply outer blocks inverse (except last) this->leftInverseMultiplyExceptLast(fset); @@ -369,7 +370,7 @@ void SaberOuterBlockChain::calibrateBlock( // Write calibration data oops::Log::info() << "Info : Write calibration data" << std::endl; - outerBlocks_.back()->write(geom, validModelGeom, outerVars); + outerBlocks_.back()->write(geom, validModelGeom, currentOuterVars); outerBlocks_.back()->write(); oops::Log::trace() << "calibrateBlock done" << std::endl; From 06fb691f1a73e366c640fc461af0a4399705eb6e Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Thu, 13 Nov 2025 18:27:56 +0100 Subject: [PATCH 133/199] Force nearest 3D level from yaml (#1151) * Add yaml parameter to force the nearest 3d level * Remove debug print --- src/saber/bump/BUMP.cc | 41 +++++++++++++++++---------------- src/saber/bump/BUMPParameters.h | 2 ++ 2 files changed, 23 insertions(+), 20 deletions(-) diff --git a/src/saber/bump/BUMP.cc b/src/saber/bump/BUMP.cc index 93f9db447..92efc40eb 100644 --- a/src/saber/bump/BUMP.cc +++ b/src/saber/bump/BUMP.cc @@ -17,6 +17,8 @@ #include #include +#include "eckit/exception/Exceptions.h" + #include "oops/base/FieldSets.h" #include "oops/util/ConfigFunctions.h" #include "oops/util/FieldSetHelpers.h" @@ -104,8 +106,7 @@ BUMP::BUMP(const oops::GeometryData & geometryData, // Check grids number if (grids.size() == 0) { - oops::Log::info() << "BUMP: grid size is zero" << std::endl; - std::abort(); + throw eckit::Exception("BUMP: grid size is zero", Here()); } // Loop over grids @@ -142,8 +143,7 @@ BUMP::BUMP(const oops::GeometryData & geometryData, if (nl0 > 1) { // Check that nl0_tmp is either 1 or nl0 if ((nl0_tmp != 1) && (nl0_tmp != nl0)) { - oops::Log::info() << "BUMP::BUMP: inconsistent number of levels in BUMP" << std::endl; - std::abort(); + throw eckit::Exception("BUMP::BUMP: inconsistent number of levels in BUMP", Here()); } } nl0 = std::max(nl0, nl0_tmp); @@ -163,16 +163,22 @@ BUMP::BUMP(const oops::GeometryData & geometryData, // Add nearest 3D level for 2D fields std::string nearest3dLevel; + if (grid.has("model.nearest 3d level")) { + nearest3dLevel = grid.getString("model.nearest 3d level"); + } for (const auto & var : var2d) { - if (xb[var].metadata().has("nearest 3d level")) { - const std::string value = xb[var].metadata().getString("nearest 3d level"); - if (nearest3dLevel.empty()) { - nearest3dLevel = value; - } else { - ASSERT(value == nearest3dLevel); + if (xb.has(var)) { + if (xb[var].metadata().has("nearest 3d level")) { + const std::string value = xb[var].metadata().getString("nearest 3d level"); + if (nearest3dLevel.empty()) { + nearest3dLevel = value; + } else { + ASSERT(value == nearest3dLevel); + } } } } + ASSERT(nearest3dLevel == "" || nearest3dLevel == "bottom" || nearest3dLevel == "top"); grid.set("model.nearest 3d level", nearest3dLevel); // Add levels direction @@ -363,8 +369,7 @@ void BUMP::addField(const oops::FieldSet3D & fset) { // Check fset grid UID if (fset.size() > 0) { if (fset.getGridUid() != gridUid_) { - oops::Log::info() << "BUMP: wrong grid UID" << std::endl; - std::abort(); + throw eckit::Exception("BUMP: wrong grid UID", Here()); } } @@ -401,14 +406,12 @@ void BUMP::addEnsemble(const oops::FieldSets & fsetEns) { if (dualResolutionGridUid_ == "") { igeom = 0; if (fsetEns[jj].getGridUid() != gridUid_) { - oops::Log::info() << "BUMP::addEnsemble: wrong grid UID" << std::endl; - std::abort(); + throw eckit::Exception("BUMP::addEnsemble: wrong grid UID", Here()); } } else { igeom = 1; if (fsetEns[jj].getGridUid() != dualResolutionGridUid_) { - oops::Log::info() << "BUMP::addEnsemble: wrong dual resolution grid UID" << std::endl; - std::abort(); + throw eckit::Exception("BUMP::addEnsemble: wrong dual resolution grid UID", Here()); } } @@ -463,14 +466,12 @@ void BUMP::iterativeUpdate(const oops::FieldSet3D & fset, if (dualResolutionGridUid_ == "") { igeom = 0; if (fset.getGridUid() != gridUid_) { - oops::Log::info() << "BUMP::iterativeUpdate: wrong grid UID" << std::endl; - std::abort(); + throw eckit::Exception("BUMP::iterativeUpdate: wrong grid UID", Here()); } } else { igeom = 1; if (fset.getGridUid() != dualResolutionGridUid_) { - oops::Log::info() << "BUMP::iterativeUpdate: wrong dual resolution grid UID" << std::endl; - std::abort(); + throw eckit::Exception("BUMP::iterativeUpdate: wrong dual resolution grid UID", Here()); } } diff --git a/src/saber/bump/BUMPParameters.h b/src/saber/bump/BUMPParameters.h index 66526fede..3abf74140 100644 --- a/src/saber/bump/BUMPParameters.h +++ b/src/saber/bump/BUMPParameters.h @@ -363,6 +363,8 @@ class ModelSection : public oops::Parameters { oops::Parameter> variables{"variables", {}, this}; // 2D variables names oops::Parameter> var2d{"2d variables", {}, this}; + // Nearest 3D level + oops::OptionalParameter nearest3dLevel{"nearest 3d level", this}; // Groups of variables oops::OptionalParameter> groups{"groups", this}; // Check that sampling couples and interpolations do not cross mask boundaries From cdb793435adb89a1ad332580bf6f16f6f5f806cd Mon Sep 17 00:00:00 2001 From: Josh Colclough <109143205+mo-joshuacolclough@users.noreply.github.com> Date: Tue, 18 Nov 2025 22:00:18 +0000 Subject: [PATCH 134/199] Prepare for Atlas 0.44.1 (#1149) * Initial change to add metadata in GaussToCS * Local changes * Fix metadata setting * Add vector field opt wherever fields are created in GaussToCS * Refactor to use ifdefs * Version >= * Cmake issue * Rm unecessary metadata * Coding norms * Move function into anon namespace * Remove use * Rm uneccessary import * Remove unused imports * Remove constexpr if * == false to ! * Change atlas version in cmake * Use if rather than a static map * Update src/saber/interpolation/VectorFieldMetadata.cc Co-authored-by: Marek Wlasak --------- Co-authored-by: Marek Wlasak --- CMakeLists.txt | 5 + src/saber/interpolation/AtlasInterpWrapper.cc | 17 +- src/saber/interpolation/CMakeLists.txt | 4 + src/saber/interpolation/GaussToCS.cc | 187 +++++++++--------- .../interpolation/VectorFieldMetadata.cc | 68 +++++++ src/saber/interpolation/VectorFieldMetadata.h | 18 ++ 6 files changed, 193 insertions(+), 106 deletions(-) create mode 100644 src/saber/interpolation/VectorFieldMetadata.cc create mode 100644 src/saber/interpolation/VectorFieldMetadata.h diff --git a/CMakeLists.txt b/CMakeLists.txt index a7429e231..c9db951f2 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -64,6 +64,11 @@ if( atlas_VERSION VERSION_GREATER "0.41" ) add_definitions(-DATLAS_MAKE_SPARSE) endif() +# Flag to signify Atlas supports spherical vector interpolation. +if( atlas_VERSION VERSION_GREATER_EQUAL "0.44.0" ) + add_definitions(-DATLAS_SUPPORTS_SPHERICAL_VECTOR_INTERP_META) +endif() + if( ENABLE_MKL ) find_package( MKL ) endif() diff --git a/src/saber/interpolation/AtlasInterpWrapper.cc b/src/saber/interpolation/AtlasInterpWrapper.cc index c48947aed..ed5476b3a 100644 --- a/src/saber/interpolation/AtlasInterpWrapper.cc +++ b/src/saber/interpolation/AtlasInterpWrapper.cc @@ -7,6 +7,7 @@ */ #include "saber/interpolation/AtlasInterpWrapper.h" +#include "saber/interpolation/VectorFieldMetadata.h" #include "atlas/array.h" #include "atlas/field.h" @@ -148,13 +149,11 @@ void AtlasInterpWrapper::execute(const atlas::FieldSet & srcFieldSet, } atlas::FieldSet targetFieldSet = util::createFieldSet(targetFspace_, variableSizes, - dstFieldSet.field_names(), 0.0); + dstFieldSet.field_names(), 0.0); if (includingVectorInterpolation_) { - tmpSrcFieldSet["eastward_wind"].metadata().set("vector_field_name", "wind"); - tmpSrcFieldSet["northward_wind"].metadata().set("vector_field_name", "wind"); - targetFieldSet["eastward_wind"].metadata().set("vector_field_name", "wind"); - targetFieldSet["northward_wind"].metadata().set("vector_field_name", "wind"); + appendVectorFieldMeta(tmpSrcFieldSet); + appendVectorFieldMeta(targetFieldSet); } interp_.execute(tmpSrcFieldSet, targetFieldSet); @@ -193,13 +192,11 @@ void AtlasInterpWrapper::executeAdjoint(atlas::FieldSet & srcFieldSet, } atlas::FieldSet targetFieldSet = util::createFieldSet(targetFspace_, variableSizes, - dstFieldSet.field_names(), 0.0); + dstFieldSet.field_names(), 0.0); if (includingVectorInterpolation_) { - srcFieldSet["eastward_wind"].metadata().set("vector_field_name", "wind"); - srcFieldSet["northward_wind"].metadata().set("vector_field_name", "wind"); - targetFieldSet["eastward_wind"].metadata().set("vector_field_name", "wind"); - targetFieldSet["northward_wind"].metadata().set("vector_field_name", "wind"); + appendVectorFieldMeta(srcFieldSet); + appendVectorFieldMeta(targetFieldSet); } inverseRedistr_.execute(tmpDstFieldSet, targetFieldSet); diff --git a/src/saber/interpolation/CMakeLists.txt b/src/saber/interpolation/CMakeLists.txt index cf7f943b7..e7320f874 100644 --- a/src/saber/interpolation/CMakeLists.txt +++ b/src/saber/interpolation/CMakeLists.txt @@ -21,6 +21,10 @@ Interpolation.h # VertProj block VertProj.cc VertProj.h + +# Vector field utils +VectorFieldMetadata.cc +VectorFieldMetadata.h ) if( atlas_TRANS_FOUND OR atlas_ECTRANS_FOUND ) diff --git a/src/saber/interpolation/GaussToCS.cc b/src/saber/interpolation/GaussToCS.cc index 818d8f2f6..de8d55521 100644 --- a/src/saber/interpolation/GaussToCS.cc +++ b/src/saber/interpolation/GaussToCS.cc @@ -6,6 +6,7 @@ */ #include + #include "atlas/field.h" #include "atlas/grid/detail/partitioner/MatchingMeshPartitionerCubedSphere.h" #include "atlas/grid/detail/partitioner/TransPartitioner.h" @@ -17,6 +18,7 @@ #include "saber/interpolation/GaussToCS.h" #include "saber/interpolation/Rescaling.h" +#include "saber/interpolation/VectorFieldMetadata.h" using atlas::grid::detail::partitioner::TransPartitioner; using atlas::grid::detail::partitioner::MatchingMeshPartitionerCubedSphere; @@ -114,6 +116,25 @@ auto createInverseInterpolation(const bool initializeInverseInterpolation, // ----------------------------------------------------------------------------- +namespace { + + // Util for gathering a subset of field configurations, when creating fields for interpolation. + std::vector gatherInterpFieldConfigs(const atlas::FieldSet& fset, + const oops::Variables& variables) { + std::vector out; + for (auto& fieldname : fset.field_names()) { + if (variables.has(fieldname)) { + out.emplace_back(atlas::option::name(fieldname) | + atlas::option::levels(fset[fieldname].shape(1))); + } + } + return out; + } + +} // namespace + +// ----------------------------------------------------------------------------- + /* Direct interpolation from NodeColumn cubed-sphere FunctionSpace to * StructuredColumns is not possible on multiple PEs. * Here, the interpolation is done following this route: @@ -133,76 +154,63 @@ void inverseInterpolateMultiplePEs( srcFieldSet.haloExchange(); - // extract copy of field names and apply sorting algorithm - auto sortedFieldNames = srcFieldSet.field_names(); - std::sort(sortedFieldNames.begin(), sortedFieldNames.end()); - // Interpolate from source to matching PointCloud and create srcFieldSet copy. atlas::FieldSet tmpSrcFieldSet; atlas::FieldSet matchingPtcldFset; - for (auto & fieldname : sortedFieldNames) { - if (variables.has(fieldname)) { - auto matchingPtcldField = - inverseInterpolation.matchingPtcldFspace->createField( - atlas::option::name(fieldname) | - atlas::option::levels(srcFieldSet[fieldname].shape(1))); - - auto tmpSrcField = - srcFieldSet[fieldname].functionspace().createField( - atlas::option::name(fieldname) | - atlas::option::levels(srcFieldSet[fieldname].shape(1))); - - atlas::array::make_view(matchingPtcldField).assign(0.0); - - const auto srcView = atlas::array::make_view(srcFieldSet[fieldname]); - auto srcTmpView = atlas::array::make_view(tmpSrcField); - for (atlas::idx_t t = 0; t < srcFieldSet[fieldname].shape(0); ++t) { - for (atlas::idx_t k = 0; k < srcFieldSet[fieldname].shape(1); ++k) { - srcTmpView(t, k) = srcView(t, k); - } - } + // Gather field configurations for fields to interpolate, filtering + // those that are not in `variables`. + const std::vector interpedFieldConfigs = + gatherInterpFieldConfigs(srcFieldSet, variables); + + for (auto& fieldConfig : interpedFieldConfigs) { + const auto fieldname = fieldConfig.getString("name"); + + auto matchingPtcldField = + inverseInterpolation.matchingPtcldFspace->createField(fieldConfig); + auto tmpSrcField = srcFieldSet[fieldname].functionspace().createField(fieldConfig); - matchingPtcldFset.add(matchingPtcldField); - tmpSrcFieldSet.add(tmpSrcField); + atlas::array::make_view(matchingPtcldField).assign(0.0); + + const auto srcView = atlas::array::make_view(srcFieldSet[fieldname]); + auto srcTmpView = atlas::array::make_view(tmpSrcField); + for (atlas::idx_t t = 0; t < srcFieldSet[fieldname].shape(0); ++t) { + for (atlas::idx_t k = 0; k < srcFieldSet[fieldname].shape(1); ++k) { + srcTmpView(t, k) = srcView(t, k); + } } + + matchingPtcldFset.add(matchingPtcldField); + tmpSrcFieldSet.add(tmpSrcField); } if (includingVectorInterpolation) { - tmpSrcFieldSet["eastward_wind"].metadata().set("vector_field_name", "wind"); - tmpSrcFieldSet["northward_wind"].metadata().set("vector_field_name", "wind"); - matchingPtcldFset["eastward_wind"].metadata().set("vector_field_name", "wind"); - matchingPtcldFset["northward_wind"].metadata().set("vector_field_name", "wind"); + appendVectorFieldMeta(tmpSrcFieldSet); + appendVectorFieldMeta(matchingPtcldFset); } inverseInterpolation.interpolation.execute(tmpSrcFieldSet, matchingPtcldFset); // Redistribute from matching PointCloud to target PointCloud atlas::FieldSet targetPtcldFset; - for (auto & fieldname : sortedFieldNames) { - if (variables.has(fieldname)) { - auto targetPtcldField = - inverseInterpolation.targetPtcldFspace->createField( - atlas::option::name(fieldname) | - atlas::option::levels(srcFieldSet[fieldname].shape(1))); - targetPtcldFset.add(targetPtcldField); - } + + for (auto& fieldConfig : interpedFieldConfigs) { + auto targetPtcldField = + inverseInterpolation.targetPtcldFspace->createField(fieldConfig); + targetPtcldFset.add(targetPtcldField); } inverseInterpolation.redistribution.execute(matchingPtcldFset, targetPtcldFset); // Copy from target PointCloud to gauss StructuredColumns - for (auto & fieldname : sortedFieldNames) { - if (variables.has(fieldname)) { - atlas::Field gaussField = - gaussFunctionSpace.createField( - atlas::option::name(fieldname) | - atlas::option::levels(srcFieldSet[fieldname].shape(1))); - atlas::array::make_view(gaussField).assign( - atlas::array::make_view(targetPtcldFset[fieldname])); - gaussField.set_dirty(); // atlas interpolation/redistribution above produces dirty halos - newFieldSet.add(gaussField); - } + for (auto& fieldConfig : interpedFieldConfigs) { + const auto fieldname = fieldConfig.getString("name"); + + atlas::Field gaussField = gaussFunctionSpace.createField(fieldConfig); + atlas::array::make_view(gaussField).assign( + atlas::array::make_view(targetPtcldFset[fieldname])); + gaussField.set_dirty(); // atlas interpolation/redistribution above produces dirty halos + newFieldSet.add(gaussField); } } @@ -240,60 +248,47 @@ void inverseInterpolateSinglePE( oops::Log::info() << "CSFunctionSpace.type() is: " << CSFunctionSpace.type() << std::endl; const auto interp = atlas::Interpolation(interpConfig, CSFunctionSpace, hybridFunctionSpace); - - // extract copy of field names and apply sorting algorithm - auto sortedFieldNames = srcFieldSet.field_names(); - std::sort(sortedFieldNames.begin(), sortedFieldNames.end()); + const std::vector interpedFieldConfigs = + gatherInterpFieldConfigs(srcFieldSet, variables); atlas::FieldSet tmpSrcFieldSet; atlas::FieldSet hybridFieldSet; - for (auto & fieldname : sortedFieldNames) { - if (variables.has(fieldname)) { - atlas::Field hybridField = - hybridFunctionSpace.createField( - atlas::option::name(fieldname) | - atlas::option::levels(srcFieldSet[fieldname].shape(1))); - atlas::Field tmpSrcField = - srcFieldSet[fieldname].functionspace().createField( - atlas::option::name(fieldname) | - atlas::option::levels(srcFieldSet[fieldname].shape(1))); - atlas::array::make_view(hybridField).assign(0.0); - - const auto srcView = atlas::array::make_view(srcFieldSet[fieldname]); - auto srcTmpView = atlas::array::make_view(tmpSrcField); - for (atlas::idx_t t = 0; t < srcFieldSet[fieldname].shape(0); ++t) { - for (atlas::idx_t k = 0; k < srcFieldSet[fieldname].shape(1); ++k) { - srcTmpView(t, k) = srcView(t, k); - } - } - hybridFieldSet.add(hybridField); - tmpSrcFieldSet.add(tmpSrcField); + for (auto& fieldConfig : interpedFieldConfigs) { + const auto fieldname = fieldConfig.getString("name"); + + atlas::Field hybridField = hybridFunctionSpace.createField(fieldConfig); + atlas::Field tmpSrcField = + srcFieldSet[fieldname].functionspace().createField(fieldConfig); + atlas::array::make_view(hybridField).assign(0.0); + + const auto srcView = atlas::array::make_view(srcFieldSet[fieldname]); + auto srcTmpView = atlas::array::make_view(tmpSrcField); + for (atlas::idx_t t = 0; t < srcFieldSet[fieldname].shape(0); ++t) { + for (atlas::idx_t k = 0; k < srcFieldSet[fieldname].shape(1); ++k) { + srcTmpView(t, k) = srcView(t, k); + } } + + hybridFieldSet.add(hybridField); + tmpSrcFieldSet.add(tmpSrcField); } if (includingVectorInterpolation) { - tmpSrcFieldSet["eastward_wind"].metadata().set("vector_field_name", "wind"); - tmpSrcFieldSet["northward_wind"].metadata().set("vector_field_name", "wind"); - hybridFieldSet["eastward_wind"].metadata().set("vector_field_name", "wind"); - hybridFieldSet["northward_wind"].metadata().set("vector_field_name", "wind"); + appendVectorFieldMeta(tmpSrcFieldSet); + appendVectorFieldMeta(hybridFieldSet); } - interp.execute(tmpSrcFieldSet, hybridFieldSet); // Copy into StructuredColumns - for (auto & fieldname : sortedFieldNames) { - if (variables.has(fieldname)) { - atlas::Field gaussField = - gaussFunctionSpace.createField( - atlas::option::name(fieldname) | - atlas::option::levels(srcFieldSet[fieldname].shape(1))); - atlas::array::make_view(gaussField).assign( - atlas::array::make_view(hybridFieldSet[fieldname])); - gaussField.set_dirty(); // atlas interpolation above produces dirty halos - newFieldSet.add(gaussField); - } + for (auto& fieldConfig : interpedFieldConfigs) { + const auto fieldname = fieldConfig.getString("name"); + atlas::Field gaussField = gaussFunctionSpace.createField(fieldConfig); + atlas::array::make_view(gaussField).assign( + atlas::array::make_view(hybridFieldSet[fieldname])); + gaussField.set_dirty(); // atlas interpolation above produces dirty halos + newFieldSet.add(gaussField); } } @@ -358,9 +353,7 @@ GaussToCS::GaussToCS(const oops::GeometryData & outerGeometryData, getHalo(params.interpType.value()))), gaussPartitioner_(new TransPartitioner()), csgrid_(CSFunctionSpace_.mesh().grid()), - includingVectorInterpolation_( - activeVars_.has("eastward_wind") && activeVars_.has("northward_wind") - && params.skipVectorInterpolation == false ? true:false), + includingVectorInterpolation_(params.skipVectorInterpolation == false), interp_(gaussPartitioner_, gaussFunctionSpace_, csgrid_, CSFunctionSpace_, params.interpType.value(), includingVectorInterpolation_), inverseInterpolation_(createInverseInterpolation( @@ -518,10 +511,12 @@ void GaussToCS::leftInverseMultiply(oops::FieldSet3D & fieldSet) const { } if (innerGeometryData_.comm().size() >= 2) { - inverseInterpolateMultiplePEs(activeVars_, inverseInterpolation_, + inverseInterpolateMultiplePEs(activeVars_, + inverseInterpolation_, gaussFunctionSpace_, includingVectorInterpolation_, - srcFieldSet, newFieldSet); + srcFieldSet, + newFieldSet); } else { // A faster and more direct route is possible on a single PE inverseInterpolateSinglePE(activeVars_, diff --git a/src/saber/interpolation/VectorFieldMetadata.cc b/src/saber/interpolation/VectorFieldMetadata.cc new file mode 100644 index 000000000..2fc1d62e1 --- /dev/null +++ b/src/saber/interpolation/VectorFieldMetadata.cc @@ -0,0 +1,68 @@ +/* + * (C) Crown Copyright 2025 Met Office + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ + +#include +#include + +#include "atlas/library/version.h" +#include "atlas/option/Options.h" +#include "atlas/util/Config.h" + +#include "saber/interpolation/VectorFieldMetadata.h" + + +namespace saber { +namespace interpolation { + +namespace { + +// Retrieves the vector field configuration for a given variable name, if there is one. +atlas::util::Config getVectorFieldOpt(const std::string_view varName) { +#ifdef ATLAS_SUPPORTS_SPHERICAL_VECTOR_INTERP_META + constexpr size_t xComponent = 0; + constexpr size_t yComponent = 1; + + if (varName == "eastward_wind") { + return atlas::option::vector_component("wind", xComponent); + } else if (varName == "northward_wind") { + return atlas::option::vector_component("wind", yComponent); + } else if (varName == "eastward_wind_at_10m") { + return atlas::option::vector_component("wind_at_10m", xComponent); + } else if (varName == "northward_wind_at_10m") { + return atlas::option::vector_component("wind_at_10m", yComponent); + } + +#endif // ATLAS_SUPPORTS_SPHERICAL_VECTOR_INTERP_META + + // Empty config - don't add any vector config to this field. + return atlas::util::Config(); +} + +} // namespace + +// ------------------------------------------------------------------------------------------------ + +void appendVectorFieldMeta(atlas::FieldSet& fset) { + // If supported, use spherical vector implementation. +#ifdef ATLAS_SUPPORTS_SPHERICAL_VECTOR_INTERP_META + for (auto& field : fset) { + auto opt = getVectorFieldOpt(field.name()); + if (!opt.empty()) { // If this field is a component of a vector field. + field.metadata().set(opt); + } + } +#else + // Otherwise, 'old-school' method. + if (fset.has("eastward_wind") && fset.has("northward_wind")) { + fset["eastward_wind"].metadata().set("vector_field_name", "wind"); + fset["northward_wind"].metadata().set("vector_field_name", "wind"); + } +#endif // ATLAS_SUPPORTS_SPHERICAL_VECTOR_INTERP_META +} + +} // namespace interpolation +} // namespace saber diff --git a/src/saber/interpolation/VectorFieldMetadata.h b/src/saber/interpolation/VectorFieldMetadata.h new file mode 100644 index 000000000..d6c34d8ed --- /dev/null +++ b/src/saber/interpolation/VectorFieldMetadata.h @@ -0,0 +1,18 @@ +/* + * (C) Crown Copyright 2025 Met Office + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ +#pragma once + +#include "atlas/field/FieldSet.h" + +namespace saber { +namespace interpolation { + +// Append metadata to fields for vector field interpolation. +void appendVectorFieldMeta(atlas::FieldSet& fset); + +} // namespace interpolation +} // namespace saber From 38477283ae5afa98cfaa389da3c225abc85d0aae Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Wed, 19 Nov 2025 15:38:55 +0100 Subject: [PATCH 135/199] New orographic interpolation block (#1052) * Fix quench geometry reader * Orographic interpolation block * Add test * Split Fields read/write * Fix indentation * Fix level * Cleaner vertical coordinate setup * WIP * Clean Geometry * Fix * Fixes * Reset * Wind bugfix * Read surface altitude * Update test * Fix Arome reader * Use interpolated variables * Change source name * WIP * Remove non-default Fields I/O * WIP * Fix lapse rate and coding norms * Fix interpolation variables * Vertical coordinate from background or geometry * Fix to skip 2D variables * Add orographic factor * Cleaning * Cleaning * Cleaning * add jedi-ci action (#1090) Add jedi-ci action Parent issue: JCSDA-internal/jedi-ci#16 Admin merge justification: JCSDA-internal/jedi-ci#17 * Fix yaml and refs * Remove orographic interpolation file * Add variable check, remove interpolation variables initialization * Trigger tests --------- Co-authored-by: Evan Parker Co-authored-by: Nate Crossette --- src/saber/generic/CMakeLists.txt | 4 + src/saber/generic/OrographicInterp.cc | 288 ++++++++++++++++++++ src/saber/generic/OrographicInterp.h | 90 ++++++ test/testdeps/dirac_orographic_interp.txt | 0 test/testinput/dirac_orographic_interp.yaml | 73 +++++ test/testlist/saber_data.txt | 1 + test/testlist/saber_test_tier1.txt | 1 + test/testref/dirac_orographic_interp.ref | 28 ++ 8 files changed, 485 insertions(+) create mode 100644 src/saber/generic/OrographicInterp.cc create mode 100644 src/saber/generic/OrographicInterp.h create mode 100644 test/testdeps/dirac_orographic_interp.txt create mode 100644 test/testinput/dirac_orographic_interp.yaml create mode 100644 test/testref/dirac_orographic_interp.ref diff --git a/src/saber/generic/CMakeLists.txt b/src/saber/generic/CMakeLists.txt index 59d90e5d5..11b9909d1 100644 --- a/src/saber/generic/CMakeLists.txt +++ b/src/saber/generic/CMakeLists.txt @@ -20,6 +20,10 @@ Hybrid.cc ID.h ID.cc +# Orographic interpolation block +OrographicInterp.h +OrographicInterp.cc + # Shadow levels block ShadowLevels.h ShadowLevels.cc diff --git a/src/saber/generic/OrographicInterp.cc b/src/saber/generic/OrographicInterp.cc new file mode 100644 index 000000000..613a096ad --- /dev/null +++ b/src/saber/generic/OrographicInterp.cc @@ -0,0 +1,288 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#include "saber/generic/OrographicInterp.h" + +#include +#include + +#include "eckit/exception/Exceptions.h" + +using atlas::array::make_view; + +namespace saber { +namespace generic { + +// ----------------------------------------------------------------------------- + +static SaberOuterBlockMaker makerOrographicInterp_("OrographicInterp"); + +// ----------------------------------------------------------------------------- + +OrographicInterp::OrographicInterp(const oops::GeometryData & outerGeometryData, + const oops::Variables & outerVars, + const eckit::Configuration & covarConfig, + const Parameters_ & params, + const oops::FieldSet3D & xb, + const oops::FieldSet3D & fg) + : SaberOuterBlockBase(params, xb.validTime()), + innerGeometryData_(outerGeometryData), + comm_(outerGeometryData.comm()), + innerVars_(outerVars), + params_(params) +{ + oops::Log::trace() << classname() << "::OrographicInterp starting" << std::endl; + + // Get ghost view + const auto ghostView = make_view(outerGeometryData.functionSpace().ghost()); + + // Vertical coordinates fieldset + atlas::FieldSet vcFset; + + // List what vertical coordinates will be used + for (const auto & var : innerVars_) { + if (params_.fieldsMetaData.value().has(var.name())) { + // Add interpolated variable + interpVars_.push_back(var); + + // Get vertical coordinate name + const std::string vcName = params_.fieldsMetaData.value().getString( + var.name() + ".vert_coord"); + + if (!vcFset.has(vcName)) { + if (xb.has(vcName)) { + // From background + vcFset.add(xb[vcName]); + } else { + // From geometry fieldset + if (outerGeometryData.fieldSet().has(vcName)) { + vcFset.add(outerGeometryData.fieldSet()[vcName]); + } else { + throw eckit::UserError("variable " + vcName + " missing in geometry fields", Here()); + } + } + } + } + } + + // Process vertical coordinates + for (const auto & vcField : vcFset) { + oops::Log::info() << "Info : Process vertical coordinate " << vcField.name() << std::endl; + + // Get number of levels + const size_t nz = vcField.shape(1); + ASSERT(nz > 1); + + // Get vertical coordinate field view + const auto vcView = make_view(vcField); + + // Compute vertical coordinates min/max/avg profile + std::vector vcMin(nz, std::numeric_limits().max()); + std::vector vcMax(nz, -std::numeric_limits().max()); + std::vector vcAvg(nz, 0.0); + int vcSize = 0.0; + for (int jnode = 0; jnode < vcField.shape(0); ++jnode) { + if (ghostView(jnode) == 0) { + for (size_t jz = 0; jz < nz; ++jz) { + vcMin[jz] = std::min(vcMin[jz], vcView(jnode, jz)); + vcMax[jz] = std::max(vcMax[jz], vcView(jnode, jz)); + vcAvg[jz] += vcView(jnode, jz); + } + ++vcSize; + } + } + + // Get global min/max profile + comm_.allReduceInPlace(vcMin.begin(), vcMin.end(), eckit::mpi::min()); + comm_.allReduceInPlace(vcMax.begin(), vcMax.end(), eckit::mpi::max()); + comm_.allReduceInPlace(vcAvg.begin(), vcAvg.end(), eckit::mpi::sum()); + comm_.allReduceInPlace(vcSize, eckit::mpi::sum()); + + // Normalize average + for (size_t jz = 0; jz < nz; ++jz) { + vcAvg[jz] /= static_cast(vcSize); + } + + // Get direction + const bool increasing = (vcAvg[0] < vcAvg[nz-1]); + + // Get constant vertical coordinate profile + std::vector vcConst(nz); + for (size_t jz = 0; jz < nz; ++jz) { + // Normalized vertical index + const double alpha = static_cast(jz)/static_cast(nz-1); + + // Vertical coordinate + if (increasing) { + vcConst[jz] = alpha*vcMax[jz] + (1.0-alpha)*vcMin[jz]; + } else { + vcConst[jz] = alpha*vcMin[jz] + (1.0-alpha)*vcMax[jz]; + } + } + + // Create interpolation fields + auto rowField = outerGeometryData.functionSpace().createField( + atlas::option::name(vcField.name() + "_row") | atlas::option::levels(2*nz)); + auto colField = outerGeometryData.functionSpace().createField( + atlas::option::name(vcField.name() + "_col") | atlas::option::levels(2*nz)); + auto SField = outerGeometryData.functionSpace().createField( + atlas::option::name(vcField.name() + "_S") | atlas::option::levels(2*nz)); + auto rowView = make_view(rowField); + auto colView = make_view(colField); + auto SView = make_view(SField); + rowView.assign(-1); + colView.assign(-1); + SView.assign(0.0); + interpFset_.add(rowField); + interpFset_.add(colField); + interpFset_.add(SField); + + // Compute interpolation + for (int jnode = 0; jnode < vcField.shape(0); ++jnode) { + // Initialization + size_t cz = 0; + size_t iz = 0; + + for (size_t jz = 0; jz < nz; ++jz) { + // Loop over levels + bool found = false; + + do { + if (increasing) { + if (vcView(jnode, jz) < vcConst[cz+1]) { + // Value below the current constant level + found = true; + } + } else { + if (vcView(jnode, jz) > vcConst[cz+1]) { + // Value above the current constant level + found = true; + } + } + + if (cz == nz-2) { + // Only up to the second to last level + found = true; + } + + if (!found) { + // Increase index + ++cz; + } + } while (!found); + + // Check interpolation index + ASSERT(iz < 2*nz); + + // First interpolation coefficient + rowView(jnode, iz) = cz; + colView(jnode, iz) = jz; + SView(jnode, iz) = (vcConst[cz+1]-vcView(jnode, jz))/(vcConst[cz+1]-vcConst[cz]); + ++iz; + + // Second interpolation coefficient + rowView(jnode, iz) = cz+1; + colView(jnode, iz) = jz; + SView(jnode, iz) = (vcView(jnode, jz)-vcConst[cz])/(vcConst[cz+1]-vcConst[cz]); + ++iz; + } + } + } + + oops::Log::trace() << classname() << "::OrographicInterp done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void OrographicInterp::multiply(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::multiply starting" << std::endl; + + for (const auto & var : interpVars_) { + // Get vertical coordinate name + const std::string vcName = params_.fieldsMetaData.value().getString(var.name() + ".vert_coord"); + + // Get number of levels + const size_t nz = var.getLevels(); + + // Get field + auto field = fset[var.name()]; + + // Get views + const auto rowView = make_view(interpFset_[vcName + "_row"]); + const auto colView = make_view(interpFset_[vcName + "_col"]); + const auto SView = make_view(interpFset_[vcName + "_S"]); + auto view = make_view(field); + + for (int jnode = 0; jnode < field.shape(0); ++jnode) { + // Copy input profile and apply weight + std::vector profile(nz); + for (size_t jz = 0; jz < nz; ++jz) { + profile[jz] = view(jnode, jz); + view(jnode, jz) *= 1.0-params_.orographicFactor.value(); + } + + // Apply interpolation + for (size_t iz = 0; iz < 2*nz; ++iz) { + view(jnode, colView(jnode, iz)) += params_.orographicFactor.value()* + profile[rowView(jnode, iz)]*SView(jnode, iz); + } + } + } + + oops::Log::trace() << classname() << "::multiply done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void OrographicInterp::multiplyAD(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; + + for (const auto & var : interpVars_) { + // Get vertical coordinate name + const std::string vcName = params_.fieldsMetaData.value().getString(var.name() + ".vert_coord"); + + // Get number of levels + const size_t nz = var.getLevels(); + + // Get fields + auto field = fset[var.name()]; + + // Get field view + auto view = make_view(field); + + // Get interpolation + const auto rowView = make_view(interpFset_[vcName + "_row"]); + const auto colView = make_view(interpFset_[vcName + "_col"]); + const auto SView = make_view(interpFset_[vcName + "_S"]); + + for (int jnode = 0; jnode < field.shape(0); ++jnode) { + // Copy input profile and apply weight + std::vector profile(nz); + for (size_t jz = 0; jz < nz; ++jz) { + profile[jz] = view(jnode, jz); + view(jnode, jz) *= 1.0-params_.orographicFactor.value(); + } + + // Apply interpolation + for (size_t iz = 0; iz < 2*nz; ++iz) { + view(jnode, rowView(jnode, iz)) += params_.orographicFactor.value()* + profile[colView(jnode, iz)]*SView(jnode, iz); + } + } + } + + oops::Log::trace() << classname() << "::multiplyAD done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void OrographicInterp::print(std::ostream & os) const { + os << classname(); +} + +// ----------------------------------------------------------------------------- + +} // namespace generic +} // namespace saber diff --git a/src/saber/generic/OrographicInterp.h b/src/saber/generic/OrographicInterp.h new file mode 100644 index 000000000..ea1bd053b --- /dev/null +++ b/src/saber/generic/OrographicInterp.h @@ -0,0 +1,90 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#pragma once + +#include +#include +#include +#include + +#include "atlas/field.h" + +#include "oops/base/GeometryData.h" +#include "oops/base/Variables.h" +#include "oops/util/parameters/Parameters.h" + +#include "saber/blocks/SaberBlockParametersBase.h" +#include "saber/blocks/SaberOuterBlockBase.h" + +namespace saber { +namespace generic { + +// ----------------------------------------------------------------------------- + +class OrographicInterpParameters : public SaberBlockParametersBase { + OOPS_CONCRETE_PARAMETERS(OrographicInterpParameters, SaberBlockParametersBase) + + public: + // Orographic factor + oops::Parameter orographicFactor{"orographic factor", 1.0, this}; + + oops::Variables mandatoryActiveVars() const override {return oops::Variables();} +}; + +// ----------------------------------------------------------------------------- + +class OrographicInterp : public SaberOuterBlockBase { + public: + static const std::string classname() + {return "saber::generic::OrographicInterp";} + + typedef OrographicInterpParameters Parameters_; + + OrographicInterp(const oops::GeometryData &, + const oops::Variables &, + const eckit::Configuration &, + const Parameters_ &, + const oops::FieldSet3D &, + const oops::FieldSet3D &); + virtual ~OrographicInterp() = default; + + const oops::GeometryData & innerGeometryData() const override + {return innerGeometryData_;} + const oops::Variables & innerVars() const override + {return innerVars_;} + + void multiply(oops::FieldSet3D &) const override; + void multiplyAD(oops::FieldSet3D &) const override; + + private: + // Inner geometry data + const oops::GeometryData & innerGeometryData_; + + // Communicator + const eckit::mpi::Comm & comm_; + + // Inner variables + const oops::Variables & innerVars_; + + // Parameters + OrographicInterpParameters params_; + + // Interpolated variables + oops::Variables interpVars_; + + // Interpolation FieldSet + atlas::FieldSet interpFset_; + + // Private methods + + // Print + void print(std::ostream &) const override; +}; + +// ----------------------------------------------------------------------------- + +} // namespace generic +} // namespace saber diff --git a/test/testdeps/dirac_orographic_interp.txt b/test/testdeps/dirac_orographic_interp.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/testinput/dirac_orographic_interp.yaml b/test/testinput/dirac_orographic_interp.yaml new file mode 100644 index 000000000..962602300 --- /dev/null +++ b/test/testinput/dirac_orographic_interp.yaml @@ -0,0 +1,73 @@ +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_temperature_1 + - air_temperature_2 + levels: 10 + vertical coordinate: + name: air_pressure + variable: air_pressure + filepath: testdata/orographic_interp + latitude south to north: false +background: + date: 2010-01-01T12:00:00Z + state variables: + - air_temperature_1 + - air_temperature_2 +background error: + covariance model: SABER + saber central block: + saber block name: FastLAM + calibration: + multivariate strategy: univariate + groups: + - group name: var3d + variables: [air_temperature_1,air_temperature_2] + horizontal length-scale: + - group: var3d + value: 200.0e3 + vertical length-scale: + - group: var3d + value: 3.0 + number of layers: 1 + resolution: 8 + skip tests: true + saber outer blocks: + - saber block name: OrographicInterp + fields metadata: + air_temperature_1: + vert_coord: air_pressure + air_temperature_2: + vert_coord: air_pressure +dirac: + lon: + - 8.5 + - 11.0 + lat: + - 56.0 + - 56.5 + level: + - 10 + - 10 + variable: + - air_temperature_1 + - air_temperature_2 +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/dirac_orographic_interp/%MPI%_dirac_%id% +test: + reference filename: testref/dirac_orographic_interp.ref diff --git a/test/testlist/saber_data.txt b/test/testlist/saber_data.txt index 9d8c1fac7..3085042d3 100644 --- a/test/testlist/saber_data.txt +++ b/test/testlist/saber_data.txt @@ -20,3 +20,4 @@ Prho_bar_Mean.nc dirac_mgbf_reg_1.nml bifourier_balance.nc bifourier_covariance.nc +orographic_interp.nc diff --git a/test/testlist/saber_test_tier1.txt b/test/testlist/saber_test_tier1.txt index b14b74edb..af4344292 100644 --- a/test/testlist/saber_test_tier1.txt +++ b/test/testlist/saber_test_tier1.txt @@ -10,6 +10,7 @@ dirac_interpolation_2 dirac_interpolation_3 dirac_interpolation_4 dirac_interpolation_5 +dirac_orographic_interp dirac_duplicate_variables error_covariance_training_diffusion_1 error_covariance_training_diffusion_2 diff --git a/test/testref/dirac_orographic_interp.ref b/test/testref/dirac_orographic_interp.ref new file mode 100644 index 000000000..00c76a37c --- /dev/null +++ b/test/testref/dirac_orographic_interp.ref @@ -0,0 +1,28 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_temperature_1 (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088794610e-03 + - air_temperature_2 (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088792225e-03 +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_temperature_1 (10 levels): + + min = 0.0000000000000000e+00 + + max = 8.6072655542923038e-01 + + mean = 4.7171099299428379e-02 + + stddev = 1.2837275717988653e-01 + - air_temperature_2 (10 levels): + + min = 0.0000000000000000e+00 + + max = 8.7630963195777267e-01 + + mean = 1.4675619737742882e-01 + + stddev = 2.1394732531682789e-01 From b62bd46ce7b5d8137c6841099ea592bfa2c2ee36 Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Wed, 3 Dec 2025 16:05:34 +0100 Subject: [PATCH 136/199] Bifourier block FFT backend and calibration (#1060) * Fix quench geometry reader * Add option to run write() in read mode * Add Biperiodization block * Add tests * WIP * Fixes * Simplified tests * Cleaning * Split Fields read/write * Fix indentation * Fix level * Option to read vorToPb factor * Cleaner vertical coordinate setup * WIP * Clean Geometry * Fix * Fixes * Reset * Wind bugfix * Read surface altitude * Correct handling of reduced wind, externalize biperiodization * Fix trace * Externalize biperiodization * Harmonizing parameters * Cleaner parameters * Remove Trace for addBiperElement * Improved BifourierRedWindToGeoWind * Move Biperiodization to bifourier directory * Save memory in gp2sp and sp2gp * Remove useless copy of inactive fields * Fix Arome reader * Bugfix for custom outer partitioner * Bugfix for biperiodization inner geometry * Bugfix: log_of_air_pressure_at_surface instead of air_pressure_at_surface * Separable covariance in progress * Separable form code done * Simplification * Fixes * Fix tests * Merge with develop * Add info * Cleaning * Cosmetic cleaning * Improve testing, fix mean wind * Mean wind improvement * WIP * Simplification + addition of dy * Fix * WIP * Calibration working * Simplify source and tests * Update according to Marek's comments * Typo * New balance setup * Upgrade block chains * WIP * Correct transform of ensemble members * Fix coding norms * Big cleaning * Cleaning * Fix yaml * WIP * Cosmetic cleaning * Fix and tests for old covariances updating * Simplify balance * Fixes * Attempt to address Marek's comments * WIP * ECTRANS backend working * Clean factories * Cleaning * Cleaning * Reset to develop * Updating StdDev to read a profile from file, removing BifourierStdDev * Generic dot product * All tests passing * Fix coding norms + remove spectral dot product * Fix ref * Rename s_to_sGlb * Remove AromeLegacy class * WIP * All tests passing * WIP * WIP * Fix variables order for ECTRANS backend * All tests passing * Clean covariance communications * WIP * All tests passing with AROME I/O * Fix refs * Cosmetic cleaning * Add sub-ensemble option * Normalization fix + explicit covariance calibration * Introduce IO conf * Trigger tests * Add I/O configuration * Fix the sub-ensembles case * Before convergence * Same normalization as in ETRANS, calibration not done * Major fixes and cleaning * Add covariance calibration tests * Aggregated inversion in balance calibration * Fix compiler warning * Wind normalization fix * Fix truncations * Add REDNMC factor * Fix spectral norm sum inverse * Fix spectral norm sum inverse * Calibration fixes * Cleaning * Set vor/div to zero for jwGlb=0 in calibration step * trigger CI * Remove ID calibration * add jedi-ci action (#1090) Add jedi-ci action Parent issue: JCSDA-internal/jedi-ci#16 Admin merge justification: JCSDA-internal/jedi-ci#17 * Use make_indexview * Add indexview alias * Add truncation factor for non-linear grids * Propagate feature/fix_bifourier_fft_leaks fix * Add const for spectral transform members --------- Co-authored-by: Marek Wlasak Co-authored-by: Nate Crossette Co-authored-by: Evan Parker --- CMakeLists.txt | 14 +- src/saber/CMakeLists.txt | 9 +- src/saber/bifourier/BifourierAromeBalance.cc | 856 +++++++ src/saber/bifourier/BifourierAromeBalance.h | 159 ++ .../bifourier/BifourierAromeCovariance.cc | 328 +++ .../bifourier/BifourierAromeCovariance.h | 89 + src/saber/bifourier/BifourierAromeLegacy.cc | 718 ------ src/saber/bifourier/BifourierAromeLegacy.h | 52 - src/saber/bifourier/BifourierBalance.cc | 1200 ++++++++-- src/saber/bifourier/BifourierBalance.h | 80 +- src/saber/bifourier/BifourierCovariance.cc | 1068 +++++++-- src/saber/bifourier/BifourierCovariance.h | 96 +- .../bifourier/BifourierGridToSpectral.cc | 4 +- src/saber/bifourier/BifourierGridToSpectral.h | 3 +- src/saber/bifourier/BifourierID.cc | 9 +- src/saber/bifourier/BifourierID.h | 4 +- .../bifourier/BifourierSpectralToGrid.cc | 10 +- src/saber/bifourier/BifourierSpectralToGrid.h | 14 +- .../BifourierSpectralVorDivToGridWind.cc | 829 +++++++ .../BifourierSpectralVorDivToGridWind.h | 151 ++ src/saber/bifourier/BifourierSplitTPs.cc | 191 -- src/saber/bifourier/BifourierSplitTPs.h | 104 - src/saber/bifourier/BifourierTransform.cc | 1882 --------------- src/saber/bifourier/BifourierTransformBase.cc | 2109 +++++++++++++++++ ...erTransform.h => BifourierTransformBase.h} | 311 ++- .../bifourier/BifourierTransformECTRANS.cc | 982 ++++++++ .../bifourier/BifourierTransformECTRANS.h | 91 + src/saber/bifourier/BifourierTransformFFTW.cc | 680 ++++++ src/saber/bifourier/BifourierTransformFFTW.h | 125 + .../bifourier/BifourierTransformStore.cc | 19 +- src/saber/bifourier/BifourierTransformStore.h | 12 +- .../bifourier/BifourierVorDivToRedWind.cc | 344 --- .../bifourier/BifourierVorDivToRedWind.h | 117 - src/saber/bifourier/BifourierVorToPb.cc | 360 --- src/saber/bifourier/BifourierVorToPb.h | 126 - src/saber/bifourier/BiperiodizationImpl.cc | 3 +- src/saber/bifourier/CMakeLists.txt | 53 +- src/saber/bifourier/RedWindToGeoWind.h | 108 - src/saber/bifourier/bifourier_arome_legacy.h | 63 +- .../bifourier_arome_legacy_interface.F90 | 83 +- .../bifourier/bifourier_arome_legacy_mod.F90 | 521 ++-- src/saber/generic/ID.h | 3 - test/CMakeLists.txt | 12 +- ...txt => convertcov_bifourier_balance_1.txt} | 0 .../convertcov_bifourier_balance_2.txt | 1 + .../convertcov_bifourier_balance_3.txt | 1 + ... => convertcov_bifourier_covariance_1.txt} | 0 .../convertcov_bifourier_covariance_2.txt | 1 + .../convertcov_bifourier_covariance_3.txt | 1 + ...urier_splittps.txt => dirac_bifourier.txt} | 0 test/testdeps/dirac_bifourier_balance_1.txt | 1 - test/testdeps/dirac_bifourier_balance_2.txt | 1 - test/testdeps/dirac_bifourier_balance_3.txt | 0 .../testdeps/dirac_bifourier_covariance_1.txt | 1 - .../testdeps/dirac_bifourier_covariance_2.txt | 1 - .../testdeps/dirac_bifourier_covariance_3.txt | 1 - test/testdeps/dirac_bifourier_ectrans.txt | 0 .../dirac_bifourier_full_spectral.txt | 2 - .../dirac_bifourier_vordivtouv_ectrans_1.txt | 0 .../dirac_bifourier_vordivtouv_ectrans_2.txt | 0 .../error_covariance_training_bifourier_1.txt | 1 + .../error_covariance_training_bifourier_2.txt | 1 + .../error_covariance_training_bifourier_3.txt | 1 + .../error_covariance_training_bifourier_4.txt | 2 + .../error_covariance_training_bifourier_5.txt | 1 + .../error_covariance_training_bifourier_6.txt | 1 + .../error_covariance_training_bifourier_7.txt | 1 + .../error_covariance_training_bifourier_8.txt | 0 ...riance_training_bifourier_covariance_1.txt | 1 + ...riance_training_bifourier_covariance_2.txt | 1 + ...ovariance_training_bifourier_ectrans_1.txt | 1 + test/testdeps/randomization_bifourier.txt | 0 .../randomization_bifourier_covariance.txt | 0 ...ml => convertcov_bifourier_balance_1.yaml} | 39 +- .../convertcov_bifourier_balance_2.yaml | 92 + .../convertcov_bifourier_balance_3.yaml | 91 + ...=> convertcov_bifourier_covariance_1.yaml} | 12 +- .../convertcov_bifourier_covariance_2.yaml | 73 + .../convertcov_bifourier_covariance_3.yaml | 73 + ...ull_spectral.yaml => dirac_bifourier.yaml} | 44 +- test/testinput/dirac_bifourier_balance_1.yaml | 30 +- test/testinput/dirac_bifourier_balance_2.yaml | 47 +- test/testinput/dirac_bifourier_balance_3.yaml | 95 + .../dirac_bifourier_covariance_1.yaml | 4 +- .../dirac_bifourier_covariance_2.yaml | 6 +- .../dirac_bifourier_covariance_3.yaml | 6 +- test/testinput/dirac_bifourier_ectrans.yaml | 100 + .../dirac_bifourier_gridtospectral.yaml | 4 +- .../dirac_bifourier_vordivtouv_1.yaml | 24 +- .../dirac_bifourier_vordivtouv_2.yaml | 13 +- .../dirac_bifourier_vordivtouv_3.yaml | 12 +- .../dirac_bifourier_vordivtouv_ectrans_1.yaml | 55 + .../dirac_bifourier_vordivtouv_ectrans_2.yaml | 70 + ...error_covariance_training_bifourier_1.yaml | 113 + ...error_covariance_training_bifourier_2.yaml | 114 + ...error_covariance_training_bifourier_3.yaml | 115 + ...error_covariance_training_bifourier_4.yaml | 120 + ...error_covariance_training_bifourier_5.yaml | 116 + ...error_covariance_training_bifourier_6.yaml | 115 + ...error_covariance_training_bifourier_7.yaml | 116 + ...rror_covariance_training_bifourier_8.yaml} | 33 +- ...iance_training_bifourier_covariance_1.yaml | 86 + ...iance_training_bifourier_covariance_2.yaml | 88 + ...variance_training_bifourier_ectrans_1.yaml | 115 + ...error_covariance_training_bump_vbal_1.yaml | 1 - test/testinput/randomization_bifourier.yaml | 88 + .../randomization_bifourier_covariance.yaml | 62 + .../saber_test_tier1-bifourier-ectrans.txt | 4 + test/testlist/saber_test_tier1-bifourier.txt | 24 +- .../convertcov_bifourier_balance_1.ref | 77 + .../convertcov_bifourier_balance_2.ref | 84 + .../convertcov_bifourier_balance_3.ref | 84 + ... => convertcov_bifourier_covariance_1.ref} | 45 +- .../convertcov_bifourier_covariance_2.ref | 77 + .../convertcov_bifourier_covariance_3.ref | 77 + ..._full_spectral.ref => dirac_bifourier.ref} | 66 +- test/testref/dirac_bifourier_balance_1.ref | 69 +- test/testref/dirac_bifourier_balance_2.ref | 89 +- test/testref/dirac_bifourier_balance_3.ref | 86 + test/testref/dirac_bifourier_covariance_1.ref | 39 +- test/testref/dirac_bifourier_covariance_2.ref | 43 +- test/testref/dirac_bifourier_covariance_3.ref | 49 +- test/testref/dirac_bifourier_ectrans.ref | 77 + .../dirac_bifourier_gridtospectral.ref | 33 +- test/testref/dirac_bifourier_splittps.ref | 47 - test/testref/dirac_bifourier_vordivtouv_1.ref | 40 +- test/testref/dirac_bifourier_vordivtouv_2.ref | 36 +- test/testref/dirac_bifourier_vordivtouv_3.ref | 44 +- .../dirac_bifourier_vordivtouv_ectrans_1.ref | 47 + .../dirac_bifourier_vordivtouv_ectrans_2.ref | 48 + .../error_covariance_training_bifourier_1.ref | 94 + .../error_covariance_training_bifourier_2.ref | 94 + .../error_covariance_training_bifourier_3.ref | 94 + .../error_covariance_training_bifourier_4.ref | 94 + .../error_covariance_training_bifourier_5.ref | 94 + .../error_covariance_training_bifourier_6.ref | 94 + .../error_covariance_training_bifourier_7.ref | 94 + .../error_covariance_training_bifourier_8.ref | 40 + ...riance_training_bifourier_covariance_1.ref | 70 + ...riance_training_bifourier_covariance_2.ref | 70 + ...ovariance_training_bifourier_ectrans_1.ref | 94 + test/testref/randomization_bifourier.ref | 749 ++++++ .../randomization_bifourier_covariance.ref | 621 +++++ 143 files changed, 14593 insertions(+), 5180 deletions(-) create mode 100644 src/saber/bifourier/BifourierAromeBalance.cc create mode 100644 src/saber/bifourier/BifourierAromeBalance.h create mode 100644 src/saber/bifourier/BifourierAromeCovariance.cc create mode 100644 src/saber/bifourier/BifourierAromeCovariance.h delete mode 100644 src/saber/bifourier/BifourierAromeLegacy.cc delete mode 100644 src/saber/bifourier/BifourierAromeLegacy.h create mode 100644 src/saber/bifourier/BifourierSpectralVorDivToGridWind.cc create mode 100644 src/saber/bifourier/BifourierSpectralVorDivToGridWind.h delete mode 100644 src/saber/bifourier/BifourierSplitTPs.cc delete mode 100644 src/saber/bifourier/BifourierSplitTPs.h delete mode 100644 src/saber/bifourier/BifourierTransform.cc create mode 100644 src/saber/bifourier/BifourierTransformBase.cc rename src/saber/bifourier/{BifourierTransform.h => BifourierTransformBase.h} (50%) create mode 100644 src/saber/bifourier/BifourierTransformECTRANS.cc create mode 100644 src/saber/bifourier/BifourierTransformECTRANS.h create mode 100644 src/saber/bifourier/BifourierTransformFFTW.cc create mode 100644 src/saber/bifourier/BifourierTransformFFTW.h delete mode 100644 src/saber/bifourier/BifourierVorDivToRedWind.cc delete mode 100644 src/saber/bifourier/BifourierVorDivToRedWind.h delete mode 100644 src/saber/bifourier/BifourierVorToPb.cc delete mode 100644 src/saber/bifourier/BifourierVorToPb.h delete mode 100644 src/saber/bifourier/RedWindToGeoWind.h rename test/testdeps/{convertcov_bifourier_balance.txt => convertcov_bifourier_balance_1.txt} (100%) create mode 100644 test/testdeps/convertcov_bifourier_balance_2.txt create mode 100644 test/testdeps/convertcov_bifourier_balance_3.txt rename test/testdeps/{convertcov_bifourier_covariance.txt => convertcov_bifourier_covariance_1.txt} (100%) create mode 100644 test/testdeps/convertcov_bifourier_covariance_2.txt create mode 100644 test/testdeps/convertcov_bifourier_covariance_3.txt rename test/testdeps/{dirac_bifourier_splittps.txt => dirac_bifourier.txt} (100%) create mode 100644 test/testdeps/dirac_bifourier_balance_3.txt create mode 100644 test/testdeps/dirac_bifourier_ectrans.txt delete mode 100644 test/testdeps/dirac_bifourier_full_spectral.txt create mode 100644 test/testdeps/dirac_bifourier_vordivtouv_ectrans_1.txt create mode 100644 test/testdeps/dirac_bifourier_vordivtouv_ectrans_2.txt create mode 100644 test/testdeps/error_covariance_training_bifourier_1.txt create mode 100644 test/testdeps/error_covariance_training_bifourier_2.txt create mode 100644 test/testdeps/error_covariance_training_bifourier_3.txt create mode 100644 test/testdeps/error_covariance_training_bifourier_4.txt create mode 100644 test/testdeps/error_covariance_training_bifourier_5.txt create mode 100644 test/testdeps/error_covariance_training_bifourier_6.txt create mode 100644 test/testdeps/error_covariance_training_bifourier_7.txt create mode 100644 test/testdeps/error_covariance_training_bifourier_8.txt create mode 100644 test/testdeps/error_covariance_training_bifourier_covariance_1.txt create mode 100644 test/testdeps/error_covariance_training_bifourier_covariance_2.txt create mode 100644 test/testdeps/error_covariance_training_bifourier_ectrans_1.txt create mode 100644 test/testdeps/randomization_bifourier.txt create mode 100644 test/testdeps/randomization_bifourier_covariance.txt rename test/testinput/{convertcov_bifourier_balance.yaml => convertcov_bifourier_balance_1.yaml} (71%) create mode 100644 test/testinput/convertcov_bifourier_balance_2.yaml create mode 100644 test/testinput/convertcov_bifourier_balance_3.yaml rename test/testinput/{convertcov_bifourier_covariance.yaml => convertcov_bifourier_covariance_1.yaml} (81%) create mode 100644 test/testinput/convertcov_bifourier_covariance_2.yaml create mode 100644 test/testinput/convertcov_bifourier_covariance_3.yaml rename test/testinput/{dirac_bifourier_full_spectral.yaml => dirac_bifourier.yaml} (66%) create mode 100644 test/testinput/dirac_bifourier_balance_3.yaml create mode 100644 test/testinput/dirac_bifourier_ectrans.yaml create mode 100644 test/testinput/dirac_bifourier_vordivtouv_ectrans_1.yaml create mode 100644 test/testinput/dirac_bifourier_vordivtouv_ectrans_2.yaml create mode 100644 test/testinput/error_covariance_training_bifourier_1.yaml create mode 100644 test/testinput/error_covariance_training_bifourier_2.yaml create mode 100644 test/testinput/error_covariance_training_bifourier_3.yaml create mode 100644 test/testinput/error_covariance_training_bifourier_4.yaml create mode 100644 test/testinput/error_covariance_training_bifourier_5.yaml create mode 100644 test/testinput/error_covariance_training_bifourier_6.yaml create mode 100644 test/testinput/error_covariance_training_bifourier_7.yaml rename test/testinput/{dirac_bifourier_splittps.yaml => error_covariance_training_bifourier_8.yaml} (53%) create mode 100644 test/testinput/error_covariance_training_bifourier_covariance_1.yaml create mode 100644 test/testinput/error_covariance_training_bifourier_covariance_2.yaml create mode 100644 test/testinput/error_covariance_training_bifourier_ectrans_1.yaml create mode 100644 test/testinput/randomization_bifourier.yaml create mode 100644 test/testinput/randomization_bifourier_covariance.yaml create mode 100644 test/testlist/saber_test_tier1-bifourier-ectrans.txt create mode 100644 test/testref/convertcov_bifourier_balance_1.ref create mode 100644 test/testref/convertcov_bifourier_balance_2.ref create mode 100644 test/testref/convertcov_bifourier_balance_3.ref rename test/testref/{convertcov_bifourier_covariance.ref => convertcov_bifourier_covariance_1.ref} (64%) create mode 100644 test/testref/convertcov_bifourier_covariance_2.ref create mode 100644 test/testref/convertcov_bifourier_covariance_3.ref rename test/testref/{dirac_bifourier_full_spectral.ref => dirac_bifourier.ref} (54%) create mode 100644 test/testref/dirac_bifourier_balance_3.ref create mode 100644 test/testref/dirac_bifourier_ectrans.ref delete mode 100644 test/testref/dirac_bifourier_splittps.ref create mode 100644 test/testref/dirac_bifourier_vordivtouv_ectrans_1.ref create mode 100644 test/testref/dirac_bifourier_vordivtouv_ectrans_2.ref create mode 100644 test/testref/error_covariance_training_bifourier_1.ref create mode 100644 test/testref/error_covariance_training_bifourier_2.ref create mode 100644 test/testref/error_covariance_training_bifourier_3.ref create mode 100644 test/testref/error_covariance_training_bifourier_4.ref create mode 100644 test/testref/error_covariance_training_bifourier_5.ref create mode 100644 test/testref/error_covariance_training_bifourier_6.ref create mode 100644 test/testref/error_covariance_training_bifourier_7.ref create mode 100644 test/testref/error_covariance_training_bifourier_8.ref create mode 100644 test/testref/error_covariance_training_bifourier_covariance_1.ref create mode 100644 test/testref/error_covariance_training_bifourier_covariance_2.ref create mode 100644 test/testref/error_covariance_training_bifourier_ectrans_1.ref create mode 100644 test/testref/randomization_bifourier.ref create mode 100644 test/testref/randomization_bifourier_covariance.ref diff --git a/CMakeLists.txt b/CMakeLists.txt index c9db951f2..c74bd3018 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -83,6 +83,7 @@ find_package( oops 1.10.0 REQUIRED ) find_package( vader 1.7.0 REQUIRED ) # Optionals +find_package( ECTRANS 1.6.0 COMPONENTS transi double QUIET ) # TODO(Benjamin): update tag once the ectrans PR is merged and a new tag is created find_package( FFTW 3.3.8 QUIET ) find_package( gsibec 1.3.2 QUIET ) find_package( eccodes 2.24 QUIET ) @@ -92,17 +93,22 @@ if( eccodes_FOUND ) endif() # Optional SABER blocks -if( gsibec_FOUND ) - find_package( sp QUIET ) - message( STATUS "SABER block GSI is enabled" ) +if( FFTW_FOUND OR ( ECTRANS_FOUND AND ectrans_HAVE_ETRANS AND ectrans_HAVE_TRANSI ) ) + message( STATUS "SABER block Bifourier is enabled" ) else() - message( STATUS "SABER block GSI is NOT enabled" ) + message( STATUS "SABER block Bifourier is NOT enabled" ) endif() if( FFTW_FOUND ) message( STATUS "SABER block FastLAM spectral layer is enabled" ) else() message( STATUS "SABER block FastLAM spectral layer is NOT enabled" ) endif() +if( gsibec_FOUND ) + find_package( sp QUIET ) + message( STATUS "SABER block GSI is enabled" ) +else() + message( STATUS "SABER block GSI is NOT enabled" ) +endif() if( atlas_TRANS_FOUND OR atlas_ECTRANS_FOUND ) message( STATUS "SABER block SPECTRALB is enabled" ) else() diff --git a/src/saber/CMakeLists.txt b/src/saber/CMakeLists.txt index ed7836b47..dcc0a409a 100644 --- a/src/saber/CMakeLists.txt +++ b/src/saber/CMakeLists.txt @@ -31,6 +31,12 @@ target_link_libraries( ${PROJECT_NAME} PUBLIC atlas_f ) target_link_libraries( ${PROJECT_NAME} PUBLIC ${oops_LIBRARIES} ) target_link_libraries( ${PROJECT_NAME} PUBLIC vader ) +if( ECTRANS_FOUND AND ectrans_HAVE_ETRANS AND ectrans_HAVE_TRANSI ) + target_link_libraries( ${PROJECT_NAME} PUBLIC transi ) +endif() +if( FFTW_FOUND ) + target_link_libraries( ${PROJECT_NAME} PUBLIC FFTW::fftw3 ) +endif() if( gsibec_FOUND ) target_link_libraries( ${PROJECT_NAME} PUBLIC gsibec ) target_compile_definitions( ${PROJECT_NAME} PUBLIC GSIBEC_FOUND ) @@ -42,9 +48,6 @@ if( MGBFLIB_FOUND EQUAL 9999 ) target_link_libraries( ${PROJECT_NAME} PUBLIC mgbf_lib ) target_compile_definitions( ${PROJECT_NAME} PUBLIC MGBF_FOUND) endif() -if( FFTW_FOUND ) - target_link_libraries( ${PROJECT_NAME} PUBLIC FFTW::fftw3 ) -endif() if ( ENABLE_OFFLINE_CODECOV ) target_link_libraries( ${PROJECT_NAME} PUBLIC gcov ) endif() diff --git a/src/saber/bifourier/BifourierAromeBalance.cc b/src/saber/bifourier/BifourierAromeBalance.cc new file mode 100644 index 000000000..93e6e8dac --- /dev/null +++ b/src/saber/bifourier/BifourierAromeBalance.cc @@ -0,0 +1,856 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#include "saber/bifourier/BifourierAromeBalance.h" + +#include + +#include + +#include "saber/bifourier/bifourier_arome_legacy.h" +#include "saber/bifourier/BifourierUtilities.h" + +#define ERR(e, msg) {std::string s(nc_strerror(e)); \ + throw eckit::Exception(s + " : " + msg, Here());} + +using atlas::array::make_datatype; +using atlas::array::make_shape; +using atlas::array::make_view; + +namespace saber { +namespace bifourier { + +// ----------------------------------------------------------------------------- + +static SaberOuterBlockMaker + makerBifourierAromeBalance_("BifourierAromeBalance"); + +// ----------------------------------------------------------------------------- + +BifourierAromeBalance::BifourierAromeBalance(const oops::GeometryData & outerGeometryData, + const oops::Variables & outerVars, + const eckit::Configuration & covarConfig, + const Parameters_ & params, + const oops::FieldSet3D & xb, + const oops::FieldSet3D & fg) + : BifourierBalance(outerGeometryData, genericInnerVars(outerVars), covarConfig, params, xb, fg), + params_(params), + aromeInnerVars_(innerVars_) +{ + oops::Log::trace() << classname() << "::BifourierAromeBalance starting" << std::endl; + + // Check balanced air pressure source + ASSERT((params_.explicitPb.value() != boost::none) || params_.pbFromTrans.value() + || params_.read.value()); + + if ((params_.explicitPb.value() != boost::none) || params_.pbFromTrans.value()) { + // Get change of variable parameters from configuration or from spectral transform + const auto & explicitPb = params_.explicitPb.value(); + const size_t M = (explicitPb != boost::none) ? explicitPb->M.value() : trans_->M(); + const size_t N = (explicitPb != boost::none) ? explicitPb->N.value() : trans_->N(); + const double meanLat = (explicitPb != boost::none) ? explicitPb->meanLat.value() + : trans_->meanLat(); + + // Allocate fact1 + fact1_.resize(trans_->ns()); + + // Compute change of variable factor + const size_t nwGlb = std::max(M, N)+1; + const double zromega = 0.7292115e-4; + const double zcc = -2.0*zromega*std::sin(meanLat*M_PI/180.0); + const double zly = 2.0*static_cast(nwGlb)*trans_->dy(); + const double zfact1 = zcc*(zly/(2.0*M_PI))*(zly/(2.0*M_PI)); + for (size_t js = 0; js < trans_->ns(); ++js) { + const double kstar = trans_->rkstar(trans_->jk(js), trans_->jl(js), M, N, nwGlb); + if (kstar > 0.0) { + fact1_[js] = zfact1/(kstar*kstar); + } else { + fact1_[js] = 0.0; + } + } + } + + // Remove balanced pressure from inner variables + aromeInnerVars_ -= aromeInnerVars_["balanced_air_pressure"]; + + oops::Log::trace() << classname() << "::BifourierAromeBalance done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::multiply(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::multiply starting" << std::endl; + + // Vorticity to balanced pressure + vorToPb(fset); + + // Generic balance + BifourierBalance::multiply(fset); + + // Remove balanced pressure + removePb(fset); + + // Split TPs + splitTPs(fset); + + oops::Log::trace() << classname() << "::multiply done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::multiplyAD(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; + + // Split TPs, adjoint + gatherTPs(fset); + + // Remove balanced pressure, adjoint + removePbAD(fset); + + // Generic balance, adjoint + BifourierBalance::multiplyAD(fset); + + // Vorticity to balanced pressure, adjoint + vorToPbAD(fset); + + oops::Log::trace() << classname() << "::multiplyAD done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::leftInverseMultiply(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::leftInverseMultiply starting" << std::endl; + + // Split TPs, left inverse + gatherTPs(fset); + + // Remove balanced pressure, left inverse + removePbLeftInverse(fset); + + // Generic balance, left inverse + BifourierBalance::leftInverseMultiply(fset); + + // Vorticity to balanced pressure, left inverse + vorToPbLeftInverse(fset); + + oops::Log::trace() << classname() << "::leftInverseMultiply done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::read() { + oops::Log::trace() << classname() << "::read starting" << std::endl; + + // Allocate fact1 + std::vector fact1FromFile(trans_->ns()); + + // Read data + if (params_.read.value()->inputFileFormat.value() == "arome legacy binary" + || params_.read.value()->inputFileFormat.value() == "arome legacy netcdf") { + for (const auto & row : params_.rows.value()) { + // Get output variable + const oops::Variable outputVar = balVars_[row.outputVar.value()]; + for (const auto & inputVarName : row.inputVars.value()) { + // Get input variable + const oops::Variable inputVar = balVars_[inputVarName]; + + // Create regression field + createField3D("reg", trans_->nw(), outputVar, inputVar, data_); + } + } + + // Define global vectors + std::vector sDivPbGlb; + std::vector sTpsPbGlb; + std::vector sTpsDivuGlb; + std::vector sQPbGlb; + std::vector sQDivuGlb; + std::vector sQTpsuGlb; + + // Define global IAL size + size_t nial = 0; + for (size_t jm = 0; jm < trans_->ellips().size(); ++jm) { + nial += 4*(trans_->ellips()[jm]+1); + } + + // Fact1 IAL vector + std::vector fact1IAL(nial); + + if (comm_.rank() == 0) { + // Allocate global vectors + sDivPbGlb.resize(trans_->nwGlb()*nz_*nz_); + sTpsPbGlb.resize(trans_->nwGlb()*nz_*(nz_+1)); + sTpsDivuGlb.resize(trans_->nwGlb()*nz_*(nz_+1)); + sQPbGlb.resize(trans_->nwGlb()*nz_*nz_); + sQDivuGlb.resize(trans_->nwGlb()*nz_*nz_); + sQTpsuGlb.resize(trans_->nwGlb()*(nz_+1)*nz_); + + if (params_.read.value()->inputFileFormat.value() == "arome legacy binary") { + // Read Fortran unformatted file (based on readjbbal.F90) + bifourier_arome_legacy_read_balance_f90(params_.read.value()->toConfiguration(), + trans_->nwGlb(), nz_, sDivPbGlb.data(), sTpsPbGlb.data(), sTpsDivuGlb.data(), + sQPbGlb.data(), sQDivuGlb.data(), sQTpsuGlb.data(), nial, fact1IAL.data()); + } else if (params_.read.value()->inputFileFormat.value() == "arome legacy netcdf") { + // NetCDF file path + const std::string ncFilePath = params_.read.value()->inputFile.value(); + + // NetCDF IDs + int ncId, retval, dimId, varId; + size_t nzFromFile, nwGlbFromFile, nialFromFile; + + // Open NetCDF file + if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncId))) ERR(retval, ncFilePath); + + // Check dimensions + if ((retval = nc_inq_dimid(ncId, "NFLEV", &dimId))) ERR(retval, "NFLEV"); + if ((retval = nc_inq_dimlen(ncId, dimId, &nzFromFile))) ERR(retval, "NFLEV"); + ASSERT(nzFromFile == nz_); + if ((retval = nc_inq_dimid(ncId, "NSMAXP1", &dimId))) ERR(retval, "NSMAXP1"); + if ((retval = nc_inq_dimlen(ncId, dimId, &nwGlbFromFile))) ERR(retval, "NSMAXP1"); + ASSERT(nwGlbFromFile == trans_->nwGlb()); + if ((retval = nc_inq_dimid(ncId, "KSPEC2G", &dimId))) ERR(retval, "KSPEC2G"); + if ((retval = nc_inq_dimlen(ncId, dimId, &nialFromFile))) ERR(retval, "KSPEC2G"); + ASSERT(nialFromFile == nial); + + // Get variables + if ((retval = nc_inq_varid(ncId, "SDIV_PB", &varId))) ERR(retval, "SDIV_PB"); + if ((retval = nc_get_var_double(ncId, varId, sDivPbGlb.data()))) ERR(retval, "SDIV_PB"); + if ((retval = nc_inq_varid(ncId, "STPS_PB", &varId))) ERR(retval, "STPS_PB"); + if ((retval = nc_get_var_double(ncId, varId, sTpsPbGlb.data()))) ERR(retval, "STPS_PB"); + if ((retval = nc_inq_varid(ncId, "STPS_DIVU", &varId))) ERR(retval, "STPS_DIVU"); + if ((retval = nc_get_var_double(ncId, varId, sTpsDivuGlb.data()))) ERR(retval, "STPS_DIVU"); + if ((retval = nc_inq_varid(ncId, "SQ_PB", &varId))) ERR(retval, "SQ_PB"); + if ((retval = nc_get_var_double(ncId, varId, sQPbGlb.data()))) ERR(retval, "SQ_PB"); + if ((retval = nc_inq_varid(ncId, "SQ_DIVU", &varId))) ERR(retval, "SQ_DIVU"); + if ((retval = nc_get_var_double(ncId, varId, sQDivuGlb.data()))) ERR(retval, "SQ_DIVU"); + if ((retval = nc_inq_varid(ncId, "SQ_TPSU", &varId))) ERR(retval, "SQ_TPSU"); + if ((retval = nc_get_var_double(ncId, varId, sQTpsuGlb.data()))) ERR(retval, "SQ_TPSU"); + if ((retval = nc_inq_varid(ncId, "FACT1", &varId))) ERR(retval, "FACT1"); + if ((retval = nc_get_var_double(ncId, varId, fact1IAL.data()))) ERR(retval, "FACT1"); + + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + } + + // Get fields + auto sDivPbField = getField("reg", balVars_["air_horizontal_divergence"], + balVars_["balanced_air_pressure"], data_); + auto sTpsPbField = getField("reg", + balVars_["air_temperature_and_log_of_air_pressure_at_surface"], + balVars_["balanced_air_pressure"], data_); + auto sTpsDivuField = getField("reg", + balVars_["air_temperature_and_log_of_air_pressure_at_surface"], + balVars_["air_horizontal_divergence"], data_); + auto sQPbField = getField("reg", balVars_["water_vapor_mixing_ratio_wrt_moist_air"], + balVars_["balanced_air_pressure"], data_); + auto sQDivuField = getField("reg", balVars_["water_vapor_mixing_ratio_wrt_moist_air"], + balVars_["air_horizontal_divergence"], data_); + auto sQTpsuField = getField("reg", balVars_["water_vapor_mixing_ratio_wrt_moist_air"], + balVars_["air_temperature_and_log_of_air_pressure_at_surface"], data_); + + // Scatter vectors + trans_->scatterCov(sDivPbGlb, sDivPbField, true); + trans_->scatterCov(sTpsPbGlb, sTpsPbField, true); + trans_->scatterCov(sTpsDivuGlb, sTpsDivuField, true); + trans_->scatterCov(sQPbGlb, sQPbField, true); + trans_->scatterCov(sQDivuGlb, sQDivuField, true); + trans_->scatterCov(sQTpsuGlb, sQTpsuField, true); + + // Broadcast fact1 + oops::Log::info() << "Info : Broadcast fact1" << std::endl; + comm_.broadcast(fact1IAL.begin(), fact1IAL.end(), 0); + + // Global IAL / spectral conversion + atlas::Field IALIndexField("IALIndex", make_datatype(), + make_shape(trans_->ellips().size(), trans_->ellips()[0]+1, 4)); + auto IALIndexView = make_view(IALIndexField); + IALIndexView.assign(-1); + size_t jIAL = 0; + for (size_t jk = 0; jk < trans_->ellips().size(); ++jk) { + for (size_t jl = 0; jl <= trans_->ellips()[jk]; ++jl) { + for (size_t jq = 0; jq < 4; ++jq) { + IALIndexView(jk, jl, jq) = jIAL; + ++jIAL; + } + } + } + ASSERT(jIAL == nial); + + // Copy fact1 + for (size_t js = 0; js < trans_->ns(); ++js) { + const size_t jk = trans_->jk(js); + const size_t jl = trans_->jl(js); + const size_t jq = trans_->jq(js); + jIAL = IALIndexView(jk, jl, jq); + fact1FromFile[js] = fact1IAL[jIAL]; + } + + // Print norms + print(oops::Log::test()); + } else { + // Read generic balance + BifourierBalance::read(); + + // NetCDF file path + const std::string ncFilePath = params_.read.value()->inputFile.value(); + + // NetCDF IDs + int ncId, retval, nsGlbId, varId; + size_t nsGlbFromFile; + + // Define global vector + std::vector fact1Glb; + + if (comm_.rank() == 0) { + // Open NetCDF file + if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncId))) ERR(retval, ncFilePath); + + // Check dimension + if ((retval = nc_inq_dimid(ncId, "nsGlb", &nsGlbId))) ERR(retval, "nsGlb"); + if ((retval = nc_inq_dimlen(ncId, nsGlbId, &nsGlbFromFile))) ERR(retval, "nsGlb"); + ASSERT(nsGlbFromFile == trans_->nsGlb()); + + // Get variable ID + if ((retval = nc_inq_varid(ncId, "fact1", &varId))) ERR(retval, "fact1"); + + // Read data + std::vector fact1GlbOrdered(trans_->nsGlb()); + if ((retval = nc_get_var_double(ncId, varId, fact1GlbOrdered.data()))) ERR(retval, "fact1"); + + // Reorder data + fact1Glb.resize(trans_->nsGlb()); + for (size_t jsGlb = 0; jsGlb < trans_->nsGlb(); ++jsGlb) { + fact1Glb[jsGlb] = fact1GlbOrdered[trans_->sMapping()[jsGlb]]; + } + + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + + // Scatter vector + comm_.scatterv(fact1Glb.cbegin(), fact1Glb.cend(), trans_->sCounts(), trans_->sDispls(), + fact1FromFile.begin(), fact1FromFile.end(), 0); + } + + // Copy fact1 from file if it has not been defined in the constructor + if (!((params_.explicitPb.value() != boost::none) || params_.pbFromTrans.value())) { + // Allocate fact1 + fact1_.resize(trans_->ns()); + + // Copy fact1 + fact1_ = fact1FromFile; + } + + oops::Log::trace() << classname() << "::read done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::directCalibration(const oops::FieldSets & fsetEns) { + oops::Log::trace() << classname() << "::directCalibration starting" << std::endl; + + // Copy ensemble + auto fsetEnsCopy = fsetEns; + + for (size_t je = 0; je < fsetEnsCopy.size(); ++je) { + // Split TPs, left inverse + gatherTPs(fsetEnsCopy[je]); + + // Remove balanced pressure, left inverse + removePbLeftInverse(fsetEnsCopy[je]); + } + + // Generic balance + BifourierBalance::directCalibration(fsetEnsCopy); + + oops::Log::trace() << classname() << "::directCalibration done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::iterativeCalibrationUpdate(const oops::FieldSet3D & fset) { + oops::Log::trace() << classname() << "::iterativeCalibrationUpdate starting" << std::endl; + + // Copy fieldset + auto fsetCopy = fset; + + // Split TPs, left inverse + gatherTPs(fsetCopy); + + // Remove balanced pressure, left inverse + removePbLeftInverse(fsetCopy); + + // Generic balance + BifourierBalance::iterativeCalibrationUpdate(fsetCopy); + + oops::Log::trace() << classname() << "::iterativeCalibrationUpdate done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::write() const { + oops::Log::trace() << classname() << "::write starting" << std::endl; + + if (params_.write.value() != boost::none) { + // Write data + if (params_.write.value()->outputFileFormat.value() == "arome legacy binary" + || params_.write.value()->outputFileFormat.value() == "arome legacy netcdf") { + // Define global vectors + std::vector sDivPbGlb; + std::vector sTpsPbGlb; + std::vector sTpsDivuGlb; + std::vector sQPbGlb; + std::vector sQDivuGlb; + std::vector sQTpsuGlb; + + // Get fields + const auto sDivPbField = getField("reg", balVars_["air_horizontal_divergence"], + balVars_["balanced_air_pressure"], data_); + const auto sTpsPbField = getField("reg", + balVars_["air_temperature_and_log_of_air_pressure_at_surface"], + balVars_["balanced_air_pressure"], data_); + const auto sTpsDivuField = getField("reg", + balVars_["air_temperature_and_log_of_air_pressure_at_surface"], + balVars_["air_horizontal_divergence"], data_); + const auto sQPbField = getField("reg", balVars_["water_vapor_mixing_ratio_wrt_moist_air"], + balVars_["balanced_air_pressure"], data_); + const auto sQDivuField = getField("reg", balVars_["water_vapor_mixing_ratio_wrt_moist_air"], + balVars_["air_horizontal_divergence"], data_); + const auto sQTpsuField = getField("reg", balVars_["water_vapor_mixing_ratio_wrt_moist_air"], + balVars_["air_temperature_and_log_of_air_pressure_at_surface"], data_); + + // Gather vectors + trans_->gatherCov(sDivPbField, sDivPbGlb, true); + trans_->gatherCov(sTpsPbField, sTpsPbGlb, true); + trans_->gatherCov(sTpsDivuField, sTpsDivuGlb, true); + trans_->gatherCov(sQPbField, sQPbGlb, true); + trans_->gatherCov(sQDivuField, sQDivuGlb, true); + trans_->gatherCov(sQTpsuField, sQTpsuGlb, true); + + // Define global IAL size + size_t nial = 0; + for (size_t jm = 0; jm < trans_->ellips().size(); ++jm) { + nial += 4*(trans_->ellips()[jm]+1); + } + + // Allocate fact1 IAL vector + std::vector fact1IAL(nial, 0.0); + + // Global IAL / spectral conversion + atlas::Field IALIndexField("IALIndex", make_datatype(), + make_shape(trans_->ellips().size(), trans_->ellips()[0]+1, 4)); + auto IALIndexView = make_view(IALIndexField); + IALIndexView.assign(-1); + size_t jIAL = 0; + for (size_t jk = 0; jk < trans_->ellips().size(); ++jk) { + for (size_t jl = 0; jl <= trans_->ellips()[jk]; ++jl) { + for (size_t jq = 0; jq < 4; ++jq) { + IALIndexView(jk, jl, jq) = jIAL; + ++jIAL; + } + } + } + ASSERT(jIAL == nial); + + // Copy fact1 + for (size_t js = 0; js < trans_->ns(); ++js) { + const size_t jk = trans_->jk(js); + const size_t jl = trans_->jl(js); + const size_t jq = trans_->jq(js); + jIAL = IALIndexView(jk, jl, jq); + fact1IAL[jIAL] = fact1_[js]; + } + + // Reduce fact1 IAL vector + comm_.allReduceInPlace(fact1IAL.begin(), fact1IAL.end(), eckit::mpi::sum()); + + if (comm_.rank() == 0) { + // Get number of levels + const size_t nz = balVars_["balanced_air_pressure"].getLevels(); + + if (params_.write.value()->outputFileFormat.value() == "arome legacy binary") { + // Write Fortran unformatted file (based on ewgsabal.F90) + bifourier_arome_legacy_write_balance_f90(params_.write.value()->toConfiguration(), + trans_->nwGlb(), nz_, sDivPbGlb.data(), sTpsPbGlb.data(), sTpsDivuGlb.data(), + sQPbGlb.data(), sQDivuGlb.data(), sQTpsuGlb.data(), nial, fact1IAL.data()); + } else if (params_.write.value()->outputFileFormat.value() == "arome legacy netcdf") { + // NetCDF file path + const std::string ncFilePath = params_.write.value()->outputFile.value(); + + // NetCDF IDs + int ncId, retval, nzId, nzP1Id, nwGlbId, nialId, dNzNzId[3], dNzNzP1Id[3], dNzP1NzId[3], + dIALId[1], sDivPbID, sTpsPbId, sTpsDivuId, sQPbId, sQDivuId, sQTpsuId, fact1Id; + + // Create NetCDF file + if ((retval = nc_create(ncFilePath.c_str(), NC_64BIT_OFFSET | NC_CLOBBER, &ncId))) + ERR(retval, ncFilePath); + + // Create dimensions + if ((retval = nc_def_dim(ncId, "NFLEV", nz, &nzId))) ERR(retval, "NFLEV"); + if ((retval = nc_def_dim(ncId, "NFLEVP1", nz+1, &nzP1Id))) ERR(retval, "NFLEVP1"); + if ((retval = nc_def_dim(ncId, "NSMAXP1", trans_->nwGlb(), &nwGlbId))) + ERR(retval, "NSMAXP1"); + if ((retval = nc_def_dim(ncId, "KSPEC2G", nial, &nialId))) ERR(retval, "KSPEC2G"); + + // Dimensions arrays + dNzNzId[0] = nwGlbId; + dNzNzId[1] = nzId; + dNzNzId[2] = nzId; + dNzNzP1Id[0] = nwGlbId; + dNzNzP1Id[1] = nzId; + dNzNzP1Id[2] = nzP1Id; + dNzP1NzId[0] = nwGlbId; + dNzP1NzId[1] = nzP1Id; + dNzP1NzId[2] = nzId; + dIALId[0] = nialId; + + // Create variables + if ((retval = nc_def_var(ncId, "SDIV_PB", NC_DOUBLE, 3, dNzNzId, &sDivPbID))) + ERR(retval, "SDIV_PB"); + if ((retval = nc_def_var(ncId, "STPS_PB", NC_DOUBLE, 3, dNzNzP1Id, &sTpsPbId))) + ERR(retval, "STPS_PB"); + if ((retval = nc_def_var(ncId, "STPS_DIVU", NC_DOUBLE, 3, dNzNzP1Id, &sTpsDivuId))) + ERR(retval, "STPS_DIVU"); + if ((retval = nc_def_var(ncId, "SQ_PB", NC_DOUBLE, 3, dNzNzId, &sQPbId))) + ERR(retval, "SQ_PB"); + if ((retval = nc_def_var(ncId, "SQ_DIVU", NC_DOUBLE, 3, dNzNzId, &sQDivuId))) + ERR(retval, "SQ_DIVU"); + if ((retval = nc_def_var(ncId, "SQ_TPSU", NC_DOUBLE, 3, dNzP1NzId, &sQTpsuId))) + ERR(retval, "SQ_TPSU"); + if ((retval = nc_def_var(ncId, "FACT1", NC_DOUBLE, 1, dIALId, &fact1Id))) + ERR(retval, "FACT1"); + + // End definition mode + if ((retval = nc_enddef(ncId))) ERR(retval, ncFilePath); + + // Write data + if ((retval = nc_put_var_double(ncId, sDivPbID, sDivPbGlb.data()))) + ERR(retval, "SDIV_PB"); + if ((retval = nc_put_var_double(ncId, sTpsPbId, sTpsPbGlb.data()))) + ERR(retval, "STPS_PB"); + if ((retval = nc_put_var_double(ncId, sTpsDivuId, sTpsDivuGlb.data()))) + ERR(retval, "STPS_DIVU"); + if ((retval = nc_put_var_double(ncId, sQPbId, sQPbGlb.data()))) + ERR(retval, "SQ_PB"); + if ((retval = nc_put_var_double(ncId, sQDivuId, sQDivuGlb.data()))) + ERR(retval, "SQ_DIVU"); + if ((retval = nc_put_var_double(ncId, sQTpsuId, sQTpsuGlb.data()))) + ERR(retval, "SQ_TPSU"); + if ((retval = nc_put_var_double(ncId, fact1Id, fact1IAL.data()))) + ERR(retval, "FACT1"); + + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + } + } else { + // Generic balance + BifourierBalance::write(); + + // Allocate global vector + std::vector fact1Glb; + if (comm_.rank() == 0) { + fact1Glb.resize(trans_->nsGlb()); + } + + // Gather data + comm_.gatherv(fact1_.cbegin(), fact1_.cend(), fact1Glb.begin(), fact1Glb.end(), + trans_->sCounts(), trans_->sDispls(), 0); + + // NetCDF IDs + int retval, ncId, nsGlbId, d1DId[1], varId; + + // NetCDF file path + const std::string ncFilePath = params_.write.value()->outputFile.value(); + + if (comm_.rank() == 0) { + // Open NetCDF file + if ((retval = nc_open(ncFilePath.c_str(), NC_64BIT_OFFSET | NC_WRITE, &ncId))) + ERR(retval, ncFilePath); + + // Return to definition mode + if ((retval = nc_redef(ncId))) ERR(retval, ncFilePath); + + // Create dimension + if ((retval = nc_def_dim(ncId, "nsGlb", trans_->nsGlb(), &nsGlbId))) ERR(retval, "nsGlb"); + + // Dimensions array + d1DId[0] = nsGlbId; + + // Define variable + if ((retval = nc_def_var(ncId, "fact1", NC_DOUBLE, 1, d1DId, &varId))) + ERR(retval, "fact1"); + + // End definition mode + if ((retval = nc_enddef(ncId))) ERR(retval, ncFilePath); + + // Reorder data + std::vector fact1GlbOrdered(trans_->nsGlb()); + for (size_t jsGlb = 0; jsGlb < trans_->nsGlb(); ++jsGlb) { + fact1GlbOrdered[trans_->sMapping()[jsGlb]] = fact1Glb[jsGlb]; + } + + // Write data + if ((retval = nc_put_var_double(ncId, varId, fact1GlbOrdered.data()))) + ERR(retval, "fact1"); + + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + } + } + + oops::Log::trace() << classname() << "::write done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +oops::Variables BifourierAromeBalance::genericInnerVars(const oops::Variables & outerVars) { + oops::Log::trace() << classname() << "::genericInnerVars starting" << std::endl; + + // Get number of levels + nz_ = outerVars["air_temperature"].getLevels(); + + // Add TPs to inner variables and remove T and Ps + oops::Variables vars(outerVars); + vars.push_back("air_temperature_and_log_of_air_pressure_at_surface"); + vars["air_temperature_and_log_of_air_pressure_at_surface"].setLevels(nz_+1); + vars -= vars["air_temperature"]; + vars -= vars["log_of_air_pressure_at_surface"]; + + // Add balanced pressure + vars.push_back("balanced_air_pressure"); + vars["balanced_air_pressure"].setLevels(nz_); + + oops::Log::trace() << classname() << "::genericInnerVars done" << std::endl; + return vars; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::vorToPb(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::vorToPb starting" << std::endl; + + // Get inner field + const auto vorField = fset["air_upward_absolute_vorticity"]; + + // Create outer field + atlas::Field pbField = trans_->spFspace()->createField( + atlas::option::name("balanced_air_pressure") | atlas::option::levels(nz_)); + + // Get fields views + const auto vorView = make_view(vorField); + auto pbView = make_view(pbField); + + // Apply change of variable + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jz = 0; jz < nz_; ++jz) { + pbView(js, jz) = vorView(js, jz)*fact1_[js]; + } + } + + // Add outer field + fset.add(pbField); + + oops::Log::trace() << classname() << "::vorToPb done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::vorToPbAD(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::vorToPbAD starting" << std::endl; + + // Get fields + const auto pbField = fset["balanced_air_pressure"]; + auto vorField = fset["air_upward_absolute_vorticity"]; + + // Get fields views + const auto pbView = make_view(pbField); + auto vorView = make_view(vorField); + + // Apply change of variable, adjoint + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jz = 0; jz < nz_; ++jz) { + vorView(js, jz) += pbView(js, jz)*fact1_[js]; + } + } + + // Remove outer field + util::removeFieldsFromFieldSet(fset.fieldSet(), {"balanced_air_pressure"}); + + oops::Log::trace() << classname() << "::vorToPbAD done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::vorToPbLeftInverse(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::vorToPbLeftInverse starting" << std::endl; + + // Get fields + const auto pbField = fset["balanced_air_pressure"]; + auto vorField = fset["air_upward_absolute_vorticity"]; + + // Get fields views + const auto pbView = make_view(pbField); + auto vorView = make_view(vorField); + + // Apply change of variable, inverse + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jz = 0; jz < nz_; ++jz) { + if (std::abs(fact1_[js]) > 0.0) { + vorView(js, jz) = pbView(js, jz)/fact1_[js]; + } + } + } + + // Remove outer field + util::removeFieldsFromFieldSet(fset.fieldSet(), {"balanced_air_pressure"}); + + oops::Log::trace() << classname() << "::vorToPbLeftInverse done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::removePb(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::removePb starting" << std::endl; + + util::removeFieldsFromFieldSet(fset.fieldSet(), {"balanced_air_pressure"}); + + oops::Log::trace() << classname() << "::removePb done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::removePbAD(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::removePbAD starting" << std::endl; + + // Get outer field + const auto vorField = fset["air_upward_absolute_vorticity"]; + + // Create inner field + atlas::Field pbField = trans_->spFspace()->createField( + atlas::option::name("balanced_air_pressure") | atlas::option::levels(nz_)); + + // Get inner field view + auto pbView = make_view(pbField); + + // Set inner field to zero + pbView.assign(0.0); + + // Add outer field + fset.add(pbField); + + oops::Log::trace() << classname() << "::removePbAD done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::removePbLeftInverse(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::removePbLeftInverse starting" << std::endl; + + // Get inner field + const auto vorField = fset["air_upward_absolute_vorticity"]; + + // Create outer field + atlas::Field pbField = trans_->spFspace()->createField( + atlas::option::name("balanced_air_pressure") | atlas::option::levels(nz_)); + + // Get fields views + const auto vorView = make_view(vorField); + auto pbView = make_view(pbField); + + // Apply change of variable + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jz = 0; jz < nz_; ++jz) { + pbView(js, jz) = vorView(js, jz)*fact1_[js]; + } + } + + // Add outer field + fset.add(pbField); + + oops::Log::trace() << classname() << "::removePbLeftInverse done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::splitTPs(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::splitTPs starting" << std::endl; + + // Get inner field + const auto tPsField = fset["air_temperature_and_log_of_air_pressure_at_surface"]; + + // Create outer fields + atlas::Field tField = trans_->spFspace()->createField( + atlas::option::name("air_temperature") | atlas::option::levels(nz_)); + atlas::Field psField = trans_->spFspace()->createField( + atlas::option::name("log_of_air_pressure_at_surface") | atlas::option::levels(1)); + + // Get fields views + const auto tPsView = make_view(tPsField); + auto tView = make_view(tField); + auto psView = make_view(psField); + + // Copy data + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jz = 0; jz < nz_; ++jz) { + tView(js, jz) = tPsView(js, jz); + } + psView(js, 0) = tPsView(js, nz_); + } + + // Remove inner field + util::removeFieldsFromFieldSet(fset.fieldSet(), + {"air_temperature_and_log_of_air_pressure_at_surface"}); + + // Add outer fields + fset.add(tField); + fset.add(psField); + + oops::Log::trace() << classname() << "::splitTPs done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeBalance::gatherTPs(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::gatherTPs starting" << std::endl; + + // Get outer fields + const auto tField = fset["air_temperature"]; + const auto psField = fset["log_of_air_pressure_at_surface"]; + + // Create inner field + atlas::Field tPsField = trans_->spFspace()->createField( + atlas::option::name("air_temperature_and_log_of_air_pressure_at_surface") | + atlas::option::levels(nz_+1)); + + // Get fields views + const auto tView = make_view(tField); + const auto psView = make_view(psField); + auto tPsView = make_view(tPsField); + + // Copy data + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jz = 0; jz < nz_; ++jz) { + tPsView(js, jz) = tView(js, jz); + } + tPsView(js, nz_) = psView(js, 0); + } + + // Remove outer fields + util::removeFieldsFromFieldSet(fset.fieldSet(), {"air_temperature", + "log_of_air_pressure_at_surface"}); + + // Add inner field + fset.add(tPsField); + + oops::Log::trace() << classname() << "::gatherTPs done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +} // namespace bifourier +} // namespace saber diff --git a/src/saber/bifourier/BifourierAromeBalance.h b/src/saber/bifourier/BifourierAromeBalance.h new file mode 100644 index 000000000..1ec0c6b1f --- /dev/null +++ b/src/saber/bifourier/BifourierAromeBalance.h @@ -0,0 +1,159 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#pragma once + +#include +#include + +#include "saber/bifourier/BifourierBalance.h" + +namespace saber { +namespace bifourier { + +// ----------------------------------------------------------------------------- + +class BifourierAromeBalanceReadParameters : public BifourierBalanceReadParameters { + OOPS_CONCRETE_PARAMETERS(BifourierAromeBalanceReadParameters, BifourierBalanceReadParameters) + + public: + // Input file format ("netcdf", "arome legacy binary" or "arome legacy netcdf") + oops::Parameter inputFileFormat{"input file format", "netcdf", this}; +}; + +// ----------------------------------------------------------------------------- + +class BifourierAromeBalanceWriteParameters : public BifourierBalanceWriteParameters { + OOPS_CONCRETE_PARAMETERS(BifourierAromeBalanceWriteParameters, BifourierBalanceWriteParameters) + + public: + // Output file + oops::RequiredParameter outputFile{"output file", this}; + + // Output file format ("netcdf", "arome legacy binary" or "arome legacy netcdf") + oops::Parameter outputFileFormat{"output file format", "netcdf", this}; +}; + +// ----------------------------------------------------------------------------- + +class BalancedAirPressureParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(BalancedAirPressureParameters, oops::Parameters) + + public: + // Zonal wavenumbers size + oops::RequiredParameter M{"zonal truncation", this}; + + // Meridional wavenumbers size + oops::RequiredParameter N{"meridional truncation", this}; + + // Mean latitude + oops::RequiredParameter meanLat{"mean latitude", this}; +}; + +// ----------------------------------------------------------------------------- + +class BifourierAromeBalanceParameters : public BifourierBalanceParameters { + OOPS_CONCRETE_PARAMETERS(BifourierAromeBalanceParameters, BifourierBalanceParameters) + + public: + // Read parameters + oops::OptionalParameter read{"read", this}; + + // Write parameters + oops::OptionalParameter write{"write", this}; + + // Explicit balanced air pressure parameters + oops::OptionalParameter + explicitPb{"explicit balanced air pressure parameters", this}; + + // Balanced air pressure parameters from grid + oops::Parameter pbFromTrans{"balanced air pressure parameters from grid", false, this}; + + oops::Variables mandatoryActiveVars() const override {return oops::Variables( + std::vector({ + "air_upward_absolute_vorticity", + "air_temperature", + "log_of_air_pressure_at_surface", + "air_temperature_and_log_of_air_pressure_at_surface"}));} +}; + +// ----------------------------------------------------------------------------- + +class BifourierAromeBalance : public BifourierBalance { + public: + static const std::string classname() + {return "saber::bifourier::BifourierAromeBalance";} + + typedef BifourierAromeBalanceParameters Parameters_; + + BifourierAromeBalance(const oops::GeometryData &, + const oops::Variables &, + const eckit::Configuration &, + const Parameters_ &, + const oops::FieldSet3D &, + const oops::FieldSet3D &); + + const oops::Variables & innerVars() const override + {return aromeInnerVars_;} + + void multiply(oops::FieldSet3D &) const; + void multiplyAD(oops::FieldSet3D &) const; + void leftInverseMultiply(oops::FieldSet3D &) const; + + void read(); + + void directCalibration(const oops::FieldSets &); + + void iterativeCalibrationUpdate(const oops::FieldSet3D &); + + void write() const; + + private: + // Parameters + BifourierAromeBalanceParameters params_; + + // Number of levels + size_t nz_; + + // Vorticity to balanced pressure factor + std::vector fact1_; + + // AROME balance inner variables + oops::Variables aromeInnerVars_; + + // Private methods + + // Generic inner variables + oops::Variables genericInnerVars(const oops::Variables &); + + // Vorticity to balanced pressure + void vorToPb(oops::FieldSet3D &) const; + + // Vorticity to balanced pressure, adjoint + void vorToPbAD(oops::FieldSet3D &) const; + + // Vorticity to balanced pressure, left inverse + void vorToPbLeftInverse(oops::FieldSet3D &) const; + + // Remove balanced pressure + void removePb(oops::FieldSet3D &) const; + + // Remove balanced pressure, adjoint + void removePbAD(oops::FieldSet3D &) const; + + // Remove balanced pressure, left inverse + void removePbLeftInverse(oops::FieldSet3D &) const; + + // Split TPs + void splitTPs(oops::FieldSet3D &) const; + + // Gather TPs + void gatherTPs(oops::FieldSet3D &) const; +}; + +// ----------------------------------------------------------------------------- + +} // namespace bifourier +} // namespace saber diff --git a/src/saber/bifourier/BifourierAromeCovariance.cc b/src/saber/bifourier/BifourierAromeCovariance.cc new file mode 100644 index 000000000..4db2b8a93 --- /dev/null +++ b/src/saber/bifourier/BifourierAromeCovariance.cc @@ -0,0 +1,328 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#include "saber/bifourier/BifourierAromeCovariance.h" + +#include + +#include +#include + +#include "saber/bifourier/bifourier_arome_legacy.h" +#include "saber/bifourier/BifourierUtilities.h" + +#define ERR(e, msg) {std::string s(nc_strerror(e)); \ + throw eckit::Exception(s + " : " + msg, Here());} + +using atlas::array::make_datatype; +using atlas::array::make_shape; +using atlas::array::make_view; + +namespace saber { +namespace bifourier { + +// ----------------------------------------------------------------------------- + +static SaberCentralBlockMaker + makerBifourierAromeCovariance_("BifourierAromeCovariance"); + +// ----------------------------------------------------------------------------- + +void BifourierAromeCovariance::read() { + oops::Log::trace() << classname() << "::read starting" << std::endl; + + // Read data + if (params_.read.value()->inputFileFormat.value() == "arome legacy binary" + || params_.read.value()->inputFileFormat.value() == "arome legacy netcdf") { + for (const auto & var : activeVars_) { + // Create covariance field + createField3D("cov", trans_->nw(), var, data_); + } + + // Get number of levels + const size_t nz = activeVars_["air_upward_absolute_vorticity"].getLevels(); + + // Define global vectors + std::vector vorCovGlb; + std::vector divuCovGlb; + std::vector tPsuCovGlb; + std::vector quCovGlb; + + if (comm_.rank() == 0) { + // Allocate global vectors + vorCovGlb.resize(trans_->nwGlb()*nz*nz); + divuCovGlb.resize(trans_->nwGlb()*nz*nz); + tPsuCovGlb.resize(trans_->nwGlb()*(nz+1)*(nz+1)); + quCovGlb.resize(trans_->nwGlb()*nz*nz); + + if (params_.read.value()->inputFileFormat.value() == "arome legacy binary") { + // Read Fortran unformatted file (from readjbdat96.F90) + bifourier_arome_legacy_read_covariance_f90(params_.read.value()->toConfiguration(), + trans_->nwGlb(), nz, vorCovGlb.data(), divuCovGlb.data(), tPsuCovGlb.data(), + quCovGlb.data()); + } else if (params_.read.value()->inputFileFormat.value() == "arome legacy netcdf") { + // NetCDF file path + const std::string ncFilePath = params_.read.value()->inputFile.value(); + + // NetCDF IDs + int ncId, retval, dimId, varId; + size_t nzFromFile, nwGlbFromFile; + + // Open NetCDF file + if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncId))) ERR(retval, ncFilePath); + + // Check dimensions + if ((retval = nc_inq_dimid(ncId, "NFLEV", &dimId))) ERR(retval, "NFLEV"); + if ((retval = nc_inq_dimlen(ncId, dimId, &nzFromFile))) ERR(retval, "NFLEV"); + ASSERT(nzFromFile == nz); + if ((retval = nc_inq_dimid(ncId, "NSMAXP1", &dimId))) ERR(retval, "NSMAXP1"); + if ((retval = nc_inq_dimlen(ncId, dimId, &nwGlbFromFile))) ERR(retval, "NSMAXP1"); + ASSERT(nwGlbFromFile == trans_->nwGlb()); + + // Get variables + if ((retval = nc_inq_varid(ncId, "VOR_VERTCOV", &varId))) ERR(retval, "VOR_VERTCOV"); + if ((retval = nc_get_var_double(ncId, varId, vorCovGlb.data()))) ERR(retval, "VOR_VERTCOV"); + if ((retval = nc_inq_varid(ncId, "DIVU_VERTCOV", &varId))) ERR(retval, "DIVU_VERTCOV"); + if ((retval = nc_get_var_double(ncId, varId, divuCovGlb.data()))) + ERR(retval, "DIVU_VERTCOV"); + if ((retval = nc_inq_varid(ncId, "TPSU_VERTCOV", &varId))) ERR(retval, "TPSU_VERTCOV"); + if ((retval = nc_get_var_double(ncId, varId, tPsuCovGlb.data()))) + ERR(retval, "TPSU_VERTCOV"); + if ((retval = nc_inq_varid(ncId, "QU_VERTCOV", &varId))) ERR(retval, "QU_VERTCOV"); + if ((retval = nc_get_var_double(ncId, varId, quCovGlb.data()))) ERR(retval, "QU_VERTCOV"); + + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + } + + // Scatter data + for (const auto & var : activeVars_) { + // Get covariance field + auto covField = getField("cov", var, data_); + + // Scatter global vector + if (var.name() == "air_upward_absolute_vorticity") { + trans_->scatterCov(vorCovGlb, covField, true); + } + if (var.name() == "air_horizontal_divergence") { + trans_->scatterCov(divuCovGlb, covField, true); + } + if (var.name() == "air_temperature_and_log_of_air_pressure_at_surface") { + trans_->scatterCov(tPsuCovGlb, covField, true); + } + if (var.name() == "water_vapor_mixing_ratio_wrt_moist_air") { + trans_->scatterCov(quCovGlb, covField, true); + } + } + + // Rescale covariance from AROME to block standard + for (const auto & var : activeVars_) { + // Get number of levels + const size_t nz = var.getLevels(); + + // Get covariance view + auto covView = getView3D("cov", var, data_); + + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + // Get AROME weight + const double zWeight = 1.0/aromeWeight(jw); + + // Apply weight + for (size_t jzI = 0; jzI < nz; ++jzI) { + for (size_t jzJ = 0; jzJ < nz; ++jzJ) { + covView(jw, jzI, jzJ) *= zWeight; + } + } + } + } + + // Compute square-root + computeSquareRoot(); + + // Print norms + print(oops::Log::test()); + } else { + // Generic reader + BifourierCovariance::read(); + } + + oops::Log::trace() << classname() << "::read done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierAromeCovariance::write() const { + oops::Log::trace() << classname() << "::write starting" << std::endl; + + if (params_.write.value() != boost::none) { + // Write data + if (params_.write.value()->outputFileFormat.value() == "arome legacy binary" + || params_.write.value()->outputFileFormat.value() == "arome legacy netcdf") { + // Create AROME covariance fieldset + atlas::FieldSet aromeCovData; + + // Compute covariance from correlation square-root and standard-deviation if it is missing + computeCovariance(aromeCovData); + + // Define global vectors + std::vector vorCovGlb; + std::vector divuCovGlb; + std::vector tPsuCovGlb; + std::vector quCovGlb; + + + for (const auto & var : activeVars_) { + // Get number of levels + const size_t nz = var.getLevels(); + + // Get covariance view + const auto covView = getView3D("cov", var, aromeCovData); + + // Create AROME covariance field + createField3D("aromeCov", trans_->nw(), var, aromeCovData); + + // Get AROME covariance view + auto aromeCovView = getView3D("aromeCov", var, aromeCovData); + + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + // Get AROME weight + const double zWeight = aromeWeight(jw); + + // Apply weight + for (size_t jzI = 0; jzI < nz; ++jzI) { + for (size_t jzJ = 0; jzJ < nz; ++jzJ) { + aromeCovView(jw, jzI, jzJ) = covView(jw, jzI, jzJ)*zWeight; + } + } + } + } + + // Write AROME covariances + for (const auto & var : activeVars_) { + // Get covariance field + const auto aromeCovField = getField("aromeCov", var, aromeCovData); + + // Gather covariance vector + if (var.name() == "air_upward_absolute_vorticity") { + trans_->gatherCov(aromeCovField, vorCovGlb, true); + } + if (var.name() == "air_horizontal_divergence") { + trans_->gatherCov(aromeCovField, divuCovGlb, true); + } + if (var.name() == "air_temperature_and_log_of_air_pressure_at_surface") { + trans_->gatherCov(aromeCovField, tPsuCovGlb, true); + } + if (var.name() == "water_vapor_mixing_ratio_wrt_moist_air") { + trans_->gatherCov(aromeCovField, quCovGlb, true); + } + } + + if (comm_.rank() == 0) { + // Get number of levels + const size_t nz = activeVars_["air_upward_absolute_vorticity"].getLevels(); + + if (params_.write.value()->outputFileFormat.value() == "arome legacy binary") { + // Write Fortran unformatted file (from ewgsacov.F90) + bifourier_arome_legacy_write_covariance_f90(params_.write.value()->toConfiguration(), + trans_->nwGlb(), nz, vorCovGlb.data(), divuCovGlb.data(), tPsuCovGlb.data(), + quCovGlb.data()); + } else if (params_.write.value()->outputFileFormat.value() == "arome legacy netcdf") { + // NetCDF file path + const std::string ncFilePath = params_.write.value()->outputFile.value(); + + // NetCDF IDs + int ncId, retval, nzId, nzP1Id, nwGlbId, dNzId[3], dNzP1Id[3], + vorCovId, divuCovId, tPsuCovId, quCovId; + + // Create NetCDF file + if ((retval = nc_create(ncFilePath.c_str(), NC_64BIT_OFFSET | NC_CLOBBER, &ncId))) + ERR(retval, ncFilePath); + + // Create dimensions + if ((retval = nc_def_dim(ncId, "NFLEV", nz, &nzId))) ERR(retval, "NFLEV"); + if ((retval = nc_def_dim(ncId, "NFLEVP1", nz+1, &nzP1Id))) ERR(retval, "NFLEVP1"); + if ((retval = nc_def_dim(ncId, "NSMAXP1", trans_->nwGlb(), &nwGlbId))) + ERR(retval, "NSMAXP1"); + + // Dimensions arrays + dNzId[0] = nwGlbId; + dNzId[1] = nzId; + dNzId[2] = nzId; + dNzP1Id[0] = nwGlbId; + dNzP1Id[1] = nzP1Id; + dNzP1Id[2] = nzP1Id; + + // Create variables + if ((retval = nc_def_var(ncId, "VOR_VERTCOV", NC_DOUBLE, 3, dNzId, &vorCovId))) + ERR(retval, "VOR_VERTCOV"); + if ((retval = nc_def_var(ncId, "DIVU_VERTCOV", NC_DOUBLE, 3, dNzId, &divuCovId))) + ERR(retval, "DIVU_VERTCOV"); + if ((retval = nc_def_var(ncId, "TPSU_VERTCOV", NC_DOUBLE, 3, dNzP1Id, &tPsuCovId))) + ERR(retval, "TPSU_VERTCOV"); + if ((retval = nc_def_var(ncId, "QU_VERTCOV", NC_DOUBLE, 3, dNzId, &quCovId))) + ERR(retval, "QU_VERTCOV"); + + // End definition mode + if ((retval = nc_enddef(ncId))) ERR(retval, ncFilePath); + + // Write data + if ((retval = nc_put_var_double(ncId, vorCovId, vorCovGlb.data()))) + ERR(retval, "VOR_VERTCOV"); + if ((retval = nc_put_var_double(ncId, divuCovId, divuCovGlb.data()))) + ERR(retval, "DIVU_VERTCOV"); + if ((retval = nc_put_var_double(ncId, tPsuCovId, tPsuCovGlb.data()))) + ERR(retval, "TPSU_VERTCOV"); + if ((retval = nc_put_var_double(ncId, quCovId, quCovGlb.data()))) + ERR(retval, "QU_VERTCOV"); + + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + } + } else { + // Generic writer + BifourierCovariance::write(); + } + } + + oops::Log::trace() << classname() << "::write done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +double BifourierAromeCovariance::aromeWeight(const size_t & jw) const { + oops::Log::trace() << classname() << "::aromeWeight starting" << std::endl; + + // Get global total wavenumber + const size_t jwGlb = jw + trans_->nwStart(); + + // Constant coefficient + const double zmovern = static_cast(trans_->ellips().size()) + / static_cast(trans_->nwGlb()-1); + + // Compute weight + double zWeight; + if (jwGlb != 0 && jwGlb != trans_->nwGlb()-1) { + zWeight = 2.0*M_PI*static_cast(jwGlb)*zmovern; + } else if (jwGlb == 0) { +// zWeight = M_PI*zmovern/4.0; + zWeight = M_PI*zmovern/2.0; + } else if (jwGlb == trans_->nwGlb()-1) { + zWeight = M_PI*(static_cast(trans_->nwGlb()-1)-0.25)*zmovern; + } + + // REDNMC factor + zWeight /= params_.rednmc.value()*params_.rednmc.value(); + + oops::Log::trace() << classname() << "::aromeWeight starting" << std::endl; + return zWeight; +} + +// ----------------------------------------------------------------------------- + +} // namespace bifourier +} // namespace saber + diff --git a/src/saber/bifourier/BifourierAromeCovariance.h b/src/saber/bifourier/BifourierAromeCovariance.h new file mode 100644 index 000000000..77aeb7ba2 --- /dev/null +++ b/src/saber/bifourier/BifourierAromeCovariance.h @@ -0,0 +1,89 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#pragma once + +#include + +#include "saber/bifourier/BifourierCovariance.h" + +namespace saber { +namespace bifourier { + +// ----------------------------------------------------------------------------- + +class BifourierAromeCovarianceReadParameters : public BifourierCovarianceReadParameters { + OOPS_CONCRETE_PARAMETERS(BifourierAromeCovarianceReadParameters, + BifourierCovarianceReadParameters) + + public: + // Input file format ("netcdf", "arome legacy binary" or "arome legacy netcdf") + oops::Parameter inputFileFormat{"input file format", "netcdf", this}; +}; + +// ----------------------------------------------------------------------------- + +class BifourierAromeCovarianceWriteParameters : public BifourierCovarianceWriteParameters { + OOPS_CONCRETE_PARAMETERS(BifourierAromeCovarianceWriteParameters, + BifourierCovarianceWriteParameters) + + public: + // Output file format ("netcdf", "arome legacy binary" or "arome legacy netcdf") + oops::Parameter outputFileFormat{"output file format", "netcdf", this}; +}; + +// ----------------------------------------------------------------------------- + +class BifourierAromeCovarianceParameters : public BifourierCovarianceParameters { + OOPS_CONCRETE_PARAMETERS(BifourierAromeCovarianceParameters, BifourierCovarianceParameters) + + public: + // Read parameters + oops::OptionalParameter read{"read", this}; + + // Write parameters + oops::OptionalParameter write{"write", this}; + + // REDNMC factor + oops::Parameter rednmc{"rednmc", std::sqrt(0.5), this}; + + oops::Variables mandatoryActiveVars() const override + {return oops::Variables();} +}; + + +// ----------------------------------------------------------------------------- + +class BifourierAromeCovariance : public BifourierCovariance { + public: + static const std::string classname() + {return "saber::bifourier::BifourierAromeCovariance";} + + typedef BifourierAromeCovarianceParameters Parameters_; + + BifourierAromeCovariance(const oops::GeometryData & gdata, + const oops::Variables & activeVars, + const eckit::Configuration & covarConf, + const Parameters_ & params, + const oops::FieldSet3D & xb, + const oops::FieldSet3D & fg) : + BifourierCovariance(gdata, activeVars, covarConf, params, xb, fg), params_(params) {} + + void read(); + + void write() const; + + private: + // Parameters + Parameters_ params_; + + // Private methods + double aromeWeight(const size_t &) const; +}; + +// ----------------------------------------------------------------------------- + +} // namespace bifourier +} // namespace saber diff --git a/src/saber/bifourier/BifourierAromeLegacy.cc b/src/saber/bifourier/BifourierAromeLegacy.cc deleted file mode 100644 index 5f8d4ce87..000000000 --- a/src/saber/bifourier/BifourierAromeLegacy.cc +++ /dev/null @@ -1,718 +0,0 @@ -/* - * (C) Copyright 2025 Meteorologisk Institutt - * - */ - -#include "saber/bifourier/BifourierAromeLegacy.h" - -#include -#include - -#include -#include -#include - -#include "oops/util/FieldSetHelpers.h" - -#include "saber/bifourier/bifourier_arome_legacy.h" -#include "saber/bifourier/BifourierBalance.h" -#include "saber/bifourier/BifourierCovariance.h" -#include "saber/bifourier/BifourierUtilities.h" -#include "saber/bifourier/BifourierVorToPb.h" - -#define ERR(e, msg) {std::string s(nc_strerror(e)); \ - throw eckit::Exception(s + " : " + msg, Here());} - -using atlas::array::make_datatype; -using atlas::array::make_shape; -using atlas::array::make_view; - -namespace saber { -namespace bifourier { -namespace arome_legacy { - -// ----------------------------------------------------------------------------- - -void readVorToPb(const eckit::mpi::Comm & comm, - const BifourierVorToPbReadParameters & params, - const BifourierTransform & trans, - std::vector & fact1) { - oops::Log::trace() << "saber::bifourier::BifourierAromeLegacy::readVorToPb starting" << std::endl; - - // Define global IAL size - size_t nial = 0; - for (size_t jm = 0; jm < trans.ellips().size(); ++jm) { - nial += 4*(trans.ellips()[jm]+1); - } - - // Fact1 global vector - std::vector fact1Glb(nial); - - if (comm.rank() == 0) { - if (params.inputFileFormat.value() == "arome legacy binary") { - // Read Fortran unformatted file (based on readjbbal.F90) - bifourier_arome_legacy_vortopb_f90(params.toConfiguration(), nial, fact1Glb.data()); - } else if (params.inputFileFormat.value() == "arome legacy netcdf") { - // NetCDF file path - const std::string ncFilePath = *params.inputFile.value(); - - // NetCDF IDs - int ncid, retval, dimid, varid; - size_t nialFromFile; - - // Open NetCDF file - if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncid))) ERR(retval, ncFilePath); - - // Check dimensions - if ((retval = nc_inq_dimid(ncid, "KSPEC2G", &dimid))) ERR(retval, "KSPEC2G"); - if ((retval = nc_inq_dimlen(ncid, dimid, &nialFromFile))) ERR(retval, "KSPEC2G"); - ASSERT(nialFromFile == nial); - - // Get variables - if ((retval = nc_inq_varid(ncid, "FACT1", &varid))) ERR(retval, "FACT1"); - if ((retval = nc_get_var_double(ncid, varid, fact1Glb.data()))) ERR(retval, "FACT1"); - - // Close file - if ((retval = nc_close(ncid))) ERR(retval, ncFilePath); - } - - // Print norms - oops::Log::info() << "Info : Fact1 norm: " << std::endl; - const double fact1Norm = std::inner_product(fact1Glb.begin(), fact1Glb.end(), fact1Glb.begin(), - 0.0); - oops::Log::test() << "- fact1: " << fact1Norm << std::endl; - } - - // Broadcast fact1 - oops::Log::info() << "Info : Broadcast fact1" << std::endl; - comm.broadcast(fact1Glb.begin(), fact1Glb.end(), 0); - - // Global IAL / spectral conversion - atlas::Field IALIndexField("IALIndex", make_datatype(), - make_shape(trans.ellips().size(), trans.ellips()[0]+1, 4)); - auto IALIndexView = make_view(IALIndexField); - IALIndexView.assign(-1); - size_t jIAL = 0; - for (size_t jk = 0; jk < trans.ellips().size(); ++jk) { - for (size_t jl = 0; jl <= trans.ellips()[jk]; ++jl) { - for (size_t jq = 0; jq < 4; ++jq) { - IALIndexView(jk, jl, jq) = jIAL; - ++jIAL; - } - } - } - ASSERT(jIAL == nial); - - // Copy fact1 - for (size_t js = 0; js < trans.ns(); ++js) { - const size_t jk = trans.jk(js); - const size_t jl = trans.jl(js); - const size_t jq = trans.jq(js); - jIAL = IALIndexView(jk, jl, jq); - fact1[js] = fact1Glb[jIAL]; - } - - oops::Log::trace() << "saber::bifourier::BifourierAromeLegacy::readVorToPb done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void readBalance(const eckit::mpi::Comm & comm, - const oops::Variables & balVars, - const BifourierBalanceReadParameters & params, - const BifourierTransform & trans, - atlas::FieldSet & balFset) { - oops::Log::trace() << "saber::bifourier::BifourierAromeLegacy::readBalance starting" << std::endl; - - // Get number of levels - const size_t nflev = balVars[0].getLevels(); - - // Allocate local vectors - std::vector sDivPb(trans.nw()*nflev*nflev); - std::vector sTpsPb(trans.nw()*nflev*(nflev+1)); - std::vector sTpsDivu(trans.nw()*nflev*(nflev+1)); - std::vector sQPb(trans.nw()*nflev*nflev); - std::vector sQDivu(trans.nw()*nflev*nflev); - std::vector sQTpsu(trans.nw()*(nflev+1)*nflev); - - // Tag root - const size_t tagRoot = 123; - - if (comm.rank() == 0) { - // Allocate global vectors - std::vector sDivPbGlb(trans.nwGlb()*nflev*nflev); - std::vector sTpsPbGlb(trans.nwGlb()*nflev*(nflev+1)); - std::vector sTpsDivuGlb(trans.nwGlb()*nflev*(nflev+1)); - std::vector sQPbGlb(trans.nwGlb()*nflev*nflev); - std::vector sQDivuGlb(trans.nwGlb()*nflev*nflev); - std::vector sQTpsuGlb(trans.nwGlb()*(nflev+1)*nflev); - - if (params.inputFileFormat.value() == "arome legacy binary") { - // Read Fortran unformatted file (based on readjbbal.F90) - bifourier_arome_legacy_balance_f90(params.toConfiguration(), trans.nwGlb(), nflev, - sDivPbGlb.data(), sTpsPbGlb.data(), sTpsDivuGlb.data(), sQPbGlb.data(), sQDivuGlb.data(), - sQTpsuGlb.data()); - } else if (params.inputFileFormat.value() == "arome legacy netcdf") { - // NetCDF file path - std::string ncFilePath = params.inputFile.value(); - - // NetCDF IDs - int ncid, retval, dimid, varid; - size_t nflevFromFile, nwFromFile; - - // Open NetCDF file - if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncid))) ERR(retval, ncFilePath); - - // Check dimensions - if ((retval = nc_inq_dimid(ncid, "NFLEV", &dimid))) ERR(retval, "NFLEV"); - if ((retval = nc_inq_dimlen(ncid, dimid, &nflevFromFile))) ERR(retval, "NFLEV"); - ASSERT(nflevFromFile == nflev); - if ((retval = nc_inq_dimid(ncid, "NSMAXP1", &dimid))) ERR(retval, "NSMAXP1"); - if ((retval = nc_inq_dimlen(ncid, dimid, &nwFromFile))) ERR(retval, "NSMAXP1"); - ASSERT(nwFromFile == trans.nwGlb()); - - // Get variables - if ((retval = nc_inq_varid(ncid, "SDIV_PB", &varid))) ERR(retval, "SDIV_PB"); - if ((retval = nc_get_var_double(ncid, varid, sDivPbGlb.data()))) ERR(retval, "SDIV_PB"); - if ((retval = nc_inq_varid(ncid, "STPS_PB", &varid))) ERR(retval, "STPS_PB"); - if ((retval = nc_get_var_double(ncid, varid, sTpsPbGlb.data()))) ERR(retval, "STPS_PB"); - if ((retval = nc_inq_varid(ncid, "STPS_DIVU", &varid))) ERR(retval, "STPS_DIVU"); - if ((retval = nc_get_var_double(ncid, varid, sTpsDivuGlb.data()))) ERR(retval, "STPS_DIVU"); - if ((retval = nc_inq_varid(ncid, "SQ_PB", &varid))) ERR(retval, "SQ_PB"); - if ((retval = nc_get_var_double(ncid, varid, sQPbGlb.data()))) ERR(retval, "SQ_PB"); - if ((retval = nc_inq_varid(ncid, "SQ_DIVU", &varid))) ERR(retval, "SQ_DIVU"); - if ((retval = nc_get_var_double(ncid, varid, sQDivuGlb.data()))) ERR(retval, "SQ_DIVU"); - if ((retval = nc_inq_varid(ncid, "SQ_TPSU", &varid))) ERR(retval, "SQ_TPSU"); - if ((retval = nc_get_var_double(ncid, varid, sQTpsuGlb.data()))) ERR(retval, "SQ_TPSU"); - - // Close file - if ((retval = nc_close(ncid))) ERR(retval, ncFilePath); - } - - // Print norms - oops::Log::info() << "Info : Balance operator norms: " << std::endl; - const double sDivPbNorm = std::inner_product(sDivPbGlb.begin(), sDivPbGlb.end(), - sDivPbGlb.begin(), 0.0); - oops::Log::test() << "- sDivPb: " << sDivPbNorm << std::endl; - const double sTpsPbNorm = std::inner_product(sTpsPbGlb.begin(), sTpsPbGlb.end(), - sTpsPbGlb.begin(), 0.0); - oops::Log::test() << "- sTpsPb: " << sTpsPbNorm << std::endl; - const double sTpsDivuNorm = std::inner_product(sTpsDivuGlb.begin(), sTpsDivuGlb.end(), - sTpsDivuGlb.begin(), 0.0); - oops::Log::test() << "- sTpsDivu: " << sTpsDivuNorm << std::endl; - const double sQPbNorm = std::inner_product(sQPbGlb.begin(), sQPbGlb.end(), sQPbGlb.begin(), - 0.0); - oops::Log::test() << "- sQPb: " << sQPbNorm << std::endl; - const double sQDivuNorm = std::inner_product(sQDivuGlb.begin(), sQDivuGlb.end(), - sQDivuGlb.begin(), 0.0); - oops::Log::test() << "- sQDivu: " << sQDivuNorm << std::endl; - const double sQTpsuNorm = std::inner_product(sQTpsuGlb.begin(), sQTpsuGlb.end(), - sQTpsuGlb.begin(), 0.0); - oops::Log::test() << "- sQTpsu: " << sQTpsuNorm << std::endl; - - // Copy data - for (size_t jw = 0; jw < trans.nw(); ++jw) { - const size_t jwGlb = jw + trans.nwStart(); - for (size_t jz2 = 0; jz2 < nflev; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev; ++jz1) { - const size_t index = jw*nflev*nflev + jz1*nflev + jz2; - const size_t indexGlb = jwGlb*nflev*nflev + jz1*nflev + jz2; - sDivPb[index] = sDivPbGlb[indexGlb]; - sQPb[index] = sQPbGlb[indexGlb]; - sQDivu[index] = sQDivuGlb[indexGlb]; - } - } - for (size_t jz2 = 0; jz2 < nflev+1; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev; ++jz1) { - const size_t index = jw*nflev*(nflev+1) + jz1*(nflev+1) + jz2; - const size_t indexGlb = jwGlb*nflev*(nflev+1) + jz1*(nflev+1) + jz2; - sTpsPb[index] = sTpsPbGlb[indexGlb]; - sTpsDivu[index] = sTpsDivuGlb[indexGlb]; - } - } - for (size_t jz2 = 0; jz2 < nflev; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev+1; ++jz1) { - const size_t index = jw*(nflev+1)*nflev + jz1*nflev + jz2; - const size_t indexGlb = jwGlb*(nflev+1)*nflev + jz1*nflev + jz2; - sQTpsu[index] = sQTpsuGlb[indexGlb]; - } - } - } - - // Send data - int tag = tagRoot; - for (size_t jt = 1; jt < comm.size(); ++jt) { - // Create vectors - std::vector sDivPbSend(trans.nwPerTask()[jt]*nflev*nflev); - std::vector sTpsPbSend(trans.nwPerTask()[jt]*nflev*(nflev+1)); - std::vector sTpsDivuSend(trans.nwPerTask()[jt]*nflev*(nflev+1)); - std::vector sQPbSend(trans.nwPerTask()[jt]*nflev*nflev); - std::vector sQDivuSend(trans.nwPerTask()[jt]*nflev*nflev); - std::vector sQTpsuSend(trans.nwPerTask()[jt]*(nflev+1)*nflev); - - // Fill vectors - for (size_t jwSend = 0; jwSend < trans.nwPerTask()[jt]; ++jwSend) { - const size_t jwGlb = jwSend + trans.nwStartPerTask()[jt]; - for (size_t jz2 = 0; jz2 < nflev; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev; ++jz1) { - const size_t indexSend = jwSend*nflev*nflev + jz1*nflev + jz2; - const size_t indexGlb = jwGlb*nflev*nflev + jz1*nflev + jz2; - sDivPbSend[indexSend] = sDivPbGlb[indexGlb]; - sQPbSend[indexSend] = sQPbGlb[indexGlb]; - sQDivuSend[indexSend] = sQDivuGlb[indexGlb]; - } - } - for (size_t jz2 = 0; jz2 < nflev+1; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev; ++jz1) { - const size_t indexSend = jwSend*nflev*(nflev+1) + jz1*(nflev+1) + jz2; - const size_t indexGlb = jwGlb*nflev*(nflev+1) + jz1*(nflev+1) + jz2; - sTpsPbSend[indexSend] = sTpsPbGlb[indexGlb]; - sTpsDivuSend[indexSend] = sTpsDivuGlb[indexGlb]; - } - } - for (size_t jz2 = 0; jz2 < nflev; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev+1; ++jz1) { - const size_t indexSend = jwSend*(nflev+1)*nflev + jz1*nflev + jz2; - const size_t indexGlb = jwGlb*(nflev+1)*nflev + jz1*nflev + jz2; - sQTpsuSend[indexSend] = sQTpsuGlb[indexGlb]; - } - } - } - - // Send vectors - comm.send(sDivPbSend.data(), trans.nwPerTask()[jt]*nflev*nflev, jt, tag+0); - comm.send(sTpsPbSend.data(), trans.nwPerTask()[jt]*nflev*(nflev+1), jt, tag+1); - comm.send(sTpsDivuSend.data(), trans.nwPerTask()[jt]*nflev*(nflev+1), jt, tag+2); - comm.send(sQPbSend.data(), trans.nwPerTask()[jt]*nflev*nflev, jt, tag+3); - comm.send(sQDivuSend.data(), trans.nwPerTask()[jt]*nflev*nflev, jt, tag+4); - comm.send(sQTpsuSend.data(), trans.nwPerTask()[jt]*(nflev+1)*nflev, jt, tag+5); - - // Update tag - tag += 6; - } - } - - // Receive vectors - if (comm.rank() > 0) { - const int tagBase = tagRoot+6*(comm.rank()-1); - comm.receive(sDivPb.data(), trans.nw()*nflev*nflev, 0, tagBase+0); - comm.receive(sTpsPb.data(), trans.nw()*nflev*(nflev+1), 0, tagBase+1); - comm.receive(sTpsDivu.data(), trans.nw()*nflev*(nflev+1), 0, tagBase+2); - comm.receive(sQPb.data(), trans.nw()*nflev*nflev, 0, tagBase+3); - comm.receive(sQDivu.data(), trans.nw()*nflev*nflev, 0, tagBase+4); - comm.receive(sQTpsu.data(), trans.nw()*(nflev+1)*nflev, 0, tagBase+5); - } - - // MPI barrier - comm.barrier(); - - // Get fields - atlas::Field sDivPbField = balFset[ - "reg_air_horizontal_divergence_from_balanced_air_pressure"]; - atlas::Field sTpsPbField = balFset[ - "reg_air_temperature_and_log_of_air_pressure_at_surface_from_balanced_air_pressure"]; - atlas::Field sTpsDivuField = balFset[ - "reg_air_temperature_and_log_of_air_pressure_at_surface_from_air_horizontal_divergence"]; - atlas::Field sQPbField = balFset[ - "reg_water_vapor_mixing_ratio_wrt_moist_air_from_balanced_air_pressure"]; - atlas::Field sQDivuField = balFset[ - "reg_water_vapor_mixing_ratio_wrt_moist_air_from_air_horizontal_divergence"]; - atlas::Field sQTpsuField = balFset[ - "reg_water_vapor_mixing_ratio_wrt_moist_air_from_air_temperature_and_" - "log_of_air_pressure_at_surface"]; - - // Get fields views - auto sDivPbView = make_view(sDivPbField); - auto sTpsPbView = make_view(sTpsPbField); - auto sTpsDivuView = make_view(sTpsDivuField); - auto sQPbView = make_view(sQPbField); - auto sQDivuView = make_view(sQDivuField); - auto sQTpsuView = make_view(sQTpsuField); - - // Deserialize data - for (size_t jw = 0; jw < trans.nw(); ++jw) { - for (size_t jz2 = 0; jz2 < nflev; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev; ++jz1) { - const size_t jv = jw*nflev*nflev + jz1*nflev + jz2; - sDivPbView(jw, jz2, jz1) = sDivPb[jv]; - sQPbView(jw, jz2, jz1) = sQPb[jv]; - sQDivuView(jw, jz2, jz1) = sQDivu[jv]; - } - } - for (size_t jz2 = 0; jz2 < nflev+1; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev; ++jz1) { - const size_t jv = jw*nflev*(nflev+1) + jz1*(nflev+1) + jz2; - sTpsPbView(jw, jz2, jz1) = sTpsPb[jv]; - sTpsDivuView(jw, jz2, jz1) = sTpsDivu[jv]; - } - } - for (size_t jz2 = 0; jz2 < nflev; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev+1; ++jz1) { - const size_t jv = jw*(nflev+1)*nflev + jz1*nflev + jz2; - sQTpsuView(jw, jz2, jz1) = sQTpsu[jv]; - } - } - } - - oops::Log::trace() << "saber::bifourier::BifourierAromeLegacy::readBalance done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void readCovariance(const eckit::mpi::Comm & comm, - const oops::Variables & activeVars, - const BifourierCovarianceReadParameters & params, - const BifourierTransform & trans, - atlas::FieldSet & fset) { - oops::Log::trace() << "saber::bifourier::BifourierAromeLegacy::readCovariance starting" - << std::endl; - - // Get number of levels - const size_t nflev = activeVars["air_upward_absolute_vorticity"].getLevels(); - - // Allocate local vectors - std::vector vorCov(trans.nw()*nflev*nflev); - std::vector divuCov(trans.nw()*nflev*nflev); - std::vector tPsuCov(trans.nw()*(nflev+1)*(nflev+1)); - std::vector quCov(trans.nw()*nflev*nflev); - - // Tag root - const size_t tagRoot = 123; - - if (comm.rank() == 0) { - // Allocate global vectors - std::vector vorCovGlb(trans.nwGlb()*nflev*nflev); - std::vector divuCovGlb(trans.nwGlb()*nflev*nflev); - std::vector tPsuCovGlb(trans.nwGlb()*(nflev+1)*(nflev+1)); - std::vector quCovGlb(trans.nwGlb()*nflev*nflev); - - if (params.inputFileFormat.value() == "arome legacy binary") { - // Read Fortran unformatted file (from readjbdat96.F90) - bifourier_arome_legacy_covariance_f90(params.toConfiguration(), trans.nwGlb(), nflev, - vorCovGlb.data(), divuCovGlb.data(), tPsuCovGlb.data(), quCovGlb.data()); - } else if (params.inputFileFormat.value() == "arome legacy netcdf") { - // NetCDF file path - std::string ncFilePath = params.inputFile.value(); - - // NetCDF IDs - int ncid, retval, dimid, varid; - size_t nflevFromFile, nwFromFile; - - // Open NetCDF file - if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncid))) ERR(retval, ncFilePath); - - // Check dimensions - if ((retval = nc_inq_dimid(ncid, "NFLEV", &dimid))) ERR(retval, "NFLEV"); - if ((retval = nc_inq_dimlen(ncid, dimid, &nflevFromFile))) ERR(retval, "NFLEV"); - ASSERT(nflevFromFile == nflev); - if ((retval = nc_inq_dimid(ncid, "NSMAXP1", &dimid))) ERR(retval, "NSMAXP1"); - if ((retval = nc_inq_dimlen(ncid, dimid, &nwFromFile))) ERR(retval, "NSMAXP1"); - ASSERT(nwFromFile == trans.nwGlb()); - - // Get variables - if ((retval = nc_inq_varid(ncid, "VOR_VERTCOV", &varid))) ERR(retval, "VOR_VERTCOV"); - if ((retval = nc_get_var_double(ncid, varid, vorCovGlb.data()))) ERR(retval, "VOR_VERTCOV"); - if ((retval = nc_inq_varid(ncid, "DIVU_VERTCOV", &varid))) ERR(retval, "DIVU_VERTCOV"); - if ((retval = nc_get_var_double(ncid, varid, divuCovGlb.data()))) - ERR(retval, "DIVU_VERTCOV"); - if ((retval = nc_inq_varid(ncid, "TPSU_VERTCOV", &varid))) ERR(retval, "TPSU_VERTCOV"); - if ((retval = nc_get_var_double(ncid, varid, tPsuCovGlb.data()))) - ERR(retval, "TPSU_VERTCOV"); - if ((retval = nc_inq_varid(ncid, "QU_VERTCOV", &varid))) ERR(retval, "QU_VERTCOV"); - if ((retval = nc_get_var_double(ncid, varid, quCovGlb.data()))) ERR(retval, "QU_VERTCOV"); - - // Close file - if ((retval = nc_close(ncid))) ERR(retval, ncFilePath); - } - - // Print norms - oops::Log::info() << "Info : Covariance norms: " << std::endl; - const double vorCovNorm = std::inner_product(vorCovGlb.begin(), vorCovGlb.end(), - vorCovGlb.begin(), 0.0); - oops::Log::test() << "- vorVertCov: " << vorCovNorm << std::endl; - const double divuCovNorm = std::inner_product(divuCovGlb.begin(), divuCovGlb.end(), - divuCovGlb.begin(), 0.0); - oops::Log::test() << "- divuVertCov: " << divuCovNorm << std::endl; - const double tPsuCovNorm = std::inner_product(tPsuCovGlb.begin(), tPsuCovGlb.end(), - tPsuCovGlb.begin(), 0.0); - oops::Log::test() << "- tPsuVertCov: " << tPsuCovNorm << std::endl; - const double quCovNorm = std::inner_product(quCovGlb.begin(), quCovGlb.end(), - quCovGlb.begin(), 0.0); - oops::Log::test() << "- quVertCov: " << quCovNorm << std::endl; - - // Copy data - for (size_t jw = 0; jw < trans.nw(); ++jw) { - const size_t jwGlb = jw + trans.nwStart(); - for (size_t jz2 = 0; jz2 < nflev; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev; ++jz1) { - const size_t index = jw*nflev*nflev + jz2*nflev + jz1; - const size_t indexGlb = jwGlb*nflev*nflev + jz2*nflev + jz1; - vorCov[index] = vorCovGlb[indexGlb]; - divuCov[index] = divuCovGlb[indexGlb]; - quCov[index] = quCovGlb[indexGlb]; - } - } - for (size_t jz2 = 0; jz2 < nflev+1; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev+1; ++jz1) { - const size_t index = jw*(nflev+1)*(nflev+1) + jz2*(nflev+1) + jz1; - const size_t indexGlb = jwGlb*(nflev+1)*(nflev+1) + jz2*(nflev+1) + jz1; - tPsuCov[index] = tPsuCovGlb[indexGlb]; - } - } - } - - // Send data - int tag = tagRoot; - for (size_t jt = 1; jt < comm.size(); ++jt) { - // Create vectors - std::vector vorCovSend(trans.nwPerTask()[jt]*nflev*nflev); - std::vector divuCovSend(trans.nwPerTask()[jt]*nflev*nflev); - std::vector tPsuCovSend(trans.nwPerTask()[jt]*(nflev+1)*(nflev+1)); - std::vector quCovSend(trans.nwPerTask()[jt]*nflev*nflev); - - // Fill vectors - for (size_t jwSend = 0; jwSend < trans.nwPerTask()[jt]; ++jwSend) { - const size_t jwGlb = jwSend + trans.nwStartPerTask()[jt]; - for (size_t jz2 = 0; jz2 < nflev; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev; ++jz1) { - const size_t indexSend = jwSend*nflev*nflev + jz2*nflev + jz1; - const size_t indexGlb = jwGlb*nflev*nflev + jz2*nflev + jz1; - vorCovSend[indexSend] = vorCovGlb[indexGlb]; - divuCovSend[indexSend] = divuCovGlb[indexGlb]; - quCovSend[indexSend] = quCovGlb[indexGlb]; - } - } - } - for (size_t jwSend = 0; jwSend < trans.nwPerTask()[jt]; ++jwSend) { - const size_t jwGlb = jwSend + trans.nwStartPerTask()[jt]; - for (size_t jz2 = 0; jz2 < nflev+1; ++jz2) { - for (size_t jz1 = 0; jz1 < nflev+1; ++jz1) { - const size_t indexSend = jwSend*(nflev+1)*(nflev+1) + jz2*(nflev+1) + jz1; - const size_t indexGlb = jwGlb*(nflev+1)*(nflev+1) + jz2*(nflev+1) + jz1; - tPsuCovSend[indexSend] = tPsuCovGlb[indexGlb]; - } - } - } - - // Send vectors - comm.send(vorCovSend.data(), trans.nwPerTask()[jt]*nflev*nflev, jt, tag+0); - comm.send(divuCovSend.data(), trans.nwPerTask()[jt]*nflev*nflev, jt, tag+1); - comm.send(tPsuCovSend.data(), trans.nwPerTask()[jt]*(nflev+1)*(nflev+1), jt, tag+2); - comm.send(quCovSend.data(), trans.nwPerTask()[jt]*nflev*nflev, jt, tag+3); - - // Update tag - tag += 4; - } - } - - // Receive vectors - if (comm.rank() > 0) { - const int tagBase = tagRoot+4*(comm.rank()-1); - comm.receive(vorCov.data(), trans.nw()*nflev*nflev, 0, tagBase+0); - comm.receive(divuCov.data(), trans.nw()*nflev*nflev, 0, tagBase+1); - comm.receive(tPsuCov.data(), trans.nw()*(nflev+1)*(nflev+1), 0, tagBase+2); - comm.receive(quCov.data(), trans.nw()*nflev*nflev, 0, tagBase+3); - } - - // MPI barrier - comm.barrier(); - - // Constant coefficient - const double zmovern = static_cast(trans.ellips().size()) - / static_cast(trans.nwGlb()-1); - - // Theoretical REDNMC value - const double sqrtHalf = std::sqrt(0.5); - - for (const auto & var : activeVars) { - // Get number of levels - const size_t nz = var.getLevels(); - - // Create covariance field - createField3D("cov", trans.nw(), var, fset); - - // Get covariance view - auto covView = getView3D("cov", var, fset); - - // Copy data - for (size_t jw = 0; jw < trans.nw(); ++jw) { - for (size_t jz2 = 0; jz2 < nz; ++jz2) { - for (size_t jz1 = 0; jz1 < nz; ++jz1) { - const size_t index = jw*nz*nz + jz2*nz + jz1; - if (var.name() == "air_upward_absolute_vorticity") { - covView(jw, jz2, jz1) = vorCov[index]; - } - if (var.name() == "air_horizontal_divergence") { - covView(jw, jz2, jz1) = divuCov[index]; - } - if (var.name() == "air_temperature_and_log_of_air_pressure_at_surface") { - covView(jw, jz2, jz1) = tPsuCov[index]; - } - if (var.name() == "water_vapor_mixing_ratio_wrt_moist_air") { - covView(jw, jz2, jz1) = quCov[index]; - } - } - } - } - - // Get correlation square-root view - auto corSqrtView = getView3D("corSqrt", var, fset); - - // From suejbstd.F90 - - // Create standard-deviation profiles - std::vector vertStd(nz, 0.0); - - // Compute vertical variance for each level - for (size_t jw = 0; jw < trans.nwRoot(); ++jw) { - for (size_t jz = 0; jz < nz; ++jz) { - vertStd[jz] += covView(jw, jz, jz); - } - } - - // Communication - comm.allReduceInPlace(vertStd.begin(), vertStd.end(), eckit::mpi::sum()); - - // Take variance square-root - for (size_t jz = 0; jz < nz; ++jz) { - vertStd[jz] = std::sqrt(vertStd[jz]); - } - - // From suejbcor.F90 - - // Compute vertical correlation square-root - const double zeps = 1.0e-99; - Eigen::SelfAdjointEigenSolver es; - for (size_t jw = 0; jw < trans.nw(); ++jw) { - // Compute vertical correlation matrix - Eigen::MatrixXd vertCor(nz, nz); - for (size_t jz2 = 0; jz2 < nz; ++jz2) { - for (size_t jz1 = 0; jz1 < nz; ++jz1) { - vertCor(jz2, jz1) = covView(jw, jz2, jz1) / - std::sqrt(std::max(zeps, covView(jw, jz1, jz1))*std::max(zeps, covView(jw, jz2, jz2))); - } - } - - // Compute eigendecomposition - es.compute(vertCor); - - // Store covariance square-root - for (size_t jz2 = 0; jz2 < nz; ++jz2) { - for (size_t jz1 = 0; jz1 < nz; ++jz1) { - corSqrtView(jw, jz2, jz1) = es.eigenvectors().col(jz1)[jz2] - *std::sqrt(es.eigenvalues()[jz1]); - } - } - } - - // Set wavenumber 0 to zero for vorticity and divergence - if (var.name() == "air_upward_absolute_vorticity" - || var.name() == "air_horizontal_divergence") { - for (size_t jw = 0; jw < trans.nw(); ++jw) { - const size_t jwGlb = jw + trans.nwStart(); - if (jwGlb == 0) { - for (size_t jz2 = 0; jz2 < nz; ++jz2) { - for (size_t jz1 = 0; jz1 < nz; ++jz1) { - covView(jw, jz2, jz1) = 0.0; - } - } - } - } - } - - // Compute sum over wavenumbers - std::vector sum(nz, 0.0); - for (size_t jw = 0; jw < trans.nwRoot(); ++jw) { - for (size_t jz = 0; jz < nz; ++jz) { - sum[jz] += covView(jw, jz, jz); - } - } - - // Communication - comm.allReduceInPlace(sum.begin(), sum.end(), eckit::mpi::sum()); - - // Create horizontal covariance field - atlas::Field horCovField("horCov", make_datatype(), - make_shape(trans.nw(), nz)); - - // Get horizontal covariance view - auto horCovView = make_view(horCovField); - - // Normalize sums - for (size_t jw = 0; jw < trans.nw(); ++jw) { - for (size_t jz = 0; jz < nz; ++jz) { - horCovView(jw, jz) = covView(jw, jz, jz)/sum[jz]; - } - } - - // Apply weight - double zWeight; - for (size_t jw = 0; jw < trans.nw(); ++jw) { - const size_t jwGlb = jw + trans.nwStart(); - if (jwGlb != 0 && jwGlb != trans.nwGlb()-1) { - zWeight = 2.0*M_PI*static_cast(jwGlb)*zmovern; - } else if (jwGlb == 0) { - zWeight = M_PI*zmovern/4.0; - } else if (jwGlb == trans.nwGlb()-1) { - zWeight = M_PI*(static_cast(trans.nwGlb()-1)-0.25)*zmovern; - } - for (size_t jz = 0; jz < nz; ++jz) { - horCovView(jw, jz) = std::max(1.0e-20, std::sqrt(horCovView(jw, jz) / zWeight)); - } - } - - // Merge contributions - for (size_t jw = 0; jw < trans.nw(); ++jw) { - for (size_t jz2 = 0; jz2 < nz; ++jz2) { - for (size_t jz1 = 0; jz1 < nz; ++jz1) { - corSqrtView(jw, jz2, jz1) *= horCovView(jw, jz2) * vertStd[jz2] * sqrtHalf; - } - } - } - - // Get standard-deviation view - auto stdDevView = getViewProfile("stdDev", var, fset); - - // Compute variance - std::vector variance(nz, 0.0); - for (size_t jz2 = 0; jz2 < nz; ++jz2) { - for (size_t js = 0; js < trans.ns(); ++js) { - if (trans.jq(js) == 0) { - const size_t jw = trans.jw(js); - for (size_t jz1 = 0; jz1 < nz; ++jz1) { - variance[jz2] += corSqrtView(jw, jz2, jz1)*corSqrtView(jw, jz2, jz1) - *trans.spNorm(js)*trans.spNorm(js); - } - } - } - } - - // Communication - comm.allReduceInPlace(variance.begin(), variance.end(), eckit::mpi::sum()); - - // Compute standard-deviation - for (size_t jz = 0; jz < nz; ++jz) { - stdDevView(jz) = std::sqrt(variance[jz]); - } - - // Apply inverse standard-deviation to normalize correlation square-root - for (size_t jz2 = 0; jz2 < nz; ++jz2) { - ASSERT(stdDevView(jz2) > 0.0); - const double norm = 1.0/stdDevView(jz2); - for (size_t jw = 0; jw < trans.nw(); ++jw) { - for (size_t jz1 = 0; jz1 < nz; ++jz1) { - corSqrtView(jw, jz2, jz1) *= norm; - } - } - } - } - - oops::Log::trace() << "saber::bifourier::BifourierAromeLegacy::readCovariance done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -} // namespace arome_legacy -} // namespace bifourier -} // namespace saber - diff --git a/src/saber/bifourier/BifourierAromeLegacy.h b/src/saber/bifourier/BifourierAromeLegacy.h deleted file mode 100644 index 9afc6827d..000000000 --- a/src/saber/bifourier/BifourierAromeLegacy.h +++ /dev/null @@ -1,52 +0,0 @@ -/* - * (C) Copyright 2025 Meteorologisk Institutt - * - */ - -#pragma once - -#include - -#include "atlas/field.h" - -#include "eckit/mpi/Comm.h" - -#include "saber/bifourier/BifourierTransform.h" - -namespace saber { -namespace bifourier { - -class BifourierVorToPbReadParameters; -class BifourierBalanceReadParameters; -class BifourierCovarianceReadParameters; - -namespace arome_legacy { - -// ----------------------------------------------------------------------------- - -void readVorToPb(const eckit::mpi::Comm &, - const BifourierVorToPbReadParameters &, - const BifourierTransform &, - std::vector &); - -// ----------------------------------------------------------------------------- - -void readBalance(const eckit::mpi::Comm &, - const oops::Variables &, - const BifourierBalanceReadParameters &, - const BifourierTransform &, - atlas::FieldSet &); - -// ----------------------------------------------------------------------------- - -void readCovariance(const eckit::mpi::Comm &, - const oops::Variables &, - const BifourierCovarianceReadParameters &, - const BifourierTransform &, - atlas::FieldSet &); - -// ----------------------------------------------------------------------------- - -} // namespace arome_legacy -} // namespace bifourier -} // namespace saber diff --git a/src/saber/bifourier/BifourierBalance.cc b/src/saber/bifourier/BifourierBalance.cc index 1c5e0d3d7..cd70eee94 100644 --- a/src/saber/bifourier/BifourierBalance.cc +++ b/src/saber/bifourier/BifourierBalance.cc @@ -12,7 +12,6 @@ #include "oops/util/FieldSetOperations.h" -#include "saber/bifourier/BifourierAromeLegacy.h" #include "saber/bifourier/BifourierUtilities.h" #define ERR(e, msg) {std::string s(nc_strerror(e)); \ @@ -41,13 +40,13 @@ BifourierBalance::BifourierBalance(const oops::GeometryData & outerGeometryData, innerGeometryData_(outerGeometryData), comm_(outerGeometryData.comm()), innerVars_(outerVars), - params_(params) + params_(params), + Lf_(params_.calibration.value() != boost::none ? + params_.calibration.value()->filteringScale.value() : 0), + trans_(transStore_.retrieveTransform(outerGeometryData)) { oops::Log::trace() << classname() << "::BifourierBalance starting" << std::endl; - // Retrieve spectral transform - trans_ = transStore_.retrieveTransform(outerGeometryData); - // Initialize components counter nCmp_ = 0; @@ -229,25 +228,140 @@ void BifourierBalance::read() { } } - // Read data - if (params_.read.value()->inputFileFormat.value() == "arome legacy binary" - || params_.read.value()->inputFileFormat.value() == "arome legacy netcdf") { - arome_legacy::readBalance(comm_, balVars_, *params_.read.value(), *trans_, data_); - } else { - // NetCDF file path - const std::string ncFilePath = params_.read.value()->inputFile.value(); + // NetCDF file path + const std::string ncFilePath = params_.read.value()->inputFile.value(); - // NetCDF IDs - int ncid, retval, nwGlb_id, nzI_id, nzJ_id, varid; - size_t nwGlbFromFile, nzIFromFile, nzJFromFile; + // NetCDF IDs + int ncId, retval, nwGlbId, nzIId, nzJId, varId; + size_t nwGlbFromFile, nzIFromFile, nzJFromFile; - if (comm_.rank() == 0) { - // Open NetCDF file - if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncid))) ERR(retval, ncFilePath); + if (comm_.rank() == 0) { + // Open NetCDF file + if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncId))) ERR(retval, ncFilePath); + } + + for (const auto & row : params_.rows.value()) { + // Get output variable + const oops::Variable outputVar = balVars_[row.outputVar.value()]; + + // Get number of output levels + const size_t nzI = outputVar.getLevels(); + + // Define global regression vector + std::vector regVecGlb; + + for (const auto & inputVarName : row.inputVars.value()) { + // Get input variable + const oops::Variable inputVar = balVars_[inputVarName]; + + // Get number of input levels + const size_t nzJ = inputVar.getLevels(); + + if (comm_.rank() == 0) { + // Check dimensions + const std::string nzIName = "nzI_" + outputVar.name(); + const std::string nzJName = "nzJ_" + inputVar.name(); + if ((retval = nc_inq_dimid(ncId, "nwGlb", &nwGlbId))) ERR(retval, "nwGlb"); + if ((retval = nc_inq_dimid(ncId, nzIName.c_str(), &nzIId))) ERR(retval, nzIName); + if ((retval = nc_inq_dimid(ncId, nzJName.c_str(), &nzJId))) ERR(retval, nzJName); + if ((retval = nc_inq_dimlen(ncId, nwGlbId, &nwGlbFromFile))) ERR(retval, "nwGlb"); + if ((retval = nc_inq_dimlen(ncId, nzIId, &nzIFromFile))) ERR(retval, nzIName); + if ((retval = nc_inq_dimlen(ncId, nzJId, &nzJFromFile))) ERR(retval, nzJName); + ASSERT(nwGlbFromFile == trans_->nwGlb()); + ASSERT(nzIFromFile == nzI); + ASSERT(nzJFromFile == nzJ); + + // Allocate global regression vector + regVecGlb.resize(trans_->nwGlb()*nzI*nzJ); + + // Read data + const std::string regFieldName = fieldName("reg", outputVar, inputVar); + if ((retval = nc_inq_varid(ncId, regFieldName.c_str(), &varId))) + ERR(retval, regFieldName); + if ((retval = nc_get_var_double(ncId, varId, regVecGlb.data()))) ERR(retval, regFieldName); + } + + // Get regression field + auto regField = getField("reg", outputVar, inputVar, data_); + + // Scatter regression vector + trans_->scatterCov(regVecGlb, regField); + } + } + + if (comm_.rank() == 0) { + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + + oops::Log::trace() << classname() << "::read done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierBalance::directCalibration(const oops::FieldSets & fsetEns) { + oops::Log::trace() << classname() << "::directCalibration starting" << std::endl; + + // Check ensemble size + const size_t ne = fsetEns.ens_size(); + ASSERT(ne > 2); + + if (params_.calibration.value()->fullRecursiveInverse.value()) { + // Using the full recursive inverse formula + + // Estimate xx-covariance for all lower triangular blocks (including diagonal) + for (const auto & outputVar : balVars_) { + // Get number of output levels + const size_t nzI = outputVar.getLevels(); + + for (const auto & inputVar : balVars_) { + if (balVars_.find(inputVar.name()) <= balVars_.find(outputVar.name())) { + // Get number of input levels + const size_t nzJ = inputVar.getLevels(); + + // Create xx-covariance field + createField3D("xxCov", trans_->nw(), outputVar, inputVar, data_); + + // Get xx-covariance view + auto xxCovView = getView3D("xxCov", outputVar, inputVar, data_); + + // Loop over ensemble members + for (size_t je = 0; je < ne; ++je) { + // Get member views + const auto outputView = getView2D(outputVar, fsetEns[je]); + const auto inputView = getView2D(inputVar, fsetEns[je]); + + // Update xx-covariance + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + if (trans_->includeWavenumber(js, jw)) { + const double factor = trans_->spNorm(js); + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + xxCovView(jw, jzI, jzJ) += factor*inputView(js, jzJ)*outputView(js, jzI); + } + } + } + } + } + } + + // Get xx-covariance field + auto xxCovField = getField("xxCov", outputVar, inputVar, data_); + + // Reduce and normalize xx-covariance + trans_->reduceNormalizeCov(ne-1, xxCovField); + } + } } - // Tag root - size_t tagRoot = 123; + // Compute regressions from xx-covariances + computeRegressionsFromCovariances(); + } else { + // Using the partial recursive inverse formula + + // Copy ensemble + oops::FieldSets fsetEnsUnbal(fsetEns); for (const auto & row : params_.rows.value()) { // Get output variable @@ -263,103 +377,274 @@ void BifourierBalance::read() { // Get number of input levels const size_t nzJ = inputVar.getLevels(); - // Get regression view - auto regView = getView3D("reg", outputVar, inputVar, data_); + // Create xv-covariance field + createField3D("xvCov", trans_->nw(), outputVar, inputVar, data_); + + // Get xv-covariance view + auto xvCovView = getView3D("xvCov", outputVar, inputVar, data_); + + // Loop over ensemble members + for (size_t je = 0; je < ne; ++je) { + // Get member views + const auto outputView = getView2D(outputVar, fsetEns[je]); + const auto inputUnbalView = getView2D(inputVar, fsetEnsUnbal[je]); + + // Update xv-covariance + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + if (trans_->includeWavenumber(js, jw)) { + const double factor = trans_->spNorm(js); + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + xvCovView(jw, jzI, jzJ) += factor*inputUnbalView(js, jzJ) + *outputView(js, jzI); + } + } + } + } + } + } - // Define vector - std::vector vec(trans_->nw()*nzI*nzJ); + // Get xv-covariance field + auto xvCovField = getField("xvCov", outputVar, inputVar, data_); - if (comm_.rank() == 0) { - // Check dimensions - const std::string nzIName = "nzI_" + outputVar.name(); - const std::string nzJName = "nzJ_" + inputVar.name(); - if ((retval = nc_inq_dimid(ncid, "nwGlb", &nwGlb_id))) ERR(retval, "nwGlb"); - if ((retval = nc_inq_dimid(ncid, nzIName.c_str(), &nzI_id))) ERR(retval, nzIName); - if ((retval = nc_inq_dimid(ncid, nzJName.c_str(), &nzJ_id))) ERR(retval, nzJName); - if ((retval = nc_inq_dimlen(ncid, nwGlb_id, &nwGlbFromFile))) ERR(retval, "nwGlb"); - if ((retval = nc_inq_dimlen(ncid, nzI_id, &nzIFromFile))) ERR(retval, nzIName); - if ((retval = nc_inq_dimlen(ncid, nzJ_id, &nzJFromFile))) ERR(retval, nzJName); - ASSERT(nwGlbFromFile == trans_->nwGlb()); - ASSERT(nzIFromFile == nzI); - ASSERT(nzJFromFile == nzJ); + // Reduce and normalize xv-covariance + trans_->reduceNormalizeCov(ne-1, xvCovField); - // Define global vector - std::vector vecGlb(trans_->nwGlb()*nzI*nzJ); + // Filter xv-covariance + trans_->filterCov(Lf_, xvCovField); + } - // Read data - const std::string regFieldName = fieldName("reg", outputVar, inputVar); - if ((retval = nc_inq_varid(ncid, regFieldName.c_str(), &varid))) - ERR(retval, regFieldName); - if ((retval = nc_get_var_double(ncid, varid, vecGlb.data()))) ERR(retval, regFieldName); + // Compute regression + computeRegression(row.inputVars.value(), outputVar); - // Copy data - for (size_t jw = 0; jw < trans_->nw(); ++jw) { - const size_t jwGlb = jw + trans_->nwStart(); + // Update ensemble members + for (const auto & inputVarName : row.inputVars.value()) { + // Get input variable + const oops::Variable inputVar = balVars_[inputVarName]; + + // Get number of input levels + const size_t nzJ = inputVar.getLevels(); + + // Get regression view + const auto regView = getView3D("reg", outputVar, inputVar, data_); + + for (size_t je = 0; je < ne; ++je) { + // Get member views + const auto inputUnbalView = getView2D(inputVar, fsetEnsUnbal[je]); + auto outputUnbalView = getView2D(outputVar, fsetEnsUnbal[je]); + + // Unbalance perturbation + for (size_t js = 0; js < trans_->ns(); ++js) { + const size_t jw = trans_->jw(js); for (size_t jzI = 0; jzI < nzI; ++jzI) { for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { - const size_t jj = jw*nzI*nzJ + jzI*nzJ + jzJ; - const size_t jjGlb = jwGlb*nzI*nzJ + jzI*nzJ + jzJ; - vec[jj] = vecGlb[jjGlb]; + outputUnbalView(js, jzI) -= regView(jw, jzI, jzJ)*inputUnbalView(js, jzJ); } } } + } + } - // Send data - int tag = tagRoot; - for (size_t jt = 1; jt < comm_.size(); ++jt) { - // Create vector - std::vector vecSend(trans_->nwPerTask()[jt]*nzI*nzJ); - - // Fill vector - for (size_t jwSend = 0; jwSend < trans_->nwPerTask()[jt]; ++jwSend) { - const size_t jwGlb = jwSend + trans_->nwStartPerTask()[jt]; - for (size_t jzI = 0; jzI < nzI; ++jzI) { - for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { - const size_t jjSend = jwSend*nzI*nzJ + jzI*nzJ + jzJ; - const size_t jjGlb = jwGlb*nzI*nzJ + jzI*nzJ + jzJ; - vecSend[jjSend] = vecGlb[jjGlb]; + if (outputVar.name() != balVars_.variables().back()) { + // vv-covariance variables + std::vector vvCovVars = row.inputVars.value(); + vvCovVars.push_back(outputVar.name()); + + for (const auto & inputVarName : vvCovVars) { + // Get input variable + const oops::Variable inputVar = balVars_[inputVarName]; + + // Get number of input levels + const size_t nzJ = inputVar.getLevels(); + + // Create vv-covariance field + createField3D("vvCov", trans_->nw(), outputVar, inputVar, data_); + + // Get vv-covariance view + auto vvCovView = getView3D("vvCov", outputVar, inputVar, data_); + + // Loop over ensemble members + for (size_t je = 0; je < ne; ++je) { + // Get member views + const auto inputUnbalView = getView2D(inputVar, fsetEnsUnbal[je]); + const auto outputUnbalView = getView2D(outputVar, fsetEnsUnbal[je]); + + // Update vv-covariance + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + if (trans_->includeWavenumber(js, jw)) { + const double factor = trans_->spNorm(js); + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + vvCovView(jw, jzI, jzJ) += factor*inputUnbalView(js, jzJ) + *outputUnbalView(js, jzI); + } + } } } } + } - // Send vector - comm_.send(vecSend.data(), trans_->nwPerTask()[jt]*nzI*nzJ, jt, tag); + // Get vv-covariance field + auto vvCovField = getField("vvCov", outputVar, inputVar, data_); - // Update tag - ++tag; - } - } + // Reduce and normalize vv-covariance + trans_->reduceNormalizeCov(ne-1, vvCovField); - if (comm_.rank() > 0) { - // Receive vector - comm_.receive(vec.data(), trans_->nw()*nzI*nzJ, 0, tagRoot+(comm_.rank()-1)); + // Filter vv-covariance + trans_->filterCov(Lf_, vvCovField); } + } + } + } - // MPI barrier - comm_.barrier(); + // Print norms + print(oops::Log::test()); - // Deserialize - for (size_t jw = 0; jw < trans_->nw(); ++jw) { - for (size_t jzI = 0; jzI < nzI; ++jzI) { - for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { - const size_t jj = jw*nzI*nzJ + jzI*nzJ + jzJ; - regView(jw, jzI, jzJ) = vec[jj]; + oops::Log::trace() << classname() << "::directCalibration done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierBalance::iterativeCalibrationInit() { + oops::Log::trace() << classname() << "::iterativeCalibrationInit starting" << std::endl; + + // Initialize iterative counters with zeroes + iterativeN_ = 0; + + for (const auto & outputVar : balVars_) { + // Create perturbation field + createField2D("pert", trans_->ns(), outputVar, data_); + + // Create mean field + createField2D("mean", trans_->ns(), outputVar, data_); + + for (const auto & inputVar : balVars_) { + if (balVars_.find(inputVar.name()) <= balVars_.find(outputVar.name())) { + // Create xx-covariance field + createField3D("xxCov", trans_->nw(), outputVar, inputVar, data_); + } + } + } + + oops::Log::trace() << classname() << "::iterativeCalibrationInit done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierBalance::iterativeCalibrationUpdate(const oops::FieldSet3D & fset) { + oops::Log::trace() << classname() << "::iterativeCalibrationUpdate starting" << std::endl; + + // Increment ensemble index (ie = ie + 1) + iterativeN_++; + + // Sub-ensemble index + const size_t ie = (params_.calibration.value()->subEnsSize.value() > 0) ? + ((iterativeN_-1)%params_.calibration.value()->subEnsSize.value())+1 : iterativeN_; + + for (const auto & outputVar : balVars_) { + // Get number of output levels + const size_t nzI = outputVar.getLevels(); + + // Get member view + const auto view = getView2D(outputVar, fset); + + // Get perturbation view + auto outputPertView = getView2D("pert", outputVar, data_); + + // Get mean view + auto meanView = getView2D("mean", outputVar, data_); + + if (ie == 1) { + // Reset mean if a new sub-ensemble starts + meanView.assign(0.0); + } + + // Remove mean (pert = state - mean) + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jzI = 0; jzI < nzI; ++jzI) { + outputPertView(js, jzI) = view(js, jzI) - meanView(js, jzI); + } + } + + for (const auto & inputVar : balVars_) { + // Get number of input levels + const size_t nzJ = inputVar.getLevels(); + + if (balVars_.find(inputVar.name()) <= balVars_.find(outputVar.name())) { + // Get input perturbation view + const auto inputPertView = getView2D("pert", inputVar, data_); + + if (ie > 1) { + // Get xx-covariance view + auto xxCovView = getView3D("xxCov", outputVar, inputVar, data_); + + // Update xx-covariance (cov = cov + (ie-1)/ie * inputPert * outputPert) + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + if (trans_->includeWavenumber(js, jw)) { + const double factor = static_cast(ie-1)/static_cast(ie) + *trans_->spNorm(js); + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + xxCovView(jw, jzI, jzJ) += factor*inputPertView(js, jzJ) + *outputPertView(js, jzI); + } + } + } } } } + } + } - // Update tag root - tagRoot += comm_.size(); + // Update mean (mean = mean + 1 / ie * pert) + const double factor = 1.0/static_cast(ie); + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jzI = 0; jzI < nzI; ++jzI) { + meanView(js, jzI) += factor*outputPertView(js, jzI); } } + } - if (comm_.rank() == 0) { - // Close file - if ((retval = nc_close(ncid))) ERR(retval, ncFilePath); + oops::Log::trace() << classname() << "::iterativeCalibrationUpdate done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierBalance::iterativeCalibrationFinal() { + oops::Log::trace() << classname() << "::iterativeCalibrationFinal starting" << std::endl; + + // Compute number of sub-ensembles + size_t nSubEns = 1; + if (params_.calibration.value()->subEnsSize.value() > 0) { + // Check sub-ensembles size + ASSERT(iterativeN_%params_.calibration.value()->subEnsSize.value() == 0); + + // Get number of sub-ensembles + nSubEns = iterativeN_/params_.calibration.value()->subEnsSize.value(); + } + + for (const auto & outputVar : balVars_) { + for (const auto & inputVar : balVars_) { + if (balVars_.find(inputVar.name()) <= balVars_.find(outputVar.name())) { + // Get xx-covariance field + auto xxCovField = getField("xxCov", outputVar, inputVar, data_); + + // Reduce and normalize xx-covariance + trans_->reduceNormalizeCov(iterativeN_-nSubEns, xxCovField); + } } } - oops::Log::trace() << classname() << "::read done" << std::endl; + // Compute regressions from xx-covariances + computeRegressionsFromCovariances(); + + // Print norms + print(oops::Log::test()); + + oops::Log::trace() << classname() << "::iterativeCalibrationFinal done" << std::endl; } // ----------------------------------------------------------------------------- @@ -367,42 +652,94 @@ void BifourierBalance::read() { void BifourierBalance::write() const { oops::Log::trace() << classname() << "::write starting" << std::endl; - // Check that output file is present - ASSERT(params_.outputFile.value() != boost::none); + if (params_.write.value() != boost::none) { + // Number of covariance blocks + const size_t nCov = balVars_.size()*(balVars_.size()+1)/2; - // NetCDF IDs - int retval, ncid, nwGlb_id, d3D_id[3], nzI_id[balVars_.size()], nzJ_id[balVars_.size()], - reg_id[nCmp_]; + // NetCDF IDs + int retval, ncId, nwGlbId, d3DId[3], nzIId[balVars_.size()], nzJId[balVars_.size()], + regId[nCmp_], covId[nCov]; - // NetCDF file path - const std::string ncFilePath = *params_.outputFile.value(); + // NetCDF file path + const std::string ncFilePath = params_.write.value()->outputFile.value(); - // Definition mode - size_t jCmp = 0; + // Definition mode + size_t jCmp = 0; + size_t jCov = 0; - if (comm_.rank() == 0) { - // Create NetCDF file - if ((retval = nc_create(ncFilePath.c_str(), NC_64BIT_OFFSET | NC_CLOBBER, &ncid))) - ERR(retval, ncFilePath); - - // Create horizontal dimension - if ((retval = nc_def_dim(ncid, "nwGlb", trans_->nwGlb(), &nwGlb_id))) ERR(retval, "nwGlb"); - - // Create vertical dimensions - for (const auto & var : balVars_) { - // Get number of levels - const size_t nz = var.getLevels(); - - // Create dimensions - const size_t jvar = balVars_.find(var.name()); - const std::string nzIName = "nzI_" + var.name(); - const std::string nzJName = "nzJ_" + var.name(); - if ((retval = nc_def_dim(ncid, nzIName.c_str(), nz, &nzI_id[jvar]))) ERR(retval, nzIName); - if ((retval = nc_def_dim(ncid, nzJName.c_str(), nz, &nzJ_id[jvar]))) ERR(retval, nzJName); + if (comm_.rank() == 0) { + // Create NetCDF file + if ((retval = nc_create(ncFilePath.c_str(), NC_64BIT_OFFSET | NC_CLOBBER, &ncId))) + ERR(retval, ncFilePath); + + // Create horizontal dimension + if ((retval = nc_def_dim(ncId, "nwGlb", trans_->nwGlb(), &nwGlbId))) ERR(retval, "nwGlb"); + + // Create vertical dimensions + for (const auto & var : balVars_) { + // Get number of levels + const size_t nz = var.getLevels(); + + // Create dimensions + const size_t jvar = balVars_.find(var.name()); + const std::string nzIName = "nzI_" + var.name(); + const std::string nzJName = "nzJ_" + var.name(); + if ((retval = nc_def_dim(ncId, nzIName.c_str(), nz, &nzIId[jvar]))) ERR(retval, nzIName); + if ((retval = nc_def_dim(ncId, nzJName.c_str(), nz, &nzJId[jvar]))) ERR(retval, nzJName); + } + + // Dimensions arrays, horizontal part + d3DId[0] = nwGlbId; + + for (const auto & row : params_.rows.value()) { + // Get output variable + const oops::Variable outputVar = balVars_[row.outputVar.value()]; + + for (const auto & inputVarName : row.inputVars.value()) { + // Get input variable + const oops::Variable inputVar = balVars_[inputVarName]; + + // Dimensions array, vertical part + const size_t jvarI = balVars_.find(outputVar.name()); + const size_t jvarJ = balVars_.find(inputVar.name()); + d3DId[1] = nzIId[jvarI]; + d3DId[2] = nzJId[jvarJ]; + + // Define variable + const std::string regFieldName = fieldName("reg", outputVar, inputVar); + if ((retval = nc_def_var(ncId, regFieldName.c_str(), NC_DOUBLE, 3, d3DId, + ®Id[jCmp]))) ERR(retval, regFieldName); + ++jCmp; + } + } + + if (params_.write.value()->writeCovariance.value()) { + for (const auto & outputVar : balVars_) { + for (const auto & inputVar : balVars_) { + if (balVars_.find(inputVar.name()) <= balVars_.find(outputVar.name())) { + // Dimensions array, vertical part + const size_t jvarI = balVars_.find(outputVar.name()); + const size_t jvarJ = balVars_.find(inputVar.name()); + d3DId[1] = nzIId[jvarI]; + d3DId[2] = nzJId[jvarJ]; + + // Define variable + const std::string xxCovFieldName = fieldName("xxCov", outputVar, inputVar); + if ((retval = nc_def_var(ncId, xxCovFieldName.c_str(), NC_DOUBLE, 3, d3DId, + &covId[jCov]))) ERR(retval, xxCovFieldName); + ++jCov; + } + } + } + } + + // End definition mode + if ((retval = nc_enddef(ncId))) ERR(retval, ncFilePath); } - // Dimensions arrays, horizontal part - d3D_id[0] = nwGlb_id; + // Data mode + jCmp = 0; + jCov = 0; for (const auto & row : params_.rows.value()) { // Get output variable @@ -412,26 +749,366 @@ void BifourierBalance::write() const { // Get input variable const oops::Variable inputVar = balVars_[inputVarName]; - // Dimensions array, vertical part - const size_t jvarI = balVars_.find(outputVar.name()); - const size_t jvarJ = balVars_.find(inputVar.name()); - d3D_id[1] = nzI_id[jvarI]; - d3D_id[2] = nzJ_id[jvarJ]; + // Get regression field + const auto regField = getField("reg", outputVar, inputVar, data_); - // Define variable - const std::string regFieldName = fieldName("reg", outputVar, inputVar); - if ((retval = nc_def_var(ncid, regFieldName.c_str(), NC_DOUBLE, 3, d3D_id, ®_id[jCmp]))) - ERR(retval, regFieldName); - ++jCmp; + // Allocate global regression vector + std::vector regVecGlb; + + // Gather regression vector + trans_->gatherCov(regField, regVecGlb); + + if (comm_.rank() == 0) { + // Write data + const std::string regFieldName = fieldName("reg", outputVar, inputVar); + if ((retval = nc_put_var_double(ncId, regId[jCmp], regVecGlb.data()))) + ERR(retval, regFieldName); + ++jCmp; + } + } + } + + if (params_.write.value()->writeCovariance.value()) { + for (const auto & outputVar : balVars_) { + for (const auto & inputVar : balVars_) { + if (balVars_.find(inputVar.name()) <= balVars_.find(outputVar.name())) { + // Get covariance field + const auto xxCovField = getField("xxCov", outputVar, inputVar, data_); + + // Define global covariance vector + std::vector covVecGlb; + + // Gather covarianc vector + trans_->gatherCov(xxCovField, covVecGlb); + + if (comm_.rank() == 0) { + // Write data + const std::string xxCovFieldName = fieldName("xxCov", outputVar, inputVar); + if ((retval = nc_put_var_double(ncId, covId[jCov], covVecGlb.data()))) + ERR(retval, xxCovFieldName); + ++jCov; + } + } + } + } + } + + if (comm_.rank() == 0) { + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + } + + oops::Log::trace() << classname() << "::write done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierBalance::readCovariance() { + oops::Log::trace() << classname() << "::readCovariance starting" << std::endl; + + for (const auto & outputVar : balVars_) { + for (const auto & inputVar : balVars_) { + if (balVars_.find(inputVar.name()) <= balVars_.find(outputVar.name())) { + // Create old xx-covariance field + createField3D("xxOldCov", trans_->nw(), outputVar, inputVar, data_); + } + } + } + + // NetCDF file path + const std::string ncFilePath = *params_.calibration.value()->oldCovInputFile.value(); + + // NetCDF IDs + int ncId, retval, nwGlbId, nzIId, nzJId, varId; + size_t nwGlbFromFile, nzIFromFile, nzJFromFile; + + if (comm_.rank() == 0) { + // Open NetCDF file + if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncId))) ERR(retval, ncFilePath); + } + + for (const auto & outputVar : balVars_) { + // Get number of output levels + const size_t nzI = outputVar.getLevels(); + + for (const auto & inputVar : balVars_) { + if (balVars_.find(inputVar.name()) <= balVars_.find(outputVar.name())) { + // Get number of input levels + const size_t nzJ = inputVar.getLevels(); + + // Define global covariance vector + std::vector covVecGlb; + + if (comm_.rank() == 0) { + // Check dimensions + const std::string nzIName = "nzI_" + outputVar.name(); + const std::string nzJName = "nzJ_" + inputVar.name(); + if ((retval = nc_inq_dimid(ncId, "nwGlb", &nwGlbId))) ERR(retval, "nwGlb"); + if ((retval = nc_inq_dimid(ncId, nzIName.c_str(), &nzIId))) ERR(retval, nzIName); + if ((retval = nc_inq_dimid(ncId, nzJName.c_str(), &nzJId))) ERR(retval, nzJName); + if ((retval = nc_inq_dimlen(ncId, nwGlbId, &nwGlbFromFile))) ERR(retval, "nwGlb"); + if ((retval = nc_inq_dimlen(ncId, nzIId, &nzIFromFile))) ERR(retval, nzIName); + if ((retval = nc_inq_dimlen(ncId, nzJId, &nzJFromFile))) ERR(retval, nzJName); + ASSERT(nwGlbFromFile == trans_->nwGlb()); + ASSERT(nzIFromFile == nzI); + ASSERT(nzJFromFile == nzJ); + + // Allocate global covariance vector + covVecGlb.resize(trans_->nwGlb()*nzI*nzJ); + + // Read data + const std::string xxCovFieldName = fieldName("xxCov", outputVar, inputVar); + if ((retval = nc_inq_varid(ncId, xxCovFieldName.c_str(), &varId))) + ERR(retval, xxCovFieldName); + if ((retval = nc_get_var_double(ncId, varId, covVecGlb.data()))) + ERR(retval, xxCovFieldName); + } + + // Get old xx-covariance field + auto xxOldCovField = getField("xxOldCov", outputVar, inputVar, data_); + + // Scatter covariance vector + trans_->scatterCov(covVecGlb, xxOldCovField); } } + } + + if (comm_.rank() == 0) { + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + + oops::Log::trace() << classname() << "::readCovariance done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierBalance::computeRegression(const std::vector & inputVars, + const oops::Variable & outputVar) { + oops::Log::trace() << classname() << "::computeRegression starting" << std::endl; + + if (inputVars.size() == 0) { + // Noting to do + oops::Log::trace() << classname() << "::computeRegression done" << std::endl; + return; + } + + // Initialize aggregated size + size_t nzJagg = 0; + + for (const auto & inputVarName : inputVars) { + // Get input variable + const oops::Variable inputVar = balVars_[inputVarName]; + + // Get number of levels + const size_t nzJ = inputVar.getLevels(); + + // Update aggregated number of levels + nzJagg += nzJ; + + // Create regression field + createField3D("reg", trans_->nw(), outputVar, inputVar, data_); + } + + // Get number of levels + const size_t nzI = outputVar.getLevels(); + + // Create eigen matrices + Eigen::MatrixXd vvCovMat(nzJagg, nzJagg); + Eigen::MatrixXd xvCovMat(nzI, nzJagg); + Eigen::MatrixXd regMat(nzI, nzJagg); + + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + // Get total wavenumber + const size_t jwGlb = jw + trans_->nwStart(); - // End definition mode - if ((retval = nc_enddef(ncid))) ERR(retval, ncFilePath); + if (jwGlb == 0) { + // No regression + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJagg; ++jzJ) { + regMat(jzI, jzJ) = 0.0; + } + } + } else { + // Initialize aggregated offset + size_t dzJIagg = 0; + + for (const auto & inputVarIName : inputVars) { + // Get input variable + const oops::Variable inputVarI = balVars_[inputVarIName]; + + // Get number of levels + const size_t nzJI = inputVarI.getLevels(); + + // Initialize aggregated offset + size_t dzJJagg = 0; + + for (const auto & inputVarJName : inputVars) { + if (balVars_.find(inputVarJName) <= balVars_.find(inputVarIName)) { + // Get input variable + const oops::Variable inputVarJ = balVars_[inputVarJName]; + + // Get number of levels + const size_t nzJJ = inputVarJ.getLevels(); + + // Get vv-covariance view + const auto vvCovView = getView3D("vvCov", inputVarI, inputVarJ, data_); + + // Convert to Eigen format + for (size_t jzJI = 0; jzJI < nzJI; ++jzJI) { + for (size_t jzJJ = 0; jzJJ < nzJJ; ++jzJJ) { + vvCovMat(dzJIagg+jzJI, dzJJagg+jzJJ) = vvCovView(jw, jzJI, jzJJ); + vvCovMat(dzJJagg+jzJJ, dzJIagg+jzJI) = vvCovMat(dzJIagg+jzJI, dzJJagg+jzJJ); + } + } + + // Update aggregated offset + dzJJagg += nzJJ; + } + } + + // Get xv-covariance view + const auto xvCovView = getView3D("xvCov", outputVar, inputVarI, data_); + + // Convert to Eigen format + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJI; ++jzJ) { + xvCovMat(jzI, dzJIagg+jzJ) = xvCovView(jw, jzI, jzJ); + } + } + + // Update aggregated offset + dzJIagg += nzJI; + } + + // Solve linear regression problem + if (params_.calibration.value()->remainingVar.value() < 1.0) { + // Split standard-deviation and correlation + Eigen::VectorXd stdDevInv(nzJagg); + for (size_t jzJ = 0; jzJ < nzJagg; ++jzJ) { + ASSERT(vvCovMat(jzJ, jzJ) > 0.0); + stdDevInv[jzJ] = 1.0/std::sqrt(vvCovMat(jzJ, jzJ)); + } + for (size_t jzJI = 0; jzJI < nzJagg; ++jzJI) { + for (size_t jzJJ = 0; jzJJ < nzJagg; ++jzJJ) { + vvCovMat(jzJI, jzJJ) *= stdDevInv[jzJI]*stdDevInv[jzJJ]; + } + } + + // Eigendecomposition to keep only a fraction of the spectrum variance + Eigen::SelfAdjointEigenSolver es; + es.compute(vvCovMat); + Eigen::VectorXd d = es.eigenvalues(); + Eigen::MatrixXd V = es.eigenvectors(); + Eigen::MatrixXd vvCovInvMat = Eigen::MatrixXd::Zero(nzJagg, nzJagg); + double spectrumVarianceTarget = 0.0; + for (int jzJ = nzJagg-1; jzJ >= 0; --jzJ) { + spectrumVarianceTarget += d[jzJ]; + } + spectrumVarianceTarget *= params_.calibration.value()->remainingVar.value(); + double spectrumVariance = 0.0; + for (int jzJ = nzJagg-1; jzJ >= 0; --jzJ) { + spectrumVariance += d[jzJ]; + if (spectrumVariance > spectrumVarianceTarget) { + d[jzJ] = 0.0; + } else { + ASSERT(d[jzJ] > 0.0); + d[jzJ] = 1.0/d[jzJ]; + } + } + vvCovInvMat = stdDevInv.asDiagonal()*V*d.asDiagonal()*V.transpose() + *stdDevInv.asDiagonal(); + regMat = xvCovMat*vvCovInvMat; + } else { + // Direct inversion + regMat = (vvCovMat.selfadjointView().ldlt().solve(xvCovMat.transpose())) + .transpose(); + } + + // Initialize aggregated offset + size_t dzJagg = 0; + + for (const auto & inputVarName : inputVars) { + // Get input variable + const oops::Variable inputVar = balVars_[inputVarName]; + + // Get number of levels + const size_t nzJ = inputVar.getLevels(); + + // Get regression view + auto regView = getView3D("reg", outputVar, inputVar, data_); + + // Copy to fields + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + regView(jw, jzI, jzJ) = regMat(jzI, dzJagg+jzJ); + } + } + + // Update aggregated offset + dzJagg += nzJ; + } + } } - // Data mode - jCmp = 0; + oops::Log::trace() << classname() << "::computeRegression done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierBalance::computeRegressionsFromCovariances() { + oops::Log::trace() << classname() << "::computeRegressionsFromCovariances starting" + << std::endl; + + // Combine xx-covariance with an old xx-covariance + if (params_.calibration.value() != boost::none) { + if (params_.calibration.value()->oldCovInputFile.value() != boost::none) { + // Check parameters consistency + ASSERT(params_.calibration.value()->halfLife.value() != boost::none); + + // Read old xx-covariance + readCovariance(); + + // Define update factor + const double halfLife = *params_.calibration.value()->halfLife.value(); + const double alphaInf = 1.0-std::exp(-std::log(2.0)/halfLife); + double updateFactor = alphaInf; + if (params_.calibration.value()->cycleIndex.value() != boost::none) { + const size_t cycleIndex = *params_.calibration.value()->cycleIndex.value(); + ASSERT(cycleIndex > 0); + updateFactor /= 1.0-std::pow(1.0-alphaInf, static_cast(cycleIndex+1)); + } + + for (const auto & outputVar : balVars_) { + // Get number of output levels + const size_t nzI = outputVar.getLevels(); + + for (const auto & inputVar : balVars_) { + if (balVars_.find(inputVar.name()) <= balVars_.find(outputVar.name())) { + // Get number of input levels + const size_t nzJ = inputVar.getLevels(); + + // Get old xx-covariance view + const auto xxOldCovView = getView3D("xxOldCov", outputVar, inputVar, data_); + + // Get xx-covariance view + auto xxCovView = getView3D("xxCov", outputVar, inputVar, data_); + + // Combine xx-covariances + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + xxCovView(jw, jzI, jzJ) = updateFactor*xxCovView(jw, jzI, jzJ) + + (1.0-updateFactor)*xxOldCovView(jw, jzI, jzJ); + } + } + } + } + } + } + } + } for (const auto & row : params_.rows.value()) { // Get output variable @@ -447,57 +1124,250 @@ void BifourierBalance::write() const { // Get number of input levels const size_t nzJ = inputVar.getLevels(); - // Get regression view - auto regView = getView3D("reg", outputVar, inputVar, data_); + // Create xv-covariance field + createField3D("xvCov", trans_->nw(), outputVar, inputVar, data_); - // Serialize - std::vector vec(trans_->nwRoot()*nzI*nzJ); - for (size_t jw = 0; jw < trans_->nwRoot(); ++jw) { - for (size_t jzI = 0; jzI < nzI; ++jzI) { - for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { - const size_t jj = jw*nzI*nzJ + jzI*nzJ + jzJ; - vec[jj] = regView(jw, jzI, jzJ); + // Get xv-covariance view + auto xvCovView = getView3D("xvCov", outputVar, inputVar, data_); + + // Compute xv-covariance + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + // Using documentation indices + const size_t jvarI = balVars_.find(outputVar.name()); + const size_t jvarJ = balVars_.find(inputVar.name()); + + for (size_t jvarK = 0; jvarK <= jvarJ; ++jvarK) { + // Get number of levels + const size_t nzK = balVars_[jvarK].getLevels(); + + // Get xx-covariance view + const auto xxCovView = getView3D("xxCov", balVars_[jvarI], balVars_[jvarK], data_); + + if (jvarK == jvarJ) { + // Identity A matrix + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + xvCovView(jw, jzI, jzJ) += xxCovView(jw, jzI, jzJ); + } + } + } else { + // Get A matrix view + const auto aView = getView3D("a", balVars_[jvarJ], balVars_[jvarK], data_); + + // Matrix multiplication + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + for (size_t jzK = 0; jzK < nzK; ++jzK) { + xvCovView(jw, jzI, jzJ) += xxCovView(jw, jzI, jzK)*aView(jw, jzJ, jzK); + } + } + } } } } - // Define global vector - std::vector vecGlb; - if (comm_.rank() == 0) { - vecGlb.resize(trans_->nwGlb()*nzI*nzJ); - } + // Get xv-covariance field + auto xvCovField = getField("xvCov", outputVar, inputVar, data_); - // Gather vector - std::vector wCounts(trans_->wCounts()); - std::vector wDispls(trans_->wDispls()); - for (size_t jt = 0; jt < comm_.size(); ++jt) { - wCounts[jt] *= nzI*nzJ; - wDispls[jt] *= nzI*nzJ; - } - comm_.gatherv(vec.cbegin(), vec.cend(), vecGlb.begin(), vecGlb.end(), wCounts, wDispls, 0); + // Filter xv-covariance + trans_->filterCov(Lf_, xvCovField); + } - if (comm_.rank() == 0) { - // Write data - const std::string regFieldName = fieldName("reg", outputVar, inputVar); - if ((retval = nc_put_var_double(ncid, reg_id[jCmp], vecGlb.data()))) - ERR(retval, regFieldName); - ++jCmp; + // Compute regression + computeRegression(row.inputVars.value(), outputVar); + + // Compute A matrix + for (const auto & inputVar : balVars_) { + // Get number of input levels + const size_t nzJ = inputVar.getLevels(); + + if (balVars_.find(inputVar.name()) < balVars_.find(outputVar.name())) { + // Create A matrix field + createField3D("a", trans_->nw(), outputVar, inputVar, data_); + + // Get A matrix view + auto aView = getView3D("a", outputVar, inputVar, data_); + + // Compute A matrix + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + // Using documentation indices + const size_t jvarI = balVars_.find(outputVar.name()); + const size_t jvarJ = balVars_.find(inputVar.name()); + for (size_t jvarK = jvarJ; jvarK <= jvarI-1; ++jvarK) { + // Get number of levels + const size_t nzK = balVars_[jvarK].getLevels(); + + // Get regression field name + const std::string regFieldName = fieldName("reg", outputVar, inputVar); + + if (data_.has(regFieldName)) { + // Get regression view + const auto regView = getView3D("reg", balVars_[jvarI], balVars_[jvarK], data_); + + if (jvarK == jvarJ) { + // Identity temporary A matrix + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + aView(jw, jzI, jzJ) -= regView(jw, jzI, jzJ); + } + } + } else { + // Get temporary A matrix view + const auto tmpAView = getView3D("a", balVars_[jvarK], balVars_[jvarJ], data_); + + // Matrix multiplication + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + for (size_t jzK = 0; jzK < nzK; ++jzK) { + aView(jw, jzI, jzJ) -= regView(jw, jzI, jzK)*tmpAView(jw, jzK, jzJ); + } + } + } + } + } + } + } } } - } - if (comm_.rank() == 0) { - // Close file - if ((retval = nc_close(ncid))) ERR(retval, ncFilePath); + if (outputVar.name() != balVars_.variables().back()) { + // vv-covariance variables + std::vector vvCovVars = row.inputVars.value(); + vvCovVars.push_back(outputVar.name()); + + for (const auto & inputVarName : vvCovVars) { + // Get input variable + const oops::Variable inputVar = balVars_[inputVarName]; + + // Get number of input levels + const size_t nzJ = inputVar.getLevels(); + + // Create vv-covariance field + createField3D("vvCov", trans_->nw(), outputVar, inputVar, data_); + + // Get vv-covariance view + auto vvCovView = getView3D("vvCov", outputVar, inputVar, data_); + + // Compute vv-covariance + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + // Using documentation indices + const size_t jvarI = balVars_.find(outputVar.name()); + const size_t jvarJ = balVars_.find(inputVarName); + for (size_t jvarK = 0; jvarK <= jvarI; ++jvarK) { + // Get number of levels + const size_t nzK = balVars_[jvarK].getLevels(); + + // Create temporary matrix field + atlas::Field tmpField("tmp", make_datatype(), make_shape(nzK, nzJ)); + + // Get temporary matrix view + auto tmpView = make_view(tmpField); + + // Initialize temporary matrix + tmpView.assign(0.0); + + for (size_t jvarL = 0; jvarL <= jvarJ; ++jvarL) { + // First product + + // Get number of levels + const size_t nzL = balVars_[jvarL].getLevels(); + + // Check whether the xx-covariance ajoint should be used + const bool useAdjoint = jvarK < jvarL; + + // Get xx-covariance view + const auto xxCovView = useAdjoint ? + getView3D("xxCov", balVars_[jvarL], balVars_[jvarK], data_) : + getView3D("xxCov", balVars_[jvarK], balVars_[jvarL], data_); + + // Update temporary matrix + if (jvarL == jvarJ) { + // Identity A matrix + for (size_t jzK = 0; jzK < nzK; ++jzK) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + if (useAdjoint) { + tmpView(jzK, jzJ) += xxCovView(jw, jzJ, jzK); + } else { + tmpView(jzK, jzJ) += xxCovView(jw, jzK, jzJ); + } + } + } + } else { + // Get A matrix view + const auto aView = getView3D("a", balVars_[jvarJ], balVars_[jvarL], data_); + + // Matrix multiplication + for (size_t jzK = 0; jzK < nzK; ++jzK) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + for (size_t jzL = 0; jzL < nzL; ++jzL) { + if (useAdjoint) { + tmpView(jzK, jzJ) += xxCovView(jw, jzL, jzK)*aView(jw, jzJ, jzL); + } else { + tmpView(jzK, jzJ) += xxCovView(jw, jzK, jzL)*aView(jw, jzJ, jzL); + } + } + } + } + } + } + + // Second product + if (jvarK == jvarI) { + // Identity A matrix + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + vvCovView(jw, jzI, jzJ) += tmpView(jzI, jzJ); + } + } + } else { + // Get A matrix view + const auto aView = getView3D("a", balVars_[jvarI], balVars_[jvarK], data_); + + // Matrix multiplication + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + for (size_t jzK = 0; jzK < nzK; ++jzK) { + vvCovView(jw, jzI, jzJ) += aView(jw, jzI, jzK)*tmpView(jzK, jzJ); + } + } + } + } + } + } + + // Get vv-covariance field + auto vvCovField = getField("vvCov", outputVar, inputVar, data_); + + // Filter vv-covariance + trans_->filterCov(Lf_, vvCovField); + } + } } - oops::Log::trace() << classname() << "::write done" << std::endl; + oops::Log::trace() << classname() << "::computeRegressionsFromCovariances done" << std::endl; } // ----------------------------------------------------------------------------- void BifourierBalance::print(std::ostream & os) const { - os << classname(); + // Print norms + os << "Regression norms: " << std::endl; + for (const auto & row : params_.rows.value()) { + // Get output variable + const oops::Variable outputVar = balVars_[row.outputVar.value()]; + + for (const auto & inputVarName : row.inputVars.value()) { + // Get input variable + const oops::Variable inputVar = balVars_[inputVarName]; + + // Get regression field + const auto regField = getField("reg", outputVar, inputVar, data_); + + // Print norms + os << "- " << outputVar.name() << " from " << inputVar.name() << ": " + << trans_->normCov(regField) << std::endl; + } + } } // ----------------------------------------------------------------------------- diff --git a/src/saber/bifourier/BifourierBalance.h b/src/saber/bifourier/BifourierBalance.h index 86815a3c4..441786003 100644 --- a/src/saber/bifourier/BifourierBalance.h +++ b/src/saber/bifourier/BifourierBalance.h @@ -15,6 +15,7 @@ #include "oops/base/GeometryData.h" #include "oops/util/parameters/Parameters.h" +#include "saber/bifourier/BifourierTransformBase.h" #include "saber/bifourier/BifourierTransformStore.h" #include "saber/blocks/SaberBlockParametersBase.h" #include "saber/blocks/SaberOuterBlockBase.h" @@ -30,9 +31,47 @@ class BifourierBalanceReadParameters : public oops::Parameters { public: // Input file oops::RequiredParameter inputFile{"input file", this}; +}; + +// ----------------------------------------------------------------------------- + +class BifourierBalanceCalibrationParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(BifourierBalanceCalibrationParameters, oops::Parameters) + + public: + // Use full recursive inverse formula to compute the regression + oops::Parameter fullRecursiveInverse{"full recursive inverse", false, this}; + + // Filtering scale (in total wavenumber unit) + oops::Parameter filteringScale{"filtering scale", 0.0, this}; + + // Remaining variance fraction (between 0 and 1) in the auto-covariance inversion + oops::Parameter remainingVar{"remaining variance fraction", 1.0, this}; + + // Old covariance input file + oops::OptionalParameter oldCovInputFile{"old covariance input file", this}; + + // Half life + oops::OptionalParameter halfLife{"half life", this}; + + // Cycle index + oops::OptionalParameter cycleIndex{"cycle index", this}; + + // Sub-ensembles size + oops::Parameter subEnsSize{"sub-ensembles size", 0, this}; +}; + +// ----------------------------------------------------------------------------- + +class BifourierBalanceWriteParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(BifourierBalanceWriteParameters, oops::Parameters) - // Input file format ("netcdf", "arome legacy binary" or "arome legacy netcdf") - oops::Parameter inputFileFormat{"input file format", "netcdf", this}; + public: + // Output file + oops::RequiredParameter outputFile{"output file", this}; + + // Write covariance flag + oops::Parameter writeCovariance{"write covariance", false, this}; }; // ----------------------------------------------------------------------------- @@ -57,8 +96,11 @@ class BifourierBalanceParameters : public SaberBlockParametersBase { // Read parameters oops::OptionalParameter read{"read", this}; - // Output file - oops::OptionalParameter outputFile{"output file", this}; + // Calibration parameters + oops::OptionalParameter calibration{"calibration", this}; + + // Write parameters + oops::OptionalParameter write{"write", this}; // Rows oops::RequiredParameter> @@ -96,9 +138,15 @@ class BifourierBalance : public SaberOuterBlockBase { void read() override; + void directCalibration(const oops::FieldSets &) override; + + void iterativeCalibrationInit() override; + void iterativeCalibrationUpdate(const oops::FieldSet3D &) override; + void iterativeCalibrationFinal() override; + void write() const override; - private: + protected: // Inner geometry data const oops::GeometryData & innerGeometryData_; @@ -106,14 +154,17 @@ class BifourierBalance : public SaberOuterBlockBase { const eckit::mpi::Comm & comm_; // Inner variables - const oops::Variables & innerVars_; + oops::Variables innerVars_; // Parameters - BifourierBalanceParameters params_; + Parameters_ params_; + + // Filtering length-scale + const double Lf_; // Spectral transform const BifourierTransformStore transStore_; - std::shared_ptr trans_; + const std::shared_ptr trans_; // Ordered variables oops::Variables balVars_; @@ -124,8 +175,21 @@ class BifourierBalance : public SaberOuterBlockBase { // Data atlas::FieldSet data_; + // Interative counter + size_t iterativeN_; + // Private methods + // Read covariance + void readCovariance(); + + // Compute regression + void computeRegression(const std::vector &, + const oops::Variable &); + + // Compute regressions from covariances + void computeRegressionsFromCovariances(); + // Print void print(std::ostream &) const override; }; diff --git a/src/saber/bifourier/BifourierCovariance.cc b/src/saber/bifourier/BifourierCovariance.cc index 190d8e140..438b1eb7d 100644 --- a/src/saber/bifourier/BifourierCovariance.cc +++ b/src/saber/bifourier/BifourierCovariance.cc @@ -10,13 +10,15 @@ #include -#include "saber/bifourier/BifourierAromeLegacy.h" +#include "oops/generic/gc99.h" + #include "saber/bifourier/BifourierUtilities.h" #define ERR(e, msg) {std::string s(nc_strerror(e)); \ throw eckit::Exception(s + " : " + msg, Here());} using atlas::array::make_datatype; +using atlas::array::make_indexview; using atlas::array::make_shape; using atlas::array::make_view; @@ -34,32 +36,16 @@ BifourierCovariance::BifourierCovariance(const oops::GeometryData & gdata, const eckit::Configuration & covarConf, const Parameters_ & params, const oops::FieldSet3D & xb, - const oops::FieldSet3D & fg) : - SaberCentralBlockBase(params, xb.validTime()), + const oops::FieldSet3D & fg) + : SaberCentralBlockBase(params, xb.validTime()), comm_(gdata.comm()), activeVars_(activeVars), - params_(params) + params_(params), + Lf_(params_.calibration.value() != boost::none ? + params_.calibration.value()->filteringScale.value() : 0), + trans_(transStore_.retrieveTransform(gdata)) { oops::Log::trace() << classname() << "::BifourierCovariance starting" << std::endl; - - // Retrieve spectral transform - trans_ = transStore_.retrieveTransform(gdata); - - // Create unified factor field - atlas::Field unifiedFactorField("unifiedFactor", make_datatype(), - make_shape(trans_->ns())); - - // Get unified factor field view - auto unifiedFactorView = make_view(unifiedFactorField); - - for (size_t js = 0; js < trans_->ns(); ++js) { - // Unified factor for ellipses + FFT norm - unifiedFactorView(js) = std::sqrt(trans_->spNorm(js)/trans_->normFFT()); - } - - // Add unified factor field - data_.add(unifiedFactorField); - oops::Log::trace() << classname() << "::BifourierCovariance done" << std::endl; } @@ -76,7 +62,7 @@ void BifourierCovariance::randomize(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::randomize starting" << std::endl; // Create random spectral vector - trans_->createRandomSpectralFieldSet(fset.fieldSet(), activeVars_); + trans_->createRandomFieldSet(fset.fieldSet(), activeVars_); // Define control vector atlas::Field cv("cv", make_datatype(), make_shape(ctlVecSize())); @@ -123,9 +109,6 @@ void BifourierCovariance::multiplySqrt(const atlas::Field & cv, // Convert control vector to spectral FieldSet trans_->cv2fset(cv, fset.fieldSet(), activeVars_, offset); - // Get unified factor view - const auto unifiedFactorView = make_view(data_["unifiedFactor"]); - for (const auto & var : activeVars_) { // Get number of levels const size_t nz = var.getLevels(); @@ -164,13 +147,6 @@ void BifourierCovariance::multiplySqrt(const atlas::Field & cv, } } } - - // Apply unified factor - for (size_t js = 0; js < trans_->ns(); ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - view(js, jz) *= unifiedFactorView(js); - } - } } oops::Log::trace() << classname() << "::multiplySqrt done" << std::endl; @@ -189,9 +165,6 @@ void BifourierCovariance::multiplySqrtAD(const oops::FieldSet3D & fset, // Copy FieldSet trans_->copyFieldSet(fset.fieldSet(), fsetTmp.fieldSet(), activeVars_); - // Get unified factor view - const auto unifiedFactorView = make_view(data_["unifiedFactor"]); - for (const auto & var : activeVars_) { // Get number of levels const size_t nz = var.getLevels(); @@ -212,13 +185,6 @@ void BifourierCovariance::multiplySqrtAD(const oops::FieldSet3D & fset, // Set output field to zero view.assign(0.0); - // Apply unified factor - for (size_t js = 0; js < trans_->ns(); ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - copyView(js, jz) *= unifiedFactorView(js); - } - } - if (!params_.correlation.value()) { // Apply standard-deviation for (size_t js = 0; js < trans_->ns(); ++js) { @@ -258,148 +224,467 @@ void BifourierCovariance::read() { createFieldProfile("stdDev", var, data_); } - // Read data - if (params_.read.value()->inputFileFormat.value() == "arome legacy binary" - || params_.read.value()->inputFileFormat.value() == "arome legacy netcdf") { - arome_legacy::readCovariance(comm_, activeVars_, *params_.read.value(), *trans_, data_); - } else { - // NetCDF file path - const std::string ncFilePath = params_.read.value()->inputFile.value(); + // NetCDF file path + const std::string ncFilePath = params_.read.value()->inputFile.value(); - // NetCDF IDs - int ncid, retval, nw_id, nzI_id, nzJ_id, corSqrt_id, stdDev_id; - size_t nwGlbFromFile, nzIFromFile, nzJFromFile; + // NetCDF IDs + int ncId, retval, nwId, nzIId, nzJId, corSqrtId, stdDevId; + size_t nwGlbFromFile, nzIFromFile, nzJFromFile; + + if (comm_.rank() == 0) { + // Open NetCDF file + if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncId))) ERR(retval, ncFilePath); + } + + for (const auto & var : activeVars_) { + // Get number of levels + const size_t nz = var.getLevels(); + + // Define global vectors + std::vector corSqrtVecGlb; + std::vector stdDevVec(nz); if (comm_.rank() == 0) { - // Open NetCDF file - if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncid))) ERR(retval, ncFilePath); + // Check dimensions + const std::string nzIName = "nzI_" + var.name(); + const std::string nzJName = "nzJ_" + var.name(); + if ((retval = nc_inq_dimid(ncId, "nwGlb", &nwId))) ERR(retval, "nwGlb"); + if ((retval = nc_inq_dimid(ncId, nzIName.c_str(), &nzIId))) ERR(retval, nzIName); + if ((retval = nc_inq_dimid(ncId, nzJName.c_str(), &nzJId))) ERR(retval, nzJName); + if ((retval = nc_inq_dimlen(ncId, nwId, &nwGlbFromFile))) ERR(retval, "nwGlb"); + if ((retval = nc_inq_dimlen(ncId, nzIId, &nzIFromFile))) ERR(retval, nzIName); + if ((retval = nc_inq_dimlen(ncId, nzJId, &nzJFromFile))) ERR(retval, nzJName); + ASSERT(nwGlbFromFile == trans_->nwGlb()); + ASSERT(nzIFromFile == nz); + ASSERT(nzJFromFile == nz); + + // Get correlation square-root field name + const std::string corSqrtFieldName = fieldName("corSqrt", var); + + // Get standard-deviation field name + const std::string stdDevFieldName = fieldName("stdDev", var); + + // Get variables ID + if ((retval = nc_inq_varid(ncId, corSqrtFieldName.c_str(), &corSqrtId))) + ERR(retval, corSqrtFieldName); + if ((retval = nc_inq_varid(ncId, stdDevFieldName.c_str(), &stdDevId))) + ERR(retval, stdDevFieldName); + + // Allocate global correlation square-root vector + corSqrtVecGlb.resize(trans_->nwGlb()*nz*nz); + + // Read data + if ((retval = nc_get_var_double(ncId, corSqrtId, corSqrtVecGlb.data()))) + ERR(retval, corSqrtFieldName); + if ((retval = nc_get_var_double(ncId, stdDevId, stdDevVec.data()))) + ERR(retval, stdDevFieldName); } - // Tag root - size_t tagRoot = 123; + // Get correlation square-root field + auto corSqrtField = getField("corSqrt", var, data_); + + // Scatter correlation square-root vector + trans_->scatterCov(corSqrtVecGlb, corSqrtField); + + // Broadcast standard-deviation vector + comm_.broadcast(stdDevVec.begin(), stdDevVec.end(), 0); + + // Get standard-deviation view + auto stdDevView = getViewProfile("stdDev", var, data_); + + // Deserialize standard-deviation vector + for (size_t jzJ = 0; jzJ < nz; ++jzJ) { + stdDevView(jzJ) = stdDevVec[jzJ]; + } + } + + if (comm_.rank() == 0) { + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + + oops::Log::trace() << classname() << "::read done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierCovariance::directCalibration(const oops::FieldSets & fsetEns) { + oops::Log::trace() << classname() << "::directCalibration starting" << std::endl; + + // Check ensemble size + const size_t ne = fsetEns.ens_size(); + + if (ne == 0) { + // User-defined vertical profile for each variable + + // Index fields views + const atlas::functionspace::StructuredColumns fs(trans_->geometryData().functionSpace()); + const auto indexIView = make_indexview(fs.index_i()); + const auto indexJView = make_indexview(fs.index_j()); + + // Define fieldsets + atlas::FieldSet horCorGpFset; + atlas::FieldSet horCorSpFset; for (const auto & var : activeVars_) { // Get number of levels const size_t nz = var.getLevels(); - // Get correlation square-root view - auto corSqrtView = getView3D("corSqrt", var, data_); + // Get horizontal length-scale profile + std::vector Lh; + for (const auto & profile : params_.calibration.value()->profiles.value()) { + if (profile.variable.value() == var.name()) { + // Check profile size + ASSERT(profile.Lh.value().size() == nz); - // Get standard-deviation view - auto stdDevView = getViewProfile("stdDev", var, data_); + // Allocate profiles + ASSERT(Lh.size() == 0); + Lh.resize(nz); - // Define vector - std::vector corSqrtVec(trans_->nw()*nz*nz); - std::vector stdDevVec(nz); + // Copy horizontal length-scale profile + Lh = profile.Lh.value(); + } + } + ASSERT(Lh.size() == nz); + + // Create horizontal grid-point correlation field + auto horCorField = fs.createField(atlas::option::name(var.name()) + | atlas::option::levels(nz)); + + // Get horizontal grid-point correlation view + auto horCorView = make_view(horCorField); + + // Compute horizontal grid-point correlation + for (int jnode = 0; jnode < fs.size(); ++jnode) { + const double distI = indexIView(jnode) < static_cast(trans_->nx()/2) ? + static_cast(indexIView(jnode))*trans_->dx() : + static_cast(trans_->nx()-indexIView(jnode))*trans_->dx(); + const double distJ = indexJView(jnode) < static_cast(trans_->ny()/2) ? + static_cast(indexJView(jnode))*trans_->dy() : + static_cast(trans_->ny()-indexJView(jnode))*trans_->dy(); + const double dist = std::sqrt(distI*distI+distJ*distJ); + for (size_t jzI = 0; jzI < nz; ++jzI) { + const double normDist = dist/Lh[jzI]; + horCorView(jnode, jzI) = oops::gc99(normDist); + } + } - if (comm_.rank() == 0) { - // Check dimensions - const std::string nzIName = "nzI_" + var.name(); - const std::string nzJName = "nzJ_" + var.name(); - if ((retval = nc_inq_dimid(ncid, "nwGlb", &nw_id))) ERR(retval, "nwGlb"); - if ((retval = nc_inq_dimid(ncid, nzIName.c_str(), &nzI_id))) ERR(retval, nzIName); - if ((retval = nc_inq_dimid(ncid, nzJName.c_str(), &nzJ_id))) ERR(retval, nzJName); - if ((retval = nc_inq_dimlen(ncid, nw_id, &nwGlbFromFile))) ERR(retval, "nwGlb"); - if ((retval = nc_inq_dimlen(ncid, nzI_id, &nzIFromFile))) ERR(retval, nzIName); - if ((retval = nc_inq_dimlen(ncid, nzJ_id, &nzJFromFile))) ERR(retval, nzJName); - ASSERT(nwGlbFromFile == trans_->nwGlb()); - ASSERT(nzIFromFile == nz); - ASSERT(nzJFromFile == nz); - - // Define global vector - std::vector corSqrtVecGlb(trans_->nwGlb()*nz*nz); + // Add field + horCorGpFset.add(horCorField); + } - // Get correlation square-root field name - const std::string corSqrtFieldName = fieldName("corSqrt", var); + // Direct spectral transform of the horizontal grid-point correlation + trans_->gp2sp(horCorGpFset, horCorSpFset, activeVars_); - // Get standard-deviation field name - const std::string stdDevFieldName = fieldName("stdDev", var); + for (const auto & var : activeVars_) { + // Get number of levels + const size_t nz = var.getLevels(); - // Get variables ID - if ((retval = nc_inq_varid(ncid, corSqrtFieldName.c_str(), &corSqrt_id))) - ERR(retval, corSqrtFieldName); - if ((retval = nc_inq_varid(ncid, stdDevFieldName.c_str(), &stdDev_id))) - ERR(retval, stdDevFieldName); + // Create correlation square-root + atlas::Field corSqrtField("corSqrt", make_datatype(), + make_shape(trans_->nw(), nz, nz)); - // Read data - if ((retval = nc_get_var_double(ncid, corSqrt_id, corSqrtVecGlb.data()))) - ERR(retval, corSqrtFieldName); - if ((retval = nc_get_var_double(ncid, stdDev_id, stdDevVec.data()))) - ERR(retval, stdDevFieldName); + // Get correlation square-root view + auto corSqrtView = make_view(corSqrtField); + + // Get horizontal length-scale profile and vertical length-scale + double Lv = 0.0; + for (const auto & profile : params_.calibration.value()->profiles.value()) { + if (profile.variable.value() == var.name()) { + // Copy vertical length-scale + Lv = profile.Lv.value(); + } + } + ASSERT(Lv > 0.0); - // Copy data - for (size_t jw = 0; jw < trans_->nw(); ++jw) { - const size_t jwGlb = jw + trans_->nwStart(); - for (size_t jzI = 0; jzI < nz; ++jzI) { - for (size_t jzJ = 0; jzJ < nz; ++jzJ) { - const size_t index = jw*nz*nz + jzI*nz + jzJ; - const size_t indexGlb = jwGlb*nz*nz + jzI*nz + jzJ; - corSqrtVec[index] = corSqrtVecGlb[indexGlb]; - } - } + // Compute vertical correlation matrix + Eigen::MatrixXd vertCor(nz, nz); + for (size_t jzI = 0; jzI < nz; ++jzI) { + for (size_t jzJ = 0; jzJ < nz; ++jzJ) { + const double normDist = std::abs(static_cast(jzI)-static_cast(jzJ))/Lv; + vertCor(jzI, jzJ) = oops::gc99(normDist); } + } - // Send data - int tag = tagRoot; - for (size_t jt = 1; jt < comm_.size(); ++jt) { - // Create vector - std::vector corSqrtVecSend(trans_->nwPerTask()[jt]*nz*nz); + // Compute eigendecomposition of the vertical correlation matrix + Eigen::SelfAdjointEigenSolver es; + es.compute(vertCor); - // Fill vector - for (size_t jwSend = 0; jwSend < trans_->nwPerTask()[jt]; ++jwSend) { - const size_t jwGlb = jwSend + trans_->nwStartPerTask()[jt]; - for (size_t jzI = 0; jzI < nz; ++jzI) { - for (size_t jzJ = 0; jzJ < nz; ++jzJ) { - const size_t indexSend = jwSend*nz*nz + jzI*nz + jzJ; - const size_t indexGlb = jwGlb*nz*nz + jzI*nz + jzJ; - corSqrtVecSend[indexSend] = corSqrtVecGlb[indexGlb]; - } - } + // Get horizontal correlation in spectral space + const auto horCorSpView = make_view(horCorSpFset[var.name()]); + + // Create horizontal spectral variance field + atlas::Field horSpecVarField("horSpecVar", make_datatype(), + make_shape(trans_->nw(), nz, 1)); + + // Get horizontal spectral variance view + auto horSpecVarView = make_view(horSpecVarField); + + // Set horizontal spectral variance to zero + horSpecVarView.assign(0.0); + + // Compute horizontal spectral variance + for (size_t js = 0; js < trans_->ns(); ++js) { + if (trans_->jq(js) == 0) { + const size_t jw = trans_->jw(js); + for (size_t jzI = 0; jzI < nz; ++jzI) { + horSpecVarView(jw, jzI, 0) += horCorSpView(js, jzI); } + } + } - // Send vector - comm_.send(corSqrtVecSend.data(), trans_->nwPerTask()[jt]*nz*nz, jt, tag); + // Reduce horizontal spectral variance + trans_->reduceCov(horSpecVarField); - // Update tag - ++tag; + // Compute horizontal spectral standard-deviation + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + for (size_t jzI = 0; jzI < nz; ++jzI) { + horSpecVarView(jw, jzI, 0) *= trans_->spNormSumInv(jw); + horSpecVarView(jw, jzI, 0) = std::max(horSpecVarView(jw, jzI, 0), 0.0); + horSpecVarView(jw, jzI, 0) = std::sqrt(horSpecVarView(jw, jzI, 0)); } } - if (comm_.rank() > 0) { - // Receive vector - comm_.receive(corSqrtVec.data(), trans_->nw()*nz*nz, 0, tagRoot+(comm_.rank()-1)); + // Compute correlation square-root + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + for (size_t jzI = 0; jzI < nz; ++jzI) { + for (size_t jzJ = 0; jzJ < nz; ++jzJ) { + corSqrtView(jw, jzI, jzJ) = horSpecVarView(jw, jzI, 0)*es.eigenvectors().col(jzJ)[jzI] + *std::sqrt(es.eigenvalues()[jzJ]); + } + } } - // MPI barrier - comm_.barrier(); + // Create covariance field + createField3D("cov", trans_->nw(), var, data_); - // Broadcast data - comm_.broadcast(stdDevVec.begin(), stdDevVec.end(), 0); + // Get covariance view + auto covView = getView3D("cov", var, data_); - // Deserialize + // Compute covariance matrix for (size_t jw = 0; jw < trans_->nw(); ++jw) { for (size_t jzI = 0; jzI < nz; ++jzI) { for (size_t jzJ = 0; jzJ < nz; ++jzJ) { - const size_t index = jw*nz*nz + jzI*nz + jzJ; - corSqrtView(jw, jzI, jzJ) = corSqrtVec[index]; + for (size_t jz3 = 0; jz3 < nz; ++jz3) { + covView(jw, jzI, jzJ) += corSqrtView(jw, jzI, jz3)*corSqrtView(jw, jzJ, jz3); + } } } } - for (size_t jzJ = 0; jzJ < nz; ++jzJ) { - stdDevView(jzJ) = stdDevVec[jzJ]; + } + } else { + // Ensemble-based calibration + ASSERT(ne > 2); + + for (const auto & var : activeVars_) { + // Get number of levels + const size_t nz = var.getLevels(); + + // Create covariance field + createField3D("cov", trans_->nw(), var, data_); + + // Get covariance view + auto covView = getView3D("cov", var, data_); + + // Loop over ensemble members + for (size_t je = 0; je < ne; ++je) { + // Get view + const auto view = getView2D(var, fsetEns[je]); + + // Update covariance (lower triangle) + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + if (trans_->includeWavenumber(js, jw)) { + const double factor = trans_->spNorm(js); + for (size_t jzI = 0; jzI < nz; ++jzI) { + for (size_t jzJ = 0; jzJ < jzI+1; ++jzJ) { + covView(jw, jzI, jzJ) += factor*view(js, jzJ)*view(js, jzI); + } + } + } + } + } } - // Update tag root - tagRoot += comm_.size(); + // Transpose lower triangle + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + for (size_t jzI = 0; jzI < nz; ++jzI) { + for (size_t jzJ = 0; jzJ < jzI; ++jzJ) { + covView(jw, jzJ, jzI) = covView(jw, jzI, jzJ); + } + } + } + + // Get covariance field + auto covField = getField("cov", var, data_); + + // Reduce and normalize covariance + trans_->reduceNormalizeCov(ne-1, covField); + + // Filter covariance + trans_->filterCov(Lf_, covField); } + } - if (comm_.rank() == 0) { - // Close file - if ((retval = nc_close(ncid))) ERR(retval, ncFilePath); + // Compute square-root + computeSquareRoot(); + + if (ne == 0) { + // Update the standard-deviation + for (const auto & var : activeVars_) { + // Get number of levels + const size_t nz = var.getLevels(); + + // Get standard-deviation profile if present (default = 1.0) + std::vector stdDev(nz, 1.0); + for (const auto & profile : params_.calibration.value()->profiles.value()) { + if (profile.variable.value() == var.name()) { + if (profile.stdDev.value() != boost::none) { + stdDev = *profile.stdDev.value(); + } + } + } + + // Get standard-deviation view + auto stdDevView = getViewProfile("stdDev", var, data_); + + // Copy standard-deviation + for (size_t jzI = 0; jzI < nz; ++jzI) { + stdDevView(jzI) = stdDev[jzI]; + } } } - oops::Log::trace() << classname() << "::read done" << std::endl; + // Print norms + print(oops::Log::test()); + + oops::Log::trace() << classname() << "::directCalibration done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierCovariance::iterativeCalibrationInit() { + oops::Log::trace() << classname() << "::iterativeCalibrationInit starting" << std::endl; + + // Initialize iterative counters with zeroes + iterativeN_ = 0; + + for (const auto & var : activeVars_) { + // Create perturbation field + createField2D("pert", trans_->ns(), var, data_); + + // Create mean field + createField2D("mean", trans_->ns(), var, data_); + + // Create covariance field + createField3D("cov", trans_->nw(), var, data_); + } + + oops::Log::trace() << classname() << "::iterativeCalibrationInit done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierCovariance::iterativeCalibrationUpdate(const oops::FieldSet3D & fset) { + oops::Log::trace() << classname() << "::iterativeCalibrationUpdate starting" << std::endl; + + // Increment ensemble index (ie = ie + 1) + ++iterativeN_; + + // Sub-ensemble index + const size_t ie = (params_.calibration.value()->subEnsSize.value() > 0) ? + ((iterativeN_-1)%params_.calibration.value()->subEnsSize.value())+1 : iterativeN_; + + for (const auto & var : activeVars_) { + // Get number of output levels + const size_t nz = var.getLevels(); + + // Get member view + const auto view = getView2D(var, fset); + + // Get perturbation view + auto pertView = getView2D("pert", var, data_); + + // Get mean view + auto meanView = getView2D("mean", var, data_); + + if (ie == 1) { + // Reset mean if a new sub-ensemble starts + meanView.assign(0.0); + } + + // Remove mean (pert = state - mean) + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jz = 0; jz < nz; ++jz) { + pertView(js, jz) = view(js, jz) - meanView(js, jz); + } + } + + if (ie > 1) { + // Get covariance view + auto covView = getView3D("cov", var, data_); + + // Update covariance (cov = cov + (ie-1)/ie * pert1 * pert2) + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + if (trans_->includeWavenumber(js, jw)) { + const double factor = trans_->spNorm(js) + *static_cast(ie-1)/static_cast(ie); + for (size_t jzI = 0; jzI < nz; ++jzI) { + for (size_t jzJ = 0; jzJ < nz; ++jzJ) { + covView(jw, jzI, jzJ) += factor*pertView(js, jzJ)*pertView(js, jzI); + } + } + } + } + } + } + + // Update mean (mean = mean + 1 / ie * pert) + const double factor = 1.0/static_cast(ie); + for (size_t js = 0; js < trans_->ns(); ++js) { + for (size_t jz = 0; jz < nz; ++jz) { + meanView(js, jz) += factor*pertView(js, jz); + } + } + } + + oops::Log::trace() << classname() << "::iterativeCalibrationUpdate done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierCovariance::iterativeCalibrationFinal() { + oops::Log::trace() << classname() << "::iterativeCalibrationFinal starting" << std::endl; + + // Compute number of sub-ensembles + size_t nSubEns = 1; + if (params_.calibration.value()->subEnsSize.value() > 0) { + // Check sub-ensembles size + ASSERT(iterativeN_%params_.calibration.value()->subEnsSize.value() == 0); + + // Get number of sub-ensembles + nSubEns = iterativeN_/params_.calibration.value()->subEnsSize.value(); + } + + for (const auto & var : activeVars_) { + // Get covariance field + auto covField = getField("cov", var, data_); + + // Reduce and normalize covariance + trans_->reduceNormalizeCov(iterativeN_-nSubEns, covField); + + // Filter covariance + trans_->filterCov(Lf_, covField); + } + + // Compute square-root + computeSquareRoot(); + + // Print norms + print(oops::Log::test()); + + oops::Log::trace() << classname() << "::iterativeCalibrationFinal done" << std::endl; } // ----------------------------------------------------------------------------- @@ -407,134 +692,477 @@ void BifourierCovariance::read() { void BifourierCovariance::write() const { oops::Log::trace() << classname() << "::write starting" << std::endl; - // Check that output file is present - ASSERT(params_.outputFile.value() != boost::none); + if (params_.write.value() != boost::none) { + // Create covariance fieldset + atlas::FieldSet covData; - // NetCDF IDs - int retval, ncid, nw_id, nzI_id, nzJ_id, dStdDev_id[1], dCorSqrt_id[3], - stdDev_id[activeVars_.size()], corSqrt_id[activeVars_.size()]; + if (params_.write.value()->writeCovariance.value()) { + // Compute covariance from correlation square-root and standard-deviation if it is missing + computeCovariance(covData); + } - // NetCDF file path - const std::string ncFilePath = *params_.outputFile.value(); + // NetCDF IDs + int retval, ncId, nwId, nzIId, nzJId, dCorSqrtId[3], dStdDevId[1], dCovId[3], + corSqrtId[activeVars_.size()], stdDevId[activeVars_.size()], covId[activeVars_.size()]; - // Definition mode - size_t jvar = 0; + // NetCDF file path + const std::string ncFilePath = params_.write.value()->outputFile.value(); - if (comm_.rank() == 0) { - // Create NetCDF file - if ((retval = nc_create(ncFilePath.c_str(), NC_64BIT_OFFSET | NC_CLOBBER, &ncid))) - ERR(retval, ncFilePath); + // Definition mode + size_t jvar = 0; + + if (comm_.rank() == 0) { + // Create NetCDF file + if ((retval = nc_create(ncFilePath.c_str(), NC_64BIT_OFFSET | NC_CLOBBER, &ncId))) + ERR(retval, ncFilePath); + + // Create horizontal dimension + if ((retval = nc_def_dim(ncId, "nwGlb", trans_->nwGlb(), &nwId))) + ERR(retval, "nwGlb"); + + // Dimensions arrays, horizontal part + dCorSqrtId[0] = nwId; + dCovId[0] = nwId; + + for (const auto & var : activeVars_) { + // Get number of levels + const size_t nz = var.getLevels(); - // Create horizontal dimension - if ((retval = nc_def_dim(ncid, "nwGlb", trans_->nwGlb(), &nw_id))) - ERR(retval, "nwGlb"); + // Create vertical dimensions + const std::string nzIName = "nzI_" + var.name(); + const std::string nzJName = "nzJ_" + var.name(); + if ((retval = nc_def_dim(ncId, nzIName.c_str(), nz, &nzIId))) ERR(retval, nzIName); + if ((retval = nc_def_dim(ncId, nzJName.c_str(), nz, &nzJId))) ERR(retval, nzJName); + + // Dimensions array, vertical part + dCorSqrtId[1] = nzIId; + dCorSqrtId[2] = nzJId; + dStdDevId[0] = nzIId; + dCovId[1] = nzIId; + dCovId[2] = nzJId; + + // Get correlation square-root field name + const std::string corSqrtFieldName = fieldName("corSqrt", var); + + // Get standard-deviation field name + const std::string stdDevFieldName = fieldName("stdDev", var); + + // Get correlation square-root field name + const std::string covFieldName = fieldName("cov", var); + + // Define variables + if ((retval = nc_def_var(ncId, corSqrtFieldName.c_str(), NC_DOUBLE, 3, dCorSqrtId, + &corSqrtId[jvar]))) ERR(retval, corSqrtFieldName); + if ((retval = nc_def_var(ncId, stdDevFieldName.c_str(), NC_DOUBLE, 1, dStdDevId, + &stdDevId[jvar]))) ERR(retval, stdDevFieldName); + if (params_.write.value()->writeCovariance.value()) { + if ((retval = nc_def_var(ncId, covFieldName.c_str(), NC_DOUBLE, 3, dCovId, + &covId[jvar]))) ERR(retval, covFieldName); + } + + // Update index + ++jvar; + } + + // End definition mode + if ((retval = nc_enddef(ncId))) ERR(retval, ncFilePath); + } - // Dimensions arrays, horizontal part - dCorSqrt_id[0] = nw_id; + // Data mode + jvar = 0; for (const auto & var : activeVars_) { // Get number of levels const size_t nz = var.getLevels(); - // Create vertical dimensions - const std::string nzIName = "nzI_" + var.name(); - const std::string nzJName = "nzJ_" + var.name(); - if ((retval = nc_def_dim(ncid, nzIName.c_str(), nz, &nzI_id))) ERR(retval, nzIName); - if ((retval = nc_def_dim(ncid, nzJName.c_str(), nz, &nzJ_id))) ERR(retval, nzJName); + // Define global vectors + std::vector corSqrtVecGlb; + std::vector stdDevVec; + std::vector covVecGlb; - // Dimensions array, vertical part - dStdDev_id[0] = nzI_id; - dCorSqrt_id[1] = nzI_id; - dCorSqrt_id[2] = nzJ_id; + // Get correlation square-root field + const auto corSqrtField = getField("corSqrt", var, data_); - // Get correlation square-root field name - const std::string corSqrtFieldName = fieldName("corSqrt", var); + // Gather correlation square-root vector + trans_->gatherCov(corSqrtField, corSqrtVecGlb); - // Get standard-deviation field name - const std::string stdDevFieldName = fieldName("stdDev", var); + if (params_.write.value()->writeCovariance.value()) { + // Get correlation square-root field + const auto covField = getField("cov", var, covData); + + // Gather correlation square-root vector + trans_->gatherCov(covField, covVecGlb); + } + + if (comm_.rank() == 0) { + // Get standard-deviation view + const auto stdDevView = getViewProfile("stdDev", var, data_); - // Define variables - if ((retval = nc_def_var(ncid, corSqrtFieldName.c_str(), NC_DOUBLE, 3, dCorSqrt_id, - &corSqrt_id[jvar]))) ERR(retval, corSqrtFieldName); - if ((retval = nc_def_var(ncid, stdDevFieldName.c_str(), NC_DOUBLE, 1, dStdDev_id, - &stdDev_id[jvar]))) ERR(retval, stdDevFieldName); + // Allocate global standard-deviation vector + stdDevVec.resize(nz); - // Update index - ++jvar; + // Serialize + for (size_t jz = 0; jz < nz; ++jz) { + stdDevVec[jz] = stdDevView(jz); + } + + // Write data + if ((retval = nc_put_var_double(ncId, corSqrtId[jvar], corSqrtVecGlb.data()))) + ERR(retval, var.name() + "_corSqrt"); + if ((retval = nc_put_var_double(ncId, stdDevId[jvar], stdDevVec.data()))) + ERR(retval, var.name() + "_stdDev"); + if (params_.write.value()->writeCovariance.value()) { + if ((retval = nc_put_var_double(ncId, covId[jvar], covVecGlb.data()))) + ERR(retval, var.name() + "_cov"); + } + ++jvar; + } } - // End definition mode - if ((retval = nc_enddef(ncid))) ERR(retval, ncFilePath); + if (comm_.rank() == 0) { + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + } +} + +// ----------------------------------------------------------------------------- + +void BifourierCovariance::readCovariance() { + oops::Log::trace() << classname() << "::readCovariance starting" << std::endl; + + for (const auto & var : activeVars_) { + // Create covariance field + createField3D("oldCov", trans_->nw(), var, data_); } - // Data mode - jvar = 0; + // NetCDF file path + const std::string ncFilePath = *params_.calibration.value()->oldCovInputFile.value(); + + // NetCDF IDs + int ncId, retval, nwId, nzIId, nzJId, covId; + size_t nwGlbFromFile, nzIFromFile, nzJFromFile; + + if (comm_.rank() == 0) { + // Open NetCDF file + if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncId))) ERR(retval, ncFilePath); + } for (const auto & var : activeVars_) { // Get number of levels const size_t nz = var.getLevels(); + // Define global covariance vector + std::vector covVecGlb; + + if (comm_.rank() == 0) { + // Check dimensions + const std::string nzIName = "nzI_" + var.name(); + const std::string nzJName = "nzJ_" + var.name(); + if ((retval = nc_inq_dimid(ncId, "nwGlb", &nwId))) ERR(retval, "nwGlb"); + if ((retval = nc_inq_dimid(ncId, nzIName.c_str(), &nzIId))) ERR(retval, nzIName); + if ((retval = nc_inq_dimid(ncId, nzJName.c_str(), &nzJId))) ERR(retval, nzJName); + if ((retval = nc_inq_dimlen(ncId, nwId, &nwGlbFromFile))) ERR(retval, "nwGlb"); + if ((retval = nc_inq_dimlen(ncId, nzIId, &nzIFromFile))) ERR(retval, nzIName); + if ((retval = nc_inq_dimlen(ncId, nzJId, &nzJFromFile))) ERR(retval, nzJName); + ASSERT(nwGlbFromFile == trans_->nwGlb()); + ASSERT(nzIFromFile == nz); + ASSERT(nzJFromFile == nz); + + // Get covariance field name + const std::string covFieldName = fieldName("cov", var); + + // Get variables ID + if ((retval = nc_inq_varid(ncId, covFieldName.c_str(), &covId))) + ERR(retval, covFieldName); + + // Allocate global covariance vector + covVecGlb.resize(trans_->nwGlb()*nz*nz); + + // Read data + if ((retval = nc_get_var_double(ncId, covId, covVecGlb.data()))) + ERR(retval, covFieldName); + } + + // Get covariance field + auto covField = getField("oldCov", var, data_); + + // Scatter covariance vector + trans_->scatterCov(covVecGlb, covField); + } + + if (comm_.rank() == 0) { + // Close file + if ((retval = nc_close(ncId))) ERR(retval, ncFilePath); + } + + oops::Log::trace() << classname() << "::readCovariance done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierCovariance::computeSquareRoot() { + oops::Log::trace() << classname() << "::computeSquareRoot starting" << std::endl; + + // Combine covariance with an old covariance + if (params_.calibration.value() != boost::none) { + if (params_.calibration.value()->oldCovInputFile.value() != boost::none) { + // Check parameters consistency + ASSERT(params_.calibration.value()->halfLife.value() != boost::none); + + // Read old covariance + readCovariance(); + + // Define update factor + const double halfLife = *params_.calibration.value()->halfLife.value(); + const double alphaInf = 1.0-std::exp(-std::log(2.0)/halfLife); + double updateFactor = alphaInf; + if (params_.calibration.value()->cycleIndex.value() != boost::none) { + const size_t cycleIndex = *params_.calibration.value()->cycleIndex.value(); + ASSERT(cycleIndex > 0); + updateFactor /= 1.0-std::pow(1.0-alphaInf, static_cast(cycleIndex+1)); + } + + for (const auto & var : activeVars_) { + // Get number of levels + const size_t nz = var.getLevels(); + + // Get old covariance view + const auto oldCovView = getView3D("oldCov", var, data_); + + // Get covariance view + auto covView = getView3D("cov", var, data_); + + // Combine covariances + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + for (size_t jzI = 0; jzI < nz; ++jzI) { + for (size_t jzJ = 0; jzJ < nz; ++jzJ) { + covView(jw, jzI, jzJ) = updateFactor*covView(jw, jzI, jzJ) + + (1.0-updateFactor)*oldCovView(jw, jzI, jzJ); + } + } + } + } + } + } + + for (const auto & var : activeVars_) { + // Get number of levels + const size_t nz = var.getLevels(); + + // Create correlation square-root field + createField3D("corSqrt", trans_->nw(), var, data_); + + // Create standard-deviation field + createFieldProfile("stdDev", var, data_); + + // Get covariance view + const auto covView = getView3D("cov", var, data_); + // Get correlation square-root view - const auto corSqrtView = getView3D("corSqrt", var, data_); + auto corSqrtView = getView3D("corSqrt", var, data_); // Get standard-deviation view - const auto stdDevView = getViewProfile("stdDev", var, data_); + auto stdDevView = getViewProfile("stdDev", var, data_); + + // Compute vertical correlation square-root + const double zeps = 1.0e-99; + Eigen::SelfAdjointEigenSolver es; + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + // Compute vertical correlation matrix + Eigen::MatrixXd vertCor(nz, nz); + for (size_t jz2 = 0; jz2 < nz; ++jz2) { + for (size_t jz1 = 0; jz1 < nz; ++jz1) { + vertCor(jz2, jz1) = covView(jw, jz2, jz1) / + std::sqrt(std::max(zeps, covView(jw, jz1, jz1))*std::max(zeps, covView(jw, jz2, jz2))); + } + } - // Define vectors - std::vector corSqrtVec(trans_->nwRoot()*nz*nz); - std::vector stdDevVec(nz); + // Compute eigendecomposition + es.compute(vertCor); - // Serialize - for (size_t jw = 0; jw < trans_->nwRoot(); ++jw) { - for (size_t jzI = 0; jzI < nz; ++jzI) { - for (size_t jzJ = 0; jzJ < nz; ++jzJ) { - const size_t index = jw*nz*nz + jzI*nz + jzJ; - corSqrtVec[index] = corSqrtView(jw, jzI, jzJ); + // Store covariance square-root + for (size_t jz2 = 0; jz2 < nz; ++jz2) { + for (size_t jz1 = 0; jz1 < nz; ++jz1) { + corSqrtView(jw, jz2, jz1) = es.eigenvectors().col(jz1)[jz2] + *std::sqrt(es.eigenvalues()[jz1]); } } } + + // Compute sum over wavenumbers + std::vector sum(nz, 0.0); + for (size_t jw = 0; jw < trans_->nwRoot(); ++jw) { + for (size_t jz = 0; jz < nz; ++jz) { + sum[jz] += covView(jw, jz, jz); + } + } + + // Communication + comm_.allReduceInPlace(sum.begin(), sum.end(), eckit::mpi::sum()); + + // Create horizontal covariance field + atlas::Field horCovField("horCov", make_datatype(), + make_shape(trans_->nw(), nz)); + + // Get horizontal covariance view + auto horCovView = make_view(horCovField); + + // Normalize with the sum + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + for (size_t jz = 0; jz < nz; ++jz) { + horCovView(jw, jz) = covView(jw, jz, jz)/sum[jz]; + } + } + + // Take square-root + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + for (size_t jz = 0; jz < nz; ++jz) { + horCovView(jw, jz) = std::sqrt(horCovView(jw, jz)); + } + } + + // Create standard-deviation profiles + std::vector vertStd(nz, 0.0); + + // Compute vertical variance for each level + for (size_t jw = 0; jw < trans_->nwRoot(); ++jw) { + for (size_t jz = 0; jz < nz; ++jz) { + vertStd[jz] += covView(jw, jz, jz); + } + } + + // Communication + comm_.allReduceInPlace(vertStd.begin(), vertStd.end(), eckit::mpi::sum()); + + // Take variance square-root for (size_t jz = 0; jz < nz; ++jz) { - stdDevVec[jz] = stdDevView(jz); + vertStd[jz] = std::sqrt(vertStd[jz]); } - // Define global vector - std::vector corSqrtVecGlb; - if (comm_.rank() == 0) { - corSqrtVecGlb.resize(trans_->nwGlb()*nz*nz); + // Merge contributions + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + for (size_t jz2 = 0; jz2 < nz; ++jz2) { + for (size_t jz1 = 0; jz1 < nz; ++jz1) { + corSqrtView(jw, jz2, jz1) *= horCovView(jw, jz2)*vertStd[jz2]; + } + } + } + + // Compute variance + std::vector variance(nz, 0.0); + for (size_t jz2 = 0; jz2 < nz; ++jz2) { + for (size_t js = 0; js < trans_->ns(); ++js) { + if (trans_->jq(js) == 0) { + const size_t jw = trans_->jw(js); + for (size_t jz1 = 0; jz1 < nz; ++jz1) { + variance[jz2] += corSqrtView(jw, jz2, jz1)*corSqrtView(jw, jz2, jz1) + *trans_->spNorm(js)*trans_->spNorm(js); + } + } + } } - // Gather vector - std::vector corSqrtCounts(trans_->wCounts()); - std::vector corSqrtDispls(trans_->wDispls()); - for (size_t jt = 0; jt < comm_.size(); ++jt) { - corSqrtCounts[jt] *= nz*nz; - corSqrtDispls[jt] *= nz*nz; + // Communication + comm_.allReduceInPlace(variance.begin(), variance.end(), eckit::mpi::sum()); + + // Compute standard-deviation + for (size_t jz = 0; jz < nz; ++jz) { + stdDevView(jz) = std::sqrt(variance[jz]); } - comm_.gatherv(corSqrtVec.cbegin(), corSqrtVec.cend(), corSqrtVecGlb.begin(), - corSqrtVecGlb.end(), corSqrtCounts, corSqrtDispls, 0); - if (comm_.rank() == 0) { - // Write data - if ((retval = nc_put_var_double(ncid, corSqrt_id[jvar], corSqrtVecGlb.data()))) - ERR(retval, var.name() + "_corSqrt"); - if ((retval = nc_put_var_double(ncid, stdDev_id[jvar], stdDevVec.data()))) - ERR(retval, var.name() + "_stdDev"); - ++jvar; + // Apply inverse standard-deviation to normalize correlation square-root + for (size_t jz2 = 0; jz2 < nz; ++jz2) { + ASSERT(stdDevView(jz2) > 0.0); + const double norm = 1.0/stdDevView(jz2); + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + for (size_t jz1 = 0; jz1 < nz; ++jz1) { + corSqrtView(jw, jz2, jz1) *= norm; + } + } } } - if (comm_.rank() == 0) { - // Close file - if ((retval = nc_close(ncid))) ERR(retval, ncFilePath); + oops::Log::trace() << classname() << "::computeSquareRoot done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierCovariance::computeCovariance(atlas::FieldSet & covData) const { + oops::Log::trace() << classname() << "::computeCovariance starting" << std::endl; + + for (const auto & var : activeVars_) { + // Get covariance field name + const auto covFieldName = fieldName("cov", var); + + if (data_.has(covFieldName)) { + // Share pointer + covData.add(data_[covFieldName]); + } else { + // Get number of levels + const size_t nz = var.getLevels(); + + // Create covariance field + createField3D("cov", trans_->nw(), var, covData); + + // Get covariance view + auto covView = getView3D("cov", var, covData); + + // Get correlation square-root view + const auto corSqrtView = getView3D("corSqrt", var, data_); + + // Get standard-deviation view + const auto stdDevView = getViewProfile("stdDev", var, data_); + + // Compute covariance matrix + for (size_t jw = 0; jw < trans_->nw(); ++jw) { + for (size_t jzI = 0; jzI < nz; ++jzI) { + for (size_t jzJ = 0; jzJ < nz; ++jzJ) { + // Compute correlation + for (size_t jz3 = 0; jz3 < nz; ++jz3) { + covView(jw, jzI, jzJ) += corSqrtView(jw, jzI, jz3)*corSqrtView(jw, jzJ, jz3); + } + + // Multiply by standard-deviations + covView(jw, jzI, jzJ) *= stdDevView(jzJ)*stdDevView(jzI); + } + } + } + } } - oops::Log::trace() << classname() << "::write done" << std::endl; + oops::Log::trace() << classname() << "::computeCovariance done" << std::endl; } // ----------------------------------------------------------------------------- void BifourierCovariance::print(std::ostream & os) const { - os << classname(); + // Print norms + os << "Covariance norms: " << std::endl; + for (const auto & var : activeVars_) { + // Get number of levels + const size_t nz = var.getLevels(); + + // Get correlation square-root field + const auto corSqrtField = getField("corSqrt", var, data_); + + // Get standard-deviation view + const auto stdDevView = getViewProfile("stdDev", var, data_); + + // Compute standard deviation squared norm + double stdDevNorm = 0.0; + for (size_t jz = 0; jz < nz; ++jz) { + stdDevNorm += stdDevView(jz)*stdDevView(jz); + } + + // Compute standard deviation norm + stdDevNorm = std::sqrt(stdDevNorm); + + // Print norms + os << "- " << var.name() << ": " << std::endl; + os << " + correlation square-root: " << trans_->normCov(corSqrtField) << std::endl; + os << " + standard-deviation: " << stdDevNorm << std::endl; + } } // ----------------------------------------------------------------------------- diff --git a/src/saber/bifourier/BifourierCovariance.h b/src/saber/bifourier/BifourierCovariance.h index 8f3d3203d..5d14ff13f 100644 --- a/src/saber/bifourier/BifourierCovariance.h +++ b/src/saber/bifourier/BifourierCovariance.h @@ -17,11 +17,11 @@ #include "oops/base/FieldSets.h" #include "oops/base/GeometryData.h" #include "oops/base/Variable.h" -#include "oops/util/DateTime.h" #include "oops/util/parameters/OptionalParameter.h" #include "oops/util/parameters/Parameters.h" #include "oops/util/parameters/RequiredParameter.h" +#include "saber/bifourier/BifourierTransformBase.h" #include "saber/bifourier/BifourierTransformStore.h" #include "saber/blocks/SaberBlockParametersBase.h" #include "saber/blocks/SaberCentralBlockBase.h" @@ -38,8 +38,65 @@ class BifourierCovarianceReadParameters : public oops::Parameters { // Input file oops::RequiredParameter inputFile{"input file", this}; - // Input file format ("netcdf", "arome legacy binary" or "arome legacy netcdf") - oops::Parameter inputFileFormat{"input file format", "netcdf", this}; + // Read covariance flag + oops::Parameter readCovariance{"read covariance", false, this}; +}; + +// ----------------------------------------------------------------------------- + +class ProfileParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(ProfileParameters, oops::Parameters) + + public: + // Variable name + oops::RequiredParameter variable{"variable", this}; + + // Horizontal length-scales + oops::RequiredParameter> Lh{"horizontal length-scales", this}; + + // Vertical length-scale + oops::RequiredParameter Lv{"vertical length-scale", this}; + + // Standard-deviation + oops::OptionalParameter> stdDev{"standard-deviation", this}; +}; + +// ----------------------------------------------------------------------------- + +class BifourierCovarianceCalibrationParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(BifourierCovarianceCalibrationParameters, oops::Parameters) + + public: + // Filtering scale (in total wavenumber unit) + oops::Parameter filteringScale{"filtering scale", 0.0, this}; + + // Old covariance input file + oops::OptionalParameter oldCovInputFile{"old covariance input file", this}; + + // Half life + oops::OptionalParameter halfLife{"half life", this}; + + // Cycle index + oops::OptionalParameter cycleIndex{"cycle index", this}; + + // Sub-ensembles size + oops::Parameter subEnsSize{"sub-ensembles size", 0, this}; + + // User-defined vertical profile for each variable + oops::Parameter> profiles{"profiles", {}, this}; +}; + +// ----------------------------------------------------------------------------- + +class BifourierCovarianceWriteParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(BifourierCovarianceWriteParameters, oops::Parameters) + + public: + // Output file + oops::RequiredParameter outputFile{"output file", this}; + + // Write covariance flag + oops::Parameter writeCovariance{"write covariance", false, this}; }; // ----------------------------------------------------------------------------- @@ -51,14 +108,18 @@ class BifourierCovarianceParameters : public SaberBlockParametersBase { // Read parameters oops::OptionalParameter read{"read", this}; + // Calibration parameters + oops::OptionalParameter calibration{"calibration", + this}; + // Standard-deviation inflation factor oops::Parameter inflation{"inflation", 1.0, this}; // Only correlation oops::Parameter correlation{"correlation", false, this}; - // Output file - oops::OptionalParameter outputFile{"output file", this}; + // Write parameters + oops::OptionalParameter write{"write", this}; oops::Variables mandatoryActiveVars() const override {return oops::Variables();} @@ -96,9 +157,15 @@ class BifourierCovariance : public SaberCentralBlockBase { void read() override; + void directCalibration(const oops::FieldSets &) override; + + void iterativeCalibrationInit() override; + void iterativeCalibrationUpdate(const oops::FieldSet3D &) override; + void iterativeCalibrationFinal() override; + void write() const override; - private: + protected: // Communicator const eckit::mpi::Comm & comm_; @@ -108,15 +175,30 @@ class BifourierCovariance : public SaberCentralBlockBase { // Parameters Parameters_ params_; + // Filtering length-scale + const double Lf_; + // Spectral transform const BifourierTransformStore transStore_; - std::shared_ptr trans_; + const std::shared_ptr trans_; // Data atlas::FieldSet data_; + // Interative counter + size_t iterativeN_; + // Private methods + // Read covariance + void readCovariance(); + + // Compute square-root + void computeSquareRoot(); + + // Compute covariance from correlation square-root and standard-deviation + void computeCovariance(atlas::FieldSet &) const; + // Print void print(std::ostream &) const override; }; diff --git a/src/saber/bifourier/BifourierGridToSpectral.cc b/src/saber/bifourier/BifourierGridToSpectral.cc index 988e075c4..5fc291313 100644 --- a/src/saber/bifourier/BifourierGridToSpectral.cc +++ b/src/saber/bifourier/BifourierGridToSpectral.cc @@ -62,8 +62,8 @@ void BifourierGridToSpectral::multiplyAD(oops::FieldSet3D & fset) const { // Remove variables util::removeFieldsFromFieldSet(fset.fieldSet(), innerVars_.variables()); - // Inverse spectral transform - trans_->sp2gp(fsetTmp, fset.fieldSet(), innerVars_); + // Direct spectral transform, adjoint + trans_->gp2spAdj(fsetTmp, fset.fieldSet(), innerVars_); oops::Log::trace() << classname() << "::multiplyAD done" << std::endl; } diff --git a/src/saber/bifourier/BifourierGridToSpectral.h b/src/saber/bifourier/BifourierGridToSpectral.h index 78d88b95c..4114c3bd2 100644 --- a/src/saber/bifourier/BifourierGridToSpectral.h +++ b/src/saber/bifourier/BifourierGridToSpectral.h @@ -15,6 +15,7 @@ #include "oops/base/GeometryData.h" #include "oops/base/Variables.h" +#include "saber/bifourier/BifourierTransformBase.h" #include "saber/bifourier/BifourierTransformStore.h" #include "saber/blocks/SaberBlockParametersBase.h" #include "saber/blocks/SaberOuterBlockBase.h" @@ -66,7 +67,7 @@ class BifourierGridToSpectral : public SaberOuterBlockBase { // Spectral transform const BifourierTransformStore transStore_; - std::shared_ptr trans_; + const std::shared_ptr trans_; // Inner geometry data const oops::GeometryData & innerGeometryData_; diff --git a/src/saber/bifourier/BifourierID.cc b/src/saber/bifourier/BifourierID.cc index dcb9a2b74..70b1954fa 100644 --- a/src/saber/bifourier/BifourierID.cc +++ b/src/saber/bifourier/BifourierID.cc @@ -26,13 +26,10 @@ BifourierID::BifourierID(const oops::GeometryData & gdata, SaberCentralBlockBase(params, xb.validTime()), gdata_(gdata), comm_(gdata_.comm()), - activeVars_(activeVars) + activeVars_(activeVars), + trans_(transStore_.retrieveTransform(gdata)) { oops::Log::trace() << classname() << "::BifourierID starting" << std::endl; - - // Retrieve spectral transform - trans_ = transStore_.retrieveTransform(gdata); - oops::Log::trace() << classname() << "::BifourierID done" << std::endl; } @@ -49,7 +46,7 @@ void BifourierID::randomize(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::randomize starting" << std::endl; // Create random spectral vector - trans_->createRandomSpectralFieldSet(fset.fieldSet(), activeVars_); + trans_->createRandomFieldSet(fset.fieldSet(), activeVars_); oops::Log::trace() << classname() << "::randomize done" << std::endl; } diff --git a/src/saber/bifourier/BifourierID.h b/src/saber/bifourier/BifourierID.h index 9d49dce5a..283c0d4d0 100644 --- a/src/saber/bifourier/BifourierID.h +++ b/src/saber/bifourier/BifourierID.h @@ -15,8 +15,8 @@ #include "eckit/mpi/Comm.h" #include "oops/base/GeometryData.h" -#include "oops/util/DateTime.h" +#include "saber/bifourier/BifourierTransformBase.h" #include "saber/bifourier/BifourierTransformStore.h" #include "saber/blocks/SaberBlockParametersBase.h" #include "saber/blocks/SaberCentralBlockBase.h" @@ -79,7 +79,7 @@ class BifourierID : public SaberCentralBlockBase { // Spectral transform const BifourierTransformStore transStore_; - std::shared_ptr trans_; + const std::shared_ptr trans_; // Private methods diff --git a/src/saber/bifourier/BifourierSpectralToGrid.cc b/src/saber/bifourier/BifourierSpectralToGrid.cc index 233f1ac3f..2e68319ea 100644 --- a/src/saber/bifourier/BifourierSpectralToGrid.cc +++ b/src/saber/bifourier/BifourierSpectralToGrid.cc @@ -24,13 +24,11 @@ BifourierSpectralToGrid::BifourierSpectralToGrid(const oops::GeometryData & oute const oops::FieldSet3D & xb, const oops::FieldSet3D & fg) : SaberOuterBlockBase(params, xb.validTime()), - innerVars_(outerVars) + innerVars_(outerVars), + trans_(transStore_.setupTransform(outerGeometryData, innerVars_, params.transform.value())) { oops::Log::trace() << classname() << "::BifourierSpectralToGrid starting" << std::endl; - // Create spectral transform - trans_ = transStore_.setupTransform(outerGeometryData, innerVars_, params.toConfiguration()); - // Create inner GeometryData innerGeometryData_.reset(new oops::GeometryData(trans_->spFspace(), outerGeometryData.fieldSet(), outerGeometryData.levelsAreTopDown(), outerGeometryData.comm())); @@ -61,9 +59,9 @@ void BifourierSpectralToGrid::multiply(oops::FieldSet3D & fset) const { void BifourierSpectralToGrid::multiplyAD(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; - // Direct spectral transform + // Inverse spectral transform, adjoint atlas::FieldSet fsetTmp; - trans_->gp2sp(fset.fieldSet(), fsetTmp, innerVars_); + trans_->sp2gpAdj(fset.fieldSet(), fsetTmp, innerVars_); // Remove outer variables util::removeFieldsFromFieldSet(fset.fieldSet(), innerVars_.variables()); diff --git a/src/saber/bifourier/BifourierSpectralToGrid.h b/src/saber/bifourier/BifourierSpectralToGrid.h index cc81f3c98..441e07493 100644 --- a/src/saber/bifourier/BifourierSpectralToGrid.h +++ b/src/saber/bifourier/BifourierSpectralToGrid.h @@ -15,6 +15,7 @@ #include "oops/base/GeometryData.h" #include "oops/base/Variables.h" +#include "saber/bifourier/BifourierTransformBase.h" #include "saber/bifourier/BifourierTransformStore.h" #include "saber/blocks/SaberBlockParametersBase.h" #include "saber/blocks/SaberOuterBlockBase.h" @@ -28,14 +29,9 @@ class BifourierSpectralToGridParameters : public SaberBlockParametersBase { OOPS_CONCRETE_PARAMETERS(BifourierSpectralToGridParameters, SaberBlockParametersBase) public: - // Truncation type - oops::Parameter truncationType{"truncation type", "arome", this}; - - // Skip tests - oops::Parameter skipTests{"skip tests", false, this}; - - // Spectral tests tolerance - oops::Parameter specTolerance{"spectral tolerance", 1.0e-9, this}; + // Transform parameters + oops::Parameter transform{"transform", + BifourierTransformParameters(), this}; oops::Variables mandatoryActiveVars() const override {return oops::Variables();} @@ -79,7 +75,7 @@ class BifourierSpectralToGrid : public SaberOuterBlockBase { // Spectral transform const BifourierTransformStore transStore_; - std::shared_ptr trans_; + const std::shared_ptr trans_; // Private methods diff --git a/src/saber/bifourier/BifourierSpectralVorDivToGridWind.cc b/src/saber/bifourier/BifourierSpectralVorDivToGridWind.cc new file mode 100644 index 000000000..cd502ec48 --- /dev/null +++ b/src/saber/bifourier/BifourierSpectralVorDivToGridWind.cc @@ -0,0 +1,829 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#include "saber/bifourier/BifourierSpectralVorDivToGridWind.h" + +using atlas::array::make_view; + +namespace saber { +namespace bifourier { + +// ----------------------------------------------------------------------------- + +static SaberOuterBlockMaker + makerBifourierSpectralVorDivToGridWind_("BifourierSpectralVorDivToGridWind"); + +// ----------------------------------------------------------------------------- + +BifourierSpectralVorDivToGridWind::BifourierSpectralVorDivToGridWind( + const oops::GeometryData & outerGeometryData, + const oops::Variables & outerVars, + const eckit::Configuration &, + const Parameters_ & params, + const oops::FieldSet3D & xb, + const oops::FieldSet3D & fg) + : SaberOuterBlockBase(params, xb.validTime()), + comm_(outerGeometryData.comm()), + outerVars_(outerVars), + params_(params), + fftBackend_(params_.transform.value().fftBackend.value()), + data_(xb.validTime(), comm_) +{ + oops::Log::trace() << classname() << "::BifourierSpectralVorDivToGridWind starting" + << std::endl; + + // Inner variables + if (!params_.backward.value()) { + // Wind variables + oops::Variables windVars; + if (params_.outerSphericalWinds.value()) { + windVars.push_back(outerVars["eastward_wind"]); + windVars.push_back(outerVars["northward_wind"]); + } else { + windVars.push_back(outerVars["geographical_x_wind"]); + windVars.push_back(outerVars["geographical_y_wind"]); + } + + // Add vor/div to inner variables + innerVars_.push_back("air_upward_absolute_vorticity"); + innerVars_.push_back("air_horizontal_divergence"); + + // Number of levels + nz_ = windVars[0].getLevels(); + innerVars_["air_upward_absolute_vorticity"].setLevels(nz_); + innerVars_["air_horizontal_divergence"].setLevels(nz_); + + // Add other variables + for (const auto & var : outerVars) { + if (!windVars.has(var)) { + innerVars_.push_back(var); + } + } + } else { + // Wind variables + oops::Variables windVars; + if (params_.outerSphericalWinds.value()) { + windVars.push_back("eastward_wind"); + windVars.push_back("northward_wind"); + } else { + windVars.push_back("geographical_x_wind"); + windVars.push_back("geographical_y_wind"); + } + + // Number of levels + nz_ = outerVars["air_upward_absolute_vorticity"].getLevels(); + windVars[0].setLevels(nz_); + windVars[1].setLevels(nz_); + + // Add wind to inner variables + innerVars_.push_back(windVars[0]); + innerVars_.push_back(windVars[1]); + + // Add other variables + for (const auto & var : outerVars) { + if (!((var.name() == "air_upward_absolute_vorticity") + || (var.name() == "air_horizontal_divergence"))) { + innerVars_.push_back(var); + } + } + } + + if (!params_.backward.value()) { + // Create spectral transform + trans_ = transStore_.setupTransform(outerGeometryData, innerVars_, + params_.transform.value()); + + // Create inner GeometryData + innerGeometryData_.reset(new oops::GeometryData(trans_->spFspace(), + outerGeometryData.fieldSet(), outerGeometryData.levelsAreTopDown(), + outerGeometryData.comm())); + } else { + // Retrieve spectral transform + trans_ = transStore_.retrieveTransform(outerGeometryData); + + // Set inner GeometryData + // TODO(Benjamin): avoid this + innerGeometryData_.reset(new oops::GeometryData(trans_->geometryData().functionSpace(), + trans_->geometryData().fieldSet(), trans_->geometryData().levelsAreTopDown(), + trans_->geometryData().comm())); + } + + // Prepare biperiodization if needed + const auto &biperParams = params_.biperParams.value(); + oops::Variables biperVars; + + // Get grid function space + const atlas::functionspace::StructuredColumns fs(trans_->geometryData().functionSpace()); + + // Get lon/lat view + const auto lonlatView = atlas::array::make_view(fs.lonlat()); + + if (fftBackend_ == "fftw") { + // Get js for (jk, jl) = (0, 0) + jsZero_ = -1; + for (size_t js = 0; js < trans_->ns(); ++js) { + if ((trans_->jk(js) == 0) && (trans_->jl(js) == 0)) { + jsZero_ = js; + } + } + + if (biperParams != boost::none) { + // Check biperiodization parameters (should not change the grid size) + ASSERT(biperParams->innerExtNx.value() == biperParams->outerExtNx.value()); + ASSERT(biperParams->innerExtNy.value() == biperParams->outerExtNy.value()); + } + + // Create map factor field + atlas::Field mapFactorField = fs.createField( + atlas::option::name("map_factor") | atlas::option::levels(1)); + + // Add map factor to FieldSet + data_.add(mapFactorField); + + // Get map factor view + auto mapFactorView = make_view(mapFactorField); + + // Degree to radian + const double deg2rad = M_PI/180.0; + + // Get projection parameter + const eckit::LocalConfiguration projConf = fs.grid().projection().spec(); + const double latitude0 = projConf.getDouble("latitude0")*deg2rad; + + // Get pole + double pole; + if (latitude0 == 0.0) { + pole = 0.0; + } else if (latitude0 > 0.0) { + pole = 1.0; + } else { + pole = -1.0; + } + + // Compute map factor constants + const double sina = pole*std::sin(latitude0); + const double rho0 = std::abs(sina) > 0.0 ? + std::pow(std::cos(latitude0), 1.0-sina)*std::pow(1.0+sina, sina)/sina : 1.0; + + // Compute map factor + for (int jnode = 0; jnode < mapFactorField.shape(0); ++jnode) { + const double latRad = lonlatView(jnode, 1)*deg2rad; + mapFactorView(jnode, 0) = rho0*sina/std::cos(latRad) + *std::pow(std::tan((0.25*M_PI)-(pole*0.5*latRad)), sina); + } + + if (biperParams != boost::none) { + // Add biperiodization variable + biperVars.push_back("map_factor"); + biperVars["map_factor"].setLevels(1); + } + } + + if (params_.outerSphericalWinds.value()) { + // Get eastward and northward winds from grid winds + + // Create coefficients fields + atlas::Field dxDlonField = fs.createField( + atlas::option::name("dxDlon") | atlas::option::levels(1)); + atlas::Field dxDlatField = fs.createField( + atlas::option::name("dxDlat") | atlas::option::levels(1)); + atlas::Field dyDlonField = fs.createField( + atlas::option::name("dyDlon") | atlas::option::levels(1)); + atlas::Field dyDlatField = fs.createField( + atlas::option::name("dyDlat") | atlas::option::levels(1)); + + // Add coefficients to FieldSet + data_.add(dxDlonField); + data_.add(dxDlatField); + data_.add(dyDlonField); + data_.add(dyDlatField); + + // Get coefficients views + auto dxDlonView = make_view(dxDlonField); + auto dxDlatView = make_view(dxDlatField); + auto dyDlonView = make_view(dyDlonField); + auto dyDlatView = make_view(dyDlatField); + + for (int jnode = 0; jnode < dxDlonField.shape(0); ++jnode) { + // Get local point + atlas::PointLonLat p({lonlatView(jnode, 0), lonlatView(jnode, 1)}); + + // Get local Jacobian + dxDlonView(jnode, 0) = fs.grid().projection().jacobian(p).dx_dlon(); + dxDlatView(jnode, 0) = fs.grid().projection().jacobian(p).dx_dlat(); + dyDlonView(jnode, 0) = fs.grid().projection().jacobian(p).dy_dlon(); + dyDlatView(jnode, 0) = fs.grid().projection().jacobian(p).dy_dlat(); + + // Normalize Jacobian + const double dlonNorm = 1.0/std::sqrt( + dxDlonView(jnode, 0)*dxDlonView(jnode, 0)+dyDlonView(jnode, 0)*dyDlonView(jnode, 0)); + const double dlatNorm = 1.0/std::sqrt( + dxDlatView(jnode, 0)*dxDlatView(jnode, 0)+dyDlatView(jnode, 0)*dyDlatView(jnode, 0)); + dxDlonView(jnode, 0) *= dlonNorm; + dxDlatView(jnode, 0) *= dlatNorm; + dyDlonView(jnode, 0) *= dlonNorm; + dyDlatView(jnode, 0) *= dlatNorm; + } + + if (biperParams != boost::none) { + // Add biperiodization variables + biperVars.push_back("dxDlon"); + biperVars["dxDlon"].setLevels(1); + biperVars.push_back("dxDlat"); + biperVars["dxDlat"].setLevels(1); + biperVars.push_back("dyDlon"); + biperVars["dyDlon"].setLevels(1); + biperVars.push_back("dyDlat"); + biperVars["dyDlat"].setLevels(1); + } + } + + if (biperParams != boost::none) { + // Setup biperiodization implementation + BiperiodizationImpl biper(outerGeometryData, biperVars, *biperParams); + + // Apply biperiodization leftInverseMultiply to go to biperiodization inner geometry + biper.leftInverseMultiply(data_.fieldSet()); + + // Apply biperiodization multiply + biper.multiply(data_.fieldSet()); + } + + oops::Log::trace() << classname() << "::BifourierSpectralVorDivToGridWind done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierSpectralVorDivToGridWind::multiply(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::multiply starting" << std::endl; + + if (!params_.backward.value()) { + // Forward application + forward(fset, innerVars_); + } else { + // Backward application + backward(fset, outerVars_); + } + + oops::Log::trace() << classname() << "::multiply done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierSpectralVorDivToGridWind::multiplyAD(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; + + if (!params_.backward.value()) { + // Forward application, adjoint + forwardAD(fset, innerVars_); + } else { + // Backward application, adjoint + backwardAD(fset, outerVars_); + } + + oops::Log::trace() << classname() << "::multiplyAD done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierSpectralVorDivToGridWind::leftInverseMultiply(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::leftInverseMultiply starting" << std::endl; + + if (!params_.backward.value()) { + // Backward application + backward(fset, innerVars_); + } else { + // Forward application + forward(fset, outerVars_); + } + + oops::Log::trace() << classname() << "::leftInverseMultiply done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierSpectralVorDivToGridWind::forward(oops::FieldSet3D & fset, + const oops::Variables & vars) const { + oops::Log::trace() << classname() << "::forward starting" << std::endl; + + if (fftBackend_ == "fftw") { + // Get vorticity and divergence fields + auto vorField = fset["air_upward_absolute_vorticity"]; + ASSERT(vorField.shape(0) == static_cast(trans_->ns())); + ASSERT(vorField.shape(1) == static_cast(nz_)); + auto divField = fset["air_horizontal_divergence"]; + ASSERT(divField.shape(0) == static_cast(trans_->ns())); + ASSERT(divField.shape(1) == static_cast(nz_)); + + // Compute stream function and velocity potential + trans_->inverseLaplacian(vorField); + trans_->inverseLaplacian(divField); + + // Compute horizontal derivatives + atlas::Field dPsiDxField; + atlas::Field dPsiDyField; + atlas::Field dKhiDxField; + atlas::Field dKhiDyField; + trans_->derivative(vorField, dPsiDxField, "x"); + trans_->derivative(vorField, dPsiDyField, "y"); + trans_->derivative(divField, dKhiDxField, "x"); + trans_->derivative(divField, dKhiDyField, "y"); + + // Compute u/v + auto vorView = make_view(vorField); + auto divView = make_view(divField); + const auto dPsiDxView = make_view(dPsiDxField); + const auto dPsiDyView = make_view(dPsiDyField); + const auto dKhiDxView = make_view(dKhiDxField); + const auto dKhiDyView = make_view(dKhiDyField); + for (size_t jz = 0; jz < nz_; ++jz) { + for (size_t js = 0; js < trans_->ns(); ++js) { + vorView(js, jz) = dKhiDxView(js, jz) - dPsiDyView(js, jz); + divView(js, jz) = dKhiDyView(js, jz) + dPsiDxView(js, jz); + } + } + + // Reset mean wind profile + if (jsZero_ >= 0) { + if (fset.fieldSet().metadata().has("uMeanProfile") + && fset.fieldSet().metadata().has("vMeanProfile")) { + const std::vector uMeanProfile = + fset.fieldSet().metadata().getDoubleVector("uMeanProfile"); + const std::vector vMeanProfile = + fset.fieldSet().metadata().getDoubleVector("vMeanProfile"); + for (size_t jz = 0; jz < nz_; ++jz) { + vorView(jsZero_, jz) = uMeanProfile[jz]; + divView(jsZero_, jz) = vMeanProfile[jz]; + } + } + } + } else if (fftBackend_ == "ectrans") { + // Set number of levels for the wind transform + fset.fieldSet().metadata().set("nvordiv", nz_); + } + + // Create temporary fieldset with the same metadata + atlas::FieldSet fsetTmp; + fsetTmp.metadata() = fset.fieldSet().metadata(); + + // Copy FieldSet + trans_->copyFieldSet(fset.fieldSet(), fsetTmp, vars); + + // Remove variables + util::removeFieldsFromFieldSet(fset.fieldSet(), vars.variables()); + + // Inverse spectral transform + trans_->sp2gp(fsetTmp, fset.fieldSet(), vars); + + // Rename wind fields + fset["air_upward_absolute_vorticity"].rename("reduced_x_wind"); + fset["air_horizontal_divergence"].rename("reduced_y_wind"); + + // Get reduced wind fields + auto uField = fset["reduced_x_wind"]; + auto vField = fset["reduced_y_wind"]; + + // Get views + auto uView = atlas::array::make_view(uField); + auto vView = atlas::array::make_view(vField); + + if (fftBackend_ == "fftw") { + // Get map factor view + const auto mapFactorView = atlas::array::make_view(data_["map_factor"]); + + // Multiply by the map factor + for (int jnode = 0; jnode < uField.shape(0); ++jnode) { + for (int jlevel = 0; jlevel < uField.shape(1); ++jlevel) { + uView(jnode, jlevel) *= mapFactorView(jnode, 0); + vView(jnode, jlevel) *= mapFactorView(jnode, 0); + } + } + } + + if (params_.outerSphericalWinds.value()) { + // Get coefficients views + const auto dxDlonView = atlas::array::make_view(data_["dxDlon"]); + const auto dxDlatView = atlas::array::make_view(data_["dxDlat"]); + const auto dyDlonView = atlas::array::make_view(data_["dyDlon"]); + const auto dyDlatView = atlas::array::make_view(data_["dyDlat"]); + + for (int jnode = 0; jnode < uField.shape(0); ++jnode) { + for (int jlevel = 0; jlevel < uField.shape(1); ++jlevel) { + const double uSave = uView(jnode, jlevel); + const double vSave = vView(jnode, jlevel); + uView(jnode, jlevel) = uSave*dxDlonView(jnode, 0) + vSave*dyDlonView(jnode, 0); + vView(jnode, jlevel) = uSave*dxDlatView(jnode, 0) + vSave*dyDlatView(jnode, 0); + } + } + + // Rename wind fields + fset["reduced_x_wind"].rename("eastward_wind"); + fset["reduced_y_wind"].rename("northward_wind"); + } else { + // Rename wind fields + fset["reduced_x_wind"].rename("geographical_x_wind"); + fset["reduced_y_wind"].rename("geographical_y_wind"); + } + + if (fftBackend_ == "ectrans") { + // Reset number of levels for the wind transform + fset.fieldSet().metadata().set("nvordiv", 0); + } + + oops::Log::trace() << classname() << "::forward done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierSpectralVorDivToGridWind::forwardAD(oops::FieldSet3D & fset, + const oops::Variables & vars) const { + oops::Log::trace() << classname() << "::forwardAD starting" << std::endl; + + if (params_.outerSphericalWinds.value()) { + // Rename wind fields + fset["eastward_wind"].rename("reduced_x_wind"); + fset["northward_wind"].rename("reduced_y_wind"); + } else { + // Rename wind fields + fset["geographical_x_wind"].rename("reduced_x_wind"); + fset["geographical_y_wind"].rename("reduced_y_wind"); + } + + // Get reduced wind fields + auto uField = fset["reduced_x_wind"]; + auto vField = fset["reduced_y_wind"]; + + // Get views + auto uView = atlas::array::make_view(uField); + auto vView = atlas::array::make_view(vField); + + if (params_.outerSphericalWinds.value() && !params_.dipoleTest.value()) { + // Get coefficients views + const auto dxDlonView = atlas::array::make_view(data_["dxDlon"]); + const auto dxDlatView = atlas::array::make_view(data_["dxDlat"]); + const auto dyDlonView = atlas::array::make_view(data_["dyDlon"]); + const auto dyDlatView = atlas::array::make_view(data_["dyDlat"]); + + for (int jnode = 0; jnode < uField.shape(0); ++jnode) { + for (int jlevel = 0; jlevel < uField.shape(1); ++jlevel) { + const double uSave = uView(jnode, jlevel); + const double vSave = vView(jnode, jlevel); + uView(jnode, jlevel) = uSave*dxDlonView(jnode, 0) + vSave*dxDlatView(jnode, 0); + vView(jnode, jlevel) = uSave*dyDlonView(jnode, 0) + vSave*dyDlatView(jnode, 0); + } + } + } + + if (fftBackend_ == "fftw" && !params_.dipoleTest.value()) { + // Get map factor view + const auto mapFactorView = atlas::array::make_view(data_["map_factor"]); + + // Multiply by the map factor + for (int jnode = 0; jnode < uField.shape(0); ++jnode) { + for (int jlevel = 0; jlevel < uField.shape(1); ++jlevel) { + uView(jnode, jlevel) *= mapFactorView(jnode, 0); + vView(jnode, jlevel) *= mapFactorView(jnode, 0); + } + } + } + + // Rename wind fields + fset["reduced_x_wind"].rename("air_upward_absolute_vorticity"); + fset["reduced_y_wind"].rename("air_horizontal_divergence"); + + if (fftBackend_ == "ectrans" && !params_.dipoleTest.value()) { + // Set number of levels for the wind transform + fset.fieldSet().metadata().set("nvordiv", nz_); + } + + // Create temporary fieldset with the same metadata + atlas::FieldSet fsetTmp; + fsetTmp.metadata() = fset.fieldSet().metadata(); + + // Direct spectral transform + trans_->sp2gpAdj(fset.fieldSet(), fsetTmp, vars); + + // Remove outer variables + util::removeFieldsFromFieldSet(fset.fieldSet(), vars.variables()); + + // Copy FieldSet + trans_->copyFieldSet(fsetTmp, fset.fieldSet(), vars); + + if (fftBackend_ == "fftw" && !params_.dipoleTest.value()) { + // Get vorticity and divergence fields + auto vorField = fset["air_upward_absolute_vorticity"]; + ASSERT(vorField.shape(0) == static_cast(trans_->ns())); + ASSERT(vorField.shape(1) == static_cast(nz_)); + auto divField = fset["air_horizontal_divergence"]; + ASSERT(divField.shape(0) == static_cast(trans_->ns())); + ASSERT(divField.shape(1) == static_cast(nz_)); + auto vorView = make_view(vorField); + auto divView = make_view(divField); + + // Save mean wind profile + if (jsZero_ >= 0) { + std::vector uMeanProfile(nz_, 0.0); + std::vector vMeanProfile(nz_, 0.0); + for (size_t jz = 0; jz < nz_; ++jz) { + uMeanProfile[jz] = vorView(jsZero_, jz); + vMeanProfile[jz] = divView(jsZero_, jz); + } + fset.fieldSet().metadata().set("uMeanProfile", uMeanProfile); + fset.fieldSet().metadata().set("vMeanProfile", vMeanProfile); + } + + // Compute derivatives adjoints + atlas::Field dPsiDxField; + atlas::Field dPsiDyField; + atlas::Field dKhiDxField; + atlas::Field dKhiDyField; + trans_->derivative(divField, dPsiDxField, "x", true); + trans_->derivative(vorField, dPsiDyField, "y", true); + trans_->derivative(vorField, dKhiDxField, "x", true); + trans_->derivative(divField, dKhiDyField, "y", true); + + // Compute vorticity and divergence + const auto dPsiDxView = make_view(dPsiDxField); + const auto dPsiDyView = make_view(dPsiDyField); + const auto dKhiDxView = make_view(dKhiDxField); + const auto dKhiDyView = make_view(dKhiDyField); + for (size_t jz = 0; jz < nz_; ++jz) { + for (size_t js = 0; js < trans_->ns(); ++js) { + vorView(js, jz) = dPsiDxView(js, jz) - dPsiDyView(js, jz); + divView(js, jz) = dKhiDxView(js, jz) + dKhiDyView(js, jz); + } + } + + // Apply inverse Laplacian + trans_->inverseLaplacian(vorField); + trans_->inverseLaplacian(divField); + } else if (fftBackend_ == "ectrans" && !params_.dipoleTest.value()) { + // Reset number of levels for the wind transform + fset.fieldSet().metadata().set("nvordiv", 0); + } + + oops::Log::trace() << classname() << "::forwardAD done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierSpectralVorDivToGridWind::backward(oops::FieldSet3D & fset, + const oops::Variables & vars) const { + oops::Log::trace() << classname() << "::backward starting" << std::endl; + + if (params_.outerSphericalWinds.value()) { + // Rename wind fields + fset["eastward_wind"].rename("reduced_x_wind"); + fset["northward_wind"].rename("reduced_y_wind"); + } else { + // Rename wind fields + fset["geographical_x_wind"].rename("reduced_x_wind"); + fset["geographical_y_wind"].rename("reduced_y_wind"); + } + + // Get reduced wind fields + auto uField = fset["reduced_x_wind"]; + auto vField = fset["reduced_y_wind"]; + + // Get views + auto uView = atlas::array::make_view(uField); + auto vView = atlas::array::make_view(vField); + + if (params_.outerSphericalWinds.value()) { + // Get coefficients views + const auto dxDlonView = atlas::array::make_view(data_["dxDlon"]); + const auto dxDlatView = atlas::array::make_view(data_["dxDlat"]); + const auto dyDlonView = atlas::array::make_view(data_["dyDlon"]); + const auto dyDlatView = atlas::array::make_view(data_["dyDlat"]); + + for (int jnode = 0; jnode < uField.shape(0); ++jnode) { + // Inverse matrix + const double det = dxDlonView(jnode, 0)*dyDlatView(jnode, 0) + -dyDlonView(jnode, 0)*dxDlatView(jnode, 0); + const double dlonDx = dyDlatView(jnode, 0)/det; + const double dlonDy = -dyDlonView(jnode, 0)/det; + const double dlatDx = -dxDlatView(jnode, 0)/det; + const double dlatDy = dxDlonView(jnode, 0)/det; + + for (int jlevel = 0; jlevel < uField.shape(1); ++jlevel) { + // Apply inverse matrix + const double uSave = uView(jnode, jlevel); + const double vSave = vView(jnode, jlevel); + uView(jnode, jlevel) = uSave*dlonDx + vSave*dlonDy; + vView(jnode, jlevel) = uSave*dlatDx + vSave*dlatDy; + } + } + } + + if (fftBackend_ == "fftw") { + // Get map factor view + const auto mapFactorView = atlas::array::make_view(data_["map_factor"]); + + // Divide by the map factor + for (int jnode = 0; jnode < uField.shape(0); ++jnode) { + for (int jlevel = 0; jlevel < uField.shape(1); ++jlevel) { + uView(jnode, jlevel) /= mapFactorView(jnode, 0); + vView(jnode, jlevel) /= mapFactorView(jnode, 0); + } + } + } + + // Rename wind fields + fset["reduced_x_wind"].rename("air_upward_absolute_vorticity"); + fset["reduced_y_wind"].rename("air_horizontal_divergence"); + + if (fftBackend_ == "ectrans") { + // Set number of levels for the wind transform + fset.fieldSet().metadata().set("nvordiv", nz_); + } + + // Create temporary fieldset with the same metadata + atlas::FieldSet fsetTmp; + fsetTmp.metadata() = fset.fieldSet().metadata(); + + // Direct spectral transform + trans_->gp2sp(fset.fieldSet(), fsetTmp, vars); + + // Remove outer variables + util::removeFieldsFromFieldSet(fset.fieldSet(), vars.variables()); + + // Copy FieldSet + trans_->copyFieldSet(fsetTmp, fset.fieldSet(), vars); + + if (fftBackend_ == "fftw") { + // Get vorticity and divergence fields + auto vorField = fset["air_upward_absolute_vorticity"]; + ASSERT(vorField.shape(0) == static_cast(trans_->ns())); + ASSERT(vorField.shape(1) == static_cast(nz_)); + auto divField = fset["air_horizontal_divergence"]; + ASSERT(divField.shape(0) == static_cast(trans_->ns())); + ASSERT(divField.shape(1) == static_cast(nz_)); + + // Compute horizontal derivatives + atlas::Field dUDxField; + atlas::Field dUDyField; + atlas::Field dVDxField; + atlas::Field dVDyField; + trans_->derivative(vorField, dUDxField, "x"); + trans_->derivative(vorField, dUDyField, "y"); + trans_->derivative(divField, dVDxField, "x"); + trans_->derivative(divField, dVDyField, "y"); + + // Compute vor/div + auto vorView = make_view(vorField); + auto divView = make_view(divField); + const auto dUDxView = make_view(dUDxField); + const auto dUDyView = make_view(dUDyField); + const auto dVDxView = make_view(dVDxField); + const auto dVDyView = make_view(dVDyField); + for (size_t jz = 0; jz < nz_; ++jz) { + for (size_t js = 0; js < trans_->ns(); ++js) { + vorView(js, jz) = dVDxView(js, jz) - dUDyView(js, jz); + divView(js, jz) = dUDxView(js, jz) + dVDyView(js, jz); + } + } + } else if (fftBackend_ == "ectrans") { + // Reset number of levels for the wind transform + fset.fieldSet().metadata().set("nvordiv", 0); + } + + oops::Log::trace() << classname() << "::backward done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierSpectralVorDivToGridWind::backwardAD(oops::FieldSet3D & fset, + const oops::Variables & vars) const { + oops::Log::trace() << classname() << "::backwardAD starting" << std::endl; + + if (fftBackend_ == "fftw") { + // Get vorticity and divergence fields + auto vorField = fset["air_upward_absolute_vorticity"]; + ASSERT(vorField.shape(0) == static_cast(trans_->ns())); + ASSERT(vorField.shape(1) == static_cast(nz_)); + auto divField = fset["air_horizontal_divergence"]; + ASSERT(divField.shape(0) == static_cast(trans_->ns())); + ASSERT(divField.shape(1) == static_cast(nz_)); + + // Compute horizontal derivatives + atlas::Field dUDxField; + atlas::Field dUDyField; + atlas::Field dVDxField; + atlas::Field dVDyField; + trans_->derivative(divField, dUDxField, "x", true); + trans_->derivative(vorField, dUDyField, "y", true); + trans_->derivative(vorField, dVDxField, "x", true); + trans_->derivative(divField, dVDyField, "y", true); + + // Compute vor/div + auto vorView = make_view(vorField); + auto divView = make_view(divField); + const auto dUDxView = make_view(dUDxField); + const auto dUDyView = make_view(dUDyField); + const auto dVDxView = make_view(dVDxField); + const auto dVDyView = make_view(dVDyField); + for (size_t jz = 0; jz < nz_; ++jz) { + for (size_t js = 0; js < trans_->ns(); ++js) { + vorView(js, jz) = dUDxView(js, jz) - dUDyView(js, jz); + divView(js, jz) = dVDxView(js, jz) + dVDyView(js, jz); + } + } + } else if (fftBackend_ == "ectrans") { + // Set number of levels for the wind transform + fset.fieldSet().metadata().set("nvordiv", nz_); + } + + // Create temporary fieldset with the same metadata + atlas::FieldSet fsetTmp; + fsetTmp.metadata() = fset.fieldSet().metadata(); + + // Copy FieldSet + trans_->copyFieldSet(fset.fieldSet(), fsetTmp, vars); + + // Remove variables + util::removeFieldsFromFieldSet(fset.fieldSet(), vars.variables()); + + // Inverse spectral transform + trans_->gp2spAdj(fsetTmp, fset.fieldSet(), vars); + + // Rename wind fields + fset["air_upward_absolute_vorticity"].rename("reduced_x_wind"); + fset["air_horizontal_divergence"].rename("reduced_y_wind"); + + // Get reduced wind fields + auto uField = fset["reduced_x_wind"]; + auto vField = fset["reduced_y_wind"]; + + // Get views + auto uView = atlas::array::make_view(uField); + auto vView = atlas::array::make_view(vField); + + if (fftBackend_ == "fftw") { + // Get map factor view + const auto mapFactorView = atlas::array::make_view(data_["map_factor"]); + + // Divide by the map factor + for (int jnode = 0; jnode < uField.shape(0); ++jnode) { + for (int jlevel = 0; jlevel < uField.shape(1); ++jlevel) { + uView(jnode, jlevel) /= mapFactorView(jnode, 0); + vView(jnode, jlevel) /= mapFactorView(jnode, 0); + } + } + } + + if (params_.outerSphericalWinds.value()) { + // Get coefficients views + const auto dxDlonView = atlas::array::make_view(data_["dxDlon"]); + const auto dxDlatView = atlas::array::make_view(data_["dxDlat"]); + const auto dyDlonView = atlas::array::make_view(data_["dyDlon"]); + const auto dyDlatView = atlas::array::make_view(data_["dyDlat"]); + + for (int jnode = 0; jnode < uField.shape(0); ++jnode) { + // Inverse matrix + const double det = dxDlonView(jnode, 0)*dyDlatView(jnode, 0) + -dyDlonView(jnode, 0)*dxDlatView(jnode, 0); + const double dlonDx = dyDlatView(jnode, 0)/det; + const double dlonDy = -dyDlonView(jnode, 0)/det; + const double dlatDx = -dxDlatView(jnode, 0)/det; + const double dlatDy = dxDlonView(jnode, 0)/det; + + for (int jlevel = 0; jlevel < uField.shape(1); ++jlevel) { + // Apply inverse matrix + const double uSave = uView(jnode, jlevel); + const double vSave = vView(jnode, jlevel); + uView(jnode, jlevel) = uSave*dlonDx + vSave*dlatDx; + vView(jnode, jlevel) = uSave*dlonDy + vSave*dlatDy; + } + } + } + + if (params_.outerSphericalWinds.value()) { + // Rename wind fields + fset["reduced_x_wind"].rename("eastward_wind"); + fset["reduced_y_wind"].rename("northward_wind"); + } else { + // Rename wind fields + fset["reduced_x_wind"].rename("geographical_x_wind"); + fset["reduced_y_wind"].rename("geographical_y_wind"); + } + + if (fftBackend_ == "ectrans") { + // Reset number of levels for the wind transform + fset.fieldSet().metadata().set("nvordiv", 0); + } + + oops::Log::trace() << classname() << "::backwardAD done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierSpectralVorDivToGridWind::print(std::ostream & os) const { + os << classname(); +} + +// ----------------------------------------------------------------------------- + +} // namespace bifourier +} // namespace saber diff --git a/src/saber/bifourier/BifourierSpectralVorDivToGridWind.h b/src/saber/bifourier/BifourierSpectralVorDivToGridWind.h new file mode 100644 index 000000000..569ce7938 --- /dev/null +++ b/src/saber/bifourier/BifourierSpectralVorDivToGridWind.h @@ -0,0 +1,151 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#pragma once + +#include +#include +#include +#include + +#include "atlas/field.h" + +#include "oops/base/GeometryData.h" +#include "oops/base/Variables.h" + +#include "saber/bifourier/BifourierTransformBase.h" +#include "saber/bifourier/BifourierTransformStore.h" +#include "saber/bifourier/BiperiodizationImpl.h" +#include "saber/blocks/SaberBlockParametersBase.h" +#include "saber/blocks/SaberOuterBlockBase.h" + +namespace saber { +namespace bifourier { + +// ----------------------------------------------------------------------------- + +class BifourierSpectralVorDivToGridWindParameters : public SaberBlockParametersBase { + OOPS_CONCRETE_PARAMETERS(BifourierSpectralVorDivToGridWindParameters, SaberBlockParametersBase) + + public: + // Backward mode + oops::Parameter backward{"backward mode", false, this}; + + // Dipole test + oops::Parameter dipoleTest{"dipole test", false, this}; + + // Biperiodization parameters + oops::OptionalParameter biperParams{"biperiodization", + this}; + + // Outer spherical winds + oops::Parameter outerSphericalWinds{"outer spherical winds", false, this}; + + // Transform parameters + oops::Parameter transform{"transform", + BifourierTransformParameters(), this}; + + oops::Variables mandatoryActiveVars() const override { + oops::Variables mandatoryActiveVars; + mandatoryActiveVars.push_back("air_upward_absolute_vorticity"); + mandatoryActiveVars.push_back("air_horizontal_divergence"); + if (outerSphericalWinds) { + mandatoryActiveVars.push_back("eastward_wind"); + mandatoryActiveVars.push_back("northward_wind"); + } else { + mandatoryActiveVars.push_back("geographical_x_wind"); + mandatoryActiveVars.push_back("geographical_y_wind"); + } + return mandatoryActiveVars; + } +}; + +// ----------------------------------------------------------------------------- + +class BifourierSpectralVorDivToGridWind : public SaberOuterBlockBase { + public: + static const std::string classname() + {return "saber::bifourier::BifourierSpectralVorDivToGridWind";} + + typedef BifourierSpectralVorDivToGridWindParameters Parameters_; + + BifourierSpectralVorDivToGridWind(const oops::GeometryData &, + const oops::Variables &, + const eckit::Configuration &, + const Parameters_ &, + const oops::FieldSet3D &, + const oops::FieldSet3D &); + virtual ~BifourierSpectralVorDivToGridWind() = default; + + const oops::GeometryData & innerGeometryData() const override + {return *innerGeometryData_;} + const oops::Variables & innerVars() const override + {return innerVars_;} + + void multiply(oops::FieldSet3D &) const override; + void multiplyAD(oops::FieldSet3D &) const override; + void leftInverseMultiply(oops::FieldSet3D &) const override; + + void read() override + {} + + private: + // Inner geometry data + std::unique_ptr innerGeometryData_; + + // Communicator + const eckit::mpi::Comm & comm_; + + // Inner variables + oops::Variables innerVars_; + + // Outer variables + const oops::Variables outerVars_; + + // Parameters + Parameters_ params_; + + // Spectral transform + const BifourierTransformStore transStore_; + std::shared_ptr trans_; + + // FFT backend + const std::string fftBackend_; + + // Number of levels + size_t nz_; + + // Index js for (jk, jl) = (0, 0) + int jsZero_; + + // Map factor and Jacobian coefficients FieldSet + oops::FieldSet3D data_; + + // Private methods + + // Forward application + void forward(oops::FieldSet3D &, + const oops::Variables &) const; + + // Forward application, adjoint + void forwardAD(oops::FieldSet3D &, + const oops::Variables &) const; + + // Backward application + void backward(oops::FieldSet3D &, + const oops::Variables &) const; + + // Backward application, adjoint + void backwardAD(oops::FieldSet3D &, + const oops::Variables &) const; + + // Print + void print(std::ostream &) const override; +}; + +// ----------------------------------------------------------------------------- + +} // namespace bifourier +} // namespace saber diff --git a/src/saber/bifourier/BifourierSplitTPs.cc b/src/saber/bifourier/BifourierSplitTPs.cc deleted file mode 100644 index dafb2019d..000000000 --- a/src/saber/bifourier/BifourierSplitTPs.cc +++ /dev/null @@ -1,191 +0,0 @@ -/* - * (C) Copyright 2025 Meteorologisk Institutt - * - */ - -#include "saber/bifourier/BifourierSplitTPs.h" - -#include "atlas/field.h" - -using atlas::array::make_view; - -namespace saber { -namespace bifourier { - -// ----------------------------------------------------------------------------- - -static SaberOuterBlockMaker makerBifourierSplitTPs_("BifourierSplitTPs"); - -// ----------------------------------------------------------------------------- - -BifourierSplitTPs::BifourierSplitTPs(const oops::GeometryData & outerGeometryData, - const oops::Variables & outerVars, - const eckit::Configuration & covarConfig, - const Parameters_ & params, - const oops::FieldSet3D & xb, - const oops::FieldSet3D & fg) - : SaberOuterBlockBase(params, xb.validTime()), - innerGeometryData_(outerGeometryData), - comm_(outerGeometryData.comm()), - innerVars_(outerVars), - params_(params) -{ - oops::Log::trace() << classname() << "::BifourierSplitTPs starting" << std::endl; - - // Inner variables - if (!params_.backward.value()) { - // Add TPs to inner variables and remove T and Ps - nz_ = innerVars_["air_temperature"].getLevels(); - innerVars_.push_back("air_temperature_and_log_of_air_pressure_at_surface"); - innerVars_["air_temperature_and_log_of_air_pressure_at_surface"].setLevels(nz_+1); - innerVars_ -= innerVars_["air_temperature"]; - innerVars_ -= innerVars_["log_of_air_pressure_at_surface"]; - } else { - // Add T and Ps to inner variables and remove TPs - nz_ = innerVars_["air_temperature_and_log_of_air_pressure_at_surface"].getLevels()-1; - innerVars_.push_back("air_temperature"); - innerVars_["air_temperature"].setLevels(nz_); - innerVars_.push_back("log_of_air_pressure_at_surface"); - innerVars_["log_of_air_pressure_at_surface"].setLevels(1); - innerVars_ -= innerVars_["air_temperature_and_log_of_air_pressure_at_surface"]; - } - - // Retrieve spectral transform - trans_ = transStore_.retrieveTransform(outerGeometryData); - - oops::Log::trace() << classname() << "::BifourierSplitTPs done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierSplitTPs::multiply(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::multiply starting" << std::endl; - - if (!params_.backward.value()) { - // Forward application - forward(fset); - } else { - // Backward application - backward(fset); - } - - oops::Log::trace() << classname() << "::multiply done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierSplitTPs::multiplyAD(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; - - if (!params_.backward.value()) { - // Backward application - backward(fset); - } else { - // Forward application - forward(fset); - } - - oops::Log::trace() << classname() << "::multiplyAD done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierSplitTPs::leftInverseMultiply(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::leftInverseMultiply starting" << std::endl; - - if (!params_.backward.value()) { - // Backward application - backward(fset); - } else { - // Forward application - forward(fset); - } - - oops::Log::trace() << classname() << "::leftInverseMultiply done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierSplitTPs::forward(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::forward starting" << std::endl; - - // Get inner field - const auto tPsField = fset["air_temperature_and_log_of_air_pressure_at_surface"]; - - // Create outer fields - atlas::Field tField = trans_->spFspace()->createField( - atlas::option::name("air_temperature") | atlas::option::levels(nz_)); - atlas::Field psField = trans_->spFspace()->createField( - atlas::option::name("log_of_air_pressure_at_surface") | atlas::option::levels(1)); - - // Get fields views - const auto tPsView = make_view(tPsField); - auto tView = make_view(tField); - auto psView = make_view(psField); - - // Copy data - for (size_t js = 0; js < trans_->ns(); ++js) { - for (size_t jz = 0; jz < nz_; ++jz) { - tView(js, jz) = tPsView(js, jz); - } - psView(js, 0) = tPsView(js, nz_); - } - - // Remove inner field - util::removeFieldsFromFieldSet(fset.fieldSet(), - {"air_temperature_and_log_of_air_pressure_at_surface"}); - - // Add outer fields - fset.add(tField); - fset.add(psField); - - oops::Log::trace() << classname() << "::forward done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierSplitTPs::backward(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::backward starting" << std::endl; - - // Get outer fields - const auto tField = fset["air_temperature"]; - const auto psField = fset["log_of_air_pressure_at_surface"]; - - // Create inner field - atlas::Field tPsField = trans_->spFspace()->createField( - atlas::option::name("air_temperature_and_log_of_air_pressure_at_surface") | - atlas::option::levels(nz_+1)); - - // Get fields views - const auto tView = make_view(tField); - const auto psView = make_view(psField); - auto tPsView = make_view(tPsField); - - // Copy data - for (size_t js = 0; js < trans_->ns(); ++js) { - for (size_t jz = 0; jz < nz_; ++jz) { - tPsView(js, jz) = tView(js, jz); - } - tPsView(js, nz_) = psView(js, 0); - } - - // Remove outer fields - util::removeFieldsFromFieldSet(fset.fieldSet(), {"air_temperature", - "log_of_air_pressure_at_surface"}); - - // Add inner field - fset.add(tPsField); - - oops::Log::trace() << classname() << "::backward done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierSplitTPs::print(std::ostream & os) const { - os << classname(); -} - -// ----------------------------------------------------------------------------- - -} // namespace bifourier -} // namespace saber diff --git a/src/saber/bifourier/BifourierSplitTPs.h b/src/saber/bifourier/BifourierSplitTPs.h deleted file mode 100644 index 6f901b289..000000000 --- a/src/saber/bifourier/BifourierSplitTPs.h +++ /dev/null @@ -1,104 +0,0 @@ -/* - * (C) Copyright 2025 Meteorologisk Institutt - * - */ - -#pragma once - -#include -#include -#include -#include - -#include "oops/base/GeometryData.h" -#include "oops/base/Variables.h" -#include "oops/util/parameters/Parameters.h" - -#include "saber/bifourier/BifourierTransformStore.h" -#include "saber/blocks/SaberBlockParametersBase.h" -#include "saber/blocks/SaberOuterBlockBase.h" - -namespace saber { -namespace bifourier { - -// ----------------------------------------------------------------------------- - -class BifourierSplitTPsParameters : public SaberBlockParametersBase { - OOPS_CONCRETE_PARAMETERS(BifourierSplitTPsParameters, SaberBlockParametersBase) - - public: - // Backward mode - oops::Parameter backward{"backward mode", false, this}; - - oops::Variables mandatoryActiveVars() const override {return oops::Variables( - std::vector({ - "air_temperature", - "log_of_air_pressure_at_surface", - "air_temperature_and_log_of_air_pressure_at_surface"}));} -}; - -// ----------------------------------------------------------------------------- - -class BifourierSplitTPs : public SaberOuterBlockBase { - public: - static const std::string classname() - {return "saber::bifourier::BifourierSplitTPs";} - - typedef BifourierSplitTPsParameters Parameters_; - - BifourierSplitTPs(const oops::GeometryData &, - const oops::Variables &, - const eckit::Configuration &, - const Parameters_ &, - const oops::FieldSet3D &, - const oops::FieldSet3D &); - virtual ~BifourierSplitTPs() = default; - - const oops::GeometryData & innerGeometryData() const override - {return innerGeometryData_;} - const oops::Variables & innerVars() const override - {return innerVars_;} - - void multiply(oops::FieldSet3D &) const override; - void multiplyAD(oops::FieldSet3D &) const override; - void leftInverseMultiply(oops::FieldSet3D &) const override; - - void read() override - {} - - private: - // Inner geometry data - const oops::GeometryData & innerGeometryData_; - - // Communicator - const eckit::mpi::Comm & comm_; - - // Inner variables - oops::Variables innerVars_; - - // Parameters - Parameters_ params_; - - // Spectral transform - const BifourierTransformStore transStore_; - std::shared_ptr trans_; - - // Number of levels - size_t nz_; - - // Private methods - - // Forward application - void forward(oops::FieldSet3D &) const; - - // Backward application - void backward(oops::FieldSet3D &) const; - - // Print - void print(std::ostream &) const override; -}; - -// ----------------------------------------------------------------------------- - -} // namespace bifourier -} // namespace saber diff --git a/src/saber/bifourier/BifourierTransform.cc b/src/saber/bifourier/BifourierTransform.cc deleted file mode 100644 index fe8dd243a..000000000 --- a/src/saber/bifourier/BifourierTransform.cc +++ /dev/null @@ -1,1882 +0,0 @@ -/* - * (C) Copyright 2025 Meteorologisk Institutt - * - */ - -#include "saber/bifourier/BifourierTransform.h" - -#include -#include - -#include "eckit/exception/Exceptions.h" - -#include "oops/util/FieldSetHelpers.h" -#include "oops/util/FieldSetOperations.h" -#include "oops/util/FloatCompare.h" -#include "oops/util/Logger.h" -#include "oops/util/RandomField.h" - -#include "saber/bifourier/BifourierUtilities.h" - -using atlas::array::make_datatype; -using atlas::array::make_indexview; -using atlas::array::make_shape; -using atlas::array::make_view; - -namespace saber { -namespace bifourier { - -// ----------------------------------------------------------------------------- - -BifourierTransform::BifourierTransform(const oops::GeometryData & gdata, - const std::string & gridUid, - const oops::Variables & activeVars, - const eckit::Configuration & params) : - gdata_(gdata), - comm_(gdata_.comm()), - myrank_(comm_.rank()), - params_(params), - gridUid_(gridUid) -{ - oops::Log::trace() << classname() << "::BifourierTransform starting" << std::endl; - - // Check function space type - ASSERT(gdata_.functionSpace().type() == "StructuredColumns"); - - // Print active variables - oops::Log::info() << "Info : New Bifourier transform" << std::endl; - oops::Log::info() << "Info : - Active variable: " << activeVars << std::endl; - - // Get function space - const atlas::functionspace::StructuredColumns fs(gdata_.functionSpace()); - - // Get grid size - nx_ = fs.grid().nx()[0]; - ny_ = fs.grid().ny(); - nodes_ = fs.size(); - oops::Log::test() << "- Regional grid size: " << nx_ << "x" << ny_ << std::endl; - - // Cell size - dx_ = fs.grid().dx(0); - dy_ = fs.grid().y(1) - fs.grid().y(0); - oops::Log::test() << "- Cell sizes: " << dx_*1.0e-3 << " km x " << dy_*1.0e-3 << " km" - << std::endl; - - // Mean latitude - atlas::PointLonLat p1 = fs.grid().lonlat(0, 0); - atlas::PointLonLat p2 = fs.grid().lonlat(nx_-1, ny_-1); - meanLat_ = 0.5*(p1[1]+p2[1]); - oops::Log::test() << "- Mean latitude: " << meanLat_ << " deg" << std::endl; - - // Number of levels for all variables - nvz_ = 0; - for (const auto & var : activeVars) { - nvz_ += var.getLevels(); - } - - // Setup global spectral space parameters - setupGlobalSpectralSpace(); - - // Setup parallelization - setupParallelization(); - - // Setup local spectral space - setupLocalSpectralSpace(); - - // Setup FFT - setupFFT(); - - if (!params_.getBool("skip tests")) { - // Get tests tolerance - const double tolerance = params_.getDouble("spectral tolerance"); - - // Generate random FieldSet - atlas::FieldSet gpFset = util::createRandomFieldSet(comm_, gdata_.functionSpace(), activeVars); - - // Truncate grid-point field - atlas::FieldSet spFset; - gp2sp(gpFset, spFset, activeVars); - sp2gp(spFset, gpFset, activeVars); - - // Grid-point to spectral - gp2sp(gpFset, spFset, activeVars); - - // Check inverse - atlas::FieldSet gpFsetTest = util::copyFieldSet(gpFset); - sp2gp(spFset, gpFsetTest, activeVars); - ASSERT(util::compareFieldSets(comm_, gpFset, gpFsetTest)); - oops::Log::test() << "- Direct-inverse test passed" << std::endl; - - // Check forward - atlas::FieldSet spFsetTest; - gp2sp(gpFsetTest, spFsetTest, activeVars); - for (const auto & var : activeVars) { - const size_t nz = var.getLevels(); - const auto spField = spFset[var.name()]; - const auto spFieldTest = spFsetTest[var.name()]; - const auto spView = make_view(spField); - const auto spViewTest = make_view(spFieldTest); - int wrongValues = 0; - for (size_t js = 0; js < ns_; ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - if (!oops::is_close_relative(spView(js, jz), spViewTest(js, jz), tolerance)) { - ++wrongValues; - } - } - } - comm_.allReduceInPlace(wrongValues, eckit::mpi::sum()); - ASSERT(wrongValues == 0); - } - oops::Log::test() << "- Inverse-direct test passed" << std::endl; - - // Check Parseval's identity - double gpSqNorm = util::dotProductFieldSets(gpFset, gpFset, activeVars.variables(), comm_); - double spSqNorm = util::dotProductFieldSets(spFset, spFset, activeVars.variables(), comm_); - ASSERT(oops::is_close_relative(gpSqNorm, spSqNorm, tolerance)); - oops::Log::test() << "- Parseval identity test passed" << std::endl; - - // Adjoint test - createRandomSpectralFieldSet(spFsetTest, activeVars); - sp2gp(spFsetTest, gpFsetTest, activeVars); - gpSqNorm = util::dotProductFieldSets(gpFset, gpFsetTest, activeVars.variables(), comm_); - spSqNorm = util::dotProductFieldSets(spFset, spFsetTest, activeVars.variables(), comm_); - ASSERT(oops::is_close_relative(gpSqNorm, spSqNorm, tolerance)); - oops::Log::test() << "- Adjoint test passed" << std::endl; - - // Derivatives / Laplacian consistency test - for (const auto & var : activeVars) { - // Get field - const size_t nz = var.getLevels(); - auto spField = spFset[var.name()]; - - // Double derivative in X direction - atlas::Field spDxField; - derivative(spField, spDxField, "x"); - atlas::Field spDx2Field; - derivative(spDxField, spDx2Field, "x"); - - // Double derivative in Y direction - atlas::Field spDyField; - derivative(spField, spDyField, "y"); - atlas::Field spDy2Field; - derivative(spDyField, spDy2Field, "y"); - - // Direct Laplacian - atlas::Field spLapDirField = spField.clone(); - directLaplacian(spLapDirField); - - // Comparison - const auto spDx2View = make_view(spDx2Field); - const auto spDy2View = make_view(spDy2Field); - const auto spLapDirView = make_view(spLapDirField); - int wrongValues = 0; - for (size_t js = 0; js < ns_; ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - if (!oops::is_close_relative(spLapDirView(js, jz), spDx2View(js, jz) + spDy2View(js, jz), - tolerance)) { - ++wrongValues; - } - } - } - comm_.allReduceInPlace(wrongValues, eckit::mpi::sum()); - ASSERT(wrongValues == 0); - } - oops::Log::test() << "- Derivatives / direct Laplacian consistency test passed" << std::endl; - } - - oops::Log::trace() << classname() << "::BifourierTransform done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -BifourierTransform::~BifourierTransform() { - cleanupFFT(); -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::gp2sp(const atlas::FieldSet & gpFset, - atlas::FieldSet & spFset, - const oops::Variables & activeVars) const { - oops::Log::trace() << classname() << "::gp2sp starting" << std::endl; - - // Check the number of required levels - size_t nvz = 0; - for (const auto & var : activeVars) { - nvz += var.getLevels(); - } - ASSERT(nvz == nvz_); - - // Create send and recv vectors - std::vector sendVec; - std::vector recvVec; - - // Ghost points - const auto ghostView = make_view(gdata_.functionSpace().ghost()); - - // Serialize from grid-point FieldSet - recvVec.resize(gridRecvSize_*nvz_); - size_t zOffset = 0; - for (const auto & var : activeVars) { - // Get number of vertical levels - const size_t nz = var.getLevels(); - - // Check field - const auto gpField = gpFset[var.name()]; - ASSERT(gpField.shape(0) == static_cast(nodes_)); - ASSERT(gpField.shape(1) == static_cast(nz)); - - // Get field view - const auto gpView = make_view(gpField); - size_t jgr = 0; - for (size_t jnode = 0; jnode < nodes_; ++jnode) { - if (ghostView(jnode) == 0) { - for (size_t jz = 0; jz < nz; ++jz) { - // Total level index - const size_t jvz = zOffset + jz; - - // Communication vector index - const size_t jgrv = gridRecvIndex_[jgr] + jvz; - - // Copy data - recvVec[jgrv] = gpView(jnode, jz); - } - ++jgr; - } - } - - // Update total number of levels - zOffset += nz; - } - - // Communication - sendVec.resize(rowsSendSize_*nvz_); - comm_.allToAllv(recvVec.data(), gridRecvCounts_.data(), gridRecvDispls_.data(), - sendVec.data(), rowsSendCounts_.data(), rowsSendDispls_.data()); - - // Reserialize - for (size_t jrs = 0; jrs < rowsSendSize_; ++jrs) { - for (size_t jvz = 0; jvz < nvz_; ++jvz) { - // Communication vector index - const size_t jrsv = jrs*nvz_ + jvz; - - // FFT vector index - size_t jf = rowsSendIndex_[jrs] + jvz*nx_; - - // Copy data - rowsBufR_[jf] = sendVec[jrsv]; - } - } - - // Compute direct transform - fftw_execute(rowsPlan_r2c_); - - // Reserialize - recvVec.resize(rowsRecvSize_*nvz_*2); - size_t jrr = 0; - for (size_t jy = 0; jy < nyPerTask_[myrank_]; ++jy) { - for (size_t jk = 0; jk < nk_; ++jk) { - for (size_t jvz = 0; jvz < nvz_; ++jvz) { - // FFT vector index - const size_t jf = jy*nvz_*nk_ + jvz*nk_ + jk; - - // Communication vector index - const size_t jrrv = rowsRecvIndex_[jrr] + jvz*2; - - // Copy data - recvVec[jrrv] = rowsBufC_[jf][0]; - recvVec[jrrv+1] = rowsBufC_[jf][1]; - } - ++jrr; - } - } - - // Communication - sendVec.resize(colsSendSize_*nvz_*2); - comm_.allToAllv(recvVec.data(), rowsRecvCounts_.data(), rowsRecvDispls_.data(), - sendVec.data(), colsSendCounts_.data(), colsSendDispls_.data()); - - // Reserialize - for (size_t jcs = 0; jcs < colsSendSize_; ++jcs) { - for (size_t jvz = 0; jvz < nvz_; ++jvz) { - // Communication vector index - const size_t jcsv = jcs*nvz_*2 + jvz*2; - - // FFT vector index - const size_t jf = colsSendIndex_[jcs] + jvz*2*ny_; - - // Copy data - colsBufR_[jf] = sendVec[jcsv]; - colsBufR_[jf+ny_] = sendVec[jcsv+1]; - } - } - - // Compute direct transform - fftw_execute(colsPlan_r2c_); - - // Reserialize - recvVec.resize(colsRecvSize_*nvz_); - size_t jj = 0; - for (size_t jk = 0; jk < nkPerTask_[myrank_]; ++jk) { - for (size_t jl = 0; jl < nl_; ++jl) { - for (size_t jc = 0; jc < colsJq_[jk*nl_+jl].size(); ++jc) { - // Get jq - const size_t jq = colsJq_[jk*nl_+jl][jc]; - - for (size_t jvz = 0; jvz < nvz_; ++jvz) { - // FFT vector index - const size_t jf = jk*nvz_*2*nl_ + jvz*2*nl_ + jl; - - // Communication vector index - const size_t jcrv = colsRecvIndex_[jj] + jvz; - - // Copy data - if (jq == 0) { - recvVec[jcrv] = colsBufC_[jf][0]; - } - if (jq == 1) { - recvVec[jcrv] = colsBufC_[jf][1]; - } - if (jq == 2) { - recvVec[jcrv] = colsBufC_[jf+nl_][0]; - } - if (jq == 3) { - recvVec[jcrv] = colsBufC_[jf+nl_][1]; - } - } - - // Update communication vector index - ++jj; - } - } - } - - // Communication - sendVec.resize(eqchSendSize_*nvz_); - comm_.allToAllv(recvVec.data(), colsRecvCounts_.data(), colsRecvDispls_.data(), - sendVec.data(), eqchSendCounts_.data(), eqchSendDispls_.data()); - - // Prepare spectral FieldSet - for (const auto & var : activeVars) { - // Get number of vertical levels - const size_t nz = var.getLevels(); - - if (spFset.has(var.name())) { - // Check sizes - ASSERT(spFset[var.name()].shape(0) == static_cast(ns_)); - ASSERT(spFset[var.name()].shape(1) == static_cast(nz)); - } else { - // Create field - atlas::Field spField = spFspace_->createField( - atlas::option::name(var.name()) | atlas::option::levels(nz)); - spFset.add(spField); - } - } - - // Reserialize into spectral FieldSet - zOffset = 0; - for (const auto & var : activeVars) { - // Get number of vertical levels - const size_t nz = var.getLevels(); - - // Get field - auto spField = spFset[var.name()]; - - // Get field view - auto spView = make_view(spField); - - for (size_t jes = 0; jes < eqchSendSize_; ++jes) { - for (size_t jz = 0; jz < nz; ++jz) { - // Total level index - const size_t jvz = zOffset + jz; - - // Spectral index - const size_t js = eqchSendIndex_[jes]; - - // Communication vector index - const size_t jesv = jes*nvz_+jvz; - - // Copy data - spView(js, jz) = sendVec[jesv]; - - // Normalize FFT - spView(js, jz) *= std::sqrt(normFFT_*spNorm(js)); - } - } - - // Update total number of levels - zOffset += nz; - } - - oops::Log::trace() << classname() << "::gp2sp done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::sp2gp(const atlas::FieldSet & spFset, - atlas::FieldSet & gpFset, - const oops::Variables & activeVars) const { - oops::Log::trace() << classname() << "::sp2gp starting" << std::endl; - - // Check the number of required levels - size_t nvz = 0; - for (const auto & var : activeVars) { - nvz += var.getLevels(); - } - ASSERT(nvz == nvz_); - - // Create send and recv vectors - std::vector sendVec; - std::vector recvVec; - - // Reserialize from spectral FieldSet - sendVec.resize(eqchSendSize_*nvz_); - size_t zOffset = 0; - for (const auto & var : activeVars) { - // Get number of vertical levels - const size_t nz = var.getLevels(); - - // Check field - const auto spField = spFset[var.name()]; - ASSERT(spField.shape(0) == static_cast(ns_)); - ASSERT(spField.shape(1) == static_cast(nz)); - - // Get field view - const auto spView = make_view(spField); - - for (size_t jes = 0; jes < eqchSendSize_; ++jes) { - for (size_t jz = 0; jz < nz; ++jz) { - // Total level index - const size_t jvz = zOffset + jz; - - // Spectral index - const size_t js = eqchSendIndex_[jes]; - - // Communication vector index - const size_t jesv = jes*nvz_+jvz; - - // Copy data - sendVec[jesv] = spView(js, jz); - - // Normalize FFT - sendVec[jesv] *= std::sqrt(normFFT_/spNorm(js)); - } - } - - // Update total number of levels - zOffset += nz; - } - - // Communication - recvVec.resize(colsRecvSize_*nvz_); - comm_.allToAllv(sendVec.data(), eqchSendCounts_.data(), eqchSendDispls_.data(), - recvVec.data(), colsRecvCounts_.data(), colsRecvDispls_.data()); - - // Set FFT vector to zero - for (size_t jj = 0; jj < nkPerTask_[myrank_]*nl_*nvz_*2; ++jj) { - colsBufC_[jj][0] = 0.0; - colsBufC_[jj][1] = 0.0; - } - - // Reserialize - size_t jj = 0; - for (size_t jk = 0; jk < nkPerTask_[myrank_]; ++jk) { - for (size_t jl = 0; jl < nl_; ++jl) { - for (size_t jc = 0; jc < colsJq_[jk*nl_+jl].size(); ++jc) { - // Get jq - const size_t jq = colsJq_[jk*nl_+jl][jc]; - - for (size_t jvz = 0; jvz < nvz_; ++jvz) { - // FFT vector index - const size_t jf = jk*nvz_*2*nl_ + jvz*2*nl_ + jl; - - // Communication vector index - const size_t jcrv = colsRecvIndex_[jj] + jvz; - - // Copy data - if (jq == 0) { - colsBufC_[jf][0] = recvVec[jcrv]; - } - if (jq == 1) { - colsBufC_[jf][1] = recvVec[jcrv]; - } - if (jq == 2) { - colsBufC_[jf+nl_][0] = recvVec[jcrv]; - } - if (jq == 3) { - colsBufC_[jf+nl_][1] = recvVec[jcrv]; - } - } - - // Update communication vector index - ++jj; - } - } - } - - // Compute inverse transform - fftw_execute(colsPlan_c2r_); - - // Reserialize - sendVec.resize(colsSendSize_*nvz_*2); - for (size_t jcs = 0; jcs < colsSendSize_; ++jcs) { - for (size_t jvz = 0; jvz < nvz_; ++jvz) { - // Communication vector index - const size_t jcsv = jcs*nvz_*2 + jvz*2; - - // FFT vector index - const size_t jf = colsSendIndex_[jcs] + jvz*2*ny_; - - // Copy data - sendVec[jcsv] = colsBufR_[jf]; - sendVec[jcsv+1] = colsBufR_[jf+ny_]; - } - } - - // Communication - recvVec.resize(rowsRecvSize_*nvz_*2); - comm_.allToAllv(sendVec.data(), colsSendCounts_.data(), colsSendDispls_.data(), - recvVec.data(), rowsRecvCounts_.data(), rowsRecvDispls_.data()); - - // Reserialize - size_t jrr = 0; - for (size_t jy = 0; jy < nyPerTask_[myrank_]; ++jy) { - for (size_t jk = 0; jk < nk_; ++jk) { - for (size_t jvz = 0; jvz < nvz_; ++jvz) { - // FFT vector index - const size_t jf = jy*nvz_*nk_ + jvz*nk_ + jk; - - // Communication vector index - const size_t jrrv = rowsRecvIndex_[jrr] + jvz*2; - - // Copy data - rowsBufC_[jf][0] = recvVec[jrrv]; - rowsBufC_[jf][1] = recvVec[jrrv+1]; - } - ++jrr; - } - } - - // Compute inverse transform - fftw_execute(rowsPlan_c2r_); - - // Reserialize - sendVec.resize(rowsSendSize_*nvz_); - for (size_t jrs = 0; jrs < rowsSendSize_; ++jrs) { - for (size_t jvz = 0; jvz < nvz_; ++jvz) { - // Communication vector index - const size_t jrsv = jrs*nvz_ + jvz; - - // FFT vector index - const size_t jf = rowsSendIndex_[jrs] + jvz*nx_; - - // Copy data - sendVec[jrsv] = rowsBufR_[jf]; - } - } - - // Communication - recvVec.resize(gridRecvSize_*nvz_); - comm_.allToAllv(sendVec.data(), rowsSendCounts_.data(), rowsSendDispls_.data(), - recvVec.data(), gridRecvCounts_.data(), gridRecvDispls_.data()); - - // Prepare grid-point FieldSet - for (const auto & var : activeVars) { - // Get number of vertical levels - const size_t nz = var.getLevels(); - - if (gpFset.has(var.name())) { - // Check sizes - ASSERT(gpFset[var.name()].shape(0) == static_cast(nodes_)); - ASSERT(gpFset[var.name()].shape(1) == static_cast(nz)); - } else { - // Create field - atlas::Field gpField = gdata_.functionSpace().createField( - atlas::option::name(var.name()) | atlas::option::levels(nz)); - gpFset.add(gpField); - } - } - - // Ghost points - const auto ghostView = make_view(gdata_.functionSpace().ghost()); - - // Deserialize into grid-point FieldSet - zOffset = 0; - for (const auto & var : activeVars) { - // Get number of vertical levels - const size_t nz = var.getLevels(); - - // Get field - auto gpField = gpFset[var.name()]; - - // Get field view - auto gpView = make_view(gpField); - size_t jgr = 0; - for (size_t jnode = 0; jnode < nodes_; ++jnode) { - if (ghostView(jnode) == 0) { - for (size_t jz = 0; jz < nz; ++jz) { - // Total level index - const size_t jvz = zOffset + jz; - - // Communication vector index - const size_t jgrv = gridRecvIndex_[jgr] + jvz; - - // Copy data - gpView(jnode, jz) = recvVec[jgrv]; - } - ++jgr; - } - } - - // Update total number of levels - zOffset += nz; - } - - oops::Log::trace() << classname() << "::sp2gp done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::createRandomSpectralFieldSet(atlas::FieldSet & spFset, - const oops::Variables & activeVars) const { - oops::Log::trace() << classname() << "::createRandomSpectralFieldSet starting" << std::endl; - - // Check the number of required levels - size_t nvz = 0; - for (const auto & var : activeVars) { - nvz += var.getLevels(); - } - ASSERT(nvz == nvz_); - - // Global vector - std::vector rand_vec_glb; - - if (myrank_ == 0) { - // Generate global random vector - rand_vec_glb.resize(nsGlb_*nvz_); - util::NormalDistributionField dist(nsGlb_*nvz_, 0.0, 1.0); - for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { - for (size_t jvz = 0; jvz < nvz_; ++jvz) { - const size_t jj = jsGlb*nvz_ + jvz; - const size_t jjOrdered = sMapping_[jsGlb]*nvz_ + jvz; - rand_vec_glb[jj] = dist[jjOrdered]; - } - } - } - - // Scatter random vector - std::vector counts = sCounts_; - std::vector displs = sDispls_; - for (size_t jt = 0; jt < comm_.size(); ++jt) { - counts[jt] *= nvz_; - displs[jt] *= nvz_; - } - std::vector rand_vec_loc(ns_*nvz_); - comm_.scatterv(rand_vec_glb.cbegin(), rand_vec_glb.cend(), counts, displs, - rand_vec_loc.begin(), rand_vec_loc.end(), 0); - - // Prepare spectral FieldSet - for (const auto & var : activeVars) { - // Get number of vertical levels - const size_t nz = var.getLevels(); - - if (spFset.has(var.name())) { - // Check sizes - ASSERT(spFset[var.name()].shape(0) == static_cast(ns_)); - ASSERT(spFset[var.name()].shape(1) == static_cast(nz)); - } else { - // Create field - atlas::Field spField = spFspace_->createField( - atlas::option::name(var.name()) | atlas::option::levels(nz)); - spFset.add(spField); - } - } - - // Reserialize into spectral FieldSet - size_t zOffset = 0; - for (const auto & var : activeVars) { - // Get number of vertical levels - const size_t nz = var.getLevels(); - - // CHeck field - auto spField = spFset[var.name()]; - ASSERT(spField.shape(0) == static_cast(ns_)); - ASSERT(spField.shape(1) == static_cast(nz)); - - // Get field view - auto spView = make_view(spField); - - for (size_t js = 0; js < ns_; ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - // Total level index - const size_t jvz = zOffset + jz; - - // Random vector index - const size_t jr = js*nvz_ + jvz; - - // Copy data - spView(js, jz) = rand_vec_loc[jr]; - } - } - - // Update total number of levels - zOffset += nz; - } - - oops::Log::trace() << classname() << "::createRandomSpectralFieldSet done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::derivative(const atlas::Field & spField, - atlas::Field & spDerivField, - const std::string & direction, - const bool & adjoint) const { - oops::Log::trace() << classname() << "::derivative starting" << std::endl; - - // Check field size - ASSERT(spField.shape(0) == static_cast(ns_)); - - // Get number of vertical levels - const size_t nz = spField.shape(1); - - if (spDerivField.valid()) { - // spDerivField is already allocated - ASSERT(spDerivField.shape(0) == static_cast(ns_)); - ASSERT(spDerivField.shape(1) == static_cast(nz)); - } else { - // Allocate spDerivField - spDerivField = spField.clone(); - } - - // Get fields views - const auto spView = make_view(spField); - auto spDerivView = make_view(spDerivField); - - // Get derivative linear operator - const auto firstIndexView = adjoint ? - make_view(derivatives_[direction + "DerivCol"]) : - make_view(derivatives_[direction + "DerivRow"]); - const auto secondIndexView = adjoint ? - make_view(derivatives_[direction + "DerivRow"]) : - make_view(derivatives_[direction + "DerivCol"]); - const auto factorView = make_view(derivatives_[direction + "DerivS"]); - - // Apply derivative linear operator - spDerivView.assign(0.0); - for (size_t js = 0; js < ns_; ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - spDerivView(firstIndexView(js), jz) = spView(secondIndexView(js), jz)*factorView(js); - } - } - - oops::Log::trace() << classname() << "::derivative done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::directLaplacian(atlas::Field & field) const { - oops::Log::trace() << classname() << "::directLaplacian starting" << std::endl; - - // Check field size - ASSERT(field.shape(0) == static_cast(ns_)); - - // Get number of vertical levels - const size_t nz = field.shape(1); - - // Get field view - auto view = make_view(field); - - // Apply direct Laplacian factor - for (size_t js = 0; js < ns_; ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - view(js, jz) *= lapDirVec_[js]; - } - } - - oops::Log::trace() << classname() << "::directLaplacian done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::inverseLaplacian(atlas::Field & field) const { - oops::Log::trace() << classname() << "::inverseLaplacian starting" << std::endl; - - // Check field size - ASSERT(field.shape(0) == static_cast(ns_)); - - // Get number of vertical levels - const size_t nz = field.shape(1); - - // Get field view - auto view = make_view(field); - - // Apply inverse Laplacian factor - for (size_t js = 0; js < ns_; ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - view(js, jz) *= lapInvVec_[js]; - } - } - oops::Log::trace() << classname() << "::inverseLaplacian done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::cv2fset(const atlas::Field & cv, - atlas::FieldSet & fset, - const oops::Variables & activeVars, - const size_t & offset) const { - oops::Log::trace() << classname() << "::cv2fset starting" << std::endl; - - // Check the number of required levels - size_t nvz = 0; - for (const auto & var : activeVars) { - nvz += var.getLevels(); - } - ASSERT(nvz == nvz_); - - // Clear FieldSet - fset.clear(); - - // Get control vector view - const auto cvView = make_view(cv); - - size_t zOffset = 0; - for (const auto & var : activeVars) { - // Get number of vertical levels - const size_t nz = var.getLevels(); - - // Create field - atlas::Field spField = spFspace_->createField( - atlas::option::name(var.name()) | atlas::option::levels(nz)); - fset.add(spField); - - // Get field view - auto spView = make_view(spField); - - for (size_t jz = 0; jz < nz; ++jz) { - // Total level index - const size_t jvz = zOffset + jz; - - for (size_t js = 0; js < ns_; ++js) { - // Control vector index - const size_t jcv = offset + jvz*ns_ + js; - - // Copy data - spView(js, jz) = cvView(jcv); - } - } - - // Update total number of levels - zOffset += nz; - } - - oops::Log::trace() << classname() << "::cv2fset done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::fset2cv(const atlas::FieldSet & fset, - atlas::Field & cv, - const oops::Variables & activeVars, - const size_t & offset) const { - oops::Log::trace() << classname() << "::fset2cv starting" << std::endl; - - // Check the number of required levels - size_t nvz = 0; - for (const auto & var : activeVars) { - nvz += var.getLevels(); - } - ASSERT(nvz == nvz_); - - // Get CV view - auto cvView = make_view(cv); - - size_t zOffset = 0; - for (const auto & var : activeVars) { - // Get number of vertical levels - const size_t nz = var.getLevels(); - - // Check field - const auto spField = fset[var.name()]; - ASSERT(spField.shape(0) == static_cast(ns_)); - ASSERT(spField.shape(1) == static_cast(nz)); - - // Get field view - const auto spView = make_view(spField); - - for (size_t jz = 0; jz < nz; ++jz) { - // Total level index - const size_t jvz = zOffset + jz; - - for (size_t js = 0; js < ns_; ++js) { - // Control vector index - const size_t jcv = offset + jvz*ns_ + js; - - // Copy data - cvView(jcv) = spView(js, jz); - } - } - - // Update total number of levels - zOffset += nz; - } - - oops::Log::trace() << classname() << "::fset2cv done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::copyFieldSet(const atlas::FieldSet & spInputFset, - atlas::FieldSet & spOutputFset, - const oops::Variables & activeVars) const { - oops::Log::trace() << classname() << "::copyFieldSet starting" << std::endl; - - // Check the number of required levels - size_t nvz = 0; - for (const auto & var : activeVars) { - nvz += var.getLevels(); - } - ASSERT(nvz == nvz_); - - // Remove active variables from output FieldSet - util::removeFieldsFromFieldSet(spOutputFset, activeVars.variables()); - - for (const auto & var : activeVars) { - // Get number of vertical levels - const size_t nz = var.getLevels(); - - // Check input field - const auto spInputField = spInputFset[var.name()]; - ASSERT(spInputField.shape(0) == static_cast(ns_)); - ASSERT(spInputField.shape(1) == static_cast(nz)); - - // Create output field - atlas::Field spOutputField = spFspace_->createField( - atlas::option::name(var.name()) | atlas::option::levels(nz)); - spOutputFset.add(spOutputField); - - // Get fields views - const auto spInputView = make_view(spInputField); - auto spOutputView = make_view(spOutputField); - - for (size_t jz = 0; jz < nz; ++jz) { - for (size_t js = 0; js < ns_; ++js) { - // Copy data - spOutputView(js, jz) = spInputView(js, jz); - } - } - } - - oops::Log::trace() << classname() << "::copyFieldSet done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -double BifourierTransform::kstar(const size_t & jk, - const size_t & jl, - const size_t & nk, - const size_t & nl, - const size_t & nwGlb) const { - const double w = static_cast(nwGlb-1)*std::sqrt( - static_cast(jk*jk)/static_cast((nk-2)*(nk-2)) - + static_cast(jl*jl)/static_cast((nl-2)*(nl-2))); - return w; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::print(std::ostream & os) const { - os << classname(); -} - - -// ----------------------------------------------------------------------------- - -void BifourierTransform::setupGlobalSpectralSpace() { - oops::Log::trace() << classname() << "::setupGlobalSpectralSpace starting" << std::endl; - - // Maximum wave numbers - nk_ = nx_/2+1; - nl_ = ny_/2+1; - oops::Log::test() << "- Spectral sizes: " << nk_ << "x" << nl_ << std::endl; - - // Differential operators factors - exwn_ = 2.0*M_PI/(static_cast(nx_)*dx_); - eywn_ = 2.0*M_PI/(static_cast(ny_)*dy_); - - // Normalization factor - normFFT_ = 1.0/static_cast(nx_*ny_); - - // Define truncation - if (params_.getString("truncation type") == "arome") { - // Same as the AROME model - - // Define tolerance to define jwGlb - jwGlbTol_ = 0.49; - - // Define truncation parameters - oops::Log::test() << "- Truncation parameters MxN: " << nk_-2 << "x" << nl_-2 << std::endl; - - // Define ellips - ellips_.resize(nk_-1); - ellips_[0] = nl_-2; - for (size_t jk = 1; jk < nk_-2; ++jk) { - ellips_[jk] = static_cast(static_cast(nl_-2)/static_cast(nk_-2) - *std::sqrt(static_cast((nk_-2)*(nk_-2)-jk*jk))+1.0e-10); - } - ellips_[nk_-2] = 0; - - // Maximum total wave number - nwGlb_ = std::max(nk_-1, nl_-1); - oops::Log::test() << "- Maximum total wave number: " << nwGlb_-1 << std::endl; - } else { - // Unknown truncation - throw eckit::Exception("unknown truncation type", Here()); - } - - // Mapping - spNormKL_.resize(nk_*nl_); - std::fill(spNormKL_.begin(), spNormKL_.end(), 0.0); - size_t jk; - size_t jl; - - // k = 0 - jk = 0; - - // l = 0 - jl = 0; - addSpectralCoefficient(jk, jl, ReRe, 0, 0); - - // 0 < l < nl_-1 - for (size_t jl = 1; jl < nl_-1; ++jl) { - addSpectralCoefficient(jk, jl, ReRe, 0, 1); - addSpectralCoefficient(jk, jl, ReIm, 0, -1); - } - - // l = nl_-1 - jl = nl_-1; - if (ny_ % 2 == 1) { - addSpectralCoefficient(jk, jl, ReRe, 0, 1); - addSpectralCoefficient(jk, jl, ReIm, 0, -1); - } else { - addSpectralCoefficient(jk, jl, ReRe, 0, 0); - } - - // 0 < k < nk_-1 - for (size_t jk = 1; jk < nk_-1; ++jk) { - // l = 0 - jl = 0; - addSpectralCoefficient(jk, jl, ReRe, 1, 0); - addSpectralCoefficient(jk, jl, ImRe, -1, 0); - - // 0 < l < nl_-1 - for (size_t jl = 1; jl < nl_-1; ++jl) { - addSpectralCoefficient(jk, jl, ReRe, 2, 1); - addSpectralCoefficient(jk, jl, ReIm, 2, -1); - addSpectralCoefficient(jk, jl, ImRe, -2, 1); - addSpectralCoefficient(jk, jl, ImIm, -2, -1); - } - - // l = nl_-1 - jl = nl_-1; - if (ny_ % 2 == 1) { - addSpectralCoefficient(jk, jl, ReRe, 2, 1); - addSpectralCoefficient(jk, jl, ReIm, 2, -1); - addSpectralCoefficient(jk, jl, ImRe, -2, 1); - addSpectralCoefficient(jk, jl, ImIm, -2, -1); - } else { - addSpectralCoefficient(jk, jl, ReRe, 1, 0); - addSpectralCoefficient(jk, jl, ImRe, -1, 0); - } - } - - // k = nk_-1 - jk = nk_-1; - - // l = 0 - jl = 0; - if (nx_ % 2 == 1) { - addSpectralCoefficient(jk, jl, ReRe, 1, 0); - addSpectralCoefficient(jk, jl, ImRe, -1, 0); - } else { - addSpectralCoefficient(jk, jl, ReRe, 0, 0); - } - - // 0 < l < nl_-1 - for (size_t jl = 1; jl < nl_-1; ++jl) { - if (nx_ % 2 == 1) { - addSpectralCoefficient(jk, jl, ReRe, 2, 1); - addSpectralCoefficient(jk, jl, ReIm, 2, -1); - addSpectralCoefficient(jk, jl, ImRe, -2, 1); - addSpectralCoefficient(jk, jl, ImIm, -2, -1); - } else { - addSpectralCoefficient(jk, jl, ReRe, 0, 1); - addSpectralCoefficient(jk, jl, ReIm, 0, -1); - } - } - - // l = nl_-1 - jl = nl_-1; - if (ny_ % 2 == 1) { - if (nx_ % 2 == 1) { - addSpectralCoefficient(jk, jl, ReRe, 2, 1); - addSpectralCoefficient(jk, jl, ReIm, 2, -1); - addSpectralCoefficient(jk, jl, ImRe, -2, 1); - addSpectralCoefficient(jk, jl, ImIm, -2, -1); - - } else { - addSpectralCoefficient(jk, jl, ReRe, 0, 1); - addSpectralCoefficient(jk, jl, ReIm, 0, -1); - } - } else { - if (nx_ % 2 == 1) { - addSpectralCoefficient(jk, jl, ReRe, 1, 0); - addSpectralCoefficient(jk, jl, ImRe, -1, 0); - } else { - addSpectralCoefficient(jk, jl, ReRe, 0, 0); - } - } - - // Define global spectral size - nsGlb_ = spVec_.size(); - oops::Log::test() << "- Spectral array global size: " << nsGlb_ << std::endl; - - oops::Log::trace() << classname() << "::setupGlobalSpectralSpace done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::setupParallelization() { - oops::Log::trace() << classname() << "::setupParallelization starting" << std::endl; - - // Split in y direction - nyPerTask_.resize(comm_.size()); - std::fill(nyPerTask_.begin(), nyPerTask_.end(), 0); - size_t index = 0; - for (size_t jy = 0; jy < ny_; ++jy) { - ++nyPerTask_[index]; - ++index; - if (index == comm_.size()) index = 0; - } - std::vector nyStart(comm_.size()); - std::vector nyEnd(comm_.size()); - nyStart[0] = 0; - nyEnd[0] = nyPerTask_[0]-1; - for (size_t jt = 0; jt < comm_.size()-1; ++jt) { - nyStart[jt+1] = nyStart[jt]+nyPerTask_[jt]; - nyEnd[jt+1] = nyStart[jt+1]+nyPerTask_[jt+1]-1; - } - - // Split in k direction - nkPerTask_.resize(comm_.size()); - std::fill(nkPerTask_.begin(), nkPerTask_.end(), 0); - index = 0; - for (size_t jk = 0; jk < nk_; ++jk) { - ++nkPerTask_[index]; - ++index; - if (index == comm_.size()) index = 0; - } - std::vector nkStart(comm_.size()); - std::vector nkEnd(comm_.size()); - nkStart[0] = 0; - nkEnd[0] = nkPerTask_[0]-1; - for (size_t jt = 0; jt < comm_.size()-1; ++jt) { - nkStart[jt+1] = nkStart[jt]+nkPerTask_[jt]; - nkEnd[jt+1] = nkStart[jt+1]+nkPerTask_[jt+1]-1; - } - - // Split truncation wavenumbers in equal chunks - std::vector jkVec; - std::vector jlVec; - std::vector jwGlbVec; - std::vector nklPerTaskTarget(comm_.size()); - std::fill(nklPerTaskTarget.begin(), nklPerTaskTarget.end(), 0); - index = 0; - for (size_t jk = 0; jk < ellips_.size(); ++jk) { - for (size_t jl = 0; jl <= ellips_[jk]; ++jl) { - jkVec.push_back(jk); - jlVec.push_back(jl); - jwGlbVec.push_back(kstar(jk, jl, nk_, nl_, nwGlb_)); - ++nklPerTaskTarget[index]; - ++index; - if (index == comm_.size()) index = 0; - } - } - - // Sort truncation wavenumbers in ascending jwGlb - const size_t nkl = jwGlbVec.size(); - std::vector klOrder(nkl); - std::iota(klOrder.begin(), klOrder.end(), 0); - std::stable_sort(klOrder.begin(), klOrder.end(), - [&](int i, int j){return jwGlbVec[i] < jwGlbVec[j];}); - - // Split total wave number among tasks - std::vector nklPerTask(comm_.size()); - std::vector> ellipsTask(ellips_.size()); - for (size_t jk = 0; jk < ellips_.size(); ++jk) { - ellipsTask[jk].resize(ellips_[jk]+1); - } - size_t jt = 0; - for (size_t jkl = 0; jkl < nkl; ++jkl) { - // Conditions to switch to the next task - if ((nklPerTask[jt] > nklPerTaskTarget[jt]) && (jt < comm_.size()-1)) { - nklPerTaskTarget[jt+1] += nklPerTaskTarget[jt] - nklPerTask[jt]; - ++jt; - } - - // Get jk, jl - const size_t jk = jkVec[klOrder[jkl]]; - const size_t jl = jlVec[klOrder[jkl]]; - - // Save task - ellipsTask[jk][jl] = jt; - - // Update local size - ++nklPerTask[jt]; - } - - // Add task in global spectral vector - for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { - // Get jk, jl - const size_t jk = spVec_[jsGlb].jk; - const size_t jl = spVec_[jsGlb].jl; - - // Add task - spVec_[jsGlb].jt = ellipsTask[jk][jl]; - } - - // Spectral size per task and local to global mapping - nsPerTask_.resize(comm_.size()); - for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { - // Get task - const size_t jt = spVec_[jsGlb].jt; - - // Update number of spectral coefficient for this task - ++nsPerTask_[jt]; - - if (jt == myrank_) { - // Add local spectral coefficient - sToSGlb_.push_back(jsGlb); - } - } - - // Save local size - ns_ = sToSGlb_.size(); - - // Communication vectors and mapping - sCounts_.resize(comm_.size()); - sDispls_.resize(comm_.size()); - if (myrank_ == 0) { - sMapping_.resize(nsGlb_); - } - for (size_t jt = 0; jt < comm_.size(); ++jt) { - sCounts_[jt] = nsPerTask_[jt]; - sDispls_[jt] = static_cast(jt ? sDispls_[jt-1] + sCounts_[jt-1] : 0); - } - comm_.gatherv(sToSGlb_.cbegin(), sToSGlb_.cend(), sMapping_.begin(), sMapping_.end(), - sCounts_, sDispls_, 0); - - - // Compute spectral imbalance - const double sImb = static_cast(*std::max_element(nsPerTask_.begin(), nsPerTask_.end())) - / static_cast(*std::min_element(nsPerTask_.begin(), nsPerTask_.end())); - oops::Log::info() << "Info : - Spectral imbalance (max/min): " << sImb << std::endl; - - // Rows <=> grid - - // Ghost points - const auto ghostView = make_view(gdata_.functionSpace().ghost()); - - // Index fields views - const atlas::functionspace::StructuredColumns fs(gdata_.functionSpace()); - const auto indexIView = make_indexview(fs.index_i()); - const auto indexJView = make_indexview(fs.index_j()); - - // Number of values on each destination task - gridRecvSize_ = 0; - for (size_t jnode = 0; jnode < nodes_; ++jnode) { - if (ghostView(jnode) == 0) { - ++gridRecvSize_; - } - } - - // Define destination task - std::vector rowsSendTask(gridRecvSize_); - std::vector rowsSendOffset(gridRecvSize_); - std::vector rowsSendOffsetPerTask(comm_.size(), 0); - size_t jgr = 0; - for (size_t jnode = 0; jnode < nodes_; ++jnode) { - if (ghostView(jnode) == 0) { - for (size_t jt = 0; jt < comm_.size(); ++jt) { - if (static_cast(indexJView(jnode)) >= nyStart[jt] && - static_cast(indexJView(jnode)) <= nyEnd[jt]) { - rowsSendTask[jgr] = jt; - rowsSendOffset[jgr] = rowsSendOffsetPerTask[jt]; - ++rowsSendOffsetPerTask[jt]; - } - } - ++jgr; - } - } - - // RecvCounts - gridRecvCounts_.resize(comm_.size()); - std::fill(gridRecvCounts_.begin(), gridRecvCounts_.end(), 0); - for (size_t jgr = 0; jgr < gridRecvSize_; ++jgr) { - ++gridRecvCounts_[rowsSendTask[jgr]]; - } - - // RecvDispls - gridRecvDispls_.resize(comm_.size()); - for (size_t jt = 0; jt < comm_.size(); ++jt) { - gridRecvDispls_[jt] = static_cast(jt ? gridRecvDispls_[jt-1] + gridRecvCounts_[jt-1] : 0); - } - - // Allgather RecvCounts - eckit::mpi::Buffer rRecvCountsBuffer(comm_.size()); - comm_.allGatherv(gridRecvCounts_.begin(), gridRecvCounts_.end(), rRecvCountsBuffer); - std::vector rRecvCountsGlb_ = std::move(rRecvCountsBuffer.buffer); - - // SendCounts - for (size_t jt = 0; jt < comm_.size(); ++jt) { - rowsSendCounts_.push_back(rRecvCountsGlb_[jt*comm_.size()+myrank_]); - } - - // Buffer size - rowsSendSize_ = 0; - for (const auto & n : rowsSendCounts_) rowsSendSize_ += n; - - // SendDispls - rowsSendDispls_.resize(comm_.size()); - for (size_t jt = 0; jt < comm_.size(); ++jt) { - rowsSendDispls_[jt] = static_cast(jt ? rowsSendDispls_[jt-1] + rowsSendCounts_[jt-1] : 0); - } - - // Communicate indices - std::vector gridRecvIndex_x(gridRecvSize_); - std::vector gridRecvIndex_y(gridRecvSize_); - jgr = 0; - for (size_t jnode = 0; jnode < nodes_; ++jnode) { - if (ghostView(jnode) == 0) { - gridRecvIndex_x[jgr] = indexIView(jnode); - gridRecvIndex_y[jgr] = indexJView(jnode); - ++jgr; - } - } - std::vector rowsSendIndex_x(rowsSendSize_); - std::vector rowsSendIndex_y(rowsSendSize_); - rowsSendIndex_.resize(rowsSendSize_); - comm_.allToAllv(gridRecvIndex_x.data(), gridRecvCounts_.data(), gridRecvDispls_.data(), - rowsSendIndex_x.data(), rowsSendCounts_.data(), rowsSendDispls_.data()); - comm_.allToAllv(gridRecvIndex_y.data(), gridRecvCounts_.data(), gridRecvDispls_.data(), - rowsSendIndex_y.data(), rowsSendCounts_.data(), rowsSendDispls_.data()); - for (size_t jrs = 0; jrs < rowsSendSize_; ++jrs) { - rowsSendIndex_[jrs] = (rowsSendIndex_y[jrs]-nyStart[myrank_])*nvz_*nx_ + rowsSendIndex_x[jrs]; - } - - // Effective index - gridRecvIndex_.resize(gridRecvSize_); - for (size_t jgr = 0; jgr < gridRecvSize_; ++jgr) { - gridRecvIndex_[jgr] = (gridRecvDispls_[rowsSendTask[jgr]] + rowsSendOffset[jgr])*nvz_; - } - - // Columns <=> rows - - // Number of values on each destination task - rowsRecvSize_ = nyPerTask_[myrank_]*nk_; - - // Define destination task - std::vector colsSendTask(rowsRecvSize_); - std::vector colsSendOffset(rowsRecvSize_); - std::vector colsSendOffsetPerTask(comm_.size(), 0); - for (size_t jk = 0; jk < nk_; ++jk) { - for (size_t jy = 0; jy < nyPerTask_[myrank_]; ++jy) { - for (size_t jt = 0; jt < comm_.size(); ++jt) { - if (jk >= nkStart[jt] && jk <= nkEnd[jt]) { - colsSendTask[jy*nk_+jk] = jt; - colsSendOffset[jy*nk_+jk] = colsSendOffsetPerTask[jt]; - ++colsSendOffsetPerTask[jt]; - } - } - } - } - - // RecvCounts - rowsRecvCounts_.resize(comm_.size()); - std::fill(rowsRecvCounts_.begin(), rowsRecvCounts_.end(), 0); - for (size_t jrr = 0; jrr < rowsRecvSize_; ++jrr) { - ++rowsRecvCounts_[colsSendTask[jrr]]; - } - - // RecvDispls - rowsRecvDispls_.resize(comm_.size()); - for (size_t jt = 0; jt < comm_.size(); ++jt) { - rowsRecvDispls_[jt] = static_cast(jt ? rowsRecvDispls_[jt-1] + rowsRecvCounts_[jt-1] : 0); - } - - // Allgather RecvCounts - eckit::mpi::Buffer rowsRecvCountsBuffer(comm_.size()); - comm_.allGatherv(rowsRecvCounts_.begin(), rowsRecvCounts_.end(), rowsRecvCountsBuffer); - std::vector rowsRecvCountsGlb_ = std::move(rowsRecvCountsBuffer.buffer); - - // SendCounts - for (size_t jt = 0; jt < comm_.size(); ++jt) { - colsSendCounts_.push_back(rowsRecvCountsGlb_[jt*comm_.size()+myrank_]); - } - - // Buffer size - colsSendSize_ = 0; - for (const auto & n : colsSendCounts_) colsSendSize_ += n; - - // SendDispls - colsSendDispls_.resize(comm_.size()); - for (size_t jt = 0; jt < comm_.size(); ++jt) { - colsSendDispls_[jt] = static_cast(jt ? colsSendDispls_[jt-1] + colsSendCounts_[jt-1] : 0); - } - - // Communicate indices - std::vector rowsRecvIndex_k(rowsRecvSize_); - std::vector rowsRecvIndex_y(rowsRecvSize_); - for (size_t jk = 0; jk < nk_; ++jk) { - for (size_t jy = 0; jy < nyPerTask_[myrank_]; ++jy) { - rowsRecvIndex_k[jk*nyPerTask_[myrank_]+jy] = jk; - rowsRecvIndex_y[jk*nyPerTask_[myrank_]+jy] = jy+nyStart[myrank_]; - } - } - std::vector colsSendIndex_k(colsSendSize_); - std::vector colsSendIndex_y(colsSendSize_); - colsSendIndex_.resize(colsSendSize_); - comm_.allToAllv(rowsRecvIndex_k.data(), rowsRecvCounts_.data(), rowsRecvDispls_.data(), - colsSendIndex_k.data(), colsSendCounts_.data(), colsSendDispls_.data()); - comm_.allToAllv(rowsRecvIndex_y.data(), rowsRecvCounts_.data(), rowsRecvDispls_.data(), - colsSendIndex_y.data(), colsSendCounts_.data(), colsSendDispls_.data()); - for (size_t jcs = 0; jcs < colsSendSize_; ++jcs) { - colsSendIndex_[jcs] = (colsSendIndex_k[jcs]-nkStart[myrank_])*nvz_*2*ny_ + colsSendIndex_y[jcs]; - } - - // Effective index - rowsRecvIndex_.resize(rowsRecvSize_); - for (size_t jrr = 0; jrr < rowsRecvSize_; ++jrr) { - rowsRecvIndex_[jrr] = (rowsRecvDispls_[colsSendTask[jrr]] + colsSendOffset[jrr])*nvz_*2; - } - - // Rows <=> equal chunks - - // Number of values on each destination task - colsRecvSize_ = 0; - for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { - const size_t jk = spVec_[jsGlb].jk; - if (jk >= nkStart[myrank_] && jk <= nkEnd[myrank_]) { - ++colsRecvSize_; - } - } - - // Define destination task - std::vector eqchSendTask(colsRecvSize_); - std::vector eqchSendOffset(colsRecvSize_); - std::vector eqchSendOffsetPerTask(comm_.size(), 0); - size_t jv = 0; - for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { - const size_t jk = spVec_[jsGlb].jk; - if (jk >= nkStart[myrank_] && jk <= nkEnd[myrank_]) { - const size_t jt = spVec_[jsGlb].jt; - eqchSendTask[jv] = jt; - eqchSendOffset[jv] = eqchSendOffsetPerTask[jt]; - ++eqchSendOffsetPerTask[jt]; - ++jv; - } - } - - // RecvCounts - colsRecvCounts_.resize(comm_.size()); - std::fill(colsRecvCounts_.begin(), colsRecvCounts_.end(), 0); - for (size_t jcr = 0; jcr < colsRecvSize_; ++jcr) { - ++colsRecvCounts_[eqchSendTask[jcr]]; - } - - // RecvDispls - colsRecvDispls_.resize(comm_.size()); - for (size_t jt = 0; jt < comm_.size(); ++jt) { - colsRecvDispls_[jt] = static_cast(jt ? colsRecvDispls_[jt-1] + colsRecvCounts_[jt-1] : 0); - } - - // Allgather RecvCounts - eckit::mpi::Buffer colsRecvCountsBuffer(comm_.size()); - comm_.allGatherv(colsRecvCounts_.begin(), colsRecvCounts_.end(), colsRecvCountsBuffer); - std::vector colsRecvCountsGlb_ = std::move(colsRecvCountsBuffer.buffer); - - // SendCounts - for (size_t jt = 0; jt < comm_.size(); ++jt) { - eqchSendCounts_.push_back(colsRecvCountsGlb_[jt*comm_.size()+myrank_]); - } - - // Buffer size - eqchSendSize_ = 0; - for (const auto & n : eqchSendCounts_) eqchSendSize_ += n; - - // SendDispls - eqchSendDispls_.resize(comm_.size()); - for (size_t jt = 0; jt < comm_.size(); ++jt) { - eqchSendDispls_[jt] = static_cast(jt ? eqchSendDispls_[jt-1] + eqchSendCounts_[jt-1] : 0); - } - - // Get destination task inverse order - std::vector colsRecvOrder(colsRecvSize_); - std::iota(colsRecvOrder.begin(), colsRecvOrder.end(), 0); - std::stable_sort(colsRecvOrder.begin(), colsRecvOrder.end(), - [&](int i, int j){return eqchSendTask[i] < eqchSendTask[j];}); - std::vector colsRecvOrderInverse(colsRecvSize_); - for (size_t jcr = 0; jcr < colsRecvSize_; ++jcr) { - colsRecvOrderInverse[colsRecvOrder[jcr]] = jcr; - } - - // Communicate indices - std::vector colsRecvIndex(colsRecvSize_); - size_t jcr = 0; - for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { - const size_t jk = spVec_[jsGlb].jk; - if (jk >= nkStart[myrank_] && jk <= nkEnd[myrank_]) { - colsRecvIndex[colsRecvOrderInverse[jcr]] = jsGlb; - ++jcr; - } - } - eqchSendIndex_.resize(eqchSendSize_); - comm_.allToAllv(colsRecvIndex.data(), colsRecvCounts_.data(), colsRecvDispls_.data(), - eqchSendIndex_.data(), eqchSendCounts_.data(), eqchSendDispls_.data()); - for (size_t jes = 0; jes < eqchSendSize_; ++jes) { - const auto it = std::find(sToSGlb_.begin(), sToSGlb_.end(), eqchSendIndex_[jes]); - ASSERT(it != sToSGlb_.end()); - eqchSendIndex_[jes] = it-sToSGlb_.begin(); - } - - // Effective index - colsRecvIndex_.resize(colsRecvSize_); - for (size_t jcr = 0; jcr < colsRecvSize_; ++jcr) { - colsRecvIndex_[jcr] = (colsRecvDispls_[eqchSendTask[jcr]] + eqchSendOffset[jcr])*nvz_; - } - - // Scale counts and displs for all levels - for (size_t jt = 0; jt < comm_.size(); ++jt) { - gridRecvCounts_[jt] *= nvz_; - gridRecvDispls_[jt] *= nvz_; - rowsSendCounts_[jt] *= nvz_; - rowsSendDispls_[jt] *= nvz_; - rowsRecvCounts_[jt] *= nvz_*2; - rowsRecvDispls_[jt] *= nvz_*2; - colsSendCounts_[jt] *= nvz_*2; - colsSendDispls_[jt] *= nvz_*2; - colsRecvCounts_[jt] *= nvz_; - colsRecvDispls_[jt] *= nvz_; - eqchSendCounts_[jt] *= nvz_; - eqchSendDispls_[jt] *= nvz_; - } - - // Number of component for each local jk,jl couple - colsJq_.resize(nkPerTask_[myrank_]*nl_); - for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { - const size_t jk = spVec_[jsGlb].jk; - if (jk >= nkStart[myrank_] && jk <= nkEnd[myrank_]) { - const size_t jkPerTask = jk-nkStart[myrank_]; - const size_t jl = spVec_[jsGlb].jl; - const size_t jq = spVec_[jsGlb].jq; - colsJq_[jkPerTask*nl_+jl].push_back(jq); - } - } - - // Get min and max jwGlb - nwStartPerTask_.resize(comm_.size(), nwGlb_-1); - nwEndPerTask_.resize(comm_.size(), 0); - for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { - // Get jwGlb and jt - const size_t jwGlb = spVec_[jsGlb].jwGlb; - const size_t jt = spVec_[jsGlb].jt; - - // Update min and max jwGlb - nwStartPerTask_[jt] = std::min(nwStartPerTask_[jt], jwGlb); - nwEndPerTask_[jt] = std::max(nwEndPerTask_[jt], jwGlb); - } - nwPerTask_.resize(comm_.size()); - for (size_t jt = 0; jt < comm_.size(); ++jt) { - nwPerTask_[jt] = nwEndPerTask_[jt] - nwStartPerTask_[jt] + 1; - } - - // Local number of total wavenumbers - nw_ = nwPerTask_[myrank_]; - - // Define root nw - nwRootPerTask_.resize(comm_.size()); - for (size_t jt = 0; jt < comm_.size()-1; ++jt) { - nwRootPerTask_[jt] = nwStartPerTask_[jt+1] - nwStartPerTask_[jt]; - } - nwRootPerTask_[comm_.size()-1] = nwGlb_ - nwStartPerTask_[jt]; - - // Local number of root total wavenumbers - nwRoot_ = nwRootPerTask_[myrank_]; - - // Communication vectors - wCounts_.resize(comm_.size()); - wDispls_.resize(comm_.size()); - for (size_t jt = 0; jt < comm_.size(); ++jt) { - wCounts_[jt] = nwRootPerTask_[jt]; - wDispls_[jt] = static_cast(jt ? wDispls_[jt-1] + wCounts_[jt-1] : 0); - } - - // Compute total wavenumber imbalance - const double wImb = static_cast(*std::max_element(nwPerTask_.begin(), nwPerTask_.end())) - / static_cast(*std::min_element(nwPerTask_.begin(), nwPerTask_.end())); - oops::Log::info() << "Info : - Total wavenumber imbalance (max/min): " << wImb << std::endl; - - oops::Log::trace() << classname() << "::setupParallelization done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::setupLocalSpectralSpace() { - oops::Log::trace() << classname() << "::setupLocalSpectralSpace starting" << std::endl; - - // Create dummy PointCloud function space - atlas::FieldSet flds; - atlas::Field lonlatField("lonlat", make_datatype(), make_shape(ns_, 2)); - atlas::Field ghostField("ghost", make_datatype(), make_shape(ns_)); - atlas::Field remoteIndexField("remote_index", make_datatype(), make_shape(ns_)); - atlas::Field partitionField("partition", make_datatype(), make_shape(ns_)); - atlas::Field globalIndexField("global_index", make_datatype(), make_shape(ns_)); - flds.add(lonlatField); - flds.add(ghostField); - flds.add(remoteIndexField); - flds.add(partitionField); - flds.add(globalIndexField); - auto lonlatView = make_view(lonlatField); - auto ghostView = make_view(ghostField); - auto remoteIndexView = make_indexview(remoteIndexField); - auto partitionView = make_view(partitionField); - auto globalIndexView = make_indexview(globalIndexField); - - for (size_t js = 0; js < ns_; ++js) { - // Get global index - const size_t jsGlb = sToSGlb_[js]; - - // Get jk/jl/jq - const size_t jk = spVec_[jsGlb].jk; - const size_t jl = spVec_[jsGlb].jl; - const size_t jq = spVec_[jsGlb].jq; - - // Define dummy lon/lat from jk/jl/jq - lonlatView(js, 0) = (static_cast(jk)+0.25*static_cast(jq)) - /static_cast(nk_)*360.0; - lonlatView(js, 1) = -90.0*(static_cast(jl)+0.25*static_cast(jq)) - /static_cast(nl_)*180.0; - - // Define ghost field - ghostView(js) = 0; - - // Define remote index field - remoteIndexView(js) = js; - - // Define partition field - partitionView(js) = myrank_; - - // Define global index field - globalIndexView(js) = static_cast(jsGlb); - } - spFspace_.reset(new atlas::functionspace::PointCloud(flds)); - - // Generate spectral UID - specUid_ = generateSpectralUid(*spFspace_, comm_); - - // Print UIDs - oops::Log::info() << "Info : - UIDs: " << gridUid_ << " / " << specUid_ << std::endl; - - // Allocate vectors - jkVec_.resize(ns_); - jlVec_.resize(ns_); - jqVec_.resize(ns_); - jwGlbVec_.resize(ns_); - spNormVec_.resize(ns_); - lapDirVec_.resize(ns_); - lapInvVec_.resize(ns_); - - // Allocate fields - atlas::Field xDerivRowField("xDerivRow", make_datatype(), make_shape(ns_)); - atlas::Field xDerivColField("xDerivCol", make_datatype(), make_shape(ns_)); - atlas::Field xDerivSField("xDerivS", make_datatype(), make_shape(ns_)); - atlas::Field yDerivRowField("yDerivRow", make_datatype(), make_shape(ns_)); - atlas::Field yDerivColField("yDerivCol", make_datatype(), make_shape(ns_)); - atlas::Field yDerivSField("yDerivS", make_datatype(), make_shape(ns_)); - - // Add fields to derivatives_ - derivatives_.add(xDerivRowField); - derivatives_.add(xDerivColField); - derivatives_.add(xDerivSField); - derivatives_.add(yDerivRowField); - derivatives_.add(yDerivColField); - derivatives_.add(yDerivSField); - - // Get fields views - auto xDerivRowView = make_view(xDerivRowField); - auto xDerivColView = make_view(xDerivColField); - auto xDerivSView = make_view(xDerivSField); - auto yDerivRowView = make_view(yDerivRowField); - auto yDerivColView = make_view(yDerivColField); - auto yDerivSView = make_view(yDerivSField); - - // Fill data - for (size_t js = 0; js < ns_; ++js) { - // Get global index - const size_t jsGlb = sToSGlb_[js]; - - // Get spVec_ values - const size_t jk = spVec_[jsGlb].jk; - const size_t jl = spVec_[jsGlb].jl; - const size_t jq = spVec_[jsGlb].jq; - const size_t jwGlb = spVec_[jsGlb].jwGlb; - const int jsXDerivativeOffset = spVec_[jsGlb].jsXDerivativeOffset; - const int jsYDerivativeOffset = spVec_[jsGlb].jsYDerivativeOffset; - - // Copy jk, jl, jq and jwGlb - jkVec_[js] = jk; - jlVec_[js] = jl; - jqVec_[js] = jq; - jwGlbVec_[js] = jwGlb; - - // Spectral norm - spNormVec_[js] = static_cast(spNormKL_[jk*nl_+jl]); - - // X-derivative linear operator - xDerivColView(js) = js; - if (jsXDerivativeOffset == 0) { - // Set to zero - xDerivRowView(js) = js; - xDerivSView(js) = 0.0; - } else { - // Involved in the derivative - xDerivRowView(js) = js+jsXDerivativeOffset; - if (jsXDerivativeOffset > 0) { - xDerivSView(js) = static_cast(jk)*exwn_; - } else { - xDerivSView(js) = -static_cast(jk)*exwn_; - } - } - - // Y-derivative linear operator - yDerivColView(js) = js; - if (jsYDerivativeOffset == 0) { - // Set to zero - yDerivRowView(js) = js; - yDerivSView(js) = 0.0; - } else { - // Involved in the derivative - yDerivRowView(js) = js+jsYDerivativeOffset; - if (jsYDerivativeOffset > 0) { - yDerivSView(js) = static_cast(jl)*eywn_; - } else { - yDerivSView(js) = -static_cast(jl)*eywn_; - } - } - - // Direct Laplacian - lapDirVec_[js] = -(static_cast(jk*jk)*exwn_*exwn_ - + static_cast(jl*jl)*eywn_*eywn_); - - // Inverse Laplacian - if (jk == 0 && jl == 0) { - lapInvVec_[js] = 0.0; - } else { - lapInvVec_[js] = 1.0/lapDirVec_[js]; - } - } - - // Compute control vector size - ctlVecSize_ = ns_*nvz_; - - oops::Log::trace() << classname() << "::setupLocalSpectralSpace done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::setupFFT() { - oops::Log::trace() << classname() << "::setupFFT starting" << std::endl; - - // Rows setup - int xRank = 1; - int xN[] = {static_cast(nx_)}; - int xHowmany = nyPerTask_[myrank_]*nvz_; - int *xInembed = NULL; - const int xIstride = 1; - const int xIdist = static_cast(nx_); - int *xOnembed = NULL; - const int xOstride = 1; - const int xOdist = static_cast(nk_); - rowsBufR_ = fftw_alloc_real(xHowmany*nx_); - rowsBufC_ = fftw_alloc_complex(xHowmany*nk_); - rowsPlan_r2c_ = fftw_plan_many_dft_r2c(xRank, xN, xHowmany, rowsBufR_, xInembed, xIstride, xIdist, - rowsBufC_, xOnembed, xOstride, xOdist, FFTW_ESTIMATE); - rowsPlan_c2r_ = fftw_plan_many_dft_c2r(xRank, xN, xHowmany, rowsBufC_, xOnembed, xOstride, xOdist, - rowsBufR_, xInembed, xIstride, xIdist, FFTW_ESTIMATE); - - // Columns setup - int yRank = 1; - int yN[] = {static_cast(ny_)}; - int yHowmany = nkPerTask_[myrank_]*nvz_*2; - int *yInembed = NULL; - const int yIstride = 1; - const int yIdist = static_cast(ny_); - int *yOnembed = NULL; - const int yOstride = 1; - const int yOdist = static_cast(nl_); - colsBufR_ = fftw_alloc_real(yHowmany*ny_); - colsBufC_ = fftw_alloc_complex(yHowmany*nl_); - colsPlan_r2c_ = fftw_plan_many_dft_r2c(yRank, yN, yHowmany, colsBufR_, yInembed, yIstride, yIdist, - colsBufC_, yOnembed, yOstride, yOdist, FFTW_ESTIMATE); - colsPlan_c2r_ = fftw_plan_many_dft_c2r(yRank, yN, yHowmany, colsBufC_, yOnembed, yOstride, yOdist, - colsBufR_, yInembed, yIstride, yIdist, FFTW_ESTIMATE); - - oops::Log::trace() << classname() << "::setupFFT done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::cleanupFFT() { - fftw_destroy_plan(rowsPlan_r2c_); - fftw_destroy_plan(rowsPlan_c2r_); - fftw_destroy_plan(colsPlan_r2c_); - fftw_destroy_plan(colsPlan_c2r_); - fftw_free(rowsBufR_); - fftw_free(rowsBufC_); - fftw_free(colsBufR_); - fftw_free(colsBufC_); -} - -// ----------------------------------------------------------------------------- - -void BifourierTransform::addSpectralCoefficient(const size_t & jk, - const size_t & jl, - const Quad & jq, - const size_t & jsXDerivativeOffset, - const size_t & jsYDerivativeOffset) { - if (jk < ellips_.size()) { - if (jl <= ellips_[jk]) { - // Update spVec - spElem e; - e.jk = jk; - e.jl = jl; - e.jq = jq; - e.jwGlb = static_cast(kstar(jk, jl, nk_, nl_, nwGlb_)+jwGlbTol_); - e.jsXDerivativeOffset = jsXDerivativeOffset; - e.jsYDerivativeOffset = jsYDerivativeOffset; - spVec_.push_back(e); - - // Check consistency between truncation and maximum total wavenumber - ASSERT(e.jwGlb < nwGlb_); - } - } - - // Update spNorm - ++spNormKL_[jk*nl_+jl]; -} - -// ----------------------------------------------------------------------------- - -} // namespace bifourier -} // namespace saber diff --git a/src/saber/bifourier/BifourierTransformBase.cc b/src/saber/bifourier/BifourierTransformBase.cc new file mode 100644 index 000000000..83ec5cad5 --- /dev/null +++ b/src/saber/bifourier/BifourierTransformBase.cc @@ -0,0 +1,2109 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#include "saber/bifourier/BifourierTransformBase.h" + +#include +#include +#include + +#include "eckit/exception/Exceptions.h" + +#include "oops/generic/gc99.h" +#include "oops/util/FieldSetHelpers.h" +#include "oops/util/FieldSetOperations.h" +#include "oops/util/FloatCompare.h" +#include "oops/util/Logger.h" +#include "oops/util/RandomField.h" + +#include "saber/bifourier/BifourierUtilities.h" + +using atlas::array::make_datatype; +using atlas::array::make_indexview; +using atlas::array::make_shape; +using atlas::array::make_view; + +namespace saber { +namespace bifourier { + +// ----------------------------------------------------------------------------- + +BifourierTransformFactory::BifourierTransformFactory(const std::string & name) { + if (getMakers().find(name) != getMakers().end()) { + oops::Log::error() << name << " already registered in saber::BifourierTransformFactory." + << std::endl; + throw eckit::Exception("Element already registered in saber::BifourierTransformFactory.", + Here()); + } + getMakers()[name] = this; +} + +// ----------------------------------------------------------------------------- + +std::shared_ptr BifourierTransformFactory::create( + const oops::GeometryData & gdata, + const std::string & gridUid, + const oops::Variables & activeVars, + const BifourierTransformParameters & params) { + oops::Log::trace() << "BifourierTransformBase::create starting" << std::endl; + const std::string id = params.fftBackend.value(); + typename std::map::iterator jsb = getMakers().find(id); + if (jsb == getMakers().end()) { + oops::Log::error() << id << " does not exist in saber::bifourier::BifourierTransformFactory." + << std::endl; + throw eckit::UserError("Element does not exist in saber::bifourier::BifourierTransformFactory.", + Here()); + } + std::shared_ptr ptr = + jsb->second->make(gdata, gridUid, activeVars, params); + oops::Log::trace() << "BifourierTransformBase::create done" << std::endl; + return ptr; +} + +// ----------------------------------------------------------------------------- + +BifourierTransformBase::BifourierTransformBase(const oops::GeometryData & gdata, + const std::string & gridUid, + const oops::Variables & activeVars, + const BifourierTransformParameters & params) : + gdata_(gdata), + comm_(gdata_.comm()), + myrank_(comm_.rank()), + params_(params), + gridUid_(gridUid), + dwGlb_(params_.dwGlb.value()) +{ + oops::Log::trace() << classname() << "::BifourierTransformBase starting" << std::endl; + + // Check function space type + ASSERT(gdata_.functionSpace().type() == "StructuredColumns"); + + // Print active variables + oops::Log::info() << "Info : New Bifourier transform" << std::endl; + oops::Log::info() << "Info : - FFT backend: " << params_.fftBackend.value() << std::endl; + oops::Log::info() << "Info : - Active variable: " << activeVars.variables() << std::endl; + + // Get function space + const atlas::functionspace::StructuredColumns fs(gdata_.functionSpace()); + + // Get grid size + nx_ = fs.grid().nx()[0]; + ny_ = fs.grid().ny(); + nodes_ = fs.size(); + oops::Log::test() << "- Regional grid size: " << nx_ << "x" << ny_ << std::endl; + + // Cell size + dx_ = fs.grid().dx(0); + dy_ = fs.grid().y(1) - fs.grid().y(0); + oops::Log::test() << "- Cell sizes: " << dx_*1.0e-3 << " km x " << dy_*1.0e-3 << " km" + << std::endl; + + // Mean latitude + atlas::PointLonLat p1 = fs.grid().lonlat(0, 0); + atlas::PointLonLat p2 = fs.grid().lonlat(nx_-1, ny_-1); + meanLat_ = 0.5*(p1[1]+p2[1]); + oops::Log::test() << "- Mean latitude: " << meanLat_ << " deg" << std::endl; + + // Number of levels for all variables + nvz_ = 0; + for (const auto & var : activeVars) { + nvz_ += var.getLevels(); + } + + oops::Log::trace() << classname() << "::BifourierTransformBase done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::test(const oops::Variables & activeVars) const { + oops::Log::trace() << classname() << "::test starting" << std::endl; + + // Get tests tolerance + const double tolerance = params_.specTolerance.value(); + + // Generate random FieldSet + atlas::FieldSet gpFset = util::createRandomFieldSet(comm_, gdata_.functionSpace(), activeVars); + + // Truncate grid-point field + atlas::FieldSet spFset; + gp2sp(gpFset, spFset, activeVars); + sp2gp(spFset, gpFset, activeVars); + + // Grid-point to spectral + gp2sp(gpFset, spFset, activeVars); + + // Check inverse + atlas::FieldSet gpFsetTest = util::copyFieldSet(gpFset); + sp2gp(spFset, gpFsetTest, activeVars); + ASSERT(util::compareFieldSets(comm_, gpFset, gpFsetTest)); + oops::Log::test() << "- Direct-inverse test passed" << std::endl; + + // Check forward + atlas::FieldSet spFsetTest; + gp2sp(gpFsetTest, spFsetTest, activeVars); + for (const auto & var : activeVars) { + const size_t nz = var.getLevels(); + const auto spField = spFset[var.name()]; + const auto spFieldTest = spFsetTest[var.name()]; + const auto spView = make_view(spField); + const auto spViewTest = make_view(spFieldTest); + int wrongValues = 0; + for (size_t js = 0; js < ns_; ++js) { + for (size_t jz = 0; jz < nz; ++jz) { + if (!oops::is_close_relative(spView(js, jz), spViewTest(js, jz), tolerance)) { + ++wrongValues; + } + } + } + comm_.allReduceInPlace(wrongValues, eckit::mpi::sum()); + ASSERT(wrongValues == 0); + } + oops::Log::test() << "- Inverse-direct test passed" << std::endl; + + // Check Parseval's identity + double gpSqNorm = util::dotProductFieldSets(gpFset, gpFset, activeVars.variables(), comm_); + double spSqNorm = util::dotProductFieldSets(spFset, spFset, activeVars.variables(), comm_); +// ASSERT(oops::is_close_relative(gpSqNorm, spSqNorm, tolerance)); + oops::Log::test() << "- Parseval identity test passed" << std::endl; + + // Adjoint test, forward + gpFset = util::createRandomFieldSet(comm_, gdata_.functionSpace(), activeVars); + gp2sp(gpFset, spFset, activeVars); + createRandomFieldSet(spFsetTest, activeVars); + gp2spAdj(spFsetTest, gpFsetTest, activeVars); + gpSqNorm = util::dotProductFieldSets(gpFset, gpFsetTest, activeVars.variables(), comm_); + spSqNorm = util::dotProductFieldSets(spFset, spFsetTest, activeVars.variables(), comm_); + ASSERT(oops::is_close_relative(gpSqNorm, spSqNorm, tolerance)); + oops::Log::test() << "- Adjoint test (forward) passed" << std::endl; + + // Adjoint test, inverse + gpFset = util::createRandomFieldSet(comm_, gdata_.functionSpace(), activeVars); + sp2gpAdj(gpFset, spFset, activeVars); + createRandomFieldSet(spFsetTest, activeVars); + sp2gp(spFsetTest, gpFsetTest, activeVars); + gpSqNorm = util::dotProductFieldSets(gpFset, gpFsetTest, activeVars.variables(), comm_); + spSqNorm = util::dotProductFieldSets(spFset, spFsetTest, activeVars.variables(), comm_); + ASSERT(oops::is_close_relative(gpSqNorm, spSqNorm, tolerance)); + oops::Log::test() << "- Adjoint test (inverse) passed" << std::endl; + + // Derivatives / Laplacian consistency test + for (const auto & var : activeVars) { + // Get field + const size_t nz = var.getLevels(); + auto spField = spFset[var.name()]; + + // Double derivative in X direction + atlas::Field spDxField; + derivative(spField, spDxField, "x"); + atlas::Field spDx2Field; + derivative(spDxField, spDx2Field, "x"); + + // Double derivative in Y direction + atlas::Field spDyField; + derivative(spField, spDyField, "y"); + atlas::Field spDy2Field; + derivative(spDyField, spDy2Field, "y"); + + // Direct Laplacian + atlas::Field spLapDirField = spField.clone(); + directLaplacian(spLapDirField); + + // Comparison + const auto spDx2View = make_view(spDx2Field); + const auto spDy2View = make_view(spDy2Field); + const auto spLapDirView = make_view(spLapDirField); + int wrongValues = 0; + for (size_t js = 0; js < ns_; ++js) { + for (size_t jz = 0; jz < nz; ++jz) { + if (!oops::is_close_relative(spLapDirView(js, jz), spDx2View(js, jz) + spDy2View(js, jz), + tolerance)) { + ++wrongValues; + } + } + } + comm_.allReduceInPlace(wrongValues, eckit::mpi::sum()); + ASSERT(wrongValues == 0); + } + oops::Log::test() << "- Derivatives / direct Laplacian consistency test passed" << std::endl; + + oops::Log::trace() << classname() << "::test done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::gp2sp(const atlas::FieldSet & gpFset, + atlas::FieldSet & spFset, + const oops::Variables & activeVars) const { + oops::Log::trace() << classname() << "::gp2sp starting" << std::endl; + + // Check the number of required levels + size_t nvz = 0; + for (const auto & var : activeVars) { + nvz += var.getLevels(); + } + ASSERT(nvz == nvz_); + + // Create recv vectors + std::vector recvVec; + + // Ghost points + const auto ghostView = make_view(gdata_.functionSpace().ghost()); + + // Serialize from grid-point FieldSet + recvVec.resize(gridRecvSize_*nvz_); + size_t zOffset = 0; + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // Check field + const auto gpField = gpFset[var.name()]; + ASSERT(gpField.shape(0) == static_cast(nodes_)); + ASSERT(gpField.shape(1) == static_cast(nz)); + + // Get field view + const auto gpView = make_view(gpField); + size_t jgr = 0; + for (size_t jnode = 0; jnode < nodes_; ++jnode) { + if (ghostView(jnode) == 0) { + for (size_t jz = 0; jz < nz; ++jz) { + // Total level index + const size_t jvz = zOffset + jz; + + // Communication vector index + const size_t jgrv = gridRecvIndex_[jgr] + jvz; + + // Copy data + recvVec[jgrv] = gpView(jnode, jz); + } + ++jgr; + } + } + + // Update total number of levels + zOffset += nz; + } + + // Prepare spectral FieldSet + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + if (spFset.has(var.name())) { + // Check sizes + ASSERT(spFset[var.name()].shape(0) == static_cast(ns_)); + ASSERT(spFset[var.name()].shape(1) == static_cast(nz)); + } else { + // Create field + atlas::Field spField = spFspace_->createField( + atlas::option::name(var.name()) | atlas::option::levels(nz)); + spFset.add(spField); + } + } + + // Backend specific transform + gp2sp(recvVec, spFset.metadata()); + + // Communication + std::vector sendVec(eqchSendSize_*nvz_); + comm_.allToAllv(recvVec.data(), recvCounts().data(), recvDispls().data(), + sendVec.data(), eqchSendCounts_.data(), eqchSendDispls_.data()); + + // Reserialize into spectral FieldSet + zOffset = 0; + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // Get field + auto spField = spFset[var.name()]; + + // Get field view + auto spView = make_view(spField); + + for (size_t jes = 0; jes < eqchSendSize_; ++jes) { + for (size_t jz = 0; jz < nz; ++jz) { + // Total level index + const size_t jvz = zOffset + jz; + + // Spectral index + const size_t js = eqchSendIndex_[jes]; + + // Communication vector index + const size_t jesv = jes*nvz_+jvz; + + // Copy data + spView(js, jz) = sendVec[jesv]; + + // Normalize FFT + spView(js, jz) *= gp2spNorm(js); + } + } + + // Update total number of levels + zOffset += nz; + } + + oops::Log::trace() << classname() << "::gp2sp done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::sp2gp(const atlas::FieldSet & spFset, + atlas::FieldSet & gpFset, + const oops::Variables & activeVars) const { + oops::Log::trace() << classname() << "::sp2gp starting" << std::endl; + + // Check the number of required levels + size_t nvz = 0; + for (const auto & var : activeVars) { + nvz += var.getLevels(); + } + ASSERT(nvz == nvz_); + + // Create recv vectors + std::vector recvVec; + + // Reserialize from spectral FieldSet + std::vector sendVec(eqchSendSize_*nvz_); + size_t zOffset = 0; + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // Check field + const auto spField = spFset[var.name()]; + ASSERT(spField.shape(0) == static_cast(ns_)); + ASSERT(spField.shape(1) == static_cast(nz)); + + // Get field view + const auto spView = make_view(spField); + + for (size_t jes = 0; jes < eqchSendSize_; ++jes) { + for (size_t jz = 0; jz < nz; ++jz) { + // Total level index + const size_t jvz = zOffset + jz; + + // Spectral index + const size_t js = eqchSendIndex_[jes]; + + // Communication vector index + const size_t jesv = jes*nvz_+jvz; + + // Copy data + sendVec[jesv] = spView(js, jz); + + // Normalize FFT + sendVec[jesv] *= sp2gpNorm(js); + } + } + + // Update total number of levels + zOffset += nz; + } + + // Communication + recvVec.resize(recvSize()*nvz_); + comm_.allToAllv(sendVec.data(), eqchSendCounts_.data(), eqchSendDispls_.data(), + recvVec.data(), recvCounts().data(), recvDispls().data()); + + // Backend specific transform + sp2gp(recvVec, spFset.metadata()); + + // Prepare grid-point FieldSet + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + if (gpFset.has(var.name())) { + // Check sizes + ASSERT(gpFset[var.name()].shape(0) == static_cast(nodes_)); + ASSERT(gpFset[var.name()].shape(1) == static_cast(nz)); + } else { + // Create field + atlas::Field gpField = gdata_.functionSpace().createField( + atlas::option::name(var.name()) | atlas::option::levels(nz)); + gpFset.add(gpField); + } + } + + // Ghost points + const auto ghostView = make_view(gdata_.functionSpace().ghost()); + + // Deserialize into grid-point FieldSet + zOffset = 0; + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // Get field + auto gpField = gpFset[var.name()]; + + // Get field view + auto gpView = make_view(gpField); + size_t jgr = 0; + for (size_t jnode = 0; jnode < nodes_; ++jnode) { + if (ghostView(jnode) == 0) { + for (size_t jz = 0; jz < nz; ++jz) { + // Total level index + const size_t jvz = zOffset + jz; + + // Communication vector index + const size_t jgrv = gridRecvIndex_[jgr] + jvz; + + // Copy data + gpView(jnode, jz) = recvVec[jgrv]; + } + ++jgr; + } + } + + // Update total number of levels + zOffset += nz; + } + + oops::Log::trace() << classname() << "::sp2gp done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::gp2spAdj(const atlas::FieldSet & spFset, + atlas::FieldSet & gpFset, + const oops::Variables & activeVars) const { + oops::Log::trace() << classname() << "::gp2spAdj starting" << std::endl; + + // Check the number of required levels + size_t nvz = 0; + for (const auto & var : activeVars) { + nvz += var.getLevels(); + } + ASSERT(nvz == nvz_); + + // Create recv vectors + std::vector recvVec; + + // Reserialize from spectral FieldSet + std::vector sendVec(eqchSendSize_*nvz_); + size_t zOffset = 0; + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // Check field + const auto spField = spFset[var.name()]; + ASSERT(spField.shape(0) == static_cast(ns_)); + ASSERT(spField.shape(1) == static_cast(nz)); + + // Get field view + const auto spView = make_view(spField); + + for (size_t jes = 0; jes < eqchSendSize_; ++jes) { + for (size_t jz = 0; jz < nz; ++jz) { + // Total level index + const size_t jvz = zOffset + jz; + + // Spectral index + const size_t js = eqchSendIndex_[jes]; + + // Communication vector index + const size_t jesv = jes*nvz_+jvz; + + // Copy data + sendVec[jesv] = spView(js, jz); + + // Normalize FFT + sendVec[jesv] *= gp2spAdjNorm(js); + } + } + + // Update total number of levels + zOffset += nz; + } + + // Communication + recvVec.resize(recvSize()*nvz_); + comm_.allToAllv(sendVec.data(), eqchSendCounts_.data(), eqchSendDispls_.data(), + recvVec.data(), recvCounts().data(), recvDispls().data()); + + // Backend specific transform + gp2spAdj(recvVec, spFset.metadata()); + + // Prepare grid-point FieldSet + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + if (gpFset.has(var.name())) { + // Check sizes + ASSERT(gpFset[var.name()].shape(0) == static_cast(nodes_)); + ASSERT(gpFset[var.name()].shape(1) == static_cast(nz)); + } else { + // Create field + atlas::Field gpField = gdata_.functionSpace().createField( + atlas::option::name(var.name()) | atlas::option::levels(nz)); + gpFset.add(gpField); + } + } + + // Ghost points + const auto ghostView = make_view(gdata_.functionSpace().ghost()); + + // Deserialize into grid-point FieldSet + zOffset = 0; + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // Get field + auto gpField = gpFset[var.name()]; + + // Get field view + auto gpView = make_view(gpField); + size_t jgr = 0; + for (size_t jnode = 0; jnode < nodes_; ++jnode) { + if (ghostView(jnode) == 0) { + for (size_t jz = 0; jz < nz; ++jz) { + // Total level index + const size_t jvz = zOffset + jz; + + // Communication vector index + const size_t jgrv = gridRecvIndex_[jgr] + jvz; + + // Copy data + gpView(jnode, jz) = recvVec[jgrv]; + } + ++jgr; + } + } + + // Update total number of levels + zOffset += nz; + } + + oops::Log::trace() << classname() << "::gp2spAdj done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::sp2gpAdj(const atlas::FieldSet & gpFset, + atlas::FieldSet & spFset, + const oops::Variables & activeVars) const { + oops::Log::trace() << classname() << "::sp2gpAdj starting" << std::endl; + + // Check the number of required levels + size_t nvz = 0; + for (const auto & var : activeVars) { + nvz += var.getLevels(); + } + ASSERT(nvz == nvz_); + + // Create vectors + std::vector recvVec; + + // Ghost points + const auto ghostView = make_view(gdata_.functionSpace().ghost()); + + // Serialize from grid-point FieldSet + recvVec.resize(gridRecvSize_*nvz_); + size_t zOffset = 0; + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // Check field + const auto gpField = gpFset[var.name()]; + ASSERT(gpField.shape(0) == static_cast(nodes_)); + ASSERT(gpField.shape(1) == static_cast(nz)); + + // Get field view + const auto gpView = make_view(gpField); + size_t jgr = 0; + for (size_t jnode = 0; jnode < nodes_; ++jnode) { + if (ghostView(jnode) == 0) { + for (size_t jz = 0; jz < nz; ++jz) { + // Total level index + const size_t jvz = zOffset + jz; + + // Communication vector index + const size_t jgrv = gridRecvIndex_[jgr] + jvz; + + // Copy data + recvVec[jgrv] = gpView(jnode, jz); + } + ++jgr; + } + } + + // Update total number of levels + zOffset += nz; + } + + // Prepare spectral FieldSet + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + if (spFset.has(var.name())) { + // Check sizes + ASSERT(spFset[var.name()].shape(0) == static_cast(ns_)); + ASSERT(spFset[var.name()].shape(1) == static_cast(nz)); + } else { + // Create field + atlas::Field spField = spFspace_->createField( + atlas::option::name(var.name()) | atlas::option::levels(nz)); + spFset.add(spField); + } + } + + // Backend specific transform + sp2gpAdj(recvVec, spFset.metadata()); + + // Communication + std::vector sendVec(eqchSendSize_*nvz_); + comm_.allToAllv(recvVec.data(), recvCounts().data(), recvDispls().data(), + sendVec.data(), eqchSendCounts_.data(), eqchSendDispls_.data()); + + // Reserialize into spectral FieldSet + zOffset = 0; + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // Get field + auto spField = spFset[var.name()]; + + // Get field view + auto spView = make_view(spField); + + for (size_t jes = 0; jes < eqchSendSize_; ++jes) { + for (size_t jz = 0; jz < nz; ++jz) { + // Total level index + const size_t jvz = zOffset + jz; + + // Spectral index + const size_t js = eqchSendIndex_[jes]; + + // Communication vector index + const size_t jesv = jes*nvz_+jvz; + + // Copy data + spView(js, jz) = sendVec[jesv]; + + // Normalize FFT + spView(js, jz) *= sp2gpAdjNorm(js); + } + } + + // Update total number of levels + zOffset += nz; + } + + oops::Log::trace() << classname() << "::sp2gpAdj done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::createRandomFieldSet(atlas::FieldSet & spFset, + const oops::Variables & activeVars) const { + oops::Log::trace() << classname() << "::createRandomFieldSet starting" << std::endl; + + // Check the number of required levels + size_t nvz = 0; + for (const auto & var : activeVars) { + nvz += var.getLevels(); + } + ASSERT(nvz == nvz_); + + // Global vector + std::vector rand_vec_glb; + + if (myrank_ == 0) { + // Generate global random vector + rand_vec_glb.resize(nsGlb_*nvz_); + util::NormalDistributionField dist(nsGlb_*nvz_, 0.0, 1.0); + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + const size_t jj = jsGlb*nvz_ + jvz; + const size_t jjOrdered = sMapping_[jsGlb]*nvz_ + jvz; + rand_vec_glb[jj] = dist[jjOrdered]; + } + } + } + + // Scatter random vector + std::vector counts = sCounts_; + std::vector displs = sDispls_; + for (size_t jt = 0; jt < comm_.size(); ++jt) { + counts[jt] *= nvz_; + displs[jt] *= nvz_; + } + std::vector rand_vec_loc(ns_*nvz_); + comm_.scatterv(rand_vec_glb.cbegin(), rand_vec_glb.cend(), counts, displs, + rand_vec_loc.begin(), rand_vec_loc.end(), 0); + + // Prepare spectral FieldSet + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + if (spFset.has(var.name())) { + // Check sizes + ASSERT(spFset[var.name()].shape(0) == static_cast(ns_)); + ASSERT(spFset[var.name()].shape(1) == static_cast(nz)); + } else { + // Create field + atlas::Field spField = spFspace_->createField( + atlas::option::name(var.name()) | atlas::option::levels(nz)); + spFset.add(spField); + } + } + + // Reserialize into spectral FieldSet + size_t zOffset = 0; + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // CHeck field + auto spField = spFset[var.name()]; + ASSERT(spField.shape(0) == static_cast(ns_)); + ASSERT(spField.shape(1) == static_cast(nz)); + + // Get field view + auto spView = make_view(spField); + + for (size_t js = 0; js < ns_; ++js) { + for (size_t jz = 0; jz < nz; ++jz) { + // Total level index + const size_t jvz = zOffset + jz; + + // Random vector index + const size_t jr = js*nvz_ + jvz; + + // Copy data + spView(js, jz) = rand_vec_loc[jr]; + } + } + + // Update total number of levels + zOffset += nz; + } + + oops::Log::trace() << classname() << "::createRandomFieldSet done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::derivative(const atlas::Field & spField, + atlas::Field & spDerivField, + const std::string & direction, + const bool & adjoint) const { + oops::Log::trace() << classname() << "::derivative starting" << std::endl; + + // Check field size + ASSERT(spField.shape(0) == static_cast(ns_)); + + // Get number of vertical levels + const size_t nz = spField.shape(1); + + if (spDerivField.valid()) { + // spDerivField is already allocated + ASSERT(spDerivField.shape(0) == static_cast(ns_)); + ASSERT(spDerivField.shape(1) == static_cast(nz)); + } else { + // Allocate spDerivField + spDerivField = spField.clone(); + } + + // Get fields views + const auto spView = make_view(spField); + auto spDerivView = make_view(spDerivField); + + // Get derivative linear operator + const auto firstIndexView = adjoint ? + make_view(derivatives_[direction + "DerivCol"]) : + make_view(derivatives_[direction + "DerivRow"]); + const auto secondIndexView = adjoint ? + make_view(derivatives_[direction + "DerivRow"]) : + make_view(derivatives_[direction + "DerivCol"]); + const auto factorView = make_view(derivatives_[direction + "DerivS"]); + + // Apply derivative linear operator + spDerivView.assign(0.0); + for (size_t js = 0; js < ns_; ++js) { + for (size_t jz = 0; jz < nz; ++jz) { + spDerivView(firstIndexView(js), jz) = spView(secondIndexView(js), jz)*factorView(js); + } + } + + oops::Log::trace() << classname() << "::derivative done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::directLaplacian(atlas::Field & field) const { + oops::Log::trace() << classname() << "::directLaplacian starting" << std::endl; + + // Check field size + ASSERT(field.shape(0) == static_cast(ns_)); + + // Get number of vertical levels + const size_t nz = field.shape(1); + + // Get field view + auto view = make_view(field); + + // Apply direct Laplacian factor + for (size_t js = 0; js < ns_; ++js) { + for (size_t jz = 0; jz < nz; ++jz) { + view(js, jz) *= lapDirVec_[js]; + } + } + + oops::Log::trace() << classname() << "::directLaplacian done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::inverseLaplacian(atlas::Field & field) const { + oops::Log::trace() << classname() << "::inverseLaplacian starting" << std::endl; + + // Check field size + ASSERT(field.shape(0) == static_cast(ns_)); + + // Get number of vertical levels + const size_t nz = field.shape(1); + + // Get field view + auto view = make_view(field); + + // Apply inverse Laplacian factor + for (size_t js = 0; js < ns_; ++js) { + for (size_t jz = 0; jz < nz; ++jz) { + view(js, jz) *= lapInvVec_[js]; + } + } + oops::Log::trace() << classname() << "::inverseLaplacian done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::cv2fset(const atlas::Field & cv, + atlas::FieldSet & fset, + const oops::Variables & activeVars, + const size_t & offset) const { + oops::Log::trace() << classname() << "::cv2fset starting" << std::endl; + + // Check the number of required levels + size_t nvz = 0; + for (const auto & var : activeVars) { + nvz += var.getLevels(); + } + ASSERT(nvz == nvz_); + + // Clear FieldSet + fset.clear(); + + // Get control vector view + const auto cvView = make_view(cv); + + size_t zOffset = 0; + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // Create field + atlas::Field spField = spFspace_->createField( + atlas::option::name(var.name()) | atlas::option::levels(nz)); + fset.add(spField); + + // Get field view + auto spView = make_view(spField); + + for (size_t jz = 0; jz < nz; ++jz) { + // Total level index + const size_t jvz = zOffset + jz; + + for (size_t js = 0; js < ns_; ++js) { + // Control vector index + const size_t jcv = offset + jvz*ns_ + js; + + // Copy data + spView(js, jz) = cvView(jcv); + } + } + + // Update total number of levels + zOffset += nz; + } + + oops::Log::trace() << classname() << "::cv2fset done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::fset2cv(const atlas::FieldSet & fset, + atlas::Field & cv, + const oops::Variables & activeVars, + const size_t & offset) const { + oops::Log::trace() << classname() << "::fset2cv starting" << std::endl; + + // Check the number of required levels + size_t nvz = 0; + for (const auto & var : activeVars) { + nvz += var.getLevels(); + } + ASSERT(nvz == nvz_); + + // Get CV view + auto cvView = make_view(cv); + + size_t zOffset = 0; + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // Check field + const auto spField = fset[var.name()]; + ASSERT(spField.shape(0) == static_cast(ns_)); + ASSERT(spField.shape(1) == static_cast(nz)); + + // Get field view + const auto spView = make_view(spField); + + for (size_t jz = 0; jz < nz; ++jz) { + // Total level index + const size_t jvz = zOffset + jz; + + for (size_t js = 0; js < ns_; ++js) { + // Control vector index + const size_t jcv = offset + jvz*ns_ + js; + + // Copy data + cvView(jcv) = spView(js, jz); + } + } + + // Update total number of levels + zOffset += nz; + } + + oops::Log::trace() << classname() << "::fset2cv done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::copyFieldSet(const atlas::FieldSet & spInputFset, + atlas::FieldSet & spOutputFset, + const oops::Variables & activeVars) const { + oops::Log::trace() << classname() << "::copyFieldSet starting" << std::endl; + + // Check the number of required levels + size_t nvz = 0; + for (const auto & var : activeVars) { + nvz += var.getLevels(); + } + ASSERT(nvz == nvz_); + + // Remove active variables from output FieldSet + util::removeFieldsFromFieldSet(spOutputFset, activeVars.variables()); + + for (const auto & var : activeVars) { + // Get number of vertical levels + const size_t nz = var.getLevels(); + + // Check input field + const auto spInputField = spInputFset[var.name()]; + ASSERT(spInputField.shape(0) == static_cast(ns_)); + ASSERT(spInputField.shape(1) == static_cast(nz)); + + // Create output field + atlas::Field spOutputField = spFspace_->createField( + atlas::option::name(var.name()) | atlas::option::levels(nz)); + spOutputFset.add(spOutputField); + + // Get fields views + const auto spInputView = make_view(spInputField); + auto spOutputView = make_view(spOutputField); + + for (size_t jz = 0; jz < nz; ++jz) { + for (size_t js = 0; js < ns_; ++js) { + // Copy data + spOutputView(js, jz) = spInputView(js, jz); + } + } + } + + // Copy metadata + spOutputFset.metadata() = spInputFset.metadata(); + + oops::Log::trace() << classname() << "::copyFieldSet done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +double BifourierTransformBase::rkstar(const size_t & jk, + const size_t & jl, + const size_t & M, + const size_t & N, + const size_t & nwGlb) const { + const double w = static_cast(nwGlb-1)*std::sqrt( + static_cast(jk*jk)/static_cast(M*M) + + static_cast(jl*jl)/static_cast(N*N)); + return w; +} + +// ----------------------------------------------------------------------------- + +double BifourierTransformBase::ikstar(const size_t & jk, + const size_t & jl, + const size_t & M, + const size_t & N, + const size_t & nwGlb) const { + const size_t iw = static_cast(rkstar(jk, jl, M, N, nwGlb)+jwGlbTol_); + return iw; +} + +// ----------------------------------------------------------------------------- + +bool BifourierTransformBase::includeWavenumber(const size_t & js, + const size_t & jw) const { + bool include = true; + if (dwGlb_ > 0.0) { + // Get indices + const double jkstar = kstarVec_[js]; + const size_t jk = jkVec_[js]; + const size_t jl = jlVec_[js]; + const size_t jwGlb = jw + nwStartPerTask_[myrank_]; + + // Keep all wavenumbers inside [jwGlb-dwGlb, jwGlb+dwGlb] + include = include && (jkstar >= static_cast(jwGlb)-dwGlb_); + include = include && (jkstar <= static_cast(jwGlb)+dwGlb_); + + // Separate wavenumber 0 from others + include = include && (((jwGlb == 0) && (jk == 0) && (jl == 0)) || (jwGlb != 0)); + } else { + // Get index + const size_t jwTest = jwGlbVec_[js] - nwStartPerTask_[myrank_]; + + // Check conditions + include = include && (jw == jwTest); + } + return include; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::reduceCov(atlas::Field & covField) const { + oops::Log::trace() << classname() << "::reduceCov starting" << std::endl; + + // Get sizes + const size_t nzI = covField.shape(1); + const size_t nzJ = covField.shape(2); + + // Get covariance view + auto covView = make_view(covField); + + for (size_t jwGlb = 0; jwGlb < nwGlb_; ++jwGlb) { + if (myJwGlb_[jwGlb]) { + // Create covariance vector + std::vector covVec(nzI*nzJ); + + // Get local total wavenumber + const size_t jw = jwGlb - nwStartPerTask_[myrank_]; + + // Copy data from covariance field to covariance vector + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + const size_t jj = jzI*nzJ + jzJ; + covVec[jj] = covView(jw, jzI, jzJ); + } + } + + // Allreduce covariance vector + covRedComm_[jwGlb]->allReduceInPlace(covVec.begin(), covVec.end(), eckit::mpi::sum()); + + // Copy data from covariance vector to covariance field + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + const size_t jj = jzI*nzJ + jzJ; + covView(jw, jzI, jzJ) = covVec[jj]; + } + } + } + } + + oops::Log::trace() << classname() << "::reduceCov starting" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::scatterCov(const std::vector & covVecGlb, + atlas::Field & covField, + const bool & adjoint) const { + oops::Log::trace() << classname() << "::scatterCov starting" << std::endl; + + // Get sizes + const size_t nzI = covField.shape(1); + const size_t nzJ = covField.shape(2); + + // Check global vector size + if (myrank_ == 0) { + ASSERT(covVecGlb.size() == nwGlb_*nzI*nzJ); + } else { + ASSERT(covVecGlb.size() == 0); + } + + // Get covariance view + auto covView = make_view(covField); + + // TODO(Benjamin): check which option is the fastest + if (true) { + // Allocate root vector + std::vector rootVec(nwRoot_*nzI*nzJ); + + // Scatter vector + std::vector wCounts(wCounts_); + std::vector wDispls(wDispls_); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + wCounts[jt] *= nzI*nzJ; + wDispls[jt] *= nzI*nzJ; + } + comm_.scatterv(covVecGlb.cbegin(), covVecGlb.cend(), wCounts, wDispls, + rootVec.begin(), rootVec.end(), 0); + + for (size_t jwGlb = 0; jwGlb < nwGlb_; ++jwGlb) { + if (myJwGlb_[jwGlb]) { + // Create covariance vector + std::vector covVec(nzI*nzJ, 0.0); + + // Get local total wavenumber + const size_t jw = jwGlb - nwStartPerTask_[myrank_]; + + // Copy data from root vector to covariance vector + if (jw < nwRoot_) { + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + const size_t jj = jzI*nzJ + jzJ; + const size_t jjRoot = adjoint ? jw*nzJ*nzI + jzJ*nzI + jzI + : jw*nzI*nzJ + jzI*nzJ + jzJ; + covVec[jj] = rootVec[jjRoot]; + } + } + } + + // Allreduce covariance vector + covRedComm_[jwGlb]->allReduceInPlace(covVec.begin(), covVec.end(), eckit::mpi::sum()); + + // Copy data from covariance vector to covariance field + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + const size_t jj = jzI*nzJ + jzJ; + covView(jw, jzI, jzJ) = covVec[jj]; + } + } + } + } + } else { + for (size_t jwGlb = 0; jwGlb < nwGlb_; ++jwGlb) { + if (myJwGlb_[jwGlb] || (myrank_ == 0)) { + // Create covariance vector + std::vector covVec(nzI*nzJ); + + // Copy data from global vector to covariance vector + if (myrank_ == 0) { + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + const size_t jj = jzI*nzJ + jzJ; + const size_t jjGlb = adjoint ? jwGlb*nzJ*nzI + jzJ*nzI + jzI + : jwGlb*nzI*nzJ + jzI*nzJ + jzJ; + covVec[jj] = covVecGlb[jjGlb]; + } + } + } + + // Broadcast covariance vector + covBcastComm_[jwGlb]->broadcast(covVec.begin(), covVec.end(), 0); + + if (myJwGlb_[jwGlb]) { + // Get local total wavenumber + const size_t jw = jwGlb - nwStartPerTask_[myrank_]; + + // Copy data from covariance vector to covariance field + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + const size_t jj = jzI*nzJ + jzJ; + covView(jw, jzI, jzJ) = covVec[jj]; + } + } + } + } + } + } + + oops::Log::trace() << classname() << "::scatterCov done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::gatherCov(const atlas::Field & covField, + std::vector & covVecGlb, + const bool & adjoint) const { + oops::Log::trace() << classname() << "::gatherCov starting" << std::endl; + + // Get sizes + const size_t nzI = covField.shape(1); + const size_t nzJ = covField.shape(2); + + // Define vector + std::vector covVecRoot(nwRoot_*nzI*nzJ); + + // Get covariance view + const auto covView = make_view(covField); + + // Serialize + for (size_t jw = 0; jw < nwRoot_; ++jw) { + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + const size_t jjRoot = adjoint ? jw*nzJ*nzI + jzJ*nzI + jzI + : jw*nzI*nzJ + jzI*nzJ + jzJ; + covVecRoot[jjRoot] = covView(jw, jzI, jzJ); + } + } + } + + // Allocate global vector + if (comm_.rank() == 0) { + covVecGlb.resize(nwGlb_*nzI*nzJ); + } else { + covVecGlb.resize(0); + } + + // Gather vector + std::vector wCounts(wCounts_); + std::vector wDispls(wDispls_); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + wCounts[jt] *= nzI*nzJ; + wDispls[jt] *= nzI*nzJ; + } + comm_.gatherv(covVecRoot.cbegin(), covVecRoot.cend(), covVecGlb.begin(), covVecGlb.end(), + wCounts, wDispls, 0); + + oops::Log::trace() << classname() << "::gatherCov done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::filterCov(const double & Lf, + atlas::Field & covField) const { + oops::Log::trace() << classname() << "::filterCov starting" << std::endl; + + if (Lf > 0.0) { + // Get sizes + const size_t nzI = covField.shape(1); + const size_t nzJ = covField.shape(2); + const size_t nzz = nzI*nzJ; + + // Get covariance view + auto covView = make_view(covField); + + // Compute averaged order of magnitude for each total wavenumber + std::vector magnitude(nwGlb_, 0.0); + for (size_t jw = 0; jw < nwRoot_; ++jw) { + const size_t jwGlb = jw + nwStartPerTask_[myrank_]; + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + magnitude[jwGlb] += std::abs(covView(jw, jzI, jzJ)); + } + } + } + + // Reduce magnitude + comm_.allReduceInPlace(magnitude.begin(), magnitude.end(), eckit::mpi::sum()); + + // Set zero magnitude to one to avoid NaNs + for (size_t jwGlb = 0; jwGlb < nwGlb_; ++jwGlb) { + if (!(magnitude[jwGlb] > 0.0)) { + magnitude[jwGlb] = 1.0; + } + } + + // Transpose parallelization + std::vector nzzSizePerTask(comm_.size(), 0); + size_t jt = 0; + for (size_t jzz = 0; jzz < nzz; ++jzz) { + ++nzzSizePerTask[jt]; + ++jt; + if (jt == comm_.size()) { + jt = 0; + } + } + + // Communication vectors + std::vector sendCounts(comm_.size()); + std::vector sendDispls(comm_.size()); + std::vector recvCounts(comm_.size()); + std::vector recvDispls(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + sendCounts[jt] = nwRoot_*nzzSizePerTask[jt];; + sendDispls[jt] = static_cast(jt ? sendDispls[jt-1] + sendCounts[jt-1] : 0); + recvCounts[jt] = wCounts_[jt]*nzzSizePerTask[myrank_]; + recvDispls[jt] = wDispls_[jt]*nzzSizePerTask[myrank_]; + } + + // Serialize + std::vector sendBuf(nwRoot_*nzz); + for (size_t jw = 0; jw < nwRoot_; ++jw) { + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + const size_t jc = jzI*nzJ*nwRoot_ + jzJ*nwRoot_ + jw; + sendBuf[jc] = covView(jw, jzI, jzJ); + } + } + } + + // Communication + std::vector recvBuf(nwGlb_*nzzSizePerTask[myrank_]); + comm_.allToAllv(sendBuf.data(), sendCounts.data(), sendDispls.data(), + recvBuf.data(), recvCounts.data(), recvDispls.data()); + + // Deserialize + std::vector> covT(nzzSizePerTask[myrank_]); + std::vector> covTCopy(nzzSizePerTask[myrank_]); + for (int jzz = 0; jzz < nzzSizePerTask[myrank_]; ++jzz) { + covT[jzz].resize(nwGlb_); + covTCopy[jzz].resize(nwGlb_); + } + size_t jc = 0; + for (size_t jt = 0; jt < comm_.size(); ++jt) { + for (int jzz = 0; jzz < nzzSizePerTask[myrank_]; ++jzz) { + for (size_t jw = 0; jw < nwRootPerTask_[jt]; ++jw) { + const size_t jwGlb = jw + nwStartPerTask_[jt]; + covTCopy[jzz][jwGlb] = recvBuf[jc]/magnitude[jwGlb]; + ++jc; + } + } + } + + // Apply filtering kernel + std::vector kernel(nwGlb_); + for (int jzz = 0; jzz < nzzSizePerTask[myrank_]; ++jzz) { + covT[jzz][0] = magnitude[0]*covTCopy[jzz][0]; + } + for (size_t jwGlb = 1; jwGlb < nwGlb_; ++jwGlb) { + // Compute kernel + for (size_t kwGlb = 0; kwGlb < nwGlb_; ++kwGlb) { + const double dist = std::abs(static_cast(jwGlb)-static_cast(kwGlb))/Lf; + kernel[kwGlb] = oops::gc99(dist); + } + + for (int jzz = 0; jzz < nzzSizePerTask[myrank_]; ++jzz) { + covT[jzz][jwGlb] = 0.0; + double kernelSum = 0.0; + for (size_t kwGlb = 0; kwGlb < nwGlb_; ++kwGlb) { + covT[jzz][jwGlb] += kernel[kwGlb]*covTCopy[jzz][kwGlb]; + kernelSum += kernel[kwGlb]; + } + covT[jzz][jwGlb] *= magnitude[jwGlb]/kernelSum; + } + } + + // Serialize + jc = 0; + for (size_t jt = 0; jt < comm_.size(); ++jt) { + for (int jzz = 0; jzz < nzzSizePerTask[myrank_]; ++jzz) { + for (size_t jw = 0; jw < nwRootPerTask_[jt]; ++jw) { + const size_t jwGlb = jw + nwStartPerTask_[jt]; + recvBuf[jc] = covT[jzz][jwGlb]; + ++jc; + } + } + } + + // Communication + comm_.allToAllv(recvBuf.data(), recvCounts.data(), recvDispls.data(), + sendBuf.data(), sendCounts.data(), sendDispls.data()); + + // Reset cov to zero + covView.assign(0.0); + + // Deserialize + for (size_t jw = 0; jw < nwRoot_; ++jw) { + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + const size_t jc = jzI*nzJ*nwRoot_ + jzJ*nwRoot_ + jw; + covView(jw, jzI, jzJ) = sendBuf[jc]; + } + } + } + + // Reduce covariance + reduceCov(covField); + } + + oops::Log::trace() << classname() << "::filterCov done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +double BifourierTransformBase::normCov(const atlas::Field & covField) const { + oops::Log::trace() << classname() << "::normCov starting" << std::endl; + + // Get sizes + const size_t nzI = covField.shape(1); + const size_t nzJ = covField.shape(2); + + // Get covariance view + const auto covView = make_view(covField); + + // Compute local squared norm + double zz = 0.0; + for (size_t jw = 0; jw < nwRoot_; ++jw) { + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + zz += covView(jw, jzI, jzJ)*covView(jw, jzI, jzJ); + } + } + } + + // Reduce squared norm + comm_.allReduceInPlace(zz, eckit::mpi::sum()); + + // Take square-root + zz = std::sqrt(zz); + + oops::Log::trace() << classname() << "::normCov starting" << std::endl; + return zz; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::reduceNormalizeCov(const size_t & rank, + atlas::Field & covField) { + oops::Log::trace() << classname() << "::reduceNormalizeCov starting" << std::endl; + + // Reduce covariance + reduceCov(covField); + + // Get number of levels + const size_t nzI = covField.shape(1); + const size_t nzJ = covField.shape(2); + + // Get covariance view + auto covView = make_view(covField); + + // Normalize covariance + for (size_t jw = 0; jw < nw_; ++jw) { + const double covEnsNorm = 1.0/static_cast(rank); + const double covNorm = covEnsNorm*spNormSumInv_[jw]; + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + covView(jw, jzI, jzJ) *= covNorm; + } + } + } + + // Set wavenumber 0 to zero for vorticity and divergence + if (covField.name() == "air_upward_absolute_vorticity" + || covField.name() == "air_horizontal_divergence") { + for (size_t jw = 0; jw < nw_; ++jw) { + const size_t jwGlb = jw + nwStartPerTask_[myrank_]; + if (jwGlb == 0) { + for (size_t jzI = 0; jzI < nzI; ++jzI) { + for (size_t jzJ = 0; jzJ < nzJ; ++jzJ) { + covView(jw, jzI, jzJ) = 0.0; + } + } + } + } + } + + oops::Log::trace() << classname() << "::reduceNormalizeCov done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::print(std::ostream & os) const { + os << classname(); +} + + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::setupGlobalSpectralSpace() { + oops::Log::trace() << classname() << "::setupGlobalSpectralSpace starting" << std::endl; + + // Maximum wave numbers + nk_ = nx_/2+1; + nl_ = ny_/2+1; + oops::Log::test() << "- Spectral sizes: " << nk_ << "x" << nl_ << std::endl; + + // Differential operators factors + exwn_ = 2.0*M_PI/(static_cast(nx_)*dx_); + eywn_ = 2.0*M_PI/(static_cast(ny_)*dy_); + + // Normalization factor + normFFT_ = 1.0/static_cast(nx_*ny_); + + // Define truncation + if (params_.truncationType.value() == "arome") { + // Same as the AROME model + + // Define tolerance to define jwGlb + jwGlbTol_ = 0.49; + + // Define truncation parameters + M_ = (nx_-1)/params_.truncationFactor.value(); + N_ = (ny_-1)/params_.truncationFactor.value(); + oops::Log::test() << "- Truncation parameters MxN: " << M_ << "x" << N_ << std::endl; + + // Define ellips + ellips_.resize(M_+1); + ellips_[0] = N_; + for (size_t jk = 1; jk < M_; ++jk) { + ellips_[jk] = static_cast(static_cast(N_)/static_cast(M_) + *std::sqrt(static_cast(M_*M_-jk*jk))+1.0e-10); + } + ellips_[M_] = 0; + + // Maximum total wave number + nwGlb_ = std::max(M_, N_)+1; + oops::Log::test() << "- Maximum total wave number: " << nwGlb_-1 << std::endl; + } else { + // Unknown truncation + throw eckit::Exception("unknown truncation type", Here()); + } + + // Mapping + spNormKL_.resize(nk_*nl_, 0.0); + size_t jk; + size_t jl; + + // k = 0 + jk = 0; + + // l = 0 + jl = 0; + addSpectralCoefficient(jk, jl, ReRe, 0, 0); + + // 0 < l < nl_-1 + for (size_t jl = 1; jl < nl_-1; ++jl) { + addSpectralCoefficient(jk, jl, ReRe, 0, 1); + addSpectralCoefficient(jk, jl, ReIm, 0, -1); + } + + // l = nl_-1 + jl = nl_-1; + if (ny_ % 2 == 1) { + addSpectralCoefficient(jk, jl, ReRe, 0, 1); + addSpectralCoefficient(jk, jl, ReIm, 0, -1); + } else { + addSpectralCoefficient(jk, jl, ReRe, 0, 0); + } + + // 0 < k < nk_-1 + for (size_t jkk = 1; jkk < nk_-1; ++jkk) { + // l = 0 + jl = 0; + addSpectralCoefficient(jkk, jl, ReRe, 1, 0); + addSpectralCoefficient(jkk, jl, ImRe, -1, 0); + + // 0 < l < nl_-1 + for (size_t jll = 1; jll < nl_-1; ++jll) { + addSpectralCoefficient(jkk, jll, ReRe, 2, 1); + addSpectralCoefficient(jkk, jll, ReIm, 2, -1); + addSpectralCoefficient(jkk, jll, ImRe, -2, 1); + addSpectralCoefficient(jkk, jll, ImIm, -2, -1); + } + + // l = nl_-1 + jl = nl_-1; + if (ny_ % 2 == 1) { + addSpectralCoefficient(jkk, jl, ReRe, 2, 1); + addSpectralCoefficient(jkk, jl, ReIm, 2, -1); + addSpectralCoefficient(jkk, jl, ImRe, -2, 1); + addSpectralCoefficient(jkk, jl, ImIm, -2, -1); + } else { + addSpectralCoefficient(jkk, jl, ReRe, 1, 0); + addSpectralCoefficient(jkk, jl, ImRe, -1, 0); + } + } + + // k = nk_-1 + jk = nk_-1; + + // l = 0 + jl = 0; + if (nx_ % 2 == 1) { + addSpectralCoefficient(jk, jl, ReRe, 1, 0); + addSpectralCoefficient(jk, jl, ImRe, -1, 0); + } else { + addSpectralCoefficient(jk, jl, ReRe, 0, 0); + } + + // 0 < l < nl_-1 + for (size_t jll = 1; jll < nl_-1; ++jll) { + if (nx_ % 2 == 1) { + addSpectralCoefficient(jk, jll, ReRe, 2, 1); + addSpectralCoefficient(jk, jll, ReIm, 2, -1); + addSpectralCoefficient(jk, jll, ImRe, -2, 1); + addSpectralCoefficient(jk, jll, ImIm, -2, -1); + } else { + addSpectralCoefficient(jk, jll, ReRe, 0, 1); + addSpectralCoefficient(jk, jll, ReIm, 0, -1); + } + } + + // l = nl_-1 + jl = nl_-1; + if (ny_ % 2 == 1) { + if (nx_ % 2 == 1) { + addSpectralCoefficient(jk, jl, ReRe, 2, 1); + addSpectralCoefficient(jk, jl, ReIm, 2, -1); + addSpectralCoefficient(jk, jl, ImRe, -2, 1); + addSpectralCoefficient(jk, jl, ImIm, -2, -1); + + } else { + addSpectralCoefficient(jk, jl, ReRe, 0, 1); + addSpectralCoefficient(jk, jl, ReIm, 0, -1); + } + } else { + if (nx_ % 2 == 1) { + addSpectralCoefficient(jk, jl, ReRe, 1, 0); + addSpectralCoefficient(jk, jl, ImRe, -1, 0); + } else { + addSpectralCoefficient(jk, jl, ReRe, 0, 0); + } + } + + // Define global spectral size + nsGlb_ = spVec_.size(); + oops::Log::test() << "- Spectral array global size: " << nsGlb_ << std::endl; + + oops::Log::trace() << classname() << "::setupGlobalSpectralSpace done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::setupParallelizationInit() { + oops::Log::trace() << classname() << "::setupParallelizationInit starting" << std::endl; + + // Split truncation wavenumbers in equal chunks + + // Prepare vectors + std::vector jkVec; + std::vector jlVec; + std::vector jwGlbVec; + std::vector nklPerTaskTarget(comm_.size(), 0); + size_t index = 0; + for (size_t jk = 0; jk < ellips_.size(); ++jk) { + for (size_t jl = 0; jl <= ellips_[jk]; ++jl) { + jkVec.push_back(jk); + jlVec.push_back(jl); + jwGlbVec.push_back(ikstar(jk, jl, M_, N_, nwGlb_)); + ++nklPerTaskTarget[index]; + ++index; + if (index == comm_.size()) index = 0; + } + } + + // Sort truncation wavenumbers in ascending jwGlb + const size_t nkl = jwGlbVec.size(); + std::vector klOrder(nkl); + std::iota(klOrder.begin(), klOrder.end(), 0); + std::stable_sort(klOrder.begin(), klOrder.end(), + [&](size_t i, size_t j){return jwGlbVec[i] < jwGlbVec[j];}); + + // Split total wave number among tasks + std::vector nklPerTask(comm_.size()); + std::vector> ellipsTask(ellips_.size()); + for (size_t jk = 0; jk < ellips_.size(); ++jk) { + ellipsTask[jk].resize(ellips_[jk]+1); + } + size_t jt = 0; + for (size_t jkl = 0; jkl < nkl; ++jkl) { + // Conditions to switch to the next task + if ((nklPerTask[jt] > nklPerTaskTarget[jt]) && (jt < comm_.size()-1)) { + nklPerTaskTarget[jt+1] += nklPerTaskTarget[jt] - nklPerTask[jt]; + ++jt; + } + + // Get jk, jl + const size_t jk = jkVec[klOrder[jkl]]; + const size_t jl = jlVec[klOrder[jkl]]; + + // Save task + ellipsTask[jk][jl] = jt; + + // Update local size + ++nklPerTask[jt]; + } + + // Add task in global spectral vector + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + // Get jk, jl + const size_t jk = spVec_[jsGlb].jk; + const size_t jl = spVec_[jsGlb].jl; + + // Add task + spVec_[jsGlb].jt = ellipsTask[jk][jl]; + } + + // Spectral size per task and local to global mapping + nsPerTask_.resize(comm_.size()); + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + // Get task + const size_t jt = spVec_[jsGlb].jt; + + // Update number of spectral coefficient for this task + ++nsPerTask_[jt]; + + if (jt == myrank_) { + // Add local spectral coefficient + sToSGlb_.push_back(jsGlb); + } + } + + // Save local size + ns_ = sToSGlb_.size(); + + // Communication vectors and mapping + sCounts_.resize(comm_.size()); + sDispls_.resize(comm_.size()); + if (myrank_ == 0) { + sMapping_.resize(nsGlb_); + } + for (size_t jt = 0; jt < comm_.size(); ++jt) { + sCounts_[jt] = nsPerTask_[jt]; + sDispls_[jt] = static_cast(jt ? sDispls_[jt-1] + sCounts_[jt-1] : 0); + } + comm_.gatherv(sToSGlb_.cbegin(), sToSGlb_.cend(), sMapping_.begin(), sMapping_.end(), + sCounts_, sDispls_, 0); + + // Compute spectral imbalance + const double sImb = static_cast(*std::max_element(nsPerTask_.begin(), nsPerTask_.end())) + / static_cast(*std::min_element(nsPerTask_.begin(), nsPerTask_.end())); + oops::Log::info() << "Info : - Spectral imbalance (max/min): " << sImb << std::endl; + + oops::Log::trace() << classname() << "::setupParallelizationInit done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::setupParallelizationFinal() { + oops::Log::trace() << classname() << "::setupParallelizationFinal starting" << std::endl; + + // Get min and max jwGlb + nwStartPerTask_.resize(comm_.size(), nwGlb_-1); + nwEndPerTask_.resize(comm_.size(), 0); + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + // Get task + const size_t jt = spVec_[jsGlb].jt; + + // Get global total wavenumber + const size_t jwGlb = spVec_[jsGlb].jwGlb; + + // Update min and max global total wavenumber + nwStartPerTask_[jt] = std::min(nwStartPerTask_[jt], jwGlb); + nwEndPerTask_[jt] = std::max(nwEndPerTask_[jt], jwGlb); + + if (dwGlb_ > 0.0) { + // Get jkstar + const double jkstar = spVec_[jsGlb].kstar; + + // Loop of over global total wavenumber + for (size_t jwGlb = 0; jwGlb < nwGlb_; ++jwGlb) { + if ((jkstar >= static_cast(jwGlb)-dwGlb_) + && (jkstar <= static_cast(jwGlb)+dwGlb_)) { + // Update min and max global total wavenumber + nwStartPerTask_[jt] = std::min(nwStartPerTask_[jt], jwGlb); + nwEndPerTask_[jt] = std::max(nwEndPerTask_[jt], jwGlb); + } + } + } + } + + // Define nwPerTask_ + nwPerTask_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + nwPerTask_[jt] = nwEndPerTask_[jt] - nwStartPerTask_[jt] + 1; + } + + // Local number of total wavenumbers + nw_ = nwPerTask_[myrank_]; + + // Define root nw + nwRootPerTask_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size()-1; ++jt) { + nwRootPerTask_[jt] = nwStartPerTask_[jt+1] - nwStartPerTask_[jt]; + } + nwRootPerTask_[comm_.size()-1] = nwGlb_ - nwStartPerTask_[comm_.size()-1]; + + // Local number of root total wavenumbers + nwRoot_ = nwRootPerTask_[myrank_]; + + // Communication vectors + wCounts_.resize(comm_.size()); + wDispls_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + wCounts_[jt] = nwRootPerTask_[jt]; + wDispls_[jt] = static_cast(jt ? wDispls_[jt-1] + wCounts_[jt-1] : 0); + } + + // Compute total wavenumber imbalance + const double wImb = static_cast(*std::max_element(nwPerTask_.begin(), nwPerTask_.end())) + / static_cast(*std::min_element(nwPerTask_.begin(), nwPerTask_.end())); + oops::Log::info() << "Info : - Total wavenumber imbalance (max/min): " << wImb << std::endl; + + // Prepare covariance communicators + myJwGlb_.resize(nwGlb_); + for (size_t jwGlb = 0; jwGlb < nwGlb_; ++jwGlb) { + // Define used global wavenumbers + myJwGlb_[jwGlb] = (nwStartPerTask_[myrank_] <= jwGlb) && (jwGlb <= nwEndPerTask_[myrank_]); + + // Define color of the reduction communicator + const size_t covRedColor = myJwGlb_[jwGlb] ? 1 : 0; + + // Communicator name + const std::string covRedCommName = "covRed_" + std::to_string(jwGlb); + + // Split communicator + covRedComm_.push_back(&comm_.split(covRedColor, covRedCommName.c_str())); + + // Define color of the broadcasting communicator + const size_t covBcastColor = myJwGlb_[jwGlb] || myrank_ == 0 ? 1 : 0; + + // Communicator name + const std::string covBcastCommName = "covBcast_" + std::to_string(jwGlb); + + // Split communicator= + covBcastComm_.push_back(&comm_.split(covBcastColor, covBcastCommName.c_str())); + } + + oops::Log::trace() << classname() << "::setupParallelizationFinal done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::setupLocalSpectralSpace() { + oops::Log::trace() << classname() << "::setupLocalSpectralSpace starting" << std::endl; + + // Create dummy PointCloud function space + atlas::FieldSet flds; + atlas::Field lonlatField("lonlat", make_datatype(), make_shape(ns_, 2)); + atlas::Field ghostField("ghost", make_datatype(), make_shape(ns_)); + atlas::Field remoteIndexField("remote_index", make_datatype(), make_shape(ns_)); + atlas::Field partitionField("partition", make_datatype(), make_shape(ns_)); + atlas::Field globalIndexField("global_index", make_datatype(), make_shape(ns_)); + flds.add(lonlatField); + flds.add(ghostField); + flds.add(remoteIndexField); + flds.add(partitionField); + flds.add(globalIndexField); + auto lonlatView = make_view(lonlatField); + auto ghostView = make_view(ghostField); + auto remoteIndexView = make_indexview(remoteIndexField); + auto partitionView = make_view(partitionField); + auto globalIndexView = make_indexview(globalIndexField); + + for (size_t js = 0; js < ns_; ++js) { + // Get global index + const size_t jsGlb = sToSGlb_[js]; + + // Get jk/jl/jq + const size_t jk = spVec_[jsGlb].jk; + const size_t jl = spVec_[jsGlb].jl; + const size_t jq = spVec_[jsGlb].jq; + + // Define dummy lon/lat from jk/jl/jq + lonlatView(js, 0) = (static_cast(jk)+0.25*static_cast(jq)) + /static_cast(nk_)*360.0; + lonlatView(js, 1) = -90.0*(static_cast(jl)+0.25*static_cast(jq)) + /static_cast(nl_)*180.0; + + // Define ghost field + ghostView(js) = 0; + + // Define remote index field + remoteIndexView(js) = js; + + // Define partition field + partitionView(js) = myrank_; + + // Define global index field + globalIndexView(js) = static_cast(jsGlb); + } + spFspace_.reset(new atlas::functionspace::PointCloud(flds)); + + // Generate spectral UID + specUid_ = generateSpectralUid(*spFspace_, comm_); + + // Print UIDs + oops::Log::info() << "Info : - UIDs: " << gridUid_ << " / " << specUid_ << std::endl; + + // Allocate vectors + jkVec_.resize(ns_); + jlVec_.resize(ns_); + jqVec_.resize(ns_); + jwGlbVec_.resize(ns_); + kstarVec_.resize(ns_); + spNormVec_.resize(ns_); + lapDirVec_.resize(ns_); + lapInvVec_.resize(ns_); + + // Allocate fields + atlas::Field xDerivRowField("xDerivRow", make_datatype(), make_shape(ns_)); + atlas::Field xDerivColField("xDerivCol", make_datatype(), make_shape(ns_)); + atlas::Field xDerivSField("xDerivS", make_datatype(), make_shape(ns_)); + atlas::Field yDerivRowField("yDerivRow", make_datatype(), make_shape(ns_)); + atlas::Field yDerivColField("yDerivCol", make_datatype(), make_shape(ns_)); + atlas::Field yDerivSField("yDerivS", make_datatype(), make_shape(ns_)); + + // Add fields to derivatives_ + derivatives_.add(xDerivRowField); + derivatives_.add(xDerivColField); + derivatives_.add(xDerivSField); + derivatives_.add(yDerivRowField); + derivatives_.add(yDerivColField); + derivatives_.add(yDerivSField); + + // Get fields views + auto xDerivRowView = make_view(xDerivRowField); + auto xDerivColView = make_view(xDerivColField); + auto xDerivSView = make_view(xDerivSField); + auto yDerivRowView = make_view(yDerivRowField); + auto yDerivColView = make_view(yDerivColField); + auto yDerivSView = make_view(yDerivSField); + + // Fill data + for (size_t js = 0; js < ns_; ++js) { + // Get global index + const size_t jsGlb = sToSGlb_[js]; + + // Get spVec_ values + const size_t jk = spVec_[jsGlb].jk; + const size_t jl = spVec_[jsGlb].jl; + const size_t jq = spVec_[jsGlb].jq; + const double kstar = spVec_[jsGlb].kstar; + const size_t jwGlb = spVec_[jsGlb].jwGlb; + const int jsXDerivativeOffset = spVec_[jsGlb].jsXDerivativeOffset; + const int jsYDerivativeOffset = spVec_[jsGlb].jsYDerivativeOffset; + + // Copy jk, jl, jq and jwGlb + jkVec_[js] = jk; + jlVec_[js] = jl; + jqVec_[js] = jq; + kstarVec_[js] = kstar; + jwGlbVec_[js] = jwGlb; + + // Spectral norm + spNormVec_[js] = static_cast(spNormKL_[jk*nl_+jl]); + + // X-derivative linear operator + xDerivColView(js) = js; + if (jsXDerivativeOffset == 0) { + // Set to zero + xDerivRowView(js) = js; + xDerivSView(js) = 0.0; + } else { + // Involved in the derivative + xDerivRowView(js) = js+jsXDerivativeOffset; + if (jsXDerivativeOffset > 0) { + xDerivSView(js) = static_cast(jk)*exwn_; + } else { + xDerivSView(js) = -static_cast(jk)*exwn_; + } + } + + // Y-derivative linear operator + yDerivColView(js) = js; + if (jsYDerivativeOffset == 0) { + // Set to zero + yDerivRowView(js) = js; + yDerivSView(js) = 0.0; + } else { + // Involved in the derivative + yDerivRowView(js) = js+jsYDerivativeOffset; + if (jsYDerivativeOffset > 0) { + yDerivSView(js) = static_cast(jl)*eywn_; + } else { + yDerivSView(js) = -static_cast(jl)*eywn_; + } + } + + // Direct Laplacian + lapDirVec_[js] = -(static_cast(jk*jk)*exwn_*exwn_ + + static_cast(jl*jl)*eywn_*eywn_); + + // Inverse Laplacian + if (jk == 0 && jl == 0) { + lapInvVec_[js] = 0.0; + } else { + lapInvVec_[js] = 1.0/lapDirVec_[js]; + } + } + + // Compute control vector size + ctlVecSize_ = ns_*nvz_; + + // Compute spectral norm sum + std::vector spNormSum(nwGlb_, 0.0); + for (size_t js = 0; js < ns_; ++js) { + for (size_t jw = 0; jw < nw_; ++jw) { + // Update spectral norm sum + const size_t jwGlb = jw + nwStartPerTask_[myrank_]; + if (includeWavenumber(js, jw)) { + spNormSum[jwGlb] += spNormVec_[js]; + } + } + } + + // Reduce spectral norm sum + comm_.allReduceInPlace(spNormSum.begin(), spNormSum.end(), eckit::mpi::sum()); + + // Inverse spectral norm sum + spNormSumInv_.resize(nw_, 0.0); + for (size_t jw = 0; jw < nw_; ++jw) { + const size_t jwGlb = jw + nwStartPerTask_[myrank_]; + ASSERT(spNormSum[jwGlb] > 0.0); + spNormSumInv_[jw] = 1.0/spNormSum[jwGlb]; + } + + oops::Log::trace() << classname() << "::setupLocalSpectralSpace done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformBase::addSpectralCoefficient(const size_t & jk, + const size_t & jl, + const Quad & jq, + const size_t & jsXDerivativeOffset, + const size_t & jsYDerivativeOffset) { + if (jk < ellips_.size()) { + if (jl <= ellips_[jk]) { + // Update spVec + spElem e; + e.jk = jk; + e.jl = jl; + e.jq = jq; + e.kstar = rkstar(jk, jl, M_, N_, nwGlb_); + e.jwGlb = ikstar(jk, jl, M_, N_, nwGlb_); + e.jsXDerivativeOffset = jsXDerivativeOffset; + e.jsYDerivativeOffset = jsYDerivativeOffset; + spVec_.push_back(e); + + // Check consistency between truncation and maximum total wavenumber + ASSERT(e.jwGlb < nwGlb_); + } + } + + // Update spNorm + ++spNormKL_[jk*nl_+jl]; +} + +// ----------------------------------------------------------------------------- + +} // namespace bifourier +} // namespace saber diff --git a/src/saber/bifourier/BifourierTransform.h b/src/saber/bifourier/BifourierTransformBase.h similarity index 50% rename from src/saber/bifourier/BifourierTransform.h rename to src/saber/bifourier/BifourierTransformBase.h index ba8723a1a..5f9b8fcda 100644 --- a/src/saber/bifourier/BifourierTransform.h +++ b/src/saber/bifourier/BifourierTransformBase.h @@ -5,40 +5,108 @@ #pragma once -#include +#include #include #include #include #include "atlas/field.h" +#include + #include "eckit/mpi/Comm.h" -#include "oops/util/Printable.h" #include "oops/base/GeometryData.h" #include "oops/base/Variables.h" +#include "oops/util/parameters/Parameter.h" +#include "oops/util/parameters/Parameters.h" +#include "oops/util/Printable.h" namespace saber { namespace bifourier { // ----------------------------------------------------------------------------- -class BifourierTransform : public util::Printable { +class BifourierTransformParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(BifourierTransformParameters, Parameters) + public: - static const std::string classname() - {return "saber::bifourier::BifourierTransform";} + // FFT backend + oops::Parameter fftBackend{"fft backend", "fftw", this}; + + // Truncation type + oops::Parameter truncationType{"truncation type", "arome", this}; - // Constructors + // Truncation factor (2.0 for a linear grid) + oops::Parameter truncationFactor{"truncation factor", 2.0, this}; - // Create spectral transform - BifourierTransform(const oops::GeometryData &, - const std::string &, - const oops::Variables &, - const eckit::Configuration &); + // Sub-ellipses half-width for calibration (AROME default is 1.5) + oops::Parameter dwGlb{"sub-ellipses half-width", -1.0, this}; + + // Skip tests + oops::Parameter skipTests{"skip tests", false, this}; + + // Spectral tests tolerance + oops::Parameter specTolerance{"spectral tolerance", 1.0e-9, this}; +}; + +// ----------------------------------------------------------------------------- + +class BifourierTransformBase : public util::Printable, + private boost::noncopyable { + public: + static const std::string classname() + {return "saber::bifourier::BifourierTransformBase";} + + // Constructor + BifourierTransformBase(const oops::GeometryData &, + const std::string &, + const oops::Variables &, + const BifourierTransformParameters &); // Destructor - ~BifourierTransform(); + virtual ~BifourierTransformBase() + {} + + // Forward FFT + virtual void gp2sp(std::vector &, + atlas::util::Metadata &) const = 0; + + // Inverse FFT + virtual void sp2gp(std::vector &, + const atlas::util::Metadata &) const = 0; + + // Forward FFT adjoint + virtual void gp2spAdj(std::vector &, + const atlas::util::Metadata &) const = 0; + + // Inverse FFT adjoint + virtual void sp2gpAdj(std::vector &, + atlas::util::Metadata &) const = 0; + + // Forward FFT normalization + virtual double gp2spNorm(const size_t &) const + {return 1.0;} + + // Inverse FFT normalization + virtual double sp2gpNorm(const size_t &) const + {return 1.0;} + + // Forward FFT adjoint normalization + virtual double gp2spAdjNorm(const size_t &) const + {return 1.0;} + + // Inverse FFT adjoint normalization + virtual double sp2gpAdjNorm(const size_t &) const + {return 1.0;} + + // Communication vectors + virtual const size_t & recvSize() const = 0; + virtual const std::vector & recvCounts() const = 0; + virtual const std::vector & recvDispls() const = 0; + + // Non-virtual methods // Accessors @@ -52,6 +120,12 @@ class BifourierTransform : public util::Printable { const std::string & specUid() const {return specUid_;} + // Grid size + const size_t & nx() const + {return nx_;} + const size_t & ny() const + {return ny_;} + // Grid cell sizes const double & dx() const {return dx_;} @@ -90,13 +164,13 @@ class BifourierTransform : public util::Printable { const atlas::FunctionSpace & spFspace() const {return *spFspace_;} - // Zonal wavenumbers size - const size_t & nk() const - {return nk_;} + // Zonal truncation + const size_t & M() const + {return M_;} - // Meridional wavenumbers size - const size_t & nl() const - {return nl_;} + // Meridional truncation + const size_t & N() const + {return N_;} // Return jk for this wavenumber const size_t & jk(const size_t & js) const @@ -110,14 +184,22 @@ class BifourierTransform : public util::Printable { const size_t & jq(const size_t & js) const {return jqVec_[js];} + // Return kstar for this wavenumber + double kstar(const size_t & js) const + {return kstarVec_[js];} + // Return jw for this wavenumber - const size_t jw(const size_t & js) const + size_t jw(const size_t & js) const {return jwGlbVec_[js] - nwStartPerTask_[myrank_];} // Return spNorm for this wavenumber const double & spNorm(const size_t & js) const {return spNormVec_[js];} + // Return spNormSumInv for this total wavenumber + const double & spNormSumInv(const size_t & jw) const + {return spNormSumInv_[jw];} + // Truncation ellips const std::vector & ellips() const {return ellips_;} @@ -154,16 +236,19 @@ class BifourierTransform : public util::Printable { const size_t & nwStart() const {return nwStartPerTask_[myrank_];} - // Communication vectors - const std::vector & wCounts() const - {return wCounts_;} - const std::vector & wDispls() const - {return wDispls_;} + // Ending global nw + const size_t & nwEnd() const + {return nwEndPerTask_[myrank_];} // Total number of levels (sum of all levels of all active variables) const size_t & nvz() const {return nvz_;} + // Public methods + + // Run tests + void test(const oops::Variables &) const; + // Spectral operations // Forward FFT @@ -176,9 +261,19 @@ class BifourierTransform : public util::Printable { atlas::FieldSet &, const oops::Variables &) const; + // Forward FFT adjoint + void gp2spAdj(const atlas::FieldSet &, + atlas::FieldSet &, + const oops::Variables &) const; + + // Inverse FFT adjoint + void sp2gpAdj(const atlas::FieldSet &, + atlas::FieldSet &, + const oops::Variables &) const; + // Create random spectral FieldSet - void createRandomSpectralFieldSet(atlas::FieldSet &, - const oops::Variables &) const; + void createRandomFieldSet(atlas::FieldSet &, + const oops::Variables &) const; // Apply derivative void derivative(const atlas::Field &, @@ -213,14 +308,50 @@ class BifourierTransform : public util::Printable { atlas::FieldSet &, const oops::Variables &) const; - // kstar value - double kstar(const size_t &, - const size_t &, - const size_t &, - const size_t &, - const size_t &) const; + // Real kstar value + double rkstar(const size_t &, + const size_t &, + const size_t &, + const size_t &, + const size_t &) const; - private: + + // Integer kstar value + double ikstar(const size_t &, + const size_t &, + const size_t &, + const size_t &, + const size_t &) const; + + // Include wavenumber in the calibration process + bool includeWavenumber(const size_t &, + const size_t &) const; + + // Reduce covariances + void reduceCov(atlas::Field &) const; + + // Scatter covariances + void scatterCov(const std::vector &, + atlas::Field &, + const bool & adjointInput = false) const; + + // Gather covariances + void gatherCov(const atlas::Field &, + std::vector &, + const bool & adjoint = false) const; + + // Filter covariances + void filterCov(const double &, + atlas::Field &) const; + + // Compute covariances norm + double normCov(const atlas::Field &) const; + + // Reduce and normalize covariance + void reduceNormalizeCov(const size_t &, + atlas::Field &); + + protected: // Model grid geometry data const oops::GeometryData & gdata_; @@ -229,7 +360,10 @@ class BifourierTransform : public util::Printable { size_t myrank_; // Parameters - const eckit::Configuration & params_; + const BifourierTransformParameters & params_; + + // FFT backend + const std::string fftBackend_; // UIDs std::string gridUid_; @@ -258,6 +392,8 @@ class BifourierTransform : public util::Printable { double normFFT_; // Truncation (number of positive wavenumber in y dimension for each wavenumber in x dimension) + size_t M_; + size_t N_; std::vector ellips_; // Mapping and normalization @@ -271,6 +407,7 @@ class BifourierTransform : public util::Printable { size_t jk; size_t jl; Quad jq; + double kstar; size_t jwGlb; size_t jsXDerivativeOffset; size_t jsYDerivativeOffset; @@ -282,6 +419,7 @@ class BifourierTransform : public util::Printable { std::vector jkVec_; std::vector jlVec_; std::vector jqVec_; + std::vector kstarVec_; std::vector jwGlbVec_; std::vector spNormVec_; std::vector lapDirVec_; @@ -289,44 +427,25 @@ class BifourierTransform : public util::Printable { atlas::FieldSet derivatives_; // Parallelization - std::vector nyPerTask_; - std::vector nkPerTask_; - std::vector nsPerTask_; + + // Global mapping std::vector sToSGlb_; - // Rows <=> grid - size_t rowsSendSize_; + // Grid size_t gridRecvSize_; std::vector gridRecvIndex_; - std::vector rowsSendIndex_; - std::vector rowsSendCounts_; - std::vector rowsSendDispls_; std::vector gridRecvCounts_; std::vector gridRecvDispls_; - // Columns <=> rows - size_t colsSendSize_; - size_t rowsRecvSize_; - std::vector rowsRecvIndex_; - std::vector colsSendIndex_; - std::vector colsSendCounts_; - std::vector colsSendDispls_; - std::vector rowsRecvCounts_; - std::vector rowsRecvDispls_; - - // Equal chunks <=> columns + // Equal chunks size_t eqchSendSize_; - size_t colsRecvSize_; - std::vector colsRecvIndex_; - std::vector> colsJq_; std::vector eqchSendIndex_; std::vector eqchSendCounts_; std::vector eqchSendDispls_; - std::vector colsRecvCounts_; - std::vector colsRecvDispls_; // Local spectral space std::vector truncMask_; + std::vector nsPerTask_; size_t ns_; size_t nsGlb_; std::vector sCounts_; @@ -336,11 +455,9 @@ class BifourierTransform : public util::Printable { // Dummy spectral function space std::unique_ptr spFspace_; - // Control vector size - size_t ctlVecSize_; - // Total wavenumber size_t nwGlb_; + double dwGlb_; size_t nw_; size_t nwRoot_; std::vector nwStartPerTask_; @@ -350,17 +467,16 @@ class BifourierTransform : public util::Printable { std::vector wCounts_; std::vector wDispls_; - // Rows FFT - fftw_plan rowsPlan_r2c_; - fftw_plan rowsPlan_c2r_; - double *rowsBufR_ = nullptr; - fftw_complex *rowsBufC_ = nullptr; + // Covariance communicators + std::vector myJwGlb_; + std::vector covRedComm_; + std::vector covBcastComm_; + + // Control vector size + size_t ctlVecSize_; - // Columns FFT - fftw_plan colsPlan_r2c_; - fftw_plan colsPlan_c2r_; - double *colsBufR_ = nullptr; - fftw_complex *colsBufC_ = nullptr; + // Spectral norm sum inverse + std::vector spNormSumInv_; // Private methods @@ -371,15 +487,12 @@ class BifourierTransform : public util::Printable { void setupGlobalSpectralSpace(); // Setup parallelization - void setupParallelization(); + void setupParallelizationInit(); + void setupParallelizationFinal(); // Setup local spectral space void setupLocalSpectralSpace(); - // Setup FFT - void setupFFT(); - void cleanupFFT(); - // Add spectral coefficient void addSpectralCoefficient(const size_t &, const size_t &, @@ -390,5 +503,51 @@ class BifourierTransform : public util::Printable { // ----------------------------------------------------------------------------- +class BifourierTransformFactory; + +// ----------------------------------------------------------------------------- + +class BifourierTransformFactory { + public: + static std::shared_ptr create(const oops::GeometryData &, + const std::string &, + const oops::Variables &, + const BifourierTransformParameters &); + + virtual ~BifourierTransformFactory() = default; + + protected: + explicit BifourierTransformFactory(const std::string &name); + + private: + virtual std::shared_ptr make(const oops::GeometryData &, + const std::string &, + const oops::Variables &, + const BifourierTransformParameters &) = 0; + + static std::map < std::string, BifourierTransformFactory * > & getMakers() { + static std::map < std::string, BifourierTransformFactory * > makers_; + return makers_; + } +}; + +// ----------------------------------------------------------------------------- + +template +class BifourierTransformMaker : public BifourierTransformFactory { + std::shared_ptr make(const oops::GeometryData & gdata, + const std::string & gridUid, + const oops::Variables & activeVars, + const BifourierTransformParameters & params) + override { + return std::make_shared(gdata, gridUid, activeVars, params); + } + + public: + explicit BifourierTransformMaker(const std::string & name) : BifourierTransformFactory(name) {} +}; + +// ----------------------------------------------------------------------------- + } // namespace bifourier } // namespace saber diff --git a/src/saber/bifourier/BifourierTransformECTRANS.cc b/src/saber/bifourier/BifourierTransformECTRANS.cc new file mode 100644 index 000000000..7cd3a7c67 --- /dev/null +++ b/src/saber/bifourier/BifourierTransformECTRANS.cc @@ -0,0 +1,982 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#include "saber/bifourier/BifourierTransformECTRANS.h" + +#include +#include +#include + +#include "saber/bifourier/BifourierUtilities.h" + +using atlas::array::make_datatype; +using atlas::array::make_indexview; +using atlas::array::make_shape; +using atlas::array::make_view; + +namespace saber { +namespace bifourier { + +// ----------------------------------------------------------------------------- + +static BifourierTransformMaker makerECTRANS_("ectrans"); + +// ----------------------------------------------------------------------------- + +BifourierTransformECTRANS::BifourierTransformECTRANS(const oops::GeometryData & gdata, + const std::string & gridUid, + const oops::Variables & activeVars, + const BifourierTransformParameters & params) : + BifourierTransformBase(gdata, gridUid, activeVars, params) { + oops::Log::trace() << classname() << "::BifourierTransformECTRANS starting" << std::endl; + + // Setup global spectral space parameters + setupGlobalSpectralSpace(); + + // Setup parallelization, initial step [base method] + setupParallelizationInit(); + + // Setup parallelization, backend-specific + setupBackend(); + + // Setup parallelization, final step [base method] + setupParallelizationFinal(); + + // Setup local spectral space + setupLocalSpectralSpace(); + + oops::Log::trace() << classname() << "::BifourierTransformECTRANS done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +BifourierTransformECTRANS::~BifourierTransformECTRANS() { + oops::Log::trace() << classname() << "::~BifourierTransformECTRANS starting" << std::endl; + + // Delete and finalize transform structure + trans_delete(&trans_); + trans_finalize(); + + oops::Log::trace() << classname() << "::~BifourierTransformECTRANS done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformECTRANS::gp2sp(std::vector & recvVec, + atlas::util::Metadata & metadata) const { + oops::Log::trace() << classname() << "::gp2sp starting" << std::endl; + + // Check metadata for wind transform + const size_t nvordiv = metadata.getInt("nvordiv", 0); + + // Number of scalar fields + const size_t nscalar = nvz_-2*nvordiv; + + // Allocate buffers + std::vector rgp(transGpSize_*nvz_); + std::vector rspScalar; + std::vector rspVor; + std::vector rspDiv; + std::vector rMeanU; + std::vector rMeanV; + rspScalar.resize(transSpSize_*nscalar); + rspVor.resize(transSpSize_*nvordiv); + rspDiv.resize(transSpSize_*nvordiv); + rMeanU.resize(nvordiv); + rMeanV.resize(nvordiv); + + // Setup direct transform + struct DirTrans_t dirtrans; + dirtrans = new_dirtrans(&trans_); + dirtrans.nscalar = nscalar; + dirtrans.nvordiv = nvordiv; + dirtrans.rspscalar = rspScalar.data(); + dirtrans.rspvor = rspVor.data(); + dirtrans.rspdiv = rspDiv.data(); + dirtrans.rmeanu = rMeanU.data(); + dirtrans.rmeanv = rMeanV.data(); + dirtrans.rgp = rgp.data(); + + // Communication + std::vector sendVec(transGpSendSize_*nvz_); + comm_.allToAllv(recvVec.data(), gridRecvCounts_.data(), gridRecvDispls_.data(), + sendVec.data(), transGpSendCounts_.data(), transGpSendDispls_.data()); + + // Reserialize + for (size_t jrs = 0; jrs < transGpSendSize_; ++jrs) { + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // Communication vector index + const size_t jrsv = jrs*nvz_ + jvz; + + // FFT vector index + const size_t jf = jvz*transGpSendSize_ + transGpSendIndex_[jrs]; + + // Copy data + rgp[jf] = sendVec[jrsv]; + } + } + + // Compute direct transform + trans_dirtrans(&dirtrans); + + if (nvordiv > 0) { + // Save mean wind + const double windNorm = std::sqrt(normFFT_); + for (size_t jz = 0; jz < nvordiv; ++jz) { + rMeanU[jz] *= windNorm; + rMeanV[jz] *= windNorm; + } + metadata.set("uMeanProfile", rMeanU); + metadata.set("vMeanProfile", rMeanV); + } + + // Reserialize + recvVec.resize(transSpRecvSize_*nvz_); + size_t jj = 0; + size_t jfBase = 0; + for (int jk = 0; jk < trans_.nump; ++jk) { + for (size_t jl = 0; jl < nl_; ++jl) { + for (size_t jc = 0; jc < transSpJq_[jk*nl_+jl].size(); ++jc) { + // Get jq + const size_t jq = transSpJq_[jk*nl_+jl][jc]; + + // Initialize variable and level counter + size_t jvz = 0; + + // Vorticity + for (size_t jz = 0; jz < nvordiv; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nvordiv + jq*nvordiv + jz; + + // Copy data + recvVec[jcrv] = rspVor[jf]; + + // Update counter + ++jvz; + } + + // Divergence + for (size_t jz = 0; jz < nvordiv; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nvordiv + jq*nvordiv + jz; + + // Copy data + recvVec[jcrv] = rspDiv[jf]; + + // Update counter + ++jvz; + } + + // Scalars + for (size_t jz = 0; jz < nscalar; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nscalar + jq*nscalar + jz; + + // Copy data + recvVec[jcrv] = rspScalar[jf]; + + // Update counter + ++jvz; + } + + // Check counter + ASSERT(jvz == nvz_); + + // Update communication vector index + ++jj; + } + + // Update FFT vector base index + if (transSpJq_[jk*nl_+jl].size() > 0) { + ++jfBase; + } + } + } + + oops::Log::trace() << classname() << "::gp2sp done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformECTRANS::sp2gp(std::vector & recvVec, + const atlas::util::Metadata & metadata) const { + oops::Log::trace() << classname() << "::sp2gp starting" << std::endl; + + // Check metadata for wind transform + const size_t nvordiv = metadata.getInt("nvordiv", 0); + + // Number of scalar fields + const size_t nscalar = nvz_-2*nvordiv; + + // Allocate buffers + std::vector rgp(transGpSize_*nvz_); + std::vector rspScalar; + std::vector rspVor; + std::vector rspDiv; + std::vector rMeanU; + std::vector rMeanV; + rspScalar.resize(transSpSize_*nscalar, 0.0); + rspVor.resize(transSpSize_*nvordiv, 0.0); + rspDiv.resize(transSpSize_*nvordiv, 0.0); + rMeanU.resize(nvordiv); + rMeanV.resize(nvordiv); + + // Setup inverse transform + struct InvTrans_t invtrans; + invtrans = new_invtrans(&trans_); + invtrans.nscalar = nscalar; + invtrans.nvordiv = nvordiv; + invtrans.rspscalar = rspScalar.data(); + invtrans.rspvor = rspVor.data(); + invtrans.rspdiv = rspDiv.data(); + invtrans.rmeanu = rMeanU.data(); + invtrans.rmeanv = rMeanV.data(); + invtrans.rgp = rgp.data(); + + // Reserialize + size_t jj = 0; + size_t jfBase = 0; + for (int jk = 0; jk < trans_.nump; ++jk) { + for (size_t jl = 0; jl < nl_; ++jl) { + for (size_t jc = 0; jc < transSpJq_[jk*nl_+jl].size(); ++jc) { + // Get jq + const size_t jq = transSpJq_[jk*nl_+jl][jc]; + + // Initialize variable and level counter + size_t jvz = 0; + + // Vorticity + for (size_t jz = 0; jz < nvordiv; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nvordiv + jq*nvordiv + jz; + + // Copy data + rspVor[jf] = recvVec[jcrv]; + + // Update counter + ++jvz; + } + + // Divergence + for (size_t jz = 0; jz < nvordiv; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nvordiv + jq*nvordiv + jz; + + // Copy data + rspDiv[jf] = recvVec[jcrv]; + + // Update counter + ++jvz; + } + + // Scalars + for (size_t jz = 0; jz < nscalar; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nscalar + jq*nscalar + jz; + + // Copy data + rspScalar[jf] = recvVec[jcrv]; + + // Update counter + ++jvz; + } + + // Check counter + ASSERT(jvz == nvz_); + + // Update communication vector index + ++jj; + } + + // Update FFT vector base index + if (transSpJq_[jk*nl_+jl].size() > 0) { + ++jfBase; + } + } + } + + if (metadata.has("uMeanProfile") && metadata.has("vMeanProfile")) { + // Copy mean wind + const std::vector uMeanProfile = metadata.getDoubleVector("uMeanProfile"); + const std::vector vMeanProfile = metadata.getDoubleVector("vMeanProfile"); + for (size_t jz = 0; jz < nvordiv; ++jz) { + rMeanU[jz] = uMeanProfile[jz]; + rMeanV[jz] = vMeanProfile[jz]; + } + } else { + // Set mean wind to zero + std::fill(rMeanU.begin(), rMeanU.end(), 0.0); + std::fill(rMeanV.begin(), rMeanV.end(), 0.0); + } + + // Compute inverse transform + trans_invtrans(&invtrans); + + // Reserialize + std::vector sendVec(transGpSendSize_*nvz_); + for (size_t jrs = 0; jrs < transGpSendSize_; ++jrs) { + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // Communication vector index + const size_t jrsv = jrs*nvz_ + jvz; + + // FFT vector index + const size_t jf = jvz*transGpSendSize_ + transGpSendIndex_[jrs]; + + // Copy data + sendVec[jrsv] = rgp[jf]; + } + } + + // Communication + recvVec.resize(gridRecvSize_*nvz_); + comm_.allToAllv(sendVec.data(), transGpSendCounts_.data(), transGpSendDispls_.data(), + recvVec.data(), gridRecvCounts_.data(), gridRecvDispls_.data()); + + oops::Log::trace() << classname() << "::sp2gp done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformECTRANS::gp2spAdj(std::vector & recvVec, + const atlas::util::Metadata & metadata) const { + oops::Log::trace() << classname() << "::gp2spAdj starting" << std::endl; + + // Check metadata for wind transform + const size_t nvordiv = metadata.getInt("nvordiv", 0); + + // Number of scalar fields + const size_t nscalar = nvz_-2*nvordiv; + + // Allocate buffers + std::vector rgp(transGpSize_*nvz_); + std::vector rspScalar; + std::vector rspVor; + std::vector rspDiv; + std::vector rMeanU; + std::vector rMeanV; + rspScalar.resize(transSpSize_*nscalar, 0.0); + rspVor.resize(transSpSize_*nvordiv, 0.0); + rspDiv.resize(transSpSize_*nvordiv, 0.0); + rMeanU.resize(nvordiv); + rMeanV.resize(nvordiv); + + // Setup inverse transform + struct DirTransAdj_t dirtrans_adj; + dirtrans_adj = new_dirtrans_adj(&trans_); + dirtrans_adj.nscalar = nscalar; + dirtrans_adj.nvordiv = nvordiv; + dirtrans_adj.rspscalar = rspScalar.data(); + dirtrans_adj.rspvor = rspVor.data(); + dirtrans_adj.rspdiv = rspDiv.data(); + dirtrans_adj.rmeanu = rMeanU.data(); + dirtrans_adj.rmeanv = rMeanV.data(); + dirtrans_adj.rgp = rgp.data(); + + // Reserialize + size_t jj = 0; + size_t jfBase = 0; + for (int jk = 0; jk < trans_.nump; ++jk) { + for (size_t jl = 0; jl < nl_; ++jl) { + for (size_t jc = 0; jc < transSpJq_[jk*nl_+jl].size(); ++jc) { + // Get jq + const size_t jq = transSpJq_[jk*nl_+jl][jc]; + + // Initialize variable and level counter + size_t jvz = 0; + + // Vorticity + for (size_t jz = 0; jz < nvordiv; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nvordiv + jq*nvordiv + jz; + + // Copy data + rspVor[jf] = recvVec[jcrv]; + + // Update counter + ++jvz; + } + + // Divergence + for (size_t jz = 0; jz < nvordiv; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nvordiv + jq*nvordiv + jz; + + // Copy data + rspDiv[jf] = recvVec[jcrv]; + + // Update counter + ++jvz; + } + + // Scalars + for (size_t jz = 0; jz < nscalar; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nscalar + jq*nscalar + jz; + + // Copy data + rspScalar[jf] = recvVec[jcrv]; + + // Update counter + ++jvz; + } + + // Check counter + ASSERT(jvz == nvz_); + + // Update communication vector index + ++jj; + } + + // Update FFT vector base index + if (transSpJq_[jk*nl_+jl].size() > 0) { + ++jfBase; + } + } + } + + if (metadata.has("uMeanProfile") && metadata.has("vMeanProfile")) { + // Copy mean wind + const std::vector uMeanProfile = metadata.getDoubleVector("uMeanProfile"); + const std::vector vMeanProfile = metadata.getDoubleVector("vMeanProfile"); + for (size_t jz = 0; jz < nvordiv; ++jz) { + rMeanU[jz] = uMeanProfile[jz]; + rMeanV[jz] = vMeanProfile[jz]; + } + } else { + // Set mean wind to zero + std::fill(rMeanU.begin(), rMeanU.end(), 0.0); + std::fill(rMeanV.begin(), rMeanV.end(), 0.0); + } + + // Compute direct adjoint transform + trans_dirtrans_adj(&dirtrans_adj); + + // Reserialize + std::vector sendVec(transGpSendSize_*nvz_); + for (size_t jrs = 0; jrs < transGpSendSize_; ++jrs) { + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // Communication vector index + const size_t jrsv = jrs*nvz_ + jvz; + + // FFT vector index + const size_t jf = jvz*transGpSendSize_ + transGpSendIndex_[jrs]; + + // Copy data + sendVec[jrsv] = rgp[jf]; + } + } + + // Communication + recvVec.resize(gridRecvSize_*nvz_); + comm_.allToAllv(sendVec.data(), transGpSendCounts_.data(), transGpSendDispls_.data(), + recvVec.data(), gridRecvCounts_.data(), gridRecvDispls_.data()); + + oops::Log::trace() << classname() << "::gp2spAdj done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformECTRANS::sp2gpAdj(std::vector & recvVec, + atlas::util::Metadata & metadata) const { + oops::Log::trace() << classname() << "::sp2gpAdj starting" << std::endl; + + // Check metadata for wind transform + const size_t nvordiv = metadata.getInt("nvordiv", 0); + + // Number of scalar fields + const size_t nscalar = nvz_-2*nvordiv; + + // Allocate buffers + std::vector rgp(transGpSize_*nvz_); + std::vector rspScalar; + std::vector rspVor; + std::vector rspDiv; + std::vector rMeanU; + std::vector rMeanV; + rspScalar.resize(transSpSize_*nscalar); + rspVor.resize(transSpSize_*nvordiv); + rspDiv.resize(transSpSize_*nvordiv); + rMeanU.resize(nvordiv); + rMeanV.resize(nvordiv); + + // Setup direct transform + struct InvTransAdj_t invtrans_adj; + invtrans_adj = new_invtrans_adj(&trans_); + invtrans_adj.nscalar = nscalar; + invtrans_adj.nvordiv = nvordiv; + invtrans_adj.rspscalar = rspScalar.data(); + invtrans_adj.rspvor = rspVor.data(); + invtrans_adj.rspdiv = rspDiv.data(); + invtrans_adj.rmeanu = rMeanU.data(); + invtrans_adj.rmeanv = rMeanV.data(); + invtrans_adj.rgp = rgp.data(); + + // Communication + std::vector sendVec(transGpSendSize_*nvz_); + comm_.allToAllv(recvVec.data(), gridRecvCounts_.data(), gridRecvDispls_.data(), + sendVec.data(), transGpSendCounts_.data(), transGpSendDispls_.data()); + + // Reserialize + for (size_t jrs = 0; jrs < transGpSendSize_; ++jrs) { + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // Communication vector index + const size_t jrsv = jrs*nvz_ + jvz; + + // FFT vector index + const size_t jf = jvz*transGpSendSize_ + transGpSendIndex_[jrs]; + + // Copy data + rgp[jf] = sendVec[jrsv]; + } + } + + // Compute inverse adjoint transform + trans_invtrans_adj(&invtrans_adj); + + if (nvordiv > 0) { + // Save mean wind + const double windNorm = std::sqrt(normFFT_); + for (size_t jz = 0; jz < nvordiv; ++jz) { + rMeanU[jz] *= windNorm; + rMeanV[jz] *= windNorm; + } + metadata.set("uMeanProfile", rMeanU); + metadata.set("vMeanProfile", rMeanV); + } + + // Reserialize + recvVec.resize(transSpRecvSize_*nvz_); + size_t jj = 0; + size_t jfBase = 0; + for (int jk = 0; jk < trans_.nump; ++jk) { + for (size_t jl = 0; jl < nl_; ++jl) { + for (size_t jc = 0; jc < transSpJq_[jk*nl_+jl].size(); ++jc) { + // Get jq + const size_t jq = transSpJq_[jk*nl_+jl][jc]; + + // Initialize variable and level counter + size_t jvz = 0; + + // Vorticity + for (size_t jz = 0; jz < nvordiv; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nvordiv + jq*nvordiv + jz; + + // Copy data + recvVec[jcrv] = rspVor[jf]; + + // Update counter + ++jvz; + } + + // Divergence + for (size_t jz = 0; jz < nvordiv; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nvordiv + jq*nvordiv + jz; + + // Copy data + recvVec[jcrv] = rspDiv[jf]; + + // Update counter + ++jvz; + } + + // Scalars + for (size_t jz = 0; jz < nscalar; ++jz) { + // Communication vector index + const size_t jcrv = transSpRecvIndex_[jj] + jvz; + + // FFT vector index + const size_t jf = jfBase*4*nscalar + jq*nscalar + jz; + + // Copy data + recvVec[jcrv] = rspScalar[jf]; + + // Update counter + ++jvz; + } + + // Check counter + ASSERT(jvz == nvz_); + + // Update communication vector index + ++jj; + } + + // Update FFT vector base index + if (transSpJq_[jk*nl_+jl].size() > 0) { + ++jfBase; + } + } + } + + oops::Log::trace() << classname() << "::sp2gpAdj done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformECTRANS::setupBackend() { + oops::Log::trace() << classname() << "::setupBackend starting" << std::endl; + + // Configure transforms + trans_use_mpi(true); + trans_set_leq_regions(false); + const int nprgpew = std::min(1, static_cast(std::sqrt(static_cast(comm_.size())))); + trans_set_nprgpew(nprgpew); + + // Setup transform structure + trans_new(&trans_); + trans_set_resol_lam(&trans_, nx_, ny_, dx_, dy_); + trans_set_trunc_lam(&trans_, M_, N_); + trans_setup(&trans_); + trans_inquire(&trans_, "nlstlat,nfrstlat,nsta,nonl,nmyms"); + + // Copy transform structure sizes + transGpSize_ = trans_.ngptot; + transSpSize_ = trans_.nspec2; + + // Trans <=> grid + + // Define x/y indices from trans grid-point distribution (see IFS code for details...) + std::vector index_x(transGpSize_); + std::vector index_y(transGpSize_); + size_t xMin = std::numeric_limits::max(); + size_t xMax = std::numeric_limits::min(); + size_t yMin = std::numeric_limits::max(); + size_t yMax = std::numeric_limits::min(); + int irof = 0; + const int istlat = 1; + const int iendlat = trans_.nlstlat[trans_.my_region_NS+f2c]-trans_.nfrstloff; + for (int jgl = istlat; jgl <= iendlat; ++jgl) { + const int iglg = trans_.nfrstlat[trans_.my_region_NS+f2c]+jgl-istlat; + const int nstaIndex = (trans_.nptrfloff+jgl-1)*trans_.n_regions_EW + trans_.my_region_EW; + const int istlon = trans_.nsta[nstaIndex+f2c]; + const int iendlon = trans_.nsta[nstaIndex+f2c]+trans_.nonl[nstaIndex+f2c]-1; + for (int jlon = istlon; jlon <= iendlon; ++jlon) { + const int igp = trans_.nlon*(iglg-1)+jlon; + index_y[irof] = (igp-1)/trans_.nlon+1; + index_x[irof] = igp-(index_y[irof]-1)*trans_.nlon; + xMin = std::min(xMin, index_x[irof]); + xMax = std::max(xMax, index_x[irof]); + yMin = std::min(yMin, index_y[irof]); + yMax = std::max(yMax, index_y[irof]); + ++irof; + } + } + ASSERT(irof == static_cast(transGpSize_)); + + // Trans grid local index from x/y + const size_t nx = xMax-xMin+1; + const size_t ny = yMax-yMin+1; + std::vector> gpIndex(nx); + for (size_t jx = 0; jx < nx; ++jx) { + gpIndex[jx].resize(ny, -1); + } + for (size_t jj = 0; jj < transGpSize_; ++jj) { + gpIndex[index_x[jj]-xMin][index_y[jj]-yMin] = jj; + } + + // Copy x/y/rank + std::vector nto(3, 1); + std::vector rgpg; + if (comm_.rank() == 0) { + rgpg.resize(3*trans_.ngptotg); + } + std::vector rgp(3*transGpSize_); + for (size_t jj = 0; jj < transGpSize_; ++jj) { + rgp[0*transGpSize_+jj] = static_cast(index_x[jj]); + rgp[1*transGpSize_+jj] = static_cast(index_y[jj]); + rgp[2*transGpSize_+jj] = comm_.rank(); + } + + // Gather x/y/rank + struct GathGrid_t gathgrid = new_gathgrid(&trans_); + gathgrid.rgp = rgp.data(); + gathgrid.rgpg = rgpg.data(); + gathgrid.nto = nto.data(); + gathgrid.nfld = 3; + trans_gathgrid(&gathgrid); + + // Get partition + std::vector partgp(trans_.ngptotg); + if (comm_.rank() == 0) { + ASSERT(trans_.ngptotg == trans_.ngptotg); + for (int jj = 0; jj < trans_.ngptotg; ++jj) { + const size_t ix = static_cast(rgpg[0*trans_.ngptotg+jj])+f2c; + const size_t iy = static_cast(rgpg[1*trans_.ngptotg+jj])+f2c; + const size_t it = static_cast(rgpg[2*trans_.ngptotg+jj]); + const size_t ixy = ix*ny_+iy; + partgp[ixy] = it; + } + } + + // Broadcast partition + comm_.broadcast(partgp, 0); + + // Ghost points + const auto ghostView = make_view(gdata_.functionSpace().ghost()); + + // Index fields views + const atlas::functionspace::StructuredColumns fs(gdata_.functionSpace()); + const auto indexIView = make_indexview(fs.index_i()); + const auto indexJView = make_indexview(fs.index_j()); + + // Number of values on each destination task + gridRecvSize_ = 0; + for (size_t jnode = 0; jnode < nodes_; ++jnode) { + if (ghostView(jnode) == 0) { + ++gridRecvSize_; + } + } + + // Define destination task + std::vector transGpSendTask(gridRecvSize_); + std::vector transGpSendOffset(gridRecvSize_); + std::vector transGpSendOffsetPerTask(comm_.size(), 0); + size_t jgr = 0; + for (size_t jnode = 0; jnode < nodes_; ++jnode) { + if (ghostView(jnode) == 0) { + const size_t ix = indexIView(jnode); + const size_t iy = indexJView(jnode); + const size_t ixy = ix*ny_+iy; + const size_t it = partgp[ixy]; + transGpSendTask[jgr] = it; + transGpSendOffset[jgr] = transGpSendOffsetPerTask[it]; + ++transGpSendOffsetPerTask[it]; + ++jgr; + } + } + + // RecvCounts + gridRecvCounts_.resize(comm_.size(), 0); + for (size_t jgr = 0; jgr < gridRecvSize_; ++jgr) { + ++gridRecvCounts_[transGpSendTask[jgr]]; + } + + // RecvDispls + gridRecvDispls_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + gridRecvDispls_[jt] = static_cast(jt ? gridRecvDispls_[jt-1] + gridRecvCounts_[jt-1] : 0); + } + + // Allgather RecvCounts + eckit::mpi::Buffer rRecvCountsBuffer(comm_.size()); + comm_.allGatherv(gridRecvCounts_.begin(), gridRecvCounts_.end(), rRecvCountsBuffer); + std::vector rRecvCountsGlb_ = std::move(rRecvCountsBuffer.buffer); + + // SendCounts + for (size_t jt = 0; jt < comm_.size(); ++jt) { + transGpSendCounts_.push_back(rRecvCountsGlb_[jt*comm_.size()+myrank_]); + } + + // Buffer size + transGpSendSize_ = 0; + for (const auto & n : transGpSendCounts_) transGpSendSize_ += n; + + // SendDispls + transGpSendDispls_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + transGpSendDispls_[jt] = static_cast(jt ? + transGpSendDispls_[jt-1] + transGpSendCounts_[jt-1] : 0); + } + + // Communicate indices + std::vector gridRecvIndex_x(gridRecvSize_); + std::vector gridRecvIndex_y(gridRecvSize_); + jgr = 0; + for (size_t jnode = 0; jnode < nodes_; ++jnode) { + if (ghostView(jnode) == 0) { + gridRecvIndex_x[jgr] = indexIView(jnode); + gridRecvIndex_y[jgr] = indexJView(jnode); + ++jgr; + } + } + std::vector transGpSendIndex_x(transGpSendSize_); + std::vector transGpSendIndex_y(transGpSendSize_); + transGpSendIndex_.resize(transGpSendSize_); + comm_.allToAllv(gridRecvIndex_x.data(), gridRecvCounts_.data(), gridRecvDispls_.data(), + transGpSendIndex_x.data(), transGpSendCounts_.data(), transGpSendDispls_.data()); + comm_.allToAllv(gridRecvIndex_y.data(), gridRecvCounts_.data(), gridRecvDispls_.data(), + transGpSendIndex_y.data(), transGpSendCounts_.data(), transGpSendDispls_.data()); + for (size_t jrs = 0; jrs < transGpSendSize_; ++jrs) { + transGpSendIndex_[jrs] = gpIndex[transGpSendIndex_x[jrs]-(xMin+f2c)] + [transGpSendIndex_y[jrs]-(yMin+f2c)]; + ASSERT(transGpSendIndex_[jrs] >= 0); + ASSERT(transGpSendIndex_[jrs] < static_cast(transGpSize_)); + } + + // Effective index + gridRecvIndex_.resize(gridRecvSize_); + for (size_t jgr = 0; jgr < gridRecvSize_; ++jgr) { + gridRecvIndex_[jgr] = (gridRecvDispls_[transGpSendTask[jgr]] + transGpSendOffset[jgr])*nvz_; + } + + // Equal chunks <=> trans + + // Number of values on each destination task + transSpRecvSize_ = 0; + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + const size_t jk = spVec_[jsGlb].jk; + for (int jump = 1; jump <= trans_.nump; ++jump) { + if (static_cast(jk) == trans_.nmyms[jump+f2c]) { + ++transSpRecvSize_; + } + } + } + + // Define destination task + std::vector eqchSendTask(transSpRecvSize_); + std::vector eqchSendOffset(transSpRecvSize_); + std::vector eqchSendOffsetPerTask(comm_.size(), 0); + size_t jv = 0; + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + const size_t jk = spVec_[jsGlb].jk; + for (int jump = 1; jump <= trans_.nump; ++jump) { + if (static_cast(jk) == trans_.nmyms[jump+f2c]) { + const size_t jt = spVec_[jsGlb].jt; + eqchSendTask[jv] = jt; + eqchSendOffset[jv] = eqchSendOffsetPerTask[jt]; + ++eqchSendOffsetPerTask[jt]; + ++jv; + } + } + } + + // RecvCounts + transSpRecvCounts_.resize(comm_.size(), 0); + for (size_t jcr = 0; jcr < transSpRecvSize_; ++jcr) { + ++transSpRecvCounts_[eqchSendTask[jcr]]; + } + + // RecvDispls + transSpRecvDispls_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + transSpRecvDispls_[jt] = static_cast(jt ? + transSpRecvDispls_[jt-1] + transSpRecvCounts_[jt-1] : 0); + } + + // Allgather RecvCounts + eckit::mpi::Buffer transSpRecvCountsBuffer(comm_.size()); + comm_.allGatherv(transSpRecvCounts_.begin(), transSpRecvCounts_.end(), transSpRecvCountsBuffer); + std::vector transSpRecvCountsGlb_ = std::move(transSpRecvCountsBuffer.buffer); + + // SendCounts + for (size_t jt = 0; jt < comm_.size(); ++jt) { + eqchSendCounts_.push_back(transSpRecvCountsGlb_[jt*comm_.size()+myrank_]); + } + + // Buffer size + eqchSendSize_ = 0; + for (const auto & n : eqchSendCounts_) eqchSendSize_ += n; + + // SendDispls + eqchSendDispls_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + eqchSendDispls_[jt] = static_cast(jt ? eqchSendDispls_[jt-1] + eqchSendCounts_[jt-1] : 0); + } + + // Get destination task inverse order + std::vector transSpRecvOrder(transSpRecvSize_); + std::iota(transSpRecvOrder.begin(), transSpRecvOrder.end(), 0); + std::stable_sort(transSpRecvOrder.begin(), transSpRecvOrder.end(), + [&](int i, int j){return eqchSendTask[i] < eqchSendTask[j];}); + std::vector transSpRecvOrderInverse(transSpRecvSize_); + for (size_t jcr = 0; jcr < transSpRecvSize_; ++jcr) { + transSpRecvOrderInverse[transSpRecvOrder[jcr]] = jcr; + } + + // Communicate indices + std::vector transSpRecvIndex(transSpRecvSize_); + size_t jcr = 0; + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + const size_t jk = spVec_[jsGlb].jk; + for (int jump = 1; jump <= trans_.nump; ++jump) { + if (static_cast(jk) == trans_.nmyms[jump+f2c]) { + transSpRecvIndex[transSpRecvOrderInverse[jcr]] = jsGlb; + ++jcr; + } + } + } + eqchSendIndex_.resize(eqchSendSize_); + comm_.allToAllv(transSpRecvIndex.data(), transSpRecvCounts_.data(), transSpRecvDispls_.data(), + eqchSendIndex_.data(), eqchSendCounts_.data(), eqchSendDispls_.data()); + for (size_t jes = 0; jes < eqchSendSize_; ++jes) { + const auto it = std::find(sToSGlb_.begin(), sToSGlb_.end(), eqchSendIndex_[jes]); + ASSERT(it != sToSGlb_.end()); + eqchSendIndex_[jes] = it-sToSGlb_.begin(); + } + + // Effective index + transSpRecvIndex_.resize(transSpRecvSize_); + for (size_t jcr = 0; jcr < transSpRecvSize_; ++jcr) { + transSpRecvIndex_[jcr] = (transSpRecvDispls_[eqchSendTask[jcr]] + eqchSendOffset[jcr])*nvz_; + } + + // Scale counts and displs for all levels + for (size_t jt = 0; jt < comm_.size(); ++jt) { + gridRecvCounts_[jt] *= nvz_; + gridRecvDispls_[jt] *= nvz_; + transGpSendCounts_[jt] *= nvz_; + transGpSendDispls_[jt] *= nvz_; + transSpRecvCounts_[jt] *= nvz_; + transSpRecvDispls_[jt] *= nvz_; + eqchSendCounts_[jt] *= nvz_; + eqchSendDispls_[jt] *= nvz_; + } + + // Number of component for each local jk,jl couple + transSpJq_.resize(trans_.nump*nl_); + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + const size_t jk = spVec_[jsGlb].jk; + for (int jump = 1; jump <= trans_.nump; ++jump) { + if (static_cast(jk) == trans_.nmyms[jump+f2c]) { + const size_t jkPerTask = jump+f2c; + const size_t jl = spVec_[jsGlb].jl; + const size_t jq = spVec_[jsGlb].jq; + transSpJq_[jkPerTask*nl_+jl].push_back(jq); + } + } + } + + oops::Log::trace() << classname() << "::setupBackend done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +} // namespace bifourier +} // namespace saber diff --git a/src/saber/bifourier/BifourierTransformECTRANS.h b/src/saber/bifourier/BifourierTransformECTRANS.h new file mode 100644 index 000000000..6647eacab --- /dev/null +++ b/src/saber/bifourier/BifourierTransformECTRANS.h @@ -0,0 +1,91 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#pragma once + +#include +#include + +#include "ectrans/transi.h" + +#include "saber/bifourier/BifourierTransformBase.h" + +namespace saber { +namespace bifourier { + +// ----------------------------------------------------------------------------- + +class BifourierTransformECTRANS : public BifourierTransformBase { + public: + static const std::string classname() + {return "saber::bifourier::BifourierTransformECTRANS";} + + // Constructor + BifourierTransformECTRANS(const oops::GeometryData & gdata, + const std::string & gridUid, + const oops::Variables & activeVars, + const BifourierTransformParameters & params); + + // Destructor + ~BifourierTransformECTRANS(); + + // Forward FFT + void gp2sp(std::vector &, + atlas::util::Metadata &) const; + + // Inverse FFT + void sp2gp(std::vector &, + const atlas::util::Metadata &) const; + + // Forward FFT adjoint + void gp2spAdj(std::vector &, + const atlas::util::Metadata &) const; + + // Inverse FFT adjoint + void sp2gpAdj(std::vector &, + atlas::util::Metadata &) const; + + // Communication vectors + const size_t & recvSize() const + {return transSpRecvSize_;} + const std::vector & recvCounts() const + {return transSpRecvCounts_;} + const std::vector & recvDispls() const + {return transSpRecvDispls_;} + + private: + // ECTRANS backend + + // Conversion from Fortran to C arrays + const int f2c = -1; + + // Transform structure + mutable struct Trans_t trans_; + + // Trans <=> grid + size_t transGpSize_; + size_t transGpSendSize_; + std::vector transGpSendIndex_; + std::vector transGpSendCounts_; + std::vector transGpSendDispls_; + + // Equal chunks <=> trans + size_t transSpSize_; + size_t transSpRecvSize_; + std::vector transSpRecvIndex_; + std::vector> transSpJq_; + std::vector transSpRecvCounts_; + std::vector transSpRecvDispls_; + + // Private methods + + // Setup transform + void setupBackend(); +}; + +// ----------------------------------------------------------------------------- + +} // namespace bifourier +} // namespace saber diff --git a/src/saber/bifourier/BifourierTransformFFTW.cc b/src/saber/bifourier/BifourierTransformFFTW.cc new file mode 100644 index 000000000..0ff25d9f4 --- /dev/null +++ b/src/saber/bifourier/BifourierTransformFFTW.cc @@ -0,0 +1,680 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#include "saber/bifourier/BifourierTransformFFTW.h" + +#include + +#include "saber/bifourier/BifourierUtilities.h" + +using atlas::array::make_datatype; +using atlas::array::make_indexview; +using atlas::array::make_shape; +using atlas::array::make_view; + +namespace saber { +namespace bifourier { + +// ----------------------------------------------------------------------------- + +static BifourierTransformMaker makerFFTW_("fftw"); + +// ----------------------------------------------------------------------------- + +BifourierTransformFFTW::BifourierTransformFFTW(const oops::GeometryData & gdata, + const std::string & gridUid, + const oops::Variables & activeVars, + const BifourierTransformParameters & params) : + BifourierTransformBase(gdata, gridUid, activeVars, params) { + oops::Log::trace() << classname() << "::BifourierTransformFFTW starting" << std::endl; + + // Setup global spectral space parameters + setupGlobalSpectralSpace(); + + // Setup parallelization, initial step [base method] + setupParallelizationInit(); + + // Backend-specific setup + setupBackend(); + + // Setup parallelization, final step [base method] + setupParallelizationFinal(); + + // Setup local spectral space + setupLocalSpectralSpace(); + + oops::Log::trace() << classname() << "::BifourierTransformFFTW done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +BifourierTransformFFTW::~BifourierTransformFFTW() { + oops::Log::trace() << classname() << "::~BifourierTransformFFTW starting" << std::endl; + + // Delete FFTW-related data + fftw_destroy_plan(rowsPlan_r2c_); + fftw_destroy_plan(rowsPlan_c2r_); + fftw_destroy_plan(colsPlan_r2c_); + fftw_destroy_plan(colsPlan_c2r_); + fftw_free(rowsBufR_); + fftw_free(rowsBufC_); + fftw_free(colsBufR_); + fftw_free(colsBufC_); + + oops::Log::trace() << classname() << "::~BifourierTransformFFTW done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformFFTW::gp2sp(std::vector & recvVec, + atlas::util::Metadata & metadata) const { + oops::Log::trace() << classname() << "::gp2sp starting" << std::endl; + + // Create send vector + std::vector sendVec; + + // Communication + sendVec.resize(rowsSendSize_*nvz_); + comm_.allToAllv(recvVec.data(), gridRecvCounts_.data(), gridRecvDispls_.data(), + sendVec.data(), rowsSendCounts_.data(), rowsSendDispls_.data()); + + // Reserialize + for (size_t jrs = 0; jrs < rowsSendSize_; ++jrs) { + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // Communication vector index + const size_t jrsv = jrs*nvz_ + jvz; + + // FFT vector index + size_t jf = rowsSendIndex_[jrs] + jvz*nx_; + + // Copy data + rowsBufR_[jf] = sendVec[jrsv]; + } + } + + // Compute direct transform + fftw_execute(rowsPlan_r2c_); + + // Reserialize + recvVec.resize(rowsRecvSize_*nvz_*2); + size_t jrr = 0; + for (size_t jy = 0; jy < nyPerTask_[myrank_]; ++jy) { + for (size_t jk = 0; jk < nk_; ++jk) { + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // FFT vector index + const size_t jf = jy*nvz_*nk_ + jvz*nk_ + jk; + + // Communication vector index + const size_t jrrv = rowsRecvIndex_[jrr] + jvz*2; + + // Copy data + recvVec[jrrv] = rowsBufC_[jf][0]; + recvVec[jrrv+1] = rowsBufC_[jf][1]; + } + ++jrr; + } + } + + // Communication + sendVec.resize(colsSendSize_*nvz_*2); + comm_.allToAllv(recvVec.data(), rowsRecvCounts_.data(), rowsRecvDispls_.data(), + sendVec.data(), colsSendCounts_.data(), colsSendDispls_.data()); + + // Reserialize + for (size_t jcs = 0; jcs < colsSendSize_; ++jcs) { + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // Communication vector index + const size_t jcsv = jcs*nvz_*2 + jvz*2; + + // FFT vector index + const size_t jf = colsSendIndex_[jcs] + jvz*2*ny_; + + // Copy data + colsBufR_[jf] = sendVec[jcsv]; + colsBufR_[jf+ny_] = sendVec[jcsv+1]; + } + } + + // Compute direct transform + fftw_execute(colsPlan_r2c_); + + // Reserialize + recvVec.resize(colsRecvSize_*nvz_); + size_t jj = 0; + for (size_t jk = 0; jk < nkPerTask_[myrank_]; ++jk) { + for (size_t jl = 0; jl < nl_; ++jl) { + for (size_t jc = 0; jc < colsJq_[jk*nl_+jl].size(); ++jc) { + // Get jq + const size_t jq = colsJq_[jk*nl_+jl][jc]; + + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // FFT vector index + const size_t jf = jk*nvz_*2*nl_ + jvz*2*nl_ + jl; + + // Communication vector index + const size_t jcrv = colsRecvIndex_[jj] + jvz; + + // Copy data + if (jq == 0) { + recvVec[jcrv] = colsBufC_[jf][0]; + } + if (jq == 1) { + recvVec[jcrv] = colsBufC_[jf][1]; + } + if (jq == 2) { + recvVec[jcrv] = colsBufC_[jf+nl_][0]; + } + if (jq == 3) { + recvVec[jcrv] = colsBufC_[jf+nl_][1]; + } + } + + // Update communication vector index + ++jj; + } + } + } + + oops::Log::trace() << classname() << "::gp2sp done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformFFTW::sp2gp(std::vector & recvVec, + const atlas::util::Metadata & metadata) const { + oops::Log::trace() << classname() << "::sp2gp starting" << std::endl; + + // Create send vector + std::vector sendVec; + + // Set FFT vector to zero + for (size_t jj = 0; jj < nkPerTask_[myrank_]*nl_*nvz_*2; ++jj) { + colsBufC_[jj][0] = 0.0; + colsBufC_[jj][1] = 0.0; + } + + // Reserialize + size_t jj = 0; + for (size_t jk = 0; jk < nkPerTask_[myrank_]; ++jk) { + for (size_t jl = 0; jl < nl_; ++jl) { + for (size_t jc = 0; jc < colsJq_[jk*nl_+jl].size(); ++jc) { + // Get jq + const size_t jq = colsJq_[jk*nl_+jl][jc]; + + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // FFT vector index + const size_t jf = jk*nvz_*2*nl_ + jvz*2*nl_ + jl; + + // Communication vector index + const size_t jcrv = colsRecvIndex_[jj] + jvz; + + // Copy data + if (jq == 0) { + colsBufC_[jf][0] = recvVec[jcrv]; + } + if (jq == 1) { + colsBufC_[jf][1] = recvVec[jcrv]; + } + if (jq == 2) { + colsBufC_[jf+nl_][0] = recvVec[jcrv]; + } + if (jq == 3) { + colsBufC_[jf+nl_][1] = recvVec[jcrv]; + } + } + + // Update communication vector index + ++jj; + } + } + } + + // Compute inverse transform + fftw_execute(colsPlan_c2r_); + + // Reserialize + sendVec.resize(colsSendSize_*nvz_*2); + for (size_t jcs = 0; jcs < colsSendSize_; ++jcs) { + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // Communication vector index + const size_t jcsv = jcs*nvz_*2 + jvz*2; + + // FFT vector index + const size_t jf = colsSendIndex_[jcs] + jvz*2*ny_; + + // Copy data + sendVec[jcsv] = colsBufR_[jf]; + sendVec[jcsv+1] = colsBufR_[jf+ny_]; + } + } + + // Communication + recvVec.resize(rowsRecvSize_*nvz_*2); + comm_.allToAllv(sendVec.data(), colsSendCounts_.data(), colsSendDispls_.data(), + recvVec.data(), rowsRecvCounts_.data(), rowsRecvDispls_.data()); + + // Reserialize + size_t jrr = 0; + for (size_t jy = 0; jy < nyPerTask_[myrank_]; ++jy) { + for (size_t jk = 0; jk < nk_; ++jk) { + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // FFT vector index + const size_t jf = jy*nvz_*nk_ + jvz*nk_ + jk; + + // Communication vector index + const size_t jrrv = rowsRecvIndex_[jrr] + jvz*2; + + // Copy data + rowsBufC_[jf][0] = recvVec[jrrv]; + rowsBufC_[jf][1] = recvVec[jrrv+1]; + } + ++jrr; + } + } + + // Compute inverse transform + fftw_execute(rowsPlan_c2r_); + + // Reserialize + sendVec.resize(rowsSendSize_*nvz_); + for (size_t jrs = 0; jrs < rowsSendSize_; ++jrs) { + for (size_t jvz = 0; jvz < nvz_; ++jvz) { + // Communication vector index + const size_t jrsv = jrs*nvz_ + jvz; + + // FFT vector index + const size_t jf = rowsSendIndex_[jrs] + jvz*nx_; + + // Copy data + sendVec[jrsv] = rowsBufR_[jf]; + } + } + + // Communication + recvVec.resize(gridRecvSize_*nvz_); + comm_.allToAllv(sendVec.data(), rowsSendCounts_.data(), rowsSendDispls_.data(), + recvVec.data(), gridRecvCounts_.data(), gridRecvDispls_.data()); + + oops::Log::trace() << classname() << "::sp2gp done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +void BifourierTransformFFTW::setupBackend() { + oops::Log::trace() << classname() << "::setupBackend starting" << std::endl; + + // Split in y direction + nyPerTask_.resize(comm_.size(), 0); + size_t index = 0; + for (size_t jy = 0; jy < ny_; ++jy) { + ++nyPerTask_[index]; + ++index; + if (index == comm_.size()) index = 0; + } + std::vector nyStart(comm_.size()); + std::vector nyEnd(comm_.size()); + nyStart[0] = 0; + nyEnd[0] = nyPerTask_[0]-1; + for (size_t jt = 0; jt < comm_.size()-1; ++jt) { + nyStart[jt+1] = nyStart[jt]+nyPerTask_[jt]; + nyEnd[jt+1] = nyStart[jt+1]+nyPerTask_[jt+1]-1; + } + + // Split in k direction + nkPerTask_.resize(comm_.size(), 0); + index = 0; + for (size_t jk = 0; jk < nk_; ++jk) { + ++nkPerTask_[index]; + ++index; + if (index == comm_.size()) index = 0; + } + std::vector nkStart(comm_.size()); + std::vector nkEnd(comm_.size()); + nkStart[0] = 0; + nkEnd[0] = nkPerTask_[0]-1; + for (size_t jt = 0; jt < comm_.size()-1; ++jt) { + nkStart[jt+1] = nkStart[jt]+nkPerTask_[jt]; + nkEnd[jt+1] = nkStart[jt+1]+nkPerTask_[jt+1]-1; + } + + // Rows <=> grid + + // Ghost points + const auto ghostView = make_view(gdata_.functionSpace().ghost()); + + // Index fields views + const atlas::functionspace::StructuredColumns fs(gdata_.functionSpace()); + const auto indexIView = make_indexview(fs.index_i()); + const auto indexJView = make_indexview(fs.index_j()); + + // Number of values on each destination task + gridRecvSize_ = 0; + for (size_t jnode = 0; jnode < nodes_; ++jnode) { + if (ghostView(jnode) == 0) { + ++gridRecvSize_; + } + } + + // Define destination task + std::vector rowsSendTask(gridRecvSize_); + std::vector rowsSendOffset(gridRecvSize_); + std::vector rowsSendOffsetPerTask(comm_.size(), 0); + size_t jgr = 0; + for (size_t jnode = 0; jnode < nodes_; ++jnode) { + if (ghostView(jnode) == 0) { + for (size_t jt = 0; jt < comm_.size(); ++jt) { + if (static_cast(indexJView(jnode)) >= nyStart[jt] && + static_cast(indexJView(jnode)) <= nyEnd[jt]) { + rowsSendTask[jgr] = jt; + rowsSendOffset[jgr] = rowsSendOffsetPerTask[jt]; + ++rowsSendOffsetPerTask[jt]; + } + } + ++jgr; + } + } + + // RecvCounts + gridRecvCounts_.resize(comm_.size(), 0); + for (size_t jgr = 0; jgr < gridRecvSize_; ++jgr) { + ++gridRecvCounts_[rowsSendTask[jgr]]; + } + + // RecvDispls + gridRecvDispls_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + gridRecvDispls_[jt] = static_cast(jt ? gridRecvDispls_[jt-1] + gridRecvCounts_[jt-1] : 0); + } + + // Allgather RecvCounts + eckit::mpi::Buffer rRecvCountsBuffer(comm_.size()); + comm_.allGatherv(gridRecvCounts_.begin(), gridRecvCounts_.end(), rRecvCountsBuffer); + std::vector rRecvCountsGlb_ = std::move(rRecvCountsBuffer.buffer); + + // SendCounts + for (size_t jt = 0; jt < comm_.size(); ++jt) { + rowsSendCounts_.push_back(rRecvCountsGlb_[jt*comm_.size()+myrank_]); + } + + // Buffer size + rowsSendSize_ = 0; + for (const auto & n : rowsSendCounts_) rowsSendSize_ += n; + + // SendDispls + rowsSendDispls_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + rowsSendDispls_[jt] = static_cast(jt ? rowsSendDispls_[jt-1] + rowsSendCounts_[jt-1] : 0); + } + + // Communicate indices + std::vector gridRecvIndex_x(gridRecvSize_); + std::vector gridRecvIndex_y(gridRecvSize_); + jgr = 0; + for (size_t jnode = 0; jnode < nodes_; ++jnode) { + if (ghostView(jnode) == 0) { + gridRecvIndex_x[jgr] = indexIView(jnode); + gridRecvIndex_y[jgr] = indexJView(jnode); + ++jgr; + } + } + std::vector rowsSendIndex_x(rowsSendSize_); + std::vector rowsSendIndex_y(rowsSendSize_); + rowsSendIndex_.resize(rowsSendSize_); + comm_.allToAllv(gridRecvIndex_x.data(), gridRecvCounts_.data(), gridRecvDispls_.data(), + rowsSendIndex_x.data(), rowsSendCounts_.data(), rowsSendDispls_.data()); + comm_.allToAllv(gridRecvIndex_y.data(), gridRecvCounts_.data(), gridRecvDispls_.data(), + rowsSendIndex_y.data(), rowsSendCounts_.data(), rowsSendDispls_.data()); + for (size_t jrs = 0; jrs < rowsSendSize_; ++jrs) { + rowsSendIndex_[jrs] = (rowsSendIndex_y[jrs]-nyStart[myrank_])*nvz_*nx_ + rowsSendIndex_x[jrs]; + } + + // Effective index + gridRecvIndex_.resize(gridRecvSize_); + for (size_t jgr = 0; jgr < gridRecvSize_; ++jgr) { + gridRecvIndex_[jgr] = (gridRecvDispls_[rowsSendTask[jgr]] + rowsSendOffset[jgr])*nvz_; + } + + // Columns <=> rows + + // Number of values on each destination task + rowsRecvSize_ = nyPerTask_[myrank_]*nk_; + + // Define destination task + std::vector colsSendTask(rowsRecvSize_); + std::vector colsSendOffset(rowsRecvSize_); + std::vector colsSendOffsetPerTask(comm_.size(), 0); + for (size_t jk = 0; jk < nk_; ++jk) { + for (size_t jy = 0; jy < nyPerTask_[myrank_]; ++jy) { + for (size_t jt = 0; jt < comm_.size(); ++jt) { + if (jk >= nkStart[jt] && jk <= nkEnd[jt]) { + colsSendTask[jy*nk_+jk] = jt; + colsSendOffset[jy*nk_+jk] = colsSendOffsetPerTask[jt]; + ++colsSendOffsetPerTask[jt]; + } + } + } + } + + // RecvCounts + rowsRecvCounts_.resize(comm_.size(), 0); + for (size_t jrr = 0; jrr < rowsRecvSize_; ++jrr) { + ++rowsRecvCounts_[colsSendTask[jrr]]; + } + + // RecvDispls + rowsRecvDispls_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + rowsRecvDispls_[jt] = static_cast(jt ? rowsRecvDispls_[jt-1] + rowsRecvCounts_[jt-1] : 0); + } + + // Allgather RecvCounts + eckit::mpi::Buffer rowsRecvCountsBuffer(comm_.size()); + comm_.allGatherv(rowsRecvCounts_.begin(), rowsRecvCounts_.end(), rowsRecvCountsBuffer); + std::vector rowsRecvCountsGlb_ = std::move(rowsRecvCountsBuffer.buffer); + + // SendCounts + for (size_t jt = 0; jt < comm_.size(); ++jt) { + colsSendCounts_.push_back(rowsRecvCountsGlb_[jt*comm_.size()+myrank_]); + } + + // Buffer size + colsSendSize_ = 0; + for (const auto & n : colsSendCounts_) colsSendSize_ += n; + + // SendDispls + colsSendDispls_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + colsSendDispls_[jt] = static_cast(jt ? colsSendDispls_[jt-1] + colsSendCounts_[jt-1] : 0); + } + + // Communicate indices + std::vector rowsRecvIndex_k(rowsRecvSize_); + std::vector rowsRecvIndex_y(rowsRecvSize_); + for (size_t jk = 0; jk < nk_; ++jk) { + for (size_t jy = 0; jy < nyPerTask_[myrank_]; ++jy) { + rowsRecvIndex_k[jk*nyPerTask_[myrank_]+jy] = jk; + rowsRecvIndex_y[jk*nyPerTask_[myrank_]+jy] = jy+nyStart[myrank_]; + } + } + std::vector colsSendIndex_k(colsSendSize_); + std::vector colsSendIndex_y(colsSendSize_); + colsSendIndex_.resize(colsSendSize_); + comm_.allToAllv(rowsRecvIndex_k.data(), rowsRecvCounts_.data(), rowsRecvDispls_.data(), + colsSendIndex_k.data(), colsSendCounts_.data(), colsSendDispls_.data()); + comm_.allToAllv(rowsRecvIndex_y.data(), rowsRecvCounts_.data(), rowsRecvDispls_.data(), + colsSendIndex_y.data(), colsSendCounts_.data(), colsSendDispls_.data()); + for (size_t jcs = 0; jcs < colsSendSize_; ++jcs) { + colsSendIndex_[jcs] = (colsSendIndex_k[jcs]-nkStart[myrank_])*nvz_*2*ny_ + colsSendIndex_y[jcs]; + } + + // Effective index + rowsRecvIndex_.resize(rowsRecvSize_); + for (size_t jrr = 0; jrr < rowsRecvSize_; ++jrr) { + rowsRecvIndex_[jrr] = (rowsRecvDispls_[colsSendTask[jrr]] + colsSendOffset[jrr])*nvz_*2; + } + + // Equal chunks <=> columns + + // Number of values on each destination task + colsRecvSize_ = 0; + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + const size_t jk = spVec_[jsGlb].jk; + if (jk >= nkStart[myrank_] && jk <= nkEnd[myrank_]) { + ++colsRecvSize_; + } + } + + // Define destination task + std::vector eqchSendTask(colsRecvSize_); + std::vector eqchSendOffset(colsRecvSize_); + std::vector eqchSendOffsetPerTask(comm_.size(), 0); + size_t jv = 0; + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + const size_t jk = spVec_[jsGlb].jk; + if (jk >= nkStart[myrank_] && jk <= nkEnd[myrank_]) { + const size_t jt = spVec_[jsGlb].jt; + eqchSendTask[jv] = jt; + eqchSendOffset[jv] = eqchSendOffsetPerTask[jt]; + ++eqchSendOffsetPerTask[jt]; + ++jv; + } + } + + // RecvCounts + colsRecvCounts_.resize(comm_.size(), 0); + for (size_t jcr = 0; jcr < colsRecvSize_; ++jcr) { + ++colsRecvCounts_[eqchSendTask[jcr]]; + } + + // RecvDispls + colsRecvDispls_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + colsRecvDispls_[jt] = static_cast(jt ? colsRecvDispls_[jt-1] + colsRecvCounts_[jt-1] : 0); + } + + // Allgather RecvCounts + eckit::mpi::Buffer colsRecvCountsBuffer(comm_.size()); + comm_.allGatherv(colsRecvCounts_.begin(), colsRecvCounts_.end(), colsRecvCountsBuffer); + std::vector colsRecvCountsGlb_ = std::move(colsRecvCountsBuffer.buffer); + + // SendCounts + for (size_t jt = 0; jt < comm_.size(); ++jt) { + eqchSendCounts_.push_back(colsRecvCountsGlb_[jt*comm_.size()+myrank_]); + } + + // Buffer size + eqchSendSize_ = 0; + for (const auto & n : eqchSendCounts_) eqchSendSize_ += n; + + // SendDispls + eqchSendDispls_.resize(comm_.size()); + for (size_t jt = 0; jt < comm_.size(); ++jt) { + eqchSendDispls_[jt] = static_cast(jt ? eqchSendDispls_[jt-1] + eqchSendCounts_[jt-1] : 0); + } + + // Get destination task inverse order + std::vector colsRecvOrder(colsRecvSize_); + std::iota(colsRecvOrder.begin(), colsRecvOrder.end(), 0); + std::stable_sort(colsRecvOrder.begin(), colsRecvOrder.end(), + [&](int i, int j){return eqchSendTask[i] < eqchSendTask[j];}); + std::vector colsRecvOrderInverse(colsRecvSize_); + for (size_t jcr = 0; jcr < colsRecvSize_; ++jcr) { + colsRecvOrderInverse[colsRecvOrder[jcr]] = jcr; + } + + // Communicate indices + std::vector colsRecvIndex(colsRecvSize_); + size_t jcr = 0; + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + const size_t jk = spVec_[jsGlb].jk; + if (jk >= nkStart[myrank_] && jk <= nkEnd[myrank_]) { + colsRecvIndex[colsRecvOrderInverse[jcr]] = jsGlb; + ++jcr; + } + } + eqchSendIndex_.resize(eqchSendSize_); + comm_.allToAllv(colsRecvIndex.data(), colsRecvCounts_.data(), colsRecvDispls_.data(), + eqchSendIndex_.data(), eqchSendCounts_.data(), eqchSendDispls_.data()); + for (size_t jes = 0; jes < eqchSendSize_; ++jes) { + const auto it = std::find(sToSGlb_.begin(), sToSGlb_.end(), eqchSendIndex_[jes]); + ASSERT(it != sToSGlb_.end()); + eqchSendIndex_[jes] = it-sToSGlb_.begin(); + } + + // Effective index + colsRecvIndex_.resize(colsRecvSize_); + for (size_t jcr = 0; jcr < colsRecvSize_; ++jcr) { + colsRecvIndex_[jcr] = (colsRecvDispls_[eqchSendTask[jcr]] + eqchSendOffset[jcr])*nvz_; + } + + // Scale counts and displs for all levels + for (size_t jt = 0; jt < comm_.size(); ++jt) { + gridRecvCounts_[jt] *= nvz_; + gridRecvDispls_[jt] *= nvz_; + rowsSendCounts_[jt] *= nvz_; + rowsSendDispls_[jt] *= nvz_; + rowsRecvCounts_[jt] *= nvz_*2; + rowsRecvDispls_[jt] *= nvz_*2; + colsSendCounts_[jt] *= nvz_*2; + colsSendDispls_[jt] *= nvz_*2; + colsRecvCounts_[jt] *= nvz_; + colsRecvDispls_[jt] *= nvz_; + eqchSendCounts_[jt] *= nvz_; + eqchSendDispls_[jt] *= nvz_; + } + + // Number of component for each local jk,jl couple + colsJq_.resize(nkPerTask_[myrank_]*nl_); + for (size_t jsGlb = 0; jsGlb < nsGlb_; ++jsGlb) { + const size_t jk = spVec_[jsGlb].jk; + if (jk >= nkStart[myrank_] && jk <= nkEnd[myrank_]) { + const size_t jkPerTask = jk-nkStart[myrank_]; + const size_t jl = spVec_[jsGlb].jl; + const size_t jq = spVec_[jsGlb].jq; + colsJq_[jkPerTask*nl_+jl].push_back(jq); + } + } + + // Rows setup + int xRank = 1; + int xN[] = {static_cast(nx_)}; + int xHowmany = nyPerTask_[myrank_]*nvz_; + int *xInembed = NULL; + const int xIstride = 1; + const int xIdist = static_cast(nx_); + int *xOnembed = NULL; + const int xOstride = 1; + const int xOdist = static_cast(nk_); + rowsBufR_ = fftw_alloc_real(xHowmany*nx_); + rowsBufC_ = fftw_alloc_complex(xHowmany*nk_); + rowsPlan_r2c_ = fftw_plan_many_dft_r2c(xRank, xN, xHowmany, rowsBufR_, xInembed, xIstride, + xIdist, rowsBufC_, xOnembed, xOstride, xOdist, FFTW_ESTIMATE); + rowsPlan_c2r_ = fftw_plan_many_dft_c2r(xRank, xN, xHowmany, rowsBufC_, xOnembed, xOstride, + xOdist, rowsBufR_, xInembed, xIstride, xIdist, FFTW_ESTIMATE); + + // Columns setup + int yRank = 1; + int yN[] = {static_cast(ny_)}; + int yHowmany = nkPerTask_[myrank_]*nvz_*2; + int *yInembed = NULL; + const int yIstride = 1; + const int yIdist = static_cast(ny_); + int *yOnembed = NULL; + const int yOstride = 1; + const int yOdist = static_cast(nl_); + colsBufR_ = fftw_alloc_real(yHowmany*ny_); + colsBufC_ = fftw_alloc_complex(yHowmany*nl_); + colsPlan_r2c_ = fftw_plan_many_dft_r2c(yRank, yN, yHowmany, colsBufR_, yInembed, yIstride, + yIdist, colsBufC_, yOnembed, yOstride, yOdist, FFTW_ESTIMATE); + colsPlan_c2r_ = fftw_plan_many_dft_c2r(yRank, yN, yHowmany, colsBufC_, yOnembed, yOstride, + yOdist, colsBufR_, yInembed, yIstride, yIdist, FFTW_ESTIMATE); + + oops::Log::trace() << classname() << "::setupBackend done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +} // namespace bifourier +} // namespace saber diff --git a/src/saber/bifourier/BifourierTransformFFTW.h b/src/saber/bifourier/BifourierTransformFFTW.h new file mode 100644 index 000000000..6b86d3bfb --- /dev/null +++ b/src/saber/bifourier/BifourierTransformFFTW.h @@ -0,0 +1,125 @@ +/* + * (C) Copyright 2025 Meteorologisk Institutt + * + */ + +#pragma once + +#include + +#include +#include + +#include "saber/bifourier/BifourierTransformBase.h" + +namespace saber { +namespace bifourier { + +// ----------------------------------------------------------------------------- + +class BifourierTransformFFTW : public BifourierTransformBase { + public: + static const std::string classname() + {return "saber::bifourier::BifourierTransformFFTW";} + + // Constructor + BifourierTransformFFTW(const oops::GeometryData &, + const std::string &, + const oops::Variables &, + const BifourierTransformParameters &); + + // Destructor + ~BifourierTransformFFTW(); + + // Forward FFT + void gp2sp(std::vector &, + atlas::util::Metadata &) const; + + // Inverse FFT + void sp2gp(std::vector &, + const atlas::util::Metadata &) const; + + // Forward FFT adjoint + void gp2spAdj(std::vector & recvVec, + const atlas::util::Metadata & metadata) const + {sp2gp(recvVec, metadata);} + + // Inverse FFT adjoint + void sp2gpAdj(std::vector & recvVec, + atlas::util::Metadata & metadata) const + {gp2sp(recvVec, metadata);} + + // Forward FFT normalization + double gp2spNorm(const size_t & js) const + {return normFFT_;} + + // Inverse FFT normalization + double sp2gpNorm(const size_t & js) const + {return 1.0;} + + // Forward FFT adjoint normalization + double gp2spAdjNorm(const size_t & js) const + {return normFFT_/spNorm(js);} + + // Inverse FFT adjoint normalization + double sp2gpAdjNorm(const size_t & js) const + {return spNorm(js);} + + // Communication vectors + const size_t & recvSize() const + {return colsRecvSize_;} + const std::vector & recvCounts() const + {return colsRecvCounts_;} + const std::vector & recvDispls() const + {return colsRecvDispls_;} + + private: + // Sizes + std::vector nyPerTask_; + std::vector nkPerTask_; + + // Rows <=> grid + size_t rowsSendSize_; + std::vector rowsSendIndex_; + std::vector rowsSendCounts_; + std::vector rowsSendDispls_; + + // Columns <=> rows + size_t colsSendSize_; + size_t rowsRecvSize_; + std::vector rowsRecvIndex_; + std::vector colsSendIndex_; + std::vector colsSendCounts_; + std::vector colsSendDispls_; + std::vector rowsRecvCounts_; + std::vector rowsRecvDispls_; + + // Equal chunks <=> columns + size_t colsRecvSize_; + std::vector colsRecvIndex_; + std::vector> colsJq_; + std::vector colsRecvCounts_; + std::vector colsRecvDispls_; + + // Rows FFT + fftw_plan rowsPlan_r2c_; + fftw_plan rowsPlan_c2r_; + double *rowsBufR_ = nullptr; + fftw_complex *rowsBufC_ = nullptr; + + // Columns FFT + fftw_plan colsPlan_r2c_; + fftw_plan colsPlan_c2r_; + double *colsBufR_ = nullptr; + fftw_complex *colsBufC_ = nullptr; + + // Private methods + + // Setup backend + void setupBackend(); +}; + +// ----------------------------------------------------------------------------- + +} // namespace bifourier +} // namespace saber diff --git a/src/saber/bifourier/BifourierTransformStore.cc b/src/saber/bifourier/BifourierTransformStore.cc index a4e697419..b84f59ab7 100644 --- a/src/saber/bifourier/BifourierTransformStore.cc +++ b/src/saber/bifourier/BifourierTransformStore.cc @@ -17,11 +17,11 @@ namespace bifourier { // ----------------------------------------------------------------------------- static int stores_in_use = 0; -static std::vector> transformsVector; +static std::vector> transformsVector; // ----------------------------------------------------------------------------- -std::vector> & BifourierTransformStore::transforms() { +std::vector> & BifourierTransformStore::transforms() { return transformsVector; } @@ -42,10 +42,10 @@ BifourierTransformStore::~BifourierTransformStore() { // ----------------------------------------------------------------------------- -std::shared_ptr BifourierTransformStore::setupTransform( +std::shared_ptr BifourierTransformStore::setupTransform( const oops::GeometryData & gdata, const oops::Variables & vars, - const eckit::Configuration & conf) const { + const BifourierTransformParameters & params) const { oops::Log::trace() << classname() << "::setupTransform starting" << std::endl; // Check function space type @@ -66,8 +66,13 @@ std::shared_ptr BifourierTransformStore::setupTransform( } // Create transform - std::shared_ptr transform; - transform.reset(new BifourierTransform(gdata, gridUid, vars, conf)); + std::shared_ptr transform = + BifourierTransformFactory::create(gdata, gridUid, vars, params); + + if (!params.skipTests.value()) { + // Test tranform + transform->test(vars); + } // Insert new transform transforms().push_back(transform); @@ -78,7 +83,7 @@ std::shared_ptr BifourierTransformStore::setupTransform( // ----------------------------------------------------------------------------- -std::shared_ptr BifourierTransformStore::retrieveTransform( +std::shared_ptr BifourierTransformStore::retrieveTransform( const oops::GeometryData & gdata) const { oops::Log::trace() << classname() << "::retrieveTransform starting" << std::endl; diff --git a/src/saber/bifourier/BifourierTransformStore.h b/src/saber/bifourier/BifourierTransformStore.h index 6114a980c..1f8275893 100644 --- a/src/saber/bifourier/BifourierTransformStore.h +++ b/src/saber/bifourier/BifourierTransformStore.h @@ -9,7 +9,7 @@ #include #include -#include "saber/bifourier/BifourierTransform.h" +#include "saber/bifourier/BifourierTransformBase.h" namespace saber { namespace bifourier { @@ -19,7 +19,7 @@ namespace bifourier { class BifourierTransformStore { public: static const std::string classname() - {return "saber::bifourier::BifourierTransform";} + {return "saber::bifourier::BifourierTransformStore";} // Constructor BifourierTransformStore(); @@ -30,16 +30,16 @@ class BifourierTransformStore { // Accessors // Store - static std::vector> & transforms(); + static std::vector> & transforms(); // Return or create spectral transform from a grid-point function space (StructuredColumns) - std::shared_ptr setupTransform( + std::shared_ptr setupTransform( const oops::GeometryData &, const oops::Variables &, - const eckit::Configuration &) const; + const BifourierTransformParameters &) const; // Retrieve an existing spectral transform from a spectral function space (PointCloud) - std::shared_ptr retrieveTransform( + std::shared_ptr retrieveTransform( const oops::GeometryData &) const; }; diff --git a/src/saber/bifourier/BifourierVorDivToRedWind.cc b/src/saber/bifourier/BifourierVorDivToRedWind.cc deleted file mode 100644 index a1a485422..000000000 --- a/src/saber/bifourier/BifourierVorDivToRedWind.cc +++ /dev/null @@ -1,344 +0,0 @@ -/* - * (C) Copyright 2025 Meteorologisk Institutt - * - */ - -#include "saber/bifourier/BifourierVorDivToRedWind.h" - -#include "atlas/field.h" - -using atlas::array::make_view; - -namespace saber { -namespace bifourier { - -// ----------------------------------------------------------------------------- - -static SaberOuterBlockMaker - makerBifourierVorDivToRedWind_("BifourierVorDivToRedWind"); - -// ----------------------------------------------------------------------------- - -BifourierVorDivToRedWind::BifourierVorDivToRedWind(const oops::GeometryData & outerGeometryData, - const oops::Variables & outerVars, - const eckit::Configuration & covarConfig, - const Parameters_ & params, - const oops::FieldSet3D & xb, - const oops::FieldSet3D & fg) - : SaberOuterBlockBase(params, xb.validTime()), - innerGeometryData_(outerGeometryData), - comm_(outerGeometryData.comm()), - innerVars_(outerVars), - params_(params) -{ - oops::Log::trace() << classname() << "::BifourierVorDivToRedWind starting" << std::endl; - - // Inner variables - if (!params.backward.value()) { - // Add vor/div to inner variables and remove u/v - nz_ = innerVars_["reduced_x_wind"].getLevels(); - innerVars_.push_back("air_upward_absolute_vorticity"); - innerVars_["air_upward_absolute_vorticity"].setLevels(nz_); - innerVars_ -= innerVars_["reduced_x_wind"]; - innerVars_.push_back("air_horizontal_divergence"); - innerVars_["air_horizontal_divergence"].setLevels(nz_); - innerVars_ -= innerVars_["reduced_y_wind"]; - } else { - // Add u/v to inner variables and remove vor/div - nz_ = innerVars_["air_upward_absolute_vorticity"].getLevels(); - innerVars_.push_back("reduced_x_wind"); - innerVars_["reduced_x_wind"].setLevels(nz_); - innerVars_ -= innerVars_["air_upward_absolute_vorticity"]; - innerVars_.push_back("reduced_y_wind"); - innerVars_["reduced_y_wind"].setLevels(nz_); - innerVars_ -= innerVars_["air_horizontal_divergence"]; - } - - // Retrieve spectral transform - trans_ = transStore_.retrieveTransform(outerGeometryData); - - // Get grid function space - const atlas::functionspace::StructuredColumns fs(trans_->geometryData().functionSpace()); - - // Get js for (jk, jl) = (0, 0) - jsZero_ = -1; - for (size_t js = 0; js < trans_->ns(); ++js) { - if ((trans_->jk(js) == 0) && (trans_->jl(js) == 0)) { - jsZero_ = js; - } - } - - oops::Log::trace() << classname() << "::BifourierVorDivToRedWind done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorDivToRedWind::multiply(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::multiply starting" << std::endl; - - if (!params_.backward.value()) { - // Forward application - forward(fset); - } else { - // Backward application - backward(fset); - } - - oops::Log::trace() << classname() << "::multiply done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorDivToRedWind::multiplyAD(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; - - if (!params_.backward.value()) { - // Forward application, adjoint - forwardAD(fset); - } else { - // Backward application, adjoint - backwardAD(fset); - } - - oops::Log::trace() << classname() << "::multiplyAD done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorDivToRedWind::leftInverseMultiply(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::leftInverseMultiply starting" << std::endl; - - if (!params_.backward.value()) { - // Backward application - backward(fset); - } else { - // Forward application - forward(fset); - } - - oops::Log::trace() << classname() << "::leftInverseMultiply done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorDivToRedWind::forward(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::forward starting" << std::endl; - - // Get vorticity and divergence fields - auto vorField = fset["air_upward_absolute_vorticity"]; - ASSERT(vorField.shape(0) == static_cast(trans_->ns())); - ASSERT(vorField.shape(1) == static_cast(nz_)); - auto divField = fset["air_horizontal_divergence"]; - ASSERT(divField.shape(0) == static_cast(trans_->ns())); - ASSERT(divField.shape(1) == static_cast(nz_)); - - // Compute stream function and velocity potential - trans_->inverseLaplacian(vorField); - trans_->inverseLaplacian(divField); - - // Compute horizontal derivatives - atlas::Field dPsiDxField; - atlas::Field dPsiDyField; - atlas::Field dKhiDxField; - atlas::Field dKhiDyField; - trans_->derivative(vorField, dPsiDxField, "x"); - trans_->derivative(vorField, dPsiDyField, "y"); - trans_->derivative(divField, dKhiDxField, "x"); - trans_->derivative(divField, dKhiDyField, "y"); - - // Compute u/v - auto vorView = make_view(vorField); - auto divView = make_view(divField); - const auto dPsiDxView = make_view(dPsiDxField); - const auto dPsiDyView = make_view(dPsiDyField); - const auto dKhiDxView = make_view(dKhiDxField); - const auto dKhiDyView = make_view(dKhiDyField); - for (size_t jz = 0; jz < nz_; ++jz) { - for (size_t js = 0; js < trans_->ns(); ++js) { - vorView(js, jz) = dKhiDxView(js, jz) - dPsiDyView(js, jz); - divView(js, jz) = dKhiDyView(js, jz) + dPsiDxView(js, jz); - } - } - - // Reset mean wind profile - if (jsZero_ >= 0) { - if (fset.fieldSet().metadata().has("uMeanProfile") - && fset.fieldSet().metadata().has("vMeanProfile")) { - const std::vector uMeanProfile = - fset.fieldSet().metadata().getDoubleVector("uMeanProfile"); - const std::vector vMeanProfile = - fset.fieldSet().metadata().getDoubleVector("vMeanProfile"); - for (size_t jz = 0; jz < nz_; ++jz) { - vorView(jsZero_, jz) = uMeanProfile[jz]; - divView(jsZero_, jz) = vMeanProfile[jz]; - } - } - } - - // Rename wind fields - fset["air_upward_absolute_vorticity"].rename("reduced_x_wind"); - fset["air_horizontal_divergence"].rename("reduced_y_wind"); - - oops::Log::trace() << classname() << "::forward done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorDivToRedWind::forwardAD(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::forwardAD starting" << std::endl; - - if (!params_.dipoleTest.value()) { - // Get vorticity and divergence fields - auto vorField = fset["reduced_x_wind"]; - ASSERT(vorField.shape(0) == static_cast(trans_->ns())); - ASSERT(vorField.shape(1) == static_cast(nz_)); - auto divField = fset["reduced_y_wind"]; - ASSERT(divField.shape(0) == static_cast(trans_->ns())); - ASSERT(divField.shape(1) == static_cast(nz_)); - auto vorView = make_view(vorField); - auto divView = make_view(divField); - - // Save mean wind profile - if (jsZero_ >= 0) { - std::vector uMeanProfile(nz_, 0.0); - std::vector vMeanProfile(nz_, 0.0); - for (size_t jz = 0; jz < nz_; ++jz) { - uMeanProfile[jz] = vorView(jsZero_, jz); - vMeanProfile[jz] = divView(jsZero_, jz); - } - fset.fieldSet().metadata().set("uMeanProfile", uMeanProfile); - fset.fieldSet().metadata().set("vMeanProfile", vMeanProfile); - } - - // Compute derivatives adjoints - atlas::Field dPsiDxField; - atlas::Field dPsiDyField; - atlas::Field dKhiDxField; - atlas::Field dKhiDyField; - trans_->derivative(divField, dPsiDxField, "x", true); - trans_->derivative(vorField, dPsiDyField, "y", true); - trans_->derivative(vorField, dKhiDxField, "x", true); - trans_->derivative(divField, dKhiDyField, "y", true); - - // Compute vorticity and divergence - const auto dPsiDxView = make_view(dPsiDxField); - const auto dPsiDyView = make_view(dPsiDyField); - const auto dKhiDxView = make_view(dKhiDxField); - const auto dKhiDyView = make_view(dKhiDyField); - for (size_t jz = 0; jz < nz_; ++jz) { - for (size_t js = 0; js < trans_->ns(); ++js) { - vorView(js, jz) = dPsiDxView(js, jz) - dPsiDyView(js, jz); - divView(js, jz) = dKhiDxView(js, jz) + dKhiDyView(js, jz); - } - } - - // Apply inverse Laplacian - trans_->inverseLaplacian(vorField); - trans_->inverseLaplacian(divField); - } - - // Rename wind fields - fset["reduced_x_wind"].rename("air_upward_absolute_vorticity"); - fset["reduced_y_wind"].rename("air_horizontal_divergence"); - - oops::Log::trace() << classname() << "::forwardAD done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorDivToRedWind::backward(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::backward starting" << std::endl; - - // Get vorticity and divergence fields - auto uField = fset["reduced_x_wind"]; - ASSERT(uField.shape(0) == static_cast(trans_->ns())); - ASSERT(uField.shape(1) == static_cast(nz_)); - auto vField = fset["reduced_y_wind"]; - ASSERT(vField.shape(0) == static_cast(trans_->ns())); - ASSERT(vField.shape(1) == static_cast(nz_)); - - // Compute horizontal derivatives - atlas::Field dUDxField; - atlas::Field dUDyField; - atlas::Field dVDxField; - atlas::Field dVDyField; - trans_->derivative(uField, dUDxField, "x"); - trans_->derivative(uField, dUDyField, "y"); - trans_->derivative(vField, dVDxField, "x"); - trans_->derivative(vField, dVDyField, "y"); - - // Compute vor/div - auto uView = make_view(uField); - auto vView = make_view(vField); - const auto dUDxView = make_view(dUDxField); - const auto dUDyView = make_view(dUDyField); - const auto dVDxView = make_view(dVDxField); - const auto dVDyView = make_view(dVDyField); - for (size_t jz = 0; jz < nz_; ++jz) { - for (size_t js = 0; js < trans_->ns(); ++js) { - uView(js, jz) = dVDxView(js, jz) - dUDyView(js, jz); - vView(js, jz) = dUDxView(js, jz) + dVDyView(js, jz); - } - } - - // Rename wind fields - fset["reduced_x_wind"].rename("air_upward_absolute_vorticity"); - fset["reduced_y_wind"].rename("air_horizontal_divergence"); - - oops::Log::trace() << classname() << "::backward done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorDivToRedWind::backwardAD(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::backwardAD starting" << std::endl; - - // Get vorticity and divergence fields - auto uField = fset["air_upward_absolute_vorticity"]; - ASSERT(uField.shape(0) == static_cast(trans_->ns())); - ASSERT(uField.shape(1) == static_cast(nz_)); - auto vField = fset["air_horizontal_divergence"]; - ASSERT(vField.shape(0) == static_cast(trans_->ns())); - ASSERT(vField.shape(1) == static_cast(nz_)); - - // Compute horizontal derivatives - atlas::Field dUDxField; - atlas::Field dUDyField; - atlas::Field dVDxField; - atlas::Field dVDyField; - trans_->derivative(vField, dUDxField, "x", true); - trans_->derivative(uField, dUDyField, "y", true); - trans_->derivative(uField, dVDxField, "x", true); - trans_->derivative(vField, dVDyField, "y", true); - - // Compute vor/div - auto uView = make_view(uField); - auto vView = make_view(vField); - const auto dUDxView = make_view(dUDxField); - const auto dUDyView = make_view(dUDyField); - const auto dVDxView = make_view(dVDxField); - const auto dVDyView = make_view(dVDyField); - for (size_t jz = 0; jz < nz_; ++jz) { - for (size_t js = 0; js < trans_->ns(); ++js) { - uView(js, jz) = dUDxView(js, jz) - dUDyView(js, jz); - vView(js, jz) = dVDxView(js, jz) + dVDyView(js, jz); - } - } - - // Rename wind fields - fset["air_upward_absolute_vorticity"].rename("reduced_x_wind"); - fset["air_horizontal_divergence"].rename("reduced_y_wind"); - - oops::Log::trace() << classname() << "::backwardAD done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorDivToRedWind::print(std::ostream & os) const { - os << classname(); -} - -// ----------------------------------------------------------------------------- - -} // namespace bifourier -} // namespace saber diff --git a/src/saber/bifourier/BifourierVorDivToRedWind.h b/src/saber/bifourier/BifourierVorDivToRedWind.h deleted file mode 100644 index e1f003782..000000000 --- a/src/saber/bifourier/BifourierVorDivToRedWind.h +++ /dev/null @@ -1,117 +0,0 @@ -/* - * (C) Copyright 2025 Meteorologisk Institutt - * - */ - -#pragma once - -#include -#include -#include -#include - -#include "oops/base/GeometryData.h" -#include "oops/base/Variables.h" -#include "oops/util/parameters/Parameters.h" - -#include "saber/bifourier/BifourierTransformStore.h" -#include "saber/blocks/SaberBlockParametersBase.h" -#include "saber/blocks/SaberOuterBlockBase.h" - -namespace saber { -namespace bifourier { - -// ----------------------------------------------------------------------------- - -class BifourierVorDivToRedWindParameters : public SaberBlockParametersBase { - OOPS_CONCRETE_PARAMETERS(BifourierVorDivToRedWindParameters, SaberBlockParametersBase) - - public: - // Backward mode - oops::Parameter backward{"backward mode", false, this}; - - // Dipole test - oops::Parameter dipoleTest{"dipole test", false, this}; - - oops::Variables mandatoryActiveVars() const override {return oops::Variables( - std::vector({ - "air_upward_absolute_vorticity", - "air_horizontal_divergence", - "reduced_x_wind", - "reduced_y_wind"}));} -}; - -// ----------------------------------------------------------------------------- - -class BifourierVorDivToRedWind : public SaberOuterBlockBase { - public: - static const std::string classname() - {return "saber::bifourier::BifourierVorDivToRedWind";} - - typedef BifourierVorDivToRedWindParameters Parameters_; - - BifourierVorDivToRedWind(const oops::GeometryData &, - const oops::Variables &, - const eckit::Configuration &, - const Parameters_ &, - const oops::FieldSet3D &, - const oops::FieldSet3D &); - virtual ~BifourierVorDivToRedWind() = default; - - const oops::GeometryData & innerGeometryData() const override - {return innerGeometryData_;} - const oops::Variables & innerVars() const override - {return innerVars_;} - - void multiply(oops::FieldSet3D &) const override; - void multiplyAD(oops::FieldSet3D &) const override; - void leftInverseMultiply(oops::FieldSet3D &) const override; - - void read() override - {} - - private: - // Inner geometry data - const oops::GeometryData & innerGeometryData_; - - // Communicator - const eckit::mpi::Comm & comm_; - - // Inner variables - oops::Variables innerVars_; - - // Parameters - Parameters_ params_; - - // Spectral transform - const BifourierTransformStore transStore_; - std::shared_ptr trans_; - - // Number of levels - size_t nz_; - - // Index js for (jk, jl) = (0, 0) - int jsZero_; - - // Private methods - - // Forward application - void forward(oops::FieldSet3D &) const; - - // Forward application, adjoint - void forwardAD(oops::FieldSet3D &) const; - - // Backward application - void backward(oops::FieldSet3D &) const; - - // Backward application, adjoint - void backwardAD(oops::FieldSet3D &) const; - - // Print - void print(std::ostream &) const override; -}; - -// ----------------------------------------------------------------------------- - -} // namespace bifourier -} // namespace saber diff --git a/src/saber/bifourier/BifourierVorToPb.cc b/src/saber/bifourier/BifourierVorToPb.cc deleted file mode 100644 index f41debf47..000000000 --- a/src/saber/bifourier/BifourierVorToPb.cc +++ /dev/null @@ -1,360 +0,0 @@ -/* - * (C) Copyright 2025 Meteorologisk Institutt - * - */ - -#include "saber/bifourier/BifourierVorToPb.h" - -#include - -#include - -#include "atlas/field.h" - -#include "saber/bifourier/BifourierAromeLegacy.h" - -#define ERR(e, msg) {std::string s(nc_strerror(e)); \ - throw eckit::Exception(s + " : " + msg, Here());} - -using atlas::array::make_view; - -namespace saber { -namespace bifourier { - -// ----------------------------------------------------------------------------- - -static SaberOuterBlockMaker makerBifourierVorToPb_("BifourierVorToPb"); - -// ----------------------------------------------------------------------------- - -static std::vector fact1Static; - -// ----------------------------------------------------------------------------- - -std::vector & BifourierVorToPb::fact1() { - return fact1Static; -} - -// ----------------------------------------------------------------------------- - -BifourierVorToPb::BifourierVorToPb(const oops::GeometryData & outerGeometryData, - const oops::Variables & outerVars, - const eckit::Configuration & covarConfig, - const Parameters_ & params, - const oops::FieldSet3D & xb, - const oops::FieldSet3D & fg) - : SaberOuterBlockBase(params, xb.validTime()), - innerGeometryData_(outerGeometryData), - comm_(outerGeometryData.comm()), - innerVars_(outerVars), - params_(params) -{ - oops::Log::trace() << classname() << "::BifourierVorToPb starting" << std::endl; - - // Inner variables - if (!params_.backward.value()) { - // Forward mode - innerVars_ -= innerVars_["balanced_air_pressure"]; - } else { - // Backward mode - innerVars_.push_back("balanced_air_pressure"); - innerVars_["balanced_air_pressure"].setLevels( - innerVars_["air_upward_absolute_vorticity"].getLevels()); - } - - // Retrieve spectral transform - trans_ = transStore_.retrieveTransform(outerGeometryData); - - if (params_.read.value() == boost::none && fact1().size() == 0) { - // Allocate fact1 - fact1().resize(trans_->ns()); - - // Get change of variable parameters from configuration or from spectral transform - const auto & nkFromConf = params_.nk.value(); - const size_t nk = (nkFromConf != boost::none) ? *nkFromConf : trans_->nk(); - const auto & nlFromConf = params_.nl.value(); - const size_t nl = (nlFromConf != boost::none) ? *nlFromConf : trans_->nl(); - const auto & meanLatFromConf = params_.meanLat.value(); - const double meanLat = (meanLatFromConf != boost::none) ? *meanLatFromConf : trans_->meanLat(); - - // Compute change of variable factor - const size_t nwGlb = std::max(nk-1, nl-1); - const double zromega = 0.7292115e-4; - const double zcc = -2.0*zromega*std::sin(meanLat*M_PI/180.0); - const double zly = 2.0*static_cast(nwGlb)*trans_->dy(); - const double zfact1 = zcc*(zly/(2.0*M_PI))*(zly/(2.0*M_PI)); - for (size_t js = 0; js < trans_->ns(); ++js) { - const double kstar = trans_->kstar(trans_->jk(js), trans_->jl(js), nk, nl, nwGlb); - if (kstar > 0.0) { - fact1()[js] = zfact1/(kstar*kstar); - } else { - fact1()[js] = 0.0; - } - } - } - - oops::Log::trace() << classname() << "::BifourierVorToPb done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorToPb::multiply(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::multiply starting" << std::endl; - - if (!params_.backward.value()) { - // Get inner field - const auto vorField = fset["air_upward_absolute_vorticity"]; - const size_t nz = vorField.levels(); - - // Create outer field - atlas::Field pbField = trans_->spFspace()->createField( - atlas::option::name("balanced_air_pressure") | atlas::option::levels(nz)); - - // Get fields views - const auto vorView = make_view(vorField); - auto pbView = make_view(pbField); - - // Apply change of variable - for (size_t js = 0; js < trans_->ns(); ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - pbView(js, jz) = vorView(js, jz)*fact1()[js]; - } - } - - // Add outer field - fset.add(pbField); - } else { - // Remove outer field - util::removeFieldsFromFieldSet(fset.fieldSet(), {"balanced_air_pressure"}); - } - - oops::Log::trace() << classname() << "::multiply done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorToPb::multiplyAD(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; - - if (!params_.backward.value()) { - // Get fields - const auto pbField = fset["balanced_air_pressure"]; - auto vorField = fset["air_upward_absolute_vorticity"]; - const size_t nz = vorField.levels(); - - // Get fields views - const auto pbView = make_view(pbField); - auto vorView = make_view(vorField); - - // Apply change of variable, adjoint - for (size_t js = 0; js < trans_->ns(); ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - vorView(js, jz) += pbView(js, jz)*fact1()[js]; - } - } - - // Remove outer field - util::removeFieldsFromFieldSet(fset.fieldSet(), {"balanced_air_pressure"}); - } else { - // Get outer field - const auto vorField = fset["air_upward_absolute_vorticity"]; - const size_t nz = vorField.levels(); - - // Create inner field - atlas::Field pbField = trans_->spFspace()->createField( - atlas::option::name("balanced_air_pressure") | atlas::option::levels(nz)); - - // Get inner field view - auto pbView = make_view(pbField); - - // Set inner field to zero - pbView.assign(0.0); - - // Add outer field - fset.add(pbField); - } - - oops::Log::trace() << classname() << "::multiplyAD done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorToPb::leftInverseMultiply(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::leftInverseMultiply starting" << std::endl; - - if (!params_.backward.value()) { - // Get fields - const auto pbField = fset["balanced_air_pressure"]; - auto vorField = fset["air_upward_absolute_vorticity"]; - const size_t nz = vorField.levels(); - - // Get fields views - const auto pbView = make_view(pbField); - auto vorView = make_view(vorField); - - // Apply change of variable, inverse - for (size_t js = 0; js < trans_->ns(); ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - if (std::abs(fact1()[js]) > 0.0) { - vorView(js, jz) = pbView(js, jz)/fact1()[js]; - } - } - } - - // Remove outer field - util::removeFieldsFromFieldSet(fset.fieldSet(), {"balanced_air_pressure"}); - } else { - // Get inner field - const auto vorField = fset["air_upward_absolute_vorticity"]; - const size_t nz = vorField.levels(); - - // Create outer field - atlas::Field pbField = trans_->spFspace()->createField( - atlas::option::name("balanced_air_pressure") | atlas::option::levels(nz)); - - // Get fields views - const auto vorView = make_view(vorField); - auto pbView = make_view(pbField); - - // Apply change of variable - for (size_t js = 0; js < trans_->ns(); ++js) { - for (size_t jz = 0; jz < nz; ++jz) { - pbView(js, jz) = vorView(js, jz)*fact1()[js]; - } - } - - // Add outer field - fset.add(pbField); - } - - oops::Log::trace() << classname() << "::leftInverseMultiply done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorToPb::read() { - oops::Log::trace() << classname() << "::read starting" << std::endl; - - if (params_.read.value()->inputFile.value() != boost::none) { - // Allocate fact1 - fact1().resize(trans_->ns()); - - // Read data - if (params_.read.value()->inputFileFormat.value() == "arome legacy binary" - || params_.read.value()->inputFileFormat.value() == "arome legacy netcdf") { - // Read fact1 from file - arome_legacy::readVorToPb(comm_, *params_.read.value(), *trans_, fact1()); - } else { - // NetCDF file path - std::string ncFilePath = *params_.read.value()->inputFile.value(); - - // NetCDF IDs - int ncid, retval, nsGlb_id, varid; - size_t nsGlbFromFile; - - // Allocate global vector - std::vector fact1Glb; - if (comm_.rank() == 0) { - fact1Glb.resize(trans_->nsGlb()); - } - - if (comm_.rank() == 0) { - // Open NetCDF file - if ((retval = nc_open(ncFilePath.c_str(), NC_NOWRITE, &ncid))) ERR(retval, ncFilePath); - - // Check dimension - if ((retval = nc_inq_dimid(ncid, "nsGlb", &nsGlb_id))) ERR(retval, "nsGlb"); - if ((retval = nc_inq_dimlen(ncid, nsGlb_id, &nsGlbFromFile))) ERR(retval, "nsGlb"); - ASSERT(nsGlbFromFile == trans_->nsGlb()); - - // Get variable ID - if ((retval = nc_inq_varid(ncid, "fact1", &varid))) ERR(retval, "fact1"); - - // Read data - std::vector fact1GlbOrdered(trans_->nsGlb()); - if ((retval = nc_get_var_double(ncid, varid, fact1GlbOrdered.data()))) ERR(retval, "fact1"); - - // Reorder data - for (size_t jsGlb = 0; jsGlb < trans_->nsGlb(); ++jsGlb) { - fact1Glb[jsGlb] = fact1GlbOrdered[trans_->sMapping()[jsGlb]]; - } - - // Close file - if ((retval = nc_close(ncid))) ERR(retval, ncFilePath); - } - - // Scatter vector - comm_.scatterv(fact1Glb.cbegin(), fact1Glb.cend(), trans_->sCounts(), trans_->sDispls(), - fact1().begin(), fact1().end(), 0); - } - } - - oops::Log::trace() << classname() << "::read done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorToPb::write() const { - oops::Log::trace() << classname() << "::write starting" << std::endl; - - if (params_.outputFile.value() != boost::none) { - // NetCDF IDs - int retval, ncid, nsGlb_id, d1D_id[1], var_id; - - // NetCDF file path - std::string ncFilePath = *params_.outputFile.value(); - - // Allocate global vector - std::vector fact1Glb; - if (comm_.rank() == 0) { - fact1Glb.resize(trans_->nsGlb()); - } - - // Gather data - comm_.gatherv(fact1().cbegin(), fact1().cend(), fact1Glb.begin(), fact1Glb.end(), - trans_->sCounts(), trans_->sDispls(), 0); - - if (comm_.rank() == 0) { - // Create NetCDF file - if ((retval = nc_create(ncFilePath.c_str(), NC_64BIT_OFFSET | NC_CLOBBER, &ncid))) - ERR(retval, ncFilePath); - - // Create dimension - if ((retval = nc_def_dim(ncid, "nsGlb", trans_->nsGlb(), &nsGlb_id))) ERR(retval, "nsGlb"); - - // Dimensions array - d1D_id[0] = nsGlb_id; - - // Define variable - if ((retval = nc_def_var(ncid, "fact1", NC_DOUBLE, 1, d1D_id, &var_id))) ERR(retval, "fact1"); - - // End definition mode - if ((retval = nc_enddef(ncid))) ERR(retval, ncFilePath); - - // Reorder data - std::vector fact1GlbOrdered(trans_->nsGlb()); - for (size_t jsGlb = 0; jsGlb < trans_->nsGlb(); ++jsGlb) { - fact1GlbOrdered[trans_->sMapping()[jsGlb]] = fact1Glb[jsGlb]; - } - - // Write data - if ((retval = nc_put_var_double(ncid, var_id, fact1GlbOrdered.data()))) ERR(retval, "fact1"); - - // Close file - if ((retval = nc_close(ncid))) ERR(retval, ncFilePath); - } - } - - oops::Log::trace() << classname() << "::write done" << std::endl; -} - -// ----------------------------------------------------------------------------- - -void BifourierVorToPb::print(std::ostream & os) const { - os << classname(); -} - -// ----------------------------------------------------------------------------- - -} // namespace bifourier -} // namespace saber diff --git a/src/saber/bifourier/BifourierVorToPb.h b/src/saber/bifourier/BifourierVorToPb.h deleted file mode 100644 index 2eca0b151..000000000 --- a/src/saber/bifourier/BifourierVorToPb.h +++ /dev/null @@ -1,126 +0,0 @@ -/* - * (C) Copyright 2025 Meteorologisk Institutt - * - */ - -#pragma once - -#include -#include -#include -#include - -#include "oops/base/GeometryData.h" -#include "oops/base/Variables.h" -#include "oops/util/parameters/Parameters.h" - -#include "saber/bifourier/BifourierTransformStore.h" -#include "saber/blocks/SaberBlockParametersBase.h" -#include "saber/blocks/SaberOuterBlockBase.h" - -namespace saber { -namespace bifourier { - -// ----------------------------------------------------------------------------- - -class BifourierVorToPbReadParameters : public oops::Parameters { - OOPS_CONCRETE_PARAMETERS(BifourierVorToPbReadParameters, oops::Parameters) - - public: - // Input file - oops::OptionalParameter inputFile{"input file", this}; - - // Input file format ("netcdf", "arome legacy binary" or "arome legacy netcdf") - oops::Parameter inputFileFormat{"input file format", "netcdf", this}; -}; - -// ----------------------------------------------------------------------------- - -class BifourierVorToPbParameters : public SaberBlockParametersBase { - OOPS_CONCRETE_PARAMETERS(BifourierVorToPbParameters, SaberBlockParametersBase) - - public: - // Read parameters - oops::OptionalParameter read{"read", this}; - - // Backward mode - oops::Parameter backward{"backward mode", false, this}; - - // Zonal wavenumbers size - oops::OptionalParameter nk{"zonal wavenumbers size", this}; - - // Meridional wavenumbers size - oops::OptionalParameter nl{"meridional wavenumbers size", this}; - - // Mean latitude - oops::OptionalParameter meanLat{"mean latitude", this}; - - // Output file - oops::OptionalParameter outputFile{"output file", this}; - - oops::Variables mandatoryActiveVars() const override {return oops::Variables( - std::vector({ - "air_upward_absolute_vorticity", - "balanced_air_pressure"}));} -}; - -// ----------------------------------------------------------------------------- - -class BifourierVorToPb : public SaberOuterBlockBase { - public: - static const std::string classname() - {return "saber::bifourier::BifourierVorToPb";} - - typedef BifourierVorToPbParameters Parameters_; - - BifourierVorToPb(const oops::GeometryData &, - const oops::Variables &, - const eckit::Configuration &, - const Parameters_ &, - const oops::FieldSet3D &, - const oops::FieldSet3D &); - virtual ~BifourierVorToPb() = default; - - const oops::GeometryData & innerGeometryData() const override - {return innerGeometryData_;} - const oops::Variables & innerVars() const override - {return innerVars_;} - - void multiply(oops::FieldSet3D &) const override; - void multiplyAD(oops::FieldSet3D &) const override; - void leftInverseMultiply(oops::FieldSet3D &) const override; - - void read() override; - - void write() const override; - - private: - // Inner geometry data - const oops::GeometryData & innerGeometryData_; - - // Communicator - const eckit::mpi::Comm & comm_; - - // Inner variables - oops::Variables innerVars_; - - // Parameters - Parameters_ params_; - - // Spectral transform - const BifourierTransformStore transStore_; - std::shared_ptr trans_; - - // Store - static std::vector & fact1(); - - // Private methods - - // Print - void print(std::ostream &) const override; -}; - -// ----------------------------------------------------------------------------- - -} // namespace bifourier -} // namespace saber diff --git a/src/saber/bifourier/BiperiodizationImpl.cc b/src/saber/bifourier/BiperiodizationImpl.cc index ae8fb20db..5b18c0b3d 100644 --- a/src/saber/bifourier/BiperiodizationImpl.cc +++ b/src/saber/bifourier/BiperiodizationImpl.cc @@ -317,8 +317,7 @@ BiperiodizationImpl::BiperiodizationImpl(const oops::GeometryData & outerGeometr } // RecvCounts - recvCounts_.resize(comm_.size()); - std::fill(recvCounts_.begin(), recvCounts_.end(), 0); + recvCounts_.resize(comm_.size(), 0); for (size_t jjRed = 0; jjRed < recvSize_; ++jjRed) { const size_t jt = redInnerTask[jjRed]; ++recvCounts_[jt]; diff --git a/src/saber/bifourier/CMakeLists.txt b/src/saber/bifourier/CMakeLists.txt index 77b2b63b4..35f747aca 100644 --- a/src/saber/bifourier/CMakeLists.txt +++ b/src/saber/bifourier/CMakeLists.txt @@ -7,18 +7,20 @@ Biperiodization.h Biperiodization.cc BiperiodizationImpl.h BiperiodizationImpl.cc - -# Reduced wind to geographical wind -RedWindToGeoWind.cc -RedWindToGeoWind.h ) -if( FFTW_FOUND ) +if( FFTW_FOUND OR ( ECTRANS_FOUND AND ectrans_HAVE_ETRANS AND ectrans_HAVE_TRANSI ) ) list(APPEND bifourier_src_files_list + # Bi-Fourier AROME balance block + BifourierAromeBalance.cc + BifourierAromeBalance.h + + # Bi-Fourier AROME covariance block + BifourierAromeCovariance.cc + BifourierAromeCovariance.h + # Bi-Fourier AROME legacy file format reading bifourier_arome_legacy.h - BifourierAromeLegacy.cc - BifourierAromeLegacy.h bifourier_arome_legacy_interface.F90 bifourier_arome_legacy_mod.F90 @@ -42,13 +44,13 @@ if( FFTW_FOUND ) BifourierSpectralToGrid.cc BifourierSpectralToGrid.h - # Bi-Fourier temperature/surface pressure split block - BifourierSplitTPs.cc - BifourierSplitTPs.h + # Bi-Fourier spectral vorticity/divergence to grid wind + BifourierSpectralVorDivToGridWind.cc + BifourierSpectralVorDivToGridWind.h - # Bi-Fourier spectral transform object - BifourierTransform.cc - BifourierTransform.h + # Bi-Fourier spectral transform object, base class + BifourierTransformBase.cc + BifourierTransformBase.h # Bi-Fourier spectral transforms store BifourierTransformStore.cc @@ -57,14 +59,25 @@ if( FFTW_FOUND ) # Bi-Fourier utilities BifourierUtilities.cc BifourierUtilities.h + ) +endif() - # Bi-Fourier vorticity/divergence to reduced wind - BifourierVorDivToRedWind.cc - BifourierVorDivToRedWind.h - - # Bi-Fourier vorticity to balance pressure - BifourierVorToPb.cc - BifourierVorToPb.h +# Add FFT backends +message(STATUS "Available FFT backends in BifourierTransform:") +if( FFTW_FOUND ) + # FFTW backend + message(STATUS "- fftw") + list(APPEND bifourier_src_files_list + BifourierTransformFFTW.cc + BifourierTransformFFTW.h + ) +endif() +if( ECTRANS_FOUND AND ectrans_HAVE_ETRANS AND ectrans_HAVE_TRANSI ) + # ECTRANS backend + message(STATUS "- ectrans") + list(APPEND bifourier_src_files_list + BifourierTransformECTRANS.cc + BifourierTransformECTRANS.h ) endif() diff --git a/src/saber/bifourier/RedWindToGeoWind.h b/src/saber/bifourier/RedWindToGeoWind.h deleted file mode 100644 index 20d504dce..000000000 --- a/src/saber/bifourier/RedWindToGeoWind.h +++ /dev/null @@ -1,108 +0,0 @@ -/* - * (C) Copyright 2025 Meteorologisk Institutt - * - */ - -#pragma once - -#include -#include -#include -#include - -#include "oops/base/GeometryData.h" -#include "oops/base/Variables.h" -#include "oops/util/parameters/Parameters.h" - -#include "saber/bifourier/BiperiodizationImpl.h" -#include "saber/blocks/SaberBlockParametersBase.h" -#include "saber/blocks/SaberOuterBlockBase.h" - -namespace saber { -namespace bifourier { - -// ----------------------------------------------------------------------------- - -class RedWindToGeoWindParameters : public SaberBlockParametersBase { - OOPS_CONCRETE_PARAMETERS(RedWindToGeoWindParameters, SaberBlockParametersBase) - - public: - // Biperiodization parameters - oops::OptionalParameter biperParams{"biperiodization", - this}; - - // Outer spherical winds - oops::Parameter outerSphericalWinds{"outer spherical winds", false, this}; - - // Output file - oops::OptionalParameter outputFile{"output file", this}; - - oops::Variables mandatoryActiveVars() const override { - oops::Variables mandatoryActiveVars; - mandatoryActiveVars.push_back("reduced_x_wind"); - mandatoryActiveVars.push_back("reduced_y_wind"); - if (outerSphericalWinds) { - mandatoryActiveVars.push_back("eastward_wind"); - mandatoryActiveVars.push_back("northward_wind"); - } else { - mandatoryActiveVars.push_back("geographical_x_wind"); - mandatoryActiveVars.push_back("geographical_y_wind"); - } - return mandatoryActiveVars; - } -}; - -// ----------------------------------------------------------------------------- - -class RedWindToGeoWind : public SaberOuterBlockBase { - public: - static const std::string classname() - {return "saber::bifourier::RedWindToGeoWind";} - - typedef RedWindToGeoWindParameters Parameters_; - - RedWindToGeoWind(const oops::GeometryData &, - const oops::Variables &, - const eckit::Configuration &, - const Parameters_ &, - const oops::FieldSet3D &, - const oops::FieldSet3D &); - virtual ~RedWindToGeoWind() = default; - - const oops::GeometryData & innerGeometryData() const override - {return innerGeometryData_;} - const oops::Variables & innerVars() const override - {return innerVars_;} - - void multiply(oops::FieldSet3D &) const override; - void multiplyAD(oops::FieldSet3D &) const override; - void leftInverseMultiply(oops::FieldSet3D &) const override; - - std::vector> fieldsToWrite() const; - - private: - // Inner geometry data - const oops::GeometryData & innerGeometryData_; - - // Communicator - const eckit::mpi::Comm & comm_; - - // Inner variables - oops::Variables innerVars_; - - // Parameters - Parameters_ params_; - - // Map factor and Jacobian coefficients FieldSet - oops::FieldSet3D data_; - - // Private methods - - // Print - void print(std::ostream &) const override; -}; - -// ----------------------------------------------------------------------------- - -} // namespace bifourier -} // namespace saber diff --git a/src/saber/bifourier/bifourier_arome_legacy.h b/src/saber/bifourier/bifourier_arome_legacy.h index 0c5c3eca3..71e51c021 100644 --- a/src/saber/bifourier/bifourier_arome_legacy.h +++ b/src/saber/bifourier/bifourier_arome_legacy.h @@ -5,10 +5,7 @@ #pragma once -#include "atlas/field.h" - #include "eckit/config/Configuration.h" -#include "eckit/mpi/Comm.h" namespace saber { namespace bifourier { @@ -16,27 +13,45 @@ namespace bifourier { // ----------------------------------------------------------------------------- extern "C" { - void bifourier_arome_legacy_vortopb_f90(const eckit::Configuration &, - const int &, - double[]); - - void bifourier_arome_legacy_balance_f90(const eckit::Configuration &, - const int &, - const int &, - double[], - double[], - double[], - double[], - double[], - double[]); - - void bifourier_arome_legacy_covariance_f90(const eckit::Configuration &, - const int &, - const int &, - double[], - double[], - double[], - double[]); + void bifourier_arome_legacy_read_balance_f90(const eckit::Configuration &, + const int &, + const int &, + double[], + double[], + double[], + double[], + double[], + double[], + const int &, + double[]); + + void bifourier_arome_legacy_write_balance_f90(const eckit::Configuration &, + const int &, + const int &, + double[], + double[], + double[], + double[], + double[], + double[], + const int &, + double[]); + + void bifourier_arome_legacy_read_covariance_f90(const eckit::Configuration &, + const int &, + const int &, + double[], + double[], + double[], + double[]); + + void bifourier_arome_legacy_write_covariance_f90(const eckit::Configuration &, + const int &, + const int &, + double[], + double[], + double[], + double[]); } // ----------------------------------------------------------------------------- diff --git a/src/saber/bifourier/bifourier_arome_legacy_interface.F90 b/src/saber/bifourier/bifourier_arome_legacy_interface.F90 index 7c6022c02..ae4f93778 100644 --- a/src/saber/bifourier/bifourier_arome_legacy_interface.F90 +++ b/src/saber/bifourier/bifourier_arome_legacy_interface.F90 @@ -8,8 +8,8 @@ module bifourier_arome_legacy_interface use fckit_configuration_module, only: fckit_configuration use iso_c_binding, only: c_ptr, c_int, c_double -use bifourier_arome_legacy_mod, only: bifourier_arome_legacy_vortopb, bifourier_arome_legacy_balance, & - & bifourier_arome_legacy_covariance +use bifourier_arome_legacy_mod, only: bifourier_arome_legacy_read_balance, bifourier_arome_legacy_write_balance, & + & bifourier_arome_legacy_read_covariance, bifourier_arome_legacy_write_covariance implicit none @@ -19,12 +19,21 @@ module bifourier_arome_legacy_interface !---------------------------------------------------------------------- -subroutine bifourier_arome_legacy_vortopb_c(c_conf,nial,fact1) & - & bind(c,name='bifourier_arome_legacy_vortopb_f90') +subroutine bifourier_arome_legacy_read_balance_c(c_conf,nwglb,nflev,sdivpb,stpspb,stpsdivu,sqpb,sqdivu,sqtpsu,nial,fact1) & + & bind(c,name='bifourier_arome_legacy_read_balance_f90') + implicit none ! Passed variables type(c_ptr),intent(in),value :: c_conf +integer(c_int),intent(in) :: nwglb +integer(c_int),intent(in) :: nflev +real(c_double),intent(inout) :: sdivpb(nwglb*nflev*nflev) +real(c_double),intent(inout) :: stpspb(nwglb*nflev*(nflev+1)) +real(c_double),intent(inout) :: stpsdivu(nwglb*nflev*(nflev+1)) +real(c_double),intent(inout) :: sqpb(nwglb*nflev*nflev) +real(c_double),intent(inout) :: sqdivu(nwglb*nflev*nflev) +real(c_double),intent(inout) :: sqtpsu(nwglb*(nflev+1)*nflev) integer(c_int),intent(in) :: nial real(c_double),intent(inout) :: fact1(nial) @@ -35,29 +44,32 @@ subroutine bifourier_arome_legacy_vortopb_c(c_conf,nial,fact1) & f_conf = fckit_configuration(c_conf) ! Call Fortran -call bifourier_arome_legacy_vortopb(f_conf,nial,fact1) +call bifourier_arome_legacy_read_balance(f_conf,nwglb,nflev,sdivpb,stpspb,stpsdivu,sqpb,sqdivu,sqtpsu,nial,fact1) ! Release memory call f_conf%final() -end subroutine bifourier_arome_legacy_vortopb_c +end subroutine bifourier_arome_legacy_read_balance_c !---------------------------------------------------------------------- -subroutine bifourier_arome_legacy_balance_c(c_conf,nwglb,nflev,sdivpb,stpspb,stpsdivu,sqpb,sqdivu,sqtpsu) & - & bind(c,name='bifourier_arome_legacy_balance_f90') +subroutine bifourier_arome_legacy_write_balance_c(c_conf,nwglb,nflev,sdivpb,stpspb,stpsdivu,sqpb,sqdivu,sqtpsu,nial,fact1) & + & bind(c,name='bifourier_arome_legacy_write_balance_f90') + implicit none ! Passed variables type(c_ptr),intent(in),value :: c_conf integer(c_int),intent(in) :: nwglb integer(c_int),intent(in) :: nflev -real(c_double),intent(inout) :: sdivpb(nwglb*nflev*nflev) -real(c_double),intent(inout) :: stpspb(nwglb*nflev*(nflev+1)) -real(c_double),intent(inout) :: stpsdivu(nwglb*nflev*(nflev+1)) -real(c_double),intent(inout) :: sqpb(nwglb*nflev*nflev) -real(c_double),intent(inout) :: sqdivu(nwglb*nflev*nflev) -real(c_double),intent(inout) :: sqtpsu(nwglb*(nflev+1)*nflev) +real(c_double),intent(in) :: sdivpb(nwglb*nflev*nflev) +real(c_double),intent(in) :: stpspb(nwglb*nflev*(nflev+1)) +real(c_double),intent(in) :: stpsdivu(nwglb*nflev*(nflev+1)) +real(c_double),intent(in) :: sqpb(nwglb*nflev*nflev) +real(c_double),intent(in) :: sqdivu(nwglb*nflev*nflev) +real(c_double),intent(in) :: sqtpsu(nwglb*(nflev+1)*nflev) +integer(c_int),intent(in) :: nial +real(c_double),intent(in) :: fact1(nial) ! Local variables type(fckit_configuration) :: f_conf @@ -66,17 +78,17 @@ subroutine bifourier_arome_legacy_balance_c(c_conf,nwglb,nflev,sdivpb,stpspb,stp f_conf = fckit_configuration(c_conf) ! Call Fortran -call bifourier_arome_legacy_balance(f_conf,nwglb,nflev,sdivpb,stpspb,stpsdivu,sqpb,sqdivu,sqtpsu) +call bifourier_arome_legacy_write_balance(f_conf,nwglb,nflev,sdivpb,stpspb,stpsdivu,sqpb,sqdivu,sqtpsu,nial,fact1) ! Release memory call f_conf%final() -end subroutine bifourier_arome_legacy_balance_c +end subroutine bifourier_arome_legacy_write_balance_c !---------------------------------------------------------------------- -subroutine bifourier_arome_legacy_covariance_c(c_conf,nwglb,nflev,vorcov,divucov,tpsucov,qucov) & - & bind(c,name='bifourier_arome_legacy_covariance_f90') +subroutine bifourier_arome_legacy_read_covariance_c(c_conf,nwglb,nflev,vorcov,divucov,tpsucov,qucov) & + & bind(c,name='bifourier_arome_legacy_read_covariance_f90') implicit none @@ -96,12 +108,43 @@ subroutine bifourier_arome_legacy_covariance_c(c_conf,nwglb,nflev,vorcov,divucov f_conf = fckit_configuration(c_conf) ! Call Fortran -call bifourier_arome_legacy_covariance(f_conf,nwglb,nflev,vorcov,divucov,tpsucov,qucov) +call bifourier_arome_legacy_read_covariance(f_conf,nwglb,nflev,vorcov,divucov,tpsucov,qucov) + +! Release memory +call f_conf%final() + +end subroutine bifourier_arome_legacy_read_covariance_c + + +!---------------------------------------------------------------------- + +subroutine bifourier_arome_legacy_write_covariance_c(c_conf,nwglb,nflev,vorcov,divucov,tpsucov,qucov) & + & bind(c,name='bifourier_arome_legacy_write_covariance_f90') + +implicit none + +! Passed variables +type(c_ptr),intent(in),value :: c_conf +integer(c_int),intent(in) :: nwglb +integer(c_int),intent(in) :: nflev +real(c_double),intent(in) :: vorcov(nwglb*nflev*nflev) +real(c_double),intent(in) :: divucov(nwglb*nflev*nflev) +real(c_double),intent(in) :: tpsucov(nwglb*(nflev+1)*(nflev+1)) +real(c_double),intent(in) :: qucov(nwglb*nflev*nflev) + +! Local variables +type(fckit_configuration) :: f_conf + +! Interface +f_conf = fckit_configuration(c_conf) + +! Call Fortran +call bifourier_arome_legacy_write_covariance(f_conf,nwglb,nflev,vorcov,divucov,tpsucov,qucov) ! Release memory call f_conf%final() -end subroutine bifourier_arome_legacy_covariance_c +end subroutine bifourier_arome_legacy_write_covariance_c !---------------------------------------------------------------------- diff --git a/src/saber/bifourier/bifourier_arome_legacy_mod.F90 b/src/saber/bifourier/bifourier_arome_legacy_mod.F90 index 8035ae917..e04456a45 100644 --- a/src/saber/bifourier/bifourier_arome_legacy_mod.F90 +++ b/src/saber/bifourier/bifourier_arome_legacy_mod.F90 @@ -2,7 +2,7 @@ ! Module: bifourier_arome_legacy_mod !> Bifourier AROME legacy Fortran module ! Author: Benjamin Menetrier -! Source: readjbbal.F90 and readjbdat96.F90 +! Source: readjbbal.F90, ewgsabal.F90, readjbdat96.F90 and ewgsacov.F90 ! Copyright 2025 Meteorologisk Institutt !---------------------------------------------------------------------- module bifourier_arome_legacy_mod @@ -12,91 +12,17 @@ module bifourier_arome_legacy_mod implicit none +integer(kind_int),parameter :: ichkwd = 3141592 + private -public :: bifourier_arome_legacy_vortopb,bifourier_arome_legacy_balance,bifourier_arome_legacy_covariance +public :: bifourier_arome_legacy_read_balance, bifourier_arome_legacy_write_balance, & + & bifourier_arome_legacy_read_covariance, bifourier_arome_legacy_write_covariance contains !---------------------------------------------------------------------- -subroutine bifourier_arome_legacy_vortopb(conf,nial,fact1) - -implicit none - -! Passed variables -type(fckit_configuration),intent(in) :: conf -integer(kind_int),intent(in) :: nial -real(kind_real),intent(inout) :: fact1(nial) - -! Local variables -integer(kind_int),parameter :: iultmp = 10 -integer(kind_int) :: ichkwd,idate,idim1,idim2,ilendef,inbmat,inbset,iorig,ipar1,ipar2,isetdist,itime,itypdi1,itypdi2, & - & itypmat,iweight,jj,jk,jn,idgl,idgux,idlon,idlux,ksmax,kmsmax,kflevg -real(kind_real) :: zlat0,zlat1,zlat2,zlon0,zlon1,zlon2 -character(len=10) :: clid -character(len=70) :: clcom -character(len=1024) :: cdfile -character(len=:),allocatable :: str - -! Get filename from configuration -call conf%get_or_die("input file",str) -cdfile = str - -! Open file -open(iultmp,file=cdfile,form='unformatted',convert='big_endian') - -! Read and check clid -read(iultmp) clid -write(*,'(a,a)') 'Info : - GSA ID: ',clid -if (clid/='ALADIN98') call abor1_ftn('bad id in gsa file') - -! Read description -read(iultmp) clcom -write(*,'(a,a)') 'Info : - Description : ',clcom - -! Read center and date -read(iultmp) iorig,idate,itime,inbset -write(*,'(a,i3)') 'Info : - Center: ',iorig -write(*,'(a,i8,a,i6)') 'Info : - Date/time: ',idate,' / ',itime - -! Read gsa set 0: model geometry definition -write(*,'(a)') 'Info : - Reading gsa set 0: model geometry definition' -read(iultmp) inbmat,iweight,itypmat,isetdist,ilendef -read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 -read(iultmp) -read(iultmp) -if (itypmat/=0) call abor1_ftn('no model geometry description') -if ((idim1/=1).or.(idim2/=13).or.(ipar1/=50).or.(ipar2/=0).or.(itypdi1/=0).or.(itypdi2/=0)) & - & call abor1_ftn('nonexpected parameters for model geometry description') -read(iultmp) zlon1,zlat1,zlon2,zlat2,zlon0,zlat0,idgl,idlon,idgux,idlux,ksmax,kmsmax,kflevg,ichkwd -if (ichkwd/=3141592) call abor1_ftn('bad gsa control word') -write(*,'(a,f12.8,a,f12.8)') 'Info : - File geometry : zlat1 =',zlat1,' / zlat2 =',zlat2 -write(*,'(a,i5,a,i5)') 'Info : ksmax =',ksmax,' / kmsmax =',kmsmax - -! Read gsa set 1: header -write(*,'(a)') 'Info : - Reading gsa set 1: fact1' -read(iultmp) inbmat,iweight,itypmat,isetdist,ilendef -read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 -read(iultmp) -read(iultmp) -read(iultmp) -if (itypmat/=4) call abor1_ftn('no horizontal balance in gsa set 1') - -! Check size -if (idim2 /= nial) call abor1_ftn('inconsistent number of wavenumbers in fact1 file') - -! Read gsa set 1: fact1 -read(iultmp) (fact1(jj),jj=1,idim2),ichkwd -if (ichkwd/=3141592) call abor1_ftn('bad gsa control word') - -! Close file -close(iultmp) - -end subroutine bifourier_arome_legacy_vortopb - -!---------------------------------------------------------------------- - -subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdivu,sqpb,sqdivu,sqtpsu) +subroutine bifourier_arome_legacy_read_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdivu,sqpb,sqdivu,sqtpsu,nial,fact1) implicit none @@ -110,13 +36,14 @@ subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdiv real(kind_real),intent(inout) :: sqpb(nwglb*nflev*nflev) real(kind_real),intent(inout) :: sqdivu(nwglb*nflev*nflev) real(kind_real),intent(inout) :: sqtpsu(nwglb*(nflev+1)*nflev) +integer(kind_int),intent(in) :: nial +real(kind_real),intent(inout) :: fact1(nial) ! Local variables integer(kind_int),parameter :: iultmp = 10 -integer(kind_int) :: ichkwd,idate,idim1,idim2,ilendef,inbmat,inbset,iorig,ipar1,ipar2,isetdist,itime,itypdi1,itypdi2, & +integer(kind_int) :: itestwd,idate,idim1,idim2,ilendef,inbmat,inbset,iorig,ipar1,ipar2,isetdist,itime,itypdi1,itypdi2, & & itypmat,iweight,jj,jk,jn,idgl,idgux,idlon,idlux,ksmax,kmsmax,kflevg real(kind_real) :: zlat0,zlat1,zlat2,zlon0,zlon1,zlon2 -real(kind_real),allocatable :: fact1(:) character(len=10) :: clid character(len=70) :: clcom character(len=1024) :: cdfile @@ -132,7 +59,7 @@ subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdiv ! Read and check clid read(iultmp) clid write(*,'(a,a)') 'Info : - GSA ID: ',clid -if (clid/='ALADIN98') call abor1_ftn('bad id in gsa file') +if (clid /= 'ALADIN98') call abor1_ftn('bad id in gsa file') ! Read description read(iultmp) clcom @@ -149,11 +76,11 @@ subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdiv read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -if (itypmat/=0) call abor1_ftn('no model geometry description') -if ((idim1/=1).or.(idim2/=13).or.(ipar1/=50).or.(ipar2/=0).or.(itypdi1/=0).or.(itypdi2/=0)) & +if (itypmat /= 0) call abor1_ftn('no model geometry description') +if ((idim1 /= 1).or.(idim2 /= 13).or.(ipar1 /= 50).or.(ipar2 /= 0).or.(itypdi1 /= 0).or.(itypdi2 /= 0)) & & call abor1_ftn('nonexpected parameters for model geometry description') -read(iultmp) zlon1,zlat1,zlon2,zlat2,zlon0,zlat0,idgl,idlon,idgux,idlux,ksmax,kmsmax,kflevg,ichkwd -if (ichkwd/=3141592) call abor1_ftn('bad gsa control word') +read(iultmp) zlon1,zlat1,zlon2,zlat2,zlon0,zlat0,idgl,idlon,idgux,idlux,ksmax,kmsmax,kflevg,itestwd +if (itestwd /= ichkwd) call abor1_ftn('bad gsa control word') write(*,'(a,i5,a,i3)') 'Info : - File geometry : nsmax =',ksmax,' / nflev =',kflevg ! Read gsa set 1: header @@ -162,18 +89,15 @@ subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdiv read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -read(iultmp) -if (itypmat/=4) call abor1_ftn('no horizontal balance in gsa set 1') +if (itypmat /= 4) call abor1_ftn('no horizontal balance in gsa set 1') -! Allocation -allocate(fact1(idim2)) +! Check size +if (idim2 /= nial) call abor1_ftn('inconsistent number of wavenumbers in fact1 file') ! Read gsa set 1: fact1 -read(iultmp) (fact1(jj),jj=1,idim2),ichkwd -if (ichkwd/=3141592) call abor1_ftn('bad gsa control word') - -! Release memory -deallocate(fact1) +read(iultmp) +read(iultmp) (fact1(jj),jj=1,idim2),itestwd +if (itestwd /= ichkwd) call abor1_ftn('bad gsa control word') ! Read gsa set 2: header write(*,'(a)') 'Info : - Reading gsa set 2: sdivpb' @@ -181,9 +105,9 @@ subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdiv read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -if (itypmat/=5) call abor1_ftn('not vert balance in gsa set 2') -if ((idim1/=kflevg).or.(idim2/=kflevg)) call abor1_ftn('bad vertical resolution in gsa set 2') -if ((ipar1/=11).or.(ipar2/=15)) call abor1_ftn('not pb->divb operator in gsa set 2') +if (itypmat /= 5) call abor1_ftn('not vert balance in gsa set 2') +if ((idim1 /= kflevg).or.(idim2/=kflevg)) call abor1_ftn('bad vertical resolution in gsa set 2') +if ((ipar1 /= 11).or.(ipar2 /= 15)) call abor1_ftn('not pb->divb operator in gsa set 2') ! Check sizes if (kflevg /= nflev) call abor1_ftn('inconsistent number of levels in balance file') @@ -192,8 +116,8 @@ subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdiv ! Read gsa set 2: sdivpb do jn=1,ksmax+1 read(iultmp) - read(iultmp) ((sdivpb((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg),jj=1,kflevg),ichkwd - if (ichkwd /= 3141592) call abor1_ftn('bad gsa control word') + read(iultmp) ((sdivpb((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg),jj=1,kflevg),itestwd + if (itestwd /= ichkwd) call abor1_ftn('bad gsa control word') end do ! Read gsa set 3: header @@ -202,13 +126,13 @@ subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdiv read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -if ((ipar1/=13).or.(ipar2/=15)) call abor1_ftn('no pb->tpsb operator in gsa set 3') +if ((ipar1 /= 13).or.(ipar2 /= 15)) call abor1_ftn('no pb->tpsb operator in gsa set 3') ! Read gsa set 3: stpspb do jn=1,ksmax+1 read(iultmp) - read(iultmp) ((stpspb((jn-1)*kflevg*(kflevg+1)+(jk-1)*(kflevg+1)+jj),jk=1,kflevg),jj=1,kflevg+1),ichkwd - if(ichkwd/=3141592) call abor1_ftn('bad gsa control word') + read(iultmp) ((stpspb((jn-1)*kflevg*(kflevg+1)+(jk-1)*(kflevg+1)+jj),jk=1,kflevg),jj=1,kflevg+1),itestwd + if(itestwd /= ichkwd) call abor1_ftn('bad gsa control word') end do ! Read gsa set 4: header @@ -217,13 +141,13 @@ subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdiv read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -if ((ipar1/=13).or.(ipar2/=12)) call abor1_ftn('not divu->tpsb operator in gsa set 4') +if ((ipar1 /= 13).or.(ipar2 /= 12)) call abor1_ftn('not divu->tpsb operator in gsa set 4') ! Read gsa set 4: stpsdivu do jn=1,ksmax+1 read(iultmp) - read(iultmp) ((stpsdivu((jn-1)*kflevg*(kflevg+1)+(jk-1)*(kflevg+1)+jj),jk=1,kflevg),jj=1,kflevg+1),ichkwd - if(ichkwd /= 3141592) call abor1_ftn('bad gsa control word') + read(iultmp) ((stpsdivu((jn-1)*kflevg*(kflevg+1)+(jk-1)*(kflevg+1)+jj),jk=1,kflevg),jj=1,kflevg+1),itestwd + if(itestwd /= ichkwd) call abor1_ftn('bad gsa control word') end do ! Read gsa set 5: header @@ -232,13 +156,13 @@ subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdiv read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -if ((ipar1/=16).or.(ipar2/=15)) call abor1_ftn('no pb->qb operator in gsa set 5') +if ((ipar1 /= 16).or.(ipar2 /= 15)) call abor1_ftn('no pb->qb operator in gsa set 5') ! Read gsa set 5: sqpb do jn=1,ksmax+1 read(iultmp) - read(iultmp) ((sqpb((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg),jj=1,kflevg),ichkwd - if (ichkwd/=3141592) call abor1_ftn('bad gsa control word') + read(iultmp) ((sqpb((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg),jj=1,kflevg),itestwd + if (itestwd /= ichkwd) call abor1_ftn('bad gsa control word') end do ! Read gsa set 6: header @@ -247,13 +171,13 @@ subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdiv read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -if ((ipar1/=16).or.(ipar2/=12)) call abor1_ftn('no divu->qb operator in gsa set 6') +if ((ipar1 /= 16).or.(ipar2 /= 12)) call abor1_ftn('no divu->qb operator in gsa set 6') ! Read gsa set 6: sqdivu do jn=1,ksmax+1 read(iultmp) - read(iultmp) ((sqdivu((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg),jj=1,kflevg),ichkwd - if (ichkwd/=3141592) call abor1_ftn('bad gsa control word') + read(iultmp) ((sqdivu((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg),jj=1,kflevg),itestwd + if (itestwd /= ichkwd) call abor1_ftn('bad gsa control word') end do ! Read gsa set 7: header @@ -262,23 +186,200 @@ subroutine bifourier_arome_legacy_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdiv read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -if ((ipar1/=16).or.(ipar2/=14)) call abor1_ftn('no tpsu->qb operator in gsa set 7') +if ((ipar1 /= 16).or.(ipar2 /= 14)) call abor1_ftn('no tpsu->qb operator in gsa set 7') ! Read gsa set 7: sqtpsu do jn=1,ksmax+1 read(iultmp) - read(iultmp) ((sqtpsu((jn-1)*(kflevg+1)*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg+1),jj=1,kflevg),ichkwd - if(ichkwd /= 3141592) call abor1_ftn('bad gsa control word') + read(iultmp) ((sqtpsu((jn-1)*(kflevg+1)*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg+1),jj=1,kflevg),itestwd + if(itestwd /= ichkwd) call abor1_ftn('bad gsa control word') end do ! Close file close(iultmp) -end subroutine bifourier_arome_legacy_balance +end subroutine bifourier_arome_legacy_read_balance !---------------------------------------------------------------------- -subroutine bifourier_arome_legacy_covariance(conf,nwglb,nflev,vorcov,divucov,tpsucov,qucov) +subroutine bifourier_arome_legacy_write_balance(conf,nwglb,nflev,sdivpb,stpspb,stpsdivu,sqpb,sqdivu,sqtpsu,nial,fact1) + +implicit none + +! Passed variables +type(fckit_configuration),intent(in) :: conf +integer(kind_int),intent(in) :: nwglb +integer(kind_int),intent(in) :: nflev +real(kind_real),intent(in) :: sdivpb(nwglb*nflev*nflev) +real(kind_real),intent(in) :: stpspb(nwglb*nflev*(nflev+1)) +real(kind_real),intent(in) :: stpsdivu(nwglb*nflev*(nflev+1)) +real(kind_real),intent(in) :: sqpb(nwglb*nflev*nflev) +real(kind_real),intent(in) :: sqdivu(nwglb*nflev*nflev) +real(kind_real),intent(in) :: sqtpsu(nwglb*(nflev+1)*nflev) +integer(kind_int),intent(in) :: nial +real(kind_real),intent(in) :: fact1(nial) + +! Local variables +integer(kind_int),parameter :: iultmp = 10 +integer(kind_int) :: idate,itime,iweight,jj,jk,jn,idgl,idgux,idlon,idlux,ksmax,kmsmax,kflevg,kspec2g +real(kind_real) :: zlat0,zlat1,zlat2,zlon0,zlon1,zlon2 +real(kind_real) :: zpres(nflev+1) +character(len=10) :: clid +character(len=70) :: clcom +character(len=1024) :: cdfile +character(len=:),allocatable :: str + +! Prepare zpres +do jj=1,nflev+1 + zpres(jj) = real(jj,kind=kind_real) +end do + +! Get filename from configuration +call conf%get_or_die("output file",str) +cdfile = str + +! Set relevant parameters +ksmax = nwglb-1 +kflevg = nflev +kspec2g = nial + +! Set dummy parameters +idate = 0 +itime = 0 +iweight = 0 +zlon1 = 0.0 +zlon2 = 0.0 +zlat1 = 0.0 +zlat2 = 0.0 +zlon0 = 0.0 +zlat0 = 0.0 +idgl = 0 +idlon = 0 +idgux = 0 +idlux = 0 +kmsmax = 0 + +! Open file +open(iultmp,file=cdfile,form='unformatted',convert='big_endian') + +! Write clid +clid = 'ALADIN98' +write(iultmp) clid + +! Write description +clcom = ' Balanced statistcs for a LAM, after L. Berre 1998' +write(iultmp) clcom + + +! Write center and date +write(iultmp) 85,idate,itime,8 + +! Write gsa set 0: model geometry definition +write(*,'(a)') 'Info : - Writing gsa set 0: model geometry definition' +write(iultmp) 1,iweight,0,1,0 +write(iultmp) 1,13,50,0,0,0 +write(iultmp) +write(iultmp) +write(iultmp) zlon1,zlat1,zlon2,zlat2,zlon0,zlat0,idgl,idlon,idgux,idlux,ksmax,kmsmax,kflevg,ichkwd + +! Write gsa set 1: header +write(*,'(a)') 'Info : - Writing gsa set 1: fact1' +write(iultmp) 1,iweight,4,4,1 +write(iultmp) 1,kspec2g,15,4,0,3 +write(iultmp) +write(iultmp) + +! Write gsa set 1: fact1 +write(iultmp) real(1,kind=kind_real) +write(iultmp) (fact1(jj),jj=1,kspec2g),ichkwd +if (ichkwd/=ichkwd) call abor1_ftn('bad gsa control word') + +! Write gsa set 2: header +write(*,'(a)') 'Info : - Writing gsa set 2: sdivpb' +write(iultmp) ksmax+1,iweight,5,2,1 +write(iultmp) nflev,nflev,11,15,1,1 +write(iultmp) (zpres(jj),jj=1,nflev) +write(iultmp) (zpres(jj),jj=1,nflev) + +! Write gsa set 2: sdivpb +do jn=1,ksmax+1 + write(iultmp) real(jn-1,kind=kind_real) + write(iultmp) ((sdivpb((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg),jj=1,kflevg),ichkwd +end do + +! Write gsa set 3: header +write(*,'(a)') 'Info : - Writing gsa set 3: stpspb' +write(iultmp) ksmax+1,iweight,5,2,1 +write(iultmp) nflev+1,nflev,13,15,1,1 +write(iultmp) (zpres(jj),jj=1,nflev+1) +write(iultmp) (zpres(jj),jj=1,nflev) + +! Write gsa set 3: stpspb +do jn=1,ksmax+1 + write(iultmp) real(jn-1,kind=kind_real) + write(iultmp) ((stpspb((jn-1)*kflevg*(kflevg+1)+(jk-1)*(kflevg+1)+jj),jk=1,kflevg),jj=1,kflevg+1),ichkwd +end do + +! Write gsa set 4: header +write(*,'(a)') 'Info : - Writing gsa set 4: stpsdivu' +write(iultmp) ksmax+1,iweight,5,2,1 +write(iultmp) nflev+1,nflev,13,12,1,1 +write(iultmp) (zpres(jj),jj=1,nflev+1) +write(iultmp) (zpres(jj),jj=1,nflev) + +! Write gsa set 4: stpsdivu +do jn=1,ksmax+1 + write(iultmp) real(jn-1,kind=kind_real) + write(iultmp) ((stpsdivu((jn-1)*kflevg*(kflevg+1)+(jk-1)*(kflevg+1)+jj),jk=1,kflevg),jj=1,kflevg+1),ichkwd +end do + +! Write gsa set 5: header +write(*,'(a)') 'Info : - Writing gsa set 5: sqpb' +write(iultmp) ksmax+1,iweight,5,2,1 +write(iultmp) nflev,nflev,16,15,1,1 +write(iultmp) (zpres(jj),jj=1,nflev) +write(iultmp) (zpres(jj),jj=1,nflev) + +! Write gsa set 5: sqpb +do jn=1,ksmax+1 + write(iultmp) real(jn-1,kind=kind_real) + write(iultmp) ((sqpb((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg),jj=1,kflevg),ichkwd +end do + +! Write gsa set 6: header +write(*,'(a)') 'Info : - Writing gsa set 6: sqdivu' +write(iultmp) ksmax+1,iweight,5,2,1 +write(iultmp) nflev,nflev,16,12,1,1 +write(iultmp) (zpres(jj),jj=1,nflev) +write(iultmp) (zpres(jj),jj=1,nflev) + +! Write gsa set 6: sqdivu +do jn=1,ksmax+1 + write(iultmp) real(jn-1,kind=kind_real) + write(iultmp) ((sqdivu((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg),jj=1,kflevg),ichkwd +end do + +! Write gsa set 7: header +write(*,'(a)') 'Info : - Writing gsa set 7: sqtpsu' +write(iultmp) ksmax+1,iweight,5,2,1 +write(iultmp) nflev,nflev+1,16,14,1,1 +write(iultmp) (zpres(jj),jj=1,nflev) +write(iultmp) (zpres(jj),jj=1,nflev+1) + +! Write gsa set 7: sqtpsu +do jn=1,ksmax+1 + write(iultmp) real(jn-1,kind=kind_real) + write(iultmp)((sqtpsu((jn-1)*(kflevg+1)*kflevg+(jk-1)*kflevg+jj),jk=1,kflevg+1),jj=1,kflevg),ichkwd +end do + +! Close file +close(iultmp) + +end subroutine bifourier_arome_legacy_write_balance + +!---------------------------------------------------------------------- + +subroutine bifourier_arome_legacy_read_covariance(conf,nwglb,nflev,vorcov,divucov,tpsucov,qucov) implicit none @@ -293,7 +394,7 @@ subroutine bifourier_arome_legacy_covariance(conf,nwglb,nflev,vorcov,divucov,tps ! Local variables integer(kind_int),parameter :: iultmp = 10 -integer(kind_int) :: ichkwd,idate,idim1,idim2,ilendef,inbmat,inbset,iorig,ipar1,ipar2,isetdist,itime,itypdi1,itypdi2,& +integer(kind_int) :: itestwd,idate,idim1,idim2,ilendef,inbmat,inbset,iorig,ipar1,ipar2,isetdist,itime,itypdi1,itypdi2,& & itypmat,iweight,jj,jk,jn,idgl,idgux,idlon,idlux,ksmax,kmsmax,kflevg real(kind_real) :: zlat0,zlat1,zlat2,zlon0,zlon1,zlon2,zdummy real(kind_real) :: zpdat(nflev+1) @@ -312,7 +413,7 @@ subroutine bifourier_arome_legacy_covariance(conf,nwglb,nflev,vorcov,divucov,tps ! Read and check clid read(iultmp) clid write(*,'(a,a)') 'Info : - GSA ID: ',clid -if (clid/='ALADIN98') call abor1_ftn('bad id in gsa file') +if (clid /= 'ALADIN98') call abor1_ftn('bad id in gsa file') ! Read description read(iultmp) clcom @@ -329,11 +430,11 @@ subroutine bifourier_arome_legacy_covariance(conf,nwglb,nflev,vorcov,divucov,tps read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -if (itypmat/=0) call abor1_ftn('no model geometry description') -if ((idim1/=1).or.(idim2/=13).or.(ipar1/=50).or.(ipar2/=0).or.(itypdi1/=0).or.(itypdi2/=0)) & +if (itypmat /= 0) call abor1_ftn('no model geometry description') +if ((idim1 /= 1).or.(idim2 /= 13).or.(ipar1 /= 50).or.(ipar2 /= 0).or.(itypdi1 /= 0).or.(itypdi2 /= 0)) & & call abor1_ftn('nonexpected parameters for model geometry description') -read(iultmp) zlon1,zlat1,zlon2,zlat2,zlon0,zlat0,idgl,idlon,idgux,idlux,ksmax,kmsmax,kflevg,ichkwd -if (ichkwd/=3141592) call abor1_ftn('bad gsa control word') +read(iultmp) zlon1,zlat1,zlon2,zlat2,zlon0,zlat0,idgl,idlon,idgux,idlux,ksmax,kmsmax,kflevg,itestwd +if (itestwd /= ichkwd) call abor1_ftn('bad gsa control word') write(*,'(a,i5,a,i3)') 'Info : - File geometry : nsmax =',ksmax,' / nflev =',kflevg ! Check sizes @@ -346,17 +447,17 @@ subroutine bifourier_arome_legacy_covariance(conf,nwglb,nflev,vorcov,divucov,tps read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -if ((idim1/=idim2).or.(ipar1/=ipar2).or.(itypdi1/=itypdi2)) call abor1_ftn('nonsymmetric matrix') -if (idim1<=0) call abor1_ftn('bad matrix dimensions') -if (idim1/=kflevg) call abor1_ftn('code/data dim mismatch') -if (itypdi1/=1) call abor1_ftn('matrix not on pressure levels') -if (ipar1/=4) call abor1_ftn('not vorticity in gsa set 1') +if ((idim1 /= idim2).or.(ipar1 /= ipar2).or.(itypdi1 /= itypdi2)) call abor1_ftn('nonsymmetric matrix') +if (idim1 <= 0) call abor1_ftn('bad matrix dimensions') +if (idim1 /= kflevg) call abor1_ftn('code/data dim mismatch') +if (itypdi1 /= 1) call abor1_ftn('matrix not on pressure levels') +if (ipar1 /= 4) call abor1_ftn('not vorticity in gsa set 1') ! Read gsa set 1: vorCov do jn=1,ksmax+1 read(iultmp) zdummy - read(iultmp) ((vorcov((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jj=1,kflevg),jk=1,kflevg),ichkwd - if (ichkwd /= 3141592) call abor1_ftn('bad gsa control word') + read(iultmp) ((vorcov((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jj=1,kflevg),jk=1,kflevg),itestwd + if (itestwd /= ichkwd) call abor1_ftn('bad gsa control word') end do ! Read gsa set 2: header @@ -365,13 +466,13 @@ subroutine bifourier_arome_legacy_covariance(conf,nwglb,nflev,vorcov,divucov,tps read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -if (ipar1/=12) call abor1_ftn('not unbal div in gsa set 2') +if (ipar1 /= 12) call abor1_ftn('not unbal div in gsa set 2') ! Read gsa set 2: divuCov do jn=1,ksmax+1 read(iultmp) zdummy - read(iultmp) ((divuCov((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jj=1,kflevg),jk=1,kflevg),ichkwd - if (ichkwd /= 3141592) call abor1_ftn('bad gsa control word') + read(iultmp) ((divuCov((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jj=1,kflevg),jk=1,kflevg),itestwd + if (itestwd /= ichkwd) call abor1_ftn('bad gsa control word') end do ! Read gsa set 3: header @@ -380,14 +481,14 @@ subroutine bifourier_arome_legacy_covariance(conf,nwglb,nflev,vorcov,divucov,tps read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) (zpdat(jj),jj=1,idim1) read(iultmp) -if (ipar1/=14) call abor1_ftn('not unbal t,lnps in gsa set 3') -if (idim1/=kflevg+1) call abor1_ftn('code/data dim mismatch') +if (ipar1 /= 14) call abor1_ftn('not unbal t,lnps in gsa set 3') +if (idim1 /= kflevg+1) call abor1_ftn('code/data dim mismatch') ! Read gsa set 3: tPsuCov do jn=1,ksmax+1 read(iultmp) zdummy - read(iultmp) ((tPsuCov((jn-1)*(kflevg+1)*(kflevg+1)+(jk-1)*(kflevg+1)+jj),jj=1,kflevg+1),jk=1,kflevg+1),ichkwd - if(ichkwd/=3141592) call abor1_ftn('bad gsa control word') + read(iultmp) ((tPsuCov((jn-1)*(kflevg+1)*(kflevg+1)+(jk-1)*(kflevg+1)+jj),jj=1,kflevg+1),jk=1,kflevg+1),itestwd + if(itestwd /= ichkwd) call abor1_ftn('bad gsa control word') end do ! Read gsa set 4: header @@ -396,19 +497,153 @@ subroutine bifourier_arome_legacy_covariance(conf,nwglb,nflev,vorcov,divucov,tps read(iultmp) idim1,idim2,ipar1,ipar2,itypdi1,itypdi2 read(iultmp) read(iultmp) -if (ipar1/=17) call abor1_ftn('not unbal q in gsa set 4') +if (ipar1 /= 17) call abor1_ftn('not unbal q in gsa set 4') ! Read gsa set 4: quCov do jn=1,ksmax+1 - read(iultmp) - read(iultmp) ((quCov((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jj=1,kflevg),jk=1,kflevg),ichkwd - if(ichkwd /= 3141592) call abor1_ftn('bad gsa control word') + read(iultmp) zdummy + read(iultmp) ((quCov((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jj=1,kflevg),jk=1,kflevg),itestwd + if(itestwd /= ichkwd) call abor1_ftn('bad gsa control word') +end do + +! Close file +close(iultmp) + +end subroutine bifourier_arome_legacy_read_covariance + +!---------------------------------------------------------------------- + +subroutine bifourier_arome_legacy_write_covariance(conf,nwglb,nflev,vorcov,divucov,tpsucov,qucov) + +implicit none + +! Passed variables +type(fckit_configuration),intent(in) :: conf +integer(kind_int),intent(in) :: nwglb +integer(kind_int),intent(in) :: nflev +real(kind_real),intent(in) :: vorcov(nwglb*nflev*nflev) +real(kind_real),intent(in) :: divucov(nwglb*nflev*nflev) +real(kind_real),intent(in) :: tpsucov(nwglb*(nflev+1)*(nflev+1)) +real(kind_real),intent(in) :: qucov(nwglb*nflev*nflev) + +! Local variables +integer(kind_int),parameter :: iultmp = 10 +integer(kind_int) :: idate,itime,iweight,jj,jk,jn,idgl,idgux,idlon,idlux,ksmax,kmsmax,kflevg +real(kind_real) :: zlat0,zlat1,zlat2,zlon0,zlon1,zlon2 +real(kind_real) :: zpres(nflev+1) +character(len=10) :: clid +character(len=70) :: clcom +character(len=1024) :: cdfile +character(len=:),allocatable :: str + +! Prepare zpres +do jj=1,nflev+1 + zpres(jj) = real(jj,kind=kind_real) +end do + +! Get filename from configuration +call conf%get_or_die("output file",str) +cdfile = str + +! Set relevant parameters +ksmax = nwglb-1 +kflevg = nflev + +! Set dummy parameters +idate = 0 +itime = 0 +iweight = 0 +zlon1 = 0.0 +zlon2 = 0.0 +zlat1 = 0.0 +zlat2 = 0.0 +zlon0 = 0.0 +zlat0 = 0.0 +idgl = 0 +idlon = 0 +idgux = 0 +idlux = 0 +kmsmax = 0 + +! Open file +open(iultmp,file=cdfile,form='unformatted',convert='big_endian') + +! Write clid +clid = 'ALADIN98' +write(iultmp) clid + +! Write description +clcom = ' Balanced statistcs for a LAM, after L. Berre 1998' +write(iultmp) clcom + +! Write center and date +write(iultmp) 85,idate,itime,8 + +! Write gsa set 0: model geometry definition +write(*,'(a)') 'Info : - Writing gsa set 0: model geometry definition' +write(iultmp) 1,iweight,0,1,0 +write(iultmp) 1,13,50,0,0,0 +write(iultmp) +write(iultmp) +write(iultmp) zlon1,zlat1,zlon2,zlat2,zlon0,zlat0,idgl,idlon,idgux,idlux,ksmax,kmsmax,kflevg,ichkwd + +! Write gsa set 1: header +write(*,'(a)') 'Info : - Writing gsa set 1: vorCov' +write(iultmp) ksmax+1,45,1,2,1 +write(iultmp) nflev,nflev,4,4,1,1 +write(iultmp) +write(iultmp) + +! Write gsa set 1: vorCov +do jn=1,ksmax+1 + write(iultmp) real(jn-1,kind=kind_real) + write(iultmp) ((vorcov((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jj=1,kflevg),jk=1,kflevg),ichkwd +end do + +! Write gsa set 2: header +write(*,'(a)') 'Info : - Writing gsa set 2: divuCov' +write(iultmp) ksmax+1,45,1,2,1 +write(iultmp) nflev,nflev,12,12,1,1 +write(iultmp) (zpres(jj),jj=1,nflev) +write(iultmp) (zpres(jj),jj=1,nflev) + +! Write gsa set 2: divuCov +do jn=1,ksmax+1 + write(iultmp) real(jn-1,kind=kind_real) + write(iultmp) ((divuCov((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jj=1,kflevg),jk=1,kflevg),ichkwd +end do + +! Write gsa set 3: header +write(*,'(a)') 'Info : - Writing gsa set 3: tPsuCov' +write(iultmp) ksmax+1,45,1,2,1 +write(iultmp) nflev+1,nflev+1,14,14,1,1 +write(iultmp) (zpres(jj),jj=1,nflev+1) +write(iultmp) (zpres(jj),jj=1,nflev+1) + +! Write gsa set 3: tPsuCov +do jn=1,ksmax+1 + write(iultmp) real(jn-1,kind=kind_real) + write(iultmp) ((tPsuCov((jn-1)*(kflevg+1)*(kflevg+1)+(jk-1)*(kflevg+1)+jj),jj=1,kflevg+1),jk=1,kflevg+1),ichkwd +end do + +! Write gsa set 4: header +write(*,'(a)') 'Info : - Writing gsa set 4: quCov' +write(iultmp) ksmax+1,45,1,2,1 +write(iultmp) nflev,nflev,17,17,1,1 +write(iultmp) (zpres(jj),jj=1,nflev) +write(iultmp) (zpres(jj),jj=1,nflev) + +! Write gsa set 4: quCov +do jn=1,ksmax+1 + write(iultmp) real(jn-1,kind=kind_real) + write(iultmp) ((quCov((jn-1)*kflevg*kflevg+(jk-1)*kflevg+jj),jj=1,kflevg),jk=1,kflevg),ichkwd + if(ichkwd /= ichkwd) call abor1_ftn('bad gsa control word') end do ! Close file close(iultmp) -end subroutine bifourier_arome_legacy_covariance +end subroutine bifourier_arome_legacy_write_covariance !---------------------------------------------------------------------- diff --git a/src/saber/generic/ID.h b/src/saber/generic/ID.h index 47cdfb0e6..6bfbd9f1e 100644 --- a/src/saber/generic/ID.h +++ b/src/saber/generic/ID.h @@ -54,9 +54,6 @@ class IDCentral : public SaberCentralBlockBase { void multiplySqrt(const atlas::Field &, oops::FieldSet3D &, const size_t &) const override; void multiplySqrtAD(const oops::FieldSet3D &, atlas::Field &, const size_t &) const override; - void directCalibration(const oops::FieldSets &) override - {} - private: const oops::GeometryData & geometryData_; const oops::Variables activeVars_; diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 0a7cfa06f..5fcc15af6 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -32,7 +32,10 @@ if( ENABLE_QUENCH ) # Default test selection variables (TIER-independent) set( SABER_TEST_VALGRIND 0 ) set( SABER_TEST_FASTLAM 1 ) - set( SABER_TEST_BIFOURIER 1 ) + set( SABER_TEST_BIFOURIER 0 ) + if ( FFTW_FOUND OR (ECTRANS_FOUND AND ectrans_HAVE_ETRANS AND ectrans_HAVE_TRANSI ) ) + set( SABER_TEST_BIFOURIER 1 ) + endif() set( SABER_TEST_BUMP 0 ) if( ENABLE_BUMP ) set( SABER_TEST_BUMP 1 ) @@ -115,10 +118,15 @@ if( ENABLE_QUENCH ) list( APPEND saber_test_full ${saber_test} ) endif() endif() - if( SABER_TEST_BIFOURIER AND FFTW_FOUND ) + if( SABER_TEST_BIFOURIER ) message( STATUS " - TIER 1 Bi-Fourier-specific" ) file( STRINGS testlist/saber_test_tier1-bifourier.txt saber_test ) list( APPEND saber_test_full ${saber_test} ) + if( ECTRANS_FOUND AND ectrans_HAVE_ETRANS AND ectrans_HAVE_TRANSI ) + message( STATUS " - TIER 1 Bi-Fourier-specific - ECTRANS" ) + file( STRINGS testlist/saber_test_tier1-bifourier-ectrans.txt saber_test ) + list( APPEND saber_test_full ${saber_test} ) + endif() endif() if( SABER_TEST_BUMP ) message( STATUS " - TIER 1 BUMP-specific" ) diff --git a/test/testdeps/convertcov_bifourier_balance.txt b/test/testdeps/convertcov_bifourier_balance_1.txt similarity index 100% rename from test/testdeps/convertcov_bifourier_balance.txt rename to test/testdeps/convertcov_bifourier_balance_1.txt diff --git a/test/testdeps/convertcov_bifourier_balance_2.txt b/test/testdeps/convertcov_bifourier_balance_2.txt new file mode 100644 index 000000000..e2da8ad00 --- /dev/null +++ b/test/testdeps/convertcov_bifourier_balance_2.txt @@ -0,0 +1 @@ +convertcov_bifourier_balance_1 diff --git a/test/testdeps/convertcov_bifourier_balance_3.txt b/test/testdeps/convertcov_bifourier_balance_3.txt new file mode 100644 index 000000000..f585f5355 --- /dev/null +++ b/test/testdeps/convertcov_bifourier_balance_3.txt @@ -0,0 +1 @@ +convertcov_bifourier_balance_2 diff --git a/test/testdeps/convertcov_bifourier_covariance.txt b/test/testdeps/convertcov_bifourier_covariance_1.txt similarity index 100% rename from test/testdeps/convertcov_bifourier_covariance.txt rename to test/testdeps/convertcov_bifourier_covariance_1.txt diff --git a/test/testdeps/convertcov_bifourier_covariance_2.txt b/test/testdeps/convertcov_bifourier_covariance_2.txt new file mode 100644 index 000000000..afd491b5c --- /dev/null +++ b/test/testdeps/convertcov_bifourier_covariance_2.txt @@ -0,0 +1 @@ +convertcov_bifourier_covariance_1 diff --git a/test/testdeps/convertcov_bifourier_covariance_3.txt b/test/testdeps/convertcov_bifourier_covariance_3.txt new file mode 100644 index 000000000..088902322 --- /dev/null +++ b/test/testdeps/convertcov_bifourier_covariance_3.txt @@ -0,0 +1 @@ +convertcov_bifourier_covariance_2 diff --git a/test/testdeps/dirac_bifourier_splittps.txt b/test/testdeps/dirac_bifourier.txt similarity index 100% rename from test/testdeps/dirac_bifourier_splittps.txt rename to test/testdeps/dirac_bifourier.txt diff --git a/test/testdeps/dirac_bifourier_balance_1.txt b/test/testdeps/dirac_bifourier_balance_1.txt index cb644d532..e69de29bb 100644 --- a/test/testdeps/dirac_bifourier_balance_1.txt +++ b/test/testdeps/dirac_bifourier_balance_1.txt @@ -1 +0,0 @@ -convertcov_bifourier_balance diff --git a/test/testdeps/dirac_bifourier_balance_2.txt b/test/testdeps/dirac_bifourier_balance_2.txt index cb644d532..e69de29bb 100644 --- a/test/testdeps/dirac_bifourier_balance_2.txt +++ b/test/testdeps/dirac_bifourier_balance_2.txt @@ -1 +0,0 @@ -convertcov_bifourier_balance diff --git a/test/testdeps/dirac_bifourier_balance_3.txt b/test/testdeps/dirac_bifourier_balance_3.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/testdeps/dirac_bifourier_covariance_1.txt b/test/testdeps/dirac_bifourier_covariance_1.txt index 3c84fdfcb..e69de29bb 100644 --- a/test/testdeps/dirac_bifourier_covariance_1.txt +++ b/test/testdeps/dirac_bifourier_covariance_1.txt @@ -1 +0,0 @@ -convertcov_bifourier_covariance diff --git a/test/testdeps/dirac_bifourier_covariance_2.txt b/test/testdeps/dirac_bifourier_covariance_2.txt index 3c84fdfcb..e69de29bb 100644 --- a/test/testdeps/dirac_bifourier_covariance_2.txt +++ b/test/testdeps/dirac_bifourier_covariance_2.txt @@ -1 +0,0 @@ -convertcov_bifourier_covariance diff --git a/test/testdeps/dirac_bifourier_covariance_3.txt b/test/testdeps/dirac_bifourier_covariance_3.txt index 3c84fdfcb..e69de29bb 100644 --- a/test/testdeps/dirac_bifourier_covariance_3.txt +++ b/test/testdeps/dirac_bifourier_covariance_3.txt @@ -1 +0,0 @@ -convertcov_bifourier_covariance diff --git a/test/testdeps/dirac_bifourier_ectrans.txt b/test/testdeps/dirac_bifourier_ectrans.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/testdeps/dirac_bifourier_full_spectral.txt b/test/testdeps/dirac_bifourier_full_spectral.txt deleted file mode 100644 index 68ecea44e..000000000 --- a/test/testdeps/dirac_bifourier_full_spectral.txt +++ /dev/null @@ -1,2 +0,0 @@ -dirac_bifourier_balance_1 -dirac_bifourier_covariance_1 diff --git a/test/testdeps/dirac_bifourier_vordivtouv_ectrans_1.txt b/test/testdeps/dirac_bifourier_vordivtouv_ectrans_1.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/testdeps/dirac_bifourier_vordivtouv_ectrans_2.txt b/test/testdeps/dirac_bifourier_vordivtouv_ectrans_2.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/testdeps/error_covariance_training_bifourier_1.txt b/test/testdeps/error_covariance_training_bifourier_1.txt new file mode 100644 index 000000000..061b7ee2b --- /dev/null +++ b/test/testdeps/error_covariance_training_bifourier_1.txt @@ -0,0 +1 @@ +randomization_bifourier diff --git a/test/testdeps/error_covariance_training_bifourier_2.txt b/test/testdeps/error_covariance_training_bifourier_2.txt new file mode 100644 index 000000000..061b7ee2b --- /dev/null +++ b/test/testdeps/error_covariance_training_bifourier_2.txt @@ -0,0 +1 @@ +randomization_bifourier diff --git a/test/testdeps/error_covariance_training_bifourier_3.txt b/test/testdeps/error_covariance_training_bifourier_3.txt new file mode 100644 index 000000000..061b7ee2b --- /dev/null +++ b/test/testdeps/error_covariance_training_bifourier_3.txt @@ -0,0 +1 @@ +randomization_bifourier diff --git a/test/testdeps/error_covariance_training_bifourier_4.txt b/test/testdeps/error_covariance_training_bifourier_4.txt new file mode 100644 index 000000000..a3b607025 --- /dev/null +++ b/test/testdeps/error_covariance_training_bifourier_4.txt @@ -0,0 +1,2 @@ +error_covariance_training_bifourier_3 +randomization_bifourier diff --git a/test/testdeps/error_covariance_training_bifourier_5.txt b/test/testdeps/error_covariance_training_bifourier_5.txt new file mode 100644 index 000000000..061b7ee2b --- /dev/null +++ b/test/testdeps/error_covariance_training_bifourier_5.txt @@ -0,0 +1 @@ +randomization_bifourier diff --git a/test/testdeps/error_covariance_training_bifourier_6.txt b/test/testdeps/error_covariance_training_bifourier_6.txt new file mode 100644 index 000000000..061b7ee2b --- /dev/null +++ b/test/testdeps/error_covariance_training_bifourier_6.txt @@ -0,0 +1 @@ +randomization_bifourier diff --git a/test/testdeps/error_covariance_training_bifourier_7.txt b/test/testdeps/error_covariance_training_bifourier_7.txt new file mode 100644 index 000000000..061b7ee2b --- /dev/null +++ b/test/testdeps/error_covariance_training_bifourier_7.txt @@ -0,0 +1 @@ +randomization_bifourier diff --git a/test/testdeps/error_covariance_training_bifourier_8.txt b/test/testdeps/error_covariance_training_bifourier_8.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/testdeps/error_covariance_training_bifourier_covariance_1.txt b/test/testdeps/error_covariance_training_bifourier_covariance_1.txt new file mode 100644 index 000000000..206c99690 --- /dev/null +++ b/test/testdeps/error_covariance_training_bifourier_covariance_1.txt @@ -0,0 +1 @@ +randomization_bifourier_covariance diff --git a/test/testdeps/error_covariance_training_bifourier_covariance_2.txt b/test/testdeps/error_covariance_training_bifourier_covariance_2.txt new file mode 100644 index 000000000..206c99690 --- /dev/null +++ b/test/testdeps/error_covariance_training_bifourier_covariance_2.txt @@ -0,0 +1 @@ +randomization_bifourier_covariance diff --git a/test/testdeps/error_covariance_training_bifourier_ectrans_1.txt b/test/testdeps/error_covariance_training_bifourier_ectrans_1.txt new file mode 100644 index 000000000..061b7ee2b --- /dev/null +++ b/test/testdeps/error_covariance_training_bifourier_ectrans_1.txt @@ -0,0 +1 @@ +randomization_bifourier diff --git a/test/testdeps/randomization_bifourier.txt b/test/testdeps/randomization_bifourier.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/testdeps/randomization_bifourier_covariance.txt b/test/testdeps/randomization_bifourier_covariance.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/testinput/convertcov_bifourier_balance.yaml b/test/testinput/convertcov_bifourier_balance_1.yaml similarity index 71% rename from test/testinput/convertcov_bifourier_balance.yaml rename to test/testinput/convertcov_bifourier_balance_1.yaml index ed89aa62d..09988276a 100644 --- a/test/testinput/convertcov_bifourier_balance.yaml +++ b/test/testinput/convertcov_bifourier_balance_1.yaml @@ -18,18 +18,19 @@ geometry: - variables: - air_upward_absolute_vorticity - air_horizontal_divergence + - air_temperature - water_vapor_mixing_ratio_wrt_moist_air levels: 10 - variables: - - air_temperature_and_log_of_air_pressure_at_surface - levels: 11 - latitude south to north: false + - log_of_air_pressure_at_surface + levels: 1 background: date: 2010-01-01T12:00:00Z state variables: - air_upward_absolute_vorticity - air_horizontal_divergence - - air_temperature_and_log_of_air_pressure_at_surface + - air_temperature + - log_of_air_pressure_at_surface - water_vapor_mixing_ratio_wrt_moist_air background error: covariance model: SABER @@ -39,12 +40,12 @@ background error: saber central block: saber block name: BifourierID saber outer blocks: - - saber block name: BifourierVorToPb - - saber block name: BifourierBalance + - saber block name: BifourierAromeBalance read: input file: testdata/bifourier_balance.nc - input file format: arome legacy netcdf - output file: testdata/convertcov_bifourier_balance/_MPI_-_OMP__balance.nc + write: + output file: testdata/convertcov_bifourier_balance_1/_MPI_-_OMP__balance.nc + output file format: arome legacy netcdf force write: true rows: - output variable: balanced_air_pressure @@ -54,13 +55,13 @@ background error: input variables: [balanced_air_pressure, air_horizontal_divergence] - output variable: water_vapor_mixing_ratio_wrt_moist_air input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] - - saber block name: BifourierVorToPb - read: - input file: testdata/bifourier_balance.nc - input file format: arome legacy netcdf - output file: testdata/convertcov_bifourier_balance/_MPI_-_OMP__vortopb.nc - force write: true - backward mode: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air - saber block name: BifourierSpectralToGrid dirac: lon: @@ -76,15 +77,15 @@ dirac: level: - 1 - 1 - - 11 + - 1 - 1 variable: - air_upward_absolute_vorticity - air_horizontal_divergence - - air_temperature_and_log_of_air_pressure_at_surface + - log_of_air_pressure_at_surface - water_vapor_mixing_ratio_wrt_moist_air output dirac: mpi pattern: '%MPI%' - filepath: testdata/convertcov_bifourier_balance/%MPI%_dirac_%id% + filepath: testdata/convertcov_bifourier_balance_1/%MPI%_dirac_%id% test: - reference filename: testref/convertcov_bifourier_balance.ref + reference filename: testref/convertcov_bifourier_balance_1.ref diff --git a/test/testinput/convertcov_bifourier_balance_2.yaml b/test/testinput/convertcov_bifourier_balance_2.yaml new file mode 100644 index 000000000..171058757 --- /dev/null +++ b/test/testinput/convertcov_bifourier_balance_2.yaml @@ -0,0 +1,92 @@ +# Convert balance operator file from arome format to bifourier block-specific format +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 +background: + date: 2010-01-01T12:00:00Z + state variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierID + saber outer blocks: + - saber block name: BifourierAromeBalance + read: + input file: testdata/convertcov_bifourier_balance_1/_MPI_-_OMP__balance.nc + input file format: arome legacy netcdf + write: + output file: testdata/convertcov_bifourier_balance_2/_MPI_-_OMP__balance.bin + output file format: arome legacy binary + force write: true + rows: + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralToGrid +dirac: + lon: + - 9.9058 + - 9.9058 + - 9.9058 + - 9.9058 + lat: + - 56.3223 + - 56.3223 + - 56.3223 + - 56.3223 + level: + - 1 + - 1 + - 1 + - 1 + variable: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/convertcov_bifourier_balance_2/%MPI%_dirac_%id% +test: + reference filename: testref/convertcov_bifourier_balance_2.ref diff --git a/test/testinput/convertcov_bifourier_balance_3.yaml b/test/testinput/convertcov_bifourier_balance_3.yaml new file mode 100644 index 000000000..98cd13097 --- /dev/null +++ b/test/testinput/convertcov_bifourier_balance_3.yaml @@ -0,0 +1,91 @@ +# Convert balance operator file from arome format to bifourier block-specific format +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 +background: + date: 2010-01-01T12:00:00Z + state variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierID + saber outer blocks: + - saber block name: BifourierAromeBalance + read: + input file: testdata/convertcov_bifourier_balance_2/_MPI_-_OMP__balance.bin + input file format: arome legacy binary + write: + output file: testdata/convertcov_bifourier_balance_3/_MPI_-_OMP__balance.nc + force write: true + rows: + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralToGrid +dirac: + lon: + - 9.9058 + - 9.9058 + - 9.9058 + - 9.9058 + lat: + - 56.3223 + - 56.3223 + - 56.3223 + - 56.3223 + level: + - 1 + - 1 + - 1 + - 1 + variable: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/convertcov_bifourier_balance_3/%MPI%_dirac_%id% +test: + reference filename: testref/convertcov_bifourier_balance_3.ref diff --git a/test/testinput/convertcov_bifourier_covariance.yaml b/test/testinput/convertcov_bifourier_covariance_1.yaml similarity index 81% rename from test/testinput/convertcov_bifourier_covariance.yaml rename to test/testinput/convertcov_bifourier_covariance_1.yaml index 0d27235bf..48218f93f 100644 --- a/test/testinput/convertcov_bifourier_covariance.yaml +++ b/test/testinput/convertcov_bifourier_covariance_1.yaml @@ -23,7 +23,6 @@ geometry: - variables: - air_temperature_and_log_of_air_pressure_at_surface levels: 11 - latitude south to north: false background: date: 2010-01-01T12:00:00Z state variables: @@ -36,11 +35,12 @@ background error: adjoint test: true square-root test: true saber central block: - saber block name: BifourierCovariance + saber block name: BifourierAromeCovariance read: input file: testdata/bifourier_covariance.nc - input file format: arome legacy netcdf - output file: testdata/convertcov_bifourier_covariance/_MPI_-_OMP__covariance.nc + write: + output file: testdata/convertcov_bifourier_covariance_1/_MPI_-_OMP__covariance.nc + output file format: arome legacy netcdf force write: true saber outer blocks: - saber block name: BifourierSpectralToGrid @@ -67,6 +67,6 @@ dirac: - water_vapor_mixing_ratio_wrt_moist_air output dirac: mpi pattern: '%MPI%' - filepath: testdata/convertcov_bifourier_covariance/%MPI%_dirac_%id% + filepath: testdata/convertcov_bifourier_covariance_1/%MPI%_dirac_%id% test: - reference filename: testref/convertcov_bifourier_covariance.ref + reference filename: testref/convertcov_bifourier_covariance_1.ref diff --git a/test/testinput/convertcov_bifourier_covariance_2.yaml b/test/testinput/convertcov_bifourier_covariance_2.yaml new file mode 100644 index 000000000..f064eb531 --- /dev/null +++ b/test/testinput/convertcov_bifourier_covariance_2.yaml @@ -0,0 +1,73 @@ +# Convert covariance operator file from arome format to bifourier block-specific format +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + adjoint test: true + square-root test: true + saber central block: + saber block name: BifourierAromeCovariance + read: + input file: testdata/convertcov_bifourier_covariance_1/_MPI_-_OMP__covariance.nc + input file format: arome legacy netcdf + write: + output file: testdata/convertcov_bifourier_covariance_2/_MPI_-_OMP__covariance.bin + output file format: arome legacy binary + force write: true + saber outer blocks: + - saber block name: BifourierSpectralToGrid +dirac: + lon: + - 9.9058 + - 9.9058 + - 9.9058 + - 9.9058 + lat: + - 56.3223 + - 56.3223 + - 56.3223 + - 56.3223 + level: + - 1 + - 1 + - 11 + - 1 + variable: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/convertcov_bifourier_covariance_2/%MPI%_dirac_%id% +test: + reference filename: testref/convertcov_bifourier_covariance_2.ref diff --git a/test/testinput/convertcov_bifourier_covariance_3.yaml b/test/testinput/convertcov_bifourier_covariance_3.yaml new file mode 100644 index 000000000..aae20b018 --- /dev/null +++ b/test/testinput/convertcov_bifourier_covariance_3.yaml @@ -0,0 +1,73 @@ +# Convert covariance operator file from arome format to bifourier block-specific format +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + adjoint test: true + square-root test: true + saber central block: + saber block name: BifourierAromeCovariance + read: + input file: testdata/convertcov_bifourier_covariance_2/_MPI_-_OMP__covariance.bin + input file format: arome legacy binary + write: + output file: testdata/convertcov_bifourier_covariance_3/_MPI_-_OMP__covariance.nc + write covariance: true + force write: true + saber outer blocks: + - saber block name: BifourierSpectralToGrid +dirac: + lon: + - 9.9058 + - 9.9058 + - 9.9058 + - 9.9058 + lat: + - 56.3223 + - 56.3223 + - 56.3223 + - 56.3223 + level: + - 1 + - 1 + - 11 + - 1 + variable: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/convertcov_bifourier_covariance_3/%MPI%_dirac_%id% +test: + reference filename: testref/convertcov_bifourier_covariance_3.ref diff --git a/test/testinput/dirac_bifourier_full_spectral.yaml b/test/testinput/dirac_bifourier.yaml similarity index 66% rename from test/testinput/dirac_bifourier_full_spectral.yaml rename to test/testinput/dirac_bifourier.yaml index 7a7a61d34..866967b3a 100644 --- a/test/testinput/dirac_bifourier_full_spectral.yaml +++ b/test/testinput/dirac_bifourier.yaml @@ -18,8 +18,6 @@ geometry: - variables: - air_upward_absolute_vorticity - air_horizontal_divergence - - reduced_x_wind - - reduced_y_wind - geographical_x_wind - geographical_y_wind - air_temperature @@ -31,7 +29,6 @@ geometry: - variables: - air_temperature_and_log_of_air_pressure_at_surface levels: 11 - latitude south to north: false background: date: 2010-01-01T12:00:00Z state variables: @@ -42,15 +39,17 @@ background: - water_vapor_mixing_ratio_wrt_moist_air background error: covariance model: SABER + adjoint test: true + square-root test: true + inverse test: true saber central block: - saber block name: BifourierCovariance + saber block name: BifourierAromeCovariance read: - input file: testdata/convertcov_bifourier_covariance/_MPI_-_OMP__covariance.nc + input file: testdata/bifourier_covariance.nc saber outer blocks: - - saber block name: BifourierVorToPb - - saber block name: BifourierBalance + - saber block name: BifourierAromeBalance read: - input file: testdata/convertcov_bifourier_balance/_MPI_-_OMP__balance.nc + input file: testdata/bifourier_balance.nc rows: - output variable: air_upward_absolute_vorticity - output variable: balanced_air_pressure @@ -60,12 +59,23 @@ background error: input variables: [balanced_air_pressure, air_horizontal_divergence] - output variable: water_vapor_mixing_ratio_wrt_moist_air input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] - - saber block name: BifourierVorToPb - backward mode: true - - saber block name: BifourierSplitTPs - - saber block name: BifourierVorDivToRedWind - - saber block name: BifourierSpectralToGrid - - saber block name: RedWindToGeoWind + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralVorDivToGridWind + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air biperiodization: &biper x inner extension: 7 y inner extension: 5 @@ -79,11 +89,11 @@ dirac: lat: - 56.3223 level: - - 1 + - 4 variable: - air_temperature output dirac: mpi pattern: '%MPI%' - filepath: testdata/dirac_bifourier_full_spectral/%MPI%_dirac_%id% + filepath: testdata/dirac_bifourier/%MPI%_dirac_%id% test: - reference filename: testref/dirac_bifourier_full_spectral.ref + reference filename: testref/dirac_bifourier.ref diff --git a/test/testinput/dirac_bifourier_balance_1.yaml b/test/testinput/dirac_bifourier_balance_1.yaml index 8b7fbe463..b7040b097 100644 --- a/test/testinput/dirac_bifourier_balance_1.yaml +++ b/test/testinput/dirac_bifourier_balance_1.yaml @@ -18,18 +18,19 @@ geometry: - variables: - air_upward_absolute_vorticity - air_horizontal_divergence + - air_temperature - water_vapor_mixing_ratio_wrt_moist_air levels: 10 - variables: - - air_temperature_and_log_of_air_pressure_at_surface - levels: 11 - latitude south to north: false + - log_of_air_pressure_at_surface + levels: 1 background: date: 2010-01-01T12:00:00Z state variables: - air_upward_absolute_vorticity - air_horizontal_divergence - - air_temperature_and_log_of_air_pressure_at_surface + - air_temperature + - log_of_air_pressure_at_surface - water_vapor_mixing_ratio_wrt_moist_air background error: covariance model: SABER @@ -39,10 +40,9 @@ background error: saber central block: saber block name: BifourierID saber outer blocks: - - saber block name: BifourierVorToPb - - saber block name: BifourierBalance + - saber block name: BifourierAromeBalance read: - input file: testdata/convertcov_bifourier_balance/_MPI_-_OMP__balance.nc + input file: testdata/convertcov_bifourier_balance_3/_MPI_-_OMP__balance.nc rows: - output variable: balanced_air_pressure - output variable: air_horizontal_divergence @@ -51,11 +51,13 @@ background error: input variables: [balanced_air_pressure, air_horizontal_divergence] - output variable: water_vapor_mixing_ratio_wrt_moist_air input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] - - saber block name: BifourierVorToPb - zonal wavenumbers size: 325 - meridional wavenumbers size: 325 - mean latitude: 55.434555488 - backward mode: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air - saber block name: BifourierSpectralToGrid dirac: lon: @@ -71,12 +73,12 @@ dirac: level: - 1 - 1 - - 11 + - 1 - 1 variable: - air_upward_absolute_vorticity - air_horizontal_divergence - - air_temperature_and_log_of_air_pressure_at_surface + - log_of_air_pressure_at_surface - water_vapor_mixing_ratio_wrt_moist_air output dirac: mpi pattern: '%MPI%' diff --git a/test/testinput/dirac_bifourier_balance_2.yaml b/test/testinput/dirac_bifourier_balance_2.yaml index 6970e102f..ec4f1803e 100644 --- a/test/testinput/dirac_bifourier_balance_2.yaml +++ b/test/testinput/dirac_bifourier_balance_2.yaml @@ -1,10 +1,10 @@ -# Same as dirac_bifourier_balance_1, with an additional biperiodization block +# Same as dirac_bifourier_balance_1, with explicit balanced air pressure parameters geometry: function space: StructuredColumns grid: type : regional - nx : 52 - ny : 36 + nx : 73 + ny : 51 dx : 2.5e3 dy : 2.5e3 lonlat(centre) : [9.9, 56.3] @@ -18,28 +18,31 @@ geometry: - variables: - air_upward_absolute_vorticity - air_horizontal_divergence + - air_temperature - water_vapor_mixing_ratio_wrt_moist_air levels: 10 - variables: - - air_temperature_and_log_of_air_pressure_at_surface - levels: 11 - latitude south to north: false + - log_of_air_pressure_at_surface + levels: 1 background: date: 2010-01-01T12:00:00Z state variables: - air_upward_absolute_vorticity - air_horizontal_divergence - - air_temperature_and_log_of_air_pressure_at_surface + - air_temperature + - log_of_air_pressure_at_surface - water_vapor_mixing_ratio_wrt_moist_air background error: covariance model: SABER + adjoint test: true + square-root test: true + inverse test: true saber central block: saber block name: BifourierID saber outer blocks: - - saber block name: BifourierVorToPb - - saber block name: BifourierBalance + - saber block name: BifourierAromeBalance read: - input file: testdata/convertcov_bifourier_balance/_MPI_-_OMP__balance.nc + input file: testdata/bifourier_balance.nc rows: - output variable: balanced_air_pressure - output variable: air_horizontal_divergence @@ -48,16 +51,18 @@ background error: input variables: [balanced_air_pressure, air_horizontal_divergence] - output variable: water_vapor_mixing_ratio_wrt_moist_air input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] - - saber block name: BifourierVorToPb - backward mode: true + explicit balanced air pressure parameters: + zonal truncation: 479 + meridional truncation: 539 + mean latitude: 60.94768174 + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air - saber block name: BifourierSpectralToGrid - - saber block name: Biperiodization - biperiodization: - x inner extension: 28 - y inner extension: 20 - x outer extension: 7 - y outer extension: 5 - skip tests: true dirac: lon: - 9.9058 @@ -72,12 +77,12 @@ dirac: level: - 1 - 1 - - 11 + - 1 - 1 variable: - air_upward_absolute_vorticity - air_horizontal_divergence - - air_temperature_and_log_of_air_pressure_at_surface + - log_of_air_pressure_at_surface - water_vapor_mixing_ratio_wrt_moist_air output dirac: mpi pattern: '%MPI%' diff --git a/test/testinput/dirac_bifourier_balance_3.yaml b/test/testinput/dirac_bifourier_balance_3.yaml new file mode 100644 index 000000000..f0a8e94fa --- /dev/null +++ b/test/testinput/dirac_bifourier_balance_3.yaml @@ -0,0 +1,95 @@ +# Same as dirac_bifourier_balance_1, balanced air pressure parameters from grid and an additional biperiodization block +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 52 + ny : 36 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 +background: + date: 2010-01-01T12:00:00Z + state variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierID + saber outer blocks: + - saber block name: BifourierAromeBalance + read: + input file: testdata/bifourier_balance.nc + rows: + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralToGrid + - saber block name: Biperiodization + biperiodization: + x inner extension: 28 + y inner extension: 20 + x outer extension: 7 + y outer extension: 5 + skip tests: true +dirac: + lon: + - 9.9058 + - 9.9058 + - 9.9058 + - 9.9058 + lat: + - 56.3223 + - 56.3223 + - 56.3223 + - 56.3223 + level: + - 1 + - 1 + - 1 + - 1 + variable: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/dirac_bifourier_balance_3/%MPI%_dirac_%id% +test: + reference filename: testref/dirac_bifourier_balance_3.ref diff --git a/test/testinput/dirac_bifourier_covariance_1.yaml b/test/testinput/dirac_bifourier_covariance_1.yaml index 20df5842b..ca7a9804f 100644 --- a/test/testinput/dirac_bifourier_covariance_1.yaml +++ b/test/testinput/dirac_bifourier_covariance_1.yaml @@ -23,7 +23,6 @@ geometry: - variables: - air_temperature_and_log_of_air_pressure_at_surface levels: 11 - latitude south to north: false background: date: 2010-01-01T12:00:00Z state variables: @@ -35,10 +34,11 @@ background error: covariance model: SABER adjoint test: true square-root test: true + inverse test: true saber central block: saber block name: BifourierCovariance read: - input file: testdata/convertcov_bifourier_covariance/_MPI_-_OMP__covariance.nc + input file: testdata/bifourier_covariance.nc saber outer blocks: - saber block name: BifourierSpectralToGrid dirac: diff --git a/test/testinput/dirac_bifourier_covariance_2.yaml b/test/testinput/dirac_bifourier_covariance_2.yaml index c94c53f47..e2fd933fb 100644 --- a/test/testinput/dirac_bifourier_covariance_2.yaml +++ b/test/testinput/dirac_bifourier_covariance_2.yaml @@ -23,7 +23,6 @@ geometry: - variables: - air_temperature_and_log_of_air_pressure_at_surface levels: 11 - latitude south to north: false background: date: 2010-01-01T12:00:00Z state variables: @@ -35,16 +34,17 @@ background error: covariance model: SABER adjoint test: true square-root test: true + inverse test: true saber central block: saber block name: BifourierCovariance read: - input file: testdata/convertcov_bifourier_covariance/_MPI_-_OMP__covariance.nc + input file: testdata/bifourier_covariance.nc correlation: true saber outer blocks: - saber block name: StdDev read: profile file: - filepath: testdata/convertcov_bifourier_covariance/_MPI_-_OMP__covariance.nc + filepath: testdata/bifourier_covariance.nc prefix: stdDev_ - saber block name: BifourierSpectralToGrid dirac: diff --git a/test/testinput/dirac_bifourier_covariance_3.yaml b/test/testinput/dirac_bifourier_covariance_3.yaml index 6e4d33893..375698984 100644 --- a/test/testinput/dirac_bifourier_covariance_3.yaml +++ b/test/testinput/dirac_bifourier_covariance_3.yaml @@ -23,7 +23,6 @@ geometry: - variables: - air_temperature_and_log_of_air_pressure_at_surface levels: 11 - latitude south to north: false background: date: 2010-01-01T12:00:00Z state variables: @@ -33,10 +32,13 @@ background: - water_vapor_mixing_ratio_wrt_moist_air background error: covariance model: SABER + adjoint test: true + square-root test: true + inverse test: true saber central block: saber block name: BifourierCovariance read: - input file: testdata/convertcov_bifourier_covariance/_MPI_-_OMP__covariance.nc + input file: testdata/bifourier_covariance.nc saber outer blocks: - saber block name: BifourierSpectralToGrid - saber block name: Biperiodization diff --git a/test/testinput/dirac_bifourier_ectrans.yaml b/test/testinput/dirac_bifourier_ectrans.yaml new file mode 100644 index 000000000..f28e582c6 --- /dev/null +++ b/test/testinput/dirac_bifourier_ectrans.yaml @@ -0,0 +1,100 @@ +# Dirac test for a full bifourier covariance matrix, using ECTRANS backend +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierAromeCovariance + read: + input file: testdata/bifourier_covariance.nc + saber outer blocks: + - saber block name: BifourierAromeBalance + read: + input file: testdata/bifourier_balance.nc + rows: + - output variable: air_upward_absolute_vorticity + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralVorDivToGridWind + transform: + fft backend: ectrans + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: Biperiodization + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 4 + variable: + - air_temperature +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/dirac_bifourier_ectrans/%MPI%_dirac_%id% +test: + reference filename: testref/dirac_bifourier_ectrans.ref diff --git a/test/testinput/dirac_bifourier_gridtospectral.yaml b/test/testinput/dirac_bifourier_gridtospectral.yaml index c0b0042a6..507b52c9e 100644 --- a/test/testinput/dirac_bifourier_gridtospectral.yaml +++ b/test/testinput/dirac_bifourier_gridtospectral.yaml @@ -19,7 +19,6 @@ geometry: - air_upward_absolute_vorticity - air_horizontal_divergence levels: 10 - latitude south to north: false background: date: 2010-01-01T12:00:00Z state variables: @@ -27,6 +26,9 @@ background: - air_horizontal_divergence background error: covariance model: SABER + adjoint test: true + square-root test: true + inverse test: true saber central block: saber block name: ID saber outer blocks: diff --git a/test/testinput/dirac_bifourier_vordivtouv_1.yaml b/test/testinput/dirac_bifourier_vordivtouv_1.yaml index 76ed70870..615f65613 100644 --- a/test/testinput/dirac_bifourier_vordivtouv_1.yaml +++ b/test/testinput/dirac_bifourier_vordivtouv_1.yaml @@ -1,4 +1,4 @@ -# Dirac test for the BifourierVorDivToRedWind (forward and backward) and RedWindToGeoWind blocks +# Dirac test for the BifourierVorDivToGridWind (forward and backward) block, differential operators scaling activated geometry: function space: StructuredColumns grid: @@ -18,15 +18,12 @@ geometry: - variables: - air_upward_absolute_vorticity - air_horizontal_divergence - - reduced_x_wind - - reduced_y_wind - geographical_x_wind - geographical_y_wind levels: 10 - variables: - map_factor levels: 1 - latitude south to north: false background: date: 2010-01-01T12:00:00Z state variables: @@ -34,25 +31,22 @@ background: - geographical_y_wind background error: covariance model: SABER - adjoint test: false - square-root test: false - inverse test: false + adjoint test: true + square-root test: true + inverse test: true saber central block: - saber block name: BifourierID + saber block name: ID saber outer blocks: - - saber block name: BifourierVorDivToRedWind + - saber block name: BifourierSpectralVorDivToGridWind backward mode: true - - saber block name: BifourierVorDivToRedWind - - saber block name: BifourierSpectralToGrid - - saber block name: RedWindToGeoWind + - saber block name: BifourierSpectralVorDivToGridWind + transform: + differential operators scaling: true biperiodization: x inner extension: 7 y inner extension: 5 x outer extension: 7 y outer extension: 5 - output file: - filepath: testdata/dirac_bifourier_vordivtouv_1/_MPI_-_OMP__red_wind_to_geo_wind - force write: true dirac: lon: - 9.9058 diff --git a/test/testinput/dirac_bifourier_vordivtouv_2.yaml b/test/testinput/dirac_bifourier_vordivtouv_2.yaml index b68b652bf..f8bd5c700 100644 --- a/test/testinput/dirac_bifourier_vordivtouv_2.yaml +++ b/test/testinput/dirac_bifourier_vordivtouv_2.yaml @@ -1,4 +1,4 @@ -# Dirac test of the BifourierVorDivToRedWind block, with the dipole mode activated +# Dirac test of the BifourierVorDivToWind block, with the dipole mode activated geometry: function space: StructuredColumns grid: @@ -18,12 +18,9 @@ geometry: - variables: - air_upward_absolute_vorticity - air_horizontal_divergence - - reduced_x_wind - - reduced_y_wind - geographical_x_wind - geographical_y_wind levels: 10 - latitude south to north: false background: date: 2010-01-01T12:00:00Z state variables: @@ -32,8 +29,8 @@ background: background error: covariance model: SABER adjoint test: false - square-root test: false - inverse test: false + square-root test: true + inverse test: true saber central block: saber block name: FastLAM calibration: @@ -53,10 +50,8 @@ background error: resolution: 5 saber outer blocks: - saber block name: BifourierGridToSpectral - - saber block name: BifourierVorDivToRedWind + - saber block name: BifourierSpectralVorDivToGridWind dipole test: true - - saber block name: BifourierSpectralToGrid - - saber block name: RedWindToGeoWind biperiodization: x inner extension: 7 y inner extension: 5 diff --git a/test/testinput/dirac_bifourier_vordivtouv_3.yaml b/test/testinput/dirac_bifourier_vordivtouv_3.yaml index a8350aaea..a35ad3810 100644 --- a/test/testinput/dirac_bifourier_vordivtouv_3.yaml +++ b/test/testinput/dirac_bifourier_vordivtouv_3.yaml @@ -1,4 +1,4 @@ -# Dirac test of the RedWindToGeoWind block, with the outer spherical winds activated mode activated +# Dirac test of the BifourierSpectralVorDivToGridWind block, with the outer spherical winds activated mode activated geometry: function space: StructuredColumns grid: @@ -18,8 +18,6 @@ geometry: - variables: - air_upward_absolute_vorticity - air_horizontal_divergence - - reduced_x_wind - - reduced_y_wind - eastward_wind - northward_wind levels: 10 @@ -30,7 +28,6 @@ geometry: - dyDlon - dyDlat levels: 1 - latitude south to north: false background: date: 2010-01-01T12:00:00Z state variables: @@ -44,18 +41,13 @@ background error: saber central block: saber block name: BifourierID saber outer blocks: - - saber block name: BifourierVorDivToRedWind - - saber block name: BifourierSpectralToGrid - - saber block name: RedWindToGeoWind + - saber block name: BifourierSpectralVorDivToGridWind outer spherical winds: true biperiodization: x inner extension: 7 y inner extension: 5 x outer extension: 7 y outer extension: 5 - output file: - filepath: testdata/dirac_bifourier_vordivtouv_3/_MPI_-_OMP__red_wind_to_geo_wind - force write: true dirac: lon: - 9.9058 diff --git a/test/testinput/dirac_bifourier_vordivtouv_ectrans_1.yaml b/test/testinput/dirac_bifourier_vordivtouv_ectrans_1.yaml new file mode 100644 index 000000000..3873c64aa --- /dev/null +++ b/test/testinput/dirac_bifourier_vordivtouv_ectrans_1.yaml @@ -0,0 +1,55 @@ +# Dirac test for the BifourierSpectralVorDivToGridRedWind (forward and backward) and RedWindToGeoWind blocks, using ECTRANS backend +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + levels: 10 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind +background error: + covariance model: SABER + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: ID + saber outer blocks: + - saber block name: BifourierSpectralVorDivToGridWind + backward mode: true + - saber block name: BifourierSpectralVorDivToGridWind + transform: + fft backend: ectrans +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 1 + variable: + - geographical_x_wind +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/dirac_bifourier_vordivtouv_ectrans_1/%MPI%_dirac_%id% +test: + reference filename: testref/dirac_bifourier_vordivtouv_ectrans_1.ref diff --git a/test/testinput/dirac_bifourier_vordivtouv_ectrans_2.yaml b/test/testinput/dirac_bifourier_vordivtouv_ectrans_2.yaml new file mode 100644 index 000000000..9c460ef3a --- /dev/null +++ b/test/testinput/dirac_bifourier_vordivtouv_ectrans_2.yaml @@ -0,0 +1,70 @@ +# Dirac test of the BifourierSpectralVorDivToGridWind block, with the dipole mode activated, using ECTRANS backend +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + levels: 10 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind +background error: + covariance model: SABER + adjoint test: false + square-root test: true + inverse test: true + saber central block: + saber block name: FastLAM + calibration: + multivariate strategy: univariate + groups: + - group name: vars + variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + horizontal length-scale: + - group: vars + value: 15.0e3 + vertical length-scale: + - group: vars + value: 3.0 + number of layers: 1 + resolution: 5 + saber outer blocks: + - saber block name: BifourierGridToSpectral + - saber block name: BifourierSpectralVorDivToGridWind + dipole test: true + transform: + fft backend: ectrans +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 1 + variable: + - geographical_x_wind +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/dirac_bifourier_vordivtouv_ectrans_2/%MPI%_dirac_%id% +test: + reference filename: testref/dirac_bifourier_vordivtouv_ectrans_2.ref diff --git a/test/testinput/error_covariance_training_bifourier_1.yaml b/test/testinput/error_covariance_training_bifourier_1.yaml new file mode 100644 index 000000000..cd09dbe10 --- /dev/null +++ b/test/testinput/error_covariance_training_bifourier_1.yaml @@ -0,0 +1,113 @@ +# Direct calibration of a full bifourier error covariance matrix +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + ensemble: + members from template: + template: + date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bifourier/_MPI_-_OMP__member_%mem% + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + pattern: '%mem%' + nmembers: 25 + zero padding: 6 + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierCovariance + calibration: {} + write: + output file: testdata/error_covariance_training_bifourier_1/_MPI_-_OMP__covariance.nc + write covariance: true + saber outer blocks: + - saber block name: BifourierAromeBalance + calibration: {} + write: + output file: testdata/error_covariance_training_bifourier_1/_MPI_-_OMP__balance.nc + rows: + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralVorDivToGridWind + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 4 + variable: + - air_temperature +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/error_covariance_training_bifourier_1/%MPI%_dirac_%id% +test: + reference filename: testref/error_covariance_training_bifourier_1.ref diff --git a/test/testinput/error_covariance_training_bifourier_2.yaml b/test/testinput/error_covariance_training_bifourier_2.yaml new file mode 100644 index 000000000..4c7cecfd2 --- /dev/null +++ b/test/testinput/error_covariance_training_bifourier_2.yaml @@ -0,0 +1,114 @@ +# Direct calibration of a full bifourier error covariance matrix, using the full recursive inverse for the balance operator (should be almost similar to error_covariance_training_bifourier_1) +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + ensemble: + members from template: + template: + date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bifourier/_MPI_-_OMP__member_%mem% + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + pattern: '%mem%' + nmembers: 25 + zero padding: 6 + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierCovariance + calibration: {} + write: + output file: testdata/error_covariance_training_bifourier_2/_MPI_-_OMP__covariance.nc + write covariance: true + saber outer blocks: + - saber block name: BifourierAromeBalance + calibration: + full recursive inverse: true + write: + output file: testdata/error_covariance_training_bifourier_2/_MPI_-_OMP__balance.nc + rows: + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralVorDivToGridWind + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 4 + variable: + - air_temperature +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/error_covariance_training_bifourier_2/%MPI%_dirac_%id% +test: + reference filename: testref/error_covariance_training_bifourier_2.ref diff --git a/test/testinput/error_covariance_training_bifourier_3.yaml b/test/testinput/error_covariance_training_bifourier_3.yaml new file mode 100644 index 000000000..ad389121e --- /dev/null +++ b/test/testinput/error_covariance_training_bifourier_3.yaml @@ -0,0 +1,115 @@ +# Iterative calibration of a full bifourier error covariance matrix, should be equal to error_covariance_training_bifourier_2 +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + iterative ensemble loading: true + ensemble: + members from template: + template: + date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bifourier/_MPI_-_OMP__member_%mem% + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + pattern: '%mem%' + nmembers: 25 + zero padding: 6 + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierCovariance + calibration: {} + write: + output file: testdata/error_covariance_training_bifourier_3/_MPI_-_OMP__covariance.nc + write covariance: true + saber outer blocks: + - saber block name: BifourierAromeBalance + calibration: {} + write: + output file: testdata/error_covariance_training_bifourier_3/_MPI_-_OMP__balance.nc + write covariance: true + rows: + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralVorDivToGridWind + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 4 + variable: + - air_temperature +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/error_covariance_training_bifourier_3/%MPI%_dirac_%id% +test: + reference filename: testref/error_covariance_training_bifourier_3.ref diff --git a/test/testinput/error_covariance_training_bifourier_4.yaml b/test/testinput/error_covariance_training_bifourier_4.yaml new file mode 100644 index 000000000..ee9b89619 --- /dev/null +++ b/test/testinput/error_covariance_training_bifourier_4.yaml @@ -0,0 +1,120 @@ +# Iterative calibration of a full bifourier error covariance matrix, including averaged with an existing error covariance matrix +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + iterative ensemble loading: true + ensemble: + members from template: + template: + date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bifourier/_MPI_-_OMP__member_%mem% + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + pattern: '%mem%' + nmembers: 25 + zero padding: 6 + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierCovariance + calibration: + old covariance input file: testdata/error_covariance_training_bifourier_3/_MPI_-_OMP__covariance.nc + half life: 8.0 + cycle index: 1 + write: + output file: testdata/error_covariance_training_bifourier_4/_MPI_-_OMP__covariance.nc + write covariance: true + saber outer blocks: + - saber block name: BifourierAromeBalance + calibration: + old covariance input file: testdata/error_covariance_training_bifourier_3/_MPI_-_OMP__balance.nc + half life: 8.0 + cycle index: 1 + write: + output file: testdata/error_covariance_training_bifourier_4/_MPI_-_OMP__balance.nc + rows: + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralVorDivToGridWind + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 4 + variable: + - air_temperature +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/error_covariance_training_bifourier_4/%MPI%_dirac_%id% +test: + reference filename: testref/error_covariance_training_bifourier_4.ref diff --git a/test/testinput/error_covariance_training_bifourier_5.yaml b/test/testinput/error_covariance_training_bifourier_5.yaml new file mode 100644 index 000000000..2b31a1db7 --- /dev/null +++ b/test/testinput/error_covariance_training_bifourier_5.yaml @@ -0,0 +1,116 @@ +# Iterative calibration of a full bifourier error covariance matrix, using sub-ensembles +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + iterative ensemble loading: true + ensemble: + members from template: + template: + date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bifourier/_MPI_-_OMP__member_%mem% + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + pattern: '%mem%' + nmembers: 25 + zero padding: 6 + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierCovariance + calibration: + sub-ensembles size: 5 + write: + output file: testdata/error_covariance_training_bifourier_5/_MPI_-_OMP__covariance.nc + write covariance: true + saber outer blocks: + - saber block name: BifourierAromeBalance + calibration: + sub-ensembles size: 5 + write: + output file: testdata/error_covariance_training_bifourier_5/_MPI_-_OMP__balance.nc + rows: + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralVorDivToGridWind + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 4 + variable: + - air_temperature +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/error_covariance_training_bifourier_5/%MPI%_dirac_%id% +test: + reference filename: testref/error_covariance_training_bifourier_5.ref diff --git a/test/testinput/error_covariance_training_bifourier_6.yaml b/test/testinput/error_covariance_training_bifourier_6.yaml new file mode 100644 index 000000000..48677f99d --- /dev/null +++ b/test/testinput/error_covariance_training_bifourier_6.yaml @@ -0,0 +1,115 @@ +# Iterative calibration of a full bifourier error covariance matrix, with a partial inversion to compute the balance regressions +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + iterative ensemble loading: true + ensemble: + members from template: + template: + date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bifourier/_MPI_-_OMP__member_%mem% + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + pattern: '%mem%' + nmembers: 25 + zero padding: 6 + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierCovariance + calibration: {} + write: + output file: testdata/error_covariance_training_bifourier_6/_MPI_-_OMP__covariance.nc + write covariance: true + saber outer blocks: + - saber block name: BifourierAromeBalance + calibration: + remaining variance fraction: 0.9 + write: + output file: testdata/error_covariance_training_bifourier_6/_MPI_-_OMP__balance.nc + rows: + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralVorDivToGridWind + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 4 + variable: + - air_temperature +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/error_covariance_training_bifourier_6/%MPI%_dirac_%id% +test: + reference filename: testref/error_covariance_training_bifourier_6.ref diff --git a/test/testinput/error_covariance_training_bifourier_7.yaml b/test/testinput/error_covariance_training_bifourier_7.yaml new file mode 100644 index 000000000..48094d4d2 --- /dev/null +++ b/test/testinput/error_covariance_training_bifourier_7.yaml @@ -0,0 +1,116 @@ +# Iterative calibration of a full bifourier error covariance matrix, with a spectral filtering of covariances +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + iterative ensemble loading: true + ensemble: + members from template: + template: + date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bifourier/_MPI_-_OMP__member_%mem% + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + pattern: '%mem%' + nmembers: 25 + zero padding: 6 + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierCovariance + calibration: + filtering scale: 4.0 + write: + output file: testdata/error_covariance_training_bifourier_6/_MPI_-_OMP__covariance.nc + write covariance: true + saber outer blocks: + - saber block name: BifourierAromeBalance + calibration: + filtering scale: 4.0 + write: + output file: testdata/error_covariance_training_bifourier_6/_MPI_-_OMP__balance.nc + rows: + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralVorDivToGridWind + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 4 + variable: + - air_temperature +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/error_covariance_training_bifourier_7/%MPI%_dirac_%id% +test: + reference filename: testref/error_covariance_training_bifourier_7.ref diff --git a/test/testinput/dirac_bifourier_splittps.yaml b/test/testinput/error_covariance_training_bifourier_8.yaml similarity index 53% rename from test/testinput/dirac_bifourier_splittps.yaml rename to test/testinput/error_covariance_training_bifourier_8.yaml index 9225901ad..46d0541ed 100644 --- a/test/testinput/dirac_bifourier_splittps.yaml +++ b/test/testinput/error_covariance_training_bifourier_8.yaml @@ -1,4 +1,4 @@ -# Dirac test for the BifourierSplitTPs block, forward and backward +# Calibration of the covariance block with user-specified values geometry: function space: StructuredColumns grid: @@ -18,41 +18,42 @@ geometry: - variables: - air_temperature levels: 10 - - variables: - - log_of_air_pressure_at_surface - levels: 1 - - variables: - - air_temperature_and_log_of_air_pressure_at_surface - levels: 11 - latitude south to north: false background: date: 2010-01-01T12:00:00Z state variables: - air_temperature - - log_of_air_pressure_at_surface background error: covariance model: SABER adjoint test: true square-root test: true inverse test: true saber central block: - saber block name: BifourierID + saber block name: BifourierCovariance + calibration: + profiles: + - variable: air_temperature + horizontal length-scales: [30.0e3, 28.0e3, 26.0e3, 24.0e3, 22.0e3, 20.0e3, 18.0e3, 16.0e3, 14.0e3, 12.0e3] + vertical length-scale: 4.0 + write: + output file: testdata/error_covariance_training_bifourier_6/_MPI_-_OMP__covariance.nc + write covariance: true saber outer blocks: - - saber block name: BifourierSplitTPs - backward mode: true - - saber block name: BifourierSplitTPs - saber block name: BifourierSpectralToGrid dirac: lon: - 9.9058 + - 9.9058 lat: - 56.3223 + - 56.3223 level: - 1 + - 10 variable: - - log_of_air_pressure_at_surface + - air_temperature + - air_temperature output dirac: mpi pattern: '%MPI%' - filepath: testdata/dirac_bifourier_splittps/%MPI%_dirac_%id% + filepath: testdata/error_covariance_training_bifourier_8/%MPI%_dirac_%id% test: - reference filename: testref/dirac_bifourier_splittps.ref + reference filename: testref/error_covariance_training_bifourier_8.ref diff --git a/test/testinput/error_covariance_training_bifourier_covariance_1.yaml b/test/testinput/error_covariance_training_bifourier_covariance_1.yaml new file mode 100644 index 000000000..c5781d9c3 --- /dev/null +++ b/test/testinput/error_covariance_training_bifourier_covariance_1.yaml @@ -0,0 +1,86 @@ +# Direct calibration of a bifourier covariance matrix +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + ensemble: + members from template: + template: + date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bifourier_covariance/_MPI_-_OMP__member_%mem% + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + pattern: '%mem%' + nmembers: 25 + zero padding: 6 + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierCovariance + calibration: {} + write: + output file: testdata/error_covariance_training_bifourier_covariance_1/_MPI_-_OMP__covariance.nc + write covariance: true + saber outer blocks: + - saber block name: BifourierSpectralVorDivToGridWind + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 4 + variable: + - air_temperature_and_log_of_air_pressure_at_surface +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/error_covariance_training_bifourier_covariance_1/%MPI%_dirac_%id% +test: + reference filename: testref/error_covariance_training_bifourier_covariance_1.ref diff --git a/test/testinput/error_covariance_training_bifourier_covariance_2.yaml b/test/testinput/error_covariance_training_bifourier_covariance_2.yaml new file mode 100644 index 000000000..6d71945be --- /dev/null +++ b/test/testinput/error_covariance_training_bifourier_covariance_2.yaml @@ -0,0 +1,88 @@ +# Direct calibration of a bifourier covariance matrix using positive subellipses half-width +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + ensemble: + members from template: + template: + date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bifourier_covariance/_MPI_-_OMP__member_%mem% + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + pattern: '%mem%' + nmembers: 25 + zero padding: 6 + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierCovariance + calibration: {} + write: + output file: testdata/error_covariance_training_bifourier_covariance_2/_MPI_-_OMP__covariance.nc + write covariance: true + saber outer blocks: + - saber block name: BifourierSpectralVorDivToGridWind + transform: + sub-ellipses half-width: 1.5 + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 4 + variable: + - air_temperature_and_log_of_air_pressure_at_surface +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/error_covariance_training_bifourier_covariance_2/%MPI%_dirac_%id% +test: + reference filename: testref/error_covariance_training_bifourier_covariance_2.ref diff --git a/test/testinput/error_covariance_training_bifourier_ectrans_1.yaml b/test/testinput/error_covariance_training_bifourier_ectrans_1.yaml new file mode 100644 index 000000000..ffe32f930 --- /dev/null +++ b/test/testinput/error_covariance_training_bifourier_ectrans_1.yaml @@ -0,0 +1,115 @@ +# Direct calibration of a full bifourier error covariance matrix +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + iterative ensemble loading: true + ensemble: + members from template: + template: + date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bifourier/_MPI_-_OMP__member_%mem% + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + pattern: '%mem%' + nmembers: 25 + zero padding: 6 + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierCovariance + calibration: {} + write: + output file: testdata/error_covariance_training_bifourier_ectrans_1/_MPI_-_OMP__covariance.nc + saber outer blocks: + - saber block name: BifourierAromeBalance + calibration: {} + write: + output file: testdata/error_covariance_training_bifourier_ectrans_1/_MPI_-_OMP__balance.nc + rows: + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralVorDivToGridWind + transform: + fft backend: ectrans + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 +dirac: + lon: + - 9.9058 + lat: + - 56.3223 + level: + - 4 + variable: + - air_temperature +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/error_covariance_training_bifourier_ectrans_1/%MPI%_dirac_%id% +test: + reference filename: testref/error_covariance_training_bifourier_ectrans_1.ref diff --git a/test/testinput/error_covariance_training_bump_vbal_1.yaml b/test/testinput/error_covariance_training_bump_vbal_1.yaml index 18ee8a2b8..68c9518c8 100644 --- a/test/testinput/error_covariance_training_bump_vbal_1.yaml +++ b/test/testinput/error_covariance_training_bump_vbal_1.yaml @@ -32,7 +32,6 @@ background error: filepath: testdata/error_covariance_training_bump_vbal_1/_MPI_-_OMP__unbalanced_member saber central block: saber block name: ID - calibration: {} saber outer blocks: - saber block name: BUMP_VerticalBalance calibration: diff --git a/test/testinput/randomization_bifourier.yaml b/test/testinput/randomization_bifourier.yaml new file mode 100644 index 000000000..ae137737d --- /dev/null +++ b/test/testinput/randomization_bifourier.yaml @@ -0,0 +1,88 @@ +# Randomization with a full bifourier error covariance matrix +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - log_of_air_pressure_at_surface + levels: 1 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierAromeCovariance + read: + input file: testdata/bifourier_covariance.nc + saber outer blocks: + - saber block name: BifourierAromeBalance + read: + input file: testdata/bifourier_balance.nc + rows: + - output variable: air_upward_absolute_vorticity + - output variable: balanced_air_pressure + - output variable: air_horizontal_divergence + input variables: [balanced_air_pressure] + - output variable: air_temperature_and_log_of_air_pressure_at_surface + input variables: [balanced_air_pressure, air_horizontal_divergence] + - output variable: water_vapor_mixing_ratio_wrt_moist_air + input variables: [balanced_air_pressure, air_horizontal_divergence, air_temperature_and_log_of_air_pressure_at_surface] + balanced air pressure parameters from grid: true + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - air_temperature + - log_of_air_pressure_at_surface + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + - saber block name: BifourierSpectralVorDivToGridWind + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature + - log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 + randomization size: 25 +output states: + filepath: testdata/randomization_bifourier/_MPI_-_OMP__member +test: + reference filename: testref/randomization_bifourier.ref diff --git a/test/testinput/randomization_bifourier_covariance.yaml b/test/testinput/randomization_bifourier_covariance.yaml new file mode 100644 index 000000000..a64ca400c --- /dev/null +++ b/test/testinput/randomization_bifourier_covariance.yaml @@ -0,0 +1,62 @@ +# Randomization with a partial bifourier error covariance matrix +geometry: + function space: StructuredColumns + grid: + type : regional + nx : 73 + ny : 51 + dx : 2.5e3 + dy : 2.5e3 + lonlat(centre) : [9.9, 56.3] + projection : + type : lambert_conformal_conic + latitude0 : 56.3 + longitude0 : 0.0 + y_numbering: 1 + partitioner: checkerboard + groups: + - variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - water_vapor_mixing_ratio_wrt_moist_air + levels: 10 + - variables: + - air_temperature_and_log_of_air_pressure_at_surface + levels: 11 +background: + date: 2010-01-01T12:00:00Z + state variables: + - geographical_x_wind + - geographical_y_wind + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air +background error: + covariance model: SABER + adjoint test: true + square-root test: true + inverse test: true + saber central block: + saber block name: BifourierAromeCovariance + read: + input file: testdata/bifourier_covariance.nc + saber outer blocks: + - saber block name: BifourierSpectralVorDivToGridWind + active variables: + - air_upward_absolute_vorticity + - air_horizontal_divergence + - geographical_x_wind + - geographical_y_wind + - air_temperature_and_log_of_air_pressure_at_surface + - water_vapor_mixing_ratio_wrt_moist_air + biperiodization: + x inner extension: 7 + y inner extension: 5 + x outer extension: 7 + y outer extension: 5 + randomization size: 25 +output states: + filepath: testdata/randomization_bifourier_covariance/_MPI_-_OMP__member +test: + reference filename: testref/randomization_bifourier_covariance.ref diff --git a/test/testlist/saber_test_tier1-bifourier-ectrans.txt b/test/testlist/saber_test_tier1-bifourier-ectrans.txt new file mode 100644 index 000000000..7c6b79b1b --- /dev/null +++ b/test/testlist/saber_test_tier1-bifourier-ectrans.txt @@ -0,0 +1,4 @@ +dirac_bifourier_ectrans +dirac_bifourier_vordivtouv_ectrans_1 +dirac_bifourier_vordivtouv_ectrans_2 +error_covariance_training_bifourier_ectrans_1 diff --git a/test/testlist/saber_test_tier1-bifourier.txt b/test/testlist/saber_test_tier1-bifourier.txt index f6d4e997d..ce918530d 100644 --- a/test/testlist/saber_test_tier1-bifourier.txt +++ b/test/testlist/saber_test_tier1-bifourier.txt @@ -1,13 +1,29 @@ -convertcov_bifourier_balance -convertcov_bifourier_covariance +convertcov_bifourier_balance_1 +convertcov_bifourier_balance_2 +convertcov_bifourier_balance_3 +convertcov_bifourier_covariance_1 +convertcov_bifourier_covariance_2 +convertcov_bifourier_covariance_3 +error_covariance_training_bifourier_covariance_1 +error_covariance_training_bifourier_covariance_2 +error_covariance_training_bifourier_1 +error_covariance_training_bifourier_2 +error_covariance_training_bifourier_3 +error_covariance_training_bifourier_4 +error_covariance_training_bifourier_5 +error_covariance_training_bifourier_6 +error_covariance_training_bifourier_7 +error_covariance_training_bifourier_8 dirac_bifourier_balance_1 dirac_bifourier_balance_2 -dirac_bifourier_splittps +dirac_bifourier_balance_3 dirac_bifourier_covariance_1 dirac_bifourier_covariance_2 dirac_bifourier_covariance_3 -dirac_bifourier_full_spectral +dirac_bifourier dirac_bifourier_gridtospectral dirac_bifourier_vordivtouv_1 dirac_bifourier_vordivtouv_2 dirac_bifourier_vordivtouv_3 +randomization_bifourier_covariance +randomization_bifourier diff --git a/test/testref/convertcov_bifourier_balance_1.ref b/test/testref/convertcov_bifourier_balance_1.ref new file mode 100644 index 000000000..6b8d946ee --- /dev/null +++ b/test/testref/convertcov_bifourier_balance_1.ref @@ -0,0 +1,77 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - air_horizontal_divergence (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-04 + + stddev = 1.6389038743052555e-02 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralToGrid passed +Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierID passed +Square-root test for block BifourierID passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = -1.4508261826054790e+04 + + max = 1.4038995439242774e+04 + + mean = 9.9999999999907468e-02 + + stddev = 2.3489559471196440e+03 + - air_horizontal_divergence (10 levels): + + min = -2.0201757991444223e+05 + + max = 1.0053003032753203e+05 + + mean = 1.0000000002853121e-01 + + stddev = 4.6333332574651715e+04 + - air_temperature (10 levels): + + min = -1.2357841483690619e+10 + + max = 1.1035868802069090e+10 + + mean ~ 0 + + stddev = 3.0235128985460033e+09 + - log_of_air_pressure_at_surface (1 levels): + + min = -1.1649819520862186e+07 + + max = 2.6881556074599214e+07 + + mean = 9.9999999341645240e-01 + + stddev = 8.9234801080148462e+06 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.0192165069745528e+06 + + max = 3.7689297459882582e+06 + + mean = 1.0000000104940768e-01 + + stddev = 1.3386463103391572e+06 diff --git a/test/testref/convertcov_bifourier_balance_2.ref b/test/testref/convertcov_bifourier_balance_2.ref new file mode 100644 index 000000000..8bf3a962c --- /dev/null +++ b/test/testref/convertcov_bifourier_balance_2.ref @@ -0,0 +1,84 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - air_horizontal_divergence (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-04 + + stddev = 1.6389038743052555e-02 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralToGrid passed +Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) +Regression norms: +- air_horizontal_divergence from balanced_air_pressure: 2.1918086032475726e-04 +- air_temperature_and_log_of_air_pressure_at_surface from balanced_air_pressure: 1.5654598599293770e+00 +- air_temperature_and_log_of_air_pressure_at_surface from air_horizontal_divergence: 1.2814560072106249e+06 +- water_vapor_mixing_ratio_wrt_moist_air from balanced_air_pressure: 5.8990054088852079e-04 +- water_vapor_mixing_ratio_wrt_moist_air from air_horizontal_divergence: 4.7681841513515462e+02 +- water_vapor_mixing_ratio_wrt_moist_air from air_temperature_and_log_of_air_pressure_at_surface: 7.9170837364445719e+00 +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierID passed +Square-root test for block BifourierID passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = -1.4508261826054790e+04 + + max = 1.4038995439242774e+04 + + mean = 9.9999999999907468e-02 + + stddev = 2.3489559471196440e+03 + - air_horizontal_divergence (10 levels): + + min = -2.0201757991444223e+05 + + max = 1.0053003032753203e+05 + + mean = 1.0000000002853121e-01 + + stddev = 4.6333332574651715e+04 + - air_temperature (10 levels): + + min = -1.2357841483690619e+10 + + max = 1.1035868802069090e+10 + + mean ~ 0 + + stddev = 3.0235128985460033e+09 + - log_of_air_pressure_at_surface (1 levels): + + min = -1.1649819520862186e+07 + + max = 2.6881556074599214e+07 + + mean = 9.9999999341645240e-01 + + stddev = 8.9234801080148462e+06 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.0192165069745528e+06 + + max = 3.7689297459882582e+06 + + mean = 1.0000000104940768e-01 + + stddev = 1.3386463103391572e+06 diff --git a/test/testref/convertcov_bifourier_balance_3.ref b/test/testref/convertcov_bifourier_balance_3.ref new file mode 100644 index 000000000..8bf3a962c --- /dev/null +++ b/test/testref/convertcov_bifourier_balance_3.ref @@ -0,0 +1,84 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - air_horizontal_divergence (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-04 + + stddev = 1.6389038743052555e-02 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralToGrid passed +Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) +Regression norms: +- air_horizontal_divergence from balanced_air_pressure: 2.1918086032475726e-04 +- air_temperature_and_log_of_air_pressure_at_surface from balanced_air_pressure: 1.5654598599293770e+00 +- air_temperature_and_log_of_air_pressure_at_surface from air_horizontal_divergence: 1.2814560072106249e+06 +- water_vapor_mixing_ratio_wrt_moist_air from balanced_air_pressure: 5.8990054088852079e-04 +- water_vapor_mixing_ratio_wrt_moist_air from air_horizontal_divergence: 4.7681841513515462e+02 +- water_vapor_mixing_ratio_wrt_moist_air from air_temperature_and_log_of_air_pressure_at_surface: 7.9170837364445719e+00 +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierID passed +Square-root test for block BifourierID passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = -1.4508261826054790e+04 + + max = 1.4038995439242774e+04 + + mean = 9.9999999999907468e-02 + + stddev = 2.3489559471196440e+03 + - air_horizontal_divergence (10 levels): + + min = -2.0201757991444223e+05 + + max = 1.0053003032753203e+05 + + mean = 1.0000000002853121e-01 + + stddev = 4.6333332574651715e+04 + - air_temperature (10 levels): + + min = -1.2357841483690619e+10 + + max = 1.1035868802069090e+10 + + mean ~ 0 + + stddev = 3.0235128985460033e+09 + - log_of_air_pressure_at_surface (1 levels): + + min = -1.1649819520862186e+07 + + max = 2.6881556074599214e+07 + + mean = 9.9999999341645240e-01 + + stddev = 8.9234801080148462e+06 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.0192165069745528e+06 + + max = 3.7689297459882582e+06 + + mean = 1.0000000104940768e-01 + + stddev = 1.3386463103391572e+06 diff --git a/test/testref/convertcov_bifourier_covariance.ref b/test/testref/convertcov_bifourier_covariance_1.ref similarity index 64% rename from test/testref/convertcov_bifourier_covariance.ref rename to test/testref/convertcov_bifourier_covariance_1.ref index 614777268..10121a29c 100644 --- a/test/testref/convertcov_bifourier_covariance.ref +++ b/test/testref/convertcov_bifourier_covariance_1.ref @@ -26,42 +26,39 @@ Input Dirac increment: - Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km - Mean latitude: 5.6289831946322792e+01 deg - Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 - Direct-inverse test passed - Inverse-direct test passed - Parseval identity test passed -- Adjoint test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed - Derivatives / direct Laplacian consistency test passed Adjoint test for block BifourierSpectralToGrid passed -- vorVertCov: 4.5414267349673046e-19 -- divuVertCov: 2.1548846210808361e-19 -- tPsuVertCov: 7.4051526110127950e-03 -- quVertCov: 5.9747335707837516e-15 -Adjoint test for block BifourierCovariance passed -Square-root test for block BifourierCovariance passed +Adjoint test for block BifourierAromeCovariance passed +Square-root test for block BifourierAromeCovariance passed Covariance(SABER) * Increment: - Valid time: 2010-01-01T12:00:00Z Geometry: structured [3723] Fields: - air_upward_absolute_vorticity (10 levels): - + min = -6.8104850345376157e-11 - + max = 1.0355880483436708e-09 + + min = -3.9997053364313195e-11 + + max = 5.5329603214293043e-10 + mean ~ 0 - + stddev = 1.2886943098971443e-11 + + stddev = 6.5281126673378689e-12 - air_horizontal_divergence (10 levels): - + min = -4.0819833615634788e-11 - + max = 4.9896228579636901e-10 + + min = -2.8488458312699573e-11 + + max = 3.2305862921761320e-10 + mean ~ 0 - + stddev = 5.9208712626493634e-12 + + stddev = 3.7174077522049670e-12 - air_temperature_and_log_of_air_pressure_at_surface (11 levels): - + min = -6.9272889504143479e-06 - + max = 6.4484957503523551e-07 - + mean = -4.7561868173668380e-08 - + stddev = 3.4069674359127481e-07 + + min = -8.5375673983992523e-06 + + max = 6.3892158810947996e-07 + + mean = 5.7469798126267869e-08 + + stddev = 3.2134350144332136e-07 - water_vapor_mixing_ratio_wrt_moist_air (10 levels): - + min = -4.1667621991827320e-09 - + max = 7.9003792552401004e-08 - + mean = 2.8981704477217596e-10 - + stddev = 2.3185774389295988e-09 + + min = -1.4228820253838982e-09 + + max = 3.6863836528339586e-08 + + mean = 4.3367304218866932e-11 + + stddev = 8.0479983797995087e-10 diff --git a/test/testref/convertcov_bifourier_covariance_2.ref b/test/testref/convertcov_bifourier_covariance_2.ref new file mode 100644 index 000000000..ac975fe75 --- /dev/null +++ b/test/testref/convertcov_bifourier_covariance_2.ref @@ -0,0 +1,77 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - air_horizontal_divergence (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.4418235538300004e-05 + + stddev = 4.9414811077572087e-03 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralToGrid passed +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9202692301777849e-01 + + standard-deviation: 6.5009836490167783e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8312571043873865e-01 + + standard-deviation: 5.6990166440000530e-05 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.6909265752786689e-01 + + standard-deviation: 8.6202056358169210e-01 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.2538968703821552e-01 + + standard-deviation: 5.1329425500907036e-04 +Adjoint test for block BifourierAromeCovariance passed +Square-root test for block BifourierAromeCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = -3.9997053364313286e-11 + + max = 5.5329603214293125e-10 + + mean ~ 0 + + stddev = 6.5281126673378786e-12 + - air_horizontal_divergence (10 levels): + + min = -2.8488458312699635e-11 + + max = 3.2305862921761366e-10 + + mean ~ 0 + + stddev = 3.7174077522049734e-12 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -8.5375673983992726e-06 + + max = 6.3892158810947943e-07 + + mean = 5.7469798126268028e-08 + + stddev = 3.2134350144332152e-07 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -1.4228820253838993e-09 + + max = 3.6863836528339639e-08 + + mean = 4.3367304218866971e-11 + + stddev = 8.0479983797995201e-10 diff --git a/test/testref/convertcov_bifourier_covariance_3.ref b/test/testref/convertcov_bifourier_covariance_3.ref new file mode 100644 index 000000000..85a84020c --- /dev/null +++ b/test/testref/convertcov_bifourier_covariance_3.ref @@ -0,0 +1,77 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - air_horizontal_divergence (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.4418235538300004e-05 + + stddev = 4.9414811077572087e-03 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralToGrid passed +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9202692301777843e-01 + + standard-deviation: 6.5009836490167796e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8312571043873863e-01 + + standard-deviation: 5.6990166440000530e-05 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.6909265752786694e-01 + + standard-deviation: 8.6202056358169210e-01 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.2538968703821552e-01 + + standard-deviation: 5.1329425500907036e-04 +Adjoint test for block BifourierAromeCovariance passed +Square-root test for block BifourierAromeCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = -3.9997053364313298e-11 + + max = 5.5329603214293125e-10 + + mean ~ 0 + + stddev = 6.5281126673378786e-12 + - air_horizontal_divergence (10 levels): + + min = -2.8488458312699661e-11 + + max = 3.2305862921761382e-10 + + mean ~ 0 + + stddev = 3.7174077522049751e-12 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -8.5375673983992743e-06 + + max = 6.3892158810947985e-07 + + mean = 5.7469798126267995e-08 + + stddev = 3.2134350144332152e-07 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -1.4228820253838984e-09 + + max = 3.6863836528339639e-08 + + mean = 4.3367304218866945e-11 + + stddev = 8.0479983797995180e-10 diff --git a/test/testref/dirac_bifourier_full_spectral.ref b/test/testref/dirac_bifourier.ref similarity index 54% rename from test/testref/dirac_bifourier_full_spectral.ref rename to test/testref/dirac_bifourier.ref index 599275ecb..e347c49f4 100644 --- a/test/testref/dirac_bifourier_full_spectral.ref +++ b/test/testref/dirac_bifourier.ref @@ -22,47 +22,59 @@ Input Dirac increment: - xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] - yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] Outer grid size: 3723 -- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] -- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] -Outer grid size: 3723 +Adjoint test for block Biperiodization passed +Inner inverse test for block Biperiodization passed: U Uinv (U x) == (U x) +Outer inverse test for block Biperiodization passed: Uinv U (Uinv x) == (Uinv x) - Regional grid size: 73x51 - Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km - Mean latitude: 5.6289831946322792e+01 deg - Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 - Direct-inverse test passed - Inverse-direct test passed - Parseval identity test passed -- Adjoint test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed - Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierAromeCovariance passed +Square-root test for block BifourierAromeCovariance passed Covariance(SABER) * Increment: - Valid time: 2010-01-01T12:00:00Z Geometry: structured [3723] Fields: - geographical_x_wind (10 levels): - + min = -1.4339583700199378e-03 - + max = 1.4339584951944958e-03 - + mean = 3.4837419207031867e-08 - + stddev = 1.0892378706547147e-04 + + min = -4.8758267625730837e-04 + + max = 4.8758269755709636e-04 + + mean = 7.7610225540131166e-08 + + stddev = 1.2074694185161375e-04 - geographical_y_wind (10 levels): - + min = -1.4552594823439963e-03 - + max = 1.4552586039184399e-03 - + mean = 8.9125905063764296e-08 - + stddev = 1.1205285066806075e-04 + + min = -4.9875807461742950e-04 + + max = 4.9875792412800888e-04 + + mean = -3.9785578920951780e-08 + + stddev = 1.0025669490806806e-04 - air_temperature (10 levels): - + min = -4.0018428673275078e-03 - + max = 6.8273241818768204e-02 - + mean = 2.7233184781826379e-04 - + stddev = 2.1789874172456615e-03 + + min = -5.1340230885500099e-03 + + max = 8.4431734952200840e-02 + + mean = 1.8676565320962566e-04 + + stddev = 3.1221611795713981e-03 - log_of_air_pressure_at_surface (1 levels): - + min = -9.6146532959821594e-06 - + max = 8.7227994060707780e-07 - + mean = -1.0139811883941386e-07 - + stddev = 5.8330603392065161e-07 + + min = -7.0870712822661497e-06 + + max = 1.5383528799813379e-06 + + mean = 4.8075964194695064e-08 + + stddev = 7.4412989602294107e-07 - water_vapor_mixing_ratio_wrt_moist_air (10 levels): - + min = -1.9027851500363250e-05 - + max = 3.6132207417606268e-06 - + mean = 2.3817993996993099e-09 - + stddev = 8.6835014162664768e-07 + + min = -9.5218129829356541e-07 + + max = 6.8621703500169453e-06 + + mean = 5.7681742085596905e-10 + + stddev = 3.5342015127105225e-07 diff --git a/test/testref/dirac_bifourier_balance_1.ref b/test/testref/dirac_bifourier_balance_1.ref index 482b4655b..6b8d946ee 100644 --- a/test/testref/dirac_bifourier_balance_1.ref +++ b/test/testref/dirac_bifourier_balance_1.ref @@ -12,11 +12,14 @@ Input Dirac increment: + max = 1.0000000000000000e+00 + mean = 2.6860059092130003e-05 + stddev = 5.1826691088793144e-03 - - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - log_of_air_pressure_at_surface (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 2.4418235538300004e-05 - + stddev = 4.9414811077572087e-03 + + mean = 2.6860059092130003e-04 + + stddev = 1.6389038743052555e-02 - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 @@ -26,26 +29,21 @@ Input Dirac increment: - Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km - Mean latitude: 5.6289831946322792e+01 deg - Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 - Direct-inverse test passed - Inverse-direct test passed - Parseval identity test passed -- Adjoint test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed - Derivatives / direct Laplacian consistency test passed Adjoint test for block BifourierSpectralToGrid passed Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) -Adjoint test for block BifourierVorToPb passed -Inner inverse test for block BifourierVorToPb passed: U Uinv (U x) == (U x) -Outer inverse test for block BifourierVorToPb passed: Uinv U (Uinv x) == (Uinv x) -Adjoint test for block BifourierBalance passed -Inner inverse test for block BifourierBalance passed: U Uinv (U x) == (U x) -Outer inverse test for block BifourierBalance passed: Uinv U (Uinv x) == (Uinv x) -Adjoint test for block BifourierVorToPb passed -Inner inverse test for block BifourierVorToPb passed: U Uinv (U x) == (U x) -Outer inverse test for block BifourierVorToPb passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) Adjoint test for block BifourierID passed Square-root test for block BifourierID passed Covariance(SABER) * Increment: @@ -53,22 +51,27 @@ Covariance(SABER) * Increment: Geometry: structured [3723] Fields: - air_upward_absolute_vorticity (10 levels): - + min = -1.1267022184890865e+00 - + max = 1.5423921212612668e+00 - + mean = 2.6860059092133795e-05 - + stddev = 3.9994721579386758e-02 + + min = -1.4508261826054790e+04 + + max = 1.4038995439242774e+04 + + mean = 9.9999999999907468e-02 + + stddev = 2.3489559471196440e+03 - air_horizontal_divergence (10 levels): - + min = -9.2005338897735311e-01 - + max = 2.2612563153249150e+00 - + mean = 2.6860059092177674e-05 - + stddev = 9.2273421726565663e-02 - - air_temperature_and_log_of_air_pressure_at_surface (11 levels): - + min = -2.4545959036098633e+04 - + max = 9.7848814895902888e+03 - + mean = 2.4418232969080431e-05 - + stddev = 3.9942583113142005e+03 + + min = -2.0201757991444223e+05 + + max = 1.0053003032753203e+05 + + mean = 1.0000000002853121e-01 + + stddev = 4.6333332574651715e+04 + - air_temperature (10 levels): + + min = -1.2357841483690619e+10 + + max = 1.1035868802069090e+10 + + mean ~ 0 + + stddev = 3.0235128985460033e+09 + - log_of_air_pressure_at_surface (1 levels): + + min = -1.1649819520862186e+07 + + max = 2.6881556074599214e+07 + + mean = 9.9999999341645240e-01 + + stddev = 8.9234801080148462e+06 - water_vapor_mixing_ratio_wrt_moist_air (10 levels): - + min = -2.3806796808866082e+01 - + max = 1.1276214139675341e+02 - + mean = 2.6860059102208049e-05 - + stddev = 1.0460793444929793e+01 + + min = -8.0192165069745528e+06 + + max = 3.7689297459882582e+06 + + mean = 1.0000000104940768e-01 + + stddev = 1.3386463103391572e+06 diff --git a/test/testref/dirac_bifourier_balance_2.ref b/test/testref/dirac_bifourier_balance_2.ref index f8c16c1b8..42b270153 100644 --- a/test/testref/dirac_bifourier_balance_2.ref +++ b/test/testref/dirac_bifourier_balance_2.ref @@ -1,66 +1,77 @@ Input Dirac increment: - Valid time: 2010-01-01T12:00:00Z - Geometry: structured [1872] + Geometry: structured [3723] Fields: - air_upward_absolute_vorticity (10 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.3418803418803419e-05 - + stddev = 7.3088168275599876e-03 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 - air_horizontal_divergence (10 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.3418803418803419e-05 - + stddev = 7.3088168275599876e-03 - - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - log_of_air_pressure_at_surface (1 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 4.8562548562548563e-05 - + stddev = 6.9686834167248047e-03 + + mean = 2.6860059092130003e-04 + + stddev = 1.6389038743052555e-02 - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.3418803418803419e-05 - + stddev = 7.3088168275599876e-03 -- xspace: LocalConfiguration[root={type => linear , start => 5.4495971254055749e+05 , end => 6.7245971254055749e+05 , N => 52 , endpoint => true}] -- yspace: LocalConfiguration[root={type => linear , start => 7.6919900607317686e+01 , end => 8.7576919900607318e+04 , N => 36 , endpoint => true}] -Outer grid size: 1872 -- xspace: LocalConfiguration[root={type => linear , start => 5.4495971254055749e+05 , end => 7.2495971254055749e+05 , N => 73 , endpoint => true}] -- yspace: LocalConfiguration[root={type => linear , start => 7.6919900607317686e+01 , end => 1.2507691990060732e+05 , N => 51 , endpoint => true}] -Info : Inner grid size: 3723 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 - Regional grid size: 73x51 - Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km -- Mean latitude: 5.6421911446117591e+01 deg +- Mean latitude: 5.6289831946322792e+01 deg - Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 - Direct-inverse test passed - Inverse-direct test passed - Parseval identity test passed -- Adjoint test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed - Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralToGrid passed +Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierID passed +Square-root test for block BifourierID passed Covariance(SABER) * Increment: - Valid time: 2010-01-01T12:00:00Z - Geometry: structured [1872] + Geometry: structured [3723] Fields: - air_upward_absolute_vorticity (10 levels): - + min = -7.3164065198568162e-02 - + max = 7.0069765993590338e-01 - + mean = 5.1472057751694653e-05 - + stddev = 6.1101052289613345e-03 + + min = -1.4508261826054228e+04 + + max = 1.4038995439242231e+04 + + mean = 9.9999999999822453e-02 + + stddev = 2.3489559471195530e+03 - air_horizontal_divergence (10 levels): - + min = -3.3855047469424016e-01 - + max = 9.3059319267751239e-01 - + mean = 2.6291156404978440e-03 - + stddev = 5.0020272796363487e-02 - - air_temperature_and_log_of_air_pressure_at_surface (11 levels): - + min = -2.4724453343443245e+04 - + max = 4.8940571866904747e+03 - + mean = -1.7233937277218424e+03 - + stddev = 3.2044951935428708e+03 + + min = -2.0201757991442701e+05 + + max = 1.0053003032752436e+05 + + mean = 1.0000000001401155e-01 + + stddev = 4.6333332574647829e+04 + - air_temperature (10 levels): + + min = -1.2357841483689671e+10 + + max = 1.1035868802068279e+10 + + mean ~ 0 + + stddev = 3.0235128985457573e+09 + - log_of_air_pressure_at_surface (1 levels): + + min = -1.1649819520861393e+07 + + max = 2.6881556074597500e+07 + + mean = 9.9999999451913035e-01 + + stddev = 8.9234801080142520e+06 - water_vapor_mixing_ratio_wrt_moist_air (10 levels): - + min = -9.2775154379568416e+00 - + max = 6.0464452634813185e+01 - + mean = 3.6224752923744488e+00 - + stddev = 5.3889247616845752e+00 + + min = -8.0192165069739809e+06 + + max = 3.7689297459879532e+06 + + mean = 1.0000000102633098e-01 + + stddev = 1.3386463103390560e+06 diff --git a/test/testref/dirac_bifourier_balance_3.ref b/test/testref/dirac_bifourier_balance_3.ref new file mode 100644 index 000000000..7fa401f70 --- /dev/null +++ b/test/testref/dirac_bifourier_balance_3.ref @@ -0,0 +1,86 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [1872] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 5.3418803418803419e-05 + + stddev = 7.3088168275599876e-03 + - air_horizontal_divergence (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 5.3418803418803419e-05 + + stddev = 7.3088168275599876e-03 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 5.3418803418803424e-04 + + stddev = 2.3112508176051736e-02 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 5.3418803418803419e-05 + + stddev = 7.3088168275599876e-03 +- xspace: LocalConfiguration[root={type => linear , start => 5.4495971254055749e+05 , end => 6.7245971254055749e+05 , N => 52 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => 7.6919900607317686e+01 , end => 8.7576919900607318e+04 , N => 36 , endpoint => true}] +Outer grid size: 1872 +- xspace: LocalConfiguration[root={type => linear , start => 5.4495971254055749e+05 , end => 7.2495971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => 7.6919900607317686e+01 , end => 1.2507691990060732e+05 , N => 51 , endpoint => true}] +Info : Inner grid size: 3723 +Adjoint test for block Biperiodization passed +Inner inverse test for block Biperiodization passed: U Uinv (U x) == (U x) +Outer inverse test for block Biperiodization passed: Uinv U (Uinv x) == (Uinv x) +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6421911446117591e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralToGrid passed +Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierID passed +Square-root test for block BifourierID passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [1872] + Fields: + - air_upward_absolute_vorticity (10 levels): + + min = -9.9302490880956179e+02 + + max = 1.1018852192599121e+04 + + mean = 8.0898653248138497e-01 + + stddev = 9.3536414093170436e+01 + - air_horizontal_divergence (10 levels): + + min = -8.1144396798071093e+03 + + max = 9.7725977588141104e+03 + + mean = 3.7109095705565437e+01 + + stddev = 1.4447876889688850e+03 + - air_temperature (10 levels): + + min = -6.9905190432577908e+08 + + max = 2.5338088054928975e+09 + + mean = 3.1440075357906771e+08 + + stddev = 5.0724552738395780e+08 + - log_of_air_pressure_at_surface (1 levels): + + min = -9.1857900938669581e+05 + + max = 4.5103070484552290e+06 + + mean = 5.7856308384850260e+05 + + stddev = 1.1625441442490732e+06 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.9648407231480745e+05 + + max = 3.9599421567466407e+05 + + mean = -2.3825165462862456e+04 + + stddev = 1.8311672281413534e+05 diff --git a/test/testref/dirac_bifourier_covariance_1.ref b/test/testref/dirac_bifourier_covariance_1.ref index 357125162..1dbc162ef 100644 --- a/test/testref/dirac_bifourier_covariance_1.ref +++ b/test/testref/dirac_bifourier_covariance_1.ref @@ -26,15 +26,18 @@ Input Dirac increment: - Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km - Mean latitude: 5.6289831946322792e+01 deg - Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 - Direct-inverse test passed - Inverse-direct test passed - Parseval identity test passed -- Adjoint test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed - Derivatives / direct Laplacian consistency test passed Adjoint test for block BifourierSpectralToGrid passed +Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) Adjoint test for block BifourierCovariance passed Square-root test for block BifourierCovariance passed Covariance(SABER) * Increment: @@ -42,22 +45,22 @@ Covariance(SABER) * Increment: Geometry: structured [3723] Fields: - air_upward_absolute_vorticity (10 levels): - + min = -6.8104850345376157e-11 - + max = 1.0355880483436708e-09 + + min = -3.9997053364313195e-11 + + max = 5.5329603214293043e-10 + mean ~ 0 - + stddev = 1.2886943098971443e-11 + + stddev = 6.5281126673378689e-12 - air_horizontal_divergence (10 levels): - + min = -4.0819833615634788e-11 - + max = 4.9896228579636901e-10 + + min = -2.8488458312699573e-11 + + max = 3.2305862921761320e-10 + mean ~ 0 - + stddev = 5.9208712626493634e-12 + + stddev = 3.7174077522049670e-12 - air_temperature_and_log_of_air_pressure_at_surface (11 levels): - + min = -6.9272889504143479e-06 - + max = 6.4484957503523551e-07 - + mean = -4.7561868173668380e-08 - + stddev = 3.4069674359127481e-07 + + min = -8.5375673983992523e-06 + + max = 6.3892158810947996e-07 + + mean = 5.7469798126267869e-08 + + stddev = 3.2134350144332136e-07 - water_vapor_mixing_ratio_wrt_moist_air (10 levels): - + min = -4.1667621991827320e-09 - + max = 7.9003792552401004e-08 - + mean = 2.8981704477217596e-10 - + stddev = 2.3185774389295988e-09 + + min = -1.4228820253838982e-09 + + max = 3.6863836528339586e-08 + + mean = 4.3367304218866932e-11 + + stddev = 8.0479983797995087e-10 diff --git a/test/testref/dirac_bifourier_covariance_2.ref b/test/testref/dirac_bifourier_covariance_2.ref index e31b1ed12..58552eb94 100644 --- a/test/testref/dirac_bifourier_covariance_2.ref +++ b/test/testref/dirac_bifourier_covariance_2.ref @@ -26,17 +26,22 @@ Input Dirac increment: - Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km - Mean latitude: 5.6289831946322792e+01 deg - Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 - Direct-inverse test passed - Inverse-direct test passed - Parseval identity test passed -- Adjoint test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed - Derivatives / direct Laplacian consistency test passed Adjoint test for block BifourierSpectralToGrid passed -Norm of input parameter StdDev: 4.2893947557583196e+01 +Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) +Norm of input parameter StdDev: 4.5735865796952176e+01 Adjoint test for block StdDev passed +Inner inverse test for block StdDev passed: U Uinv (U x) == (U x) +Outer inverse test for block StdDev passed: Uinv U (Uinv x) == (Uinv x) Adjoint test for block BifourierCovariance passed Square-root test for block BifourierCovariance passed Covariance(SABER) * Increment: @@ -44,22 +49,22 @@ Covariance(SABER) * Increment: Geometry: structured [3723] Fields: - air_upward_absolute_vorticity (10 levels): - + min = -6.8104850345376157e-11 - + max = 1.0355880483436708e-09 + + min = -3.9997053364313195e-11 + + max = 5.5329603214293043e-10 + mean ~ 0 - + stddev = 1.2886943098971444e-11 + + stddev = 6.5281126673378689e-12 - air_horizontal_divergence (10 levels): - + min = -4.0819833615634801e-11 - + max = 4.9896228579636901e-10 + + min = -2.8488458312699573e-11 + + max = 3.2305862921761320e-10 + mean ~ 0 - + stddev = 5.9208712626493634e-12 + + stddev = 3.7174077522049670e-12 - air_temperature_and_log_of_air_pressure_at_surface (11 levels): - + min = -6.9272889504143479e-06 - + max = 6.4484957503523562e-07 - + mean = -4.7561868173668380e-08 - + stddev = 3.4069674359127475e-07 + + min = -8.5375673983992523e-06 + + max = 6.3892158810947996e-07 + + mean = 5.7469798126267869e-08 + + stddev = 3.2134350144332136e-07 - water_vapor_mixing_ratio_wrt_moist_air (10 levels): - + min = -4.1667621991827336e-09 - + max = 7.9003792552400991e-08 - + mean = 2.8981704477217617e-10 - + stddev = 2.3185774389295992e-09 + + min = -1.4228820253838982e-09 + + max = 3.6863836528339586e-08 + + mean = 4.3367304218866932e-11 + + stddev = 8.0479983797995087e-10 diff --git a/test/testref/dirac_bifourier_covariance_3.ref b/test/testref/dirac_bifourier_covariance_3.ref index 8eba9e191..9f1c1c785 100644 --- a/test/testref/dirac_bifourier_covariance_3.ref +++ b/test/testref/dirac_bifourier_covariance_3.ref @@ -28,39 +28,48 @@ Outer grid size: 1872 - xspace: LocalConfiguration[root={type => linear , start => 5.4495971254055749e+05 , end => 7.2495971254055749e+05 , N => 73 , endpoint => true}] - yspace: LocalConfiguration[root={type => linear , start => 7.6919900607317686e+01 , end => 1.2507691990060732e+05 , N => 51 , endpoint => true}] Info : Inner grid size: 3723 +Adjoint test for block Biperiodization passed +Inner inverse test for block Biperiodization passed: U Uinv (U x) == (U x) +Outer inverse test for block Biperiodization passed: Uinv U (Uinv x) == (Uinv x) - Regional grid size: 73x51 - Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km - Mean latitude: 5.6421911446117591e+01 deg - Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 - Direct-inverse test passed - Inverse-direct test passed - Parseval identity test passed -- Adjoint test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed - Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralToGrid passed +Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed Covariance(SABER) * Increment: - Valid time: 2010-01-01T12:00:00Z Geometry: structured [1872] Fields: - air_upward_absolute_vorticity (10 levels): - + min = -6.8104850345376183e-11 - + max = 1.0355880483436711e-09 - + mean = 8.5730142683384615e-14 - + stddev = 1.8116380590147095e-11 + + min = -3.9997053364313221e-11 + + max = 5.5329603214293053e-10 + + mean = 6.1260224913053795e-14 + + stddev = 9.1669324071505505e-12 - air_horizontal_divergence (10 levels): - + min = -4.0819833615634788e-11 - + max = 4.9896228579636911e-10 - + mean = 7.0383219256487351e-14 - + stddev = 8.3193222184629522e-12 + + min = -2.8488458312699551e-11 + + max = 3.2305862921761325e-10 + + mean = 3.5650422827084458e-14 + + stddev = 5.2211228062170574e-12 - air_temperature_and_log_of_air_pressure_at_surface (11 levels): - + min = -6.9272889504143470e-06 - + max = 4.7427003702465581e-07 - + mean = -1.0560690316493778e-07 - + stddev = 4.6077545769342089e-07 + + min = -8.5375673983992540e-06 + + max = 6.3892158810947953e-07 + + mean = 3.3119368055067728e-08 + + stddev = 4.4359298669738382e-07 - water_vapor_mixing_ratio_wrt_moist_air (10 levels): - + min = -3.5249796308867758e-09 - + max = 7.9003792552401030e-08 - + mean = 5.1854503378407329e-10 - + stddev = 3.2011745031465903e-09 + + min = -1.4228820253838980e-09 + + max = 3.6863836528339586e-08 + + mean = 1.1363201592461813e-10 + + stddev = 1.1169946743835887e-09 diff --git a/test/testref/dirac_bifourier_ectrans.ref b/test/testref/dirac_bifourier_ectrans.ref new file mode 100644 index 000000000..5288bf235 --- /dev/null +++ b/test/testref/dirac_bifourier_ectrans.ref @@ -0,0 +1,77 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block Biperiodization passed +Inner inverse test for block Biperiodization passed: U Uinv (U x) == (U x) +Outer inverse test for block Biperiodization passed: Uinv U (Uinv x) == (Uinv x) +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierAromeCovariance passed +Square-root test for block BifourierAromeCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -4.8758264938425575e-04 + + max = 4.8758264938425586e-04 + + mean = 7.7569000899094634e-08 + + stddev = 1.2074597900524888e-04 + - geographical_y_wind (10 levels): + + min = -4.9875792412800888e-04 + + max = 4.9875792412800899e-04 + + mean = -3.9912777639975227e-08 + + stddev = 1.0025526378204409e-04 + - air_temperature (10 levels): + + min = -5.1340230885500082e-03 + + max = 8.4431734952200826e-02 + + mean = 1.8676565320962591e-04 + + stddev = 3.1221611795713981e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = -7.0870712822661480e-06 + + max = 1.5383528799813387e-06 + + mean = 4.8075964194695124e-08 + + stddev = 7.4412989602294160e-07 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -9.5218129829356520e-07 + + max = 6.8621703500169469e-06 + + mean = 5.7681742085595333e-10 + + stddev = 3.5342015127105225e-07 diff --git a/test/testref/dirac_bifourier_gridtospectral.ref b/test/testref/dirac_bifourier_gridtospectral.ref index cb39d9aa0..ced8a8bbc 100644 --- a/test/testref/dirac_bifourier_gridtospectral.ref +++ b/test/testref/dirac_bifourier_gridtospectral.ref @@ -16,25 +16,34 @@ Input Dirac increment: - Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km - Mean latitude: 5.6289831946322792e+01 deg - Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 - Direct-inverse test passed - Inverse-direct test passed - Parseval identity test passed -- Adjoint test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed - Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralToGrid passed +Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierGridToSpectral passed +Inner inverse test for block BifourierGridToSpectral passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierGridToSpectral passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block ID passed +Square-root test for block ID passed Covariance(SABER) * Increment: - Valid time: 2010-01-01T12:00:00Z Geometry: structured [3723] Fields: - air_upward_absolute_vorticity (10 levels): - + min = -7.4201315154539038e-02 - + max = 7.0561375235025525e-01 - + mean = 2.6860059092130010e-05 - + stddev = 4.3534600825004960e-03 + + min = -6.5269073914377571e-02 + + max = 7.5611066344345945e-01 + + mean = 2.6860059092129963e-05 + + stddev = 4.5065509137786255e-03 - air_horizontal_divergence (10 levels): - + min = -7.4201315154539038e-02 - + max = 7.0561375235025525e-01 - + mean = 2.6860059092130010e-05 - + stddev = 4.3534600825004960e-03 + + min = -6.5269073914377571e-02 + + max = 7.5611066344345945e-01 + + mean = 2.6860059092129963e-05 + + stddev = 4.5065509137786246e-03 diff --git a/test/testref/dirac_bifourier_splittps.ref b/test/testref/dirac_bifourier_splittps.ref deleted file mode 100644 index fa449f9d2..000000000 --- a/test/testref/dirac_bifourier_splittps.ref +++ /dev/null @@ -1,47 +0,0 @@ -Input Dirac increment: -- Valid time: 2010-01-01T12:00:00Z - Geometry: structured [3723] - Fields: - - air_temperature (10 levels): - + min = 0.0000000000000000e+00 - + max = 0.0000000000000000e+00 - - log_of_air_pressure_at_surface (1 levels): - + min = 0.0000000000000000e+00 - + max = 1.0000000000000000e+00 - + mean = 2.6860059092130003e-04 - + stddev = 1.6389038743052555e-02 -- Regional grid size: 73x51 -- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km -- Mean latitude: 5.6289831946322792e+01 deg -- Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 -- Direct-inverse test passed -- Inverse-direct test passed -- Parseval identity test passed -- Adjoint test passed -- Derivatives / direct Laplacian consistency test passed -Adjoint test for block BifourierSpectralToGrid passed -Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) -Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) -Adjoint test for block BifourierSplitTPs passed -Inner inverse test for block BifourierSplitTPs passed: U Uinv (U x) == (U x) -Outer inverse test for block BifourierSplitTPs passed: Uinv U (Uinv x) == (Uinv x) -Adjoint test for block BifourierSplitTPs passed -Inner inverse test for block BifourierSplitTPs passed: U Uinv (U x) == (U x) -Outer inverse test for block BifourierSplitTPs passed: Uinv U (Uinv x) == (Uinv x) -Adjoint test for block BifourierID passed -Square-root test for block BifourierID passed -Covariance(SABER) * Increment: -- Valid time: 2010-01-01T12:00:00Z - Geometry: structured [3723] - Fields: - - air_temperature (10 levels): - + min = 0.0000000000000000e+00 - + max = 0.0000000000000000e+00 - - log_of_air_pressure_at_surface (1 levels): - + min = -7.4201315154539038e-02 - + max = 7.0561375235025525e-01 - + mean = 2.6860059092129965e-04 - + stddev = 1.3766155101017443e-02 diff --git a/test/testref/dirac_bifourier_vordivtouv_1.ref b/test/testref/dirac_bifourier_vordivtouv_1.ref index 732c25c67..2ec69f2cc 100644 --- a/test/testref/dirac_bifourier_vordivtouv_1.ref +++ b/test/testref/dirac_bifourier_vordivtouv_1.ref @@ -12,33 +12,41 @@ Input Dirac increment: + max = 1.0000000000000000e+00 + mean = 2.6860059092130003e-05 + stddev = 5.1826691088793144e-03 -- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] -- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] -Outer grid size: 3723 -Norm of output parameter : 6.1017419610202452e+01 - Regional grid size: 73x51 - Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km - Mean latitude: 5.6289831946322792e+01 deg - Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 - Direct-inverse test passed - Inverse-direct test passed - Parseval identity test passed -- Adjoint test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed - Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block ID passed +Square-root test for block ID passed Covariance(SABER) * Increment: - Valid time: 2010-01-01T12:00:00Z Geometry: structured [3723] Fields: - geographical_x_wind (10 levels): - + min = -7.4201371134311744e-02 - + max = 7.0561385878272243e-01 - + mean = 2.6860063042975873e-05 - + stddev = 4.3534623918608127e-03 + + min = -6.5537549086463073e-02 + + max = 7.5584151543655453e-01 + + mean = -4.5069384212612013e-10 + + stddev = 4.5058287817629503e-03 - geographical_y_wind (10 levels): - + min = -7.4201371134311744e-02 - + max = 7.0561385878272243e-01 - + mean = 2.6860063042975873e-05 - + stddev = 4.3534623918608118e-03 + + min = -6.5537549086463073e-02 + + max = 7.5584151543655453e-01 + + mean = -4.5069384211670216e-10 + + stddev = 4.5058287817629503e-03 diff --git a/test/testref/dirac_bifourier_vordivtouv_2.ref b/test/testref/dirac_bifourier_vordivtouv_2.ref index fefe5d77d..e68610ce7 100644 --- a/test/testref/dirac_bifourier_vordivtouv_2.ref +++ b/test/testref/dirac_bifourier_vordivtouv_2.ref @@ -10,36 +10,42 @@ Input Dirac increment: - geographical_y_wind (10 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 -- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] -- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] -Outer grid size: 3723 - Regional grid size: 73x51 - Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km - Mean latitude: 5.6289831946322792e+01 deg - Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 - Direct-inverse test passed - Inverse-direct test passed - Parseval identity test passed -- Adjoint test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed - Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Inner inverse test for block BifourierGridToSpectral passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierGridToSpectral passed: Uinv U (Uinv x) == (Uinv x) FastLAM interpolation accuracy test passed FastLAM interpolation adjoint test passed FastLAM redToRows test passed FastLAM rowsToCols test passed +Square-root test for block FastLAM passed Covariance(SABER) * Increment: - Valid time: 2010-01-01T12:00:00Z Geometry: structured [3723] Fields: - geographical_x_wind (10 levels): - + min = -2.1343051349092116e+03 - + max = 2.0906119791328451e+03 - + mean = -4.1341902275466312e-05 - + stddev = 1.1921190567106957e+02 + + min = -2.1348106301150806e+03 + + max = 2.0898006483377430e+03 + + mean = -4.1557379994899284e-05 + + stddev = 1.1920809568604234e+02 - geographical_y_wind (10 levels): - + min = -2.1443925475165092e+03 - + max = 2.1443922671377277e+03 - + mean = 1.1469726009252675e-05 - + stddev = 1.3659732343996504e+02 + + min = -2.1452821986739773e+03 + + max = 2.1452819181788741e+03 + + mean = 1.1561889218461781e-05 + + stddev = 1.3665546894420132e+02 diff --git a/test/testref/dirac_bifourier_vordivtouv_3.ref b/test/testref/dirac_bifourier_vordivtouv_3.ref index a344f1698..e04772862 100644 --- a/test/testref/dirac_bifourier_vordivtouv_3.ref +++ b/test/testref/dirac_bifourier_vordivtouv_3.ref @@ -10,31 +10,25 @@ Input Dirac increment: - northward_wind (10 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 -- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] -- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] -Outer grid size: 3723 -Norm of output parameter : 1.0568360561474853e+02 -Adjoint test for block RedWindToGeoWind passed -Inner inverse test for block RedWindToGeoWind passed: U Uinv (U x) == (U x) -Outer inverse test for block RedWindToGeoWind passed: Uinv U (Uinv x) == (Uinv x) - Regional grid size: 73x51 - Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km - Mean latitude: 5.6289831946322792e+01 deg - Spectral sizes: 37x26 -- Truncation parameters MxN: 35x24 -- Maximum total wave number: 35 -- Spectral array global size: 2627 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 - Direct-inverse test passed - Inverse-direct test passed - Parseval identity test passed -- Adjoint test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed - Derivatives / direct Laplacian consistency test passed -Adjoint test for block BifourierSpectralToGrid passed -Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) -Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) -Adjoint test for block BifourierVorDivToRedWind passed -Inner inverse test for block BifourierVorDivToRedWind passed: U Uinv (U x) == (U x) -Outer inverse test for block BifourierVorDivToRedWind passed: Uinv U (Uinv x) == (Uinv x) +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) Adjoint test for block BifourierID passed Square-root test for block BifourierID passed Covariance(SABER) * Increment: @@ -42,12 +36,12 @@ Covariance(SABER) * Increment: Geometry: structured [3723] Fields: - eastward_wind (10 levels): - + min = -3.9438479402583261e+05 - + max = 3.7986544906090382e+06 - + mean = 1.7819229608784877e+00 - + stddev = 1.3315980902354096e+05 + + min = -5.0793423348106327e+09 + + max = 4.8979095522810432e+10 + + mean = 1.3211899828903976e+04 + + stddev = 1.2819347578317482e+09 - northward_wind (10 levels): - + min = -9.2218007641997756e+03 - + max = 6.8693321138288738e+03 - + mean = -8.0549546089857145e+01 - + stddev = 1.1348912430587532e+03 + + min = -1.0939509974629569e+08 + + max = 8.1549991354016662e+07 + + mean = -6.0025148786476220e+05 + + stddev = 8.9724237956770845e+06 diff --git a/test/testref/dirac_bifourier_vordivtouv_ectrans_1.ref b/test/testref/dirac_bifourier_vordivtouv_ectrans_1.ref new file mode 100644 index 000000000..edac8af8a --- /dev/null +++ b/test/testref/dirac_bifourier_vordivtouv_ectrans_1.ref @@ -0,0 +1,47 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block ID passed +Square-root test for block ID passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -6.5537543631035700e-02 + + max = 7.5584140142791345e-01 + + mean ~ 0 + + stddev = 4.5058264798653776e-03 + - geographical_y_wind (10 levels): + + min = -2.5041913934409621e-18 + + max = 2.4919113744910578e-18 + + mean ~ 0 + + stddev = 2.2158576513486978e-19 diff --git a/test/testref/dirac_bifourier_vordivtouv_ectrans_2.ref b/test/testref/dirac_bifourier_vordivtouv_ectrans_2.ref new file mode 100644 index 000000000..23844c59a --- /dev/null +++ b/test/testref/dirac_bifourier_vordivtouv_ectrans_2.ref @@ -0,0 +1,48 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Inner inverse test for block BifourierGridToSpectral passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierGridToSpectral passed: Uinv U (Uinv x) == (Uinv x) + FastLAM interpolation accuracy test passed + FastLAM interpolation adjoint test passed + FastLAM redToRows test passed + FastLAM rowsToCols test passed +Square-root test for block FastLAM passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -2.1348080526467038e+03 + + max = 2.0898000182443848e+03 + + mean ~ 0 + + stddev = 1.1920753947004273e+02 + - geographical_y_wind (10 levels): + + min = -2.1452818669226399e+03 + + max = 2.1452818669226390e+03 + + mean ~ 0 + + stddev = 1.3665494414081243e+02 diff --git a/test/testref/error_covariance_training_bifourier_1.ref b/test/testref/error_covariance_training_bifourier_1.ref new file mode 100644 index 000000000..2f2a5c076 --- /dev/null +++ b/test/testref/error_covariance_training_bifourier_1.ref @@ -0,0 +1,94 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Regression norms: +- air_horizontal_divergence from balanced_air_pressure: 3.4400355027687624e-02 +- air_temperature_and_log_of_air_pressure_at_surface from balanced_air_pressure: 3.8183205559885050e+02 +- air_temperature_and_log_of_air_pressure_at_surface from air_horizontal_divergence: 3.7073084658326195e+06 +- water_vapor_mixing_ratio_wrt_moist_air from balanced_air_pressure: 2.6216732643132723e-01 +- water_vapor_mixing_ratio_wrt_moist_air from air_horizontal_divergence: 2.2517891437620488e+03 +- water_vapor_mixing_ratio_wrt_moist_air from air_temperature_and_log_of_air_pressure_at_surface: 7.9725818390904193e+00 +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9240493817614107e-01 + + standard-deviation: 6.5109589057317480e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8269157202140690e-01 + + standard-deviation: 5.6685458805479676e-05 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.2739063589221912e-01 + + standard-deviation: 5.0366861901284291e-04 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.5354764274897985e-01 + + standard-deviation: 8.3806376972365637e-01 +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -4.4933091255010163e-04 + + max = 4.4933093217888167e-04 + + mean = 9.9858436284763976e-11 + + stddev = 1.3585174124949823e-04 + - geographical_y_wind (10 levels): + + min = -4.6265111802071724e-04 + + max = 4.6265097842578716e-04 + + mean = 1.4291595379793755e-10 + + stddev = 1.0606404552589640e-04 + - air_temperature (10 levels): + + min = -3.6692417325731911e-03 + + max = 8.2267393326151309e-02 + + mean = 1.5255536192051208e-04 + + stddev = 2.9116616197034807e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.2928251254258133e-06 + + max = 2.2322740421243892e-06 + + mean = 7.3194516715444677e-08 + + stddev = 9.1410743066947919e-07 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.4592611051897738e-07 + + max = 6.4485196510788338e-06 + + mean ~ 0 + + stddev = 3.3197803319098560e-07 diff --git a/test/testref/error_covariance_training_bifourier_2.ref b/test/testref/error_covariance_training_bifourier_2.ref new file mode 100644 index 000000000..f9167b122 --- /dev/null +++ b/test/testref/error_covariance_training_bifourier_2.ref @@ -0,0 +1,94 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Regression norms: +- air_horizontal_divergence from balanced_air_pressure: 3.4400355027687624e-02 +- air_temperature_and_log_of_air_pressure_at_surface from balanced_air_pressure: 3.8183205559887131e+02 +- air_temperature_and_log_of_air_pressure_at_surface from air_horizontal_divergence: 3.7073084658970879e+06 +- water_vapor_mixing_ratio_wrt_moist_air from balanced_air_pressure: 2.6216732643133966e-01 +- water_vapor_mixing_ratio_wrt_moist_air from air_horizontal_divergence: 2.2517891437969265e+03 +- water_vapor_mixing_ratio_wrt_moist_air from air_temperature_and_log_of_air_pressure_at_surface: 7.9725818390904033e+00 +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9240493817614107e-01 + + standard-deviation: 6.5109589057317480e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8269157202140690e-01 + + standard-deviation: 5.6685458805479676e-05 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.2739063589221923e-01 + + standard-deviation: 5.0366861901284270e-04 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.5354764274897980e-01 + + standard-deviation: 8.3806376972365648e-01 +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -4.4933091255010016e-04 + + max = 4.4933093217887999e-04 + + mean = 9.9858436341819367e-11 + + stddev = 1.3585174124950192e-04 + - geographical_y_wind (10 levels): + + min = -4.6265111802071669e-04 + + max = 4.6265097842578635e-04 + + mean = 1.4291595374689929e-10 + + stddev = 1.0606404552589761e-04 + - air_temperature (10 levels): + + min = -3.6692417325727041e-03 + + max = 8.2267393326151433e-02 + + mean = 1.5255536192051232e-04 + + stddev = 2.9116616197035288e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.2928251254273354e-06 + + max = 2.2322740421236730e-06 + + mean = 7.3194516715445577e-08 + + stddev = 9.1410743066905726e-07 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.4592611051875990e-07 + + max = 6.4485196510791717e-06 + + mean ~ 0 + + stddev = 3.3197803319100852e-07 diff --git a/test/testref/error_covariance_training_bifourier_3.ref b/test/testref/error_covariance_training_bifourier_3.ref new file mode 100644 index 000000000..9b53e1656 --- /dev/null +++ b/test/testref/error_covariance_training_bifourier_3.ref @@ -0,0 +1,94 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Regression norms: +- air_horizontal_divergence from balanced_air_pressure: 3.4400355027686624e-02 +- air_temperature_and_log_of_air_pressure_at_surface from balanced_air_pressure: 3.8183205559842548e+02 +- air_temperature_and_log_of_air_pressure_at_surface from air_horizontal_divergence: 3.7073084658369832e+06 +- water_vapor_mixing_ratio_wrt_moist_air from balanced_air_pressure: 2.6216732643122720e-01 +- water_vapor_mixing_ratio_wrt_moist_air from air_horizontal_divergence: 2.2517891437694448e+03 +- water_vapor_mixing_ratio_wrt_moist_air from air_temperature_and_log_of_air_pressure_at_surface: 7.9725818390904104e+00 +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9240493817614104e-01 + + standard-deviation: 6.5109589057317494e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8269157202140698e-01 + + standard-deviation: 5.6685458805479635e-05 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.2739063589221906e-01 + + standard-deviation: 5.0366861901284291e-04 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.5354764274897946e-01 + + standard-deviation: 8.3806376972365670e-01 +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -4.4933091255010244e-04 + + max = 4.4933093217888254e-04 + + mean = 9.9858436342235180e-11 + + stddev = 1.3585174124948856e-04 + - geographical_y_wind (10 levels): + + min = -4.6265111802071772e-04 + + max = 4.6265097842578749e-04 + + mean = 1.4291595387753140e-10 + + stddev = 1.0606404552589416e-04 + - air_temperature (10 levels): + + min = -3.6692417325719061e-03 + + max = 8.2267393326148533e-02 + + mean = 1.5255536192051221e-04 + + stddev = 2.9116616197031363e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.2928251254260530e-06 + + max = 2.2322740421244565e-06 + + mean = 7.3194516715445366e-08 + + stddev = 9.1410743066949613e-07 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.4592611051908739e-07 + + max = 6.4485196510781019e-06 + + mean ~ 0 + + stddev = 3.3197803319093801e-07 diff --git a/test/testref/error_covariance_training_bifourier_4.ref b/test/testref/error_covariance_training_bifourier_4.ref new file mode 100644 index 000000000..2ae2d7972 --- /dev/null +++ b/test/testref/error_covariance_training_bifourier_4.ref @@ -0,0 +1,94 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Regression norms: +- air_horizontal_divergence from balanced_air_pressure: 3.4400355027686819e-02 +- air_temperature_and_log_of_air_pressure_at_surface from balanced_air_pressure: 3.8183205559846687e+02 +- air_temperature_and_log_of_air_pressure_at_surface from air_horizontal_divergence: 3.7073084658074188e+06 +- water_vapor_mixing_ratio_wrt_moist_air from balanced_air_pressure: 2.6216732643124058e-01 +- water_vapor_mixing_ratio_wrt_moist_air from air_horizontal_divergence: 2.2517891437646776e+03 +- water_vapor_mixing_ratio_wrt_moist_air from air_temperature_and_log_of_air_pressure_at_surface: 7.9725818390904211e+00 +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9240493817614090e-01 + + standard-deviation: 6.5109589057317507e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8269157202140698e-01 + + standard-deviation: 5.6685458805479642e-05 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.2739063589221895e-01 + + standard-deviation: 5.0366861901284280e-04 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.5354764274897963e-01 + + standard-deviation: 8.3806376972365648e-01 +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -4.4933091255010195e-04 + + max = 4.4933093217888227e-04 + + mean = 9.9858436309724449e-11 + + stddev = 1.3585174124949292e-04 + - geographical_y_wind (10 levels): + + min = -4.6265111802071827e-04 + + max = 4.6265097842578792e-04 + + mean = 1.4291595401934523e-10 + + stddev = 1.0606404552589565e-04 + - air_temperature (10 levels): + + min = -3.6692417325713492e-03 + + max = 8.2267393326148450e-02 + + mean = 1.5255536192051029e-04 + + stddev = 2.9116616197031558e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.2928251254259260e-06 + + max = 2.2322740421242702e-06 + + mean = 7.3194516715445710e-08 + + stddev = 9.1410743066936145e-07 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.4592611051903784e-07 + + max = 6.4485196510781985e-06 + + mean ~ 0 + + stddev = 3.3197803319094663e-07 diff --git a/test/testref/error_covariance_training_bifourier_5.ref b/test/testref/error_covariance_training_bifourier_5.ref new file mode 100644 index 000000000..d4907fb9b --- /dev/null +++ b/test/testref/error_covariance_training_bifourier_5.ref @@ -0,0 +1,94 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Regression norms: +- air_horizontal_divergence from balanced_air_pressure: 3.5982558136748180e-02 +- air_temperature_and_log_of_air_pressure_at_surface from balanced_air_pressure: 4.1759844068797253e+02 +- air_temperature_and_log_of_air_pressure_at_surface from air_horizontal_divergence: 3.6497986995759979e+06 +- water_vapor_mixing_ratio_wrt_moist_air from balanced_air_pressure: 2.6570010790594650e-01 +- water_vapor_mixing_ratio_wrt_moist_air from air_horizontal_divergence: 3.1139447537166857e+03 +- water_vapor_mixing_ratio_wrt_moist_air from air_temperature_and_log_of_air_pressure_at_surface: 7.9085677788076261e+00 +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9250554453861476e-01 + + standard-deviation: 6.5207410891391726e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8263542617354050e-01 + + standard-deviation: 5.6627709205312890e-05 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.2541108191558932e-01 + + standard-deviation: 5.0101485455981217e-04 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.6123324820770872e-01 + + standard-deviation: 8.3562264580164547e-01 +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -4.5801311102332997e-04 + + max = 4.5801313103138692e-04 + + mean = 9.8583349972661957e-11 + + stddev = 1.3894326515603703e-04 + - geographical_y_wind (10 levels): + + min = -4.6972570339229959e-04 + + max = 4.6972556166276647e-04 + + mean = 1.3353245006830264e-10 + + stddev = 1.0733636338555283e-04 + - air_temperature (10 levels): + + min = -3.9207503249316430e-03 + + max = 8.2193245952076055e-02 + + mean = 1.6019682858715617e-04 + + stddev = 2.9466397733630936e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.7337733493276711e-06 + + max = 2.1455616446683048e-06 + + mean = 1.0597150141089746e-07 + + stddev = 9.1892798752531870e-07 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.8718070061375058e-07 + + max = 6.3274030964037416e-06 + + mean ~ 0 + + stddev = 3.4460871190804017e-07 diff --git a/test/testref/error_covariance_training_bifourier_6.ref b/test/testref/error_covariance_training_bifourier_6.ref new file mode 100644 index 000000000..f693c695c --- /dev/null +++ b/test/testref/error_covariance_training_bifourier_6.ref @@ -0,0 +1,94 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Regression norms: +- air_horizontal_divergence from balanced_air_pressure: 1.8185838103753451e-03 +- air_temperature_and_log_of_air_pressure_at_surface from balanced_air_pressure: 3.1283380016611275e+01 +- air_temperature_and_log_of_air_pressure_at_surface from air_horizontal_divergence: 1.5543114533489171e+05 +- water_vapor_mixing_ratio_wrt_moist_air from balanced_air_pressure: 2.1288902222397748e-02 +- water_vapor_mixing_ratio_wrt_moist_air from air_horizontal_divergence: 6.4510492615670216e+01 +- water_vapor_mixing_ratio_wrt_moist_air from air_temperature_and_log_of_air_pressure_at_surface: 7.0957042545145876e+00 +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9240493817614104e-01 + + standard-deviation: 6.5109589057317494e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8301246881346506e-01 + + standard-deviation: 5.6833092571194115e-05 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.3629287566623084e-01 + + standard-deviation: 5.1868771970865540e-04 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.6626915120344509e-01 + + standard-deviation: 8.6163088049795578e-01 +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -4.0621767085463980e-04 + + max = 4.0621768860004114e-04 + + mean = 9.7356636904267019e-11 + + stddev = 1.2737857654755957e-04 + - geographical_y_wind (10 levels): + + min = -4.1624157738082699e-04 + + max = 4.1624145178896792e-04 + + mean = 1.4111829786048982e-10 + + stddev = 1.0283930800493764e-04 + - air_temperature (10 levels): + + min = -3.9221783715925910e-03 + + max = 8.2156805939864214e-02 + + mean = 1.5255536192051194e-04 + + stddev = 2.8818210298874633e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.3187376039977568e-06 + + max = 2.1880598034477309e-06 + + mean = 7.3194516715445802e-08 + + stddev = 9.0250655493872701e-07 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -9.0320618688518223e-07 + + max = 6.3384352592189854e-06 + + mean ~ 0 + + stddev = 3.5137540251495597e-07 diff --git a/test/testref/error_covariance_training_bifourier_7.ref b/test/testref/error_covariance_training_bifourier_7.ref new file mode 100644 index 000000000..87b929e62 --- /dev/null +++ b/test/testref/error_covariance_training_bifourier_7.ref @@ -0,0 +1,94 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Regression norms: +- air_horizontal_divergence from balanced_air_pressure: 2.1984270698582196e-02 +- air_temperature_and_log_of_air_pressure_at_surface from balanced_air_pressure: 2.3160116556805383e+02 +- air_temperature_and_log_of_air_pressure_at_surface from air_horizontal_divergence: 2.9068109123170441e+06 +- water_vapor_mixing_ratio_wrt_moist_air from balanced_air_pressure: 1.5297262389715954e-01 +- water_vapor_mixing_ratio_wrt_moist_air from air_horizontal_divergence: 9.0531771975696972e+02 +- water_vapor_mixing_ratio_wrt_moist_air from air_temperature_and_log_of_air_pressure_at_surface: 8.1841884053183414e+00 +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9176283531418409e-01 + + standard-deviation: 6.5103419499988827e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8248058914672874e-01 + + standard-deviation: 5.6790773478040396e-05 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.4048375883165960e-01 + + standard-deviation: 5.1345026853487179e-04 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.5748843246329868e-01 + + standard-deviation: 8.5213486042750353e-01 +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -4.6910152921944879e-04 + + max = 4.6910154971189778e-04 + + mean = 4.2503039547823656e-11 + + stddev = 5.7648904541724963e-05 + - geographical_y_wind (10 levels): + + min = -4.7294774603696201e-04 + + max = 4.7294760333524741e-04 + + mean = 6.6736282919805176e-11 + + stddev = 4.8757312116061723e-05 + - air_temperature (10 levels): + + min = -4.2199976934812885e-03 + + max = 8.1605854489469429e-02 + + mean = 1.5255536192051178e-04 + + stddev = 2.6949717445765541e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = -7.2927049170897995e-06 + + max = 1.0586156666937939e-06 + + mean = 7.3194516715445604e-08 + + stddev = 4.5367273364785858e-07 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.2716108064275915e-07 + + max = 5.9767384135764493e-06 + + mean ~ 0 + + stddev = 2.8274030576314328e-07 diff --git a/test/testref/error_covariance_training_bifourier_8.ref b/test/testref/error_covariance_training_bifourier_8.ref new file mode 100644 index 000000000..ae6f37862 --- /dev/null +++ b/test/testref/error_covariance_training_bifourier_8.ref @@ -0,0 +1,40 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 5.3720118184260007e-05 + + stddev = 7.3293025056932037e-03 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +Adjoint test for block BifourierSpectralToGrid passed +Inner inverse test for block BifourierSpectralToGrid passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralToGrid passed: Uinv U (Uinv x) == (Uinv x) +Covariance norms: +- air_temperature: + + correlation square-root: 7.1544394431007285e-01 + + standard-deviation: 3.1622776601683795e+00 +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - air_temperature (10 levels): + + min = -3.8372360722991411e-02 + + max = 1.0000000000000375e+00 + + mean = 1.2912401471731493e-02 + + stddev = 4.6599546655297974e-02 diff --git a/test/testref/error_covariance_training_bifourier_covariance_1.ref b/test/testref/error_covariance_training_bifourier_covariance_1.ref new file mode 100644 index 000000000..c7d92d587 --- /dev/null +++ b/test/testref/error_covariance_training_bifourier_covariance_1.ref @@ -0,0 +1,70 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.4418235538300004e-05 + + stddev = 4.9414811077572096e-03 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9232482916988225e-01 + + standard-deviation: 6.5096139703568241e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8297881459347570e-01 + + standard-deviation: 5.6957380932564061e-05 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.8060096306219813e-01 + + standard-deviation: 8.6004624888847780e-01 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.1562269381901209e-01 + + standard-deviation: 5.0910646298903464e-04 +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -3.9152903735747910e-03 + + max = 7.8206333954952745e-02 + + mean = 1.7218475492059896e-04 + + stddev = 2.4278966665326773e-03 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 diff --git a/test/testref/error_covariance_training_bifourier_covariance_2.ref b/test/testref/error_covariance_training_bifourier_covariance_2.ref new file mode 100644 index 000000000..ffdd2de68 --- /dev/null +++ b/test/testref/error_covariance_training_bifourier_covariance_2.ref @@ -0,0 +1,70 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.4418235538300004e-05 + + stddev = 4.9414811077572096e-03 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9201688803646683e-01 + + standard-deviation: 6.4964665308500996e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8212288554754891e-01 + + standard-deviation: 5.6816088944661464e-05 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.7570652940409819e-01 + + standard-deviation: 8.5743232176877704e-01 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.1293144290357017e-01 + + standard-deviation: 5.0827697900926027e-04 +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -3.8896112641256262e-03 + + max = 7.7694397284785777e-02 + + mean = 1.7218475492059918e-04 + + stddev = 2.3491871574915814e-03 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 diff --git a/test/testref/error_covariance_training_bifourier_ectrans_1.ref b/test/testref/error_covariance_training_bifourier_ectrans_1.ref new file mode 100644 index 000000000..e574f384e --- /dev/null +++ b/test/testref/error_covariance_training_bifourier_ectrans_1.ref @@ -0,0 +1,94 @@ +Input Dirac increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - geographical_y_wind (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - air_temperature (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 2.6860059092130003e-05 + + stddev = 5.1826691088793144e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = 0.0000000000000000e+00 + + max = 0.0000000000000000e+00 +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Regression norms: +- air_horizontal_divergence from balanced_air_pressure: 3.4400422531225355e-02 +- air_temperature_and_log_of_air_pressure_at_surface from balanced_air_pressure: 3.8182570617054927e+02 +- air_temperature_and_log_of_air_pressure_at_surface from air_horizontal_divergence: 3.7072151251671431e+06 +- water_vapor_mixing_ratio_wrt_moist_air from balanced_air_pressure: 2.6216247565748430e-01 +- water_vapor_mixing_ratio_wrt_moist_air from air_horizontal_divergence: 2.2517419458016429e+03 +- water_vapor_mixing_ratio_wrt_moist_air from air_temperature_and_log_of_air_pressure_at_surface: 7.9725818120114358e+00 +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Covariance norms: +- air_upward_absolute_vorticity: + + correlation square-root: 1.9240494080691278e-01 + + standard-deviation: 6.5110687651583264e-05 +- air_horizontal_divergence: + + correlation square-root: 1.8269156901708009e-01 + + standard-deviation: 5.6686413642225397e-05 +- water_vapor_mixing_ratio_wrt_moist_air: + + correlation square-root: 3.2739069170321944e-01 + + standard-deviation: 5.0366865399519478e-04 +- air_temperature_and_log_of_air_pressure_at_surface: + + correlation square-root: 4.5354765647486833e-01 + + standard-deviation: 8.3806378905799539e-01 +Adjoint test for block BifourierCovariance passed +Square-root test for block BifourierCovariance passed +Covariance(SABER) * Increment: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -4.4933869716445477e-04 + + max = 4.4933869716445483e-04 + + mean ~ 0 + + stddev = 1.3585235650957346e-04 + - geographical_y_wind (10 levels): + + min = -4.6265891871727469e-04 + + max = 4.6265891871727480e-04 + + mean ~ 0 + + stddev = 1.0606399018475063e-04 + - air_temperature (10 levels): + + min = -3.6692424521247618e-03 + + max = 8.2267393795270455e-02 + + mean = 1.5255536192051230e-04 + + stddev = 2.9116617335130557e-03 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.2928251196266344e-06 + + max = 2.2322735527011065e-06 + + mean = 7.3194516715445524e-08 + + stddev = 9.1410732706674012e-07 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.4592556460534714e-07 + + max = 6.4485199600456523e-06 + + mean ~ 0 + + stddev = 3.3197806668879587e-07 diff --git a/test/testref/randomization_bifourier.ref b/test/testref/randomization_bifourier.ref new file mode 100644 index 000000000..404f65dbe --- /dev/null +++ b/test/testref/randomization_bifourier.ref @@ -0,0 +1,749 @@ +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierAromeBalance passed +Inner inverse test for block BifourierAromeBalance passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierAromeBalance passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierAromeCovariance passed +Square-root test for block BifourierAromeCovariance passed +Member 0: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.8003811298340192e-01 + + max = 1.6815338363225155e-01 + + mean = -4.1970694652879272e-08 + + stddev = 4.3778971509958381e-02 + - geographical_y_wind (10 levels): + + min = -1.6872337769663770e-01 + + max = 1.6704556967059853e-01 + + mean = -4.8285500467084327e-09 + + stddev = 4.0121097999330245e-02 + - air_temperature (10 levels): + + min = -1.1657711906315411e+00 + + max = 1.0553143348847640e+00 + + mean = -1.9318518843681052e-02 + + stddev = 2.8094624070695584e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.8269521768225681e-04 + + max = 6.1637066757958513e-04 + + mean = 2.6716608358899865e-06 + + stddev = 2.0316211375136142e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.0517957836909416e-04 + + max = 6.9466204174261628e-04 + + mean = -2.3945722153313237e-06 + + stddev = 1.6958098146912896e-04 +Member 1: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -2.0105777481838452e-01 + + max = 1.6286013790097054e-01 + + mean = 5.4283718192461603e-10 + + stddev = 4.3014139511799984e-02 + - geographical_y_wind (10 levels): + + min = -1.5390382123736304e-01 + + max = 1.7088847751085595e-01 + + mean = -4.4166859454420834e-08 + + stddev = 3.9906005728501025e-02 + - air_temperature (10 levels): + + min = -1.1673151089805771e+00 + + max = 1.0991459942725728e+00 + + mean = -1.3643450505104302e-02 + + stddev = 2.8541492532525148e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.3720483254844635e-04 + + max = 5.5707007976845248e-04 + + mean = 2.3017428325637423e-05 + + stddev = 1.6958980824371197e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.3272934717419744e-04 + + max = 7.1918272706631087e-04 + + mean = 8.7754585982149008e-06 + + stddev = 1.7009445676209690e-04 +Member 2: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.5645459655653632e-01 + + max = 1.4983852056524377e-01 + + mean = -1.9899067822372602e-08 + + stddev = 4.1279848077676075e-02 + - geographical_y_wind (10 levels): + + min = -1.4844014794850957e-01 + + max = 1.7192248883557254e-01 + + mean = -3.0046317992424646e-08 + + stddev = 4.1036261411666886e-02 + - air_temperature (10 levels): + + min = -1.0088726588731880e+00 + + max = 1.0546796241917749e+00 + + mean = -1.5097950783363769e-02 + + stddev = 2.8207354020714059e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.2411315163326360e-04 + + max = 5.3444565331153349e-04 + + mean = 1.7157112112272657e-05 + + stddev = 1.8290285123327593e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.1205308254689139e-04 + + max = 7.2184827132996585e-04 + + mean = 9.6709412420165861e-06 + + stddev = 1.7449538839509526e-04 +Member 3: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7074243289477509e-01 + + max = 1.8605297506348312e-01 + + mean = 6.7751569745934815e-09 + + stddev = 4.3084222942305489e-02 + - geographical_y_wind (10 levels): + + min = -1.8555309228741304e-01 + + max = 1.9068406195135015e-01 + + mean = 5.7886966023983637e-09 + + stddev = 4.2917520781378463e-02 + - air_temperature (10 levels): + + min = -1.0783214116539532e+00 + + max = 1.1996310742698801e+00 + + mean = -7.2308487508127269e-03 + + stddev = 2.8956506284650835e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -4.7238526020626709e-04 + + max = 5.3530279985256654e-04 + + mean = -2.8525202030474831e-05 + + stddev = 1.5546122842266050e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.6304856720497403e-04 + + max = 7.7556409193057553e-04 + + mean = 5.2154444219611445e-06 + + stddev = 1.7292749528245984e-04 +Member 4: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6749815561163628e-01 + + max = 1.5666424647879906e-01 + + mean = 2.4720168983117445e-08 + + stddev = 4.2321914596783548e-02 + - geographical_y_wind (10 levels): + + min = -1.6893077632711248e-01 + + max = 1.7443536120073275e-01 + + mean = 2.6931884400447980e-08 + + stddev = 4.2196442545792606e-02 + - air_temperature (10 levels): + + min = -1.3007715055628908e+00 + + max = 1.2280992726769620e+00 + + mean = 1.3981717191817338e-03 + + stddev = 2.9062022354508488e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.3785607611844528e-04 + + max = 6.0471244138557239e-04 + + mean = 1.2704371989948643e-05 + + stddev = 1.7303014728356158e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.1334901622015982e-04 + + max = 8.8872240564937519e-04 + + mean = -8.1159223049614782e-06 + + stddev = 1.7302454597780697e-04 +Member 5: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7207385704622749e-01 + + max = 2.2502482082962344e-01 + + mean = 4.6990939334244181e-08 + + stddev = 4.4086164455434902e-02 + - geographical_y_wind (10 levels): + + min = -1.6014532962672598e-01 + + max = 1.4521154372432077e-01 + + mean = 1.4443892998046245e-08 + + stddev = 4.0898074475917319e-02 + - air_temperature (10 levels): + + min = -1.0908535407531865e+00 + + max = 1.0637036431031883e+00 + + mean = -2.1393582140781527e-02 + + stddev = 2.9173446838204475e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -8.2380510913470349e-04 + + max = 5.6743426004112526e-04 + + mean = -4.7909578445253466e-05 + + stddev = 2.0743464576619022e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.6177435609824340e-04 + + max = 7.9056247382906742e-04 + + mean = -4.9707134550705446e-07 + + stddev = 1.6723627453192936e-04 +Member 6: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7998268124547454e-01 + + max = 1.7425957538764381e-01 + + mean = 4.0765452270087553e-08 + + stddev = 3.9612978220290557e-02 + - geographical_y_wind (10 levels): + + min = -1.9051807785417352e-01 + + max = 1.5924252627610030e-01 + + mean = 2.7269929580622516e-08 + + stddev = 4.1317401107977852e-02 + - air_temperature (10 levels): + + min = -1.0142764469450483e+00 + + max = 1.1639256586157463e+00 + + mean = 4.9298064618781860e-03 + + stddev = 2.8079103127992633e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -4.9718831569397430e-04 + + max = 7.4663700716027484e-04 + + mean = 5.1204788799455136e-05 + + stddev = 1.8244863446220195e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.7037662502561382e-04 + + max = 8.2272507130686076e-04 + + mean = 1.8286219704601474e-05 + + stddev = 1.7737056188831042e-04 +Member 7: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.5612113015472057e-01 + + max = 1.7091828049226543e-01 + + mean = 8.6316850709117524e-08 + + stddev = 4.1584558653035175e-02 + - geographical_y_wind (10 levels): + + min = -1.6326730199012585e-01 + + max = 1.7101814465587098e-01 + + mean = 5.2882122217461703e-08 + + stddev = 4.4393077518405891e-02 + - air_temperature (10 levels): + + min = -1.3269520272333279e+00 + + max = 1.1369139673483106e+00 + + mean = -9.5608417506817134e-03 + + stddev = 2.8283047820251989e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.4660399706209467e-04 + + max = 5.3635143600865324e-04 + + mean = -2.4933637646988562e-05 + + stddev = 1.5630289802979612e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.3092103079679294e-04 + + max = 7.9126132087152848e-04 + + mean = -3.0824921946158370e-06 + + stddev = 1.7131101634810733e-04 +Member 8: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7964927878930606e-01 + + max = 1.9688362664377979e-01 + + mean = 1.5008563415463424e-07 + + stddev = 4.4069353479904740e-02 + - geographical_y_wind (10 levels): + + min = -1.6838824101901476e-01 + + max = 1.6082502331641943e-01 + + mean = -2.2070871712693040e-08 + + stddev = 4.0309373685434045e-02 + - air_temperature (10 levels): + + min = -1.2013528735137906e+00 + + max = 1.0026471802512427e+00 + + mean = 7.4425481187896060e-03 + + stddev = 2.8356403857566587e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.9841737081593944e-04 + + max = 5.8926561399538194e-04 + + mean = -4.9515373573382219e-05 + + stddev = 1.8089922591920204e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.2710672076298421e-04 + + max = 9.2987898705156633e-04 + + mean = -1.8305195174504657e-06 + + stddev = 1.7656058909242990e-04 +Member 9: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6203474547845961e-01 + + max = 1.5813857099368755e-01 + + mean = -1.3066036039889247e-07 + + stddev = 4.1262589264299904e-02 + - geographical_y_wind (10 levels): + + min = -2.0401524658215406e-01 + + max = 1.6931494448339504e-01 + + mean = 4.5767399228882351e-08 + + stddev = 4.6216948422345937e-02 + - air_temperature (10 levels): + + min = -1.2843594819562907e+00 + + max = 1.0857405498713342e+00 + + mean = 1.0467210715587387e-02 + + stddev = 2.6877235090874624e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -4.6605607189888193e-04 + + max = 5.9295993577680207e-04 + + mean = 1.5860436949571334e-05 + + stddev = 1.7236704838041343e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.8381982937771933e-04 + + max = 7.2602515106875553e-04 + + mean = -1.1573637985075016e-06 + + stddev = 1.6740655231217702e-04 +Member 10: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.5364524199032334e-01 + + max = 1.5747563108272170e-01 + + mean = -9.0412684678200020e-08 + + stddev = 4.2137514453575213e-02 + - geographical_y_wind (10 levels): + + min = -1.6502081766103696e-01 + + max = 1.4327607990522501e-01 + + mean = 4.1662809837567204e-08 + + stddev = 3.9052992440993986e-02 + - air_temperature (10 levels): + + min = -1.1879592561651706e+00 + + max = 1.1333497138518094e+00 + + mean = -5.4236473466231375e-03 + + stddev = 2.7886275399176730e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.0988756523098044e-04 + + max = 6.6103209933376038e-04 + + mean = 3.1449285596690126e-05 + + stddev = 2.1389634883404931e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.2345722801423970e-04 + + max = 8.2462183634847506e-04 + + mean = 9.7344548889740082e-07 + + stddev = 1.7013090230179521e-04 +Member 11: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7197669313668612e-01 + + max = 1.7521486297980260e-01 + + mean = 5.8605531378220191e-08 + + stddev = 4.4355613114335515e-02 + - geographical_y_wind (10 levels): + + min = -1.8564015291710353e-01 + + max = 1.6507918458243498e-01 + + mean = 4.3288352749550298e-08 + + stddev = 4.3115892029083239e-02 + - air_temperature (10 levels): + + min = -1.4063198932755396e+00 + + max = 1.1517410504545493e+00 + + mean = 8.0579126897353231e-03 + + stddev = 2.9305975112636562e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.2906314090765275e-04 + + max = 6.5039048501146040e-04 + + mean = -2.6170897306836732e-05 + + stddev = 2.0343892314801827e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.4089844935115717e-04 + + max = 6.5408071010344048e-04 + + mean = -9.4183359339277093e-06 + + stddev = 1.7292997920156082e-04 +Member 12: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.4320121782648648e-01 + + max = 1.7143368304924803e-01 + + mean = -2.1345719808176764e-08 + + stddev = 4.2231031290957122e-02 + - geographical_y_wind (10 levels): + + min = -1.7062928632166977e-01 + + max = 1.7691360928642463e-01 + + mean = 7.8708147753624982e-08 + + stddev = 4.4485259078575645e-02 + - air_temperature (10 levels): + + min = -1.1777469782396566e+00 + + max = 1.2089498407454737e+00 + + mean = 6.5907410790185276e-03 + + stddev = 2.8750252119286579e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.5679801231502016e-04 + + max = 5.5038770273201196e-04 + + mean = 2.0792813663215601e-05 + + stddev = 1.6166711458068920e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.0280132125464232e-04 + + max = 6.8035605065102918e-04 + + mean = 1.1368968417604856e-06 + + stddev = 1.6852127915759760e-04 +Member 13: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.5628923659204372e-01 + + max = 1.8797044962934392e-01 + + mean = 1.8156395033734678e-07 + + stddev = 4.4557078666937873e-02 + - geographical_y_wind (10 levels): + + min = -2.0075326445553823e-01 + + max = 1.9150592977575370e-01 + + mean = -2.5383728308170293e-08 + + stddev = 4.5072609063914588e-02 + - air_temperature (10 levels): + + min = -1.3287755240452235e+00 + + max = 1.1458230435944818e+00 + + mean = -2.4138202940068562e-02 + + stddev = 2.8762687353640415e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.8421524718762308e-04 + + max = 5.2079565261020731e-04 + + mean = 5.2211066296078259e-06 + + stddev = 1.7698483331944135e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.4021829426718453e-04 + + max = 7.2023964923592296e-04 + + mean = 4.9923445715092367e-06 + + stddev = 1.7119629119894799e-04 +Member 14: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6636115416906277e-01 + + max = 1.6622336343156432e-01 + + mean = 1.4857366784787933e-08 + + stddev = 4.1035694080279017e-02 + - geographical_y_wind (10 levels): + + min = -1.8105639517077249e-01 + + max = 1.6823513487614628e-01 + + mean = 1.5159825414400909e-08 + + stddev = 4.2581878737079075e-02 + - air_temperature (10 levels): + + min = -1.2700304367341260e+00 + + max = 1.1145563591475574e+00 + + mean = -7.1189201822691155e-03 + + stddev = 2.8616442827548461e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.4181278640850420e-04 + + max = 5.2873208758800116e-04 + + mean = 5.5927640881291736e-06 + + stddev = 1.7278753811183592e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.2502764293154523e-04 + + max = 7.2616620954259452e-04 + + mean = -1.1919029628064308e-05 + + stddev = 1.8117692556074227e-04 +Member 15: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -2.1643552063225172e-01 + + max = 1.6367274947923977e-01 + + mean = 5.5617225492515059e-08 + + stddev = 4.1238472541424279e-02 + - geographical_y_wind (10 levels): + + min = -1.6145482255083057e-01 + + max = 1.6070131843648006e-01 + + mean = -9.0328611696369999e-08 + + stddev = 4.2461745604210385e-02 + - air_temperature (10 levels): + + min = -1.2690759137035075e+00 + + max = 1.1359888301478454e+00 + + mean = -2.0799694460220557e-02 + + stddev = 2.8220862909514727e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -6.3474528751250342e-04 + + max = 5.8389979000671947e-04 + + mean = -6.9924551611960541e-06 + + stddev = 1.8967487599349598e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.7007544359361340e-04 + + max = 7.2883995697167324e-04 + + mean = -1.7059507382054246e-06 + + stddev = 1.7394268281959799e-04 +Member 16: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.9014877045316828e-01 + + max = 1.9320548878711519e-01 + + mean = -6.2338779461470570e-09 + + stddev = 4.5691579630077528e-02 + - geographical_y_wind (10 levels): + + min = -1.7672128881415106e-01 + + max = 1.5752428422844542e-01 + + mean = 1.0139413411291234e-08 + + stddev = 4.1632118040115511e-02 + - air_temperature (10 levels): + + min = -1.2685462920039825e+00 + + max = 1.1357364837298363e+00 + + mean = 1.1596611718735595e-02 + + stddev = 2.9538928234107475e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.9307170245701359e-04 + + max = 6.5029036297861134e-04 + + mean = 1.2901175446613318e-05 + + stddev = 1.7517327049060660e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.0325602033672035e-04 + + max = 7.5138987904556614e-04 + + mean = 4.7929100380018140e-06 + + stddev = 1.7656565332882165e-04 +Member 17: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6006426137631755e-01 + + max = 1.8695422022495417e-01 + + mean = -6.0957306197865918e-09 + + stddev = 4.4480556878955704e-02 + - geographical_y_wind (10 levels): + + min = -1.7617516237763439e-01 + + max = 1.8066767156801311e-01 + + mean = 2.0347670560418861e-08 + + stddev = 4.2294939560161018e-02 + - air_temperature (10 levels): + + min = -1.2535705644675921e+00 + + max = 1.2295550435405040e+00 + + mean = 1.1878270377860063e-03 + + stddev = 2.7677937461459889e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -4.8826801396970070e-04 + + max = 6.4268703537276491e-04 + + mean = 3.3719180214779894e-05 + + stddev = 1.6485617140029512e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.1499482648865729e-04 + + max = 6.8322494317461118e-04 + + mean = -8.0899109397732761e-06 + + stddev = 1.6878056893917509e-04 +Member 18: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6588912297871547e-01 + + max = 1.6510598806255794e-01 + + mean = 6.4169546822103867e-09 + + stddev = 4.5088104898784544e-02 + - geographical_y_wind (10 levels): + + min = -1.5465077341974817e-01 + + max = 1.6954064105549671e-01 + + mean = 3.0146339539072185e-08 + + stddev = 4.1015850996500409e-02 + - air_temperature (10 levels): + + min = -1.2290376340568514e+00 + + max = 1.2005573723629630e+00 + + mean = -8.3184789096797987e-04 + + stddev = 2.7534324936163795e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.3735487741895843e-04 + + max = 4.6986342701436619e-04 + + mean = -7.3383142831664614e-06 + + stddev = 1.7170361200846056e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.7585512226590399e-04 + + max = 7.0283408632953169e-04 + + mean = -2.8377175972046632e-06 + + stddev = 1.7637030979346022e-04 +Member 19: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7617063079463979e-01 + + max = 1.5635714529617076e-01 + + mean = 5.9832860198841367e-08 + + stddev = 4.2182730580875911e-02 + - geographical_y_wind (10 levels): + + min = -1.6712916032020705e-01 + + max = 1.6475041335431370e-01 + + mean = 7.3230391773881650e-08 + + stddev = 4.0442147562852498e-02 + - air_temperature (10 levels): + + min = -1.0917494119697175e+00 + + max = 1.2422621784761689e+00 + + mean = 1.3959634994803365e-02 + + stddev = 2.7876774721135583e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.3196259825658964e-04 + + max = 4.0546967121531590e-04 + + mean = -3.7125162168780582e-05 + + stddev = 1.4227234129012453e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.3443886985854047e-04 + + max = 8.1968603900103615e-04 + + mean = -1.0161211957080866e-05 + + stddev = 1.7085929091778461e-04 +Member 20: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6935145068174934e-01 + + max = 1.7289120973415442e-01 + + mean = 3.3441264534011465e-08 + + stddev = 4.0744745014463707e-02 + - geographical_y_wind (10 levels): + + min = -1.8747346158348183e-01 + + max = 1.7397294309077807e-01 + + mean = 3.7090362245435155e-08 + + stddev = 4.2843533402500279e-02 + - air_temperature (10 levels): + + min = -1.0173286304269642e+00 + + max = 1.0166172917348288e+00 + + mean = 2.7925470470776935e-04 + + stddev = 2.8841775863511304e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -8.1814822815164828e-04 + + max = 5.6549970230648479e-04 + + mean = -1.2105303538180847e-05 + + stddev = 1.8033826022938589e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.4954852322240524e-04 + + max = 6.7297340270993170e-04 + + mean = 1.2277997543188240e-05 + + stddev = 1.7072329884265249e-04 +Member 21: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.8636321070924897e-01 + + max = 1.7851268142122206e-01 + + mean = 3.7111425458452336e-09 + + stddev = 4.3419206888522584e-02 + - geographical_y_wind (10 levels): + + min = -1.5880594800105183e-01 + + max = 1.6874598356251561e-01 + + mean = -3.4468476074171414e-08 + + stddev = 4.1347125950891545e-02 + - air_temperature (10 levels): + + min = -1.0980681880117520e+00 + + max = 1.0658746295792800e+00 + + mean = -5.5266636301278009e-03 + + stddev = 2.6466160472384376e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.4871212587468885e-04 + + max = 3.8035691044975599e-04 + + mean = -2.4234693262833596e-05 + + stddev = 1.5269829953270256e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.1846252683390294e-04 + + max = 7.5244260228942090e-04 + + mean = -1.5185799489716820e-06 + + stddev = 1.7299204575670177e-04 +Member 22: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.8380296748755401e-01 + + max = 1.6962358559223178e-01 + + mean = 1.2084932226776877e-07 + + stddev = 4.1595727708897863e-02 + - geographical_y_wind (10 levels): + + min = -1.5015552176081212e-01 + + max = 1.7726217061074906e-01 + + mean = 7.7953867107407819e-08 + + stddev = 4.4143455194346488e-02 + - air_temperature (10 levels): + + min = -1.2134029471501218e+00 + + max = 1.1821707814131848e+00 + + mean = 2.2101491042719688e-04 + + stddev = 2.9094990997428444e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -7.7656387482309621e-04 + + max = 4.0166359305805413e-04 + + mean = -5.1270281973144353e-05 + + stddev = 1.9240155313823384e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.5328036122725725e-04 + + max = 8.0238589368271081e-04 + + mean = -5.4747888484323545e-08 + + stddev = 1.6642567551401592e-04 +Member 23: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6441539429519139e-01 + + max = 1.8532682041706483e-01 + + mean = 2.8590680539942037e-08 + + stddev = 3.9349496442594382e-02 + - geographical_y_wind (10 levels): + + min = -1.8181557196125359e-01 + + max = 1.4981842970946990e-01 + + mean = -2.2888159490244817e-08 + + stddev = 4.1555832874551689e-02 + - air_temperature (10 levels): + + min = -1.2486062901946582e+00 + + max = 1.1711002735242810e+00 + + mean = 1.0884776773005471e-02 + + stddev = 2.8766152151175656e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.6041469234973025e-04 + + max = 6.4182022152349614e-04 + + mean = 7.4562509384810166e-05 + + stddev = 1.8047547051370307e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.1613054638958451e-04 + + max = 7.0875862536923955e-04 + + mean = 4.6189605031523403e-06 + + stddev = 1.7101519773795110e-04 +Member 24: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6783254310187554e-01 + + max = 1.5421840490206482e-01 + + mean = -5.9539755638515300e-08 + + stddev = 4.0264076088630238e-02 + - geographical_y_wind (10 levels): + + min = -1.4532748753523073e-01 + + max = 1.8132483873916527e-01 + + mean = 5.5880940642871904e-08 + + stddev = 4.0173847479094631e-02 + - air_temperature (10 levels): + + min = -1.2232172719999994e+00 + + max = 1.0527920170803957e+00 + + mean = -2.2056858935650403e-02 + + stddev = 2.7703240774526505e-01 + - log_of_air_pressure_at_surface (1 levels): + + min = -5.8271728352420071e-04 + + max = 3.9298756601212895e-04 + + mean = -8.2266273424471461e-05 + + stddev = 1.5724674725243071e-04 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.8979663708973816e-04 + + max = 7.4988320594138527e-04 + + mean = 3.2880121395273571e-07 + + stddev = 1.7136529882147387e-04 diff --git a/test/testref/randomization_bifourier_covariance.ref b/test/testref/randomization_bifourier_covariance.ref new file mode 100644 index 000000000..24b504140 --- /dev/null +++ b/test/testref/randomization_bifourier_covariance.ref @@ -0,0 +1,621 @@ +- Regional grid size: 73x51 +- Cell sizes: 2.5000000000000000e+00 km x 2.5000000000000000e+00 km +- Mean latitude: 5.6289831946322792e+01 deg +- Spectral sizes: 37x26 +- Truncation parameters MxN: 36x25 +- Maximum total wave number: 36 +- Spectral array global size: 2815 +- Direct-inverse test passed +- Inverse-direct test passed +- Parseval identity test passed +- Adjoint test (forward) passed +- Adjoint test (inverse) passed +- Derivatives / direct Laplacian consistency test passed +- xspace: LocalConfiguration[root={type => linear , start => 5.1870971254055749e+05 , end => 6.9870971254055749e+05 , N => 73 , endpoint => true}] +- yspace: LocalConfiguration[root={type => linear , start => -1.8673080099392682e+04 , end => 1.0632691990060732e+05 , N => 51 , endpoint => true}] +Outer grid size: 3723 +Adjoint test for block BifourierSpectralVorDivToGridWind passed +Inner inverse test for block BifourierSpectralVorDivToGridWind passed: U Uinv (U x) == (U x) +Outer inverse test for block BifourierSpectralVorDivToGridWind passed: Uinv U (Uinv x) == (Uinv x) +Adjoint test for block BifourierAromeCovariance passed +Square-root test for block BifourierAromeCovariance passed +Member 0: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.8109288195261342e-01 + + max = 1.8083983001288981e-01 + + mean = -1.4594110186751631e-08 + + stddev = 4.0791635891860994e-02 + - geographical_y_wind (10 levels): + + min = -1.8106246909943779e-01 + + max = 1.6960725419971465e-01 + + mean = -5.2494503532844245e-08 + + stddev = 4.3326291720511306e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.1090526825343627e+00 + + max = 1.1861165593914902e+00 + + mean = -2.2562856783251598e-02 + + stddev = 2.6259248620844317e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.2137045935629068e-04 + + max = 6.8630854249814195e-04 + + mean = -3.9819372116929572e-06 + + stddev = 1.6239531704796188e-04 +Member 1: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6935940874619579e-01 + + max = 1.6049118997076992e-01 + + mean = 2.2302257910169839e-08 + + stddev = 4.1456793247777048e-02 + - geographical_y_wind (10 levels): + + min = -1.8133677364882378e-01 + + max = 1.4958736080051768e-01 + + mean = 3.4519901044424303e-08 + + stddev = 4.0462161680901831e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.0403614371846013e+00 + + max = 1.0316022658084856e+00 + + mean = -7.8965979475276726e-03 + + stddev = 2.6250793074864737e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.4828409062014057e-04 + + max = 6.7789092542018992e-04 + + mean = -3.4580674572824656e-06 + + stddev = 1.6293220850624297e-04 +Member 2: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.5135018360274952e-01 + + max = 1.8174006246824140e-01 + + mean = 9.9455392070414265e-08 + + stddev = 4.2641988416392107e-02 + - geographical_y_wind (10 levels): + + min = -1.6390248786509118e-01 + + max = 1.6754182671329393e-01 + + mean = 1.6352332715752594e-08 + + stddev = 4.1025830992410917e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.0973163313563628e+00 + + max = 1.1087881731981857e+00 + + mean = -5.2889357727308362e-05 + + stddev = 2.5984889636202546e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.1969216262633619e-04 + + max = 9.2795778262038330e-04 + + mean = 9.5545353567162503e-07 + + stddev = 1.5872948484169035e-04 +Member 3: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.8531526523592060e-01 + + max = 1.7181809767696915e-01 + + mean = -3.2169571515048093e-08 + + stddev = 4.0919264299554448e-02 + - geographical_y_wind (10 levels): + + min = -1.5901860570093401e-01 + + max = 1.6392126129972570e-01 + + mean = -1.9420806641818116e-08 + + stddev = 4.1183570233831762e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.2862657473972965e+00 + + max = 1.0783316485070238e+00 + + mean = -5.6519291533635779e-03 + + stddev = 2.5955424828589668e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.6499301544359225e-04 + + max = 6.2517638257504604e-04 + + mean = -1.8770158338021403e-06 + + stddev = 1.5601227031241375e-04 +Member 4: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7992619780846150e-01 + + max = 1.6806400155720455e-01 + + mean = -4.1950015370524263e-08 + + stddev = 4.3766456245365772e-02 + - geographical_y_wind (10 levels): + + min = -1.6867013473244205e-01 + + max = 1.6714205578550165e-01 + + mean = -4.8439295301061517e-09 + + stddev = 4.0122819639491700e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.1201277990974123e+00 + + max = 1.1572100530372775e+00 + + mean = -1.3724212539741321e-02 + + stddev = 2.6156763328406796e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.5050365314054774e-04 + + max = 6.1679199241421721e-04 + + mean = -1.0160770748349481e-05 + + stddev = 1.5858007014625921e-04 +Member 5: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -2.0103792919939470e-01 + + max = 1.6241739704874458e-01 + + mean = 7.2324839298024605e-10 + + stddev = 4.3015573241130332e-02 + - geographical_y_wind (10 levels): + + min = -1.5374705953538487e-01 + + max = 1.7065359742216343e-01 + + mean = -4.3998912474321253e-08 + + stddev = 3.9889058167407176e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.0826270090489429e+00 + + max = 1.0593351138947937e+00 + + mean = 5.9996627677274938e-03 + + stddev = 2.4998623231692310e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.2445151407278898e-04 + + max = 6.0520692565115691e-04 + + mean = -4.9778526726749511e-06 + + stddev = 1.6032788171664974e-04 +Member 6: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.5642739552982809e-01 + + max = 1.4971314164397340e-01 + + mean = -1.9846184032030349e-08 + + stddev = 4.1283022406872615e-02 + - geographical_y_wind (10 levels): + + min = -1.4846696335339726e-01 + + max = 1.7190076448998690e-01 + + mean = -3.0124002261018476e-08 + + stddev = 4.1035032583642710e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.2087427736003615e+00 + + max = 1.0666712580820539e+00 + + mean = -1.6198384837335218e-02 + + stddev = 2.6324757002523991e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.5174394456271037e-04 + + max = 6.5110385724593926e-04 + + mean = -7.1502395026878230e-06 + + stddev = 1.6029427315311976e-04 +Member 7: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7085563906410436e-01 + + max = 1.8586775391080196e-01 + + mean = 6.8086739522269028e-09 + + stddev = 4.3069421654864964e-02 + - geographical_y_wind (10 levels): + + min = -1.8556100713916998e-01 + + max = 1.9081133091462674e-01 + + mean = 5.8726868637498802e-09 + + stddev = 4.2933104489008431e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.1313760412001019e+00 + + max = 1.1369748177571766e+00 + + mean = -2.7670588344767149e-03 + + stddev = 2.6374427780612741e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.0591539859878017e-04 + + max = 6.5551247228626622e-04 + + mean = -3.4061208408269185e-06 + + stddev = 1.6296792401231423e-04 +Member 8: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6757020573507214e-01 + + max = 1.5692220548247424e-01 + + mean = 2.4852299614214509e-08 + + stddev = 4.2334485106268430e-02 + - geographical_y_wind (10 levels): + + min = -1.6892294705901070e-01 + + max = 1.7430694776764738e-01 + + mean = 2.7094601781320704e-08 + + stddev = 4.2189266107490908e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.1780613384474439e+00 + + max = 1.1845975436831864e+00 + + mean = -3.9885750406572331e-03 + + stddev = 2.5980541935591933e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.1797906598123078e-04 + + max = 7.5604325892053396e-04 + + mean = 1.7225221398760031e-06 + + stddev = 1.6437704410266504e-04 +Member 9: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7251537797482322e-01 + + max = 2.2493601517556483e-01 + + mean = 4.7105669796812075e-08 + + stddev = 4.4065132528592413e-02 + - geographical_y_wind (10 levels): + + min = -1.6010577134917742e-01 + + max = 1.4529924201272612e-01 + + mean = 1.4230318163455757e-08 + + stddev = 4.0895155477544055e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.0048332186247806e+00 + + max = 1.4060890613968677e+00 + + mean = 1.2250139057460150e-02 + + stddev = 2.6560946600106933e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -5.9680791262077581e-04 + + max = 6.8750465957504716e-04 + + mean = -9.8198457512191995e-06 + + stddev = 1.6128967067672589e-04 +Member 10: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.8013339295820524e-01 + + max = 1.7431667434524320e-01 + + mean = 4.0691464003601848e-08 + + stddev = 3.9628499883816691e-02 + - geographical_y_wind (10 levels): + + min = -1.9048666220847912e-01 + + max = 1.5922617459978636e-01 + + mean = 2.7567945856757370e-08 + + stddev = 4.1316474772179215e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.0814607698810323e+00 + + max = 1.0386322396314926e+00 + + mean = -1.5544780090872769e-03 + + stddev = 2.5737658533265539e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.5289926243468680e-04 + + max = 6.9175451449481301e-04 + + mean = 2.3482756192581022e-06 + + stddev = 1.5952426768490327e-04 +Member 11: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.5599354615460778e-01 + + max = 1.7048758945239420e-01 + + mean = 8.6102093073132010e-08 + + stddev = 4.1558178707230747e-02 + - geographical_y_wind (10 levels): + + min = -1.6330084068554349e-01 + + max = 1.7104015830298536e-01 + + mean = 5.3282592660331272e-08 + + stddev = 4.4390204777802332e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.0826848790488888e+00 + + max = 1.2045923170297568e+00 + + mean = 8.8994498740845966e-03 + + stddev = 2.5098933395046091e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.1405988749615801e-04 + + max = 7.1838888189628108e-04 + + mean = -5.2984745650163174e-06 + + stddev = 1.6163280402853357e-04 +Member 12: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7991174676150518e-01 + + max = 1.9684828712621730e-01 + + mean = 1.4984575653828988e-07 + + stddev = 4.4069516877739523e-02 + - geographical_y_wind (10 levels): + + min = -1.6830934434963910e-01 + + max = 1.6081382186325105e-01 + + mean = -2.1170452538691582e-08 + + stddev = 4.0306998450311882e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.0901791668754666e+00 + + max = 1.1145235564391753e+00 + + mean = 1.7913770555205665e-02 + + stddev = 2.6673837699233099e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.2735318367578294e-04 + + max = 6.2925344499546363e-04 + + mean = 2.7170147555572416e-06 + + stddev = 1.6170831114225187e-04 +Member 13: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6199594062092612e-01 + + max = 1.5842744026585134e-01 + + mean = -1.3058717115470103e-07 + + stddev = 4.1290813873641155e-02 + - geographical_y_wind (10 levels): + + min = -2.0393280875968678e-01 + + max = 1.6932279878855028e-01 + + mean = 4.5283692811441461e-08 + + stddev = 4.6213367636232738e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.0526391289188506e+00 + + max = 1.1108553964530801e+00 + + mean = 1.3803907073372590e-02 + + stddev = 2.5203924786292947e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.9290446125873872e-04 + + max = 6.7370819854016128e-04 + + mean = 4.6486765633031707e-06 + + stddev = 1.5733250133477777e-04 +Member 14: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.5359295733190267e-01 + + max = 1.5727859974150657e-01 + + mean = -9.0363976073924516e-08 + + stddev = 4.2149559201343702e-02 + - geographical_y_wind (10 levels): + + min = -1.6505824179386619e-01 + + max = 1.4330496474390667e-01 + + mean = 4.1068941202734907e-08 + + stddev = 3.9052146429100695e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.0268302457960574e+00 + + max = 1.2389671192256821e+00 + + mean = 1.5919605078868783e-02 + + stddev = 2.5861575418555471e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.3046225491574604e-04 + + max = 6.4838074727731256e-04 + + mean = -4.1216819257519919e-06 + + stddev = 1.5890025033133337e-04 +Member 15: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7205650300563774e-01 + + max = 1.7515381612639516e-01 + + mean = 5.8642927321917741e-08 + + stddev = 4.4353638320003975e-02 + - geographical_y_wind (10 levels): + + min = -1.8568403579992004e-01 + + max = 1.6502795595374140e-01 + + mean = 4.3588132927048287e-08 + + stddev = 4.3122077371634919e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.1232338514017124e+00 + + max = 1.0345608452828901e+00 + + mean = -4.5830963556902455e-03 + + stddev = 2.5833739503057684e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.7193812127187749e-04 + + max = 7.9173616934585952e-04 + + mean = 5.3139076862394640e-06 + + stddev = 1.6363271042611684e-04 +Member 16: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.4317337868588767e-01 + + max = 1.7138923898879713e-01 + + mean = -2.1447382098167038e-08 + + stddev = 4.2235083888161579e-02 + - geographical_y_wind (10 levels): + + min = -1.7051473260223629e-01 + + max = 1.7686129505006992e-01 + + mean = 7.8691481679077376e-08 + + stddev = 4.4470745138391644e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.4232316177830906e+00 + + max = 1.1626880163003088e+00 + + mean = 9.8965374008610756e-03 + + stddev = 2.5641872615388689e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.7642316083538364e-04 + + max = 7.0053287954959182e-04 + + mean = 2.3894005240041913e-06 + + stddev = 1.6246049340683678e-04 +Member 17: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.5637276521920315e-01 + + max = 1.8809767239499872e-01 + + mean = 1.8167393758418732e-07 + + stddev = 4.4566017105721605e-02 + - geographical_y_wind (10 levels): + + min = -2.0068119934855924e-01 + + max = 1.9182740374772145e-01 + + mean = -2.4541894615215685e-08 + + stddev = 4.5081170618287876e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.1917602251546855e+00 + + max = 1.0742991282296623e+00 + + mean = -1.7129366219071056e-02 + + stddev = 2.5089972012282946e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.3135253571582461e-04 + + max = 6.5547582858691694e-04 + + mean = -9.9103843541436117e-06 + + stddev = 1.6368298204098110e-04 +Member 18: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6625833543380525e-01 + + max = 1.6621493019080871e-01 + + mean = 1.4897291031213612e-08 + + stddev = 4.1038868417407344e-02 + - geographical_y_wind (10 levels): + + min = -1.8114590246029355e-01 + + max = 1.6812739007676719e-01 + + mean = 1.4988869849122998e-08 + + stddev = 4.2569557360069732e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.0428556531718254e+00 + + max = 1.0711684508194694e+00 + + mean = -6.5646197919822149e-03 + + stddev = 2.5956394685439804e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.6845616044118777e-04 + + max = 7.0748068141615757e-04 + + mean = -2.8317799501950700e-06 + + stddev = 1.6346002193023533e-04 +Member 19: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -2.1637516017086286e-01 + + max = 1.6376648891851389e-01 + + mean = 5.5637246389693663e-08 + + stddev = 4.1230011731577518e-02 + - geographical_y_wind (10 levels): + + min = -1.6145211720069910e-01 + + max = 1.6062406609407021e-01 + + mean = -8.9799276816907576e-08 + + stddev = 4.2454152650471741e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.1253179165826674e+00 + + max = 1.1387119330295845e+00 + + mean = 4.3371980004277731e-04 + + stddev = 2.6741172872224878e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -8.0186416349993647e-04 + + max = 7.2169660594307368e-04 + + mean = -1.0882711776272887e-05 + + stddev = 1.5906239076899018e-04 +Member 20: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.9001331971511698e-01 + + max = 1.9294050569905052e-01 + + mean = -6.3009532906542492e-09 + + stddev = 4.5688692298868579e-02 + - geographical_y_wind (10 levels): + + min = -1.7680914176418580e-01 + + max = 1.5748247810500687e-01 + + mean = 9.8373804865738259e-09 + + stddev = 4.1634942348774066e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.2260511516892865e+00 + + max = 9.6390305424282152e-01 + + mean = -5.0572401700209211e-03 + + stddev = 2.6249014705025248e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.6924218790871855e-04 + + max = 6.8372680795749730e-04 + + mean = 5.8846957422012345e-06 + + stddev = 1.6385205316837089e-04 +Member 21: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6001941297520786e-01 + + max = 1.8674653645867884e-01 + + mean = -6.2477003420744297e-09 + + stddev = 4.4494183016277201e-02 + - geographical_y_wind (10 levels): + + min = -1.7628980949528708e-01 + + max = 1.8060742585526016e-01 + + mean = 2.0133016200715747e-08 + + stddev = 4.2293844585848145e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.1296555107998705e+00 + + max = 1.0702235127879014e+00 + + mean = -5.7528099116363361e-03 + + stddev = 2.4873566226871677e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.4604917885568297e-04 + + max = 6.2621383676930177e-04 + + mean = 4.5750089574706927e-07 + + stddev = 1.6036892905966753e-04 +Member 22: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6611079518080013e-01 + + max = 1.6519439648220596e-01 + + mean = 6.3489957013911860e-09 + + stddev = 4.5113247092363799e-02 + - geographical_y_wind (10 levels): + + min = -1.5460898044660187e-01 + + max = 1.6961526215115089e-01 + + mean = 3.0447811526616065e-08 + + stddev = 4.1010432430819282e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.1059758870702119e+00 + + max = 1.1963206145694971e+00 + + mean = 2.9169717696604525e-03 + + stddev = 2.6627930881171230e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -7.8911199879089190e-04 + + max = 6.2509630941989965e-04 + + mean = -9.4643497452641772e-07 + + stddev = 1.5602963467395664e-04 +Member 23: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.7609433125306409e-01 + + max = 1.5664913449025633e-01 + + mean = 5.9895732793386569e-08 + + stddev = 4.2175159069296399e-02 + - geographical_y_wind (10 levels): + + min = -1.6713222412033246e-01 + + max = 1.6480180707051131e-01 + + mean = 7.3294767903202452e-08 + + stddev = 4.0439410074063591e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -1.1465837692174290e+00 + + max = 1.1313921142952250e+00 + + mean = -1.1747616247127078e-02 + + stddev = 2.6057082171055684e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.7245605784053562e-04 + + max = 7.4283783214804772e-04 + + mean = 8.0713655029419023e-06 + + stddev = 1.5859174261441305e-04 +Member 24: +- Valid time: 2010-01-01T12:00:00Z + Geometry: structured [3723] + Fields: + - geographical_x_wind (10 levels): + + min = -1.6923852601056733e-01 + + max = 1.7289288103629458e-01 + + mean = 3.3450851733819280e-08 + + stddev = 4.0741324127956703e-02 + - geographical_y_wind (10 levels): + + min = -1.8740960491132602e-01 + + max = 1.7408411928327963e-01 + + mean = 3.7351770855617562e-08 + + stddev = 4.2851062451600350e-02 + - air_temperature_and_log_of_air_pressure_at_surface (11 levels): + + min = -9.5247036080838376e-01 + + max = 1.1131103556335833e+00 + + mean = 2.4084552705575801e-02 + + stddev = 2.5132685703388358e-01 + - water_vapor_mixing_ratio_wrt_moist_air (10 levels): + + min = -6.8053266648248809e-04 + + max = 6.8927958940581528e-04 + + mean = 4.6749961480204465e-07 + + stddev = 1.6714414182351629e-04 From 8dd883ab6d1dc8c84027c7f13d19b35b8a108601 Mon Sep 17 00:00:00 2001 From: Matt Shin Date: Wed, 3 Dec 2025 15:08:47 +0000 Subject: [PATCH 137/199] Fix compiler warnings (#1152) * Fix compiler warnings Fix warnings of types: * "ERR" redefined * defined but not used * unused variable * Remove ERR fixes Prefer fixing root cause at oops header. --- src/saber/diffusion/Diffusion.cc | 2 -- src/saber/interpolation/VectorFieldMetadata.cc | 5 ++--- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/src/saber/diffusion/Diffusion.cc b/src/saber/diffusion/Diffusion.cc index 98d64c152..25d999315 100644 --- a/src/saber/diffusion/Diffusion.cc +++ b/src/saber/diffusion/Diffusion.cc @@ -245,8 +245,6 @@ void Diffusion::multiply(oops::FieldSet3D & fset) const { // -------------------------------------------------------------------------------------- void Diffusion::filter(oops::FieldSet3D & fset) const { - const atlas::FunctionSpace & fs = geom_.functionSpace(); - // iterate through the list of groups for (const auto & group : groups_) { // get the subset of fields, or create a common field if doing duplicated variable diff --git a/src/saber/interpolation/VectorFieldMetadata.cc b/src/saber/interpolation/VectorFieldMetadata.cc index 2fc1d62e1..a6ca0f312 100644 --- a/src/saber/interpolation/VectorFieldMetadata.cc +++ b/src/saber/interpolation/VectorFieldMetadata.cc @@ -18,11 +18,11 @@ namespace saber { namespace interpolation { +#ifdef ATLAS_SUPPORTS_SPHERICAL_VECTOR_INTERP_META namespace { // Retrieves the vector field configuration for a given variable name, if there is one. atlas::util::Config getVectorFieldOpt(const std::string_view varName) { -#ifdef ATLAS_SUPPORTS_SPHERICAL_VECTOR_INTERP_META constexpr size_t xComponent = 0; constexpr size_t yComponent = 1; @@ -36,13 +36,12 @@ atlas::util::Config getVectorFieldOpt(const std::string_view varName) { return atlas::option::vector_component("wind_at_10m", yComponent); } -#endif // ATLAS_SUPPORTS_SPHERICAL_VECTOR_INTERP_META - // Empty config - don't add any vector config to this field. return atlas::util::Config(); } } // namespace +#endif // ATLAS_SUPPORTS_SPHERICAL_VECTOR_INTERP_META // ------------------------------------------------------------------------------------------------ From bf4c9e9d099dee7d09716392f9877efe9269c1e0 Mon Sep 17 00:00:00 2001 From: Marek Wlasak Date: Mon, 8 Dec 2025 15:56:09 +0000 Subject: [PATCH 138/199] Feature/parallel b (#1148) * add disabling switch * First stab * adding "run components recursively" to dirac yaml when running "hybrid" * all tests running as before. Now need to make a bespoke test with a fractional PE covariance allocation. * Ratio of parallelisation of B * corrected comment * removing whitespace * slightly cleaner code * This is an empty commit * Add missing param * Update test/testinput/dirac_bump_1.yaml Co-authored-by: Nate Crossette * Update test/testinput/dirac_bump_3.yaml Co-authored-by: Nate Crossette * Update test/testinput/dirac_parallel_hybrid_id.yaml Co-authored-by: Nate Crossette * Update test/testinput/dirac_parallel_hybrid_ratio_stddev.yaml Co-authored-by: Nate Crossette * Update test/testinput/dirac_parallel_hybrid_stddev.yaml Co-authored-by: Nate Crossette --------- Co-authored-by: mo-joshuacolclough Co-authored-by: Nate Crossette --- src/saber/generic/Hybrid.h | 7 ++ src/saber/oops/ErrorCovariance.h | 103 +++++++++++++----- src/saber/oops/ErrorCovarianceToolbox.h | 35 ++++-- test/CMakeLists.txt | 9 ++ .../dirac_parallel_hybrid_ratio_stddev.txt | 2 + test/testinput/dirac_bump_1.yaml | 1 + test/testinput/dirac_bump_2.yaml | 1 + test/testinput/dirac_bump_3.yaml | 1 + test/testinput/dirac_bump_4.yaml | 1 + test/testinput/dirac_bump_6.yaml | 1 + test/testinput/dirac_ens_both_geom.yaml | 1 + test/testinput/dirac_ens_other_geom_2.yaml | 1 + test/testinput/dirac_parallel_hybrid_id.yaml | 1 - .../dirac_parallel_hybrid_ratio_stddev.yaml | 74 +++++++++++++ ...irac_spectralb_covariance_rescaling_1.yaml | 1 + test/testinput/dirac_spectralb_gauss_1.yaml | 2 + test/testinput/dirac_spectralb_gauss_2.yaml | 1 + .../dirac_spectralb_gauss_vader_3.yaml | 1 + .../dirac_spectralb_gauss_vader_5.yaml | 1 + test/testlist/saber_test_tier1-spectralb.txt | 3 + test/testref/dirac_parallel_hybrid_id.ref | 43 +------- .../dirac_parallel_hybrid_ratio_stddev.ref | 1 + test/testref/dirac_parallel_hybrid_stddev.ref | 18 +-- 23 files changed, 223 insertions(+), 86 deletions(-) create mode 100644 test/testdeps/dirac_parallel_hybrid_ratio_stddev.txt create mode 100644 test/testinput/dirac_parallel_hybrid_ratio_stddev.yaml create mode 100644 test/testref/dirac_parallel_hybrid_ratio_stddev.ref diff --git a/src/saber/generic/Hybrid.h b/src/saber/generic/Hybrid.h index 038d93819..d52936fc5 100644 --- a/src/saber/generic/Hybrid.h +++ b/src/saber/generic/Hybrid.h @@ -91,6 +91,13 @@ class HybridParameters : public SaberBlockParametersBase { // Switch to run components in parallel oops::Parameter runInParallel{"run in parallel", false, this}; + // Switch to run components recursively (for diagnostics) + oops::Parameter runComponentsRecursively{"run components recursively", false, this}; + + // Resource weighting for each hybrid component. + oops::OptionalParameter> parallelCovarRelativeCPUWeight{ + "parallel covariance relative cpu weight", this}; + oops::Variables mandatoryActiveVars() const override {return oops::Variables();} }; diff --git a/src/saber/oops/ErrorCovariance.h b/src/saber/oops/ErrorCovariance.h index 5a83e4fe0..c33cb9e6b 100644 --- a/src/saber/oops/ErrorCovariance.h +++ b/src/saber/oops/ErrorCovariance.h @@ -8,7 +8,9 @@ #pragma once +#include #include +#include #include #include @@ -231,20 +233,53 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, eckit::LocalConfiguration hybridConf = saberCentralBlockParams.toConfiguration(); parallelHybrid_ = hybridConf.getBool("run in parallel"); - + const eckit::mpi::Comm & defaultSpaceComm = geom.getComm(); + const size_t ntasks = defaultSpaceComm.size(); const size_t nComponents = hybridConf.getSubConfigurations("components").size(); - const eckit::mpi::Comm & globalSpaceComm = geom.getComm(); - const size_t ntasks = globalSpaceComm.size(); - - if (parallelHybrid_ && ntasks % nComponents != 0) { - oops::Log::warning() << "Warning : Number of MPI tasks not divisible " - "by number of Hybrid block components, running serially." - << std::endl; - parallelHybrid_ = false; - } + + std::vector parallelCovRelativeCpuWeight = + hybridConf.has("parallel covariance relative cpu weight") ? + hybridConf.getDoubleVector("parallel covariance relative cpu weight") : + std::vector(nComponents, + 1.0 / static_cast(nComponents)); + + std::vector ntasksPerComponent(nComponents, 0); + std::vector globalTaskOffsetPerComponent(nComponents+1, 0); if (parallelHybrid_) { oops::Log::info() << "Info : Creating Hybrid block in parallel" << std::endl; + // checks + ASSERT(nComponents == parallelCovRelativeCpuWeight.size()); + + // need to check to ensure that the total sum of PEs over components is consistent + // with the MPI size on the default communicator and that each component + // has a minimum MPI size of 1. + for (size_t component = 0; component < nComponents; ++component) { + ntasksPerComponent[component] = + std::round(parallelCovRelativeCpuWeight[component] * ntasks); + ASSERT(ntasksPerComponent[component] > 0); + } + int discrepencyPE = + std::accumulate(ntasksPerComponent.begin(), ntasksPerComponent.end(), 0) - ntasks; + + for (size_t component = 0; component < nComponents && discrepencyPE != 0; ++component) { + if (discrepencyPE > 0 && ntasksPerComponent[component] >= 2) { + ntasksPerComponent[component] -= 1; + discrepencyPE -= 1; + } else if (discrepencyPE < 0) { + ntasksPerComponent[component] += 1; + discrepencyPE += 1; + } + } + + ASSERT(std::accumulate(ntasksPerComponent.begin(), + ntasksPerComponent.end(), 0) - ntasks == 0); + + for (size_t component = 1; component < nComponents; ++component) { + globalTaskOffsetPerComponent[component] = + globalTaskOffsetPerComponent[component-1] + ntasksPerComponent[component-1]; + } + globalTaskOffsetPerComponent[nComponents] = ntasks; if (dualResParams != boost::none) { throw eckit::NotImplemented("Parallel Hybrid not compatible " @@ -253,12 +288,20 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, } const eckit::mpi::Comm & initialDefaultComm = eckit::mpi::comm(); - ASSERT(initialDefaultComm.name() == globalSpaceComm.name()); + ASSERT(initialDefaultComm.name() == defaultSpaceComm.name()); // We split the space communicators only, the time parallelization is untouched - const size_t myTask = globalSpaceComm.rank(); - const size_t tasksPerComponent = ntasks / nComponents; - myComponent_ = myTask / tasksPerComponent; + const size_t myTask = defaultSpaceComm.rank(); + + // Set myComponent_ tasksPerComponent + size_t tasksPerComponent; + for (size_t component = 0; component < nComponents; ++component) { + if ((myTask >= globalTaskOffsetPerComponent[component]) && + (myTask < globalTaskOffsetPerComponent[component+1])) { + myComponent_ = component; + tasksPerComponent = ntasksPerComponent[component]; + } + } oops::Log::info() << "Info : Creating component " << myComponent_ + 1 << "/" << nComponents @@ -270,7 +313,7 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, if (eckit::mpi::hasComm(spaceCommName.c_str())) { eckit::mpi::deleteComm(spaceCommName.c_str()); } - const auto & localSpaceComm = globalSpaceComm.split(myComponent_, spaceCommName.c_str()); + const auto & localSpaceComm = defaultSpaceComm.split(myComponent_, spaceCommName.c_str()); // Set up default MPI communicator for atlas eckit::mpi::setCommDefault(localSpaceComm.name().c_str()); @@ -292,18 +335,18 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, for (size_t jtime = 0; jtime < xb.size(); jtime++) { util::redistributeToSubcommunicator(xb[jtime].fieldSet().fieldSet(), localXb[jtime].fieldSet().fieldSet(), - globalSpaceComm, + defaultSpaceComm, localSpaceComm, geom.functionSpace(), localHybridGeom_->functionSpace()); util::redistributeToSubcommunicator(fg[jtime].fieldSet().fieldSet(), localFg[jtime].fieldSet().fieldSet(), - globalSpaceComm, + defaultSpaceComm, localSpaceComm, geom.functionSpace(), localHybridGeom_->functionSpace()); } - globalSpaceComm.barrier(); + defaultSpaceComm.barrier(); const oops::FieldSet4D localFset4dXbTmp(localXb); const oops::FieldSet4D localFset4dFgTmp(localFg); @@ -381,7 +424,7 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, ASSERT(hybridBlockChain_.size() > 0); // Restore previous default MPI communicator for atlas - eckit::mpi::setCommDefault(globalSpaceComm.name().c_str()); + eckit::mpi::setCommDefault(defaultSpaceComm.name().c_str()); } else { oops::Log::info() << "Info : Creating Hybrid block serially" << std::endl; // Create block geometry (needed for ensemble reading) @@ -514,11 +557,11 @@ void ErrorCovariance::doRandomize(Increment4D_ & dx) const { ASSERT(hybridBlockChain_.size() == 1); // global communicator and functionSpace - const auto & globalSpaceComm = dx.geometry().getComm(); + const auto & defaultSpaceComm = dx.geometry().getComm(); const auto & globalFunctionSpace = dx.geometry().functionSpace(); // check global communicator is the default one for atlas MPI - ASSERT(eckit::mpi::comm().name() == globalSpaceComm.name()); + ASSERT(eckit::mpi::comm().name() == defaultSpaceComm.name()); // subcommunicator within this component const auto spaceCommName = "comm_space_" + std::to_string(myComponent_); @@ -543,20 +586,20 @@ void ErrorCovariance::doRandomize(Increment4D_ & dx) const { } // Add components - globalSpaceComm.barrier(); + defaultSpaceComm.barrier(); for (size_t jtime = 0; jtime < fset4dCmp.size(); jtime++) { // Redistribute to global communicator and sum util::gatherAndSumFromSubcommunicator(fset4dCmp[jtime].fieldSet(), fset4dSum[jtime].fieldSet(), localSpaceComm, - globalSpaceComm, + defaultSpaceComm, localHybridGeom_->functionSpace(), globalFunctionSpace); } // Restore atlas MPI to previous - eckit::mpi::setCommDefault(globalSpaceComm.name().c_str()); + eckit::mpi::setCommDefault(defaultSpaceComm.name().c_str()); fset4dSum += fset4dCmp; } else { @@ -619,9 +662,9 @@ void ErrorCovariance::doMultiply(const Increment4D_ & dxi, ASSERT(hybridFieldWeightSqrt_.size() == 1); // Global communicator - const auto & globalSpaceComm = dxi.geometry().getComm(); + const auto & defaultSpaceComm = dxi.geometry().getComm(); const auto & globalFunctionSpace = dxi.geometry().functionSpace(); - ASSERT(globalSpaceComm.name() == eckit::mpi::comm().name()); + ASSERT(defaultSpaceComm.name() == eckit::mpi::comm().name()); // Subcommunicator within component const std::string spaceCommName = "comm_space_" + std::to_string(myComponent_); @@ -632,7 +675,7 @@ void ErrorCovariance::doMultiply(const Increment4D_ & dxi, for (size_t jtime = 0; jtime < fset4dCmp.size(); jtime++) { util::redistributeToSubcommunicator(fset4dInit[jtime].fieldSet(), fset4dCmp[jtime].fieldSet(), - globalSpaceComm, + defaultSpaceComm, localSpaceComm, globalFunctionSpace, localHybridGeom_->functionSpace()); @@ -665,20 +708,20 @@ void ErrorCovariance::doMultiply(const Increment4D_ & dxi, } // Wait for all components to have finished multiplying - globalSpaceComm.barrier(); + defaultSpaceComm.barrier(); // Gather and sum data across components for (size_t jtime = 0; jtime < fset4dCmp.size(); jtime++) { util::gatherAndSumFromSubcommunicator(fset4dCmp[jtime].fieldSet(), fset4dSum[jtime].fieldSet(), localSpaceComm, - globalSpaceComm, + defaultSpaceComm, localHybridGeom_->functionSpace(), globalFunctionSpace); } // Set back default MPI communicator - eckit::mpi::setCommDefault(globalSpaceComm.name().c_str()); + eckit::mpi::setCommDefault(defaultSpaceComm.name().c_str()); } else { if (hybridBlockChain_.size() > 1) { diff --git a/src/saber/oops/ErrorCovarianceToolbox.h b/src/saber/oops/ErrorCovarianceToolbox.h index 30bee2dfd..984b4e370 100644 --- a/src/saber/oops/ErrorCovarianceToolbox.h +++ b/src/saber/oops/ErrorCovarianceToolbox.h @@ -441,25 +441,40 @@ template class ErrorCovarianceToolbox : public oops::Applicatio // Look for hybrid or ensemble covariance models const std::string covarianceModel(covarConf.getString("covariance model")); - if (covarianceModel == "hybrid") { - std::vector confs; - covarConf.get("components", confs); - size_t componentIndex(1); - for (const auto & conf : confs) { - std::string idC(id + std::to_string(componentIndex)); - const eckit::LocalConfiguration componentConfig(conf, "covariance"); - dirac(componentConfig, testConf, idC, geom, vars, xx, dxi); - ++componentIndex; + bool runComponentsRecursively = + covarConf.has("run components recursively") ? + covarConf.getBool("run components recursively") : false; + + oops::Log::info() << "Covariance Configuration : Running components recursively : " + << covarConf << " " << covarConf.has("run components recursively") << " " + << runComponentsRecursively << std::endl; + + if (runComponentsRecursively) { + if (covarianceModel == "hybrid") { + std::vector confs; + covarConf.get("components", confs); + size_t componentIndex(1); + for (const auto & conf : confs) { + std::string idC(id + std::to_string(componentIndex)); + const eckit::LocalConfiguration componentConfig(conf, "covariance"); + dirac(componentConfig, testConf, idC, geom, vars, xx, dxi); + ++componentIndex; + } } } if (covarianceModel == "SABER") { const std::string saberCentralBlockName = covarConf.getString("saber central block.saber block name"); + bool runComponentsRecursively = + covarConf.has("saber central block.run components recursively") ? + covarConf.getBool("saber central block.run components recursively") : + false; if (saberCentralBlockName == "Hybrid") { // Check for outer blocks (can't pass the correct geometry/variables in that case) - if (!covarConf.has("saber outer blocks")) { + if (!covarConf.has("saber outer blocks") && (runComponentsRecursively)) { std::vector confs; covarConf.get("saber central block.components", confs); + size_t componentIndex(1); for (const auto & conf : confs) { std::string idC(id + std::to_string(componentIndex)); diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 5fcc15af6..866239604 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -418,3 +418,12 @@ if( SABER_TEST_BUMP ) SOURCES fctest/fctest_nicas_sqrt.F90 LIBS saber ) endif() + +# A bespoke test for parallel B +set( mpi 5 ) +set( omp 1 ) +ecbuild_add_test( TARGET saber_test_dirac_parallel_hybrid_ratio_stddev_5-1 + MPI ${mpi} + OMP ${omp} + COMMAND ${CMAKE_BINARY_DIR}/bin/saber_quench_error_covariance_toolbox.x + ARGS testinput/dirac_parallel_hybrid_ratio_stddev.yaml) diff --git a/test/testdeps/dirac_parallel_hybrid_ratio_stddev.txt b/test/testdeps/dirac_parallel_hybrid_ratio_stddev.txt new file mode 100644 index 000000000..4637ab71d --- /dev/null +++ b/test/testdeps/dirac_parallel_hybrid_ratio_stddev.txt @@ -0,0 +1,2 @@ +error_covariance_training_stddev_1 +error_covariance_training_stddev_2 diff --git a/test/testinput/dirac_bump_1.yaml b/test/testinput/dirac_bump_1.yaml index 03a27bc42..7a5e1c31b 100644 --- a/test/testinput/dirac_bump_1.yaml +++ b/test/testinput/dirac_bump_1.yaml @@ -25,6 +25,7 @@ background: - northward_wind background error: covariance model: hybrid + run components recursively: true components: - covariance: covariance model: SABER diff --git a/test/testinput/dirac_bump_2.yaml b/test/testinput/dirac_bump_2.yaml index 1f50a2408..218681c25 100644 --- a/test/testinput/dirac_bump_2.yaml +++ b/test/testinput/dirac_bump_2.yaml @@ -23,6 +23,7 @@ background: - northward_wind background error: covariance model: hybrid + run components recursively: true components: - covariance: covariance model: SABER diff --git a/test/testinput/dirac_bump_3.yaml b/test/testinput/dirac_bump_3.yaml index 191b3243c..487b374a8 100644 --- a/test/testinput/dirac_bump_3.yaml +++ b/test/testinput/dirac_bump_3.yaml @@ -22,6 +22,7 @@ background error: square-root test: true saber central block: saber block name: Hybrid + run components recursively: true components: - covariance: saber central block: diff --git a/test/testinput/dirac_bump_4.yaml b/test/testinput/dirac_bump_4.yaml index 61432be65..f268b686a 100644 --- a/test/testinput/dirac_bump_4.yaml +++ b/test/testinput/dirac_bump_4.yaml @@ -22,6 +22,7 @@ background error: square-root test: true saber central block: saber block name: Hybrid + run components recursively: true components: - covariance: saber central block: diff --git a/test/testinput/dirac_bump_6.yaml b/test/testinput/dirac_bump_6.yaml index a6d267416..ef130aeda 100644 --- a/test/testinput/dirac_bump_6.yaml +++ b/test/testinput/dirac_bump_6.yaml @@ -16,6 +16,7 @@ background: - northward_wind background error: covariance model: hybrid + run components recursively: true components: - covariance: covariance model: SABER diff --git a/test/testinput/dirac_ens_both_geom.yaml b/test/testinput/dirac_ens_both_geom.yaml index 8cb72eb57..cea5f30e8 100644 --- a/test/testinput/dirac_ens_both_geom.yaml +++ b/test/testinput/dirac_ens_both_geom.yaml @@ -22,6 +22,7 @@ background error: covariance model: SABER saber central block: saber block name: Hybrid + run components recursively: true components: - weight: value: 0.5 diff --git a/test/testinput/dirac_ens_other_geom_2.yaml b/test/testinput/dirac_ens_other_geom_2.yaml index 800cbb237..2d230b527 100644 --- a/test/testinput/dirac_ens_other_geom_2.yaml +++ b/test/testinput/dirac_ens_other_geom_2.yaml @@ -21,6 +21,7 @@ background error: covariance model: SABER saber central block: saber block name: Hybrid + run components recursively: true components: ########################################################################### # Waveband 1 - F14 grid diff --git a/test/testinput/dirac_parallel_hybrid_id.yaml b/test/testinput/dirac_parallel_hybrid_id.yaml index e72c30b13..4bcfa7a2c 100644 --- a/test/testinput/dirac_parallel_hybrid_id.yaml +++ b/test/testinput/dirac_parallel_hybrid_id.yaml @@ -17,7 +17,6 @@ background: background error: covariance model: SABER adjoint test: true - randomization size: 1 saber central block: saber block name: Hybrid run in parallel: true diff --git a/test/testinput/dirac_parallel_hybrid_ratio_stddev.yaml b/test/testinput/dirac_parallel_hybrid_ratio_stddev.yaml new file mode 100644 index 000000000..8fd6628b7 --- /dev/null +++ b/test/testinput/dirac_parallel_hybrid_ratio_stddev.yaml @@ -0,0 +1,74 @@ +geometry: &geom + function space: StructuredColumns + grid: + type: regular_lonlat + N: 10 + groups: + - variables: &vars + - air_horizontal_streamfunction + - air_horizontal_velocity_potential + levels: 2 + halo: 1 + +background: + states: + - date: 2010-01-01T12:00:00Z + state variables: *vars + +background error: + covariance model: SABER + adjoint test: true + saber central block: + saber block name: Hybrid + run in parallel: true + parallel covariance relative cpu weight: + - 0.6 + - 0.4 + geometry: *geom + components: + - weight: + value: 0.5 + covariance: + saber central block: + saber block name: ID + saber outer blocks: + - saber block name: StdDev + read: + model file: + filepath: testdata/error_covariance_training_stddev_1/2-_OMP__stddev + - weight: + value: 0.5 + covariance: + saber central block: + saber block name: ID + saber outer blocks: + - saber block name: StdDev + read: + model file: + filepath: testdata/error_covariance_training_stddev_2/2-_OMP__stddev + saber outer blocks: + - saber block name: write fields + save netCDF file: false + output path: testdata/dirac_parallel_hybrid_ratio_stddev + multiply fset filename: fields_in_multiply +dirac: &dirac + lon: + - 0.0 + lat: + - 0.0 + level: + - 1 + variable: + - air_horizontal_streamfunction + +diagnostic points: *dirac + +output dirac: + mpi pattern: '%MPI%' + filepath: testdata/dirac_parallel_hybrid_ratio_stddev/%MPI%_dirac_%id% + +# The result from this should be the same as dirac_parallel_hybrid_stddev.ref +# as all we are doing is splitting the communicator in a different way +test: + reference filename: testref/dirac_parallel_hybrid_stddev.ref + diff --git a/test/testinput/dirac_spectralb_covariance_rescaling_1.yaml b/test/testinput/dirac_spectralb_covariance_rescaling_1.yaml index ee7f875af..db53853d9 100644 --- a/test/testinput/dirac_spectralb_covariance_rescaling_1.yaml +++ b/test/testinput/dirac_spectralb_covariance_rescaling_1.yaml @@ -20,6 +20,7 @@ background error: covariance model: SABER saber central block: saber block name: Hybrid + run components recursively: true components: - weight: value: 1.0 diff --git a/test/testinput/dirac_spectralb_gauss_1.yaml b/test/testinput/dirac_spectralb_gauss_1.yaml index afb847b79..684213c5a 100644 --- a/test/testinput/dirac_spectralb_gauss_1.yaml +++ b/test/testinput/dirac_spectralb_gauss_1.yaml @@ -68,6 +68,8 @@ background error: adjoint test: false saber central block: saber block name: Hybrid + run components recursively: true + run in parallel: false components: # =========================================================== # Waveband 1 diff --git a/test/testinput/dirac_spectralb_gauss_2.yaml b/test/testinput/dirac_spectralb_gauss_2.yaml index d6d7b9f45..24dd6a744 100644 --- a/test/testinput/dirac_spectralb_gauss_2.yaml +++ b/test/testinput/dirac_spectralb_gauss_2.yaml @@ -68,6 +68,7 @@ background error: adjoint test: false saber central block: saber block name: Hybrid + run components recursively: true components: # =========================================================== # Waveband 1 diff --git a/test/testinput/dirac_spectralb_gauss_vader_3.yaml b/test/testinput/dirac_spectralb_gauss_vader_3.yaml index 1fa562282..1721cb969 100644 --- a/test/testinput/dirac_spectralb_gauss_vader_3.yaml +++ b/test/testinput/dirac_spectralb_gauss_vader_3.yaml @@ -57,6 +57,7 @@ geometry: halo: 1 background error: covariance model: hybrid + run components recursively: true components: - covariance: covariance model: SABER diff --git a/test/testinput/dirac_spectralb_gauss_vader_5.yaml b/test/testinput/dirac_spectralb_gauss_vader_5.yaml index 42b9a68da..a36bddfe6 100644 --- a/test/testinput/dirac_spectralb_gauss_vader_5.yaml +++ b/test/testinput/dirac_spectralb_gauss_vader_5.yaml @@ -80,6 +80,7 @@ background error: adjoint test: false saber central block: saber block name: Hybrid + run components recursively: true components: # =========================================================== # Waveband 1 diff --git a/test/testlist/saber_test_tier1-spectralb.txt b/test/testlist/saber_test_tier1-spectralb.txt index bcae2cd2a..40d5ffa83 100644 --- a/test/testlist/saber_test_tier1-spectralb.txt +++ b/test/testlist/saber_test_tier1-spectralb.txt @@ -7,6 +7,9 @@ dirac_ens_model_geom dirac_ens_other_geom_1 dirac_ens_other_geom_2 dirac_interpolation_1 +dirac_parallel_hybrid_id +dirac_parallel_hybrid_stddev +dirac_parallel_hybrid_ratio_stddev dirac_spectralb dirac_spectralb_and_touv dirac_spectralb_correlation_profiles diff --git a/test/testref/dirac_parallel_hybrid_id.ref b/test/testref/dirac_parallel_hybrid_id.ref index 0f7a1e7f7..7deb9fc00 100644 --- a/test/testref/dirac_parallel_hybrid_id.ref +++ b/test/testref/dirac_parallel_hybrid_id.ref @@ -6,10 +6,12 @@ Input Dirac increment: + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 + mean = 3.7037037037037035e-04 - + stddev = 1.9245008972987449e-02 + + stddev = 1.9245008972987445e-02 + - mu (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 + Adjoint test for block ID passed Covariance(SABER) diagnostics: - Variances at Dirac points: @@ -25,43 +27,8 @@ Covariance(SABER) * Increment: + max = 3.9999999999999996e+00 + mean = 1.4814814814814814e-03 + stddev = 7.6980035891949780e-02 + - mu (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 -Adjoint test for block ID passed -Covariance(SABER1_SABER) diagnostics: -- Variances at Dirac points: - + Value for variable unbalanced_pressure_levels_minus_one, subwindow 0, at (longitude, latitude, vertical index) point (0.00000, 0.00000, 1): 1.0000000000000000e+00 -- Covariances at diagnostic points: - + Value for variable unbalanced_pressure_levels_minus_one, subwindow 0, at (longitude, latitude, vertical index) point (0.00000, 0.00000, 1): 1.0000000000000000e+00 -Covariance(SABER1_SABER) * Increment: -- Valid time: 2010-01-01T12:00:00Z - Geometry: CS-LFR-15 [1350] - Fields: - - unbalanced_pressure_levels_minus_one (2 levels): - + min = 0.0000000000000000e+00 - + max = 1.0000000000000000e+00 - + mean = 3.7037037037037035e-04 - + stddev = 1.9245008972987449e-02 - - mu (2 levels): - + min = 0.0000000000000000e+00 - + max = 0.0000000000000000e+00 -Adjoint test for block ID passed -Covariance(SABER2_SABER) diagnostics: -- Variances at Dirac points: - + Value for variable unbalanced_pressure_levels_minus_one, subwindow 0, at (longitude, latitude, vertical index) point (0.00000, 0.00000, 1): 1.0000000000000000e+00 -- Covariances at diagnostic points: - + Value for variable unbalanced_pressure_levels_minus_one, subwindow 0, at (longitude, latitude, vertical index) point (0.00000, 0.00000, 1): 1.0000000000000000e+00 -Covariance(SABER2_SABER) * Increment: -- Valid time: 2010-01-01T12:00:00Z - Geometry: CS-LFR-15 [1350] - Fields: - - unbalanced_pressure_levels_minus_one (2 levels): - + min = 0.0000000000000000e+00 - + max = 1.0000000000000000e+00 - + mean = 3.7037037037037035e-04 - + stddev = 1.9245008972987449e-02 - - mu (2 levels): - + min = 0.0000000000000000e+00 - + max = 0.0000000000000000e+00 -Adjoint test for block ID passed + diff --git a/test/testref/dirac_parallel_hybrid_ratio_stddev.ref b/test/testref/dirac_parallel_hybrid_ratio_stddev.ref new file mode 100644 index 000000000..46f518612 --- /dev/null +++ b/test/testref/dirac_parallel_hybrid_ratio_stddev.ref @@ -0,0 +1 @@ +Not used ... same reference as dirac_parallel_hybrid_stddev diff --git a/test/testref/dirac_parallel_hybrid_stddev.ref b/test/testref/dirac_parallel_hybrid_stddev.ref index b80279ab5..d2c3b2be9 100644 --- a/test/testref/dirac_parallel_hybrid_stddev.ref +++ b/test/testref/dirac_parallel_hybrid_stddev.ref @@ -5,17 +5,19 @@ Input Dirac increment: - air_horizontal_streamfunction (2 levels): + min = 0.0000000000000000e+00 + max = 1.0000000000000000e+00 - + mean = 5.9523809523809529e-04 - + stddev = 2.4397501823713353e-02 + + mean = 6.5616797900262466e-04 + + stddev = 2.5615775978927884e-02 + - air_horizontal_velocity_potential (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 + Did not write file testdata/dirac_parallel_hybrid_stddev/fields_in_multiply_1.nc Fields: - air_horizontal_streamfunction: 4.0127503126905729e+01 - air_horizontal_velocity_potential: 4.1873820575192191e+01 + air_horizontal_streamfunction: 4.0127503126905715e+01 + air_horizontal_velocity_potential: 4.1873820575192198e+01 Adjoint test for block write fields passed -Norm of input parameter StdDev: 5.7581328949717772e+01 +Norm of input parameter StdDev: 5.4937700734311058e+01 Adjoint test for block StdDev passed Adjoint test for block ID passed Did not write file testdata/dirac_parallel_hybrid_stddev/fields_in_multiply_2.nc @@ -34,8 +36,10 @@ Covariance(SABER) * Increment: - air_horizontal_streamfunction (2 levels): + min = 0.0000000000000000e+00 + max = 1.2944134874642319e+00 - + mean = 7.7048421872870951e-04 - + stddev = 3.1580455421047732e-02 + + mean = 8.4935268206314429e-04 + + stddev = 3.3157405918986436e-02 + - air_horizontal_velocity_potential (2 levels): + min = 0.0000000000000000e+00 + max = 0.0000000000000000e+00 + From 76b8cb561f8002eeb80d58f0949bda947d8b760d Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Wed, 10 Dec 2025 22:28:51 +0100 Subject: [PATCH 139/199] Add right-inverse outer block for ensemble transform (#1155) * Add right-inverse outer block * Fix trace --------- Co-authored-by: Nate Crossette --- src/saber/blocks/SaberEnsembleBlockChain.h | 6 +-- src/saber/blocks/SaberOuterBlockBase.h | 5 +++ src/saber/blocks/SaberOuterBlockChain.h | 13 ++++++ src/saber/generic/ID.cc | 7 +++ src/saber/generic/ID.h | 1 + src/saber/generic/StdDev.cc | 50 +++++++++++----------- src/saber/generic/StdDev.h | 6 ++- 7 files changed, 59 insertions(+), 29 deletions(-) diff --git a/src/saber/blocks/SaberEnsembleBlockChain.h b/src/saber/blocks/SaberEnsembleBlockChain.h index 069fa2d96..c0332801e 100644 --- a/src/saber/blocks/SaberEnsembleBlockChain.h +++ b/src/saber/blocks/SaberEnsembleBlockChain.h @@ -225,12 +225,12 @@ SaberEnsembleBlockChain::SaberEnsembleBlockChain(const oops::Geometry & g currentOuterVars, fset4dXb, fset4dFg, ensemble_, covarConfUpdated, ensTransOuterBlocksParams); - // Left inverse of ensemble transform on ensemble members - oops::Log::info() << "Info : Left inverse of ensemble transform on ensemble members" + // Right inverse of ensemble transform on ensemble members + oops::Log::info() << "Info : Right inverse of ensemble transform on ensemble members" << std::endl; for (size_t itime = 0; itime < ensemble_.local_time_size(); ++itime) { for (size_t iens = 0; iens < ensemble_.local_ens_size(); ++iens) { - ensTransBlockChain->leftInverseMultiply(ensemble_(itime, iens)); + ensTransBlockChain->rightInverseMultiply(ensemble_(itime, iens)); } } diff --git a/src/saber/blocks/SaberOuterBlockBase.h b/src/saber/blocks/SaberOuterBlockBase.h index c7e38fe3f..6c627fcff 100644 --- a/src/saber/blocks/SaberOuterBlockBase.h +++ b/src/saber/blocks/SaberOuterBlockBase.h @@ -72,6 +72,11 @@ class SaberOuterBlockBase : public util::Printable, {throw eckit::NotImplemented("leftInverseMultiply not implemented yet for the block " + blockName_, Here());} + // Block right inverse multiplication + virtual void rightInverseMultiply(oops::FieldSet3D &) const + {throw eckit::NotImplemented("rightInverseMultiply not implemented yet for the block " + + blockName_, Here());} + // Setup / calibration methods // Read block data diff --git a/src/saber/blocks/SaberOuterBlockChain.h b/src/saber/blocks/SaberOuterBlockChain.h index ace947cc6..ed637a258 100644 --- a/src/saber/blocks/SaberOuterBlockChain.h +++ b/src/saber/blocks/SaberOuterBlockChain.h @@ -118,6 +118,19 @@ class SaberOuterBlockChain { } } + /// @brief Right inverse multiply (used in ensemble transform) by all outer blocks + /// except the ones that haven't implemented inverse yet. + void rightInverseMultiply(oops::FieldSet3D & fset) const { + for (auto it = outerBlocks_.begin(); it != outerBlocks_.end(); ++it) { + if (it->get()->skipInverse()) { + oops::Log::info() << "Warning: right inverse multiplication skipped for block " + << it->get()->blockName() << std::endl; + } else { + it->get()->rightInverseMultiply(fset); + } + } + } + private: /// @brief Initialize outer block, and return tuple of current outer variables, /// saber block parameters and active variables diff --git a/src/saber/generic/ID.cc b/src/saber/generic/ID.cc index bafb1eab6..da965e672 100644 --- a/src/saber/generic/ID.cc +++ b/src/saber/generic/ID.cc @@ -176,6 +176,13 @@ void IDOuter::leftInverseMultiply(oops::FieldSet3D & fset) const { // ----------------------------------------------------------------------------- +void IDOuter::rightInverseMultiply(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::rightInverseMultiply starting" << std::endl; + oops::Log::trace() << classname() << "::rightInverseMultiply done" << std::endl; +} + +// ----------------------------------------------------------------------------- + void IDOuter::print(std::ostream & os) const { os << classname(); } diff --git a/src/saber/generic/ID.h b/src/saber/generic/ID.h index 6bfbd9f1e..66279efe1 100644 --- a/src/saber/generic/ID.h +++ b/src/saber/generic/ID.h @@ -84,6 +84,7 @@ class IDOuter : public SaberOuterBlockBase { void multiply(oops::FieldSet3D &) const override; void multiplyAD(oops::FieldSet3D &) const override; void leftInverseMultiply(oops::FieldSet3D &) const override; + void rightInverseMultiply(oops::FieldSet3D &) const override; private: void print(std::ostream &) const override; diff --git a/src/saber/generic/StdDev.cc b/src/saber/generic/StdDev.cc index cf864e569..1dfd0dbe5 100644 --- a/src/saber/generic/StdDev.cc +++ b/src/saber/generic/StdDev.cc @@ -190,31 +190,6 @@ void StdDev::multiplyAD(oops::FieldSet3D & fset) const { // ----------------------------------------------------------------------------- -void StdDev::leftInverseMultiply(oops::FieldSet3D & fset) const { - oops::Log::trace() << classname() << "::leftInverseMultiply starting" << std::endl; - if (stdDevFset_) { - // Apply 3D standard-deviation - fset /= *stdDevFset_; - } else { - // Apply scaling - for (auto & field : fset) { - const std::string var = field.name(); - if (scaling_.find(var) != scaling_.end()) { - const double fact = 1.0 / scaling_.at(var); - auto view = atlas::array::make_view(field); - for (int jnode = 0; jnode < field.shape(0); ++jnode) { - for (int jlevel = 0; jlevel < field.shape(1); ++jlevel) { - view(jnode, jlevel) *= fact; - } - } - } - } - } - oops::Log::trace() << classname() << "::leftInverseMultiply done" << std::endl; -} - -// ----------------------------------------------------------------------------- - std::vector> StdDev::getReadConfs() const { oops::Log::trace() << classname() << "::getReadConfs starting" << std::endl; @@ -489,5 +464,30 @@ void StdDev::print(std::ostream & os) const { // ----------------------------------------------------------------------------- +void StdDev::inverseMultiply(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::inverseMultiply starting" << std::endl; + if (stdDevFset_) { + // Apply 3D standard-deviation + fset /= *stdDevFset_; + } else { + // Apply scaling + for (auto & field : fset) { + const std::string var = field.name(); + if (scaling_.find(var) != scaling_.end()) { + const double fact = 1.0 / scaling_.at(var); + auto view = atlas::array::make_view(field); + for (int jnode = 0; jnode < field.shape(0); ++jnode) { + for (int jlevel = 0; jlevel < field.shape(1); ++jlevel) { + view(jnode, jlevel) *= fact; + } + } + } + } + } + oops::Log::trace() << classname() << "::inverseMultiply done" << std::endl; +} + +// ----------------------------------------------------------------------------- + } // namespace generic } // namespace saber diff --git a/src/saber/generic/StdDev.h b/src/saber/generic/StdDev.h index 6f97c126a..b003c226f 100644 --- a/src/saber/generic/StdDev.h +++ b/src/saber/generic/StdDev.h @@ -98,7 +98,10 @@ class StdDev : public SaberOuterBlockBase { void multiply(oops::FieldSet3D &) const override; void multiplyAD(oops::FieldSet3D &) const override; - void leftInverseMultiply(oops::FieldSet3D &) const override; + void leftInverseMultiply(oops::FieldSet3D & fset) const override + {inverseMultiply(fset);} + void rightInverseMultiply(oops::FieldSet3D & fset) const override + {inverseMultiply(fset);} std::vector> getReadConfs() const override; void setReadFields(const std::vector &) override; @@ -118,6 +121,7 @@ class StdDev : public SaberOuterBlockBase { private: void print(std::ostream &) const override; + void inverseMultiply(oops::FieldSet3D &) const; const oops::GeometryData & innerGeometryData_; oops::Variables innerVars_; Parameters_ params_; From 44784d297326fe6f766a4a28e1e525e35166732c Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Fri, 12 Dec 2025 21:21:52 +0100 Subject: [PATCH 140/199] NICAS filter (#1141) * WIP, parallel not working * Filtering fixed, stddev tests still failing * Remove smoother keys, add read/write for filter mode * Reintroduce filter-specific parameters * Remove debug print * Trigger tests * Fix yaml * Add purely horizontal NICAS filtering test * Filter parallelization fix * Normalization fix * Fix lev2d * Trigger tests * Remove extra line * Trigger tests * Trigger tests * Fix variance filtering * Use two variables instead of one for bump_stddev tests * Thresholding to avoid negative variances --------- Co-authored-by: Nate Crossette --- src/saber/bump/BUMP.cc | 12 + src/saber/bump/BUMP.h | 1 + src/saber/bump/BUMPParameters.h | 14 +- src/saber/bump/NICAS.cc | 8 + src/saber/bump/NICAS.h | 1 + src/saber/bump/subr_list.fypp | 12 +- src/saber/bump/type_bump.fypp | 42 ++ src/saber/bump/type_bump.h | 1 + src/saber/bump/type_bump_interface.F90 | 28 + src/saber/bump/type_bump_parameters.cc | 14 +- src/saber/bump/type_bump_parameters.h | 28 +- src/saber/bump/type_geom.fypp | 2 +- src/saber/bump/type_nam.fypp | 31 +- src/saber/bump/type_nicas.fypp | 46 +- src/saber/bump/type_nicas_blk.fypp | 235 +++----- src/saber/bump/type_nicas_cmp.fypp | 546 +++++++++--------- src/saber/bump/type_var.fypp | 339 +++++++---- test/testdeps/process_perts_bump_nicas_1.txt | 1 + test/testdeps/process_perts_bump_nicas_2.txt | 2 + test/testdeps/process_perts_bump_nicas_3.txt | 1 + ...ror_covariance_training_bump_stddev_1.yaml | 6 + ...ror_covariance_training_bump_stddev_2.yaml | 9 +- ...ror_covariance_training_bump_stddev_4.yaml | 3 + ...ror_covariance_training_bump_stddev_5.yaml | 5 + .../testinput/process_perts_bump_nicas_1.yaml | 61 ++ .../testinput/process_perts_bump_nicas_2.yaml | 49 ++ .../testinput/process_perts_bump_nicas_3.yaml | 58 ++ test/testlist/saber_test_tier1-bump.txt | 3 + ...rror_covariance_training_bump_stddev_1.ref | 34 +- ...rror_covariance_training_bump_stddev_2.ref | 10 +- ...rror_covariance_training_bump_stddev_4.ref | 2 +- ...rror_covariance_training_bump_stddev_5.ref | 14 +- test/testref/process_perts_bump_nicas_1.ref | 49 ++ test/testref/process_perts_bump_nicas_2.ref | 29 + test/testref/process_perts_bump_nicas_3.ref | 40 ++ 35 files changed, 1134 insertions(+), 602 deletions(-) create mode 100644 test/testdeps/process_perts_bump_nicas_1.txt create mode 100644 test/testdeps/process_perts_bump_nicas_2.txt create mode 100644 test/testdeps/process_perts_bump_nicas_3.txt create mode 100644 test/testinput/process_perts_bump_nicas_1.yaml create mode 100644 test/testinput/process_perts_bump_nicas_2.yaml create mode 100644 test/testinput/process_perts_bump_nicas_3.yaml create mode 100644 test/testref/process_perts_bump_nicas_1.ref create mode 100644 test/testref/process_perts_bump_nicas_2.ref create mode 100644 test/testref/process_perts_bump_nicas_3.ref diff --git a/src/saber/bump/BUMP.cc b/src/saber/bump/BUMP.cc index 92efc40eb..abb767831 100644 --- a/src/saber/bump/BUMP.cc +++ b/src/saber/bump/BUMP.cc @@ -693,6 +693,18 @@ void BUMP::multiplyNicas(oops::FieldSet3D & fset) const { // ----------------------------------------------------------------------------- +void BUMP::filterNicas(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::filterNicas starting" << std::endl; + + for (size_t jgrid = 0; jgrid < keyBUMP_.size(); ++jgrid) { + bump_apply_nicas_filter_f90(keyBUMP_[jgrid], fset.get()); + } + + oops::Log::trace() << classname() << "::filterNicas done" << std::endl; +} + +// ----------------------------------------------------------------------------- + void BUMP::multiplyPsiChiToUV(oops::FieldSet3D & fset) const { oops::Log::trace() << classname() << "::multiplyPsiChiToUV starting" << std::endl; diff --git a/src/saber/bump/BUMP.h b/src/saber/bump/BUMP.h index 4c5e13ff1..ac2bd91c7 100644 --- a/src/saber/bump/BUMP.h +++ b/src/saber/bump/BUMP.h @@ -79,6 +79,7 @@ class BUMP { void inverseMultiplyStdDev(oops::FieldSet3D &) const; void randomizeNicas(oops::FieldSet3D &) const; void multiplyNicas(oops::FieldSet3D &) const; + void filterNicas(oops::FieldSet3D &) const; void multiplyPsiChiToUV(oops::FieldSet3D &) const; void multiplyPsiChiToUVAd(oops::FieldSet3D &) const; size_t getCvSize() const; diff --git a/src/saber/bump/BUMPParameters.h b/src/saber/bump/BUMPParameters.h index 3abf74140..69fcbedf8 100644 --- a/src/saber/bump/BUMPParameters.h +++ b/src/saber/bump/BUMPParameters.h @@ -542,12 +542,6 @@ class VarianceSection : public oops::Parameters { // Variance initial filtering support radius [in meters] oops::Parameter> var_rhflt{"initial length-scale", {}, this}; - // Resolution for the NICAS smoother - oops::Parameter smoother_resol = param(def.smoother_resol, this); - // Maximum size of the Sc1 subset for the NICAS smoother - oops::Parameter smoother_nc1max = param(def.smoother_nc1max, this); - // Minimum effective resolution for the NICAS smoother - oops::Parameter smoother_resol_eff_min = param(def.smoother_resol_eff_min, this); }; // ----------------------------------------------------------------------------- @@ -606,6 +600,14 @@ class NICASSection : public oops::Parameters { oops::Parameter nc1max = param(def.nc1max, this); // Minimum effective resolution oops::Parameter resol_eff_min = param(def.resol_eff_min, this); + // Filter mode + oops::Parameter filter_mode = param(def.filter_mode, this); + // Resolution for the NICAS filter + oops::Parameter filter_resol = param(def.filter_resol, this); + // Maximum size of the Sc1 subset for the NICAS filter + oops::Parameter filter_nc1max = param(def.filter_nc1max, this); + // Minimum effective resolution for the NICAS filter + oops::Parameter filter_resol_eff_min = param(def.filter_resol_eff_min, this); // NICAS draw type ('random' or 'octahedral') oops::Parameter nicas_draw_type = param(def.nicas_draw_type, this); // Force specific support radii diff --git a/src/saber/bump/NICAS.cc b/src/saber/bump/NICAS.cc index b0de5f658..53dea24df 100644 --- a/src/saber/bump/NICAS.cc +++ b/src/saber/bump/NICAS.cc @@ -71,6 +71,14 @@ void NICAS::multiply(oops::FieldSet3D & fset) const { // ----------------------------------------------------------------------------- +void NICAS::filter(oops::FieldSet3D & fset) const { + oops::Log::trace() << classname() << "::filter starting" << std::endl; + bump_->filterNicas(fset); + oops::Log::trace() << classname() << "::filter done" << std::endl; +} + +// ----------------------------------------------------------------------------- + std::vector> NICAS::getReadConfs() const { oops::Log::trace() << classname() << "::getReadConfs starting" << std::endl; std::vector inputModelFilesConf diff --git a/src/saber/bump/NICAS.h b/src/saber/bump/NICAS.h index 42cdaf27a..5de54a203 100644 --- a/src/saber/bump/NICAS.h +++ b/src/saber/bump/NICAS.h @@ -57,6 +57,7 @@ class NICAS : public SaberCentralBlockBase { void randomize(oops::FieldSet3D &) const override; void multiply(oops::FieldSet3D &) const override; + void filter(oops::FieldSet3D &) const override; std::vector> getReadConfs() const override; void setReadFields(const std::vector &) override; diff --git a/src/saber/bump/subr_list.fypp b/src/saber/bump/subr_list.fypp index e404708e0..4fc50b016 100644 --- a/src/saber/bump/subr_list.fypp +++ b/src/saber/bump/subr_list.fypp @@ -152,6 +152,7 @@ #:set subr_list = subr_list + ["bump_apply_stddev_inv"] #:set subr_list = subr_list + ["bump_apply_nicas"] #:set subr_list = subr_list + ["bump_apply_nicas_deprecated_atlas"] +#:set subr_list = subr_list + ["bump_apply_nicas_filter"] #:set subr_list = subr_list + ["bump_get_cv_size"] #:set subr_list = subr_list + ["bump_apply_nicas_sqrt"] #:set subr_list = subr_list + ["bump_apply_nicas_sqrt_deprecated_atlas"] @@ -278,9 +279,6 @@ #:set subr_list = subr_list + ["geom_fieldset_to_c0"] #:set subr_list = subr_list + ["geom_c0_to_fieldset"] #:set subr_list = subr_list + ["geom_rand_point"] -#:set subr_list = subr_list + ["geom_compute_smoother"] -#:set subr_list = subr_list + ["geom_apply_smoother"] -#:set subr_list = subr_list + ["geom_apply_smoother_ad"] #:set subr_list = subr_list + ["geom_initialize_sampling"] #:set subr_list = subr_list + ["geom_define_test_vectors"] #:set subr_list = subr_list + ["geom_mg_to_mga"] @@ -430,8 +428,9 @@ #:set subr_list = subr_list + ["nicas_blk_write_steps_def"] #:set subr_list = subr_list + ["nicas_blk_write_steps_data"] #:set subr_list = subr_list + ["nicas_blk_compute_parameters"] -#:set subr_list = subr_list + ["nicas_blk_compute_parameters_horizontal_smoother"] +#:set subr_list = subr_list + ["nicas_blk_compute_parameters_filter"] #:set subr_list = subr_list + ["nicas_blk_copy_cmat"] +#:set subr_list = subr_list + ["nicas_blk_apply_filter"] #:set subr_list = subr_list + ["nicas_blk_apply_sqrt"] #:set subr_list = subr_list + ["nicas_blk_apply_sqrt_ad"] #:set subr_list = subr_list + ["nicas_blk_test_adjoint"] @@ -453,7 +452,6 @@ #:set subr_list = subr_list + ["nicas_cmp_write_steps_def"] #:set subr_list = subr_list + ["nicas_cmp_write_steps_data"] #:set subr_list = subr_list + ["nicas_cmp_compute_parameters"] -#:set subr_list = subr_list + ["nicas_cmp_compute_parameters_horizontal_smoother"] #:set subr_list = subr_list + ["nicas_cmp_compute_horizontal"] #:set subr_list = subr_list + ["nicas_cmp_compute_vertical"] #:set subr_list = subr_list + ["nicas_cmp_compute_convol"] @@ -464,7 +462,7 @@ #:set subr_list = subr_list + ["nicas_cmp_compute_normalization"] #:set subr_list = subr_list + ["nicas_cmp_randomize_normalization"] #:set subr_list = subr_list + ["nicas_cmp_random_cv"] -#:set subr_list = subr_list + ["nicas_cmp_apply_horizontal_smoother"] +#:set subr_list = subr_list + ["nicas_cmp_apply_filter"] #:set subr_list = subr_list + ["nicas_cmp_apply_sqrt"] #:set subr_list = subr_list + ["nicas_cmp_apply_sqrt_ad"] #:set subr_list = subr_list + ["nicas_cmp_apply_convol_sqrt"] @@ -477,7 +475,6 @@ #:set subr_list = subr_list + ["nicas_cmp_apply_interp_vertical_ad"] #:set subr_list = subr_list + ["nicas_cmp_test_adjoint"] #:set subr_list = subr_list + ["nicas_cmp_test_normalization"] -#:set subr_list = subr_list + ["nicas_cmp_test_normalization_horizontal_smoother"] #:set subr_list = subr_list + ["nicas_cmp_c1_to_c1a"] #:set subr_list = subr_list + ["nicas_cmp_c1_to_proc"] #:set subr_list = subr_list + ["nicas_cmp_c1_to_c1u"] @@ -500,6 +497,7 @@ #:set subr_list = subr_list + ["nicas_alloc_cv"] #:set subr_list = subr_list + ["nicas_random_cv"] #:set subr_list = subr_list + ["nicas_apply"] +#:set subr_list = subr_list + ["nicas_apply_filter"] #:set subr_list = subr_list + ["nicas_apply_sqrt"] #:set subr_list = subr_list + ["nicas_apply_sqrt_ad"] #:set subr_list = subr_list + ["nicas_gen_ens_pert"] diff --git a/src/saber/bump/type_bump.fypp b/src/saber/bump/type_bump.fypp index da244d973..cebb563e2 100644 --- a/src/saber/bump/type_bump.fypp +++ b/src/saber/bump/type_bump.fypp @@ -73,6 +73,7 @@ contains procedure :: apply_stddev => bump_apply_stddev procedure :: apply_stddev_inv => bump_apply_stddev_inv procedure :: apply_nicas => bump_apply_nicas + procedure :: apply_nicas_filter => bump_apply_nicas_filter procedure :: get_cv_size => bump_get_cv_size procedure :: apply_nicas_sqrt => bump_apply_nicas_sqrt procedure :: apply_nicas_sqrt_ad => bump_apply_nicas_sqrt_ad @@ -1336,6 +1337,47 @@ call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) end subroutine bump_apply_nicas +!---------------------------------------------------------------------- +! Subroutine: bump_apply_nicas_filter +!> NICAS application +!---------------------------------------------------------------------- +subroutine bump_apply_nicas_filter(bump,fieldset) + +implicit none + +! Passed variables +class(bump_type),intent(inout) :: bump !< BUMP +type(fieldset_type),intent(inout) :: fieldset !< Fieldset + +! Local variable +real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) + +! Set name +@:set_name(bump_apply_nicas_filter) + +! Get instance +@:get_instance(bump) + +! Probe in +@:probe_in() + +! Set fieldset metadata +call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) + +! Fieldset to Fortran on subset Sc0 +call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) + +! Apply NICAS +call bump%nicas(1)%apply_filter(bump%mpl,bump%nam,bump%geom(1),fld_c0a) + +! Fortran array on subset Sc0 to fieldset +call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) + +! Probe out +@:probe_out() + +end subroutine bump_apply_nicas_filter + !---------------------------------------------------------------------- ! Subroutine: bump_get_cv_size !> Get control variable size diff --git a/src/saber/bump/type_bump.h b/src/saber/bump/type_bump.h index ba9de98c0..f9fc2ef84 100644 --- a/src/saber/bump/type_bump.h +++ b/src/saber/bump/type_bump.h @@ -43,6 +43,7 @@ extern "C" { void bump_apply_stddev_f90(const int &, const atlas::field::FieldSetImpl *); void bump_apply_stddev_inv_f90(const int &, const atlas::field::FieldSetImpl *); void bump_apply_nicas_f90(const int &, const atlas::field::FieldSetImpl *); + void bump_apply_nicas_filter_f90(const int &, const atlas::field::FieldSetImpl *); void bump_get_cv_size_f90(const int &, int &); void bump_apply_nicas_sqrt_f90(const int &, const atlas::field::FieldImpl *, const atlas::field::FieldSetImpl *, const int &); diff --git a/src/saber/bump/type_bump_interface.F90 b/src/saber/bump/type_bump_interface.F90 index 1c1d62579..e71827c29 100644 --- a/src/saber/bump/type_bump_interface.F90 +++ b/src/saber/bump/type_bump_interface.F90 @@ -422,6 +422,34 @@ subroutine bump_apply_nicas_c(key_bump,c_afieldset) bind(c,name='bump_apply_nica end subroutine bump_apply_nicas_c +!---------------------------------------------------------------------- +! Subroutine: bump_apply_nicas_filter_c +!> NICAS application +!---------------------------------------------------------------------- +subroutine bump_apply_nicas_filter_c(key_bump,c_afieldset) bind(c,name='bump_apply_nicas_filter_f90') + +implicit none + +! Passed variables +integer(c_int),intent(in) :: key_bump !< BUMP +type(c_ptr),intent(in),value :: c_afieldset !< ATLAS fieldset pointer + +! Local variables +type(bump_type),pointer :: bump +type(fieldset_type) :: f_fieldset + +! Interface +call bump_registry%get(key_bump,bump) +f_fieldset = atlas_fieldset(c_afieldset) + +! Call Fortran +call bump%apply_nicas_filter(f_fieldset) + +! Release memory +call f_fieldset%final() + +end subroutine bump_apply_nicas_filter_c + !---------------------------------------------------------------------- ! Subroutine: bump_get_cv_size_c !> Get control variable size diff --git a/src/saber/bump/type_bump_parameters.cc b/src/saber/bump/type_bump_parameters.cc index 58ab605e2..1166b7c0f 100644 --- a/src/saber/bump/type_bump_parameters.cc +++ b/src/saber/bump/type_bump_parameters.cc @@ -268,12 +268,6 @@ void bump_config_init_f90(eckit::LocalConfiguration * config) { param(varianceDef.var_niter, varianceConf); // Number of passes for the variance filtering (0 for uniform variance) param(varianceDef.var_npass, varianceConf); - // Resolution for the NICAS smoother - param(varianceDef.smoother_resol, varianceConf); - // Maximum size of the Sc1 subset for the NICAS smoother - param(varianceDef.smoother_nc1max, varianceConf); - // Minimum effective resolution for the NICAS smoother - param(varianceDef.smoother_resol_eff_min, varianceConf); // Optimality test section OptimalityTestDef optimalityTestDef; @@ -308,6 +302,14 @@ void bump_config_init_f90(eckit::LocalConfiguration * config) { param(nicasDef.nc1max, nicasConf); // Minimum effective resolution param(nicasDef.resol_eff_min, nicasConf); + // Filter mode + param(nicasDef.filter_mode, nicasConf); + // Resolution for the NICAS filter + param(nicasDef.filter_resol, nicasConf); + // Maximum size of the Sc1 subset for the NICAS filter + param(nicasDef.filter_nc1max, nicasConf); + // Minimum effective resolution for the NICAS filter + param(nicasDef.filter_resol_eff_min, nicasConf); // NICAS draw type ('random' or 'octahedral') param(nicasDef.nicas_draw_type, nicasConf); // Force specific support radii diff --git a/src/saber/bump/type_bump_parameters.h b/src/saber/bump/type_bump_parameters.h index a821b59c9..3ddf17224 100644 --- a/src/saber/bump/type_bump_parameters.h +++ b/src/saber/bump/type_bump_parameters.h @@ -481,18 +481,6 @@ struct VarianceDef { // Number of passes for the variance filtering (0 for uniform variance) std::pair var_npass = std::make_pair("filtering passes", -1); - - // Resolution for the NICAS smoother - std::pair smoother_resol = - std::make_pair("smoother resolution", 5.0); - - // Maximum size of the Sc1 subset for the NICAS smoother - std::pair smoother_nc1max = - std::make_pair("smoother max horizontal grid size", 50000); - - // Minimum effective resolution for the NICAS smoother - std::pair smoother_resol_eff_min = - std::make_pair("smoother min effective resolution", 2.0); }; // Optimality test section @@ -547,6 +535,22 @@ struct NICASDef { std::pair resol_eff_min = std::make_pair("min effective resolution", 3.0); + // Filter mode + std::pair filter_mode = + std::make_pair("filter mode", false); + + // Resolution for the NICAS filter + std::pair filter_resol = + std::make_pair("filter resolution", 5.0); + + // Maximum size of the Sc1 subset for the NICAS filter + std::pair filter_nc1max = + std::make_pair("filter max horizontal grid size", 50000); + + // Minimum effective resolution for the NICAS filter + std::pair filter_resol_eff_min = + std::make_pair("filter min effective resolution", 2.0); + // NICAS draw type ('random' or 'octahedral') std::pair nicas_draw_type = std::make_pair("grid type", "random"); diff --git a/src/saber/bump/type_geom.fypp b/src/saber/bump/type_geom.fypp index 7543a78f4..a341c84e4 100644 --- a/src/saber/bump/type_geom.fypp +++ b/src/saber/bump/type_geom.fypp @@ -249,7 +249,6 @@ if (allocated(geom%c0u_to_c0a)) deallocate(geom%c0u_to_c0a) call geom%com_AU%dealloc if (allocated(geom%c0a_to_c0)) deallocate(geom%c0a_to_c0) if (allocated(geom%c0u_to_c0)) deallocate(geom%c0u_to_c0) -if (allocated(geom%nc0_gmask)) deallocate(geom%nc0_gmask) if (allocated(geom%l0i_to_l0)) deallocate(geom%l0i_to_l0) if (allocated(geom%area_ver_c0)) deallocate(geom%area_ver_c0) if (allocated(geom%vert_coordavg)) deallocate(geom%vert_coordavg) @@ -296,6 +295,7 @@ if (allocated(geom%lon_c0a)) deallocate(geom%lon_c0a) if (allocated(geom%lat_c0a)) deallocate(geom%lat_c0a) if (allocated(geom%vert_coord_c0a)) deallocate(geom%vert_coord_c0a) if (allocated(geom%gmask_c0a)) deallocate(geom%gmask_c0a) +if (allocated(geom%nc0_gmask)) deallocate(geom%nc0_gmask) if (allocated(geom%l0_to_l0i)) deallocate(geom%l0_to_l0i) if (allocated(geom%grp2d)) deallocate(geom%grp2d) call geom%io%dealloc diff --git a/src/saber/bump/type_nam.fypp b/src/saber/bump/type_nam.fypp index abb9b67f1..8904abaa3 100644 --- a/src/saber/bump/type_nam.fypp +++ b/src/saber/bump/type_nam.fypp @@ -162,9 +162,6 @@ type nam_type integer :: var_niter !< Number of iterations for the variance filtering (0 for uniform variance) integer :: var_npass !< Number of passes for the variance filtering (0 for uniform variance) real(kind_real),allocatable :: var_rhflt(:,:) !< Variance initial filtering support radius [in meters] - real(kind_real) :: smoother_resol !< Resolution for the NICAS smoother - integer :: smoother_nc1max !< Maximum size of the Sc1 subset for the NICAS smoother - real(kind_real) :: smoother_resol_eff_min !< Minimum effective resolution for the NICAS smoother ! Optimality test section integer :: optimality_nfac !< Number of length-scale factors for optimization @@ -173,7 +170,7 @@ type nam_type ! Fit section real(kind_real) :: diag_raw_th !< Threshold to filter out lower raw values - real(kind_real) :: diag_rhflt !< Horizontal filtering suport radius [in meters] + real(kind_real) :: diag_rhflt !< Horizontal filtering support radius [in meters] real(kind_real) :: diag_rvflt !< Vertical filtering support radius integer :: fit_dl0 !< Number of levels between interpolation levels integer :: fit_ncmp !< Number of components in the fit function @@ -188,6 +185,10 @@ type nam_type real(kind_real) :: resol !< Resolution integer :: nc1max !< Maximum size of the Sc1 subset real(kind_real) :: resol_eff_min !< Minimum effective resolution + logical :: filter_mode !< Filter mode + real(kind_real) :: filter_resol !< Resolution for the NICAS filter + integer :: filter_nc1max !< Maximum size of the Sc1 subset for the NICAS filter + real(kind_real) :: filter_resol_eff_min !< Minimum effective resolution for the NICAS filter character(len=1024) :: nicas_draw_type !< NICAS draw type ('random' or 'octahedral') logical :: forced_radii !< Force specific support radii real(kind_real),allocatable :: rh(:,:) !< Forced horizontal support radius [in meters] @@ -796,9 +797,6 @@ if (conf%get('variance',section)) then call nam%get(section,'filtering iterations',nam%var_niter) call nam%get(section,'filtering passes',nam%var_npass) call nam%get(mpl,section,'initial length-scale',nam%var_rhflt,one/req) - call nam%get(section,'smoother resolution',nam%smoother_resol) - call nam%get(section,'smoother min effective resolution',nam%smoother_resol_eff_min) - call nam%get(section,'smoother max horizontal grid size',nam%smoother_nc1max) end if ! Optimality test section @@ -853,6 +851,10 @@ if (conf%get('nicas',section)) then call nam%get(section,'resolution',nam%resol) call nam%get(section,'max horizontal grid size',nam%nc1max) call nam%get(section,'min effective resolution',nam%resol_eff_min) + call nam%get(section,'filter mode',nam%filter_mode) + call nam%get(section,'filter resolution',nam%filter_resol) + call nam%get(section,'filter max horizontal grid size',nam%filter_nc1max) + call nam%get(section,'filter min effective resolution',nam%filter_resol_eff_min) call nam%get(section,'grid type',nam%nicas_draw_type) call nam%get(section,'explicit length-scales',nam%forced_radii) call nam%get(mpl,section,'horizontal length-scale',nam%rh,one/req) @@ -1321,9 +1323,6 @@ if (nam%new_var) then end do end do end if - if (.not.(nam%smoother_resol>zero)) call mpl%abort('${subr}$','smoother_resol should be positive') - if (nam%smoother_nc1max<=0) call mpl%abort('${subr}$','smoother_nc1max should be positive') - if (.not.(nam%smoother_resol_eff_min>zero)) call mpl%abort('${subr}$','smoother_resol_eff_min should be positive') end if end if @@ -1371,9 +1370,15 @@ if (nam%new_nicas.or.nam%load_nicas_local.or.nam%load_nicas_global) then if (.not.nam%forced_radii) call mpl%abort('${subr}$','forced_radii required for check_optimality') end if if (nam%new_nicas) then - if (.not.(nam%resol>zero)) call mpl%abort('${subr}$','resol should be positive') - if (nam%nc1max<=0) call mpl%abort('${subr}$','nc1max should be positive') - if (.not.(nam%resol_eff_min>zero)) call mpl%abort('${subr}$','resol_eff_min should be positive') + if (nam%filter_mode) then + if (.not.(nam%filter_resol>zero)) call mpl%abort('${subr}$','filter_resol should be positive') + if (nam%filter_nc1max<=0) call mpl%abort('${subr}$','filter_nc1max should be positive') + if (.not.(nam%filter_resol_eff_min>zero)) call mpl%abort('${subr}$','filter_resol_eff_min should be positive') + else + if (.not.(nam%resol>zero)) call mpl%abort('${subr}$','resol should be positive') + if (nam%nc1max<=0) call mpl%abort('${subr}$','nc1max should be positive') + if (.not.(nam%resol_eff_min>zero)) call mpl%abort('${subr}$','resol_eff_min should be positive') + end if end if if (nam%forced_radii) then if (.not.allocated(nam%rh)) call mpl%abort('${subr}$','rh is missing') diff --git a/src/saber/bump/type_nicas.fypp b/src/saber/bump/type_nicas.fypp index a564429e3..fcff65abb 100644 --- a/src/saber/bump/type_nicas.fypp +++ b/src/saber/bump/type_nicas.fypp @@ -57,6 +57,7 @@ contains procedure :: alloc_cv => nicas_alloc_cv procedure :: random_cv => nicas_random_cv procedure :: apply => nicas_apply + procedure :: apply_filter => nicas_apply_filter procedure :: apply_sqrt => nicas_apply_sqrt procedure :: apply_sqrt_ad => nicas_apply_sqrt_ad procedure :: gen_ens_pert => nicas_gen_ens_pert @@ -1045,11 +1046,7 @@ if (nam%check_normalization>0) then do icmp=1,nicas%blk(ig)%ncmp write(mpl%info,'(a7,a,i1)') '','Component: ',icmp call mpl%flush - if (nicas%blk(ig)%cmp(icmp)%smoother) then - call nicas%blk(ig)%cmp(icmp)%test_normalization(mpl,rng,nam,geom,icmp) - else - call nicas%blk(ig)%cmp(icmp)%test_normalization(mpl,rng,nam,geom) - end if + call nicas%blk(ig)%cmp(icmp)%test_normalization(mpl,rng,nam,geom) end do write(mpl%info,'(a7,a)') '','All components:' call mpl%flush @@ -1240,7 +1237,7 @@ end subroutine nicas_random_cv !---------------------------------------------------------------------- ! Subroutine: nicas_apply -!> Apply NICAS (non smoother case) +!> Apply NICAS (correlation mode) !---------------------------------------------------------------------- subroutine nicas_apply(nicas,mpl,nam,geom,fld) @@ -1291,6 +1288,43 @@ end if end subroutine nicas_apply +!---------------------------------------------------------------------- +! Subroutine: nicas_apply_filter +!> Apply NICAS filter (filter mode) +!---------------------------------------------------------------------- +subroutine nicas_apply_filter(nicas,mpl,nam,geom,fld) + +implicit none + +! Passed variables +class(nicas_type),intent(inout) :: nicas !< NICAS data +type(mpl_type),intent(inout) :: mpl !< MPI data +type(nam_type),intent(in) :: nam !< Namelist +type(geom_type),intent(in) :: geom !< Geometry +real(kind_real),intent(inout) :: fld(geom%nc0a,geom%nl0,nam%nv) !< Field + +! Local variable +integer :: ig,iv + +! Set name +@:set_name(nicas_apply_filter) + +! Probe in +@:probe_in() + +do iv=1,nam%nv + ! Group index + ig = nam%group_index(iv) + + ! Apply NICAS + call nicas%blk(ig)%apply_filter(mpl,geom,fld(:,:,iv)) +end do + +! Probe out +@:probe_out() + +end subroutine nicas_apply_filter + !---------------------------------------------------------------------- ! Subroutine: nicas_apply_sqrt !> Apply NICAS square-root diff --git a/src/saber/bump/type_nicas_blk.fypp b/src/saber/bump/type_nicas_blk.fypp index b5adfdc98..d80fb8e1f 100644 --- a/src/saber/bump/type_nicas_blk.fypp +++ b/src/saber/bump/type_nicas_blk.fypp @@ -41,9 +41,6 @@ type nicas_blk_type ! NICAS components integer :: ncmp !< Number of components type(nicas_cmp_type),allocatable :: cmp(:) !< Components - - ! Horizontal smoother - integer,allocatable :: l0_to_l0i(:) !< Base level to independent level contains procedure :: partial_dealloc => nicas_blk_partial_dealloc procedure :: dealloc => nicas_blk_dealloc @@ -61,9 +58,10 @@ contains procedure :: write_steps_def => nicas_blk_write_steps_def procedure :: write_steps_data => nicas_blk_write_steps_data procedure :: nicas_blk_compute_parameters - procedure :: nicas_blk_compute_parameters_horizontal_smoother - generic :: compute_parameters => nicas_blk_compute_parameters,nicas_blk_compute_parameters_horizontal_smoother + procedure :: nicas_blk_compute_parameters_filter + generic :: compute_parameters => nicas_blk_compute_parameters,nicas_blk_compute_parameters_filter procedure :: copy_cmat => nicas_blk_copy_cmat + procedure :: apply_filter => nicas_blk_apply_filter procedure :: apply_sqrt => nicas_blk_apply_sqrt procedure :: apply_sqrt_ad => nicas_blk_apply_sqrt_ad procedure :: test_adjoint => nicas_blk_test_adjoint @@ -136,7 +134,6 @@ if (allocated(nicas_blk%cmp)) then end do deallocate(nicas_blk%cmp) end if -if (allocated(nicas_blk%l0_to_l0i)) deallocate(nicas_blk%l0_to_l0i) ! Probe out @:probe_out() @@ -197,7 +194,6 @@ do icmp=1,nicas_blk%ncmp nicas_blk%cmp(icmp)%ig = ig nicas_blk%cmp(icmp)%ncmp = nicas_blk%ncmp nicas_blk%cmp(icmp)%verbosity = nicas_blk%verbosity - nicas_blk%cmp(icmp)%smoother = .false. nicas_blk%cmp(icmp)%compute_norm = (.not.allocated(nicas_blk%cmp(icmp)%norm)) ! Copy file ID @@ -502,7 +498,6 @@ do icmp=1,nicas_blk%ncmp nicas_blk%cmp(icmp)%ig = ig nicas_blk%cmp(icmp)%ncmp = nicas_blk%ncmp nicas_blk%cmp(icmp)%verbosity = nicas_blk%verbosity - nicas_blk%cmp(icmp)%smoother = .false. nicas_blk%cmp(icmp)%compute_norm = (.not.allocated(nicas_blk%cmp(icmp)%norm)) ! Component work @@ -571,12 +566,17 @@ do icmp=1,nicas_blk%ncmp nicas_blk%cmp(icmp)%ig = ig nicas_blk%cmp(icmp)%ncmp = nicas_blk%ncmp nicas_blk%cmp(icmp)%verbosity = nicas_blk%verbosity - nicas_blk%cmp(icmp)%resol = nam%resol - nicas_blk%cmp(icmp)%nc1max = nam%nc1max - nicas_blk%cmp(icmp)%resol_eff_min = nam%resol_eff_min + if (nicas_blk%cmp(icmp)%filter_mode) then + nicas_blk%cmp(icmp)%resol = nam%filter_resol + nicas_blk%cmp(icmp)%nc1max = nam%filter_nc1max + nicas_blk%cmp(icmp)%resol_eff_min = nam%filter_resol_eff_min + else + nicas_blk%cmp(icmp)%resol = nam%resol + nicas_blk%cmp(icmp)%nc1max = nam%nc1max + nicas_blk%cmp(icmp)%resol_eff_min = nam%resol_eff_min + end if nicas_blk%cmp(icmp)%draw_type = nam%nicas_draw_type nicas_blk%cmp(icmp)%interp_type = nam%nicas_interp_type(ig) - nicas_blk%cmp(icmp)%smoother = .false. nicas_blk%cmp(icmp)%compute_norm = (.not.allocated(nicas_blk%cmp(icmp)%norm)) nicas_blk%cmp(icmp)%interp_in_global_file = nam%interp_in_global_file @@ -936,18 +936,24 @@ end if do icmp=1,nicas_blk%ncmp write(mpl%info,'(a7,a,i1)') '','Component: ',icmp - call mpl%flush + call mpl%flush(flush=nicas_blk%verbosity) ! Set attributes nicas_blk%cmp(icmp)%ig = ig nicas_blk%cmp(icmp)%ncmp = nicas_blk%ncmp nicas_blk%cmp(icmp)%verbosity = nicas_blk%verbosity - nicas_blk%cmp(icmp)%resol = nam%resol - nicas_blk%cmp(icmp)%nc1max = nam%nc1max - nicas_blk%cmp(icmp)%resol_eff_min = nam%resol_eff_min + nicas_blk%cmp(icmp)%filter_mode = nam%filter_mode + if (nicas_blk%cmp(icmp)%filter_mode) then + nicas_blk%cmp(icmp)%resol = nam%filter_resol + nicas_blk%cmp(icmp)%nc1max = nam%filter_nc1max + nicas_blk%cmp(icmp)%resol_eff_min = nam%filter_resol_eff_min + else + nicas_blk%cmp(icmp)%resol = nam%resol + nicas_blk%cmp(icmp)%nc1max = nam%nc1max + nicas_blk%cmp(icmp)%resol_eff_min = nam%resol_eff_min + end if nicas_blk%cmp(icmp)%draw_type = nam%nicas_draw_type nicas_blk%cmp(icmp)%interp_type = nam%nicas_interp_type(ig) - nicas_blk%cmp(icmp)%smoother = .false. nicas_blk%cmp(icmp)%compute_norm = (.not.allocated(nicas_blk%cmp(icmp)%norm)) ! Set number of levels @@ -970,10 +976,10 @@ end associate end subroutine nicas_blk_compute_parameters !---------------------------------------------------------------------- -! Subroutine: nicas_blk_compute_parameters_horizontal_smoother -!> Compute NICAS parameters for a horizontal smoother +! Subroutine: nicas_blk_compute_parameters_filter +!> Compute NICAS parameters, homogeneous horizontal filter mode !---------------------------------------------------------------------- -subroutine nicas_blk_compute_parameters_horizontal_smoother(nicas_blk,mpl,rng,nam,geom,rhflt) +subroutine nicas_blk_compute_parameters_filter(nicas_blk,mpl,rng,nam,geom,rhflt) implicit none @@ -986,146 +992,54 @@ type(geom_type),intent(inout) :: geom !< Geometry real(kind_real),intent(in) :: rhflt(geom%nl0) !< Horizontal support radius profile ! Local variables -integer :: il0,il0i,jl0,jl0i,jl0is,jl0is_tmp,nl0,nl0i,icmp -integer :: l0i_to_l0(geom%nl0),proc_to_jl0is(mpl%nproc) -integer :: nc0_gmask(0:geom%nl0) -real(kind_real) :: vert_coord_c0a(geom%nc0a,geom%nl0),area_ver_c0(geom%nl0), & - & vert_coordavg(geom%nl0),vert_coord_c0u(geom%nc0u,geom%nl0) -logical :: gmask_c0a(geom%nc0a,geom%nl0),gmask_hor_c0a(geom%nc0a),gmask_c0u(geom%nc0u,geom%nl0) +integer :: il0 +logical :: filter_mode +character(len=1024) :: strategy +type(cmat_blk_type) :: cmat_blk ! Set name -@:set_name(nicas_blk_compute_parameters_horizontal_smoother) +@:set_name(nicas_blk_compute_parameters_filter) ! Probe in @:probe_in() -! Associate -associate(ig=>nicas_blk%ig) - -! Allocation -allocate(nicas_blk%l0_to_l0i(geom%nl0)) - -! Initialization -l0i_to_l0 = mpl%msv%vali -il0 = 1 -nl0i = 1 -nicas_blk%l0_to_l0i(il0) = nl0i -l0i_to_l0(nl0i) = il0 - -do il0=2,geom%nl0 - ! Look for similar levels (same mask, same horizontal radius) - jl0is = mpl%msv%vali - do jl0i=1,nl0i - ! Index - jl0 = l0i_to_l0(jl0i) - - ! Check mask - jl0is_tmp = mpl%msv%vali - if (all(geom%gmask_c0a(:,il0).eqv.geom%gmask_c0a(:,jl0))) then - ! Check horizontal radius - if (abs(rhflt(il0)-rhflt(jl0))<1.0e-8*rhflt(il0)) jl0is_tmp = jl0i - end if - - ! Gather results - call mpl%f_comm%allgather(jl0is_tmp,proc_to_jl0is) - - ! Check if the result is the same for all tasks - if (all(proc_to_jl0is==jl0is_tmp)) then - jl0is = jl0is_tmp - exit - end if - end do - - if (mpl%msv%isnot(jl0is)) then - ! Similar level found - nicas_blk%l0_to_l0i(il0) = jl0is - else - ! No similar level found, new independent level - nl0i = nl0i+1 - nicas_blk%l0_to_l0i(il0) = nl0i - l0i_to_l0(nl0i) = il0 - end if -end do - -! Save geometry parameters -nl0 = geom%nl0 -vert_coord_c0a = geom%vert_coord_c0a -gmask_c0a = geom%gmask_c0a -gmask_hor_c0a = geom%gmask_hor_c0a -nc0_gmask = geom%nc0_gmask -area_ver_c0 = geom%area_ver_c0 -vert_coordavg = geom%vert_coordavg -vert_coord_c0u = geom%vert_coord_c0u -gmask_c0u = geom%gmask_c0u - -! One level only -geom%nl0 = 1 - -! Allocation -nicas_blk%ncmp = nl0i -allocate(nicas_blk%cmp(nicas_blk%ncmp)) -do icmp=1,nicas_blk%ncmp - allocate(nicas_blk%cmp(icmp)%vlev(geom%nl0)) +! Define C matrix block +cmat_blk%ncmp = 1 +cmat_blk%anisotropic = .false. +call cmat_blk%alloc(geom) +call cmat_blk%init(mpl) +do il0=1,geom%nl0 + cmat_blk%a(:,il0,1) = one + cmat_blk%rh(:,il0,1) = rhflt(il0) + cmat_blk%rv(:,il0,1) = zero + cmat_blk%as = cmat_blk%a + cmat_blk%rhs = cmat_blk%rh + cmat_blk%rvs = cmat_blk%rv end do +cmat_blk%scaling = one -! Initialization -do icmp=1,nicas_blk%ncmp - nicas_blk%cmp(icmp)%vlev = .true. -end do +! Copy C matrix block data +call nicas_blk%copy_cmat(mpl,nam,geom,cmat_blk) -! Setup independent levels -do il0i=1,nl0i - ! Level index - il0 = l0i_to_l0(il0i) - - ! Set local geometry parameters - geom%vert_coord_c0a(:,1) = vert_coord_c0a(:,il0) - geom%gmask_c0a(:,1) = gmask_c0a(:,il0) - geom%gmask_hor_c0a(1) = any(gmask_c0a(:,il0)) - geom%nc0_gmask(1) = nc0_gmask(il0) - geom%area_ver_c0(1) = area_ver_c0(il0) - geom%vert_coordavg(1) = vert_coordavg(il0) - geom%vert_coord_c0u(:,1) = vert_coord_c0u(:,il0) - geom%gmask_c0u(:,1) = gmask_c0u(:,il0) - - ! NICAS block initialization - nicas_blk%cmp(il0i)%ig = ig - nicas_blk%cmp(il0i)%ncmp = 1 - nicas_blk%cmp(il0i)%verbosity = .false. - nicas_blk%cmp(il0i)%resol = nam%smoother_resol - nicas_blk%cmp(il0i)%nc1max = nam%smoother_nc1max - nicas_blk%cmp(il0i)%resol_eff_min = nam%smoother_resol_eff_min - nicas_blk%cmp(il0i)%draw_type = 'octahedral' - nicas_blk%cmp(il0i)%interp_type = 'si' - nicas_blk%cmp(il0i)%smoother = .true. - nicas_blk%cmp(il0i)%compute_norm = .false. - nicas_blk%cmp(il0i)%interp_in_global_file = .false. +! Save strategy and filter mode +strategy = nam%strategy +filter_mode = nam%filter_mode - ! Set number of levels - nicas_blk%cmp(il0i)%nl0 = geom%nl0 +! Force strategy and filter mode +nam%strategy = 'univariate' +nam%filter_mode = .true. - ! Compute parameters - call nicas_blk%cmp(il0i)%compute_parameters(mpl,rng,nam,geom,rhflt(il0)) -end do +! Compute parameters +call nicas_blk%compute_parameters(mpl,rng,nam,geom) -! Reset geometry parameters -geom%nl0 = nl0 -geom%vert_coord_c0a = vert_coord_c0a -geom%gmask_c0a = gmask_c0a -geom%gmask_hor_c0a = gmask_hor_c0a -geom%nc0_gmask = nc0_gmask -geom%area_ver_c0 = area_ver_c0 -geom%vert_coordavg = vert_coordavg -geom%vert_coord_c0u = vert_coord_c0u -geom%gmask_c0u = gmask_c0u - -! End associate -end associate +! Reset strategy and filter mode +nam%strategy = strategy +nam%filter_mode = filter_mode ! Probe out @:probe_out() -end subroutine nicas_blk_compute_parameters_horizontal_smoother +end subroutine nicas_blk_compute_parameters_filter !---------------------------------------------------------------------- ! Subroutine: nicas_blk_copy_cmat @@ -1298,6 +1212,39 @@ end associate end subroutine nicas_blk_copy_cmat +!---------------------------------------------------------------------- +! Subroutine: nicas_blk_apply_filter +!> Apply NICAS method, filter mode +!---------------------------------------------------------------------- +subroutine nicas_blk_apply_filter(nicas_blk,mpl,geom,fld) + +implicit none + +! Passed variables +class(nicas_blk_type),intent(inout) :: nicas_blk !< NICAS data block +type(mpl_type),intent(inout) :: mpl !< MPI data +type(geom_type),intent(in) :: geom !< Geometry +real(kind_real),intent(out) :: fld(geom%nc0a,geom%nl0) !< Field + +! Local variable +integer :: icmp + +! Set name +@:set_name(nicas_blk_apply_sqrt) + +! Probe in +@:probe_in() + +do icmp=1,nicas_blk%ncmp + ! Component work + call nicas_blk%cmp(icmp)%apply_filter(mpl,geom,fld) +end do + +! Probe out +@:probe_out() + +end subroutine nicas_blk_apply_filter + !---------------------------------------------------------------------- ! Subroutine: nicas_blk_apply_sqrt !> Apply NICAS method square-root diff --git a/src/saber/bump/type_nicas_cmp.fypp b/src/saber/bump/type_nicas_cmp.fypp index be0a79ce6..3e1e6efce 100644 --- a/src/saber/bump/type_nicas_cmp.fypp +++ b/src/saber/bump/type_nicas_cmp.fypp @@ -14,7 +14,7 @@ use fckit_mpi_module, only: fckit_mpi_sum,fckit_mpi_min,fckit_mpi_max use tools_atlas, only: get_grid use tools_const, only: zero,half,one,two,three,four,pi,reqkm,deg2rad,rad2deg use tools_func, only: lonlatmod,zss_maxval,zss_minval,zss_sum,zss_count -use tools_gc99, only: fit_func_sqrt +use tools_gc99, only: fit_func,fit_func_sqrt use tools_kinds, only: kind_int,kind_real,huge_int,huge_real use tools_netcdf, only: define_grp,inquire_grp,put_att,get_att,define_dim,inquire_dim,inquire_dim_size,define_var, & & inquire_var,put_var,get_var @@ -158,12 +158,12 @@ type nicas_cmp_type integer :: ncmp !< Number of components in the same block logical :: anisotropic !< Anisotropic tensor flag logical :: verbosity !< Verbosity flag + logical :: filter_mode !< Filter mode real(kind_real) :: resol !< Resolution integer :: nc1max !< Maximum size of the Sc1 subset real(kind_real) :: resol_eff_min !< Minimum effective resolution character(len=1024) :: draw_type !< Draw type character(len=2) :: interp_type !< Interpolation type - logical :: smoother !< Smoother flag logical :: compute_norm !< Compute normalization logical :: interp_in_global_file !< Read/write interpolation in global file integer :: nc0a !< Number of points in subset Sc0, halo A @@ -239,7 +239,7 @@ type nicas_cmp_type real(kind_real),allocatable :: norm(:,:) !< Normalization factor real(kind_real),allocatable :: inorm(:) !< Internal normalization factor on halo A real(kind_real),allocatable :: inorm_sb(:) !< Internal normalization factor on halo B - real(kind_real),allocatable :: smoother_norm(:) !< Smoother normalization + real(kind_real),allocatable :: filter_norm_row_a(:) !< Filter normalization, rows side on halo A ! I/O IDs integer :: ncid !< main ID @@ -294,9 +294,7 @@ contains procedure :: write_grids_data => nicas_cmp_write_grids_data procedure :: write_steps_def => nicas_cmp_write_steps_def procedure :: write_steps_data => nicas_cmp_write_steps_data - procedure :: nicas_cmp_compute_parameters - procedure :: nicas_cmp_compute_parameters_horizontal_smoother - generic :: compute_parameters => nicas_cmp_compute_parameters,nicas_cmp_compute_parameters_horizontal_smoother + procedure :: compute_parameters => nicas_cmp_compute_parameters procedure :: compute_vertical => nicas_cmp_compute_vertical procedure :: compute_horizontal => nicas_cmp_compute_horizontal procedure :: compute_convol => nicas_cmp_compute_convol @@ -306,7 +304,7 @@ contains procedure :: compute_normalization => nicas_cmp_compute_normalization procedure :: randomize_normalization => nicas_cmp_randomize_normalization procedure :: random_cv => nicas_cmp_random_cv - procedure :: apply_horizontal_smoother => nicas_cmp_apply_horizontal_smoother + procedure :: apply_filter => nicas_cmp_apply_filter procedure :: apply_sqrt => nicas_cmp_apply_sqrt procedure :: apply_sqrt_ad => nicas_cmp_apply_sqrt_ad procedure :: apply_convol_sqrt => nicas_cmp_apply_convol_sqrt @@ -318,9 +316,7 @@ contains procedure :: apply_interp_vertical => nicas_cmp_apply_interp_vertical procedure :: apply_interp_vertical_ad => nicas_cmp_apply_interp_vertical_ad procedure :: test_adjoint => nicas_cmp_test_adjoint - procedure :: nicas_cmp_test_normalization - procedure :: nicas_cmp_test_normalization_horizontal_smoother - generic :: test_normalization => nicas_cmp_test_normalization,nicas_cmp_test_normalization_horizontal_smoother + procedure :: test_normalization => nicas_cmp_test_normalization procedure :: c1_to_c1a => nicas_cmp_c1_to_c1a procedure :: c1_to_proc => nicas_cmp_c1_to_proc procedure :: c1_to_c1u => nicas_cmp_c1_to_c1u @@ -720,7 +716,7 @@ if (allocated(nicas_cmp%ball)) then deallocate(nicas_cmp%ball) end if if (allocated(nicas_cmp%inorm_sb)) deallocate(nicas_cmp%inorm_sb) -if (allocated(nicas_cmp%smoother_norm)) deallocate(nicas_cmp%smoother_norm) +if (allocated(nicas_cmp%filter_norm_row_a)) deallocate(nicas_cmp%filter_norm_row_a) ! Probe out @:probe_out() @@ -805,6 +801,9 @@ character(len=1024) :: levname ! Probe in @:probe_in() +! Read filter mode +call get_att(mpl,nicas_cmp%cmpid,0,'filter_mode',nicas_cmp%filter_mode,.false.) + ! Read valid levels allocate(nicas_cmp%vlev(nicas_cmp%nl0)) vlev_id = inquire_var(mpl,nicas_cmp%cmpid,'vlev') @@ -935,6 +934,9 @@ character(len=1024) :: levname ! Probe in @:probe_in() +! Define filter mode +call put_att(mpl,nicas_cmp%cmpid,0,'filter_mode',nicas_cmp%filter_mode) + ! Define valid levels nicas_cmp%vlev_id = define_var(mpl,nicas_cmp%cmpid,'vlev','int',(/nicas_cmp%nl0_id/)) @@ -1073,6 +1075,9 @@ integer :: il1,il1s ! Probe in @:probe_in() +! filter_mode +nbufl = nbufl+1 + ! nl0 nbufi = nbufi+1 @@ -1175,6 +1180,10 @@ integer :: il1,il1s ! Probe in @:probe_in() +! filter_mode +bufl(ibufl+1) = nicas_cmp%filter_mode +ibufl = ibufl+1 + ! nl0 bufi(ibufi+1) = nicas_cmp%nl0 ibufi = ibufi+1 @@ -1321,6 +1330,10 @@ integer :: il1,il1s ! Probe in @:probe_in() +! filter_mode +nicas_cmp%filter_mode = bufl(ibufl+1) +ibufl = ibufl+1 + ! nl0 nicas_cmp%nl0 = bufi(ibufi+1) ibufi = ibufi+1 @@ -1501,7 +1514,8 @@ nicas_cmp%myuniverse = geom%myuniverse ! Set flags nicas_cmp%verbosity = .true. -nicas_cmp%smoother = .false. +call get_att(mpl,nicas_cmp%cmpid,0,'filter_mode',nicas_cmp%filter_mode,.false.) +if (mpl%iobcast) call mpl%f_comm_iobcast%broadcast(nicas_cmp%filter_mode,mpl%rootproc-1) ! Check norm input nicas_cmp%compute_norm = .not.allocated(nicas_cmp%norm) @@ -1899,6 +1913,9 @@ character(len=1024) :: levname ! Probe in @:probe_in() +! Define filter mode +call put_att(mpl,nicas_cmp%cmpid,0,'filter_mode',nicas_cmp%filter_mode) + ! Define vertical sampling write(mpl%info,'(a16,a)') '','Define vertical sampling' call mpl%flush @@ -2418,6 +2435,12 @@ if (.not.nam%load_nicas_global) then nicas_cmp%myuniverse = geom%myuniverse end if +if (nicas_cmp%filter_mode) then + ! Print filter mode + write(mpl%info,'(a10,a)') '','Filter mode activated' + call mpl%flush(flush=nicas_cmp%verbosity) +end if + ! Compute adaptive sampling, vertical write(mpl%info,'(a10,a)') '','Compute adaptive sampling, vertical' call mpl%flush(flush=nicas_cmp%verbosity) @@ -2434,7 +2457,15 @@ if (any(nicas_cmp%vlev)) then call mpl%flush(flush=nicas_cmp%verbosity) call nicas_cmp%compute_convol(mpl,nam,geom) - if (.not.nicas_cmp%smoother) then + if (nicas_cmp%filter_mode) then + ! Allocation + allocate(nicas_cmp%inorm(nicas_cmp%nsa)) + allocate(nicas_cmp%norm(geom%nc0a,nicas_cmp%nl0)) + + ! No normalization in filter mode + nicas_cmp%inorm = one + nicas_cmp%norm = one + else ! Compute internal normalization write(mpl%info,'(a10,a)') '','Compute internal normalization' call mpl%flush(flush=nicas_cmp%verbosity) @@ -2512,52 +2543,6 @@ end if end subroutine nicas_cmp_compute_parameters -!---------------------------------------------------------------------- -! Subroutine: nicas_cmp_compute_parameters_horizontal_smoother -!> Compute NICAS parameters for a horizontal smoother -!---------------------------------------------------------------------- -subroutine nicas_cmp_compute_parameters_horizontal_smoother(nicas_cmp,mpl,rng,nam,geom,rhflt) - -implicit none - -! Passed variables -class(nicas_cmp_type),intent(inout) :: nicas_cmp !< NICAS data component -type(mpl_type),intent(inout) :: mpl !< MPI data -type(rng_type),intent(inout) :: rng !< Random number generator -type(nam_type),intent(in) :: nam !< Namelist -type(geom_type),intent(in) :: geom !< Geometry -real(kind_real),intent(in) :: rhflt !< Horizontal support radius - -! Set name -@:set_name(nicas_cmp_compute_parameters_horizontal_smoother) - -! Probe in -@:probe_in() - -! Allocation -allocate(nicas_cmp%rh(geom%nc0a,nicas_cmp%nl0)) -allocate(nicas_cmp%rv(geom%nc0a,nicas_cmp%nl0)) -allocate(nicas_cmp%as(geom%nc0a,nicas_cmp%nl0)) -allocate(nicas_cmp%rhs(geom%nc0a,nicas_cmp%nl0)) -allocate(nicas_cmp%rvs(geom%nc0a,nicas_cmp%nl0)) - -! Initialization -nicas_cmp%anisotropic = .false. -nicas_cmp%rh(:,1) = rhflt -nicas_cmp%rv = zero -nicas_cmp%as = one -nicas_cmp%rhs(:,1) = rhflt -nicas_cmp%rvs = zero -nicas_cmp%scaling = one - -! Compute parameters -call nicas_cmp%compute_parameters(mpl,rng,nam,geom) - -! Probe out -@:probe_out() - -end subroutine nicas_cmp_compute_parameters_horizontal_smoother - !---------------------------------------------------------------------- ! Subroutine: nicas_cmp_compute_vertical !> Compute NICAS sampling, vertical dimension @@ -3730,10 +3715,11 @@ type(nam_type),intent(in) :: nam !< Namelist type(geom_type),intent(in) :: geom !< Geometry ! Local variables -integer :: isu,il1,il1s,il0,isa,isb,isc,jl1,i_s,is,jsu +integer :: isu,il1,il1s,il0,isa,isb,isc,jl1,i_s,is,jsc,jsu integer,allocatable :: su_to_sc(:) real(kind_real),allocatable :: rh_c0b(:),H11_c0b(:),H22_c0b(:),H12_c0b(:),rv_c0b(:) real(kind_real),allocatable :: rh_c1a(:),H11_c1a(:),H22_c1a(:),H12_c1a(:),rv_c1a(:) +real(kind_real),allocatable :: fld_one(:,:),alpha_b(:),filter_norm_col(:),filter_norm_row_c(:) logical,allocatable :: lcheck_sc(:) ! Set name @@ -3764,11 +3750,9 @@ if (.not.nam%load_nicas_global) then allocate(rh_c0b(nicas_cmp%hor(il1s)%nc0b)) allocate(rh_c1a(nicas_cmp%hor(il1s)%nc1a)) allocate(nicas_cmp%hor(il1)%rh_c1b(nicas_cmp%hor(il1s)%nc1b)) - if (.not.nicas_cmp%smoother) then - allocate(rv_c0b(nicas_cmp%hor(il1s)%nc0b)) - allocate(rv_c1a(nicas_cmp%hor(il1s)%nc1a)) - allocate(nicas_cmp%hor(il1)%rv_c1b(nicas_cmp%hor(il1s)%nc1b)) - end if + allocate(rv_c0b(nicas_cmp%hor(il1s)%nc0b)) + allocate(rv_c1a(nicas_cmp%hor(il1s)%nc1a)) + allocate(nicas_cmp%hor(il1)%rv_c1b(nicas_cmp%hor(il1s)%nc1b)) if (nicas_cmp%anisotropic) then allocate(H11_c0b(nicas_cmp%hor(il1s)%nc0b)) allocate(H11_c1a(nicas_cmp%hor(il1s)%nc1a)) @@ -3787,7 +3771,7 @@ if (.not.nam%load_nicas_global) then ! Halo extension call nicas_cmp%hor(il1s)%com_c0_AB%ext(mpl,nicas_cmp%rh(:,il0)/nicas_cmp%scaling,rh_c0b) - if (.not.nicas_cmp%smoother) call nicas_cmp%hor(il1s)%com_c0_AB%ext(mpl,nicas_cmp%rv(:,il0)/nicas_cmp%scaling,rv_c0b) + call nicas_cmp%hor(il1s)%com_c0_AB%ext(mpl,nicas_cmp%rv(:,il0)/nicas_cmp%scaling,rv_c0b) if (nicas_cmp%anisotropic) then call nicas_cmp%hor(il1s)%com_c0_AB%ext(mpl,nicas_cmp%H11(:,il0)*nicas_cmp%scaling**2,H11_c0b) call nicas_cmp%hor(il1s)%com_c0_AB%ext(mpl,nicas_cmp%H22(:,il0)*nicas_cmp%scaling**2,H22_c0b) @@ -3796,7 +3780,7 @@ if (.not.nam%load_nicas_global) then ! Interpolate fields call nicas_cmp%hor(il1s)%interp_c0b_to_c1a%apply(mpl,rh_c0b,rh_c1a) - if (.not.nicas_cmp%smoother) call nicas_cmp%hor(il1s)%interp_c0b_to_c1a%apply(mpl,rv_c0b,rv_c1a) + call nicas_cmp%hor(il1s)%interp_c0b_to_c1a%apply(mpl,rv_c0b,rv_c1a) if (nicas_cmp%anisotropic) then call nicas_cmp%hor(il1s)%interp_c0b_to_c1a%apply(mpl,H11_c0b,H11_c1a) call nicas_cmp%hor(il1s)%interp_c0b_to_c1a%apply(mpl,H22_c0b,H22_c1a) @@ -3807,7 +3791,7 @@ if (.not.nam%load_nicas_global) then write(mpl%info,'(a19,a)') '','Communication field on halo B' call mpl%flush(flush=nicas_cmp%verbosity) call nicas_cmp%hor(il1s)%com_c1_AB%ext(mpl,rh_c1a,nicas_cmp%hor(il1)%rh_c1b) - if (.not.nicas_cmp%smoother) call nicas_cmp%hor(il1s)%com_c1_AB%ext(mpl,rv_c1a,nicas_cmp%hor(il1)%rv_c1b) + call nicas_cmp%hor(il1s)%com_c1_AB%ext(mpl,rv_c1a,nicas_cmp%hor(il1)%rv_c1b) if (nicas_cmp%anisotropic) then call nicas_cmp%hor(il1s)%com_c1_AB%ext(mpl,H11_c1a,nicas_cmp%hor(il1)%H11_c1b) call nicas_cmp%hor(il1s)%com_c1_AB%ext(mpl,H22_c1a,nicas_cmp%hor(il1)%H22_c1b) @@ -3817,10 +3801,8 @@ if (.not.nam%load_nicas_global) then ! Release memory deallocate(rh_c0b) deallocate(rh_c1a) - if (.not.nicas_cmp%smoother) then - deallocate(rv_c0b) - deallocate(rv_c1a) - end if + deallocate(rv_c0b) + deallocate(rv_c1a) if (nicas_cmp%anisotropic) then deallocate(H11_c0b) deallocate(H11_c1a) @@ -3840,7 +3822,7 @@ if (.not.nam%load_nicas_global) then ! Release memory do il1=1,nicas_cmp%nl1 deallocate(nicas_cmp%hor(il1)%rh_c1b) - if (.not.nicas_cmp%smoother) deallocate(nicas_cmp%hor(il1)%rv_c1b) + deallocate(nicas_cmp%hor(il1)%rv_c1b) if (nicas_cmp%anisotropic) then deallocate(nicas_cmp%hor(il1)%H11_c1b) deallocate(nicas_cmp%hor(il1)%H22_c1b) @@ -3848,9 +3830,6 @@ if (.not.nam%load_nicas_global) then end if end do - ! Allocation - if (nicas_cmp%smoother) allocate(nicas_cmp%smoother_norm(nicas_cmp%nsb)) - ! Compute weights call nicas_cmp%compute_convol_weights(mpl,geom) @@ -3915,34 +3894,13 @@ do isb=1,nicas_cmp%nsb nicas_cmp%sb_to_sc(isb) = isc end do -! Smoother normalization -if (nicas_cmp%smoother) then - do i_s=1,nicas_cmp%c%n_s - isu = nicas_cmp%c%row(i_s) - isb = nicas_cmp%su_to_sb(isu) - if (nicas_cmp%smoother_norm(isb)>zero) then - nicas_cmp%c%S(i_s) = nicas_cmp%c%S(i_s)/nicas_cmp%smoother_norm(isb) - else - if (nicas_cmp%c%S(i_s)>zero) call mpl%abort('${subr}$','error in smoother_norm') - end if - end do -end if - ! Local convolutions source and destination nicas_cmp%c%n_src = nicas_cmp%nsc -if (nicas_cmp%smoother) then - nicas_cmp%c%n_dst = nicas_cmp%nsb -else - nicas_cmp%c%n_dst = nicas_cmp%nsa -end if +nicas_cmp%c%n_dst = nicas_cmp%nsa do i_s=1,nicas_cmp%c%n_s if (.not.nam%load_nicas_global) then isu = nicas_cmp%c%row(i_s) - if (nicas_cmp%smoother) then - nicas_cmp%c%row(i_s) = nicas_cmp%su_to_sb(isu) - else - nicas_cmp%c%row(i_s) = nicas_cmp%su_to_sa(isu) - end if + nicas_cmp%c%row(i_s) = nicas_cmp%su_to_sa(isu) end if jsu = nicas_cmp%c%col(i_s) nicas_cmp%c%col(i_s) = su_to_sc(jsu) @@ -3951,6 +3909,47 @@ end do ! Setup communication call nicas_cmp%com_s_AC%setup(mpl,'com_s_AC',nicas_cmp%nsa,nicas_cmp%nsc,nicas_cmp%ns,nicas_cmp%sa_to_s,nicas_cmp%sc_to_s) +! Filter normalization +if (nicas_cmp%filter_mode) then + ! Allocation + allocate(fld_one(geom%nc0a,nicas_cmp%nl0)) + allocate(alpha_b(nicas_cmp%nsb)) + allocate(filter_norm_col(nicas_cmp%nsa)) + allocate(filter_norm_row_c(nicas_cmp%nsc)) + + ! Extension + call nicas_cmp%com_s_AC%ext(mpl,nicas_cmp%filter_norm_row_a,filter_norm_row_c) + + ! Compute normalization, columns side + fld_one = one + call nicas_cmp%apply_interp_ad(mpl,fld_one,alpha_b) + call nicas_cmp%com_s_AB%red(mpl,alpha_b,filter_norm_col) + + do i_s=1,nicas_cmp%c%n_s + ! Rows side (but columns of nicas_cmp%c, since we apply its adjoint) + jsc = nicas_cmp%c%col(i_s) + if (filter_norm_row_c(jsc)>zero) then + nicas_cmp%c%S(i_s) = nicas_cmp%c%S(i_s)/filter_norm_row_c(jsc) + else + if (nicas_cmp%c%S(i_s)>zero) call mpl%abort('${subr}$','error in filter_norm_row_c') + end if + + ! Columns side (but rows of nicas_cmp%c, since we apply its adjoint) + isa = nicas_cmp%c%row(i_s) + if (filter_norm_col(isa)>zero) then + nicas_cmp%c%S(i_s) = nicas_cmp%c%S(i_s)/filter_norm_col(isa) + else + if (nicas_cmp%c%S(i_s)>zero) call mpl%abort('${subr}$','error in filter_norm_col') + end if + end do + + ! Release memory + deallocate(fld_one) + deallocate(alpha_b) + deallocate(filter_norm_col) + deallocate(filter_norm_row_c) +end if + ! Release memory deallocate(lcheck_sc) deallocate(su_to_sc) @@ -4087,26 +4086,18 @@ do isb=1,nicas_cmp%nsb mnd(jc1u) = .true. end if end if - if (nicas_cmp%smoother) then - if (il0==jl0) then - vnd(jc1u) = zero - else - mnd(jc1u) = .false. - end if + if (nam%from_gsi) then + distv = real(abs(il0-jl0),kind_real) else - if (nam%from_gsi) then - distv = real(abs(il0-jl0),kind_real) - else - distv = abs(nicas_cmp%hor(il1)%vert_coord_c1u(ic1u)-nicas_cmp%hor(jl1)%vert_coord_c1u(jc1u)) - end if - if (nicas_cmp%hor(il1)%rv_c1b(ic1b)>zero) then - vnd(jc1u) = distv/nicas_cmp%hor(il1)%rv_c1b(ic1b) - mnd(jc1u) = mnd(jc1u).and.inf(vnd(jc1u),half) - elseif (distv>zero) then - mnd(jc1u) = .false. - else - vnd(jc1u) = zero - end if + distv = abs(nicas_cmp%hor(il1)%vert_coord_c1u(ic1u)-nicas_cmp%hor(jl1)%vert_coord_c1u(jc1u)) + end if + if (nicas_cmp%hor(il1)%rv_c1b(ic1b)>zero) then + vnd(jc1u) = distv/nicas_cmp%hor(il1)%rv_c1b(ic1b) + mnd(jc1u) = mnd(jc1u).and.inf(vnd(jc1u),half) + elseif (distv>zero) then + mnd(jc1u) = .false. + else + vnd(jc1u) = zero end if end if end if @@ -4152,9 +4143,9 @@ type(mpl_type),intent(inout) :: mpl !< MPI data type(geom_type),intent(in) :: geom !< Geometry ! Local variables -integer :: n_s_max,ithread,isu,isb,jc1u,jl1,jbd,jsu +integer :: n_s_max,ithread,isu,isa,isb,jc1u,jl1,jbd,jsu integer :: c_n_s(mpl%nthread) -real(kind_real) :: S,S_tot(nicas_cmp%nsb,mpl%nthread) +real(kind_real) :: S,S_tot(nicas_cmp%nsa,mpl%nthread) type(linop_type) :: c(mpl%nthread) ! Set name @@ -4190,20 +4181,28 @@ do isb=1,nicas_cmp%nsb jc1u = nicas_cmp%ball(jl1,isb)%bd_to_c1u(jbd) jsu = nicas_cmp%hor(jl1)%c1u_to_su(jc1u) - ! Horizontal component - S = fit_func_sqrt(mpl,nicas_cmp%ball(jl1,isb)%hnd(jbd)) + if (nicas_cmp%filter_mode) then + ! Horizontal component + S = fit_func(mpl,'hor',nicas_cmp%ball(jl1,isb)%hnd(jbd)) - ! Vertical component - if (.not.nicas_cmp%smoother) S = S*fit_func_sqrt(mpl,nicas_cmp%ball(jl1,isb)%vnd(jbd)) + ! Vertical component + S = S*fit_func(mpl,'ver',nicas_cmp%ball(jl1,isb)%vnd(jbd)) + else + ! Horizontal component + S = fit_func_sqrt(mpl,nicas_cmp%ball(jl1,isb)%hnd(jbd)) - if (sup(abs(S),S_inf)) then - if (nicas_cmp%smoother) then - ! Store coefficient for convolution - call c(ithread)%add_op(c_n_s(ithread),isu,jsu,S) - S_tot(isb,ithread) = S_tot(isb,ithread)+S - else - ! Store coefficient for convolution - if (nicas_cmp%lcheck_sa(isu)) call c(ithread)%add_op(c_n_s(ithread),isu,jsu,S) + ! Vertical component + S = S*fit_func_sqrt(mpl,nicas_cmp%ball(jl1,isb)%vnd(jbd)) + end if + + if (sup(abs(S),S_inf).and.nicas_cmp%lcheck_sa(isu)) then + ! Store coefficient for convolution + call c(ithread)%add_op(c_n_s(ithread),isu,jsu,S) + + ! Accumulate for filter normalization + if (nicas_cmp%filter_mode) then + isa = nicas_cmp%su_to_sa(isu) + S_tot(isa,ithread) = S_tot(isa,ithread)+S end if end if end do @@ -4217,9 +4216,14 @@ if (nicas_cmp%verbosity) call mpl%prog_final ! Gather data from threads call nicas_cmp%c%gather(mpl,c_n_s,c) -if (nicas_cmp%smoother) then - do isb=1,nicas_cmp%nsb - nicas_cmp%smoother_norm(isb) = sum(S_tot(isb,:)) + +if (nicas_cmp%filter_mode) then + ! Allocation + allocate(nicas_cmp%filter_norm_row_a(nicas_cmp%nsa)) + + ! Compute filter normalization, rows side + do isa=1,nicas_cmp%nsa + nicas_cmp%filter_norm_row_a(isa) = sum(S_tot(isa,:)) end do end if @@ -4321,7 +4325,7 @@ type(mpl_type),intent(inout) :: mpl !< MPI data type(geom_type),intent(in) :: geom !< Geometry ! Local variables -integer :: il0i,i_s,ic1b,jc1b,jsb,jsc,ih,ic0a,il0,il1,il1s,jv,nlr,ilr,ic,isb_add,isa,isb,jsu,js,jproc,inecmax +integer :: i_s,ic1b,jc1b,jsb,jsc,ih,ic0a,il0,il1,il1s,jv,nlr,ilr,ic,isb_add,isa,isb,jsu,js,jproc,inecmax integer,allocatable :: order(:),isb_list(:),inec_sa(:),inec_sb(:) integer,allocatable :: c_ind_sa(:,:),c_ind_sb(:,:) real(kind_real) :: S_add @@ -4506,7 +4510,6 @@ nicas_cmp%norm = mpl%msv%valr ! Compute normalization weights do il0=1,nicas_cmp%nl0 if (nicas_cmp%vlev(il0)) then - il0i = geom%l0_to_l0i(il0) write(mpl%info,'(a13,a,i3,a)') '','Level ',il0,': ' call mpl%flush(newl=.false.,flush=nicas_cmp%verbosity) if (nicas_cmp%verbosity) call mpl%prog_init(geom%nc0a) @@ -4746,75 +4749,111 @@ deallocate(alpha) end subroutine nicas_cmp_random_cv !---------------------------------------------------------------------- -! Subroutine: nicas_cmp_apply_horizontal_smoother -!> Apply NICAS method for a horizontal smoother +! Subroutine: nicas_cmp_apply_filter +!> Apply NICAS method, filter mode !---------------------------------------------------------------------- -subroutine nicas_cmp_apply_horizontal_smoother(nicas_cmp,mpl,geom,il0,fld) +subroutine nicas_cmp_apply_filter(nicas_cmp,mpl,geom,fld) implicit none ! Passed variables -class(nicas_cmp_type),intent(in) :: nicas_cmp !< NICAS data component -type(mpl_type),intent(inout) :: mpl !< MPI data -type(geom_type),intent(in) :: geom !< Geometry -integer,intent(in) :: il0 !< Level index -real(kind_real),intent(inout) :: fld(geom%nc0a) !< Field +class(nicas_cmp_type),intent(in) :: nicas_cmp !< NICAS data component +type(mpl_type),intent(inout) :: mpl !< MPI data +type(geom_type),intent(in) :: geom !< Geometry +real(kind_real),intent(inout) :: fld(geom%nc0a,geom%nl0) !< Field ! Local variables -integer :: ic1b,isb +integer :: il0,ic0a real(kind_real) :: sums,sume -real(kind_real) :: beta(nicas_cmp%hor(1)%nc1b) real(kind_real) :: alpha_a(nicas_cmp%nsa),alpha_b(nicas_cmp%nsb),alpha_c(nicas_cmp%nsc) ! Set name -@:set_name(nicas_cmp_apply_horizontal_smoother) +@:set_name(nicas_cmp_apply_filter) ! Probe in @:probe_in() -! Check that it is a smoother -if (.not.nicas_cmp%smoother) call mpl%abort('${subr}$','apply is only for smoothers') +! Check that filter mode is activated +if (.not.nicas_cmp%filter_mode) call mpl%abort('${subr}$','apply_filter requires filter mode') -! Save global sum -sums = zss_sum(fld,mask=geom%gmask_c0a(:,il0)) -call mpl%f_comm%allreduce(sums,fckit_mpi_sum()) +if (any(nicas_cmp%vlev)) then + if (nicas_cmp%nl0==geom%nl0) then + ! Full 3D NICAS -! Adjoint horizontal interpolation -call nicas_cmp%hor(1)%interp_c1b_to_c0a%apply_ad(mpl,fld,beta) + ! Save global sum + sums = zss_sum(fld,mask=geom%gmask_c0a) + call mpl%f_comm%allreduce(sums,fckit_mpi_sum()) + sums = sums/sum(geom%nc0_gmask(1:geom%nl0)) -! Copy -do ic1b=1,nicas_cmp%hor(1)%nc1b - isb = nicas_cmp%hor(1)%c1b_to_sb(ic1b) - alpha_b(isb) = beta(ic1b) -end do + ! Adjoint interpolation + call nicas_cmp%apply_interp_ad(mpl,fld,alpha_b) -! Apply adjoint linear operator -call nicas_cmp%c%apply_ad(mpl,alpha_b,alpha_c) + ! Halo reduction from zone B to zone A + call nicas_cmp%com_s_AB%red(mpl,alpha_b,alpha_a) -! Halo reduction from zone C to zone A -call nicas_cmp%com_s_AC%red(mpl,alpha_c,alpha_a) + ! Apply linear operator + call nicas_cmp%c%apply_ad(mpl,alpha_a,alpha_c) -! Halo extension from zone A to zone B -call nicas_cmp%com_s_AB%ext(mpl,alpha_a,alpha_b) + ! Halo reduction from zone C to zone A + call nicas_cmp%com_s_AC%red(mpl,alpha_c,alpha_a) -! Copy -do ic1b=1,nicas_cmp%hor(1)%nc1b - isb = nicas_cmp%hor(1)%c1b_to_sb(ic1b) - beta(ic1b) = alpha_b(isb) -end do + ! Halo extension from zone A to zone B + call nicas_cmp%com_s_AB%ext(mpl,alpha_a,alpha_b) -! Horizontal interpolation -call nicas_cmp%hor(1)%interp_c1b_to_c0a%apply(mpl,beta,fld,msdst=.false.) + ! Interpolation + call nicas_cmp%apply_interp(mpl,alpha_b,fld) -! Reset global sum -sume = zss_sum(fld,mask=geom%gmask_c0a(:,il0)) -call mpl%f_comm%allreduce(sume,fckit_mpi_sum()) -fld = fld*sums/sume + ! Reset global sum + sume = zss_sum(fld,mask=geom%gmask_c0a) + call mpl%f_comm%allreduce(sume,fckit_mpi_sum()) + sume = sume/sum(geom%nc0_gmask(1:geom%nl0)) + do il0=1,geom%nl0 + do ic0a=1,geom%nc0a + if (geom%gmask_c0a(ic0a,il0)) fld(ic0a,il0) = fld(ic0a,il0)+sums-sume + end do + end do + else + ! Same horizontal convolution for all levels, no vertical convolution + + do il0=1,geom%nl0 + ! Save global sum + sums = zss_sum(fld(:,il0),mask=geom%gmask_c0a(:,il0)) + call mpl%f_comm%allreduce(sums,fckit_mpi_sum()) + sums = sums/geom%nc0_gmask(il0) + + ! Adjoint interpolation + call nicas_cmp%apply_interp_ad(mpl,fld(:,il0:il0),alpha_b) + + ! Halo reduction from zone B to zone A + call nicas_cmp%com_s_AB%red(mpl,alpha_b,alpha_a) + + ! Apply linear operator + call nicas_cmp%c%apply_ad(mpl,alpha_a,alpha_c) + + ! Halo reduction from zone C to zone A + call nicas_cmp%com_s_AC%red(mpl,alpha_c,alpha_a) + + ! Halo extension from zone A to zone B + call nicas_cmp%com_s_AB%ext(mpl,alpha_a,alpha_b) + + ! Interpolation + call nicas_cmp%apply_interp(mpl,alpha_b,fld(:,il0:il0)) + + ! Reset global sum + sume = zss_sum(fld(:,il0),mask=geom%gmask_c0a(:,il0)) + call mpl%f_comm%allreduce(sume,fckit_mpi_sum()) + sume = sume/geom%nc0_gmask(il0) + do ic0a=1,geom%nc0a + if (geom%gmask_c0a(ic0a,il0)) fld(ic0a,il0) = fld(ic0a,il0)+sums-sume + end do + end do + end if +end if ! Probe out @:probe_out() -end subroutine nicas_cmp_apply_horizontal_smoother +end subroutine nicas_cmp_apply_filter !---------------------------------------------------------------------- ! Subroutine: nicas_cmp_apply_sqrt @@ -4843,6 +4882,9 @@ logical :: lsteps ! Probe in @:probe_in() +! Check that filter mode is not activated +if (nicas_cmp%filter_mode) call mpl%abort('${subr}$','apply_sqrt_ad inconsistent with filter mode') + ! Local flag lsteps = .false. if (present(steps)) lsteps = steps @@ -4947,6 +4989,9 @@ logical :: lsteps ! Probe in @:probe_in() +! Check that filter mode is not activated +if (nicas_cmp%filter_mode) call mpl%abort('${subr}$','apply_sqrt_ad inconsistent with filter mode') + ! Local flag lsteps = .false. if (present(steps)) lsteps = steps @@ -5623,7 +5668,9 @@ type(geom_type),intent(in) :: geom !< Geometry ! Local variables integer :: itest,isa integer :: il0(nam%check_normalization),iproc(nam%check_normalization),ic0a(nam%check_normalization) -real(kind_real) :: alpha(nicas_cmp%nsa),norm,val(nam%check_normalization) +real(kind_real) :: norm +real(kind_real) :: val(nam%check_normalization) +real(kind_real),allocatable :: fld(:,:),alpha(:) ! Set name @:set_name(nicas_cmp_test_normalization) @@ -5649,104 +5696,71 @@ end do ! Desynchronize random number generator call rng%desync(mpl) -! Check internal normalization -write(mpl%info,'(a10,a)') '','Check internal normalization' -call mpl%flush(flush=nicas_cmp%verbosity) -do itest=1,nam%check_normalization - ! Initialization - alpha = zero - if (mpl%myproc==iproc(itest)) then - ! Get random point - call rng%rand(1,nicas_cmp%nsa,isa) - alpha(isa) = one - end if - - ! Apply convolution square-root adjoint - call nicas_cmp%apply_convol_sqrt_ad(mpl,alpha) - - ! Apply convolution square-root - call nicas_cmp%apply_convol_sqrt(mpl,alpha) - - ! Broadcast normalization value - if (mpl%myproc==iproc(itest)) norm = alpha(isa) - call mpl%f_comm%broadcast(norm,iproc(itest)-1) - val(itest) = norm -end do -write(mpl%test,'(a13,a,f10.7,a,f10.7,a,i6,a)') '','Min / max:',minval(val),' / ',maxval(val),' over ', & - & nam%check_normalization,' tests' -call mpl%flush(flush=nicas_cmp%verbosity) - -! Reset random seed if necessary -call rng%reseed - -! End associate -end associate - -! Probe out -@:probe_out() - -end subroutine nicas_cmp_test_normalization - -!---------------------------------------------------------------------- -! Subroutine: nicas_cmp_test_normalization_horizontal_smoother -!> Test NICAS normalization for horizontal smoother -!---------------------------------------------------------------------- -subroutine nicas_cmp_test_normalization_horizontal_smoother(nicas_cmp,mpl,rng,nam,geom,il0) +if (nicas_cmp%filter_mode) then + ! Check filter integral + write(mpl%info,'(a10,a)') '','Check filter integral' + call mpl%flush(flush=nicas_cmp%verbosity) -implicit none + ! Allocation + allocate(fld(geom%nc0a,geom%nl0)) -! Passed variables -class(nicas_cmp_type),intent(in) :: nicas_cmp !< NICAS data component -type(mpl_type),intent(inout) :: mpl !< MPI data -type(rng_type),intent(inout) :: rng !< Random number generator -type(nam_type),intent(in) :: nam !< Namelist -type(geom_type),intent(in) :: geom !< Geometry -integer,intent(in) :: il0 !< Level index + do itest=1,nam%check_normalization + ! Initialization + fld = zero + if (mpl%myproc==iproc(itest)) fld(ic0a(itest),il0(itest)) = one -! Local variables -integer :: itest -integer :: iproc(nam%check_normalization),ic0a(nam%check_normalization) -real(kind_real) :: fld(geom%nc0a),norm,val(nam%check_normalization) + ! Apply NICAS filter + call nicas_cmp%apply_filter(mpl,geom,fld) -! Set name -@:set_name(nicas_cmp_test_normalization) + ! Get sum + norm = zss_sum(fld,mask=geom%gmask_c0a) + call mpl%f_comm%allreduce(norm,fckit_mpi_sum()) + val(itest) = norm + end do + write(mpl%test,'(a13,a,f10.7,a,f10.7,a,i6,a)') '','Min / max:',minval(val),' / ',maxval(val),' over ', & + & nam%check_normalization,' tests' + call mpl%flush(flush=nicas_cmp%verbosity) -! Probe in -@:probe_in() + ! Release memory + deallocate(fld) +else + ! Check internal normalization + write(mpl%info,'(a10,a)') '','Check internal normalization' + call mpl%flush(flush=nicas_cmp%verbosity) -! Associate -associate(ig=>nicas_cmp%ig) + ! Allocation + allocate(alpha(nicas_cmp%nsa)) -! Resynchronize random number generator -call rng%resync(mpl) + do itest=1,nam%check_normalization + ! Initialization + alpha = zero + if (mpl%myproc==iproc(itest)) then + ! Get random point + call rng%rand(1,nicas_cmp%nsa,isa) + alpha(isa) = one + end if -! Get random points -do itest=1,nam%check_normalization - call geom%rand_point(mpl,rng,il0,iproc(itest),ic0a(itest)) -end do + ! Apply convolution square-root adjoint + call nicas_cmp%apply_convol_sqrt_ad(mpl,alpha) -! Desynchronize random number generator -call rng%desync(mpl) + ! Apply convolution square-root + call nicas_cmp%apply_convol_sqrt(mpl,alpha) -! Check smoother integral -write(mpl%info,'(a10,a)') '','Check smoother integral' -call mpl%flush(flush=nicas_cmp%verbosity) -do itest=1,nam%check_normalization - ! Initialization - fld = zero - if (mpl%myproc==iproc(itest)) fld(ic0a(itest)) = one + ! Broadcast normalization value + if (mpl%myproc==iproc(itest)) norm = alpha(isa) + call mpl%f_comm%broadcast(norm,iproc(itest)-1) + val(itest) = norm + end do + write(mpl%test,'(a13,a,f10.7,a,f10.7,a,i6,a)') '','Min / max:',minval(val),' / ',maxval(val),' over ', & + & nam%check_normalization,' tests' + call mpl%flush(flush=nicas_cmp%verbosity) - ! Apply NICAS smoother - call nicas_cmp%apply_horizontal_smoother(mpl,geom,il0,fld) + ! Release memory + deallocate(alpha) +end if - ! Get sum - norm = zss_sum(fld,mask=geom%gmask_c0a(:,il0)) - call mpl%f_comm%allreduce(norm,fckit_mpi_sum()) - val(itest) = norm -end do -write(mpl%test,'(a13,a,f10.7,a,f10.7,a,i6,a)') '','Min / max:',minval(val),' / ',maxval(val),' over ', & - & nam%check_normalization,' tests' -call mpl%flush(flush=nicas_cmp%verbosity) +! Reset random seed if necessary +call rng%reseed ! End associate end associate @@ -5754,7 +5768,7 @@ end associate ! Probe out @:probe_out() -end subroutine nicas_cmp_test_normalization_horizontal_smoother +end subroutine nicas_cmp_test_normalization !---------------------------------------------------------------------- ! Function: nicas_cmp_c1_to_c1a diff --git a/src/saber/bump/type_var.fypp b/src/saber/bump/type_var.fypp index 78aa671d5..5536cba93 100644 --- a/src/saber/bump/type_var.fypp +++ b/src/saber/bump/type_var.fypp @@ -8,10 +8,10 @@ !---------------------------------------------------------------------- module type_var -use fckit_mpi_module, only: fckit_mpi_sum +use fckit_mpi_module, only: fckit_mpi_min,fckit_mpi_sum !$ use omp_lib use tools_const, only: zero,half,one,two,three,four,six,reqkm -use tools_func, only: zss_sum,global_average +use tools_func, only: zss_minval,zss_sum,global_average use tools_kinds, only: kind_real use type_ens, only: ens_type use type_geom, only: geom_type @@ -518,12 +518,14 @@ type(nam_type),intent(inout) :: nam !< Namelist type(geom_type),intent(inout) :: geom !< Geometry ! Local variables -integer :: iv,il0,il0i,iter,ipass,ipass_min(geom%nl0) -real(kind_real) :: P9,P20,P21,diff,diff_abs_min(geom%nl0),m2avg -real(kind_real) :: m2avg_init(geom%nl0,nam%nv),m2sq(geom%nl0),m4(geom%nl0),m2sqasy(geom%nl0) -real(kind_real) :: rhflt(geom%nl0),drhflt(geom%nl0),m2prod(geom%nl0),m2_ini(geom%nc0a,geom%nl0),m2(geom%nc0a,geom%nl0) -logical :: dichotomy(geom%nl0) -type(nicas_blk_type) :: nicas_blk +integer :: iv,il0,iter,ipass +integer,allocatable :: ipass_min(:,:) +real(kind_real) :: P9,P20,P21,diff,m2avg +real(kind_real) :: m2avg_init(geom%nl0,nam%nv) +real(kind_real),allocatable :: diff_abs_min(:,:),m2_min(:,:),m2sq(:,:),m2sqasy(:,:),rhflt(:,:),m2prod(:,:),m2_ini(:,:,:) +real(kind_real),allocatable :: m4(:,:),drhflt(:,:),m2(:,:,:) +logical,allocatable :: dichotomy(:,:) +type(nicas_blk_type),allocatable :: nicas_blk(:) ! Set name @:set_name(var_filter) @@ -550,195 +552,280 @@ if ((nam%var_niter<=0).and.(nam%var_npass<=0)) then end do end do else + ! Allocation + allocate(diff_abs_min(geom%nl0,nam%nv)) + allocate(m2_min(geom%nl0,nam%nv)) + allocate(m2sq(geom%nl0,nam%nv)) + allocate(m2sqasy(geom%nl0,nam%nv)) + allocate(rhflt(geom%nl0,nam%nv)) + allocate(m2prod(geom%nl0,nam%nv)) + allocate(m2_ini(geom%nc0a,geom%nl0,nam%nv)) + allocate(nicas_blk(nam%nv)) + ! Ensemble size-dependent coefficients if (var%ne<3) call mpl%abort('${subr}$','var%ne should be larger than 3') P9 = -real(var%ne,kind_real)/real((var%ne-2)*(var%ne-3),kind_real) P20 = real((var%ne-1)*(var%ne**2-3*var%ne+3),kind_real)/real(var%ne*(var%ne-2)*(var%ne-3),kind_real) P21 = real(var%ne-1,kind_real)/real(var%ne+1,kind_real) + ! Global minimum value for thresholding + m2_min = zero do iv=1,nam%nv - write(mpl%info,'(a10,a,a)') '','Variable ',trim(nam%variables(iv)) - call mpl%flush + do il0=1,geom%nl0 + if (mpl%msv%isanynot(var%m2(:,il0,iv))) m2_min(il0,iv) = zss_minval(var%m2(:,il0,iv),mask=geom%gmask_c0a(:,il0)) + end do + end do + call mpl%f_comm%allreduce(m2_min,fckit_mpi_min()) - ! Global sum - m2sq = zero - m4 = zero + ! Global sum of squared variance + m2sq = zero + do iv=1,nam%nv do il0=1,geom%nl0 - if (mpl%msv%isanynot(var%m2(:,il0,iv))) m2sq(il0) = zss_sum(var%m2(:,il0,iv)**2,mask=geom%gmask_c0a(:,il0)) - if (mpl%msv%isanynot(var%m4(:,il0,iv))) m4(il0) = zss_sum(var%m4(:,il0,iv),mask=geom%gmask_c0a(:,il0)) + if (mpl%msv%isanynot(var%m2(:,il0,iv))) m2sq(il0,iv) = zss_sum(var%m2(:,il0,iv)**2,mask=geom%gmask_c0a(:,il0)) + end do + end do + call mpl%f_comm%allreduce(m2sq,fckit_mpi_sum()) + + ! Asymptotic statistics + if (nam%gau_approx) then + ! Gaussian approximation + m2sqasy = P21*m2sq + else + ! Allocation + allocate(m4(geom%nl0,nam%nv)) + + ! Global sum of fourth-order moment + m4 = zero + do iv=1,nam%nv + do il0=1,geom%nl0 + if (mpl%msv%isanynot(var%m4(:,il0,iv))) m4(il0,iv) = zss_sum(var%m4(:,il0,iv),mask=geom%gmask_c0a(:,il0)) + end do end do - call mpl%f_comm%allreduce(m2sq,fckit_mpi_sum()) call mpl%f_comm%allreduce(m4,fckit_mpi_sum()) - ! Asymptotic statistics - if (nam%gau_approx) then - ! Gaussian approximation - m2sqasy = P21*m2sq - else - ! General case - m2sqasy = P20*m2sq+P9*m4 - end if + ! General case + m2sqasy = P20*m2sq+P9*m4 - ! Initialization - m2_ini = var%m2(:,:,iv) + ! Release memory + deallocate(m4) + end if - if (nam%var_niter>0) then - ! Dichotomy initialization - dichotomy = .false. - rhflt = nam%var_rhflt(1:geom%nl0,iv) - drhflt = rhflt + ! Initial values without filtering + m2_ini = var%m2 + do iv=1,nam%nv + do il0=1,geom%nl0 + diff = m2prod(il0,iv)-m2sqasy(il0,iv) + diff_abs_min(il0,iv) = abs(diff) + end do + end do + var%m2flt = m2_ini - ! Global product - do il0=1,geom%nl0 - m2prod(il0) = zss_sum(m2_ini(:,il0)**2,mask=geom%gmask_c0a(:,il0)) - end do - call mpl%f_comm%allreduce(m2prod,fckit_mpi_sum()) + ! Initial global product + do iv=1,nam%nv + do il0=1,geom%nl0 + m2prod(il0,iv) = zss_sum(m2_ini(:,il0,iv)**2,mask=geom%gmask_c0a(:,il0)) + end do + end do + call mpl%f_comm%allreduce(m2prod,fckit_mpi_sum()) - ! Save results - do il0=1,geom%nl0 - diff = m2prod(il0)-m2sqasy(il0) - diff_abs_min(il0) = abs(diff) - var%m2flt(:,il0,iv) = m2(:,il0) - end do + if (nam%var_niter>0) then + ! Allocation + allocate(drhflt(geom%nl0,nam%nv)) + allocate(dichotomy(geom%nl0,nam%nv)) + + ! Initialize dichotomy method + dichotomy = .false. + rhflt = nam%var_rhflt(1:geom%nl0,1:nam%nv) + drhflt = rhflt - do iter=1,nam%var_niter - ! Copy initial value - m2 = m2_ini + do iter=1,nam%var_niter + ! Copy initial variance + m2 = m2_ini - ! Set smoother parameters - nicas_blk%ig = iv - call nicas_blk%compute_parameters(mpl,rng,nam,geom,rhflt) + do iv=1,nam%nv + ! Prepare NICAS filter + nicas_blk(iv)%ig = nam%group_index(iv) + nicas_blk(iv)%verbosity = .false. + call nicas_blk(iv)%compute_parameters(mpl,rng,nam,geom,rhflt(:,iv)) + + ! Filter variance + call nicas_blk(iv)%apply_filter(mpl,geom,m2(:,:,iv)) + + ! Release memory + call nicas_blk(iv)%dealloc + end do - ! Apply smoother + ! Reset minimum value + do iv=1,nam%nv do il0=1,geom%nl0 - il0i = nicas_blk%l0_to_l0i(il0) - call nicas_blk%cmp(il0i)%apply_horizontal_smoother(mpl,geom,il0,m2(:,il0)) + if (mpl%msv%isanynot(var%m2(:,il0,iv))) m2(:,il0,iv) = max(m2(:,il0,iv),m2_min(il0,iv)) end do + end do - ! Global product + ! Global product + do iv=1,nam%nv do il0=1,geom%nl0 - m2prod(il0) = zss_sum(m2(:,il0)*m2_ini(:,il0),mask=geom%gmask_c0a(:,il0)) + m2prod(il0,iv) = zss_sum(m2(:,il0,iv)*m2_ini(:,il0,iv),mask=geom%gmask_c0a(:,il0)) end do - call mpl%f_comm%allreduce(m2prod,fckit_mpi_sum()) + end do + call mpl%f_comm%allreduce(m2prod,fckit_mpi_sum()) - ! Update support radius + ! Update filtered variance and support radius + do iv=1,nam%nv do il0=1,geom%nl0 - diff = m2prod(il0)-m2sqasy(il0) - if ((abs(diff)zero) then ! Increase filtering support radius - if (dichotomy(il0)) then - drhflt(il0) = half*drhflt(il0) - rhflt(il0) = rhflt(il0)+drhflt(il0) + if (dichotomy(il0,iv)) then + ! Dichotomy already activated + drhflt(il0,iv) = half*drhflt(il0,iv) + rhflt(il0,iv) = rhflt(il0,iv)+drhflt(il0,iv) else - rhflt(il0) = rhflt(il0)+drhflt(il0) - drhflt(il0) = two*drhflt(il0) + ! Dichotomy not activated yet + rhflt(il0,iv) = rhflt(il0,iv)+drhflt(il0,iv) + drhflt(il0,iv) = two*drhflt(il0,iv) end if else - ! Change dichotomy status - dichotomy(il0) = .true. + if (.not.dichotomy(il0,iv)) then + ! Change dichotomy status + dichotomy(il0,iv) = .true. + drhflt(il0,iv) = half*drhflt(il0,iv) + end if ! Decrease filtering support radius - drhflt(il0) = half*drhflt(il0) - rhflt(il0) = rhflt(il0)-drhflt(il0) + drhflt(il0,iv) = half*drhflt(il0,iv) + rhflt(il0,iv) = rhflt(il0,iv)-drhflt(il0,iv) end if end if end do - - ! Release memory - call nicas_blk%dealloc end do + end do - ! Global product + ! Final global product + do iv=1,nam%nv do il0=1,geom%nl0 - m2prod(il0) = zss_sum(var%m2flt(:,il0,iv)*m2_ini(:,il0),mask=geom%gmask_c0a(:,il0)) + m2prod(il0,iv) = zss_sum(var%m2flt(:,il0,iv)*m2_ini(:,il0,iv),mask=geom%gmask_c0a(:,il0)) end do - call mpl%f_comm%allreduce(m2prod,fckit_mpi_sum()) + end do + call mpl%f_comm%allreduce(m2prod,fckit_mpi_sum()) - ! Print results - write(mpl%info,'(a13,a)') '','Optimal filtering length-scale:' + ! Print results + write(mpl%info,'(a10,a)') '','Optimal filtering length-scale:' + call mpl%flush + do iv=1,nam%nv + write(mpl%info,'(a13,a,a,a)') '','Variable ',trim(nam%variables(iv)),':' call mpl%flush do il0=1,geom%nl0 - if (m2sqasy(il0)>zero) then - write(mpl%test,'(a16,a,i3,a,f10.2,a,e12.5)') '','Level ',il0,': rhflt = ',rhflt(il0)*reqkm, & - & ' km, rel. diff. = ',(m2prod(il0)-m2sqasy(il0))/m2sqasy(il0) + if (m2sqasy(il0,iv)>zero) then + write(mpl%test,'(a16,a,i3,a,f10.2,a,e12.5)') '','Level ',il0,': rhflt = ',rhflt(il0,iv)*reqkm, & + & ' km, rel. diff. = ',(m2prod(il0,iv)-m2sqasy(il0,iv))/m2sqasy(il0,iv) call mpl%flush end if end do - elseif (nam%var_npass>0) then - ! Initialization - m2 = var%m2(:,:,iv) + end do - ! Global product - do il0=1,geom%nl0 - m2prod(il0) = zss_sum(m2_ini(:,il0)**2,mask=geom%gmask_c0a(:,il0)) - end do - call mpl%f_comm%allreduce(m2prod,fckit_mpi_sum()) + ! Release memory + deallocate(drhflt) + deallocate(dichotomy) + elseif (nam%var_npass>0) then + ! Allocation + allocate(ipass_min(geom%nl0,nam%nv)) + allocate(m2(geom%nc0a,geom%nl0,nam%nv)) - ! Save results - do il0=1,geom%nl0 - diff = m2prod(il0)-m2sqasy(il0) - diff_abs_min(il0) = abs(diff) - ipass_min(il0) = 0 - var%m2flt(:,il0,iv) = m2(:,il0) - end do + ! Initialize successive passes method + ipass_min = 0 + m2 = m2_ini + rhflt = nam%var_rhflt(1:geom%nl0,1:nam%nv) - ! Set unique smoother parameters - rhflt = nam%var_rhflt(1:geom%nl0,iv) - nicas_blk%ig = iv - call nicas_blk%compute_parameters(mpl,rng,nam,geom,rhflt) + do iv=1,nam%nv + ! Prepare NICAS filter + nicas_blk(iv)%ig = nam%group_index(iv) + nicas_blk(iv)%verbosity = .false. + call nicas_blk(iv)%compute_parameters(mpl,rng,nam,geom,rhflt(:,iv)) + end do + + do ipass=1,nam%var_npass + do iv=1,nam%nv + ! Filter variance + call nicas_blk(iv)%apply_filter(mpl,geom,m2(:,:,iv)) + end do - ! Apply smoother - do ipass=1,nam%var_npass - ! Apply smoother + ! Reset minimum value + do iv=1,nam%nv do il0=1,geom%nl0 - il0i = nicas_blk%l0_to_l0i(il0) - call nicas_blk%cmp(il0i)%apply_horizontal_smoother(mpl,geom,il0,m2(:,il0)) + if (mpl%msv%isanynot(var%m2(:,il0,iv))) m2(:,il0,iv) = max(m2(:,il0,iv),m2_min(il0,iv)) end do + end do - ! Global product + ! Global product + do iv=1,nam%nv do il0=1,geom%nl0 - m2prod(il0) = zss_sum(m2(:,il0)*m2_ini(:,il0),mask=geom%gmask_c0a(:,il0)) + m2prod(il0,iv) = zss_sum(m2(:,il0,iv)*m2_ini(:,il0,iv),mask=geom%gmask_c0a(:,il0)) end do - call mpl%f_comm%allreduce(m2prod,fckit_mpi_sum()) + end do + call mpl%f_comm%allreduce(m2prod,fckit_mpi_sum()) - ! Save results + ! Update filtered variance + do iv=1,nam%nv do il0=1,geom%nl0 - diff = m2prod(il0)-m2sqasy(il0) - if (abs(diff)zero) then - write(mpl%test,'(a16,a,i3,a,i2,a,f10.2,a,e12.5)') '','Level ',il0,': ',ipass_min(il0),' x ',rhflt(il0)*reqkm, & - & 'km, rel. diff. = ',(m2prod(il0)-m2sqasy(il0))/m2sqasy(il0) + if (m2sqasy(il0,iv)>zero) then + write(mpl%test,'(a16,a,i3,a,i2,a,f10.2,a,e12.5)') '','Level ',il0,': ',ipass_min(il0,iv),' x ',rhflt(il0,iv)*reqkm, & + & 'km, rel. diff. = ',(m2prod(il0,iv)-m2sqasy(il0,iv))/m2sqasy(il0,iv) call mpl%flush end if end do - end if - end do + end do + + ! Release memory + deallocate(ipass_min) + deallocate(m2) + end if + + ! Release memory + deallocate(diff_abs_min) + deallocate(m2_min) + deallocate(m2sq) + deallocate(m2sqasy) + deallocate(rhflt) + deallocate(m2prod) + deallocate(m2_ini) + deallocate(nicas_blk) end if ! Averaged value (initial / final) diff --git a/test/testdeps/process_perts_bump_nicas_1.txt b/test/testdeps/process_perts_bump_nicas_1.txt new file mode 100644 index 000000000..b43957c39 --- /dev/null +++ b/test/testdeps/process_perts_bump_nicas_1.txt @@ -0,0 +1 @@ +randomization_diffusion_2 diff --git a/test/testdeps/process_perts_bump_nicas_2.txt b/test/testdeps/process_perts_bump_nicas_2.txt new file mode 100644 index 000000000..adeff6853 --- /dev/null +++ b/test/testdeps/process_perts_bump_nicas_2.txt @@ -0,0 +1,2 @@ +randomization_diffusion_2 +process_perts_bump_nicas_1 diff --git a/test/testdeps/process_perts_bump_nicas_3.txt b/test/testdeps/process_perts_bump_nicas_3.txt new file mode 100644 index 000000000..b43957c39 --- /dev/null +++ b/test/testdeps/process_perts_bump_nicas_3.txt @@ -0,0 +1 @@ +randomization_diffusion_2 diff --git a/test/testinput/error_covariance_training_bump_stddev_1.yaml b/test/testinput/error_covariance_training_bump_stddev_1.yaml index 0496a82c1..697306216 100644 --- a/test/testinput/error_covariance_training_bump_stddev_1.yaml +++ b/test/testinput/error_covariance_training_bump_stddev_1.yaml @@ -6,12 +6,14 @@ geometry: groups: - variables: - air_horizontal_streamfunction + - air_horizontal_velocity_potential levels: 2 halo: 1 background: date: 2010-01-01T12:00:00Z state variables: - air_horizontal_streamfunction + - air_horizontal_velocity_potential background error: covariance model: SABER ensemble: @@ -21,6 +23,7 @@ background error: filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_%mem% state variables: - air_horizontal_streamfunction + - air_horizontal_velocity_potential pattern: '%mem%' nmembers: 20 zero padding: 6 @@ -51,6 +54,9 @@ background error: - variables: - air_horizontal_streamfunction value: 5000.0e3 + - variables: + - air_horizontal_velocity_potential + value: 4000.0e3 output model files: - parameter: stddev file: diff --git a/test/testinput/error_covariance_training_bump_stddev_2.yaml b/test/testinput/error_covariance_training_bump_stddev_2.yaml index 1964e0df6..735bb284c 100644 --- a/test/testinput/error_covariance_training_bump_stddev_2.yaml +++ b/test/testinput/error_covariance_training_bump_stddev_2.yaml @@ -6,12 +6,14 @@ geometry: groups: - variables: - air_horizontal_streamfunction + - air_horizontal_velocity_potential levels: 2 halo: 1 background: date: 2010-01-01T12:00:00Z state variables: - air_horizontal_streamfunction + - air_horizontal_velocity_potential background error: covariance model: SABER iterative ensemble loading: true @@ -22,6 +24,7 @@ background error: filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_%mem% state variables: - air_horizontal_streamfunction + - air_horizontal_velocity_potential pattern: '%mem%' nmembers: 20 zero padding: 6 @@ -44,14 +47,18 @@ background error: compute variance: true diagnostics: target ensemble size: 20 + nicas: + filter min effective resolution: 1.1 variance: objective filtering: true filtering passes: 3 - smoother min effective resolution: 1.2 initial length-scale: - variables: - air_horizontal_streamfunction value: 1000.0e3 + - variables: + - air_horizontal_velocity_potential + value: 1200.0e3 output model files: - parameter: stddev file: diff --git a/test/testinput/error_covariance_training_bump_stddev_4.yaml b/test/testinput/error_covariance_training_bump_stddev_4.yaml index a8db6d069..4a8178064 100644 --- a/test/testinput/error_covariance_training_bump_stddev_4.yaml +++ b/test/testinput/error_covariance_training_bump_stddev_4.yaml @@ -6,12 +6,14 @@ geometry: groups: - variables: - air_horizontal_streamfunction + - air_horizontal_velocity_potential levels: 2 halo: 1 background: date: 2010-01-01T12:00:00Z state variables: - air_horizontal_streamfunction + - air_horizontal_velocity_potential background error: covariance model: SABER iterative ensemble loading: true @@ -22,6 +24,7 @@ background error: filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_%mem% state variables: - air_horizontal_streamfunction + - air_horizontal_velocity_potential pattern: '%mem%' nmembers: 10 zero padding: 6 diff --git a/test/testinput/error_covariance_training_bump_stddev_5.yaml b/test/testinput/error_covariance_training_bump_stddev_5.yaml index 0982a0ecb..1cb0613db 100644 --- a/test/testinput/error_covariance_training_bump_stddev_5.yaml +++ b/test/testinput/error_covariance_training_bump_stddev_5.yaml @@ -6,12 +6,14 @@ geometry: groups: - variables: - air_horizontal_streamfunction + - air_horizontal_velocity_potential levels: 2 halo: 1 background: date: 2010-01-01T12:00:00Z state variables: - air_horizontal_streamfunction + - air_horizontal_velocity_potential background error: covariance model: SABER saber central block: @@ -33,6 +35,9 @@ background error: - variables: - air_horizontal_streamfunction value: 5000.0e3 + - variables: + - air_horizontal_velocity_potential + value: 4000.0e3 input model files: - parameter: var file: diff --git a/test/testinput/process_perts_bump_nicas_1.yaml b/test/testinput/process_perts_bump_nicas_1.yaml new file mode 100644 index 000000000..f4f3aee80 --- /dev/null +++ b/test/testinput/process_perts_bump_nicas_1.yaml @@ -0,0 +1,61 @@ +geometry: + function space: StructuredColumns + grid: + name: S10 + groups: + - variables: &vars + - air_horizontal_streamfunction + levels: &levels 10 + halo: 1 +background: + date: &date 2010-01-01T12:00:00Z + state variables: *vars +bands: +- band: + filter: + saber central block: + saber block name: BUMP_NICAS + calibration: + general: + testing: true + universe length-scale: 10000.0e3 + io: + data directory: testdata + files prefix: process_perts_bump_nicas_1/_MPI_-_OMP_ + drivers: + multivariate strategy: univariate + compute nicas: true + write local nicas: true + nicas: + filter mode: true + filter resolution: 4.0 + explicit length-scales: true + horizontal length-scale: + - groups: + - air_horizontal_streamfunction + value: 4000.0e3 + vertical length-scale: + - groups: + - air_horizontal_streamfunction + value: 3.0 + output: + model write: + filepath: testdata/process_perts_bump_nicas_1/filtered_pert_mb%MEM%_wb1 + member pattern: '%MEM%' +- band: + residual increment from previous bands: true + output: + model write: + filepath: testdata/process_perts_bump_nicas_1/filtered_pert_mb%MEM%_wb2 + member pattern: '%MEM%' +ensemble pert: + date: *date + members from template: + nmembers: 2 + pattern: '%MEM%' + template: + filepath: testdata/randomization_diffusion_2/1-1_member_pert_%MEM% + variables: *vars +input variables: *vars +test: + reference filename: testref/process_perts_bump_nicas_1.ref diff --git a/test/testinput/process_perts_bump_nicas_2.yaml b/test/testinput/process_perts_bump_nicas_2.yaml new file mode 100644 index 000000000..deb9192f9 --- /dev/null +++ b/test/testinput/process_perts_bump_nicas_2.yaml @@ -0,0 +1,49 @@ +geometry: + function space: StructuredColumns + grid: + name: S10 + groups: + - variables: &vars + - air_horizontal_streamfunction + levels: &levels 10 + halo: 1 +background: + date: &date 2010-01-01T12:00:00Z + state variables: *vars +bands: +- band: + filter: + saber central block: + saber block name: BUMP_NICAS + read: + general: + testing: true + universe length-scale: 10000.0e3 + io: + data directory: testdata + files prefix: process_perts_bump_nicas_2/_MPI_-_OMP_ + overriding nicas file: process_perts_bump_nicas_1/_MPI_-_OMP__nicas + drivers: + multivariate strategy: univariate + read local nicas: true + output: + model write: + filepath: testdata/process_perts_bump_nicas_2/filtered_pert_mb%MEM%_wb1 + member pattern: '%MEM%' +- band: + residual increment from previous bands: true + output: + model write: + filepath: testdata/process_perts_bump_nicas_2/filtered_pert_mb%MEM%_wb2 + member pattern: '%MEM%' +ensemble pert: + date: *date + members from template: + nmembers: 2 + pattern: '%MEM%' + template: + filepath: testdata/randomization_diffusion_2/1-1_member_pert_%MEM% + variables: *vars +input variables: *vars +test: + reference filename: testref/process_perts_bump_nicas_2.ref diff --git a/test/testinput/process_perts_bump_nicas_3.yaml b/test/testinput/process_perts_bump_nicas_3.yaml new file mode 100644 index 000000000..292401f9e --- /dev/null +++ b/test/testinput/process_perts_bump_nicas_3.yaml @@ -0,0 +1,58 @@ +geometry: + function space: StructuredColumns + grid: + name: S10 + groups: + - variables: &vars + - air_horizontal_streamfunction + levels: &levels 10 + halo: 1 +background: + date: &date 2010-01-01T12:00:00Z + state variables: *vars +bands: +- band: + filter: + saber central block: + saber block name: BUMP_NICAS + calibration: + general: + testing: true + universe length-scale: 10000.0e3 + io: + data directory: testdata + files prefix: process_perts_bump_nicas_3/_MPI_-_OMP_ + drivers: + multivariate strategy: univariate + compute nicas: true + write local nicas: true + nicas: + filter mode: true + filter resolution: 4.0 + explicit length-scales: true + horizontal length-scale: + - groups: + - air_horizontal_streamfunction + value: 4000.0e3 + same horizontal convolution: true + output: + model write: + filepath: testdata/process_perts_bump_nicas_3/filtered_pert_mb%MEM%_wb1 + member pattern: '%MEM%' +- band: + residual increment from previous bands: true + output: + model write: + filepath: testdata/process_perts_bump_nicas_3/filtered_pert_mb%MEM%_wb2 + member pattern: '%MEM%' +ensemble pert: + date: *date + members from template: + nmembers: 2 + pattern: '%MEM%' + template: + filepath: testdata/randomization_diffusion_2/1-1_member_pert_%MEM% + variables: *vars +input variables: *vars +test: + reference filename: testref/process_perts_bump_nicas_3.ref diff --git a/test/testlist/saber_test_tier1-bump.txt b/test/testlist/saber_test_tier1-bump.txt index 72e7f8e64..d2f5c2d71 100644 --- a/test/testlist/saber_test_tier1-bump.txt +++ b/test/testlist/saber_test_tier1-bump.txt @@ -69,6 +69,9 @@ error_covariance_training_bump_wind_1 error_covariance_training_bump_wind_2 error_covariance_training_stddev_1 error_covariance_training_stddev_2 +process_perts_bump_nicas_1 +process_perts_bump_nicas_2 +process_perts_bump_nicas_3 randomization_bump_nicas_L10L2 randomization_bump_nicas_L10L2T18 randomization_bump_nicas_L10L2_static diff --git a/test/testref/error_covariance_training_bump_stddev_1.ref b/test/testref/error_covariance_training_bump_stddev_1.ref index 2e0e06f88..df655bf6c 100644 --- a/test/testref/error_covariance_training_bump_stddev_1.ref +++ b/test/testref/error_covariance_training_bump_stddev_1.ref @@ -6,29 +6,53 @@ Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. Norm of air_horizontal_streamfunction: 0.34588449E+02 + Norm of air_horizontal_velocity_potential: 0.37486472E+02 Norm of air_horizontal_streamfunction: 0.38480279E+02 + Norm of air_horizontal_velocity_potential: 0.37219646E+02 Norm of air_horizontal_streamfunction: 0.40307232E+02 + Norm of air_horizontal_velocity_potential: 0.39780735E+02 Norm of air_horizontal_streamfunction: 0.36303975E+02 + Norm of air_horizontal_velocity_potential: 0.36149872E+02 Norm of air_horizontal_streamfunction: 0.41755387E+02 + Norm of air_horizontal_velocity_potential: 0.38000543E+02 Norm of air_horizontal_streamfunction: 0.39718819E+02 + Norm of air_horizontal_velocity_potential: 0.41164327E+02 Norm of air_horizontal_streamfunction: 0.36224969E+02 + Norm of air_horizontal_velocity_potential: 0.39790285E+02 Norm of air_horizontal_streamfunction: 0.37669628E+02 + Norm of air_horizontal_velocity_potential: 0.38307286E+02 Norm of air_horizontal_streamfunction: 0.39173419E+02 + Norm of air_horizontal_velocity_potential: 0.41255669E+02 Norm of air_horizontal_streamfunction: 0.42066923E+02 + Norm of air_horizontal_velocity_potential: 0.34634961E+02 Norm of air_horizontal_streamfunction: 0.36083988E+02 + Norm of air_horizontal_velocity_potential: 0.38721295E+02 Norm of air_horizontal_streamfunction: 0.38876060E+02 + Norm of air_horizontal_velocity_potential: 0.36934444E+02 Norm of air_horizontal_streamfunction: 0.41309295E+02 + Norm of air_horizontal_velocity_potential: 0.40330848E+02 Norm of air_horizontal_streamfunction: 0.36456482E+02 + Norm of air_horizontal_velocity_potential: 0.34103550E+02 Norm of air_horizontal_streamfunction: 0.38961976E+02 + Norm of air_horizontal_velocity_potential: 0.33724073E+02 Norm of air_horizontal_streamfunction: 0.34022314E+02 + Norm of air_horizontal_velocity_potential: 0.37799596E+02 Norm of air_horizontal_streamfunction: 0.38022274E+02 + Norm of air_horizontal_velocity_potential: 0.37289676E+02 Norm of air_horizontal_streamfunction: 0.38789543E+02 + Norm of air_horizontal_velocity_potential: 0.38923901E+02 Norm of air_horizontal_streamfunction: 0.40459495E+02 + Norm of air_horizontal_velocity_potential: 0.35849800E+02 Norm of air_horizontal_streamfunction: 0.38712001E+02 - Level 1: rhflt = 40000.00 km, rel. diff. = 0.31326E-02 - Level 2: rhflt = 40000.00 km, rel. diff. = 0.13881E-01 + Norm of air_horizontal_velocity_potential: 0.35723030E+02 + Level 1: rhflt = 12500.00 km, rel. diff. = -0.29703E-02 + Level 2: rhflt = 80000.00 km, rel. diff. = 0.23559E-01 + Level 1: rhflt = 6500.00 km, rel. diff. = -0.42795E-02 + Level 2: rhflt = 64000.00 km, rel. diff. = 0.22996E-01 Level 1 ~> 0.10260E+01 / 0.10260E+01 Level 2 ~> 0.10176E+01 / 0.10176E+01 -Norm of output parameter stddev - 1: 3.9461289082714671e+01 -Norm of output parameter var - 1: 4.1855368372594072e+01 -Norm of output parameter m4 - 1: 1.4109985229983997e+02 + Level 1 ~> 0.97964E+00 / 0.97964E+00 + Level 2 ~> 0.98589E+00 / 0.98589E+00 +Norm of output parameter stddev - 1: 5.5256078165539357e+01 +Norm of output parameter var - 1: 5.8156147066009666e+01 +Norm of output parameter m4 - 1: 1.8927948294822818e+02 diff --git a/test/testref/error_covariance_training_bump_stddev_2.ref b/test/testref/error_covariance_training_bump_stddev_2.ref index 340bf6401..2f5832915 100644 --- a/test/testref/error_covariance_training_bump_stddev_2.ref +++ b/test/testref/error_covariance_training_bump_stddev_2.ref @@ -5,8 +5,12 @@ Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. - Level 1: 3 x 1000.00km, rel. diff. = 0.10990E+00 - Level 2: 3 x 1000.00km, rel. diff. = 0.86137E-01 + Level 1: 3 x 1000.00km, rel. diff. = 0.10560E+00 + Level 2: 3 x 1000.00km, rel. diff. = 0.10524E+00 + Level 1: 3 x 1200.00km, rel. diff. = 0.98399E-01 + Level 2: 3 x 1200.00km, rel. diff. = 0.98369E-01 Level 1 ~> 0.10260E+01 / 0.10260E+01 Level 2 ~> 0.10176E+01 / 0.10176E+01 -Norm of output parameter stddev - 1: 3.9461289082714693e+01 + Level 1 ~> 0.97964E+00 / 0.97964E+00 + Level 2 ~> 0.98589E+00 / 0.98589E+00 +Norm of output parameter stddev - 1: 5.5271376756133215e+01 diff --git a/test/testref/error_covariance_training_bump_stddev_4.ref b/test/testref/error_covariance_training_bump_stddev_4.ref index a3a75abf2..cfa72cee7 100644 --- a/test/testref/error_covariance_training_bump_stddev_4.ref +++ b/test/testref/error_covariance_training_bump_stddev_4.ref @@ -5,4 +5,4 @@ Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of output parameter stddev - 1: 3.8981333255790027e+01 +Norm of output parameter stddev - 1: 5.4937700734311001e+01 diff --git a/test/testref/error_covariance_training_bump_stddev_5.ref b/test/testref/error_covariance_training_bump_stddev_5.ref index 34710e719..e04ca3ac2 100644 --- a/test/testref/error_covariance_training_bump_stddev_5.ref +++ b/test/testref/error_covariance_training_bump_stddev_5.ref @@ -5,10 +5,14 @@ Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. -Norm of input parameter var - 1: 4.1855368372594072e+01 -Norm of input parameter m4 - 1: 1.4109985229983997e+02 - Level 1: rhflt = 40000.00 km, rel. diff. = 0.31326E-02 - Level 2: rhflt = 40000.00 km, rel. diff. = 0.13881E-01 +Norm of input parameter var - 1: 5.8156147066009666e+01 +Norm of input parameter m4 - 1: 1.8927948294822818e+02 + Level 1: rhflt = 12500.00 km, rel. diff. = -0.29703E-02 + Level 2: rhflt = 80000.00 km, rel. diff. = 0.23559E-01 + Level 1: rhflt = 6500.00 km, rel. diff. = -0.42795E-02 + Level 2: rhflt = 64000.00 km, rel. diff. = 0.22996E-01 Level 1 ~> 0.10260E+01 / 0.10260E+01 Level 2 ~> 0.10176E+01 / 0.10176E+01 -Norm of output parameter stddev - 1: 3.9461289082714671e+01 + Level 1 ~> 0.97964E+00 / 0.97964E+00 + Level 2 ~> 0.98589E+00 / 0.98589E+00 +Norm of output parameter stddev - 1: 5.5256078165539357e+01 diff --git a/test/testref/process_perts_bump_nicas_1.ref b/test/testref/process_perts_bump_nicas_1.ref new file mode 100644 index 000000000..b2fb193d6 --- /dev/null +++ b/test/testref/process_perts_bump_nicas_1.ref @@ -0,0 +1,49 @@ + Independent levels: 1[10] + Subset Sc0 size: 800 + Domain area (% of Earth area): 0.100E+03% + Level 1 ~> 100.0% + Level 2 ~> 100.0% + Level 3 ~> 100.0% + Level 4 ~> 100.0% + Level 5 ~> 100.0% + Level 6 ~> 100.0% + Level 7 ~> 100.0% + Level 8 ~> 100.0% + Level 9 ~> 100.0% + Level 10 ~> 100.0% + Level 1 ~> 0.100E+01 vert. coord. + Level 2 ~> 0.200E+01 vert. coord. + Level 3 ~> 0.300E+01 vert. coord. + Level 4 ~> 0.400E+01 vert. coord. + Level 5 ~> 0.500E+01 vert. coord. + Level 6 ~> 0.600E+01 vert. coord. + Level 7 ~> 0.700E+01 vert. coord. + Level 8 ~> 0.800E+01 vert. coord. + Level 9 ~> 0.900E+01 vert. coord. + Level 10 ~> 0.100E+02 vert. coord. + Effective levels: 1 2 3 4 5 6 7 8 9 10 + Horizontal support radius: 4000.00 km ( 4000.00 km - 4000.00 km) + Estimated nc1 from horizontal support radius: 589 + Decimate full grid, at least 589 points required, 790 valid points found + Subgrid hash: -1358924416 + Final nc1: 589 + Effective horizontal resolution: 4.00 + nc1( 1) = 589 + nc1( 2) = 589 + nc1( 3) = 589 + nc1( 4) = 589 + nc1( 5) = 589 + nc1( 6) = 589 + nc1( 7) = 589 + nc1( 8) = 589 + nc1( 9) = 589 + nc1( 10) = 589 + ns = 5890 + v%n_s = 10 + c%n_s[global] = 207340 +Norm of perturbation: member 1: 2.6620275517839023e+01 +Norm of band perturbation: member 1: band 1: 1.0547425788178170e+01 +Norm of band perturbation: member 1: band 2: 2.1009053584793985e+01 +Norm of perturbation: member 2: 2.5901045342933084e+01 +Norm of band perturbation: member 2: band 1: 1.0950391918153596e+01 +Norm of band perturbation: member 2: band 2: 1.9913703810378877e+01 diff --git a/test/testref/process_perts_bump_nicas_2.ref b/test/testref/process_perts_bump_nicas_2.ref new file mode 100644 index 000000000..57b47aa92 --- /dev/null +++ b/test/testref/process_perts_bump_nicas_2.ref @@ -0,0 +1,29 @@ + Independent levels: 1[10] + Subset Sc0 size: 800 + Domain area (% of Earth area): 0.100E+03% + Level 1 ~> 100.0% + Level 2 ~> 100.0% + Level 3 ~> 100.0% + Level 4 ~> 100.0% + Level 5 ~> 100.0% + Level 6 ~> 100.0% + Level 7 ~> 100.0% + Level 8 ~> 100.0% + Level 9 ~> 100.0% + Level 10 ~> 100.0% + Level 1 ~> 0.100E+01 vert. coord. + Level 2 ~> 0.200E+01 vert. coord. + Level 3 ~> 0.300E+01 vert. coord. + Level 4 ~> 0.400E+01 vert. coord. + Level 5 ~> 0.500E+01 vert. coord. + Level 6 ~> 0.600E+01 vert. coord. + Level 7 ~> 0.700E+01 vert. coord. + Level 8 ~> 0.800E+01 vert. coord. + Level 9 ~> 0.900E+01 vert. coord. + Level 10 ~> 0.100E+02 vert. coord. +Norm of perturbation: member 1: 2.6620275517839023e+01 +Norm of band perturbation: member 1: band 1: 1.0547425788178170e+01 +Norm of band perturbation: member 1: band 2: 2.1009053584793985e+01 +Norm of perturbation: member 2: 2.5901045342933084e+01 +Norm of band perturbation: member 2: band 1: 1.0950391918153596e+01 +Norm of band perturbation: member 2: band 2: 1.9913703810378877e+01 diff --git a/test/testref/process_perts_bump_nicas_3.ref b/test/testref/process_perts_bump_nicas_3.ref new file mode 100644 index 000000000..15c840ffe --- /dev/null +++ b/test/testref/process_perts_bump_nicas_3.ref @@ -0,0 +1,40 @@ + Independent levels: 1[10] + Subset Sc0 size: 800 + Domain area (% of Earth area): 0.100E+03% + Level 1 ~> 100.0% + Level 2 ~> 100.0% + Level 3 ~> 100.0% + Level 4 ~> 100.0% + Level 5 ~> 100.0% + Level 6 ~> 100.0% + Level 7 ~> 100.0% + Level 8 ~> 100.0% + Level 9 ~> 100.0% + Level 10 ~> 100.0% + Level 1 ~> 0.100E+01 vert. coord. + Level 2 ~> 0.200E+01 vert. coord. + Level 3 ~> 0.300E+01 vert. coord. + Level 4 ~> 0.400E+01 vert. coord. + Level 5 ~> 0.500E+01 vert. coord. + Level 6 ~> 0.600E+01 vert. coord. + Level 7 ~> 0.700E+01 vert. coord. + Level 8 ~> 0.800E+01 vert. coord. + Level 9 ~> 0.900E+01 vert. coord. + Level 10 ~> 0.100E+02 vert. coord. + Effective levels: 1 + Horizontal support radius: 4000.00 km ( 4000.00 km - 4000.00 km) + Estimated nc1 from horizontal support radius: 589 + Decimate full grid, at least 589 points required, 790 valid points found + Subgrid hash: -1358924416 + Final nc1: 589 + Effective horizontal resolution: 4.00 + nc1( 1) = 589 + ns = 589 + v%n_s = 1 + c%n_s[global] = 7405 +Norm of perturbation: member 1: 2.6620275517839023e+01 +Norm of band perturbation: member 1: band 1: 1.2499346409334429e+01 +Norm of band perturbation: member 1: band 2: 2.0091601768023054e+01 +Norm of perturbation: member 2: 2.5901045342933084e+01 +Norm of band perturbation: member 2: band 1: 1.2737645373666396e+01 +Norm of band perturbation: member 2: band 2: 1.9002522754871798e+01 From 9d8e74b43779d1bf39f33e7b84f3b7a7ea29757a Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Mon, 15 Dec 2025 21:41:56 +0100 Subject: [PATCH 141/199] [Bugfix] Variance filtering initialization (#1161) * Variance filtering initialization bugfix * Remove blank line --- src/saber/bump/type_var.fypp | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/saber/bump/type_var.fypp b/src/saber/bump/type_var.fypp index 5536cba93..5664b8681 100644 --- a/src/saber/bump/type_var.fypp +++ b/src/saber/bump/type_var.fypp @@ -610,14 +610,8 @@ else deallocate(m4) end if - ! Initial values without filtering + ! Initial m2 m2_ini = var%m2 - do iv=1,nam%nv - do il0=1,geom%nl0 - diff = m2prod(il0,iv)-m2sqasy(il0,iv) - diff_abs_min(il0,iv) = abs(diff) - end do - end do var%m2flt = m2_ini ! Initial global product @@ -628,6 +622,14 @@ else end do call mpl%f_comm%allreduce(m2prod,fckit_mpi_sum()) + ! Initial values without filtering + do iv=1,nam%nv + do il0=1,geom%nl0 + diff = m2prod(il0,iv)-m2sqasy(il0,iv) + diff_abs_min(il0,iv) = abs(diff) + end do + end do + if (nam%var_niter>0) then ! Allocation allocate(drhflt(geom%nl0,nam%nv)) From 5d3eaaa03b3459b0c98be66a50d4259d46cedee6 Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Thu, 18 Dec 2025 21:36:53 +0100 Subject: [PATCH 142/199] Remove the dual resolution arguments (#1158) * Update yaml and refs for consistency * New code done, before big cleaning * BUMP working * Remove dual res from SABER * Fix last merge with develop --- src/saber/blocks/SaberBlockChainBase.h | 16 +- src/saber/blocks/SaberCentralBlockBase.h | 5 - src/saber/blocks/SaberEnsembleBlockChain.h | 8 - src/saber/blocks/SaberOuterBlockBase.h | 5 - src/saber/blocks/SaberParametricBlockChain.h | 54 +- src/saber/bump/BUMP.cc | 151 +-- src/saber/bump/BUMP.h | 8 +- src/saber/bump/BUMPParameters.h | 38 +- src/saber/bump/NICAS.cc | 9 - src/saber/bump/NICAS.h | 2 - src/saber/bump/subr_list.fypp | 8 +- src/saber/bump/type_avg.fypp | 456 ++++++- src/saber/bump/type_avg_blk.fypp | 12 +- src/saber/bump/type_bump.fypp | 1051 +++++++---------- src/saber/bump/type_bump.h | 7 +- src/saber/bump/type_bump_interface.F90 | 44 +- src/saber/bump/type_bump_parameters.cc | 36 +- src/saber/bump/type_bump_parameters.h | 52 +- src/saber/bump/type_diag.fypp | 84 +- src/saber/bump/type_diag_blk.fypp | 92 +- src/saber/bump/type_hdiag.fypp | 212 ++-- src/saber/bump/type_mom.fypp | 106 +- src/saber/bump/type_nam.fypp | 101 +- src/saber/bump/type_nicas.fypp | 12 +- src/saber/bump/type_var.fypp | 14 +- src/saber/bump/type_vbal.fypp | 4 +- src/saber/bump/type_vbal_blk.fypp | 30 +- src/saber/gsi/GSIBlockChain.h | 4 - src/saber/oops/ErrorCovariance.h | 46 - src/saber/oops/ErrorCovarianceParameters.h | 20 - src/saber/oops/Localization.h | 4 +- src/saber/oops/ProcessPerts.h | 10 +- test/fctest/fctest_nicas_sqrt.F90 | 6 +- ...covariance_training_bump_hdiag-nicas_3.txt | 1 - ...ovariance_training_bump_hdiag-nicas_3.yaml | 97 -- ...rror_covariance_training_bump_hdiag_2.yaml | 2 +- ...rror_covariance_training_bump_hdiag_5.yaml | 230 ++-- ...rror_covariance_training_bump_hdiag_6.yaml | 149 +-- ...rror_covariance_training_bump_hdiag_7.yaml | 40 +- ...rror_covariance_training_bump_hdiag_8.yaml | 34 +- ...rror_covariance_training_bump_hdiag_9.yaml | 34 +- test/testlist/saber_test_tier1-bump.txt | 1 - ...covariance_training_bump_hdiag-nicas_3.ref | 156 --- ...error_covariance_training_bump_hdiag_5.ref | 138 +-- ...error_covariance_training_bump_hdiag_6.ref | 96 +- ...error_covariance_training_bump_hdiag_7.ref | 52 +- ...error_covariance_training_bump_hdiag_8.ref | 66 +- ...error_covariance_training_bump_hdiag_9.ref | 68 +- 48 files changed, 1445 insertions(+), 2426 deletions(-) delete mode 100644 test/testdeps/error_covariance_training_bump_hdiag-nicas_3.txt delete mode 100644 test/testinput/error_covariance_training_bump_hdiag-nicas_3.yaml delete mode 100644 test/testref/error_covariance_training_bump_hdiag-nicas_3.ref diff --git a/src/saber/blocks/SaberBlockChainBase.h b/src/saber/blocks/SaberBlockChainBase.h index de9da6351..49e25a87b 100644 --- a/src/saber/blocks/SaberBlockChainBase.h +++ b/src/saber/blocks/SaberBlockChainBase.h @@ -53,13 +53,11 @@ class SaberBlockChainFactory { typedef oops::Geometry Geometry_; static std::unique_ptr create(const std::string &, - const Geometry_ &, const Geometry_ &, const oops::Variables &, oops::FieldSet4D &, oops::FieldSet4D &, oops::FieldSets &, - oops::FieldSets &, const eckit::LocalConfiguration &, const eckit::Configuration &); @@ -70,12 +68,10 @@ class SaberBlockChainFactory { private: virtual std::unique_ptr make(const Geometry_ &, - const Geometry_ &, const oops::Variables &, oops::FieldSet4D &, oops::FieldSet4D &, oops::FieldSets &, - oops::FieldSets &, const eckit::LocalConfiguration &, const eckit::Configuration &) = 0; @@ -92,16 +88,14 @@ class SaberBlockChainMaker : public SaberBlockChainFactory { typedef oops::Geometry Geometry_; std::unique_ptr make(const Geometry_ & geom, - const Geometry_ & dualResGeom, const oops::Variables & outerVars, oops::FieldSet4D & fset4dXb, oops::FieldSet4D & fset4dFg, oops::FieldSets & fsetEns, - oops::FieldSets & fsetDualResEns, const eckit::LocalConfiguration & covarConf, const eckit::Configuration & conf) override { - return std::make_unique(geom, dualResGeom, outerVars, fset4dXb, fset4dFg, - fsetEns, fsetDualResEns, covarConf, conf); + return std::make_unique(geom, outerVars, fset4dXb, fset4dFg, + fsetEns, covarConf, conf); } public: @@ -122,12 +116,10 @@ template std::unique_ptr SaberBlockChainFactory::create(const std::string & name, const Geometry_ & geom, - const Geometry_ & dualResGeom, const oops::Variables & outerVars, oops::FieldSet4D & fset4dXb, oops::FieldSet4D & fset4dFg, oops::FieldSets & fsetEns, - oops::FieldSets & fsetDualResEns, const eckit::LocalConfiguration & covarConf, const eckit::Configuration & conf) { oops::Log::trace() << "SaberBlockChainFactory::create starting" << std::endl; @@ -140,8 +132,8 @@ SaberBlockChainFactory::create(const std::string & name, "Possible values:" + makerNameList, Here()); } std::unique_ptr ptr = - jbc->second->make(geom, dualResGeom, outerVars, fset4dXb, fset4dFg, - fsetEns, fsetDualResEns, covarConf, conf); + jbc->second->make(geom, outerVars, fset4dXb, fset4dFg, + fsetEns, covarConf, conf); oops::Log::trace() << "SaberBlockChainFactory::create done" << std::endl; return ptr; } diff --git a/src/saber/blocks/SaberCentralBlockBase.h b/src/saber/blocks/SaberCentralBlockBase.h index c97e74d7d..eeb0dde3f 100644 --- a/src/saber/blocks/SaberCentralBlockBase.h +++ b/src/saber/blocks/SaberCentralBlockBase.h @@ -91,11 +91,6 @@ class SaberCentralBlockBase : public util::Printable, {throw eckit::NotImplemented("iterativeCalibrationUpdate not implemented yet for the block " + this->blockName(), Here());} - // Dual resolution setup - virtual void dualResolutionSetup(const oops::GeometryData &) - {throw eckit::NotImplemented("dualResolutionSetup not implemented yet for the block " - + this->blockName(), Here());} - // Write block data virtual void write() const {} diff --git a/src/saber/blocks/SaberEnsembleBlockChain.h b/src/saber/blocks/SaberEnsembleBlockChain.h index c0332801e..d23d9dceb 100644 --- a/src/saber/blocks/SaberEnsembleBlockChain.h +++ b/src/saber/blocks/SaberEnsembleBlockChain.h @@ -37,12 +37,10 @@ class SaberEnsembleBlockChain : public SaberBlockChainBase { public: template SaberEnsembleBlockChain(const oops::Geometry & geom, - const oops::Geometry & dualResGeom, const oops::Variables & outerVars, oops::FieldSet4D & fset4dXb, oops::FieldSet4D & fset4dFg, oops::FieldSets & fsetEns, - oops::FieldSets & fsetDualResEns, const eckit::LocalConfiguration & covarConf, const eckit::Configuration & conf); ~SaberEnsembleBlockChain() = default; @@ -86,16 +84,12 @@ class SaberEnsembleBlockChain : public SaberBlockChainBase { template SaberEnsembleBlockChain::SaberEnsembleBlockChain(const oops::Geometry & geom, - const oops::Geometry & dualResGeom, const oops::Variables & outerVars, oops::FieldSet4D & fset4dXb, oops::FieldSet4D & fset4dFg, // TODO(AS): remove as argument: this should be read inside the // block. oops::FieldSets & fsetEns, - // TODO(AS): remove as argument: this is currently not used (and - // when used should be read inside the block. - oops::FieldSets & fsetDualResEns, const eckit::LocalConfiguration & covarConf, const eckit::Configuration & conf) : outerFunctionSpace_(geom.functionSpace()), outerVariables_(outerVars), @@ -284,12 +278,10 @@ SaberEnsembleBlockChain::SaberEnsembleBlockChain(const oops::Geometry & g "functionSpaces, building localization with standard " "constructor" << std::endl; locBlockChain_ = std::make_unique(geom, - dualResGeom, currentOuterVars, fset4dXb, fset4dFg, ensemble_, - fsetDualResEns, covarConfUpdated, *locConf); } diff --git a/src/saber/blocks/SaberOuterBlockBase.h b/src/saber/blocks/SaberOuterBlockBase.h index 6c627fcff..a5330b2ba 100644 --- a/src/saber/blocks/SaberOuterBlockBase.h +++ b/src/saber/blocks/SaberOuterBlockBase.h @@ -105,11 +105,6 @@ class SaberOuterBlockBase : public util::Printable, {throw eckit::NotImplemented("iterativeCalibrationUpdate not implemented yet for the block " + this->blockName(), Here());} - // Dual resolution setup - virtual void dualResolutionSetup(const oops::GeometryData &) - {throw eckit::NotImplemented("dualResolutionSetup not implemented yet for the block " - + this->blockName(), Here());} - // Write block data virtual void write() const {} diff --git a/src/saber/blocks/SaberParametricBlockChain.h b/src/saber/blocks/SaberParametricBlockChain.h index 9b12c7512..de29bcdd7 100644 --- a/src/saber/blocks/SaberParametricBlockChain.h +++ b/src/saber/blocks/SaberParametricBlockChain.h @@ -37,12 +37,10 @@ class SaberParametricBlockChain : public SaberBlockChainBase { /// @brief Standard constructor using MODEL geometry template SaberParametricBlockChain(const oops::Geometry & geom, - const oops::Geometry & dualResGeom, const oops::Variables & outerVars, oops::FieldSet4D & fset4dXb, oops::FieldSet4D & fset4dFg, oops::FieldSets & fsetEns, - oops::FieldSets & fsetDualResEns, const eckit::LocalConfiguration & covarConf, const eckit::Configuration & conf); /// @brief Simpler, limited constructor using only generic GeometryData @@ -107,14 +105,12 @@ class SaberParametricBlockChain : public SaberBlockChainBase { template SaberParametricBlockChain::SaberParametricBlockChain(const oops::Geometry & geom, - const oops::Geometry & dualResGeom, const oops::Variables & outerVars, oops::FieldSet4D & fset4dXb, oops::FieldSet4D & fset4dFg, // TODO(AS): read inside the block so there is no need to pass // as non-const oops::FieldSets & fsetEns, - oops::FieldSets & fsetDualResEns, const eckit::LocalConfiguration & covarConf, const eckit::Configuration & conf) : outerFunctionSpace_(geom.functionSpace()), outerVariables_(outerVars), @@ -215,61 +211,13 @@ SaberParametricBlockChain::SaberParametricBlockChain(const oops::Geometry centralBlock_->read(); } - if (saberCentralBlockParams.forceWrite.value()) { + if (saberCentralBlockParams.forceWrite.value() || saberCentralBlockParams.doCalibration()) { // Write data oops::Log::info() << "Info : Write data" << std::endl; centralBlock_->write(geom); centralBlock_->write(); } - // Dual resolution ensemble - if (covarConf.has("dual resolution ensemble configuration")) { - oops::Log::info() << "Info : Dual resolution setup" << std::endl; - - // Dual resolution setup - centralBlock_->dualResolutionSetup(dualResGeom.generic()); - - // Ensemble configuration - eckit::LocalConfiguration dualResEnsembleConf - = covarConf.getSubConfiguration("dual resolution ensemble configuration"); - - if (iterativeEnsembleLoading) { - // Iterative calibration - oops::Log::info() << "Info : Iterative calibration" << std::endl; - - // Initialization - centralBlock_->iterativeCalibrationInit(); - - // Get dual resolution ensemble size - const size_t dualResNens = dualResEnsembleConf.getInt("ensemble size"); - - for (size_t ie = 0; ie < dualResNens; ++ie) { - // Read ensemble member - oops::FieldSet3D fset(fset4dXb[0].validTime(), dualResGeom.getComm()); - readEnsembleMember(dualResGeom, outerVariables_, dualResEnsembleConf, ie, fset); - - // Use FieldSet in the central block - oops::Log::info() << "Info : Use FieldSet in the central block" << std::endl; - centralBlock_->iterativeCalibrationUpdate(fset); - } - - // Finalization - oops::Log::info() << "Info : Finalization" << std::endl; - centralBlock_->iterativeCalibrationFinal(); - } else { - // Direct calibration - oops::Log::info() << "Info : Direct calibration" << std::endl; - centralBlock_->directCalibration(fsetDualResEns); - } - } - - // Write calibration data - if (saberCentralBlockParams.doCalibration()) { - oops::Log::info() << "Info : Write calibration data" << std::endl; - centralBlock_->write(geom); - centralBlock_->write(); - } - // Write final ensemble if (covarConf.has("output ensemble")) { // Get output parameters configuration diff --git a/src/saber/bump/BUMP.cc b/src/saber/bump/BUMP.cc index abb767831..a20fb1783 100644 --- a/src/saber/bump/BUMP.cc +++ b/src/saber/bump/BUMP.cc @@ -40,8 +40,7 @@ BUMP::BUMP(const oops::GeometryData & geometryData, const oops::FieldSet3D & xb) : keyBUMP_(), comm_(geometryData.comm()), fspace_(geometryData.functionSpace()), vars_(vars), validTime_(xb.validTime()), covarConf_(covarConf), bumpConf_(params.toConfiguration()), - nens_(), waitForDualResolution_(false), gridUid_(util::getGridUid(geometryData.functionSpace())), - dualResolutionGridUid_("") { + nens_(), gridUid_(util::getGridUid(geometryData.functionSpace())) { oops::Log::trace() << classname() << "::BUMP starting" << std::endl; // Get number of MPI tasks and OpenMP threads @@ -60,33 +59,21 @@ BUMP::BUMP(const oops::GeometryData & geometryData, oops::Log::info() << "Info : +++ OpenMP threads: " << omp << std::endl; // Initialization - nens_.reserve(2); - nens_[0] = 0; + nens_ = 0; if (covarConf_.has("ensemble configuration")) { - nens_[0] = covarConf_.getSubConfiguration("ensemble configuration").getInt("ensemble size"); - } - nens_[1] = 0; - if (covarConf_.has("dual resolution ensemble configuration")) { - nens_[1] = covarConf_.getSubConfiguration("dual resolution ensemble configuration") - .getInt("ensemble size"); - waitForDualResolution_ = true; + nens_ = covarConf_.getSubConfiguration("ensemble configuration").getInt("ensemble size"); } iterativeEnsembleLoading_ = covarConf_.getBool("iterative ensemble loading", false); // Case where size are specified in the BUMP configuration // TODO(Benjamin): when is this necessary? - if ((nens_[0] == 0) && bumpConf_.has("ensemble sizes.total ensemble size")) { - // Ensemble 1 size from configuration - nens_[0] = bumpConf_.getInt("ensemble sizes.total ensemble size"); - } - if ((nens_[1] == 0) && bumpConf_.has("ensemble sizes.total lowres ensemble size")) { - // Ensemble 1 size from configuration - nens_[1] = bumpConf_.getInt("ensemble sizes.total lowres ensemble size"); + if ((nens_ == 0) && bumpConf_.has("ensemble sizes.total ensemble size")) { + // Ensemble size from configuration + nens_ = bumpConf_.getInt("ensemble sizes.total ensemble size"); } // Update ensemble sizes - bumpConf_.set("ensemble sizes.total ensemble size", nens_[0]); - bumpConf_.set("ensemble sizes.total lowres ensemble size", nens_[1]); + bumpConf_.set("ensemble sizes.total ensemble size", nens_); // Set iterative ensemble loading flag bumpConf_.set("external.iterative algorithm", iterativeEnsembleLoading_); @@ -400,19 +387,9 @@ void BUMP::addEnsemble(const oops::FieldSets & fsetEns) { // Initialize ensemble index size_t ie = 0; for (size_t jj = 0; jj < fsetEns.ens_size(); ++jj) { - // Get geometry index (iterative update should be done after for the dual resolution part) - // and check grid UID - size_t igeom; - if (dualResolutionGridUid_ == "") { - igeom = 0; - if (fsetEns[jj].getGridUid() != gridUid_) { - throw eckit::Exception("BUMP::addEnsemble: wrong grid UID", Here()); - } - } else { - igeom = 1; - if (fsetEns[jj].getGridUid() != dualResolutionGridUid_) { - throw eckit::Exception("BUMP::addEnsemble: wrong dual resolution grid UID", Here()); - } + // Get geometry index and check grid UID + if (fsetEns[jj].getGridUid() != gridUid_) { + throw eckit::Exception("BUMP::addEnsemble: wrong grid UID", Here()); } for (size_t jgrid = 0; jgrid < keyBUMP_.size(); ++jgrid) { @@ -421,13 +398,12 @@ void BUMP::addEnsemble(const oops::FieldSets & fsetEns) { oops::Log::info() << "Info :" << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" << std::endl; - oops::Log::info() << "Info : +++ Add members of ensemble " << (igeom+1) << std::endl; + oops::Log::info() << "Info : +++ Add ensemble members" << std::endl; } // Add member - oops::Log::info() << "Info : Member " << ie+1 << " / " << nens_[igeom] - << std::endl; - bump_add_member_f90(keyBUMP_[jgrid], fsetEns[jj].fieldSet().get(), ie+1, igeom+1); + oops::Log::info() << "Info : Member " << ie+1 << std::endl; + bump_add_member_f90(keyBUMP_[jgrid], fsetEns[jj].fieldSet().get(), ie+1); } // Update member index @@ -439,79 +415,48 @@ void BUMP::addEnsemble(const oops::FieldSets & fsetEns) { // ----------------------------------------------------------------------------- -void BUMP::dualResolutionSetup(const atlas::FunctionSpace & fspace, - const atlas::FieldSet & fields) { - oops::Log::trace() << classname() << "::dualResolutionSetup starting" << std::endl; - - // Set dual resolution grid UID - dualResolutionGridUid_ = util::getGridUid(fspace); - - // Dual resolution setup - for (size_t jgrid = 0; jgrid < keyBUMP_.size(); ++jgrid) { - bump_dual_resolution_setup_f90(keyBUMP_[jgrid], fspace.get(), fields.get()); - } - - oops::Log::trace() << classname() << "::dualResolutionSetup done" << std::endl; -} - -// ----------------------------------------------------------------------------- - void BUMP::iterativeUpdate(const oops::FieldSet3D & fset, const size_t & ie) { oops::Log::trace() << classname() << "::iterativeUpdate starting" << std::endl; - // Get geometry index (iterative update should be done after for the dual resolution part) - // and check grid UID - size_t igeom; - if (dualResolutionGridUid_ == "") { - igeom = 0; - if (fset.getGridUid() != gridUid_) { - throw eckit::Exception("BUMP::iterativeUpdate: wrong grid UID", Here()); - } - } else { - igeom = 1; - if (fset.getGridUid() != dualResolutionGridUid_) { - throw eckit::Exception("BUMP::iterativeUpdate: wrong dual resolution grid UID", Here()); - } + // Get geometry index and check grid UID + if (fset.getGridUid() != gridUid_) { + throw eckit::Exception("BUMP::iterativeUpdate: wrong grid UID", Here()); } // Print info oops::Log::info() << "Info :" << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" << std::endl; - oops::Log::info() << "Info : +++ Load member " << ie+1 << " / " << nens_[igeom] << std::endl; + oops::Log::info() << "Info : +++ Load member " << ie+1 << std::endl; // Get driver keys bool new_vbal_cov = bumpConf_.getBool("drivers.compute vertical covariance", false); bool new_var = bumpConf_.getBool("drivers.compute variance", false); bool new_mom = bumpConf_.getBool("drivers.compute moments", false); for (size_t jgrid = 0; jgrid < keyBUMP_.size(); ++jgrid) { - if (igeom == 0) { - if (new_vbal_cov) { - // Update vertical covariance - bump_update_vbal_cov_f90(keyBUMP_[jgrid], fset.get(), ie+1); - } - if (new_var) { - // Update variance - bump_update_var_f90(keyBUMP_[jgrid], fset.get(), ie+1); - } + if (new_vbal_cov) { + // Update vertical covariance + bump_update_vbal_cov_f90(keyBUMP_[jgrid], fset.get(), ie+1); + } + if (new_var) { + // Update variance + bump_update_var_f90(keyBUMP_[jgrid], fset.get(), ie+1); } if (new_mom) { // Update moments - bump_update_mom_f90(keyBUMP_[jgrid], fset.get(), ie+1, igeom+1); + bump_update_mom_f90(keyBUMP_[jgrid], fset.get(), ie+1); } } // Print info - if (ie+1 == nens_[igeom]) { - oops::Log::info() << "Info :" - << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" - << std::endl; - oops::Log::info() << "Info : +++ End of iterative update" << std::endl; - oops::Log::info() << "Info :" - << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" - << std::endl; - } + oops::Log::info() << "Info :" + << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + << std::endl; + oops::Log::info() << "Info : +++ End of iterative update" << std::endl; + oops::Log::info() << "Info :" + << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + << std::endl; oops::Log::trace() << classname() << "::iterativeUpdate done" << std::endl; } @@ -583,26 +528,22 @@ std::vector> BUMP::fields void BUMP::runDrivers() { oops::Log::trace() << classname() << "::runDrivers starting" << std::endl; - if (waitForDualResolution_) { - waitForDualResolution_ = false; - } else { - for (size_t jgrid = 0; jgrid < keyBUMP_.size(); ++jgrid) { - oops::Log::info() << "Info :" - << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" - << std::endl; - oops::Log::info() << "Info : +++ Run drivers for BUMP instance " << (jgrid+1) - << " / " << keyBUMP_.size() << std::endl; - bump_run_drivers_f90(keyBUMP_[jgrid]); - bump_partial_dealloc_f90(keyBUMP_[jgrid]); - } - oops::Log::info() << "Info :" - << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" - << std::endl; - oops::Log::info() << "Info : +++ End of BUMP drivers" << std::endl; + for (size_t jgrid = 0; jgrid < keyBUMP_.size(); ++jgrid) { oops::Log::info() << "Info :" - << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" - << std::endl; + << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + << std::endl; + oops::Log::info() << "Info : +++ Run drivers for BUMP instance " << (jgrid+1) + << " / " << keyBUMP_.size() << std::endl; + bump_run_drivers_f90(keyBUMP_[jgrid]); + bump_partial_dealloc_f90(keyBUMP_[jgrid]); } + oops::Log::info() << "Info :" + << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + << std::endl; + oops::Log::info() << "Info : +++ End of BUMP drivers" << std::endl; + oops::Log::info() << "Info :" + << " +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++" + << std::endl; oops::Log::trace() << classname() << "::runDrivers done" << std::endl; } diff --git a/src/saber/bump/BUMP.h b/src/saber/bump/BUMP.h index ac2bd91c7..97842506a 100644 --- a/src/saber/bump/BUMP.h +++ b/src/saber/bump/BUMP.h @@ -56,10 +56,6 @@ class BUMP { // Add ensemble void addEnsemble(const oops::FieldSets &); - // Dual resolution setup - void dualResolutionSetup(const atlas::FunctionSpace &, - const atlas::FieldSet &); - // Iterative update void iterativeUpdate(const oops::FieldSet3D &, const size_t &); @@ -94,11 +90,9 @@ class BUMP { const util::DateTime validTime_; eckit::LocalConfiguration covarConf_; eckit::LocalConfiguration bumpConf_; - std::vector nens_; + size_t nens_; bool iterativeEnsembleLoading_; - bool waitForDualResolution_; std::string gridUid_; - std::string dualResolutionGridUid_; eckit::LocalConfiguration getFileConf(const eckit::mpi::Comm &, const eckit::Configuration &) const; diff --git a/src/saber/bump/BUMPParameters.h b/src/saber/bump/BUMPParameters.h index 69fcbedf8..322da4e91 100644 --- a/src/saber/bump/BUMPParameters.h +++ b/src/saber/bump/BUMPParameters.h @@ -225,8 +225,8 @@ class IOSection : public oops::Parameters { oops::Parameter fname_vbal = param(def.fname_vbal, this); // Ensemble 1 moments files oops::Parameter> fname_mom{"overriding moments file", {}, this}; - // Ensemble 2 moments files - oops::Parameter> fname_mom2{"overriding lowres moments file", {}, this}; + // Averaged statistics file + oops::Parameter fname_avg = param(def.fname_avg, this); // Universe radius file oops::Parameter fname_universe_radius = param(def.fname_universe_radius, this); // NICAS file @@ -249,18 +249,12 @@ class DriversSection : public oops::Parameters { DriversDef def; public: - // Compute covariance, ensemble 1 - oops::Parameter compute_cov1 = param(def.compute_cov1, this); - // Compute covariance, ensemble 2 - oops::Parameter compute_cov2 = param(def.compute_cov2, this); - // Compute correlation, ensemble 1 - oops::Parameter compute_cor1 = param(def.compute_cor1, this); - // Compute correlation, ensemble 2 - oops::Parameter compute_cor2 = param(def.compute_cor2, this); - // Compute localization, ensemble 1 - oops::Parameter compute_loc1 = param(def.compute_loc1, this); - // Compute localization, ensemble 2 - oops::Parameter compute_loc2 = param(def.compute_loc2, this); + // Compute covariance + oops::Parameter compute_cov = param(def.compute_cov, this); + // Compute correlation + oops::Parameter compute_cor = param(def.compute_cor, this); + // Compute localization + oops::Parameter compute_loc = param(def.compute_loc, this); // Compute hybrid weights oops::Parameter compute_hyb = param(def.compute_hyb, this); // Hybrid term source ('randomized static' or 'lowres ensemble') @@ -299,6 +293,8 @@ class DriversSection : public oops::Parameters { oops::Parameter load_mom = param(def.load_mom, this); // Write sampling moments oops::Parameter write_mom = param(def.write_mom, this); + // Write averaged statistics + oops::Parameter write_avg = param(def.write_avg, this); // Write HDIAG diagnostics oops::Parameter write_hdiag = param(def.write_hdiag, this); // Write HDIAG components detail @@ -381,14 +377,10 @@ class EnsembleSizesSection : public oops::Parameters { EnsembleSizesDef def; public: - // Ensemble 1 size - oops::Parameter ens1_ne = param(def.ens1_ne, this); - // Ensemble 1 sub-ensembles number - oops::Parameter ens1_nsub = param(def.ens1_nsub, this); - // Ensemble 2 size - oops::Parameter ens2_ne = param(def.ens2_ne, this); - // Ensemble 2 sub-ensembles number - oops::Parameter ens2_nsub = param(def.ens2_nsub, this); + // Ensemble size + oops::Parameter ens_ne = param(def.ens_ne, this); + // Ensemble sub-ensembles number + oops::Parameter ens_nsub = param(def.ens_nsub, this); }; // ----------------------------------------------------------------------------- @@ -462,8 +454,6 @@ class DiagnosticsSection : public oops::Parameters { public: // Ensemble size oops::Parameter ne = param(def.ne, this); - // Ensemble size of the hybrid term - oops::Parameter ne_lr = param(def.ne_lr, this); // Gaussian approximation for asymptotic quantities oops::Parameter gau_approx = param(def.gau_approx, this); // Localization option ('default', 'from_squared_correlation', 'nice_with_table' and diff --git a/src/saber/bump/NICAS.cc b/src/saber/bump/NICAS.cc index 53dea24df..d81b60f3f 100644 --- a/src/saber/bump/NICAS.cc +++ b/src/saber/bump/NICAS.cc @@ -141,15 +141,6 @@ void NICAS::iterativeCalibrationFinal() { // ----------------------------------------------------------------------------- -void NICAS::dualResolutionSetup(const oops::GeometryData & geometryData) { - oops::Log::trace() << classname() << "::dualResolutionSetup starting" << std::endl; - bump_->dualResolutionSetup(geometryData.functionSpace(), - geometryData.fieldSet()); - oops::Log::trace() << classname() << "::dualResolutionSetup done" << std::endl; -} - -// ----------------------------------------------------------------------------- - void NICAS::multiplySqrt(const atlas::Field & cv, oops::FieldSet3D & fset, const size_t & offset) const { diff --git a/src/saber/bump/NICAS.h b/src/saber/bump/NICAS.h index 5de54a203..980e4d3aa 100644 --- a/src/saber/bump/NICAS.h +++ b/src/saber/bump/NICAS.h @@ -70,8 +70,6 @@ class NICAS : public SaberCentralBlockBase { void iterativeCalibrationUpdate(const oops::FieldSet3D &) override; void iterativeCalibrationFinal() override; - void dualResolutionSetup(const oops::GeometryData &) override; - void write() const override; std::vector> fieldsToWrite() const override; diff --git a/src/saber/bump/subr_list.fypp b/src/saber/bump/subr_list.fypp index 4fc50b016..1b6a58d92 100644 --- a/src/saber/bump/subr_list.fypp +++ b/src/saber/bump/subr_list.fypp @@ -118,14 +118,20 @@ #:set subr_list = subr_list + ["avg_blk_alloc_grp"] #:set subr_list = subr_list + ["avg_blk_dealloc"] #:set subr_list = subr_list + ["avg_blk_copy"] -#:set subr_list = subr_list + ["avg_blk_write"] +#:set subr_list = subr_list + ["avg_blk_write_hist"] #:set subr_list = subr_list + ["avg_blk_compute_global"] #:set subr_list = subr_list + ["avg_blk_compute_local"] #:set subr_list = subr_list + ["avg_blk_compute_asy"] #:set subr_list = subr_list + ["avg_alloc"] #:set subr_list = subr_list + ["avg_dealloc"] #:set subr_list = subr_list + ["avg_copy"] +#:set subr_list = subr_list + ["avg_read"] +#:set subr_list = subr_list + ["avg_read_single"] #:set subr_list = subr_list + ["avg_write"] +#:set subr_list = subr_list + ["avg_write_single"] +#:set subr_list = subr_list + ["avg_send"] +#:set subr_list = subr_list + ["avg_receive"] +#:set subr_list = subr_list + ["avg_write_hist"] #:set subr_list = subr_list + ["avg_compute"] #:set subr_list = subr_list + ["bnda_hor_init"] #:set subr_list = subr_list + ["bnda_init"] diff --git a/src/saber/bump/type_avg.fypp b/src/saber/bump/type_avg.fypp index 81eaca590..d5e661d78 100644 --- a/src/saber/bump/type_avg.fypp +++ b/src/saber/bump/type_avg.fypp @@ -8,10 +8,13 @@ !---------------------------------------------------------------------- module type_avg +use fckit_mpi_module, only: fckit_mpi_status !$ use omp_lib use tools_const, only: zero,one use tools_func, only: add,divide use tools_kinds, only: kind_real +use tools_netcdf, only: create_file,open_file,get_att,put_att,define_grp,inquire_grp,define_dim,define_var, & + & inquire_var,put_var,get_var,close_file use type_avg_blk, only: avg_blk_type use type_geom, only: geom_type use type_mom, only: mom_type @@ -30,10 +33,21 @@ type avg_type integer :: nsub !< Number of sub-ensembles type(avg_blk_type),allocatable :: blk(:,:) !< Averaged statistics blocks type(avg_blk_type),allocatable :: grp(:,:) !< Group statistics + + ! Dimensions for local I/O + integer :: nc2a !< Number of points in subset Sc2, halo A contains procedure :: alloc => avg_alloc procedure :: dealloc => avg_dealloc - procedure :: write => avg_write + procedure :: avg_read + procedure :: avg_read_single + generic :: read => avg_read,avg_read_single + procedure :: avg_write + procedure :: avg_write_single + generic :: write => avg_write,avg_write_single + procedure :: send => avg_send + procedure :: receive => avg_receive + procedure :: write_hist => avg_write_hist procedure :: compute => avg_compute end type avg_type @@ -135,11 +149,439 @@ end if end subroutine avg_dealloc +!---------------------------------------------------------------------- +! Subroutine: avg_read +!> Read +!---------------------------------------------------------------------- +subroutine avg_read(avg,mpl,nam,geom,samp) + +implicit none + +! Passed variables +class(avg_type),intent(inout) :: avg !< Averaged statistics +type(mpl_type),intent(inout) :: mpl !< MPI data +type(nam_type),intent(in) :: nam !< Namelist +type(geom_type),intent(in) :: geom !< Geometry +type(samp_type),intent(in) :: samp !< Sampling + +! Local variables +integer :: iproc,iprocio +type(avg_type) :: avg_tmp + +! Set name +@:set_name(avg_read) + +! Probe in +@:probe_in() + +do iproc=1,mpl%nproc + ! Reading task + iprocio = mod(iproc,mpl%nprocio) + if (iprocio==0) iprocio = mpl%nprocio + + if (mpl%myproc==iprocio) then + write(mpl%info,'(a10,a,i6,a,i6)') '','Read averaged statistics of task ',iproc,' from task ',iprocio + call mpl%flush + + if (iproc==iprocio) then + ! Read data + call avg%read(mpl,nam,geom,iproc) + if (avg%nc2a/=samp%nc2a) call mpl%abort('${subr}$','avg%nc2a is not equal to samp%nc2a') + else + ! Read data + call avg_tmp%read(mpl,nam,geom,iproc) + + ! Send data to task iproc + call avg_tmp%send(mpl,nam,geom,iproc) + + ! Release memory + call avg_tmp%dealloc + end if + elseif (mpl%myproc==iproc) then + ! Receive data from task iprocio + write(mpl%info,'(a10,a,i6,a,i6)') '','Receive averaged statistics of task ',iproc,' from task ',iprocio + call mpl%flush + call avg%receive(mpl,nam,geom,iprocio) + if (avg%nc2a/=samp%nc2a) call mpl%abort('${subr}$','avg%nc2a is not equal to samp%nc2a') + end if +end do + +! Update tag +call mpl%update_tag(3) + +! Probe out +@:probe_out() + +end subroutine avg_read + +!---------------------------------------------------------------------- +! Subroutine: avg_read_single +!> Read, single task +!---------------------------------------------------------------------- +subroutine avg_read_single(avg,mpl,nam,geom,iproc) + +implicit none + +! Passed variables +class(avg_type),intent(inout) :: avg !< Averaged statistics +type(mpl_type),intent(inout) :: mpl !< MPI data +type(nam_type),intent(in) :: nam !< Namelist +type(geom_type),intent(in) :: geom !< Geometry +integer,intent(in) :: iproc !< Task index + +! Local variables +integer :: ig,ic2a +integer :: ncid,grpid,m11_id,m11sq_id +character(len=1024) :: grpname + +! Set name +@:set_name(avg_read_single) + +! Probe in +@:probe_in() + +! Open file +ncid = open_file(mpl,nam%fname_avg,iproc) + +! Get attribute +call get_att(mpl,ncid,0,'nc2a',avg%nc2a) + +! Allocation +allocate(avg%grp(0:avg%nc2a,nam%ng)) +do ig=1,nam%ng + do ic2a=0,avg%nc2a + call avg%grp(ic2a,ig)%alloc(nam,geom,ic2a) + end do +end do + +do ig=1,nam%ng + do ic2a=0,avg%nc2a + ! Get group name + write(grpname,'(a,a,i6.6)') trim(nam%group_names(ig)),'_',ic2a + + ! Get group + grpid = inquire_grp(mpl,ncid,grpname) + + ! Get variables + m11_id = inquire_var(mpl,grpid,'m11') + m11sq_id = inquire_var(mpl,grpid,'m11sq') + + ! Read data + call get_var(mpl,grpid,m11_id,avg%grp(ic2a,ig)%m11) + call get_var(mpl,grpid,m11sq_id,avg%grp(ic2a,ig)%m11sq) + end do +end do + +! Close file +call close_file(mpl,ncid) + +! Probe out +@:probe_out() + +end subroutine avg_read_single + !---------------------------------------------------------------------- ! Subroutine: avg_write !> Write !---------------------------------------------------------------------- -subroutine avg_write(avg,mpl,nam,geom) +subroutine avg_write(avg,mpl,nam,geom,samp) + +implicit none + +! Passed variables +class(avg_type),intent(inout) :: avg !< Averaged statistics +type(mpl_type),intent(inout) :: mpl !< MPI data +type(nam_type),intent(in) :: nam !< Namelist +type(geom_type),intent(in) :: geom !< Geometry +type(samp_type),intent(in) :: samp !< Sampling + +! Local variables +integer :: iproc,iprocio +type(avg_type) :: avg_tmp + +! Set name +@:set_name(avg_write) + +! Probe in +@:probe_in() + +do iproc=1,mpl%nproc + ! Writing task + iprocio = mod(iproc,mpl%nprocio) + if (iprocio==0) iprocio = mpl%nprocio + + if (mpl%myproc==iprocio) then + write(mpl%info,'(a10,a,i6,a,i6)') '','Write averaged statistics of task ',iproc,' from task ',iprocio + call mpl%flush + + if (iproc==iprocio) then + ! Write data + avg%nc2a = samp%nc2a + call avg%write(mpl,nam,geom,iproc) + else + ! Receive data from task iproc + call avg_tmp%receive(mpl,nam,geom,iproc) + + ! Write data + call avg_tmp%write(mpl,nam,geom,iproc) + + ! Release memory + call avg_tmp%dealloc + end if + elseif (mpl%myproc==iproc) then + ! Send data to task iprocio + write(mpl%info,'(a10,a,i6,a,i6)') '','Send averaged statistics of task ',iproc,' to task ',iprocio + call mpl%flush + avg%nc2a = samp%nc2a + call avg%send(mpl,nam,geom,iprocio) + end if +end do + +! Update tag +call mpl%update_tag(3) + +! Probe out +@:probe_out() + +end subroutine avg_write + +!---------------------------------------------------------------------- +! Subroutine: avg_write_single +!> Write, single task +!---------------------------------------------------------------------- +subroutine avg_write_single(avg,mpl,nam,geom,iproc) + +implicit none + +! Passed variables +class(avg_type),intent(in) :: avg !< Averaged statistics +type(mpl_type),intent(inout) :: mpl !< MPI data +type(nam_type),intent(in) :: nam !< Namelist +type(geom_type),intent(in) :: geom !< Geometry +integer,intent(in) :: iproc !< Task index + +! Local variables +integer :: ig,ic2a +integer :: ncid,grpid,nc3_id,nc4_id,nl0r_id,nl0_id,m11_id,m11sq_id +character(len=1024) :: grpname + +! Set name +@:set_name(avg_write_single) + +! Probe in +@:probe_in() + +! Create file +ncid = create_file(mpl,nam%fname_avg,iproc) + +! Put attribute +call put_att(mpl,ncid,0,'nc2a',avg%nc2a) + +! Define or get dimensions +nc3_id = define_dim(mpl,ncid,'nc3',nam%nc3) +nc4_id = define_dim(mpl,ncid,'nc4',nam%nc4) +nl0r_id = define_dim(mpl,ncid,'nl0r',nam%nl0r) +nl0_id = define_dim(mpl,ncid,'nl0',geom%nl0) + +do ig=1,nam%ng + do ic2a=0,avg%nc2a + ! Get group name + write(grpname,'(a,a,i6.6)') trim(nam%group_names(ig)),'_',ic2a + + ! Define group + grpid = define_grp(mpl,ncid,grpname) + + ! Define or get variables + m11_id = define_var(mpl,grpid,'m11','real',(/nc3_id,nc4_id,nl0r_id,nl0_id/)) + m11sq_id = define_var(mpl,grpid,'m11sq','real',(/nc3_id,nc4_id,nl0r_id,nl0_id/)) + + ! Write variables + call put_var(mpl,grpid,m11_id,avg%grp(ic2a,ig)%m11) + call put_var(mpl,grpid,m11sq_id,avg%grp(ic2a,ig)%m11sq) + end do +end do + +! Close file +call close_file(mpl,ncid) + +! Probe out +@:probe_out() + +end subroutine avg_write_single + +!---------------------------------------------------------------------- +! Subroutine: avg_send +!> Send +!---------------------------------------------------------------------- +subroutine avg_send(avg,mpl,nam,geom,iproc) + +implicit none + +! Passed variables +class(avg_type),intent(in) :: avg !< Averaged statistics +type(mpl_type),intent(inout) :: mpl !< MPI data +type(nam_type),intent(in) :: nam !< Namelist +type(geom_type),intent(in) :: geom !< Geometry +integer,intent(in) :: iproc !< Destination task + +! Local variables +integer :: nbufi,nbufr,ibufi,ibufr,ig,ic2a,bufs(2) +integer,allocatable :: bufi(:) +real(kind_real),allocatable :: bufr(:) + +! Set name +@:set_name(avg_send) + +! Probe in +@:probe_in() + +! Initialization +nbufi = 0 +nbufr = 0 + +! nc2a +nbufi = nbufi+1 + +! m11 +nbufr = nbufr+nam%ng*avg%nc2a*nam%nc3*nam%nc4*nam%nl0r*geom%nl0 + +! m11sq +nbufr = nbufr+nam%ng*avg%nc2a*nam%nc3*nam%nc4*nam%nl0r*geom%nl0 + +! Allocation +allocate(bufi(nbufi)) +allocate(bufr(nbufr)) + +! Initialization +ibufi = 0 +ibufr = 0 + +! nc2a +bufi(ibufi+1) = avg%nc2a +ibufi = ibufi+1 + +do ig=1,nam%ng + do ic2a=0,avg%nc2a + ! m11 + bufr(ibufr+1:ibufr+nam%nc3*nam%nc4*nam%nl0r*geom%nl0) = reshape(avg%grp(ic2a,ig)%m11, & + & (/nam%nc3*nam%nc4*nam%nl0r*geom%nl0/)) + ibufr = ibufr+nam%nc3*nam%nc4*nam%nl0r*geom%nl0 + + ! m11sq + bufr(ibufr+1:ibufr+nam%nc3*nam%nc4*nam%nl0r*geom%nl0) = reshape(avg%grp(ic2a,ig)%m11sq, & + & (/nam%nc3*nam%nc4*nam%nl0r*geom%nl0/)) + ibufr = ibufr+nam%nc3*nam%nc4*nam%nl0r*geom%nl0 + end do +end do + +! Check sizes +if (ibufi/=nbufi) call mpl%abort('${subr}$','wrong final index ibufi') +if (ibufr/=nbufr) call mpl%abort('${subr}$','wrong final index ibufr') + +! Send buffer size +bufs = (/nbufi,nbufr/) +call mpl%f_comm%send(bufs,iproc-1,mpl%tag) + +! Send data +call mpl%f_comm%send(bufi,iproc-1,mpl%tag+1) +call mpl%f_comm%send(bufr,iproc-1,mpl%tag+2) + +! Release memory +deallocate(bufi) +deallocate(bufr) + +! Probe out +@:probe_out() + +end subroutine avg_send + +!---------------------------------------------------------------------- +! Subroutine: avg_receive +!> Receive +!---------------------------------------------------------------------- +subroutine avg_receive(avg,mpl,nam,geom,iproc) + +implicit none + +! Passed variables +class(avg_type),intent(inout) :: avg !< Averaged statistics +type(mpl_type),intent(inout) :: mpl !< MPI data +type(nam_type),intent(in) :: nam !< Namelist +type(geom_type),intent(in) :: geom !< Geometry +integer,intent(in) :: iproc !< Source task + +! Local variables +integer :: nbufi,nbufr,ibufi,ibufr,ig,ic2a,bufs(2) +integer,allocatable :: bufi(:) +real(kind_real),allocatable :: bufr(:) +type(fckit_mpi_status) :: status + +! Set name +@:set_name(avg_receive) + +! Probe in +@:probe_in() + +! Receive buffer size +call mpl%f_comm%receive(bufs,iproc-1,mpl%tag,status) +nbufi = bufs(1) +nbufr = bufs(2) + +! Allocation +allocate(bufi(nbufi)) +allocate(bufr(nbufr)) + +! Receive data +call mpl%f_comm%receive(bufi,iproc-1,mpl%tag+1,status) +call mpl%f_comm%receive(bufr,iproc-1,mpl%tag+2,status) + +! Initialization +ibufi = 0 +ibufr = 0 + +! nc2a +avg%nc2a = bufi(ibufi+1) +ibufi = ibufi+1 + +! Allocation +allocate(avg%grp(0:avg%nc2a,nam%ng)) +do ig=1,nam%ng + do ic2a=0,avg%nc2a + call avg%grp(ic2a,ig)%alloc(nam,geom,ic2a) + end do +end do + +do ig=1,nam%ng + do ic2a=0,avg%nc2a + ! m11 + avg%grp(ic2a,ig)%m11 = reshape(bufr(ibufr+1:ibufr+nam%nc3*nam%nc4*nam%nl0r*geom%nl0), & + & (/nam%nc3,nam%nc4,nam%nl0r,geom%nl0/)) + ibufr = ibufr+nam%nc3*nam%nc4*nam%nl0r*geom%nl0 + + ! m11sq + avg%grp(ic2a,ig)%m11sq = reshape(bufr(ibufr+1:ibufr+nam%nc3*nam%nc4*nam%nl0r*geom%nl0), & + & (/nam%nc3,nam%nc4,nam%nl0r,geom%nl0/)) + ibufr = ibufr+nam%nc3*nam%nc4*nam%nl0r*geom%nl0 + end do +end do + +! Check sizes +if (ibufi/=nbufi) call mpl%abort('${subr}$','wrong final index ibufi') +if (ibufr/=nbufr) call mpl%abort('${subr}$','wrong final index ibufr') + +! Release memory +deallocate(bufr) + +! Probe out +@:probe_out() + +end subroutine avg_receive + +!---------------------------------------------------------------------- +! Subroutine: avg_write_hist +!> Write histograms +!---------------------------------------------------------------------- +subroutine avg_write_hist(avg,mpl,nam,geom) implicit none @@ -154,7 +596,7 @@ integer :: iv character(len=1024) :: filename ! Set name -@:set_name(avg_write) +@:set_name(avg_write_hist) ! Probe in @:probe_in() @@ -162,14 +604,14 @@ character(len=1024) :: filename if (mpl%main) then filename = trim(nam%prefix)//trim(avg%prefix) do iv=1,nam%nv - call avg%blk(0,iv)%write(mpl,nam,geom,filename) + call avg%blk(0,iv)%write_hist(mpl,nam,geom,filename) end do end if ! Probe out @:probe_out() -end subroutine avg_write +end subroutine avg_write_hist !---------------------------------------------------------------------- ! Subroutine: avg_compute @@ -237,11 +679,11 @@ do iv=1,nam%nv end if end do -if (mpl%main.and.(nam%avg_nbins>0)) then +if (nam%avg_nbins>0) then ! Write histograms write(mpl%info,'(a10,a)') '','Write histograms' call mpl%flush - call avg%write(mpl,nam,geom) + call avg%write_hist(mpl,nam,geom) end if ! Compute asymptotic statistics diff --git a/src/saber/bump/type_avg_blk.fypp b/src/saber/bump/type_avg_blk.fypp index 849971a31..74ee8eff9 100644 --- a/src/saber/bump/type_avg_blk.fypp +++ b/src/saber/bump/type_avg_blk.fypp @@ -56,7 +56,7 @@ contains procedure :: avg_blk_alloc_grp generic :: alloc => avg_blk_alloc_blk,avg_blk_alloc_grp procedure :: dealloc => avg_blk_dealloc - procedure :: write => avg_blk_write + procedure :: write_hist => avg_blk_write_hist procedure :: compute_global => avg_blk_compute_global procedure :: compute_local => avg_blk_compute_local procedure :: compute_asy => avg_blk_compute_asy @@ -220,10 +220,10 @@ if (allocated(avg_blk%cor_hist)) deallocate(avg_blk%cor_hist) end subroutine avg_blk_dealloc !---------------------------------------------------------------------- -! Subroutine: avg_blk_write -!> Write +! Subroutine: avg_blk_write_hist +!> Write histograms !---------------------------------------------------------------------- -subroutine avg_blk_write(avg_blk,mpl,nam,geom,filename) +subroutine avg_blk_write_hist(avg_blk,mpl,nam,geom,filename) implicit none @@ -241,7 +241,7 @@ integer :: cor_bins_id,cor_hist_id character(len=1024) :: grpname ! Set name -@:set_name(avg_blk_write) +@:set_name(avg_blk_write_hist) ! Probe in @:probe_in() @@ -302,7 +302,7 @@ call close_file(mpl,ncid) ! Probe out @:probe_out() -end subroutine avg_blk_write +end subroutine avg_blk_write_hist !---------------------------------------------------------------------- ! Subroutine: avg_blk_compute_global diff --git a/src/saber/bump/type_bump.fypp b/src/saber/bump/type_bump.fypp index cebb563e2..29949b30f 100644 --- a/src/saber/bump/type_bump.fypp +++ b/src/saber/bump/type_bump.fypp @@ -39,27 +39,26 @@ implicit none ! BUMP derived type type bump_type ! Derived types - type(cmat_type),allocatable :: cmat(:) !< C matrix - type(ens_type),allocatable :: ens(:) !< Ensembles - type(geom_type),allocatable :: geom(:) !< Geometry - type(gsi_type) :: gsi !< GSI data - type(hdiag_type) :: hdiag !< Hybrid diagnostics - type(mom_type),allocatable :: mom(:) !< Moments - type(mpl_type) :: mpl !< MPI data - type(nam_type) :: nam !< Namelist - type(nicas_type),allocatable :: nicas(:) !< NICAS data - type(rng_type) :: rng !< Random number generator - type(samp_type),allocatable :: samp(:) !< Sampling - type(var_type) :: var !< Variance - type(vbal_type) :: vbal !< Vertical balance - type(wind_type) :: wind !< Wind + type(cmat_type) :: cmat !< C matrix + type(ens_type) :: ens !< Ensembles + type(geom_type) :: geom !< Geometry + type(gsi_type) :: gsi !< GSI data + type(hdiag_type) :: hdiag !< Hybrid diagnostics + type(mom_type) :: mom !< Moments + type(mpl_type) :: mpl !< MPI data + type(nam_type) :: nam !< Namelist + type(nicas_type) :: nicas !< NICAS data + type(rng_type) :: rng !< Random number generator + type(samp_type) :: samp !< Sampling + type(var_type) :: var !< Variance + type(vbal_type) :: vbal !< Vertical balance + type(wind_type) :: wind !< Wind ! Dummy variable - logical :: dummy_logical !< Dummy variable + logical :: dummy_logical !< Dummy variable contains procedure :: create => bump_create procedure :: setup => bump_setup - procedure :: dual_resolution_setup => bump_dual_resolution_setup procedure :: add_member => bump_add_member procedure :: update_vbal_cov => bump_update_vbal_cov procedure :: update_var => bump_update_var @@ -193,12 +192,6 @@ call bump%mpl%flush ! Allocation allocate(bump%mpl%pioproc(bump%mpl%nproc)) -allocate(bump%cmat(2)) -allocate(bump%ens(2)) -allocate(bump%geom(2)) -allocate(bump%mom(2)) -allocate(bump%nicas(2)) -allocate(bump%samp(2)) ! Set I/O parameters bump%mpl%datadir = bump%nam%datadir @@ -250,27 +243,24 @@ call bump%mpl%flush call bump%rng%init(bump%mpl,bump%nam) ! Initialize allocation flags -bump%geom(1)%allocated = .false. -bump%geom(2)%allocated = .false. -bump%cmat(1)%allocated = .false. -bump%cmat(2)%allocated = .false. -bump%nicas(1)%allocated = .false. -bump%nicas(2)%allocated = .false. +bump%geom%allocated = .false. +bump%cmat%allocated = .false. +bump%nicas%allocated = .false. ! Initialize geometry write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Initialize geometry' call bump%mpl%flush -call bump%geom(1)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace,fieldset) +call bump%geom%setup(bump%mpl,bump%rng,bump%nam,afunctionspace,fieldset) -if (bump%nam%ens1_ne>0) then - ! Initialize ensemble 1 +if (bump%nam%ens_ne>0) then + ! Initialize ensemble write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Initialize ensemble 1' + write(bump%mpl%info,'(a)') '--- Initialize ensemble' call bump%mpl%flush - call bump%ens(1)%set_att(bump%nam%ens1_ne,bump%nam%ens1_nsub) + call bump%ens%set_att(bump%nam%ens_ne,bump%nam%ens_nsub) end if if ((bump%nam%from_gsi.and.(bump%nam%new_vbal.or.bump%nam%new_var.or.bump%nam%new_hdiag)).and.(.not.bump%gsi%initialized)) then @@ -278,7 +268,7 @@ if ((bump%nam%from_gsi.and.(bump%nam%new_vbal.or.bump%nam%new_var.or.bump%nam%ne call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Initialize GSI data' call bump%mpl%flush - call bump%gsi%setup(bump%mpl,bump%nam,bump%geom(1)) + call bump%gsi%setup(bump%mpl,bump%nam,bump%geom) end if ! Probe out @@ -286,57 +276,11 @@ end if end subroutine bump_setup -!---------------------------------------------------------------------- -! Subroutine: bump_dual_resolution_setup -!> Dual resolution setup -!---------------------------------------------------------------------- -subroutine bump_dual_resolution_setup(bump,afunctionspace,fieldset) - -implicit none - -! Passed variables -class(bump_type),intent(inout) :: bump !< BUMP -type(atlas_functionspace),intent(in) :: afunctionspace !< Function space -type(fieldset_type),intent(in) :: fieldset !< SABER geometry fields - -! Set name -@:set_name(bump_dual_resolution_setup) - -! Get instance -@:get_instance(bump) - -! Probe in -@:probe_in() - -! Initialize second geometry -write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' -call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- Initialize second geometry' -call bump%mpl%flush -call bump%geom(2)%setup(bump%mpl,bump%rng,bump%nam,afunctionspace,fieldset) - -! Check consistency between geometries -if (bump%geom(1)%nl0/=bump%geom(2)%nl0) call bump%mpl%abort('${subr}','both geometries should have the same number of levels') - -if (bump%nam%ens2_ne>0) then - ! Initialize ensemble 2 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Initialize ensemble 2' - call bump%mpl%flush - call bump%ens(2)%set_att(bump%nam%ens2_ne,bump%nam%ens2_nsub) -end if - -! Probe out -@:probe_out() - -end subroutine bump_dual_resolution_setup - !---------------------------------------------------------------------- ! Subroutine: bump_add_member -!> Add member into bump%ens[1,2] +!> Add member into bump%ens !---------------------------------------------------------------------- -subroutine bump_add_member(bump,fieldset,ie,igeom) +subroutine bump_add_member(bump,fieldset,ie) implicit none @@ -344,10 +288,6 @@ implicit none class(bump_type),intent(inout) :: bump !< BUMP type(fieldset_type),intent(in) :: fieldset !< Fieldset integer,intent(in) :: ie !< Member index -integer,intent(in) :: igeom !< Geometry index - -! Local variables -integer :: ne,nsub ! Set name @:set_name(bump_add_member) @@ -358,28 +298,17 @@ integer :: ne,nsub ! Probe in @:probe_in() -! Check ensemble number -if (igeom==1) then - ne = bump%nam%ens1_ne - nsub = bump%nam%ens1_nsub -elseif (igeom==2) then - ne = bump%nam%ens2_ne - nsub = bump%nam%ens2_nsub -else - call bump%mpl%abort('${subr}$','wrong ensemble number') -end if - ! Allocation -if (.not.bump%ens(igeom)%loaded) call bump%ens(igeom)%alloc(ne,nsub) -bump%ens(igeom)%loaded = .true. +if (.not.bump%ens%loaded) call bump%ens%alloc(bump%nam%ens_ne,bump%nam%ens_nsub) +bump%ens%loaded = .true. ! Pass fields -call bump%ens(igeom)%mem(ie)%init(bump%mpl,fieldset,bump%geom(igeom)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d, & +call bump%ens%mem(ie)%init(bump%mpl,fieldset,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d, & & bump%nam%var2d,pass=.true.) ! Print norm call bump%mpl%flush -call bump%ens(igeom)%mem(ie)%print(bump%mpl,bump%geom(igeom)%owned_mga) +call bump%ens%mem(ie)%print(bump%mpl,bump%geom%owned_mga) ! Probe out @:probe_out() @@ -400,7 +329,7 @@ type(fieldset_type),intent(inout) :: fieldset !< Fieldset integer,intent(in) :: ie !< Member index ! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) ! Set name @:set_name(bump_update_vbal_cov) @@ -417,19 +346,19 @@ if (ie==1) then call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Setup sampling' call bump%mpl%flush - call bump%samp(1)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(1)) - call bump%samp(1)%setup_mpi(bump%mpl,bump%rng,bump%nam,bump%geom(1)) - call bump%samp(1)%setup_write(bump%mpl,bump%nam,bump%geom(1)) + call bump%samp%setup(bump%mpl,bump%rng,bump%nam,bump%geom) + call bump%samp%setup_mpi(bump%mpl,bump%rng,bump%nam,bump%geom) + call bump%samp%setup_write(bump%mpl,bump%nam,bump%geom) end if ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Update vertical covariances -call bump%vbal%cov_update(bump%mpl,bump%nam,bump%geom(1),bump%samp(1),fld_c0a,ie) +call bump%vbal%cov_update(bump%mpl,bump%nam,bump%geom,bump%samp,fld_c0a,ie) ! Probe out @:probe_out() @@ -450,7 +379,7 @@ type(fieldset_type),intent(inout) :: fieldset !< Fieldset integer,intent(in) :: ie !< Member index ! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) ! Set name @:set_name(bump_update_var) @@ -462,13 +391,13 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Update variance -call bump%var%update(bump%mpl,bump%rng,bump%nam,bump%geom(1),fld_c0a,ie) +call bump%var%update(bump%mpl,bump%rng,bump%nam,bump%geom,fld_c0a,ie) ! Probe out @:probe_out() @@ -479,7 +408,7 @@ end subroutine bump_update_var ! Subroutine: bump_update_mom !> Update moments, one member at a time !---------------------------------------------------------------------- -subroutine bump_update_mom(bump,fieldset,ie,igeom) +subroutine bump_update_mom(bump,fieldset,ie) implicit none @@ -487,10 +416,9 @@ implicit none class(bump_type),intent(inout) :: bump !< BUMP type(fieldset_type),intent(inout) :: fieldset !< Fieldset integer,intent(in) :: ie !< Member index -integer,intent(in) :: igeom !< Geometry index ! Local variable -real(kind_real) :: fld_c0a(bump%geom(igeom)%nc0a,bump%geom(igeom)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) ! Set name @:set_name(bump_update_mom) @@ -501,33 +429,25 @@ real(kind_real) :: fld_c0a(bump%geom(igeom)%nc0a,bump%geom(igeom)%nl0,bump%nam%n ! Probe in @:probe_in() -! Check ensemble number -if ((igeom/=1).and.(igeom/=2)) call bump%mpl%abort('${subr}$','wrong ensemble number') - if (ie==1) then ! Setup sampling write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - write(bump%mpl%info,'(a,i1)') '--- Setup sampling for ensemble ',igeom + write(bump%mpl%info,'(a,i1)') '--- Setup sampling' call bump%mpl%flush - if (igeom==1) then - call bump%samp(1)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%ens(1)) - call bump%samp(1)%setup_mpi(bump%mpl,bump%rng,bump%nam,bump%geom(1)) - call bump%samp(1)%setup_write(bump%mpl,bump%nam,bump%geom(1)) - elseif (igeom==2) then - call bump%samp(igeom)%copy(bump%mpl,bump%nam,bump%geom(igeom),bump%samp(1)) - call bump%samp(2)%setup_mpi(bump%mpl,bump%rng,bump%nam,bump%geom(2)) - end if + call bump%samp%setup(bump%mpl,bump%rng,bump%nam,bump%geom,bump%ens) + call bump%samp%setup_mpi(bump%mpl,bump%rng,bump%nam,bump%geom) + call bump%samp%setup_write(bump%mpl,bump%nam,bump%geom) end if ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(igeom)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(igeom)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Update moments -call bump%mom(igeom)%update(bump%mpl,bump%nam,bump%geom(igeom),bump%samp(igeom),fld_c0a,ie,igeom) +call bump%mom%update(bump%mpl,bump%nam,bump%geom,bump%samp,fld_c0a,ie) ! Probe out @:probe_out() @@ -555,54 +475,45 @@ class(bump_type),intent(inout) :: bump !< BUMP @:probe_in() if (bump%nam%check_consistency.or.bump%nam%check_optimality) then - ! Copy namelist support radii into C matrix, ensemble 1 + ! Copy namelist support radii into C matrix write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Copy namelist support radii into C matrix, ensemble 1' + write(bump%mpl%info,'(a)') '--- Copy namelist support radii into C matrix' call bump%mpl%flush - call bump%cmat(1)%from_nam(bump%mpl,bump%nam,bump%geom(1)) + call bump%cmat%from_nam(bump%mpl,bump%nam,bump%geom) - ! Setup C matrix sampling, ensemble 1 + ! Setup C matrix sampling write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Setup C matrix sampling, ensemble 1' + write(bump%mpl%info,'(a)') '--- Setup C matrix sampling' call bump%mpl%flush - call bump%cmat(1)%setup_sampling(bump%mpl,bump%nam,bump%geom(1)) + call bump%cmat%setup_sampling(bump%mpl,bump%nam,bump%geom) - ! Run NICAS driver, ensemble 1 + ! Run NICAS driver write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Run NICAS driver, ensemble 1' + write(bump%mpl%info,'(a)') '--- Run NICAS driver' call bump%mpl%flush - call bump%nicas(1)%run_nicas(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%cmat(1)) + call bump%nicas%run_nicas(bump%mpl,bump%rng,bump%nam,bump%geom,bump%cmat) - ! Randomize ensemble 1 + ! Randomize ensemble write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - write(bump%mpl%info,'(a,i6,a)') '--- Randomize ensemble 1 (',bump%nam%ens1_ne,' members)' + write(bump%mpl%info,'(a,i6,a)') '--- Randomize ensemble (',bump%nam%ens_ne,' members)' call bump%mpl%flush - call bump%nicas(1)%gen_ens_pert(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%nam%ens1_ne,bump%ens(1)) + call bump%nicas%gen_ens_pert(bump%mpl,bump%rng,bump%nam,bump%geom,bump%nam%ens_ne,bump%ens) ! Release memory - call bump%cmat(1)%dealloc -end if - -if (bump%nam%ens1_ne>0.and.bump%ens(1)%loaded) then - ! Compute mean for ensemble 1 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Compute mean for ensemble 1' - call bump%mpl%flush - call bump%ens(1)%compute_mean(bump%mpl,bump%nam,bump%geom(1)) + call bump%cmat%dealloc end if -if (bump%nam%ens2_ne>0.and.bump%ens(2)%loaded) then - ! Compute mean for ensemble 2 +if (bump%nam%ens_ne>0.and.bump%ens%loaded) then + ! Compute mean for ensemble write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Compute mean for ensemble 2' + write(bump%mpl%info,'(a)') '--- Compute mean for ensemble' call bump%mpl%flush - call bump%ens(2)%compute_mean(bump%mpl,bump%nam,bump%geom(2)) + call bump%ens%compute_mean(bump%mpl,bump%nam,bump%geom) end if if (bump%nam%new_normality) then @@ -611,30 +522,20 @@ if (bump%nam%new_normality) then call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Run normality tests' call bump%mpl%flush - call bump%ens(1)%normality(bump%mpl,bump%nam,bump%geom(1)) + call bump%ens%normality(bump%mpl,bump%nam,bump%geom) end if if ((bump%nam%new_vbal_cov.and.(.not.bump%nam%iterative_algo)).or.bump%nam%load_vbal_cov.or.(bump%nam%new_vbal.and. & & (.not.(bump%nam%new_vbal_cov.and.bump%nam%iterative_algo))) & & .or.bump%nam%load_vbal.or.(bump%nam%new_mom.and.(.not.bump%nam%iterative_algo)).or.bump%nam%load_mom) then - ! Setup sampling for ensemble 1 + ! Setup sampling for ensemble write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Setup sampling for ensemble 1' + write(bump%mpl%info,'(a)') '--- Setup sampling for ensemble' call bump%mpl%flush - call bump%samp(1)%setup(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%ens(1)) - call bump%samp(1)%setup_mpi(bump%mpl,bump%rng,bump%nam,bump%geom(1)) - call bump%samp(1)%setup_write(bump%mpl,bump%nam,bump%geom(1)) - - if (bump%geom(2)%allocated) then - ! Setup sampling for ensemble 2 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Setup sampling for ensemble 2' - call bump%mpl%flush - call bump%samp(2)%copy(bump%mpl,bump%nam,bump%geom(2),bump%samp(1)) - call bump%samp(2)%setup_mpi(bump%mpl,bump%rng,bump%nam,bump%geom(2)) - end if + call bump%samp%setup(bump%mpl,bump%rng,bump%nam,bump%geom,bump%ens) + call bump%samp%setup_mpi(bump%mpl,bump%rng,bump%nam,bump%geom) + call bump%samp%setup_write(bump%mpl,bump%nam,bump%geom) end if if (bump%nam%new_vbal_cov.and.(.not.bump%nam%iterative_algo)) then @@ -643,7 +544,7 @@ if (bump%nam%new_vbal_cov.and.(.not.bump%nam%iterative_algo)) then call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Run vertical covariances driver' call bump%mpl%flush - call bump%vbal%cov_run(bump%mpl,bump%nam,bump%geom(1),bump%samp(1),bump%ens(1)) + call bump%vbal%cov_run(bump%mpl,bump%nam,bump%geom,bump%samp,bump%ens) elseif (bump%nam%load_vbal_cov) then ! Read vertical balance write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' @@ -651,9 +552,9 @@ elseif (bump%nam%load_vbal_cov) then write(bump%mpl%info,'(a)') '--- Read vertical covariances' call bump%mpl%flush if (bump%nam%load_samp_local) then - call bump%vbal%cov_read_local(bump%mpl,bump%nam,bump%geom(1),bump%samp(1),bump%nam%ens1_nsub) + call bump%vbal%cov_read_local(bump%mpl,bump%nam,bump%geom,bump%samp,bump%nam%ens_nsub) elseif (bump%nam%load_samp_global) then - call bump%vbal%cov_read_global(bump%mpl,bump%nam,bump%geom(1),bump%samp(1),bump%nam%ens1_nsub) + call bump%vbal%cov_read_global(bump%mpl,bump%nam,bump%geom,bump%samp,bump%nam%ens_nsub) end if end if @@ -663,7 +564,7 @@ if (bump%nam%new_vbal) then call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Run vertical balance driver' call bump%mpl%flush - call bump%vbal%run_vbal(bump%mpl,bump%nam,bump%geom(1),bump%samp(1),bump%gsi,bump%ens(1)) + call bump%vbal%run_vbal(bump%mpl,bump%nam,bump%geom,bump%samp,bump%gsi,bump%ens) elseif (bump%nam%load_vbal) then ! Read vertical balance write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' @@ -671,9 +572,9 @@ elseif (bump%nam%load_vbal) then write(bump%mpl%info,'(a)') '--- Read vertical balance' call bump%mpl%flush if (bump%nam%load_samp_local) then - call bump%vbal%read_local(bump%mpl,bump%nam,bump%geom(1),bump%samp(1)) + call bump%vbal%read_local(bump%mpl,bump%nam,bump%geom,bump%samp) elseif (bump%nam%load_samp_global) then - call bump%vbal%read_global(bump%mpl,bump%nam,bump%geom(1),bump%samp(1)) + call bump%vbal%read_global(bump%mpl,bump%nam,bump%geom,bump%samp) end if end if @@ -683,7 +584,7 @@ if (bump%nam%new_vbal.or.bump%nam%load_vbal) then call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Run vertical balance tests driver' call bump%mpl%flush - call bump%vbal%run_vbal_tests(bump%mpl,bump%rng,bump%nam,bump%geom(1)) + call bump%vbal%run_vbal_tests(bump%mpl,bump%rng,bump%nam,bump%geom) end if if ((bump%nam%new_var.and.(.not.bump%nam%iterative_algo)).or.(bump%var%bump_m2_counter>0)) then @@ -692,59 +593,35 @@ if ((bump%nam%new_var.and.(.not.bump%nam%iterative_algo)).or.(bump%var%bump_m2_c call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Run variance driver' call bump%mpl%flush - call bump%var%run_var(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%gsi,bump%ens(1)) + call bump%var%run_var(bump%mpl,bump%rng,bump%nam,bump%geom,bump%gsi,bump%ens) end if -if (bump%nam%new_mom.and.(.not.bump%nam%iterative_algo)) then - ! Compute sample moments - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Compute sample moments' - call bump%mpl%flush - - if (bump%nam%compute_cov1.or.bump%nam%compute_cor1.or.bump%nam%compute_loc1) then - ! Ensemble 1 - write(bump%mpl%info,'(a7,a)') '','Ensemble 1:' +if (bump%nam%compute_cov.or.bump%nam%compute_cor.or.bump%nam%compute_loc) then + if (bump%nam%new_mom.and.(.not.bump%nam%iterative_algo)) then + ! Compute sample moments + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - call bump%mom(1)%compute(bump%mpl,bump%nam,bump%geom(1),bump%samp(1),bump%ens(1),1) - end if - - if (bump%nam%compute_cov2.or.bump%nam%compute_cor2.or.bump%nam%compute_loc2.or.bump%nam%compute_hyb) then - ! Ensemble 2 - write(bump%mpl%info,'(a7,a)') '','Ensemble 2:' + write(bump%mpl%info,'(a)') '--- Compute sample moments' call bump%mpl%flush - call bump%mom(2)%compute(bump%mpl,bump%nam,bump%geom(2),bump%samp(2),bump%ens(2),2) - end if -elseif (bump%nam%load_mom) then - ! Load sample moments - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Load sample moments' - call bump%mpl%flush - - if (bump%nam%compute_cov1.or.bump%nam%compute_cor1.or.bump%nam%compute_loc1) then - ! Ensemble 1 - write(bump%mpl%info,'(a7,a)') '','Ensemble 1' + call bump%mom%compute(bump%mpl,bump%nam,bump%geom,bump%samp,bump%ens) + elseif (bump%nam%load_mom) then + ! Load sample moments + write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - call bump%mom(1)%read(bump%mpl,bump%nam,bump%geom(1),bump%samp(1),bump%ens(1),1) - end if - - if (bump%nam%compute_cov2.or.bump%nam%compute_cor2.or.bump%nam%compute_loc2.or.bump%nam%compute_hyb) then - ! Ensemble 2 - write(bump%mpl%info,'(a7,a)') '','Ensemble 2' + write(bump%mpl%info,'(a)') '--- Load sample moments' call bump%mpl%flush - call bump%mom(2)%read(bump%mpl,bump%nam,bump%geom(2),bump%samp(2),bump%ens(2),2) + call bump%mom%read(bump%mpl,bump%nam,bump%geom,bump%samp,bump%ens) end if end if if (bump%nam%new_hdiag) then if (bump%nam%from_gsi) then ! Interpolate length-scales from GSI data - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' + write(bump%mpl%info,'(a)') '--------------------------------------------------------------------' call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Interpolate length-scales from GSI data' call bump%mpl%flush - call bump%hdiag%from_gsi(bump%mpl,bump%nam,bump%geom(1),bump%gsi) + call bump%hdiag%from_gsi(bump%mpl,bump%nam,bump%geom,bump%gsi) else ! Run HDIAG driver write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' @@ -764,106 +641,67 @@ if (bump%nam%check_consistency) then call bump%check_consistency end if -if (allocated(bump%cmat(1)%blk)) then - ! Get C matrix from BUMP interface, ensemble 1 +if (allocated(bump%cmat%blk)) then + ! Get C matrix from BUMP interface write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Get C matrix from BUMP interface, ensemble 1' + write(bump%mpl%info,'(a)') '--- Get C matrix from BUMP interface' call bump%mpl%flush - call bump%cmat(1)%from_bump(bump%mpl,bump%nam,bump%geom(1)) + call bump%cmat%from_bump(bump%mpl,bump%nam,bump%geom) end if if (.not.bump%nam%check_optimality) then - ! Copy namelist support radii into C matrix, ensemble 1 + ! Copy namelist support radii into C matrix write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Copy namelist support radii into C matrix, ensemble 1' + write(bump%mpl%info,'(a)') '--- Copy namelist support radii into C matrix' call bump%mpl%flush - call bump%cmat(1)%from_nam(bump%mpl,bump%nam,bump%geom(1)) + call bump%cmat%from_nam(bump%mpl,bump%nam,bump%geom) end if -if (bump%nam%compute_cor1.or.bump%nam%compute_cor2.or.bump%nam%compute_loc1.or.bump%nam%compute_loc2) then +if (bump%nam%compute_cor.or.bump%nam%compute_loc) then ! Copy HDIAG into C matrix write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Copy HDIAG into C matrix' call bump%mpl%flush - - if (bump%nam%compute_cor1.or.bump%nam%compute_loc1) then - ! Ensemble 1 - write(bump%mpl%info,'(a7,a)') '','Ensemble 1' - call bump%mpl%flush - if (bump%nam%compute_loc1) then - ! Localization - call bump%cmat(1)%from_hdiag(bump%mpl,bump%nam,bump%geom(1),bump%hdiag%loc(1),bump%nam%lengths_scaling) - elseif (bump%nam%compute_cor1) then - ! Correlation - call bump%cmat(1)%from_hdiag(bump%mpl,bump%nam,bump%geom(1),bump%hdiag%cor(1),bump%nam%lengths_scaling) - end if - end if - - if (bump%nam%compute_cor2.or.bump%nam%compute_loc2) then - ! Ensemble 2 - write(bump%mpl%info,'(a7,a)') '','Ensemble 2' - call bump%mpl%flush - if (bump%nam%compute_loc2) then - ! Localization - call bump%cmat(2)%from_hdiag(bump%mpl,bump%nam,bump%geom(2),bump%hdiag%loc(2),bump%nam%lengths_scaling) - elseif (bump%nam%compute_cor2) then - ! Correlation - call bump%cmat(2)%from_hdiag(bump%mpl,bump%nam,bump%geom(2),bump%hdiag%cor(2),bump%nam%lengths_scaling) - end if + if (bump%nam%compute_loc) then + ! Localization + call bump%cmat%from_hdiag(bump%mpl,bump%nam,bump%geom,bump%hdiag%loc,bump%nam%lengths_scaling) + elseif (bump%nam%compute_cor) then + ! Correlation + call bump%cmat%from_hdiag(bump%mpl,bump%nam,bump%geom,bump%hdiag%cor,bump%nam%lengths_scaling) end if end if -if (bump%cmat(1)%allocated) then - ! Setup C matrix sampling, ensemble 1 +if (bump%cmat%allocated) then + ! Setup C matrix sampling write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Setup C matrix sampling, ensemble 1' + write(bump%mpl%info,'(a)') '--- Setup C matrix sampling' call bump%mpl%flush - call bump%cmat(1)%setup_sampling(bump%mpl,bump%nam,bump%geom(1)) + call bump%cmat%setup_sampling(bump%mpl,bump%nam,bump%geom) if (bump%nam%write_universe_radius) then ! Write universe radius - call bump%cmat(1)%write_universe_radius(bump%mpl,bump%nam,bump%geom(1)) + call bump%cmat%write_universe_radius(bump%mpl,bump%nam,bump%geom) end if end if -if (bump%cmat(2)%allocated) then - ! Setup C matrix sampling, ensemble 2 - write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' - call bump%mpl%flush - write(bump%mpl%info,'(a)') '--- Setup C matrix sampling, ensemble 2' - call bump%mpl%flush - call bump%cmat(2)%setup_sampling(bump%mpl,bump%nam,bump%geom(2)) -end if - if (bump%nam%new_nicas.or.bump%nam%load_nicas_global) then ! Run NICAS driver write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Run NICAS driver' call bump%mpl%flush - - ! Ensemble 1 - write(bump%mpl%info,'(a7,a)') '','Ensemble 1' - call bump%mpl%flush - call bump%nicas(1)%run_nicas(bump%mpl,bump%rng,bump%nam,bump%geom(1),bump%cmat(1)) - - if (bump%nam%compute_cor2.or.bump%nam%compute_loc2) then - ! Ensemble 2 - write(bump%mpl%info,'(a7,a)') '','Ensemble 2' - call bump%mpl%flush - call bump%nicas(2)%run_nicas(bump%mpl,bump%rng,bump%nam,bump%geom(2),bump%cmat(2)) - end if + call bump%nicas%run_nicas(bump%mpl,bump%rng,bump%nam,bump%geom,bump%cmat) elseif (bump%nam%load_nicas_local) then ! Read local NICAS parameters write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Read local NICAS parameters' call bump%mpl%flush - call bump%nicas(1)%read_local(bump%mpl,bump%nam,bump%geom(1)) + call bump%nicas%read_local(bump%mpl,bump%nam,bump%geom) end if if (bump%nam%check_optimality) then @@ -876,8 +714,7 @@ if (bump%nam%check_optimality) then end if ! Release memory (partial) -call bump%cmat(1)%partial_dealloc -call bump%cmat(2)%partial_dealloc +call bump%cmat%partial_dealloc if (bump%nam%new_nicas.or.bump%nam%load_nicas_local.or.bump%nam%load_nicas_global) then ! Run NICAS tests driver @@ -885,18 +722,7 @@ if (bump%nam%new_nicas.or.bump%nam%load_nicas_local.or.bump%nam%load_nicas_globa call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Run NICAS tests driver' call bump%mpl%flush - - ! Ensemble 1 - write(bump%mpl%info,'(a7,a)') '','Ensemble 1' - call bump%mpl%flush - call bump%nicas(1)%run_nicas_tests(bump%mpl,bump%rng,bump%nam,bump%geom(1)) - - if (bump%nam%compute_cor2.or.bump%nam%compute_loc2) then - ! Ensemble 2 - write(bump%mpl%info,'(a7,a)') '','Ensemble 2' - call bump%mpl%flush - call bump%nicas(2)%run_nicas_tests(bump%mpl,bump%rng,bump%nam,bump%geom(2)) - end if + call bump%nicas%run_nicas_tests(bump%mpl,bump%rng,bump%nam,bump%geom) end if if (bump%nam%new_wind.or.bump%nam%load_wind_local.or.bump%nam%load_wind_global) then @@ -905,7 +731,7 @@ if (bump%nam%new_wind.or.bump%nam%load_wind_local.or.bump%nam%load_wind_global) call bump%mpl%flush write(bump%mpl%info,'(a)') '--- Run psi/chi to u/v driver' call bump%mpl%flush - call bump%wind%setup(bump%mpl,bump%rng,bump%nam,bump%geom(1)) + call bump%wind%setup(bump%mpl,bump%rng,bump%nam,bump%geom) end if ! Probe out @@ -940,11 +766,11 @@ real(kind_real) :: rh_diag,rv_diag do ig=1,bump%nam%ng write(bump%mpl%info,'(a7,a)') '','Block: '//trim(bump%nam%group_names(ig)) call bump%mpl%flush - do il0=1,bump%geom(1)%nl0 + do il0=1,bump%geom%nl0 rh_diag = -one rv_diag = -one - if (bump%nam%rh(il0,ig)>zero) rh_diag = bump%hdiag%cor(1)%blk(0,ig)%rh_l0(il0,1)/bump%nam%rh(il0,ig) - if (bump%nam%rv(il0,ig)>zero) rv_diag = bump%hdiag%cor(1)%blk(0,ig)%rv_l0(il0,1)/bump%nam%rv(il0,ig) + if (bump%nam%rh(il0,ig)>zero) rh_diag = bump%hdiag%cor%blk(0,ig)%rh_l0(il0,1)/bump%nam%rh(il0,ig) + if (bump%nam%rv(il0,ig)>zero) rv_diag = bump%hdiag%cor%blk(0,ig)%rv_l0(il0,1)/bump%nam%rv(il0,ig) write(bump%mpl%test,'(a10,a,i3,a,f6.3,a,f6.3)') '','Level ',il0,' ~> ',rh_diag,' / ',rv_diag call bump%mpl%flush end do @@ -971,9 +797,9 @@ integer :: ig,ifac,ifac_best,itest real(kind_real) :: fac(-bump%nam%optimality_nfac:bump%nam%optimality_nfac) real(kind_real) :: mse(bump%nam%optimality_ntest,-bump%nam%optimality_nfac:bump%nam%optimality_nfac) real(kind_real) :: mse_avg(-bump%nam%optimality_nfac:bump%nam%optimality_nfac) -real(kind_real) :: fld_ref(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv,bump%nam%optimality_ntest) -real(kind_real) :: fld_save(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv,bump%nam%optimality_ntest) -real(kind_real) :: fld(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_ref(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv,bump%nam%optimality_ntest) +real(kind_real) :: fld_save(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv,bump%nam%optimality_ntest) +real(kind_real) :: fld(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) type(nicas_type) :: nicas_test ! Set name @@ -988,25 +814,25 @@ type(nicas_type) :: nicas_test ! Define test vectors write(bump%mpl%info,'(a4,a)') '','Define test vectors' call bump%mpl%flush -call bump%geom(1)%define_test_vectors(bump%mpl,bump%rng,bump%nam,bump%nam%optimality_ntest,fld_save) +call bump%geom%define_test_vectors(bump%mpl,bump%rng,bump%nam,bump%nam%optimality_ntest,fld_save) ! Apply correlation operator to test vectors write(bump%mpl%info,'(a4,a)') '','Apply correlation operator to test vectors' call bump%mpl%flush fld_ref = fld_save do itest=1,bump%nam%optimality_ntest - call bump%nicas(1)%apply(bump%mpl,bump%nam,bump%geom(1),fld_ref(:,:,:,itest)) + call bump%nicas%apply(bump%mpl,bump%nam,bump%geom,fld_ref(:,:,:,itest)) end do ! Reduce ensemble size -bump%ens(1)%ne = bump%nam%ne +bump%ens%ne = bump%nam%ne -! Compute mean for ensemble 1 +! Compute ensemble mean write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' call bump%mpl%flush -write(bump%mpl%info,'(a)') '--- Compute mean for ensemble 1' +write(bump%mpl%info,'(a)') '--- Compute ensemble mean' call bump%mpl%flush -call bump%ens(1)%compute_mean(bump%mpl,bump%nam,bump%geom(1)) +call bump%ens%compute_mean(bump%mpl,bump%nam,bump%geom) do ifac=-bump%nam%optimality_nfac,bump%nam%optimality_nfac ! Multiplication factor @@ -1025,22 +851,22 @@ do ifac=-bump%nam%optimality_nfac,bump%nam%optimality_nfac call bump%mpl%flush ! Length-scales scaling - bump%cmat(1)%blk(ig)%rhs = bump%cmat(1)%blk(ig)%rhs*fac(ifac) - bump%cmat(1)%blk(ig)%rvs = bump%cmat(1)%blk(ig)%rvs*fac(ifac) - bump%cmat(1)%blk(ig)%rh = bump%cmat(1)%blk(ig)%rh*fac(ifac) - bump%cmat(1)%blk(ig)%rv = bump%cmat(1)%blk(ig)%rv*fac(ifac) + bump%cmat%blk(ig)%rhs = bump%cmat%blk(ig)%rhs*fac(ifac) + bump%cmat%blk(ig)%rvs = bump%cmat%blk(ig)%rvs*fac(ifac) + bump%cmat%blk(ig)%rh = bump%cmat%blk(ig)%rh*fac(ifac) + bump%cmat%blk(ig)%rv = bump%cmat%blk(ig)%rv*fac(ifac) ! Copy length-scales - call nicas_test%blk(ig)%copy_cmat(bump%mpl,bump%nam,bump%geom(1),bump%cmat(1)%blk(ig)) + call nicas_test%blk(ig)%copy_cmat(bump%mpl,bump%nam,bump%geom,bump%cmat%blk(ig)) ! Compute NICAS parameters - call nicas_test%blk(ig)%compute_parameters(bump%mpl,bump%rng,bump%nam,bump%geom(1)) + call nicas_test%blk(ig)%compute_parameters(bump%mpl,bump%rng,bump%nam,bump%geom) ! Length-scales inverse scaling - bump%cmat(1)%blk(ig)%rhs = bump%cmat(1)%blk(ig)%rhs/fac(ifac) - bump%cmat(1)%blk(ig)%rvs = bump%cmat(1)%blk(ig)%rvs/fac(ifac) - bump%cmat(1)%blk(ig)%rh = bump%cmat(1)%blk(ig)%rh/fac(ifac) - bump%cmat(1)%blk(ig)%rv = bump%cmat(1)%blk(ig)%rv/fac(ifac) + bump%cmat%blk(ig)%rhs = bump%cmat%blk(ig)%rhs/fac(ifac) + bump%cmat%blk(ig)%rvs = bump%cmat%blk(ig)%rvs/fac(ifac) + bump%cmat%blk(ig)%rh = bump%cmat%blk(ig)%rh/fac(ifac) + bump%cmat%blk(ig)%rv = bump%cmat%blk(ig)%rv/fac(ifac) end do write(bump%mpl%info,'(a)') '-------------------------------------------------------------------' @@ -1051,7 +877,7 @@ do ifac=-bump%nam%optimality_nfac,bump%nam%optimality_nfac do itest=1,bump%nam%optimality_ntest ! Apply localized ensemble fld = fld_save(:,:,:,itest) - call nicas_test%apply_bens(bump%mpl,bump%nam,bump%geom(1),bump%ens(1),fld) + call nicas_test%apply_bens(bump%mpl,bump%nam,bump%geom,bump%ens,fld) ! RMSE mse(itest,ifac) = zss_sum((fld-fld_ref(:,:,:,itest))**2,mask=bump%mpl%msv%isnot(fld_ref(:,:,:,itest))) @@ -1104,7 +930,7 @@ class(bump_type),intent(inout) :: bump !< BUMP type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) ! Set name @:set_name(bump_apply_vbal) @@ -1116,16 +942,16 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Apply vertical balance -call bump%vbal%apply(bump%nam,bump%geom(1),fld_c0a) +call bump%vbal%apply(bump%nam,bump%geom,fld_c0a) ! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) ! Probe out @:probe_out() @@ -1145,7 +971,7 @@ class(bump_type),intent(inout) :: bump !< BUMP type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) ! Set name @:set_name(bump_apply_vbal_ad) @@ -1157,16 +983,16 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Apply vertical balance, adjoint -call bump%vbal%apply_ad(bump%nam,bump%geom(1),fld_c0a) +call bump%vbal%apply_ad(bump%nam,bump%geom,fld_c0a) ! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) ! Probe out @:probe_out() @@ -1186,7 +1012,7 @@ class(bump_type),intent(inout) :: bump !< BUMP type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) ! Set name @:set_name(bump_apply_vbal_inv) @@ -1198,16 +1024,16 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Apply vertical balance, inverse -call bump%vbal%apply_inv(bump%nam,bump%geom(1),fld_c0a) +call bump%vbal%apply_inv(bump%nam,bump%geom,fld_c0a) ! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) ! Probe out @:probe_out() @@ -1227,7 +1053,7 @@ class(bump_type),intent(inout) :: bump !< BUMP type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) ! Set name @:set_name(bump_apply_stddev) @@ -1239,16 +1065,16 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Apply standard-deviation -call bump%var%apply_sqrt(bump%mpl,bump%nam,bump%geom(1),fld_c0a) +call bump%var%apply_sqrt(bump%mpl,bump%nam,bump%geom,fld_c0a) ! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) ! Probe out @:probe_out() @@ -1268,7 +1094,7 @@ class(bump_type),intent(inout) :: bump !< BUMP type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) ! Set name @:set_name(bump_apply_stddev_inv) @@ -1280,16 +1106,16 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Apply standard-deviation -call bump%var%apply_sqrt_inv(bump%mpl,bump%nam,bump%geom(1),fld_c0a) +call bump%var%apply_sqrt_inv(bump%mpl,bump%nam,bump%geom,fld_c0a) ! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) ! Probe out @:probe_out() @@ -1309,7 +1135,7 @@ class(bump_type),intent(inout) :: bump !< BUMP type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) ! Set name @:set_name(bump_apply_nicas) @@ -1321,16 +1147,16 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Apply NICAS -call bump%nicas(1)%apply(bump%mpl,bump%nam,bump%geom(1),fld_c0a) +call bump%nicas%apply(bump%mpl,bump%nam,bump%geom,fld_c0a) ! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) ! Probe out @:probe_out() @@ -1350,7 +1176,7 @@ class(bump_type),intent(inout) :: bump !< BUMP type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) ! Set name @:set_name(bump_apply_nicas_filter) @@ -1362,16 +1188,16 @@ real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Apply NICAS -call bump%nicas(1)%apply_filter(bump%mpl,bump%nam,bump%geom(1),fld_c0a) +call bump%nicas%apply_filter(bump%mpl,bump%nam,bump%geom,fld_c0a) ! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) ! Probe out @:probe_out() @@ -1403,7 +1229,7 @@ type(cv_type) :: cv @:probe_in() ! Allocate control variable -call bump%nicas(1)%alloc_cv(bump%mpl,bump%nam,bump%geom(1),cv,getsizeonly=.true.) +call bump%nicas%alloc_cv(bump%mpl,bump%nam,bump%geom,cv,getsizeonly=.true.) ! Copy size n = cv%n @@ -1429,7 +1255,7 @@ integer,intent(in) :: offset !< Control vector offset ! Local variable integer :: ic0a,il0,iv -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) type(cv_type) :: cv ! Set name @@ -1442,28 +1268,28 @@ type(cv_type) :: cv @:probe_in() ! Allocation -call bump%nicas(1)%alloc_cv(bump%mpl,bump%nam,bump%geom(1),cv) +call bump%nicas%alloc_cv(bump%mpl,bump%nam,bump%geom,cv) ! Unpack control variable call cv%unpack(acv,offset) ! Apply NICAS square-root -call bump%nicas(1)%apply_sqrt(bump%mpl,bump%nam,bump%geom(1),cv,fld_c0a) +call bump%nicas%apply_sqrt(bump%mpl,bump%nam,bump%geom,cv,fld_c0a) ! Set missing unmasked values to zero do iv=1,bump%nam%nv - do il0=1,bump%geom(1)%nl0 - do ic0a=1,bump%geom(1)%nc0a - if (bump%mpl%msv%is(fld_c0a(ic0a,il0,iv)).and.(.not.bump%geom(1)%gmask_c0a(ic0a,il0))) fld_c0a(ic0a,il0,iv) = zero + do il0=1,bump%geom%nl0 + do ic0a=1,bump%geom%nc0a + if (bump%mpl%msv%is(fld_c0a(ic0a,il0,iv)).and.(.not.bump%geom%gmask_c0a(ic0a,il0))) fld_c0a(ic0a,il0,iv) = zero end do end do end do ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) ! Probe out @:probe_out() @@ -1485,7 +1311,7 @@ type(atlas_field),intent(inout) :: acv !< ATLAS field control vector integer,intent(in) :: offset !< Control vector offset ! Local variables -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) type(cv_type) :: cv ! Set name @@ -1498,13 +1324,13 @@ type(cv_type) :: cv @:probe_in() ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Apply NICAS square-root adjoint -call bump%nicas(1)%apply_sqrt_ad(bump%mpl,bump%nam,bump%geom(1),fld_c0a,cv) +call bump%nicas%apply_sqrt_ad(bump%mpl,bump%nam,bump%geom,fld_c0a,cv) ! Pack control variable call cv%pack(acv,offset) @@ -1527,7 +1353,7 @@ class(bump_type),intent(inout) :: bump !< BUMP type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variable -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) type(cv_type) :: cv ! Set name @@ -1540,16 +1366,16 @@ type(cv_type) :: cv @:probe_in() ! Generate random control vector -call bump%nicas(1)%random_cv(bump%mpl,bump%rng,bump%nam,bump%geom(1),cv) +call bump%nicas%random_cv(bump%mpl,bump%rng,bump%nam,bump%geom,cv) ! Apply NICAS square-root -call bump%nicas(1)%apply_sqrt(bump%mpl,bump%nam,bump%geom(1),cv,fld_c0a) +call bump%nicas%apply_sqrt(bump%mpl,bump%nam,bump%geom,cv,fld_c0a) ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) ! Probe out @:probe_out() @@ -1570,7 +1396,7 @@ type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variable integer :: iv,iv_psi,iv_chi,iv_ua,iv_va -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) type(atlas_field) :: afield ! Set name @@ -1586,23 +1412,23 @@ type(atlas_field) :: afield if (fieldset%has_field('eastward_wind')) then afield = fieldset%field('eastward_wind') else - afield = bump%geom(1)%afunctionspace_mg%create_field(name='eastward_wind',kind=atlas_real(kind_real), & - & levels=bump%geom(1)%nl0) + afield = bump%geom%afunctionspace_mg%create_field(name='eastward_wind',kind=atlas_real(kind_real), & + & levels=bump%geom%nl0) call fieldset%add(afield) end if if (fieldset%has_field('northward_wind')) then afield = fieldset%field('northward_wind') else - afield = bump%geom(1)%afunctionspace_mg%create_field(name='northward_wind',kind=atlas_real(kind_real), & - & levels=bump%geom(1)%nl0) + afield = bump%geom%afunctionspace_mg%create_field(name='northward_wind',kind=atlas_real(kind_real), & + & levels=bump%geom%nl0) call fieldset%add(afield) end if ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Get psi/chi/ua/va indices do iv=1,bump%nam%nv @@ -1613,11 +1439,11 @@ do iv=1,bump%nam%nv end do ! Transform psi/chi to u/v -call bump%wind%psichi_to_uv(bump%mpl,bump%geom(1),fld_c0a(:,:,iv_psi),fld_c0a(:,:,iv_chi), & +call bump%wind%psichi_to_uv(bump%mpl,bump%geom,fld_c0a(:,:,iv_psi),fld_c0a(:,:,iv_chi), & & fld_c0a(:,:,iv_ua),fld_c0a(:,:,iv_va)) ! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) ! Release memory call afield%final() @@ -1641,7 +1467,7 @@ type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variable integer :: iv,iv_psi,iv_chi,iv_ua,iv_va -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv) type(atlas_field) :: afield ! Set name @@ -1657,23 +1483,23 @@ type(atlas_field) :: afield if (fieldset%has_field('air_horizontal_streamfunction')) then afield = fieldset%field('air_horizontal_streamfunction') else - afield = bump%geom(1)%afunctionspace_mg%create_field(name='air_horizontal_streamfunction', & - kind=atlas_real(kind_real), levels=bump%geom(1)%nl0) + afield = bump%geom%afunctionspace_mg%create_field(name='air_horizontal_streamfunction', & + kind=atlas_real(kind_real), levels=bump%geom%nl0) call fieldset%add(afield) end if if (fieldset%has_field('air_horizontal_velocity_potential')) then afield = fieldset%field('air_horizontal_velocity_potential') else - afield = bump%geom(1)%afunctionspace_mg%create_field(name='air_horizontal_velocity_potential', & - kind=atlas_real(kind_real), levels=bump%geom(1)%nl0) + afield = bump%geom%afunctionspace_mg%create_field(name='air_horizontal_velocity_potential', & + kind=atlas_real(kind_real), levels=bump%geom%nl0) call fieldset%add(afield) end if ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran on subset Sc0 -call bump%geom(1)%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) +call bump%geom%fieldset_to_c0(bump%mpl,bump%nam,fieldset,fld_c0a) ! Get psi/chi/ua/va indices do iv=1,bump%nam%nv @@ -1684,11 +1510,11 @@ do iv=1,bump%nam%nv end do ! Transform psi/chi to u/v adjoint -call bump%wind%psichi_to_uv_ad(bump%mpl,bump%geom(1),fld_c0a(:,:,iv_ua),fld_c0a(:,:,iv_va), & +call bump%wind%psichi_to_uv_ad(bump%mpl,bump%geom,fld_c0a(:,:,iv_ua),fld_c0a(:,:,iv_va), & & fld_c0a(:,:,iv_psi),fld_c0a(:,:,iv_chi)) ! Fortran array on subset Sc0 to fieldset -call bump%geom(1)%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) +call bump%geom%c0_to_fieldset(bump%mpl,bump%nam,fld_c0a,fieldset) ! Release memory call afield%final() @@ -1713,7 +1539,7 @@ integer,intent(in) :: icmp !< Component index type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variables -integer :: iens,igeom,ig,iv,ic0a,il0 +integer :: ig,iv,ic0a,il0 real(kind_real),allocatable :: fld_c0a(:,:),fld_mga(:,:,:) logical :: found @@ -1729,22 +1555,9 @@ logical :: found write(bump%mpl%info,'(a7,a,a)') '','Get ',trim(param) call bump%mpl%flush -! Get local geometry index -iens = 1 -if (len_trim(param)>2) then - if (param(len_trim(param)-2:len_trim(param))=='_lr') iens = 2 -end if -if (len_trim(param)>3) then - if (param(len_trim(param)-3:len_trim(param))=='_sta') iens = 2 -end if - -! Get output geometry index -igeom = iens -if (param=='hyb_coef_ens_lr') igeom = 1 - ! Allocation -allocate(fld_c0a(bump%geom(igeom)%nc0a,bump%geom(igeom)%nl0)) -allocate(fld_mga(bump%geom(igeom)%nmga,bump%geom(igeom)%nl0,bump%nam%nv)) +allocate(fld_c0a(bump%geom%nc0a,bump%geom%nl0)) +allocate(fld_mga(bump%geom%nmga,bump%geom%nl0,bump%nam%nv)) ! Initialization fld_mga = bump%mpl%msv%valr @@ -1761,36 +1574,36 @@ do iv=1,bump%nam%nv ! Select parameter from geom select case (trim(param)) case ('lon') - if (.not.allocated(bump%geom(igeom)%lon_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - do il0=1,bump%geom(igeom)%nl0 - fld_c0a(:,il0) = bump%geom(igeom)%lon_c0a*rad2deg + if (.not.allocated(bump%geom%lon_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + do il0=1,bump%geom%nl0 + fld_c0a(:,il0) = bump%geom%lon_c0a*rad2deg end do found = .true. case ('lat') - if (.not.allocated(bump%geom(igeom)%lat_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - do il0=1,bump%geom(igeom)%nl0 - fld_c0a(:,il0) = bump%geom(igeom)%lat_c0a*rad2deg + if (.not.allocated(bump%geom%lat_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + do il0=1,bump%geom%nl0 + fld_c0a(:,il0) = bump%geom%lat_c0a*rad2deg end do found = .true. case ('vert_coord') - if (.not.allocated(bump%geom(igeom)%vert_coord_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - fld_c0a = bump%geom(igeom)%vert_coord_c0a + if (.not.allocated(bump%geom%vert_coord_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + fld_c0a = bump%geom%vert_coord_c0a found = .true. end select ! Select parameter from ens select case (trim(param)) case ('norm_m2') - if (.not.allocated(bump%ens(1)%norm_m2)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - fld_c0a = bump%ens(1)%norm_m2(:,:,iv) + if (.not.allocated(bump%ens%norm_m2)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + fld_c0a = bump%ens%norm_m2(:,:,iv) found = .true. case ('norm_m4') - if (.not.allocated(bump%ens(1)%norm_m4)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - fld_c0a = bump%ens(1)%norm_m4(:,:,iv) + if (.not.allocated(bump%ens%norm_m4)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + fld_c0a = bump%ens%norm_m4(:,:,iv) found = .true. case ('norm_kurt') - if (.not.allocated(bump%ens(1)%norm_kurt)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - fld_c0a = bump%ens(1)%norm_kurt(:,:,iv) + if (.not.allocated(bump%ens%norm_kurt)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + fld_c0a = bump%ens%norm_kurt(:,:,iv) found = .true. end select @@ -1821,193 +1634,199 @@ do iv=1,bump%nam%nv ! Select parameter from mom select case (trim(param)) case ('dirac_mom_cov') - if (.not.allocated(bump%mom(1)%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - fld_c0a = bump%mom(1)%dirac(:,:,iv,1) + if (.not.allocated(bump%mom%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + fld_c0a = bump%mom%dirac(:,:,iv,1) found = .true. case ('dirac_mom_single_obs') - if (.not.allocated(bump%mom(1)%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - fld_c0a = bump%mom(1)%dirac(:,:,iv,2) + if (.not.allocated(bump%mom%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + fld_c0a = bump%mom%dirac(:,:,iv,2) found = .true. case ('dirac_mom') - if (.not.allocated(bump%mom(1)%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - fld_c0a = bump%mom(1)%dirac(:,:,iv,3) + if (.not.allocated(bump%mom%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + fld_c0a = bump%mom%dirac(:,:,iv,3) found = .true. end select ! Select parameter from hdiag select case (trim(param)) - case ('cor_a','cor_a_lr') - if (.not.allocated(bump%hdiag%cor(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(iens)%blk(0,ig)%a_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%cor(iens)%blk(0,ig)%a_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%cor(iens)%blk(0,ig)%a_c0a(:,:,icmp) + case ('cor_a') + if (.not.allocated(bump%hdiag%cor%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor%blk(0,ig)%a_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%cor%blk(0,ig)%a_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%cor%blk(0,ig)%a_c0a(:,:,icmp) found = .true. - case ('cor_rh','cor_rh_lr') + case ('cor_rh') if (bump%nam%forced_radii) then - do il0=1,bump%geom(igeom)%nl0 + do il0=1,bump%geom%nl0 if (bump%mpl%msv%isnot(bump%nam%rh(il0,ig))) fld_c0a(:,il0) = bump%nam%rh(il0,ig)*req end do else - if (.not.allocated(bump%hdiag%cor(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(iens)%blk(0,ig)%rh_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%cor(iens)%blk(0,ig)%rh_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%cor(iens)%blk(0,ig)%rh_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%geom(igeom)%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & + if (.not.allocated(bump%hdiag%cor%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor%blk(0,ig)%rh_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%cor%blk(0,ig)%rh_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%cor%blk(0,ig)%rh_c0a(:,:,icmp) + do il0=1,bump%geom%nl0 + do ic0a=1,bump%geom%nc0a + if (bump%geom%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & & fld_c0a(ic0a,il0) = fld_c0a(ic0a,il0)*req end do end do end if found = .true. - case ('cor_rh1','cor_rh1_lr') - if (.not.allocated(bump%hdiag%cor(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(iens)%blk(0,ig)%D11_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%cor(iens)%blk(0,ig)%D11_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%cor(iens)%blk(0,ig)%D11_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%geom(igeom)%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & + case ('cor_rh1') + if (.not.allocated(bump%hdiag%cor%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor%blk(0,ig)%D11_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%cor%blk(0,ig)%D11_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%cor%blk(0,ig)%D11_c0a(:,:,icmp) + do il0=1,bump%geom%nl0 + do ic0a=1,bump%geom%nc0a + if (bump%geom%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & & fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req end do end do found = .true. - case ('cor_rh2','cor_rh2_lr') - if (.not.allocated(bump%hdiag%cor(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(iens)%blk(0,ig)%D22_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%cor(iens)%blk(0,ig)%D22_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%cor(iens)%blk(0,ig)%D22_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%geom(igeom)%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & + case ('cor_rh2') + if (.not.allocated(bump%hdiag%cor%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor%blk(0,ig)%D22_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%cor%blk(0,ig)%D22_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%cor%blk(0,ig)%D22_c0a(:,:,icmp) + do il0=1,bump%geom%nl0 + do ic0a=1,bump%geom%nc0a + if (bump%geom%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & & fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req end do end do found = .true. - case ('cor_rhc','cor_rhc_lr') - if (.not.allocated(bump%hdiag%cor(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(iens)%blk(0,ig)%D12_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%cor(iens)%blk(0,ig)%D12_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%cor(iens)%blk(0,ig)%D12_c0a(:,:,icmp) + case ('cor_rhc') + if (.not.allocated(bump%hdiag%cor%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor%blk(0,ig)%D12_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%cor%blk(0,ig)%D12_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%cor%blk(0,ig)%D12_c0a(:,:,icmp) found = .true. - case ('cor_rv','cor_rv_lr') + case ('cor_rv') if (bump%nam%forced_radii) then - do il0=1,bump%geom(igeom)%nl0 + do il0=1,bump%geom%nl0 fld_c0a(:,il0) = bump%nam%rv(il0,ig) end do else - if (.not.allocated(bump%hdiag%cor(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%cor(iens)%blk(0,ig)%rv_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%cor(iens)%blk(0,ig)%rv_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%cor(iens)%blk(0,ig)%rv_c0a(:,:,icmp) + if (.not.allocated(bump%hdiag%cor%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%cor%blk(0,ig)%rv_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%cor%blk(0,ig)%rv_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%cor%blk(0,ig)%rv_c0a(:,:,icmp) end if found = .true. - case ('dirac_diag_cor','dirac_diag_cor_lr') - if (.not.allocated(bump%hdiag%cor(iens)%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - fld_c0a = bump%hdiag%cor(iens)%dirac(:,:,iv) + case ('dirac_diag_cor') + if (.not.allocated(bump%hdiag%cor%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + fld_c0a = bump%hdiag%cor%dirac(:,:,iv) found = .true. - case ('loc_a','loc_a_lr') - if (.not.allocated(bump%hdiag%loc(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(iens)%blk(0,ig)%a_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%loc(iens)%blk(0,ig)%a_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%loc(iens)%blk(0,ig)%a_c0a(:,:,icmp) + case ('loc_a') + if (.not.allocated(bump%hdiag%loc%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc%blk(0,ig)%a_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%loc%blk(0,ig)%a_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%loc%blk(0,ig)%a_c0a(:,:,icmp) found = .true. - case ('loc_rh','loc_rh_lr') + case ('loc_rh') if (bump%nam%forced_radii) then - do il0=1,bump%geom(igeom)%nl0 + do il0=1,bump%geom%nl0 if (bump%mpl%msv%isnot(bump%nam%rh(il0,ig))) fld_c0a(:,il0) = bump%nam%rh(il0,ig)*req end do else - if (.not.allocated(bump%hdiag%loc(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(iens)%blk(0,ig)%rh_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%loc(iens)%blk(0,ig)%rh_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%loc(iens)%blk(0,ig)%rh_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%geom(igeom)%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & + if (.not.allocated(bump%hdiag%loc%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc%blk(0,ig)%rh_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%loc%blk(0,ig)%rh_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%loc%blk(0,ig)%rh_c0a(:,:,icmp) + do il0=1,bump%geom%nl0 + do ic0a=1,bump%geom%nc0a + if (bump%geom%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & & fld_c0a(ic0a,il0) = fld_c0a(ic0a,il0)*req end do end do end if found = .true. - case ('loc_rh1','loc_rh1_lr') - if (.not.allocated(bump%hdiag%loc(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(iens)%blk(0,ig)%D11_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%loc(iens)%blk(0,ig)%D11_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%loc(iens)%blk(0,ig)%D11_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%geom(igeom)%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & + case ('loc_rh1') + if (.not.allocated(bump%hdiag%loc%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc%blk(0,ig)%D11_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%loc%blk(0,ig)%D11_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%loc%blk(0,ig)%D11_c0a(:,:,icmp) + do il0=1,bump%geom%nl0 + do ic0a=1,bump%geom%nc0a + if (bump%geom%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & & fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req end do end do found = .true. - case ('loc_rh2','loc_rh2_lr') - if (.not.allocated(bump%hdiag%loc(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(iens)%blk(0,ig)%D22_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%loc(iens)%blk(0,ig)%D22_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%loc(iens)%blk(0,ig)%D22_c0a(:,:,icmp) - do il0=1,bump%geom(igeom)%nl0 - do ic0a=1,bump%geom(igeom)%nc0a - if (bump%geom(igeom)%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & + case ('loc_rh2') + if (.not.allocated(bump%hdiag%loc%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc%blk(0,ig)%D22_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%loc%blk(0,ig)%D22_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%loc%blk(0,ig)%D22_c0a(:,:,icmp) + do il0=1,bump%geom%nl0 + do ic0a=1,bump%geom%nc0a + if (bump%geom%gmask_c0a(ic0a,il0).and.bump%mpl%msv%isnot(fld_c0a(ic0a,il0))) & & fld_c0a(ic0a,il0) = sqrt(fld_c0a(ic0a,il0))*req end do end do found = .true. - case ('loc_rhc','loc_rhc_lr') - if (.not.allocated(bump%hdiag%loc(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(iens)%blk(0,ig)%D12_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%loc(iens)%blk(0,ig)%D12_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%loc(iens)%blk(0,ig)%D12_c0a(:,:,icmp) + case ('loc_rhc') + if (.not.allocated(bump%hdiag%loc%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc%blk(0,ig)%D12_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%loc%blk(0,ig)%D12_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%loc%blk(0,ig)%D12_c0a(:,:,icmp) found = .true. - case ('loc_rv','loc_rv_lr') + case ('loc_rv') if (bump%nam%forced_radii) then - do il0=1,bump%geom(igeom)%nl0 + do il0=1,bump%geom%nl0 fld_c0a(:,il0) = bump%nam%rv(il0,ig) end do else - if (.not.allocated(bump%hdiag%loc(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(iens)%blk(0,ig)%rv_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (icmp>size(bump%hdiag%loc(iens)%blk(0,ig)%rv_c0a,3)) fld_c0a = zero - fld_c0a = bump%hdiag%loc(iens)%blk(0,ig)%rv_c0a(:,:,icmp) + if (.not.allocated(bump%hdiag%loc%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc%blk(0,ig)%rv_c0a)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (icmp>size(bump%hdiag%loc%blk(0,ig)%rv_c0a,3)) fld_c0a = zero + fld_c0a = bump%hdiag%loc%blk(0,ig)%rv_c0a(:,:,icmp) end if found = .true. - case ('dirac_diag_loc','dirac_diag_loc_lr') - if (.not.allocated(bump%hdiag%loc(iens)%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - fld_c0a = bump%hdiag%loc(iens)%dirac(:,:,iv) + case ('dirac_diag_loc') + if (.not.allocated(bump%hdiag%loc%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + fld_c0a = bump%hdiag%loc%dirac(:,:,iv) + found = .true. + case ('hyb_coef_1') + if (.not.allocated(bump%hdiag%loc%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc%blk(0,ig)%hyb_coef_1_c0a)) call bump%mpl%abort('${subr}$', & + & trim(param)//' is not allocated') + fld_c0a = bump%hdiag%loc%blk(0,ig)%hyb_coef_1_c0a found = .true. - case ('hyb_coef_ens','hyb_coef_sta','hyb_coef_ens_lr') - if (.not.allocated(bump%hdiag%loc(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - if (.not.allocated(bump%hdiag%loc(iens)%blk(0,ig)%hyb_coef_c0a)) call bump%mpl%abort('${subr}$', & + case ('hyb_coef_2') + if (.not.allocated(bump%hdiag%loc%blk)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + if (.not.allocated(bump%hdiag%loc%blk(0,ig)%hyb_coef_2_c0a)) call bump%mpl%abort('${subr}$', & & trim(param)//' is not allocated') - fld_c0a = bump%hdiag%loc(iens)%blk(0,ig)%hyb_coef_c0a + fld_c0a = bump%hdiag%loc%blk(0,ig)%hyb_coef_2_c0a found = .true. end select ! Select parameter from nicas select case (trim(param)) - case ('nicas_norm','nicas_norm_lr') - if (.not.allocated(bump%nicas(iens)%blk)) call bump%mpl%abort('${subr}$',trim(param)//' block is not allocated') - if (.not.allocated(bump%nicas(iens)%blk(ig)%cmp)) call bump%mpl%abort('${subr}$',trim(param)//' component is not allocated') - if (icmp>size(bump%nicas(iens)%blk(ig)%cmp)) fld_c0a = zero - if (.not.allocated(bump%nicas(iens)%blk(ig)%cmp(icmp)%norm)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - fld_c0a = bump%nicas(iens)%blk(ig)%cmp(icmp)%norm + case ('nicas_norm') + if (.not.allocated(bump%nicas%blk)) call bump%mpl%abort('${subr}$',trim(param)//' block is not allocated') + if (.not.allocated(bump%nicas%blk(ig)%cmp)) call bump%mpl%abort('${subr}$',trim(param)//' component is not allocated') + if (icmp>size(bump%nicas%blk(ig)%cmp)) fld_c0a = zero + if (.not.allocated(bump%nicas%blk(ig)%cmp(icmp)%norm)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + fld_c0a = bump%nicas%blk(ig)%cmp(icmp)%norm found = .true. - case ('dirac_nicas','dirac_nicas_lr') - if (.not.allocated(bump%nicas(iens)%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') - fld_c0a = bump%nicas(iens)%dirac(:,:,iv) + case ('dirac_nicas') + if (.not.allocated(bump%nicas%dirac)) call bump%mpl%abort('${subr}$',trim(param)//' is not allocated') + fld_c0a = bump%nicas%dirac(:,:,iv) found = .true. end select ! Copy to model grid - call bump%geom(igeom)%copy_c0a_to_mga(bump%mpl,fld_c0a,fld_mga(:,:,iv)) + call bump%geom%copy_c0a_to_mga(bump%mpl,fld_c0a,fld_mga(:,:,iv)) ! Check that parameters was found if (.not.found) call bump%mpl%abort('${subr}$','parameter '//trim(param)//' not found') end do ! Create fieldset -call fieldset%init(bump%mpl,bump%geom(igeom)%afunctionspace_mg,bump%geom(igeom)%gmask_mga,bump%nam%variables(1:bump%nam%nv), & +call fieldset%init(bump%mpl,bump%geom%afunctionspace_mg,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv), & & bump%nam%ilev2d,bump%nam%var2d) ! Fortran array to fieldset @@ -2053,13 +1872,13 @@ write(bump%mpl%info,'(a7,a,i1)') '','Set number of components: ',ncmp call bump%mpl%flush ! Check allocation -if (.not.allocated(bump%cmat(1)%blk)) allocate(bump%cmat(1)%blk(bump%nam%ng)) -if (.not.allocated(bump%nicas(1)%blk)) allocate(bump%nicas(1)%blk(bump%nam%ng)) +if (.not.allocated(bump%cmat%blk)) allocate(bump%cmat%blk(bump%nam%ng)) +if (.not.allocated(bump%nicas%blk)) allocate(bump%nicas%blk(bump%nam%ng)) ! Copy do ig=1,bump%nam%ng - bump%cmat(1)%blk(ig)%ncmp = ncmp - bump%nicas(1)%blk(ig)%ncmp = ncmp + bump%cmat%blk(ig)%ncmp = ncmp + bump%nicas%blk(ig)%ncmp = ncmp end do ! Probe out @@ -2083,8 +1902,8 @@ type(fieldset_type),intent(inout) :: fieldset !< Fieldset ! Local variables integer :: ic0a,il0,iv,ig,jg -real(kind_real) :: fld_c0a(bump%geom(1)%nc0a,bump%geom(1)%nl0) -real(kind_real) :: fld_mga(bump%geom(1)%nmga,bump%geom(1)%nl0,bump%nam%nv) +real(kind_real) :: fld_c0a(bump%geom%nc0a,bump%geom%nl0) +real(kind_real) :: fld_mga(bump%geom%nmga,bump%geom%nl0,bump%nam%nv) logical :: found ! Set name @@ -2100,7 +1919,7 @@ write(bump%mpl%info,'(a7,a,a)') '','Set ',trim(param) call bump%mpl%flush ! Set fieldset metadata -call fieldset%set_metadata(bump%mpl,bump%geom(1)%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) +call fieldset%set_metadata(bump%mpl,bump%geom%gmask_mga,bump%nam%variables(1:bump%nam%nv),bump%nam%ilev2d,bump%nam%var2d) ! Fieldset to Fortran array call fieldset%to_array(bump%mpl,fld_mga) @@ -2124,49 +1943,49 @@ do iv=1,bump%nam%nv select case (trim(param)) case ('stddev','var','m4','sampling_mask_field','gsi_ref') case ('a','rh','rh1','rh2','rhc','rv') - if (.not.allocated(bump%cmat(1)%blk)) allocate(bump%cmat(1)%blk(bump%nam%ng)) + if (.not.allocated(bump%cmat%blk)) allocate(bump%cmat%blk(bump%nam%ng)) case ('nicas_a','nicas_norm') - if (.not.allocated(bump%nicas(1)%blk)) then + if (.not.allocated(bump%nicas%blk)) then ! Not allocated yet: allocate and set the number of components to one - allocate(bump%nicas(1)%blk(bump%nam%ng)) + allocate(bump%nicas%blk(bump%nam%ng)) do jg=1,bump%nam%ng - bump%nicas(1)%blk(jg)%ncmp = 1 + bump%nicas%blk(jg)%ncmp = 1 end do end if - if ((.not.allocated(bump%nicas(1)%blk(ig)%cmp))) allocate(bump%nicas(1)%blk(ig)%cmp(bump%nicas(1)%blk(ig)%ncmp)) + if ((.not.allocated(bump%nicas%blk(ig)%cmp))) allocate(bump%nicas%blk(ig)%cmp(bump%nicas%blk(ig)%ncmp)) case default call bump%mpl%abort('${subr}$','parameter '//trim(param)//' not yet implemented, available input parameters are:'// & & 'stddev, var, m4, sampling_mask_field, gsi_ref, a, rh, rh1, rh2, rhc, rv, nicas_norm') end select ! Copy to model grid - call bump%geom(1)%copy_mga_to_c0a(bump%mpl,fld_mga(:,:,iv),fld_c0a) + call bump%geom%copy_mga_to_c0a(bump%mpl,fld_mga(:,:,iv),fld_c0a) ! Select parameter from var select case (trim(param)) case ('sampling_mask_field') - if (.not.allocated(bump%samp(1)%smask_input_c0a)) allocate(bump%samp(1)%smask_input_c0a(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0,bump%nam%nv)) - bump%samp(1)%smask_input_c0a(:,:,iv) = fld_c0a + if (.not.allocated(bump%samp%smask_input_c0a)) allocate(bump%samp%smask_input_c0a(bump%geom%nc0a, & + & bump%geom%nl0,bump%nam%nv)) + bump%samp%smask_input_c0a(:,:,iv) = fld_c0a found = .true. end select ! Select parameter from var select case (trim(param)) case ('stddev') - if (.not.allocated(bump%var%m2sqrt)) allocate(bump%var%m2sqrt(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) + if (.not.allocated(bump%var%m2sqrt)) allocate(bump%var%m2sqrt(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv)) bump%var%m2sqrt(:,:,iv) = fld_c0a found = .true. case ('var') if (.not.allocated(bump%var%bump_m2)) then - allocate(bump%var%bump_m2(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) + allocate(bump%var%bump_m2(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv)) bump%var%bump_m2 = zero end if bump%var%bump_m2(:,:,iv) = bump%var%bump_m2(:,:,iv)+fld_c0a found = .true. case ('m4') if (.not.allocated(bump%var%bump_m4)) then - allocate(bump%var%bump_m4(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) + allocate(bump%var%bump_m4(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv)) bump%var%bump_m4 = zero end if bump%var%bump_m4(:,:,iv) = bump%var%bump_m4(:,:,iv)+fld_c0a @@ -2176,7 +1995,7 @@ do iv=1,bump%nam%nv ! Select parameter from hdiag select case (trim(param)) case('gsi_ref') - if (.not.allocated(bump%hdiag%gsi_ref)) allocate(bump%hdiag%gsi_ref(bump%geom(1)%nc0a,bump%geom(1)%nl0,bump%nam%nv)) + if (.not.allocated(bump%hdiag%gsi_ref)) allocate(bump%hdiag%gsi_ref(bump%geom%nc0a,bump%geom%nl0,bump%nam%nv)) bump%hdiag%gsi_ref(:,:,iv) = fld_c0a found = .true. end select @@ -2184,68 +2003,68 @@ do iv=1,bump%nam%nv ! Select parameter from cmat select case (trim(param)) case ('a') - if (.not.allocated(bump%cmat(1)%blk(ig)%bump_a)) allocate(bump%cmat(1)%blk(ig)%bump_a(bump%geom(1)%nc0a,bump%geom(1)%nl0, & - & bump%cmat(1)%blk(ig)%ncmp)) - bump%cmat(1)%blk(ig)%bump_a(:,:,icmp) = fld_c0a + if (.not.allocated(bump%cmat%blk(ig)%bump_a)) allocate(bump%cmat%blk(ig)%bump_a(bump%geom%nc0a,bump%geom%nl0, & + & bump%cmat%blk(ig)%ncmp)) + bump%cmat%blk(ig)%bump_a(:,:,icmp) = fld_c0a found = .true. case ('rh') - if (.not.allocated(bump%cmat(1)%blk(ig)%bump_rh)) allocate(bump%cmat(1)%blk(ig)%bump_rh(bump%geom(1)%nc0a,bump%geom(1)%nl0, & - & bump%cmat(1)%blk(ig)%ncmp)) - bump%cmat(1)%blk(ig)%bump_rh(:,:,icmp) = fld_c0a - do il0=1,bump%geom(1)%nl0 - do ic0a=1,bump%geom(1)%nc0a - if (bump%mpl%msv%isnot(bump%cmat(1)%blk(ig)%bump_rh(ic0a,il0,icmp))) & - & bump%cmat(1)%blk(ig)%bump_rh(ic0a,il0,icmp) = bump%cmat(1)%blk(ig)%bump_rh(ic0a,il0,icmp)/req + if (.not.allocated(bump%cmat%blk(ig)%bump_rh)) allocate(bump%cmat%blk(ig)%bump_rh(bump%geom%nc0a,bump%geom%nl0, & + & bump%cmat%blk(ig)%ncmp)) + bump%cmat%blk(ig)%bump_rh(:,:,icmp) = fld_c0a + do il0=1,bump%geom%nl0 + do ic0a=1,bump%geom%nc0a + if (bump%mpl%msv%isnot(bump%cmat%blk(ig)%bump_rh(ic0a,il0,icmp))) & + & bump%cmat%blk(ig)%bump_rh(ic0a,il0,icmp) = bump%cmat%blk(ig)%bump_rh(ic0a,il0,icmp)/req end do end do found = .true. case ('rh1') - if (.not.allocated(bump%cmat(1)%blk(ig)%bump_D11)) allocate(bump%cmat(1)%blk(ig)%bump_D11(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0,bump%cmat(1)%blk(ig)%ncmp)) - bump%cmat(1)%blk(ig)%bump_D11(:,:,icmp) = fld_c0a - do il0=1,bump%geom(1)%nl0 - do ic0a=1,bump%geom(1)%nc0a - if (bump%mpl%msv%isnot(bump%cmat(1)%blk(ig)%bump_D11(ic0a,il0,icmp))) & - & bump%cmat(1)%blk(ig)%bump_D11(ic0a,il0,icmp) = (bump%cmat(1)%blk(ig)%bump_D11(ic0a,il0,icmp)/req)**2 + if (.not.allocated(bump%cmat%blk(ig)%bump_D11)) allocate(bump%cmat%blk(ig)%bump_D11(bump%geom%nc0a, & + & bump%geom%nl0,bump%cmat%blk(ig)%ncmp)) + bump%cmat%blk(ig)%bump_D11(:,:,icmp) = fld_c0a + do il0=1,bump%geom%nl0 + do ic0a=1,bump%geom%nc0a + if (bump%mpl%msv%isnot(bump%cmat%blk(ig)%bump_D11(ic0a,il0,icmp))) & + & bump%cmat%blk(ig)%bump_D11(ic0a,il0,icmp) = (bump%cmat%blk(ig)%bump_D11(ic0a,il0,icmp)/req)**2 end do end do found = .true. case ('rh2') - if (.not.allocated(bump%cmat(1)%blk(ig)%bump_D22)) allocate(bump%cmat(1)%blk(ig)%bump_D22(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0,bump%cmat(1)%blk(ig)%ncmp)) - bump%cmat(1)%blk(ig)%bump_D22(:,:,icmp) = fld_c0a - do il0=1,bump%geom(1)%nl0 - do ic0a=1,bump%geom(1)%nc0a - if (bump%mpl%msv%isnot(bump%cmat(1)%blk(ig)%bump_D22(ic0a,il0,icmp))) & - & bump%cmat(1)%blk(ig)%bump_D22(ic0a,il0,icmp) = (bump%cmat(1)%blk(ig)%bump_D22(ic0a,il0,icmp)/req)**2 + if (.not.allocated(bump%cmat%blk(ig)%bump_D22)) allocate(bump%cmat%blk(ig)%bump_D22(bump%geom%nc0a, & + & bump%geom%nl0,bump%cmat%blk(ig)%ncmp)) + bump%cmat%blk(ig)%bump_D22(:,:,icmp) = fld_c0a + do il0=1,bump%geom%nl0 + do ic0a=1,bump%geom%nc0a + if (bump%mpl%msv%isnot(bump%cmat%blk(ig)%bump_D22(ic0a,il0,icmp))) & + & bump%cmat%blk(ig)%bump_D22(ic0a,il0,icmp) = (bump%cmat%blk(ig)%bump_D22(ic0a,il0,icmp)/req)**2 end do end do found = .true. case ('rhc') - if (.not.allocated(bump%cmat(1)%blk(ig)%bump_D12)) allocate(bump%cmat(1)%blk(ig)%bump_D12(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0,bump%cmat(1)%blk(ig)%ncmp)) - bump%cmat(1)%blk(ig)%bump_D12(:,:,icmp) = fld_c0a + if (.not.allocated(bump%cmat%blk(ig)%bump_D12)) allocate(bump%cmat%blk(ig)%bump_D12(bump%geom%nc0a, & + & bump%geom%nl0,bump%cmat%blk(ig)%ncmp)) + bump%cmat%blk(ig)%bump_D12(:,:,icmp) = fld_c0a found = .true. case ('rv') - if (.not.allocated(bump%cmat(1)%blk(ig)%bump_rv)) allocate(bump%cmat(1)%blk(ig)%bump_rv(bump%geom(1)%nc0a,bump%geom(1)%nl0, & - & bump%cmat(1)%blk(ig)%ncmp)) - bump%cmat(1)%blk(ig)%bump_rv(:,:,icmp) = fld_c0a + if (.not.allocated(bump%cmat%blk(ig)%bump_rv)) allocate(bump%cmat%blk(ig)%bump_rv(bump%geom%nc0a,bump%geom%nl0, & + & bump%cmat%blk(ig)%ncmp)) + bump%cmat%blk(ig)%bump_rv(:,:,icmp) = fld_c0a found = .true. end select ! Select parameter from nicas select case (trim(param)) case ('nicas_a') - if (icmp>size(bump%nicas(1)%blk(ig)%cmp)) call bump%mpl%abort('${subr}$','component index is too large') - if (.not.allocated(bump%nicas(1)%blk(ig)%cmp(icmp)%a)) allocate(bump%nicas(1)%blk(ig)%cmp(icmp)%a(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0)) - bump%nicas(1)%blk(ig)%cmp(icmp)%a = fld_c0a + if (icmp>size(bump%nicas%blk(ig)%cmp)) call bump%mpl%abort('${subr}$','component index is too large') + if (.not.allocated(bump%nicas%blk(ig)%cmp(icmp)%a)) allocate(bump%nicas%blk(ig)%cmp(icmp)%a(bump%geom%nc0a, & + & bump%geom%nl0)) + bump%nicas%blk(ig)%cmp(icmp)%a = fld_c0a found = .true. case ('nicas_norm') - if (icmp>size(bump%nicas(1)%blk(ig)%cmp)) call bump%mpl%abort('${subr}$','component index is too large') - if (.not.allocated(bump%nicas(1)%blk(ig)%cmp(icmp)%norm)) allocate(bump%nicas(1)%blk(ig)%cmp(icmp)%norm(bump%geom(1)%nc0a, & - & bump%geom(1)%nl0)) - bump%nicas(1)%blk(ig)%cmp(icmp)%norm = fld_c0a + if (icmp>size(bump%nicas%blk(ig)%cmp)) call bump%mpl%abort('${subr}$','component index is too large') + if (.not.allocated(bump%nicas%blk(ig)%cmp(icmp)%norm)) allocate(bump%nicas%blk(ig)%cmp(icmp)%norm(bump%geom%nc0a, & + & bump%geom%nl0)) + bump%nicas%blk(ig)%cmp(icmp)%norm = fld_c0a found = .true. end select @@ -2279,32 +2098,14 @@ class(bump_type),intent(inout) :: bump !< BUMP @:probe_in() ! Release memory -if (allocated(bump%cmat)) then - call bump%cmat(1)%partial_dealloc - call bump%cmat(2)%partial_dealloc -end if -if (allocated(bump%ens)) then - call bump%ens(1)%partial_dealloc - call bump%ens(2)%partial_dealloc -end if -if (allocated(bump%geom)) then - call bump%geom(1)%partial_dealloc - call bump%geom(2)%partial_dealloc -end if +call bump%cmat%partial_dealloc +call bump%ens%partial_dealloc +call bump%geom%partial_dealloc call bump%gsi%dealloc call bump%hdiag%partial_dealloc -if (allocated(bump%mom)) then - call bump%mom(1)%partial_dealloc - call bump%mom(2)%partial_dealloc -end if -if (allocated(bump%nicas)) then - call bump%nicas(1)%partial_dealloc - call bump%nicas(2)%partial_dealloc -end if -if (allocated(bump%samp)) then - call bump%samp(1)%dealloc - call bump%samp(2)%dealloc -end if +call bump%mom%partial_dealloc +call bump%nicas%partial_dealloc +call bump%samp%dealloc call bump%var%partial_dealloc call bump%vbal%partial_dealloc @@ -2341,38 +2142,14 @@ call bump%mpl%flush call registry%report(bump%mpl) ! Release memory -if (allocated(bump%cmat)) then - call bump%cmat(1)%dealloc - call bump%cmat(2)%dealloc - deallocate(bump%cmat) -end if -if (allocated(bump%ens)) then - call bump%ens(1)%dealloc - call bump%ens(2)%dealloc - deallocate(bump%ens) -end if -if (allocated(bump%geom)) then - call bump%geom(1)%dealloc - call bump%geom(2)%dealloc - deallocate(bump%geom) -end if +call bump%cmat%dealloc +call bump%ens%dealloc +call bump%geom%dealloc call bump%gsi%dealloc call bump%hdiag%dealloc -if (allocated(bump%mom)) then - call bump%mom(1)%dealloc - call bump%mom(2)%dealloc - deallocate(bump%mom) -end if -if (allocated(bump%nicas)) then - call bump%nicas(1)%dealloc - call bump%nicas(2)%dealloc - deallocate(bump%nicas) -end if -if (allocated(bump%samp)) then - call bump%samp(1)%dealloc - call bump%samp(2)%dealloc - deallocate(bump%samp) -end if +call bump%mom%dealloc +call bump%nicas%dealloc +call bump%samp%dealloc call bump%var%dealloc call bump%vbal%dealloc diff --git a/src/saber/bump/type_bump.h b/src/saber/bump/type_bump.h index f9fc2ef84..70cb0f595 100644 --- a/src/saber/bump/type_bump.h +++ b/src/saber/bump/type_bump.h @@ -25,17 +25,14 @@ extern "C" { const atlas::field::FieldSetImpl *, const eckit::Configuration &, eckit::Channel *, eckit::Channel *); - void bump_dual_resolution_setup_f90(int &, - const atlas::functionspace::FunctionSpaceImpl *, - const atlas::field::FieldSetImpl *); void bump_add_member_f90(const int &, const atlas::field::FieldSetImpl *, - const int &, const int &); + const int &); void bump_update_vbal_cov_f90(const int &, const atlas::field::FieldSetImpl *, const int &); void bump_update_var_f90(const int &, const atlas::field::FieldSetImpl *, const int &); void bump_update_mom_f90(const int &, const atlas::field::FieldSetImpl *, - const int &, const int &); + const int &); void bump_run_drivers_f90(const int &); void bump_apply_vbal_f90(const int &, const atlas::field::FieldSetImpl *); void bump_apply_vbal_inv_f90(const int &, const atlas::field::FieldSetImpl *); diff --git a/src/saber/bump/type_bump_interface.F90 b/src/saber/bump/type_bump_interface.F90 index e71827c29..3abb4d694 100644 --- a/src/saber/bump/type_bump_interface.F90 +++ b/src/saber/bump/type_bump_interface.F90 @@ -82,43 +82,11 @@ subroutine bump_create_c(key_bump,c_comm,c_afunctionspace,c_afieldset,c_conf,c_i end subroutine bump_create_c -!---------------------------------------------------------------------- -! Subroutine: bump_dual_resolution_setup_c -!> Second geometry -!---------------------------------------------------------------------- -subroutine bump_dual_resolution_setup_c(key_bump,c_afunctionspace,c_afieldset) bind(c,name='bump_dual_resolution_setup_f90') - -implicit none - -! Passed variables -integer(c_int),intent(inout) :: key_bump !< BUMP -type(c_ptr),intent(in),value :: c_afunctionspace !< ATLAS function space -type(c_ptr),intent(in),value :: c_afieldset !< ATLAS fieldset containing geometry elements - -! Local variables -type(bump_type),pointer :: bump -type(atlas_functionspace) :: f_afunctionspace -type(fieldset_type) :: f_fieldset - -! Interface -call bump_registry%get(key_bump,bump) -f_afunctionspace = atlas_functionspace(c_afunctionspace) -f_fieldset = atlas_fieldset(c_afieldset) - -! Call Fortran -call bump%dual_resolution_setup(f_afunctionspace,f_fieldset) - -! Release memory -call f_afunctionspace%final() -call f_fieldset%final() - -end subroutine bump_dual_resolution_setup_c - !---------------------------------------------------------------------- ! Subroutine: bump_add_member_c -!> Add member into bump%ens[1,2] +!> Add member into bump%ens !---------------------------------------------------------------------- -subroutine bump_add_member_c(key_bump,c_afieldset,ie,iens) bind(c,name='bump_add_member_f90') +subroutine bump_add_member_c(key_bump,c_afieldset,ie) bind(c,name='bump_add_member_f90') implicit none @@ -126,7 +94,6 @@ subroutine bump_add_member_c(key_bump,c_afieldset,ie,iens) bind(c,name='bump_add integer(c_int),intent(in) :: key_bump !< BUMP type(c_ptr),intent(in),value :: c_afieldset !< ATLAS fieldset pointer integer(c_int),intent(in) :: ie !< Member index -integer(c_int),intent(in) :: iens !< Ensemble index ! Local variables type(bump_type),pointer :: bump @@ -137,7 +104,7 @@ subroutine bump_add_member_c(key_bump,c_afieldset,ie,iens) bind(c,name='bump_add f_fieldset = atlas_fieldset(c_afieldset) ! Call Fortran -call bump%add_member(f_fieldset,ie,iens) +call bump%add_member(f_fieldset,ie) ! Release memory call f_fieldset%final() @@ -206,7 +173,7 @@ end subroutine bump_update_var_c ! Subroutine: bump_update_mom_c !> Update moments, one member at a time !---------------------------------------------------------------------- -subroutine bump_update_mom_c(key_bump,c_afieldset,ie,iens) bind(c,name='bump_update_mom_f90') +subroutine bump_update_mom_c(key_bump,c_afieldset,ie) bind(c,name='bump_update_mom_f90') implicit none @@ -214,7 +181,6 @@ subroutine bump_update_mom_c(key_bump,c_afieldset,ie,iens) bind(c,name='bump_upd integer(c_int),intent(in) :: key_bump !< BUMP type(c_ptr),intent(in),value :: c_afieldset !< ATLAS fieldset pointer integer(c_int),intent(in) :: ie !< Member index -integer(c_int),intent(in) :: iens !< Ensemble index ! Local variables type(bump_type),pointer :: bump @@ -225,7 +191,7 @@ subroutine bump_update_mom_c(key_bump,c_afieldset,ie,iens) bind(c,name='bump_upd f_fieldset = atlas_fieldset(c_afieldset) ! Call Fortran -call bump%update_mom(f_fieldset,ie,iens) +call bump%update_mom(f_fieldset,ie) ! Release memory call f_fieldset%final() diff --git a/src/saber/bump/type_bump_parameters.cc b/src/saber/bump/type_bump_parameters.cc index 1166b7c0f..34b949a74 100644 --- a/src/saber/bump/type_bump_parameters.cc +++ b/src/saber/bump/type_bump_parameters.cc @@ -66,6 +66,8 @@ void bump_config_init_f90(eckit::LocalConfiguration * config) { param(ioDef.fname_samp, ioConf); // Vertical balance file param(ioDef.fname_vbal, ioConf); + // Averaged statistics file + param(ioDef.fname_avg, ioConf); // NICAS file param(ioDef.fname_nicas, ioConf); // Psichitouv transform file @@ -78,18 +80,12 @@ void bump_config_init_f90(eckit::LocalConfiguration * config) { // Drivers section DriversDef driversDef; eckit::LocalConfiguration driversConf; - // Compute covariance, ensemble 1 - param(driversDef.compute_cov1, driversConf); - // Compute covariance, ensemble 2 - param(driversDef.compute_cov2, driversConf); - // Compute correlation, ensemble 1 - param(driversDef.compute_cor1, driversConf); - // Compute correlation, ensemble 2 - param(driversDef.compute_cor2, driversConf); - // Compute localization, ensemble 1 - param(driversDef.compute_loc1, driversConf); - // Compute localization, ensemble 2 - param(driversDef.compute_loc2, driversConf); + // Compute covariance + param(driversDef.compute_cov, driversConf); + // Compute correlation + param(driversDef.compute_cor, driversConf); + // Compute localization + param(driversDef.compute_loc, driversConf); // Compute hybrid weights param(driversDef.compute_hyb, driversConf); // Hybrid term source ('randomized static' or 'lowres ensemble') @@ -128,6 +124,8 @@ void bump_config_init_f90(eckit::LocalConfiguration * config) { param(driversDef.load_mom, driversConf); // Write sampling moments param(driversDef.write_mom, driversConf); + // Write averaged statistics + param(driversDef.write_avg, driversConf); // Write HDIAG diagnostics param(driversDef.write_hdiag, driversConf); // Write HDIAG components detail @@ -186,14 +184,10 @@ void bump_config_init_f90(eckit::LocalConfiguration * config) { // Ensemble sizes section EnsembleSizesDef ensembleSizesDef; eckit::LocalConfiguration ensembleSizesConf; - // Ensemble 1 size - param(ensembleSizesDef.ens1_ne, ensembleSizesConf); - // Ensemble 1 sub-ensembles number - param(ensembleSizesDef.ens1_nsub, ensembleSizesConf); - // Ensemble 2 size - param(ensembleSizesDef.ens2_ne, ensembleSizesConf); - // Ensemble 2 sub-ensembles number - param(ensembleSizesDef.ens2_nsub, ensembleSizesConf); + // Ensemble size + param(ensembleSizesDef.ens_ne, ensembleSizesConf); + // Ensemble sub-ensembles number + param(ensembleSizesDef.ens_nsub, ensembleSizesConf); // Sampling section SamplingDef samplingDef; @@ -231,8 +225,6 @@ void bump_config_init_f90(eckit::LocalConfiguration * config) { eckit::LocalConfiguration diagnosticsConf; // Ensemble size param(diagnosticsDef.ne, diagnosticsConf); - // Ensemble size of the hybrid term - param(diagnosticsDef.ne_lr, diagnosticsConf); // Gaussian approximation for asymptotic quantities param(diagnosticsDef.gau_approx, diagnosticsConf); // Localization option ('default', 'from_squared_correlation', 'nice_with_table' and diff --git a/src/saber/bump/type_bump_parameters.h b/src/saber/bump/type_bump_parameters.h index 3ddf17224..eb631e7e3 100644 --- a/src/saber/bump/type_bump_parameters.h +++ b/src/saber/bump/type_bump_parameters.h @@ -81,6 +81,10 @@ struct IODef { std::pair fname_vbal = std::make_pair("overriding vertical balance file", ""); + // Averaged statistics file + std::pair fname_avg = + std::make_pair("overriding averaged statistics file", ""); + // Universe radius file std::pair fname_universe_radius = std::make_pair("overriding universe radius file", ""); @@ -104,30 +108,18 @@ struct IODef { // Drivers section struct DriversDef { - // Compute covariance, ensemble 1 - std::pair compute_cov1 = + // Compute covariance + std::pair compute_cov = std::make_pair("compute covariance", false); - // Compute covariance, ensemble 2 - std::pair compute_cov2 = - std::make_pair("compute lowres covariance", false); - - // Compute correlation, ensemble 1 - std::pair compute_cor1 = + // Compute correlation + std::pair compute_cor = std::make_pair("compute correlation", false); - // Compute correlation, ensemble 2 - std::pair compute_cor2 = - std::make_pair("compute lowres correlation", false); - - // Compute localization, ensemble 1 - std::pair compute_loc1 = + // Compute localization + std::pair compute_loc = std::make_pair("compute localization", false); - // Compute localization, ensemble 2 - std::pair compute_loc2 = - std::make_pair("compute lowres localization", false); - // Compute hybrid weights std::pair compute_hyb = std::make_pair("compute hybrid weights", false); @@ -204,6 +196,10 @@ struct DriversDef { std::pair write_mom = std::make_pair("write moments", false); + // Write averaged statistics + std::pair write_avg = + std::make_pair("write averaged statistics", false); + // Write HDIAG diagnostics std::pair write_hdiag = std::make_pair("write diagnostics", false); @@ -310,21 +306,13 @@ struct ModelDef { // Ensemble sizes section struct EnsembleSizesDef { - // Ensemble 1 size - std::pair ens1_ne = + // Ensemble size + std::pair ens_ne = std::make_pair("total ensemble size", 0); - // Ensemble 1 sub-ensembles number - std::pair ens1_nsub = + // Ensemble sub-ensembles number + std::pair ens_nsub = std::make_pair("sub-ensembles", 1); - - // Ensemble 2 size - std::pair ens2_ne = - std::make_pair("total lowres ensemble size", 0); - - // Ensemble 2 sub-ensembles number - std::pair ens2_nsub = - std::make_pair("lowres sub-ensembles", 1); }; // Mask parameters @@ -404,10 +392,6 @@ struct DiagnosticsDef { std::pair ne = std::make_pair("target ensemble size", 0); - // Ensemble size of the hybrid term - std::pair ne_lr = - std::make_pair("target lowres ensemble size", 0); - // Gaussian approximation for asymptotic quantities std::pair gau_approx = std::make_pair("gaussian approximation", false); diff --git a/src/saber/bump/type_diag.fypp b/src/saber/bump/type_diag.fypp index e72e8c1b1..5489db797 100644 --- a/src/saber/bump/type_diag.fypp +++ b/src/saber/bump/type_diag.fypp @@ -193,7 +193,7 @@ logical,intent(in),optional :: hyb_coef_only !< Interpolate hybridization coef integer :: ig,il0,ic2a,icmp real(kind_real) :: a_tot real(kind_real),allocatable :: a_c2a(:,:,:),rh_c2a(:,:,:),D11_c2a(:,:,:),D22_c2a(:,:,:),D12_c2a(:,:,:),rv_c2a(:,:,:) -real(kind_real),allocatable :: hyb_coef_c2a(:,:) +real(kind_real),allocatable :: hyb_coef_1_c2a(:,:),hyb_coef_2_c2a(:,:) logical :: lhyb_coef_only ! Set name @@ -217,7 +217,8 @@ if (nam%local_diag) then ! Allocation if (lhyb_coef_only) then - allocate(hyb_coef_c2a(samp%nc2a,geom%nl0)) + allocate(hyb_coef_1_c2a(samp%nc2a,geom%nl0)) + allocate(hyb_coef_2_c2a(samp%nc2a,geom%nl0)) else allocate(a_c2a(samp%nc2a,geom%nl0,diag%blk(0,ig)%ncmp)) if (nam%nc4==1) then @@ -233,7 +234,8 @@ if (nam%local_diag) then do ic2a=1,samp%nc2a ! Copy data if (lhyb_coef_only) then - hyb_coef_c2a(ic2a,il0) = diag%blk(ic2a,ig)%hyb_coef(il0) + hyb_coef_1_c2a(ic2a,il0) = diag%blk(ic2a,ig)%hyb_coef_1(il0) + hyb_coef_2_c2a(ic2a,il0) = diag%blk(ic2a,ig)%hyb_coef_2(il0) else do icmp=1,diag%blk(0,ig)%ncmp a_c2a(ic2a,il0,icmp) = diag%blk(ic2a,ig)%a_l0(il0,icmp) @@ -250,9 +252,13 @@ if (nam%local_diag) then ! Apply global bounds if (lhyb_coef_only) then - if (mpl%msv%isnot(hyb_coef_c2a(ic2a,il0)).and.mpl%msv%isnot(diag%blk(0,ig)%hyb_coef(il0))) then - if ((hyb_coef_c2a(ic2a,il0)diag%blk(0,ig)%hyb_coef(il0)*bound)) hyb_coef_c2a(ic2a,il0) = mpl%msv%valr + if (mpl%msv%isnot(hyb_coef_1_c2a(ic2a,il0)).and.mpl%msv%isnot(diag%blk(0,ig)%hyb_coef_1(il0))) then + if ((hyb_coef_1_c2a(ic2a,il0)diag%blk(0,ig)%hyb_coef_1(il0)*bound)) hyb_coef_1_c2a(ic2a,il0) = mpl%msv%valr + end if + if (mpl%msv%isnot(hyb_coef_2_c2a(ic2a,il0)).and.mpl%msv%isnot(diag%blk(0,ig)%hyb_coef_2(il0))) then + if ((hyb_coef_2_c2a(ic2a,il0)diag%blk(0,ig)%hyb_coef_2(il0)*bound)) hyb_coef_2_c2a(ic2a,il0) = mpl%msv%valr end if else do icmp=1,diag%blk(0,ig)%ncmp @@ -286,8 +292,10 @@ if (nam%local_diag) then if (nam%diag_rhflt>zero) then ! Median filter to remove extreme values, average filter to smooth data if (lhyb_coef_only) then - call samp%diag_filter(mpl,'median',nam%diag_rhflt,hyb_coef_c2a(:,il0)) - call samp%diag_filter(mpl,'average',nam%diag_rhflt,hyb_coef_c2a(:,il0)) + call samp%diag_filter(mpl,'median',nam%diag_rhflt,hyb_coef_1_c2a(:,il0)) + call samp%diag_filter(mpl,'average',nam%diag_rhflt,hyb_coef_1_c2a(:,il0)) + call samp%diag_filter(mpl,'median',nam%diag_rhflt,hyb_coef_2_c2a(:,il0)) + call samp%diag_filter(mpl,'average',nam%diag_rhflt,hyb_coef_2_c2a(:,il0)) else do icmp=1,diag%blk(0,ig)%ncmp call samp%diag_filter(mpl,'median',nam%diag_rhflt,a_c2a(:,il0,icmp)) @@ -311,7 +319,8 @@ if (nam%local_diag) then ! Fill missing values if (lhyb_coef_only) then - call samp%diag_fill(mpl,hyb_coef_c2a(:,il0)) + call samp%diag_fill(mpl,hyb_coef_1_c2a(:,il0)) + call samp%diag_fill(mpl,hyb_coef_2_c2a(:,il0)) else do icmp=1,diag%blk(0,ig)%ncmp call samp%diag_fill(mpl,a_c2a(:,il0,icmp)) @@ -329,7 +338,8 @@ if (nam%local_diag) then ! Copy data do ic2a=1,samp%nc2a if (lhyb_coef_only) then - diag%blk(ic2a,ig)%hyb_coef(il0) = hyb_coef_c2a(ic2a,il0) + diag%blk(ic2a,ig)%hyb_coef_1(il0) = hyb_coef_1_c2a(ic2a,il0) + diag%blk(ic2a,ig)%hyb_coef_2(il0) = hyb_coef_2_c2a(ic2a,il0) else do icmp=1,diag%blk(0,ig)%ncmp diag%blk(ic2a,ig)%a_l0(il0,icmp) = a_c2a(ic2a,il0,icmp) @@ -358,7 +368,8 @@ if (nam%local_diag) then ! Release memory if (lhyb_coef_only) then - deallocate(hyb_coef_c2a) + deallocate(hyb_coef_1_c2a) + deallocate(hyb_coef_2_c2a) else deallocate(a_c2a) if (nam%nc4==1) then @@ -382,7 +393,8 @@ if (nam%diag_rvflt>zero) then ! Vertical filtering do ic2a=0,diag%nc2a if (lhyb_coef_only) then - call ver_smooth(mpl,geom%nl0,geom%vert_coordavg,nam%diag_rvflt,diag%blk(ic2a,ig)%hyb_coef) + call ver_smooth(mpl,geom%nl0,geom%vert_coordavg,nam%diag_rvflt,diag%blk(ic2a,ig)%hyb_coef_1) + call ver_smooth(mpl,geom%nl0,geom%vert_coordavg,nam%diag_rvflt,diag%blk(ic2a,ig)%hyb_coef_2) else do icmp=1,diag%blk(0,ig)%ncmp call ver_smooth(mpl,geom%nl0,geom%vert_coordavg,nam%diag_rvflt,diag%blk(ic2a,ig)%a_l0(:,icmp)) @@ -468,10 +480,15 @@ do ig=1,nam%ng end do call mpl%f_comm%allreduce(rmse,fckit_mpi_sum()) call mpl%f_comm%allreduce(norm,fckit_mpi_sum()) - if (norm>zero) rmse = sqrt(rmse/real(norm,kind_real)) - write(mpl%test,'(a13,a,a,a,e15.8,a,i8,a)') '','Block ',trim(nam%group_names(ig)),': ',rmse, & + if (norm>zero) then + rmse = sqrt(rmse/real(norm,kind_real)) + write(mpl%test,'(a13,a,a,a,e15.8,a,i8,a)') '','Block ',trim(nam%group_names(ig)),': ',rmse, & & ' for ',norm,' diagnostic points' - call mpl%flush + call mpl%flush + else + write(mpl%test,'(a13,a,a,a)') '','Block ',trim(nam%group_names(ig)),': not sampled' + call mpl%flush + end if ! Detail for multi-component case if (nam%write_hdiag_detail) then @@ -546,7 +563,7 @@ do ig=1,nam%ng ! Allocation if (lhyb_coef_only) then ! Interpolate hybridization coeffient - n = 1 + n = 2 else ! Interpolate fit parameters n = 3*diag%blk(0,ig)%ncmp @@ -559,7 +576,8 @@ do ig=1,nam%ng end if allocate(fld_c0a(geom%nc0a,geom%nl0,n)) if (lhyb_coef_only) then - allocate(diag%blk(0,ig)%hyb_coef_c0a(geom%nc0a,geom%nl0)) + allocate(diag%blk(0,ig)%hyb_coef_1_c0a(geom%nc0a,geom%nl0)) + allocate(diag%blk(0,ig)%hyb_coef_2_c0a(geom%nc0a,geom%nl0)) else allocate(diag%blk(0,ig)%a_c0a(geom%nc0a,geom%nl0,diag%blk(0,ig)%ncmp)) allocate(diag%blk(0,ig)%rh_c0a(geom%nc0a,geom%nl0,diag%blk(0,ig)%ncmp)) @@ -583,7 +601,8 @@ do ig=1,nam%ng do ic2a=ic2amin,ic2amax ! Select profile if (lhyb_coef_only) then - profile(:,1) = diag%blk(ic2a,ig)%hyb_coef + profile(:,1) = diag%blk(ic2a,ig)%hyb_coef_1 + profile(:,2) = diag%blk(ic2a,ig)%hyb_coef_2 else i = 0 do icmp=1,diag%blk(0,ig)%ncmp @@ -644,7 +663,8 @@ do ig=1,nam%ng ! Copy field if (lhyb_coef_only) then - diag%blk(0,ig)%hyb_coef_c0a = fld_c0a(:,:,1) + diag%blk(0,ig)%hyb_coef_1_c0a = fld_c0a(:,:,1) + diag%blk(0,ig)%hyb_coef_2_c0a = fld_c0a(:,:,2) else i = 0 do icmp=1,diag%blk(0,ig)%ncmp @@ -1162,7 +1182,7 @@ end subroutine diag_localization ! Subroutine: diag_hybridization !> Compute diagnostic hybridization !---------------------------------------------------------------------- -subroutine diag_hybridization(diag,mpl,nam,geom,samp,avg,loc1,prefix) +subroutine diag_hybridization(diag,mpl,nam,geom,samp,avg_1,avg_2,prefix) implicit none @@ -1170,10 +1190,10 @@ implicit none class(diag_type),intent(inout) :: diag !< Diagnostic (hybridization) type(mpl_type),intent(inout) :: mpl !< MPI data type(nam_type),intent(in) :: nam !< Namelist -type(geom_type),intent(in) :: geom(2) !< Geometry +type(geom_type),intent(in) :: geom !< Geometry type(samp_type),intent(in) :: samp !< Sampling -type(avg_type),intent(in) :: avg(2) !< Averaged statistics -type(diag_type),intent(inout) :: loc1 !< Localization of ensemble 1 +type(avg_type),intent(in) :: avg_1 !< Averaged statistics, 1 +type(avg_type),intent(in) :: avg_2 !< Averaged statistics, 2 character(len=*),intent(in) :: prefix !< Diagnostic prefix ! Local variables @@ -1186,7 +1206,7 @@ integer :: ig,ic2a,il0 @:probe_in() ! Allocation -call diag%alloc(mpl,nam,geom(2),samp,prefix) +call diag%alloc(mpl,nam,geom,samp,prefix) write(mpl%info,'(a10,a)') '','Compute and fit hybridization:' call mpl%flush @@ -1199,7 +1219,7 @@ do ig=1,nam%ng do ic2a=0,diag%nc2a ! Compute hybridization - call diag%blk(ic2a,ig)%hybridization(mpl,nam,geom,avg(1)%blk(ic2a,ig),avg(2)%blk(ic2a,ig),loc1%blk(ic2a,ig)) + call diag%blk(ic2a,ig)%hybridization(mpl,nam,geom,avg_1%grp(ic2a,ig),avg_2%grp(ic2a,ig)) ! Update call mpl%prog_print(ic2a+1) @@ -1208,12 +1228,10 @@ do ig=1,nam%ng end do ! Filter hybridization weights -call loc1%filter(mpl,nam,geom(1),samp,.true.) -call diag%filter(mpl,nam,geom(2),samp,.true.) +call diag%filter(mpl,nam,geom,samp,.true.) ! Interpolate hybridization weights (at ensemble 1 resolution) -call loc1%interp(mpl,nam,geom(1),samp,.true.) -call diag%interp(mpl,nam,geom(1),samp,.true.) +call diag%interp(mpl,nam,geom,samp,.true.) ! Print results write(mpl%info,'(a10,a)') '','Results:' @@ -1222,10 +1240,10 @@ do ig=1,nam%ng write(mpl%info,'(a13,a,a,a)') '','Block ',trim(nam%group_names(ig)),':' call mpl%flush - do il0=1,geom(2)%nl0 - if (mpl%msv%isnot(loc1%blk(0,ig)%hyb_coef(il0)).and.mpl%msv%isnot(diag%blk(0,ig)%hyb_coef(il0))) then - write(mpl%test,'(a16,a,i3,a,a,f4.2,a,f4.2,a)') '','Level: ',il0,' ~> hybrid coefficients: ', & - & trim(mpl%peach),loc1%blk(0,ig)%hyb_coef(il0),trim(mpl%black)//' / '//trim(mpl%peach),diag%blk(0,ig)%hyb_coef(il0),trim(mpl%black) + do il0=1,geom%nl0 + if (mpl%msv%isnot(diag%blk(0,ig)%hyb_coef_1(il0)).and.mpl%msv%isnot(diag%blk(0,ig)%hyb_coef_2(il0))) then + write(mpl%test,'(a16,a,i3,a,a,f4.2,a,f4.2,a)') '','Level: ',il0,' ~> hybrid coefficients: ',trim(mpl%peach), & + & diag%blk(0,ig)%hyb_coef_1(il0),trim(mpl%black)//' / '//trim(mpl%peach),diag%blk(0,ig)%hyb_coef_2(il0),trim(mpl%black) call mpl%flush end if end do diff --git a/src/saber/bump/type_diag_blk.fypp b/src/saber/bump/type_diag_blk.fypp index 65b711e0c..a61748b97 100644 --- a/src/saber/bump/type_diag_blk.fypp +++ b/src/saber/bump/type_diag_blk.fypp @@ -48,8 +48,10 @@ type diag_blk_type real(kind_real),allocatable :: D22_l0(:,:) !< Horizontal direct tensor, coefficient 22, profiles real(kind_real),allocatable :: D12_l0(:,:) !< Horizontal direct tensor, coefficient 12 (normalized), profiles real(kind_real),allocatable :: rv_l0(:,:) !< Vertical support radius, profiles - real(kind_real),allocatable :: hyb_coef_raw(:) !< Raw hybrid coefficient - real(kind_real),allocatable :: hyb_coef(:) !< Hybrid coefficient + real(kind_real),allocatable :: hyb_coef_1_raw(:) !< Raw hybrid coefficient 1 + real(kind_real),allocatable :: hyb_coef_1(:) !< Hybrid coefficient 1 + real(kind_real),allocatable :: hyb_coef_2_raw(:) !< Raw hybrid coefficient 2 + real(kind_real),allocatable :: hyb_coef_2(:) !< Hybrid coefficient 2 real(kind_real),allocatable :: a_c0a(:,:,:) !< Amplitudes, subset Sc0, halo A real(kind_real),allocatable :: rh_c0a(:,:,:) !< Horizontal support radius, subset Sc0, halo A @@ -57,7 +59,8 @@ type diag_blk_type real(kind_real),allocatable :: D22_c0a(:,:,:) !< Horizontal direct tensor, component 22, subset Sc0, halo A real(kind_real),allocatable :: D12_c0a(:,:,:) !< Horizontal direct tensor, component 12 (normalized), subset Sc0, halo A real(kind_real),allocatable :: rv_c0a(:,:,:) !< Vertical support radius, subset Sc0, halo A - real(kind_real),allocatable :: hyb_coef_c0a(:,:) !< Hybrid coefficient, subset Sc0, halo A + real(kind_real),allocatable :: hyb_coef_1_c0a(:,:) !< Hybrid coefficient 1, subset Sc0, halo A + real(kind_real),allocatable :: hyb_coef_2_c0a(:,:) !< Hybrid coefficient 2, subset Sc0, halo A contains procedure :: alloc => diag_blk_alloc procedure :: partial_dealloc => diag_blk_partial_dealloc @@ -116,8 +119,10 @@ if ((ic2a==0).or.nam%local_diag) then allocate(diag_blk%valid(nam%nc3,nam%nc4,nam%nl0r,geom%nl0)) allocate(diag_blk%vert_coord(geom%nl0)) allocate(diag_blk%fit(nam%nc3,nam%nc4,nam%nl0r,geom%nl0)) - allocate(diag_blk%hyb_coef_raw(geom%nl0)) - allocate(diag_blk%hyb_coef(geom%nl0)) + allocate(diag_blk%hyb_coef_1_raw(geom%nl0)) + allocate(diag_blk%hyb_coef_1(geom%nl0)) + allocate(diag_blk%hyb_coef_2_raw(geom%nl0)) + allocate(diag_blk%hyb_coef_2(geom%nl0)) end if ! Initialization @@ -125,8 +130,10 @@ if ((ic2a==0).or.nam%local_diag) then diag_blk%raw = mpl%msv%valr diag_blk%valid = mpl%msv%valr diag_blk%fit = mpl%msv%valr - diag_blk%hyb_coef_raw = mpl%msv%valr - diag_blk%hyb_coef = mpl%msv%valr + diag_blk%hyb_coef_1_raw = mpl%msv%valr + diag_blk%hyb_coef_1 = mpl%msv%valr + diag_blk%hyb_coef_2_raw = mpl%msv%valr + diag_blk%hyb_coef_2 = mpl%msv%valr end if ! Define weight to approximate the Frobenius norm @@ -178,8 +185,10 @@ if (allocated(diag_blk%D11_l0)) deallocate(diag_blk%D11_l0) if (allocated(diag_blk%D22_l0)) deallocate(diag_blk%D22_l0) if (allocated(diag_blk%D12_l0)) deallocate(diag_blk%D12_l0) if (allocated(diag_blk%rv_l0)) deallocate(diag_blk%rv_l0) -if (allocated(diag_blk%hyb_coef_raw)) deallocate(diag_blk%hyb_coef_raw) -if (allocated(diag_blk%hyb_coef)) deallocate(diag_blk%hyb_coef) +if (allocated(diag_blk%hyb_coef_1_raw)) deallocate(diag_blk%hyb_coef_1_raw) +if (allocated(diag_blk%hyb_coef_1)) deallocate(diag_blk%hyb_coef_1) +if (allocated(diag_blk%hyb_coef_2_raw)) deallocate(diag_blk%hyb_coef_2_raw) +if (allocated(diag_blk%hyb_coef_2)) deallocate(diag_blk%hyb_coef_2) ! Probe out @:probe_out() @@ -210,7 +219,8 @@ if (allocated(diag_blk%D11_c0a)) deallocate(diag_blk%D11_c0a) if (allocated(diag_blk%D22_c0a)) deallocate(diag_blk%D22_c0a) if (allocated(diag_blk%D12_c0a)) deallocate(diag_blk%D12_c0a) if (allocated(diag_blk%rv_c0a)) deallocate(diag_blk%rv_c0a) -if (allocated(diag_blk%hyb_coef_c0a)) deallocate(diag_blk%hyb_coef_c0a) +if (allocated(diag_blk%hyb_coef_1_c0a)) deallocate(diag_blk%hyb_coef_1_c0a) +if (allocated(diag_blk%hyb_coef_2_c0a)) deallocate(diag_blk%hyb_coef_2_c0a) ! Probe out @:probe_out() @@ -240,7 +250,7 @@ integer,intent(in) :: nl0_2_id !< NetCDF ID ! Local variables integer :: grpid,ncmp_id,raw_id,raw_hor_id,raw_zs_id,valid_id,l0rl0_to_l0_id integer :: fit_id,fit_hor_id,fit_zs_id,fit_detail_id,fit_detail_hor_id,fit_detail_zs_id -integer :: a_l0_id,rh_l0_id,D11_l0_id,D22_l0_id,D12_l0_id,rv_l0_id,hyb_coef_raw_id,hyb_coef_id +integer :: a_l0_id,rh_l0_id,D11_l0_id,D22_l0_id,D12_l0_id,rv_l0_id,hyb_coef_1_raw_id,hyb_coef_1_id,hyb_coef_2_raw_id,hyb_coef_2_id integer :: il0,jl0r,jl0,jl0rz,icmp ! Set name @@ -292,8 +302,10 @@ if (mpl%msv%isanynot(diag_blk%fit)) then rv_l0_id = define_var(mpl,grpid,'rv_l0','real',(/nl0_1_id,ncmp_id/)) end if end if -if (mpl%msv%isanynot(diag_blk%hyb_coef_raw)) hyb_coef_raw_id = define_var(mpl,grpid,'hyb_coef_raw','real',(/nl0_1_id/)) -if (mpl%msv%isanynot(diag_blk%hyb_coef)) hyb_coef_id = define_var(mpl,grpid,'hyb_coef','real',(/nl0_1_id/)) +if (mpl%msv%isanynot(diag_blk%hyb_coef_1_raw)) hyb_coef_1_raw_id = define_var(mpl,grpid,'hyb_coef_1_raw','real',(/nl0_1_id/)) +if (mpl%msv%isanynot(diag_blk%hyb_coef_1)) hyb_coef_1_id = define_var(mpl,grpid,'hyb_coef_1','real',(/nl0_1_id/)) +if (mpl%msv%isanynot(diag_blk%hyb_coef_2_raw)) hyb_coef_2_raw_id = define_var(mpl,grpid,'hyb_coef_2_raw','real',(/nl0_1_id/)) +if (mpl%msv%isanynot(diag_blk%hyb_coef_2)) hyb_coef_2_id = define_var(mpl,grpid,'hyb_coef_2','real',(/nl0_1_id/)) ! Write variables if (mpl%msv%isanynot(diag_blk%raw)) then @@ -357,8 +369,10 @@ if (mpl%msv%isanynot(diag_blk%fit)) then call put_var(mpl,grpid,rv_l0_id,diag_blk%rv_l0) end if end if -if (mpl%msv%isanynot(diag_blk%hyb_coef_raw)) call put_var(mpl,grpid,hyb_coef_raw_id,diag_blk%hyb_coef_raw) -if (mpl%msv%isanynot(diag_blk%hyb_coef)) call put_var(mpl,grpid,hyb_coef_id,diag_blk%hyb_coef) +if (mpl%msv%isanynot(diag_blk%hyb_coef_1_raw)) call put_var(mpl,grpid,hyb_coef_1_raw_id,diag_blk%hyb_coef_1_raw) +if (mpl%msv%isanynot(diag_blk%hyb_coef_1)) call put_var(mpl,grpid,hyb_coef_1_id,diag_blk%hyb_coef_1) +if (mpl%msv%isanynot(diag_blk%hyb_coef_2_raw)) call put_var(mpl,grpid,hyb_coef_2_raw_id,diag_blk%hyb_coef_2_raw) +if (mpl%msv%isanynot(diag_blk%hyb_coef_2)) call put_var(mpl,grpid,hyb_coef_2_id,diag_blk%hyb_coef_2) ! End associate end associate @@ -1029,8 +1043,9 @@ else if (nam%loc_option=='default') then !$omp end parallel do end if -! Hybrid weight -diag_blk%hyb_coef = mpl%msv%valr +! Hybrid weights +diag_blk%hyb_coef_1 = mpl%msv%valr +diag_blk%hyb_coef_2 = mpl%msv%valr ! Probe out @:probe_out() @@ -1041,7 +1056,7 @@ end subroutine diag_blk_localization ! Subroutine: diag_blk_hybridization !> Diag_blk hybridization !---------------------------------------------------------------------- -subroutine diag_blk_hybridization(diag_blk,mpl,nam,geom,avg1_blk,avg2_blk,loc1_blk) +subroutine diag_blk_hybridization(diag_blk,mpl,nam,geom,avg1_blk,avg2_blk) implicit none @@ -1049,10 +1064,9 @@ implicit none class(diag_blk_type),intent(inout) :: diag_blk !< Diagnostic block (hybridization) type(mpl_type),intent(inout) :: mpl !< MPI data type(nam_type),intent(in) :: nam !< Namelist -type(geom_type),intent(in) :: geom(2) !< Geometry +type(geom_type),intent(in) :: geom !< Geometry type(avg_blk_type),intent(in) :: avg1_blk !< Averaged statistics block for ensemble 1 type(avg_blk_type),intent(in) :: avg2_blk !< Averaged statistics block for ensemble 2 -type(diag_blk_type),intent(inout) :: loc1_blk !< Localization block for ensemble 1 ! Local variables integer :: il0,jl0r,jl0,jc3,jc4 @@ -1064,7 +1078,7 @@ real(kind_real) :: a,bc,d,e,f,num,num_1,num_2,den,wgt ! Probe in @:probe_in() -do il0=1,geom(2)%nl0 +do il0=1,geom%nl0 ! Compute hybrid weights terms a = zero bc = zero @@ -1072,22 +1086,22 @@ do il0=1,geom(2)%nl0 e = zero f = zero do jl0r=1,nam%nl0r - jl0 = geom(2)%l0rl0_to_l0(jl0r,il0) + jl0 = geom%l0rl0_to_l0(jl0r,il0) do jc4=1,nam%nc4 do jc3=1,nam%nc3 - if (mpl%msv%isnot(loc1_blk%fit(jc3,jc4,jl0r,il0)).and.mpl%msv%isnot(avg1_blk%m11sq(jc3,jc4,jl0r,il0)) & + if (mpl%msv%isnot(diag_blk%fit(jc3,jc4,jl0r,il0)).and.mpl%msv%isnot(avg1_blk%m11sq(jc3,jc4,jl0r,il0)) & & .and.mpl%msv%isnot(avg1_blk%m11(jc3,jc4,jl0r,il0)).and.mpl%msv%isnot(avg2_blk%m11(jc3,jc4,jl0r,il0)) & & .and.mpl%msv%isnot(avg2_blk%m11sq(jc3,jc4,jl0r,il0)).and.mpl%msv%isnot(avg1_blk%m11asysq(jc3,jc4,jl0r,il0))) then wgt = one ! TODO(Benjamin): should be diag_blk%frob_wgt(jc3,jc4,jl0r,il0) - a = a+wgt*loc1_blk%fit(jc3,jc4,jl0r,il0)**2*avg1_blk%m11sq(jc3,jc4,jl0r,il0) - bc = bc+wgt*loc1_blk%fit(jc3,jc4,jl0r,il0)*avg1_blk%m11(jc3,jc4,jl0r,il0)*avg2_blk%m11(jc3,jc4,jl0r,il0) + a = a+wgt*diag_blk%fit(jc3,jc4,jl0r,il0)**2*avg1_blk%m11sq(jc3,jc4,jl0r,il0) + bc = bc+wgt*diag_blk%fit(jc3,jc4,jl0r,il0)*avg1_blk%m11(jc3,jc4,jl0r,il0)*avg2_blk%m11(jc3,jc4,jl0r,il0) select case (nam%hybrid_source) case ('randomized static') d = d+wgt*avg2_blk%m11(jc3,jc4,jl0r,il0)**2 case ('lowres ensemble') d = d+wgt*avg2_blk%m11sq(jc3,jc4,jl0r,il0) end select - e = e+wgt*loc1_blk%fit(jc3,jc4,jl0r,il0)*avg1_blk%m11asysq(jc3,jc4,jl0r,il0) + e = e+wgt*diag_blk%fit(jc3,jc4,jl0r,il0)*avg1_blk%m11asysq(jc3,jc4,jl0r,il0) f = f+wgt*avg1_blk%m11(jc3,jc4,jl0r,il0)*avg2_blk%m11(jc3,jc4,jl0r,il0) end if end do @@ -1101,28 +1115,28 @@ do il0=1,geom(2)%nl0 if (den>zero) then ! Raw hybrid weights - loc1_blk%hyb_coef_raw(il0) = num_1/den - diag_blk%hyb_coef_raw(il0) = num_2/den + diag_blk%hyb_coef_1_raw(il0) = num_1/den + diag_blk%hyb_coef_2_raw(il0) = num_2/den ! Normalization (to keep a correct variance) - num = avg1_blk%m11(1,1,geom(2)%il0rz(il0),il0) - den = loc1_blk%hyb_coef_raw(il0)*avg1_blk%m11(1,1,geom(2)%il0rz(il0),il0) & - & +diag_blk%hyb_coef_raw(il0)*avg2_blk%m11(1,1,geom(2)%il0rz(il0),il0) + num = avg1_blk%m11(1,1,geom%il0rz(il0),il0) + den = diag_blk%hyb_coef_1_raw(il0)*avg1_blk%m11(1,1,geom%il0rz(il0),il0) & + & +diag_blk%hyb_coef_2_raw(il0)*avg2_blk%m11(1,1,geom%il0rz(il0),il0) if (den>zero) then ! Hybrid weights - loc1_blk%hyb_coef(il0) = loc1_blk%hyb_coef_raw(il0)*num/den - diag_blk%hyb_coef(il0) = diag_blk%hyb_coef_raw(il0)*num/den + diag_blk%hyb_coef_1(il0) = diag_blk%hyb_coef_1_raw(il0)*num/den + diag_blk%hyb_coef_2(il0) = diag_blk%hyb_coef_2_raw(il0)*num/den else ! Missing values - loc1_blk%hyb_coef(il0) = mpl%msv%valr - diag_blk%hyb_coef(il0) = mpl%msv%valr + diag_blk%hyb_coef_1(il0) = mpl%msv%valr + diag_blk%hyb_coef_2(il0) = mpl%msv%valr end if else ! Missing values - loc1_blk%hyb_coef_raw(il0) = mpl%msv%valr - diag_blk%hyb_coef_raw(il0) = mpl%msv%valr - loc1_blk%hyb_coef(il0) = mpl%msv%valr - diag_blk%hyb_coef(il0) = mpl%msv%valr + diag_blk%hyb_coef_1_raw(il0) = mpl%msv%valr + diag_blk%hyb_coef_1(il0) = mpl%msv%valr + diag_blk%hyb_coef_2_raw(il0) = mpl%msv%valr + diag_blk%hyb_coef_2(il0) = mpl%msv%valr end if end do diff --git a/src/saber/bump/type_hdiag.fypp b/src/saber/bump/type_hdiag.fypp index e868dcb2d..ad94e9b7f 100644 --- a/src/saber/bump/type_hdiag.fypp +++ b/src/saber/bump/type_hdiag.fypp @@ -26,10 +26,10 @@ implicit none ! Hybrid diagnostics derived type type hdiag_type - type(avg_type),allocatable :: avg(:) !< Averaged statistics - type(diag_type),allocatable :: cov(:) !< Covariance - type(diag_type),allocatable :: cor(:) !< Correlation - type(diag_type),allocatable :: loc(:) !< Localization + type(avg_type) :: avg !< Averaged statistics + type(diag_type) :: cov !< Covariance + type(diag_type) :: cor !< Correlation + type(diag_type) :: loc !< Localization real(kind_real),allocatable :: gsi_ref(:,:,:) !< GSI reference field contains procedure :: partial_dealloc => hdiag_partial_dealloc @@ -62,22 +62,10 @@ class(hdiag_type),intent(inout) :: hdiag !< Hybrid diagnostics @:probe_in() ! Release memory -if (allocated(hdiag%avg)) then - call hdiag%avg(1)%dealloc - call hdiag%avg(2)%dealloc -end if -if (allocated(hdiag%cov)) then - call hdiag%cov(1)%partial_dealloc - call hdiag%cov(2)%partial_dealloc -end if -if (allocated(hdiag%cor)) then - call hdiag%cor(1)%partial_dealloc - call hdiag%cor(2)%partial_dealloc -end if -if (allocated(hdiag%loc)) then - call hdiag%loc(1)%partial_dealloc - call hdiag%loc(2)%partial_dealloc -end if +call hdiag%avg%dealloc +call hdiag%cov%partial_dealloc +call hdiag%cor%partial_dealloc +call hdiag%loc%partial_dealloc if (allocated(hdiag%gsi_ref)) deallocate(hdiag%gsi_ref) ! Probe out @@ -103,11 +91,10 @@ class(hdiag_type),intent(inout) :: hdiag !< Hybrid diagnostics @:probe_in() ! Release memory -call hdiag%partial_dealloc -if (allocated(hdiag%avg)) deallocate(hdiag%avg) -if (allocated(hdiag%cov)) deallocate(hdiag%cov) -if (allocated(hdiag%cor)) deallocate(hdiag%cor) -if (allocated(hdiag%loc)) deallocate(hdiag%loc) +call hdiag%avg%dealloc +call hdiag%cov%dealloc +call hdiag%cor%dealloc +call hdiag%loc%dealloc ! Probe out @:probe_out() @@ -126,8 +113,8 @@ implicit none class(hdiag_type),intent(inout) :: hdiag !< Hybrid diagnostics type(mpl_type),intent(inout) :: mpl !< MPI data type(nam_type),intent(inout) :: nam !< Namelist -type(geom_type),intent(in) :: geom(2) !< Geometry -type(samp_type),intent(in) :: samp(2) !< Sampling +type(geom_type),intent(in) :: geom !< Geometry +type(samp_type),intent(in) :: samp !< Sampling ! Local variables integer :: ncid,grpid,nc3_id,nc4_id,nl0r_id,nl0_1_id,nl0_2_id,disth_id,as_id,vert_coord_id @@ -147,7 +134,7 @@ ic2a(0) = mpl%msv%vali if (mpl%main) ic2a(0) = 0 filename(0) = trim(nam%prefix)//'diag' do ildwv=1,nam%nldwv - ic2a(ildwv) = samp(1)%ldwv_to_c2a(ildwv) + ic2a(ildwv) = samp%ldwv_to_c2a(ildwv) filename(ildwv) = trim(nam%prefix)//'diag_'//trim(nam%name_ldwv(ildwv)) end do @@ -167,8 +154,8 @@ do ildwv=0,nam%nldwv nc3_id = define_dim(mpl,grpid,'nc3',nam%nc3) nc4_id = define_dim(mpl,grpid,'nc4',nam%nc4) nl0r_id = define_dim(mpl,grpid,'nl0r',nam%nl0r) - nl0_1_id = define_dim(mpl,grpid,'nl0_1',geom(1)%nl0) - nl0_2_id = define_dim(mpl,grpid,'nl0_2',geom(1)%nl0) + nl0_1_id = define_dim(mpl,grpid,'nl0_1',geom%nl0) + nl0_2_id = define_dim(mpl,grpid,'nl0_2',geom%nl0) ! Define coordinates disth_id = define_var(mpl,grpid,'disth','real',(/nc3_id/)) @@ -176,25 +163,17 @@ do ildwv=0,nam%nldwv vert_coord_id = define_var(mpl,grpid,'vert_coord','real',(/nl0_1_id/)) ! Write coordinates - call put_var(mpl,grpid,disth_id,geom(1)%disth(1:nam%nc3)) - call put_var(mpl,grpid,as_id,geom(1)%as(1:nam%nc4)) - call put_var(mpl,grpid,vert_coord_id,geom(1)%vert_coordavg) + call put_var(mpl,grpid,disth_id,geom%disth(1:nam%nc3)) + call put_var(mpl,grpid,as_id,geom%as(1:nam%nc4)) + call put_var(mpl,grpid,vert_coord_id,geom%vert_coordavg) - ! Write ensemble 1 correlation - if (nam%compute_cor1) call hdiag%cor(1)%blk(ic2a(ildwv),ig)%write(mpl,nam,geom(1),grpid,nc3_id,nc4_id,nl0r_id, & + ! Write ensemble correlation + if (nam%compute_cor) call hdiag%cor%blk(ic2a(ildwv),ig)%write(mpl,nam,geom,grpid,nc3_id,nc4_id,nl0r_id, & & nl0_1_id,nl0_2_id) - ! Write ensemble 2 correlation - if (nam%compute_cor2) call hdiag%cor(2)%blk(ic2a(ildwv),ig)%write(mpl,nam,geom(2),grpid,nc3_id,nc4_id,nl0r_id, & - & nl0_1_id,nl0_2_id) - - ! Write ensemble 1 localization (and hybrid coefficient) - if (nam%compute_loc1.or.nam%compute_hyb) call hdiag%loc(1)%blk(ic2a(ildwv),ig)%write(mpl,nam,geom(1),grpid, & + ! Write ensemble localization and hybrid coefficient + if (nam%compute_loc.or.nam%compute_hyb) call hdiag%loc%blk(ic2a(ildwv),ig)%write(mpl,nam,geom,grpid, & & nc3_id,nc4_id,nl0r_id,nl0_1_id,nl0_2_id) - - ! Write ensemble 2 localization (and hybrid coefficient) - if (nam%compute_loc2) call hdiag%loc(2)%blk(ic2a(ildwv),ig)%write(mpl,nam,geom(2),grpid,nc3_id,nc4_id,nl0r_id, & - & nl0_1_id,nl0_2_id) end do ! Close file @@ -219,9 +198,12 @@ implicit none class(hdiag_type),intent(inout) :: hdiag !< Hybrid diagnostics type(mpl_type),intent(inout) :: mpl !< MPI data type(nam_type),intent(inout) :: nam !< Namelist -type(geom_type),intent(in) :: geom(2) !< Geometry -type(samp_type),intent(in) :: samp(2) !< Sampling -type(mom_type),intent(in) :: mom(2) !< Moments +type(geom_type),intent(in) :: geom !< Geometry +type(samp_type),intent(in) :: samp !< Sampling +type(mom_type),intent(in) :: mom !< Moments + +! Local variables +type(avg_type) :: avg_hyb ! Set name @:set_name(hdiag_run_hdiag) @@ -229,106 +211,47 @@ type(mom_type),intent(in) :: mom(2) !< Moments ! Probe in @:probe_in() -! Allocation -allocate(hdiag%avg(2)) -allocate(hdiag%cov(2)) -allocate(hdiag%cor(2)) -allocate(hdiag%loc(2)) - -if (nam%compute_cov1.or.nam%compute_cor1.or.nam%compute_loc1.or. & - & nam%compute_cov2.or.nam%compute_cor2.or.nam%compute_loc2) then +if (nam%compute_cov.or.nam%compute_cor.or.nam%compute_loc) then ! Compute statistics write(mpl%info,'(a)') '-------------------------------------------------------------------' call mpl%flush write(mpl%info,'(a)') '--- Compute statistics' call mpl%flush + call hdiag%avg%compute(mpl,nam,geom,samp,mom,nam%ne,'avg1') + if (nam%write_avg) call hdiag%avg%write(mpl,nam,geom,samp) end if -if (nam%compute_cov1.or.nam%compute_cor1.or.nam%compute_loc1) then - ! Ensemble 1 - write(mpl%info,'(a7,a)') '','Ensemble 1:' - call mpl%flush - call hdiag%avg(1)%compute(mpl,nam,geom(1),samp(1),mom(1),nam%ne,'avg1') -end if - -if (nam%compute_cov2.or.nam%compute_cor2.or.nam%compute_loc2) then - ! Ensemble 2 - write(mpl%info,'(a7,a)') '','Ensemble 2:' - call mpl%flush - call hdiag%avg(2)%compute(mpl,nam,geom(2),samp(2),mom(2),nam%ne_lr,'avg2') -end if - -if (nam%compute_cov1.or.nam%compute_cov2) then +if (nam%compute_cov) then write(mpl%info,'(a)') '-------------------------------------------------------------------' call mpl%flush write(mpl%info,'(a)') '--- Compute covariance' call mpl%flush + call hdiag%cov%covariance(mpl,nam,geom,samp,hdiag%avg,'cov') end if -if (nam%compute_cov1) then - ! Ensemble 1 - write(mpl%info,'(a7,a)') '','Ensemble 1:' - call mpl%flush - call hdiag%cov(1)%covariance(mpl,nam,geom(1),samp(1),hdiag%avg(1),'cov1') -end if - -if (nam%compute_cov2) then - ! Ensemble 2 - write(mpl%info,'(a7,a)') '','Ensemble 2:' - call mpl%flush - call hdiag%cov(2)%covariance(mpl,nam,geom(2),samp(2),hdiag%avg(2),'cov2') -end if - -if (nam%compute_cor1.or.nam%compute_cor2) then +if (nam%compute_cor) then write(mpl%info,'(a)') '-------------------------------------------------------------------' call mpl%flush write(mpl%info,'(a)') '--- Compute correlation' call mpl%flush + call hdiag%cor%correlation(mpl,nam,geom,samp,hdiag%avg,'cor') end if -if (nam%compute_cor1) then - ! Compute ensemble 1 correlation - write(mpl%info,'(a7,a)') '','Ensemble 1:' - call mpl%flush - call hdiag%cor(1)%correlation(mpl,nam,geom(1),samp(1),hdiag%avg(1),'cor1') -end if - -if (nam%compute_cor2) then - ! Compute ensemble 2 correlation - write(mpl%info,'(a7,a)') '','Ensemble 2:' - call mpl%flush - call hdiag%cor(2)%correlation(mpl,nam,geom(2),samp(2),hdiag%avg(2),'cor2') -end if - - -if (nam%compute_loc1.or.nam%compute_loc2) then +if (nam%compute_loc) then write(mpl%info,'(a)') '-------------------------------------------------------------------' call mpl%flush write(mpl%info,'(a)') '--- Compute localization' call mpl%flush -end if - -if (nam%compute_loc1) then - ! Ensemble 1 - write(mpl%info,'(a7,a)') '','Ensemble 1:' - call mpl%flush - call hdiag%loc(1)%localization(mpl,nam,geom(1),samp(1),hdiag%avg(1),hdiag%cor(1),nam%ne,'loc1') -end if - -if (nam%compute_loc2) then - ! Ensemble 2 - write(mpl%info,'(a7,a)') '','Ensemble 2:' - call mpl%flush - call hdiag%loc(2)%localization(mpl,nam,geom(2),samp(2),hdiag%avg(2),hdiag%cor(1),nam%ne_lr,'loc2') + call hdiag%loc%localization(mpl,nam,geom,samp,hdiag%avg,hdiag%cor,nam%ne,'loc') end if if (nam%compute_hyb) then - ! Compute hybridization write(mpl%info,'(a)') '-------------------------------------------------------------------' call mpl%flush write(mpl%info,'(a)') '--- Compute hybridization' call mpl%flush - call hdiag%loc(2)%hybridization(mpl,nam,geom,samp(2),hdiag%avg,hdiag%loc(1),'loc2') + call avg_hyb%read(mpl,nam,geom,samp) + call hdiag%loc%hybridization(mpl,nam,geom,samp,hdiag%avg,avg_hyb,'loc') end if ! Write diagnostics @@ -374,9 +297,8 @@ type(diag_type) :: cor_tmp @:probe_in() ! Allocation -allocate(hdiag%cor(2)) -allocate(hdiag%cor(1)%blk(0:0,nam%ng)) -if (nam%check_dirac) allocate(hdiag%cor(1)%dirac(geom%nc0a,geom%nl0,nam%nv)) +allocate(hdiag%cor%blk(0:0,nam%ng)) +if (nam%check_dirac) allocate(hdiag%cor%dirac(geom%nc0a,geom%nl0,nam%nv)) do ig=1,nam%ng ! Variable index @@ -386,37 +308,37 @@ do ig=1,nam%ng end do ! Initialization - hdiag%cor(1)%blk(0,ig)%ncmp = size(gsi%a) - write(mpl%info,'(a7,a,i1)') '','Number of component for GSI: ',hdiag%cor(1)%blk(0,ig)%ncmp + hdiag%cor%blk(0,ig)%ncmp = size(gsi%a) + write(mpl%info,'(a7,a,i1)') '','Number of component for GSI: ',hdiag%cor%blk(0,ig)%ncmp call mpl%flush ! Allocation - allocate(hdiag%cor(1)%blk(0,ig)%a_c0a(geom%nc0a,geom%nl0,hdiag%cor(1)%blk(0,ig)%ncmp)) - allocate(hdiag%cor(1)%blk(0,ig)%rh_c0a(geom%nc0a,geom%nl0,hdiag%cor(1)%blk(0,ig)%ncmp)) - allocate(hdiag%cor(1)%blk(0,ig)%rv_c0a(geom%nc0a,geom%nl0,hdiag%cor(1)%blk(0,ig)%ncmp)) + allocate(hdiag%cor%blk(0,ig)%a_c0a(geom%nc0a,geom%nl0,hdiag%cor%blk(0,ig)%ncmp)) + allocate(hdiag%cor%blk(0,ig)%rh_c0a(geom%nc0a,geom%nl0,hdiag%cor%blk(0,ig)%ncmp)) + allocate(hdiag%cor%blk(0,ig)%rv_c0a(geom%nc0a,geom%nl0,hdiag%cor%blk(0,ig)%ncmp)) - do icmp=1,hdiag%cor(1)%blk(0,ig)%ncmp + do icmp=1,hdiag%cor%blk(0,ig)%ncmp ! Interpolate if (gsi%var2d(iv)) then ! 2D variable - hdiag%cor(1)%blk(0,ig)%rh_c0a(:,:,icmp) = mpl%msv%valr - hdiag%cor(1)%blk(0,ig)%rv_c0a(:,:,icmp) = mpl%msv%valr + hdiag%cor%blk(0,ig)%rh_c0a(:,:,icmp) = mpl%msv%valr + hdiag%cor%blk(0,ig)%rv_c0a(:,:,icmp) = mpl%msv%valr do ic0a=1,geom%nc0a call gsi%interp_lat(mpl,geom%lat_c0a(ic0a),ilatm,ilatp,rlatm,rlatp) - hdiag%cor(1)%blk(0,ig)%rh_c0a(ic0a,nam%ilev2d,icmp) = rlatm*gsi%rh(ilatm,1,icmp,iv)+rlatp*gsi%rh(ilatp,1,icmp,iv) - hdiag%cor(1)%blk(0,ig)%rv_c0a(ic0a,nam%ilev2d,icmp) = zero + hdiag%cor%blk(0,ig)%rh_c0a(ic0a,nam%ilev2d,icmp) = rlatm*gsi%rh(ilatm,1,icmp,iv)+rlatp*gsi%rh(ilatp,1,icmp,iv) + hdiag%cor%blk(0,ig)%rv_c0a(ic0a,nam%ilev2d,icmp) = zero end do else ! 3D variable do ic0a=1,geom%nc0a call gsi%interp_lat(mpl,geom%lat_c0a(ic0a),ilatm,ilatp,rlatm,rlatp) do il0=1,geom%nl0 - hdiag%cor(1)%blk(0,ig)%rh_c0a(ic0a,il0,icmp) = & + hdiag%cor%blk(0,ig)%rh_c0a(ic0a,il0,icmp) = & & rlatm*gsi%rlevm(il0)*gsi%rh(ilatm,gsi%l0_to_levm(il0),icmp,iv) & & +rlatm*gsi%rlevp(il0)*gsi%rh(ilatm,gsi%l0_to_levp(il0),icmp,iv) & & +rlatp*gsi%rlevm(il0)*gsi%rh(ilatp,gsi%l0_to_levm(il0),icmp,iv) & & +rlatp*gsi%rlevp(il0)*gsi%rh(ilatp,gsi%l0_to_levp(il0),icmp,iv) - hdiag%cor(1)%blk(0,ig)%rv_c0a(ic0a,il0,icmp) = & + hdiag%cor%blk(0,ig)%rv_c0a(ic0a,il0,icmp) = & & rlatm*gsi%rlevm(il0)/gsi%rv(ilatm,gsi%l0_to_levm(il0),icmp,iv) & & +rlatm*gsi%rlevp(il0)/gsi%rv(ilatm,gsi%l0_to_levp(il0),icmp,iv) & & +rlatp*gsi%rlevm(il0)/gsi%rv(ilatp,gsi%l0_to_levm(il0),icmp,iv) & @@ -427,18 +349,18 @@ do ig=1,nam%ng ! Amplitude and scaling if (gsi%var2d(iv)) then - hdiag%cor(1)%blk(0,ig)%a_c0a(:,:,icmp) = mpl%msv%valr - hdiag%cor(1)%blk(0,ig)%a_c0a(:,nam%ilev2d,icmp) = gsi%a(icmp) - hdiag%cor(1)%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp) = hdiag%cor(1)%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp)/req + hdiag%cor%blk(0,ig)%a_c0a(:,:,icmp) = mpl%msv%valr + hdiag%cor%blk(0,ig)%a_c0a(:,nam%ilev2d,icmp) = gsi%a(icmp) + hdiag%cor%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp) = hdiag%cor%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp)/req else - hdiag%cor(1)%blk(0,ig)%a_c0a(:,:,icmp) = gsi%a(icmp) - hdiag%cor(1)%blk(0,ig)%rh_c0a(:,:,icmp) = hdiag%cor(1)%blk(0,ig)%rh_c0a(:,:,icmp)/req + hdiag%cor%blk(0,ig)%a_c0a(:,:,icmp) = gsi%a(icmp) + hdiag%cor%blk(0,ig)%rh_c0a(:,:,icmp) = hdiag%cor%blk(0,ig)%rh_c0a(:,:,icmp)/req end if end do end do ! Dirac test -call hdiag%cor(1)%test_dirac(mpl,nam,geom) +call hdiag%cor%test_dirac(mpl,nam,geom) if (nam%check_dirac.and.allocated(hdiag%gsi_ref)) then ! Allocation @@ -450,7 +372,7 @@ if (nam%check_dirac.and.allocated(hdiag%gsi_ref)) then do ig=1,nam%ng ! Initialization - cor_tmp%blk(0,ig)%ncmp = hdiag%cor(1)%blk(0,ig)%ncmp + cor_tmp%blk(0,ig)%ncmp = hdiag%cor%blk(0,ig)%ncmp ! Allocation allocate(cor_tmp%blk(0,ig)%a_c0a(geom%nc0a,geom%nl0,cor_tmp%blk(0,ig)%ncmp)) @@ -458,7 +380,7 @@ if (nam%check_dirac.and.allocated(hdiag%gsi_ref)) then allocate(cor_tmp%blk(0,ig)%rv_c0a(geom%nc0a,geom%nl0,cor_tmp%blk(0,ig)%ncmp)) ! Copy amplitudes - cor_tmp%blk(0,ig)%a_c0a = hdiag%cor(1)%blk(0,ig)%a_c0a + cor_tmp%blk(0,ig)%a_c0a = hdiag%cor%blk(0,ig)%a_c0a end do ! Initialization @@ -478,11 +400,11 @@ if (nam%check_dirac.and.allocated(hdiag%gsi_ref)) then do icmp=1,cor_tmp%blk(0,ig)%ncmp ! Copy and multiply length-scales if (gsi%var2d(iv)) then - cor_tmp%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp) = hdiag%cor(1)%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp)*fac(ifac) - cor_tmp%blk(0,ig)%rv_c0a(:,nam%ilev2d,icmp) = hdiag%cor(1)%blk(0,ig)%rv_c0a(:,nam%ilev2d,icmp)*fac(ifac) + cor_tmp%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp) = hdiag%cor%blk(0,ig)%rh_c0a(:,nam%ilev2d,icmp)*fac(ifac) + cor_tmp%blk(0,ig)%rv_c0a(:,nam%ilev2d,icmp) = hdiag%cor%blk(0,ig)%rv_c0a(:,nam%ilev2d,icmp)*fac(ifac) else - cor_tmp%blk(0,ig)%rh_c0a(:,:,icmp) = hdiag%cor(1)%blk(0,ig)%rh_c0a(:,:,icmp)*fac(ifac) - cor_tmp%blk(0,ig)%rv_c0a(:,:,icmp) = hdiag%cor(1)%blk(0,ig)%rv_c0a(:,:,icmp)*fac(ifac) + cor_tmp%blk(0,ig)%rh_c0a(:,:,icmp) = hdiag%cor%blk(0,ig)%rh_c0a(:,:,icmp)*fac(ifac) + cor_tmp%blk(0,ig)%rv_c0a(:,:,icmp) = hdiag%cor%blk(0,ig)%rv_c0a(:,:,icmp)*fac(ifac) end if end do end do diff --git a/src/saber/bump/type_mom.fypp b/src/saber/bump/type_mom.fypp index 2bb2aef62..1189b66a9 100644 --- a/src/saber/bump/type_mom.fypp +++ b/src/saber/bump/type_mom.fypp @@ -27,7 +27,6 @@ implicit none ! Moments derived type type mom_type ! Moments data - integer :: iens !< Ensemble index integer :: ne !< Ensemble size integer :: nsub !< Number of sub-ensembles type(mom_blk_type),allocatable :: blk(:) !< Moments blocks @@ -63,17 +62,16 @@ contains ! Subroutine: mom_alloc !> Allocation !---------------------------------------------------------------------- -subroutine mom_alloc(mom,nam,geom,ne,nsub,iens) +subroutine mom_alloc(mom,nam,geom,ne,nsub) implicit none ! Passed variables -class(mom_type),intent(inout) :: mom !< Moments -type(nam_type),intent(in) :: nam !< Namelist -type(geom_type),intent(in) :: geom !< Geometry -integer,intent(in) :: ne !< Ensemble size -integer,intent(in) :: nsub !< Number of sub-ensembles -integer,intent(in) :: iens !< Ensemble index +class(mom_type),intent(inout) :: mom !< Moments +type(nam_type),intent(in) :: nam !< Namelist +type(geom_type),intent(in) :: geom !< Geometry +integer,intent(in) :: ne !< Ensemble size +integer,intent(in) :: nsub !< Number of sub-ensembles ! Local variables integer :: iv @@ -87,7 +85,6 @@ integer :: iv ! Set attributes mom%ne = ne mom%nsub = nsub -mom%iens = iens ! Allocation allocate(mom%blk(nam%nv)) @@ -211,7 +208,7 @@ end subroutine mom_dealloc ! Subroutine: mom_read !> Read !---------------------------------------------------------------------- -subroutine mom_read(mom,mpl,nam,geom,samp,ens,iens) +subroutine mom_read(mom,mpl,nam,geom,samp,ens) implicit none @@ -222,7 +219,6 @@ type(nam_type),intent(in) :: nam !< Namelist type(geom_type),intent(in) :: geom !< Geometry type(samp_type),intent(in) :: samp !< Sampling type(ens_type), intent(in) :: ens !< Ensemble -integer,intent(in) :: iens !< Ensemble index ! Local variables integer :: iproc,iprocio @@ -245,11 +241,11 @@ do iproc=1,mpl%nproc if (iproc==iprocio) then ! Read data - call mom%read(mpl,nam,geom,ens,iens,iproc) + call mom%read(mpl,nam,geom,ens,iproc) if (mom%nc1a/=samp%nc1a) call mpl%abort('${subr}$','mom%nc1a is not equal to samp%nc1a') else ! Read data - call mom_tmp%read(mpl,nam,geom,ens,iens,iproc) + call mom_tmp%read(mpl,nam,geom,ens,iproc) ! Send data to task iproc call mom_tmp%send(mpl,nam,geom,iproc) @@ -261,7 +257,7 @@ do iproc=1,mpl%nproc ! Receive data from task iprocio write(mpl%info,'(a10,a,i6,a,i6)') '','Receive moments of task ',iproc,' from task ',iprocio call mpl%flush - call mom%receive(mpl,nam,geom,ens%ne,ens%nsub,iens,iprocio) + call mom%receive(mpl,nam,geom,ens%ne,ens%nsub,iprocio) if (mom%nc1a/=samp%nc1a) call mpl%abort('${subr}$','mom%nc1a is not equal to samp%nc1a') end if end do @@ -278,7 +274,7 @@ end subroutine mom_read ! Subroutine: mom_read_single !> Read, single task !---------------------------------------------------------------------- -subroutine mom_read_single(mom,mpl,nam,geom,ens,iens,iproc) +subroutine mom_read_single(mom,mpl,nam,geom,ens,iproc) implicit none @@ -288,7 +284,6 @@ type(mpl_type),intent(inout) :: mpl !< MPI data type(nam_type),intent(in) :: nam !< Namelist type(geom_type),intent(in) :: geom !< Geometry type(ens_type), intent(in) :: ens !< Ensemble -integer,intent(in) :: iens !< Ensemble index integer,intent(in) :: iproc !< Task index ! Local variables @@ -304,12 +299,8 @@ character(len=1024) :: fname_mom,grpname do isub=1,ens%nsub ! Set file name - write(fname_mom,'(a,a,i6.6,a,i1)') trim(nam%fname_mom_default),'_',isub,'_',iens - if (iens==1) then - if (allocated(nam%fname_mom1)) fname_mom = nam%fname_mom1(isub) - elseif (iens==2) then - if (allocated(nam%fname_mom2)) fname_mom = nam%fname_mom2(isub) - end if + write(fname_mom,'(a,a,i6.6,a,i1)') trim(nam%fname_mom_default),'_',isub + if (allocated(nam%fname_mom)) fname_mom = nam%fname_mom(isub) ! Open file ncid = open_file(mpl,fname_mom,iproc) @@ -320,7 +311,7 @@ do isub=1,ens%nsub ! Allocation if (ens%ne==0) call mpl%abort('${subr}$','ensemble size is zero') - call mom%alloc(nam,geom,ens%ne,ens%nsub,iens) + call mom%alloc(nam,geom,ens%ne,ens%nsub) ! Initialization call mom%init(nam) @@ -395,7 +386,7 @@ do iproc=1,mpl%nproc call mom%write(mpl,nam,geom,iproc) else ! Receive data from task iproc - call mom_tmp%receive(mpl,nam,geom,mom%ne,mom%nsub,mom%iens,iproc) + call mom_tmp%receive(mpl,nam,geom,mom%ne,mom%nsub,iproc) ! Write data call mom_tmp%write(mpl,nam,geom,iproc) @@ -448,12 +439,8 @@ character(len=1024) :: fname_mom,grpname do isub=1,mom%nsub ! Set file name - write(fname_mom,'(a,a,i6.6,a,i1)') trim(nam%fname_mom_default),'_',isub,'_',mom%iens - if (mom%iens==1) then - if (allocated(nam%fname_mom1)) fname_mom = nam%fname_mom1(isub) - elseif (mom%iens==2) then - if (allocated(nam%fname_mom2)) fname_mom = nam%fname_mom2(isub) - end if + write(fname_mom,'(a,a,i6.6,a,i1)') trim(nam%fname_mom_default),'_',isub + if (allocated(nam%fname_mom)) fname_mom = nam%fname_mom(isub) ! Create file ncid = create_file(mpl,fname_mom,iproc) @@ -461,6 +448,12 @@ do isub=1,mom%nsub ! Define or get dimension if (isub==1) nc1a_id = define_dim(mpl,ncid,'nc1a',mom%nc1a) + ! Define or get dimensions + nc3_id = define_dim(mpl,ncid,'nc3',nam%nc3) + nc4_id = define_dim(mpl,ncid,'nc4',nam%nc4) + nl0r_id = define_dim(mpl,ncid,'nl0r',nam%nl0r) + nl0_id = define_dim(mpl,ncid,'nl0',geom%nl0) + do iv=1,nam%nv ! Get group name call nam%alias(nam%variables(iv),grpname) @@ -468,12 +461,6 @@ do isub=1,mom%nsub ! Define group grpid = define_grp(mpl,ncid,grpname) - ! Define or get dimensions - nl0_id = define_dim(mpl,grpid,'nl0',geom%nl0) - nc3_id = define_dim(mpl,grpid,'nc3',nam%nc3) - nc4_id = define_dim(mpl,grpid,'nc4',nam%nc4) - nl0r_id = define_dim(mpl,grpid,'nl0r',nam%nl0r) - ! Define or get variables m2_1_id = define_var(mpl,grpid,'m2_1','real',(/nc1a_id,nl0_id/)) m2_2_id = define_var(mpl,grpid,'m2_2','real',(/nc1a_id,nc3_id,nc4_id,nl0_id/)) @@ -529,20 +516,17 @@ nbufr = 0 ! nc1a nbufi = nbufi+1 -do iv=1,nam%nv - ! m2_1 - nbufr = nbufr+mom%nc1a*geom%nl0*mom%nsub +! m2_1 +nbufr = nbufr+nam%nv*mom%nc1a*geom%nl0*mom%nsub - ! m2_2 - nbufr = nbufr+mom%nc1a*nam%nc3*nam%nc4*geom%nl0*mom%nsub +! m2_2 +nbufr = nbufr+nam%nv*mom%nc1a*nam%nc3*nam%nc4*geom%nl0*mom%nsub - ! m11 - nbufr = nbufr+mom%nc1a*nam%nc3*nam%nc4*nam%nl0r*geom%nl0*mom%nsub - - ! m22 - nbufr = nbufr+mom%nc1a*nam%nc3*nam%nc4*nam%nl0r*geom%nl0*mom%nsub -end do +! m11 +nbufr = nbufr+nam%nv*mom%nc1a*nam%nc3*nam%nc4*nam%nl0r*geom%nl0*mom%nsub +! m22 +nbufr = nbufr+nam%nv*mom%nc1a*nam%nc3*nam%nc4*nam%nl0r*geom%nl0*mom%nsub ! Allocation allocate(bufi(nbufi)) @@ -602,7 +586,7 @@ end subroutine mom_send ! Subroutine: mom_receive !> Receive !---------------------------------------------------------------------- -subroutine mom_receive(mom,mpl,nam,geom,ne,nsub,iens,iproc) +subroutine mom_receive(mom,mpl,nam,geom,ne,nsub,iproc) implicit none @@ -613,7 +597,6 @@ type(nam_type),intent(in) :: nam !< Namelist type(geom_type),intent(in) :: geom !< Geometry integer,intent(in) :: ne !< Ensemble size integer,intent(in) :: nsub !< Number of sub-ensembles -integer,intent(in) :: iens !< Ensemble index integer,intent(in) :: iproc !< Source task ! Local variables @@ -650,7 +633,7 @@ mom%nc1a = bufi(ibufi+1) ibufi = ibufi+1 ! Allocation -call mom%alloc(nam,geom,ne,nsub,iens) +call mom%alloc(nam,geom,ne,nsub) do iv=1,nam%nv ! m2_1 @@ -690,7 +673,7 @@ end subroutine mom_receive ! Subroutine: mom_update !> Update centered moments !---------------------------------------------------------------------- -subroutine mom_update(mom,mpl,nam,geom,samp,fld_c0a,ie,iens) +subroutine mom_update(mom,mpl,nam,geom,samp,fld_c0a,ie) implicit none @@ -702,10 +685,9 @@ type(geom_type),intent(in) :: geom !< Geometry type(samp_type),intent(in) :: samp !< Sampling real(kind_real),intent(in) :: fld_c0a(geom%nc0a,geom%nl0,nam%nv) !< Field integer,intent(in) :: ie !< Member index -integer,intent(in) :: iens !< Ensemble index ! Local variables -integer :: ens_ne,ens_nsub,isub,ie_sub,jl0r,jl0,il0,il0ic1,il0ic3,jc3,jc4,ic1a,iv,jc0a,idir +integer :: isub,ie_sub,jl0r,jl0,il0,il0ic1,il0ic3,jc3,jc4,ic1a,iv,jc0a,idir real(kind_real) :: fac1,fac2,fac3,fac4,fac5,fac_norm_cov,fac_norm_m22,cor_norm real(kind_real) :: fld_c0b(samp%nc0b,geom%nl0,nam%nv),fld_c0c(samp%nc0c,geom%nl0,nam%nv) real(kind_real) :: fld_c1a(samp%nc1a,geom%nl0) @@ -724,15 +706,8 @@ write(mpl%info,'(a)') '--- Update moments' call mpl%flush ! Indices -if (iens==1) then - ens_ne = nam%ens1_ne - ens_nsub = nam%ens1_nsub -elseif (iens==2) then - ens_ne = nam%ens2_ne - ens_nsub = nam%ens2_nsub -end if -isub = (ie-1)/(ens_ne/ens_nsub)+1 -ie_sub = ie-(isub-1)*ens_ne/ens_nsub +isub = (ie-1)/(nam%ens_ne/nam%ens_nsub)+1 +ie_sub = ie-(isub-1)*nam%ens_ne/nam%ens_nsub ! Computation factors fac1 = one/real(ie_sub,kind_real) @@ -744,7 +719,7 @@ fac5 = real(ie_sub-1,kind_real)/real(ie_sub,kind_real) if (ie==1) then ! Allocation mom%nc1a = samp%nc1a - call mom%alloc(nam,geom,ens_ne,ens_nsub,iens) + call mom%alloc(nam,geom,nam%ens_ne,nam%ens_nsub) ! Initialization call mom%init(nam) @@ -980,7 +955,7 @@ end subroutine mom_update ! Subroutine: mom_compute !> Compute centered moments !---------------------------------------------------------------------- -subroutine mom_compute(mom,mpl,nam,geom,samp,ens,iens) +subroutine mom_compute(mom,mpl,nam,geom,samp,ens) implicit none @@ -991,7 +966,6 @@ type(nam_type),intent(in) :: nam !< Namelist type(geom_type),intent(in) :: geom !< Geometry type(samp_type),intent(in) :: samp !< Sampling type(ens_type), intent(inout) :: ens !< Ensemble -integer,intent(in) :: iens !< Ensemble index ! Local variables integer :: ie,ie_sub,jl0r,jl0,il0,il0ic1,il0ic3,isub,jc3,jc4,ic1a,iv,jc0a,idir @@ -1008,7 +982,7 @@ real(kind_real),allocatable :: fld_c3a(:,:,:,:),wgt_dir(:),m2(:,:,:) ! Allocation mom%nc1a = samp%nc1a -call mom%alloc(nam,geom,ens%ne,ens%nsub,iens) +call mom%alloc(nam,geom,ens%ne,ens%nsub) if (nam%check_dirac) then allocate(wgt_dir(geom%ndir)) allocate(m2(geom%nc0a,geom%nl0,nam%nv)) diff --git a/src/saber/bump/type_nam.fypp b/src/saber/bump/type_nam.fypp index 8904abaa3..eae8ad22d 100644 --- a/src/saber/bump/type_nam.fypp +++ b/src/saber/bump/type_nam.fypp @@ -39,8 +39,8 @@ type nam_type character(len=1024),allocatable :: fname_vbal_cov(:) !< Vertical covariance files character(len=1024) :: fname_vbal !< Vertical balance file character(len=1024) :: fname_mom_default !< Moments files default base - character(len=1024),allocatable :: fname_mom1(:) !< Moments files, ensemble 1 - character(len=1024),allocatable :: fname_mom2(:) !< Moments files, ensemble 2 + character(len=1024),allocatable :: fname_mom(:) !< Moments files + character(len=1024) :: fname_avg !< Averaged statistics files character(len=1024) :: fname_universe_radius !< Universe radius file character(len=1024) :: fname_nicas !< NICAS file character(len=1024) :: fname_wind !< Wind transform file @@ -48,12 +48,9 @@ type nam_type character(len=1024) :: fname_gsi_nam !< GSI namelist ! Drivers section - logical :: compute_cov1 !< Compute covariance, ensemble 1 - logical :: compute_cov2 !< Compute covariance, ensemble 2 - logical :: compute_cor1 !< Compute correlation, ensemble 1 - logical :: compute_cor2 !< Compute correlation, ensemble 2 - logical :: compute_loc1 !< Compute localization, ensemble 1 - logical :: compute_loc2 !< Compute localization, ensemble 2 + logical :: compute_cov !< Compute covariance + logical :: compute_cor !< Compute correlation + logical :: compute_loc !< Compute localization logical :: compute_hyb !< Compute hybrid weights logical :: new_hdiag !< Compute diagnostics character(len=1024) :: hybrid_source !< Hybrid term source ('randomized static' or 'lowres ensemble') @@ -74,6 +71,7 @@ type nam_type logical :: new_mom !< Compute moments logical :: load_mom !< Read sampling moments logical :: write_mom !< Write sampling moments + logical :: write_avg !< Write averaged statistics logical :: write_hdiag !< Write diagnostics logical :: write_hdiag_detail !< Write components detail logical :: load_universe_radius !< Read universe radius @@ -111,10 +109,8 @@ type nam_type logical :: mask_check !< Check that sampling couples and interpolations do not cross mask boundaries ! Ensemble sizes - integer :: ens1_ne !< Ensemble 1 size - integer :: ens1_nsub !< Ensemble 1 sub-ensembles number - integer :: ens2_ne !< Ensemble 2 size - integer :: ens2_nsub !< Ensemble 2 sub-ensembles number + integer :: ens_ne !< Ensemble size + integer :: ens_nsub !< Ensemble sub-ensembles number ! Sampling section integer :: nc1 !< Computation grid size @@ -138,7 +134,6 @@ type nam_type ! Diagnostics section integer :: ne !< Ensemble size - integer :: ne_lr !< Ensemble size of the low-resolution term (ensemble 2) logical :: gau_approx !< Gaussian approximation for asymptotic quantities character(len=1024) :: loc_option !< Localization option ('default', 'from_squared_correlation', 'nice_with_table' and 'nice_without_table') real(kind_real) :: gen_kurt_th !< Threshold on generalized kurtosis (3.0 = Gaussian distribution) @@ -425,27 +420,16 @@ if (conf%get('io',section)) then if (section%get('overriding moments file',str_array)) then if (size(str_array)>0) then ! Release memory - if (allocated(nam%fname_mom1)) deallocate(nam%fname_mom1) + if (allocated(nam%fname_mom)) deallocate(nam%fname_mom) ! Allocation - allocate(nam%fname_mom1(size(str_array))) + allocate(nam%fname_mom(size(str_array))) ! Copy - nam%fname_mom1 = str_array - end if - end if - if (section%get('overriding lowres moments file',str_array)) then - if (size(str_array)>0) then - ! Release memory - if (allocated(nam%fname_mom2)) deallocate(nam%fname_mom2) - - ! Allocation - allocate(nam%fname_mom2(size(str_array))) - - ! Copy - nam%fname_mom2 = str_array + nam%fname_mom = str_array end if end if + call nam%get(section,'overriding averaged statistics file',nam%fname_avg) call nam%get(section,'overriding universe radius file',nam%fname_universe_radius) call nam%get(section,'overriding nicas file',nam%fname_nicas) call nam%get(section,'overriding psichitouv file',nam%fname_wind) @@ -456,15 +440,11 @@ end if ! Drivers section if (conf%get('drivers',section)) then if (lverbose) call print_section(mpl,section,'Drivers') - call nam%get(section,'compute covariance',nam%compute_cov1) - call nam%get(section,'compute lowres covariance',nam%compute_cov2) - call nam%get(section,'compute correlation',nam%compute_cor1) - call nam%get(section,'compute lowres correlation',nam%compute_cor2) - call nam%get(section,'compute localization',nam%compute_loc1) - call nam%get(section,'compute lowres localization',nam%compute_loc2) + call nam%get(section,'compute covariance',nam%compute_cov) + call nam%get(section,'compute correlation',nam%compute_cor) + call nam%get(section,'compute localization',nam%compute_loc) call nam%get(section,'compute hybrid weights',nam%compute_hyb) - nam%new_hdiag = nam%compute_cov1.or.nam%compute_cor1.or.nam%compute_loc1.or. & - & nam%compute_cov2.or.nam%compute_cor2.or.nam%compute_loc2.or.nam%compute_hyb + nam%new_hdiag = nam%compute_cov.or.nam%compute_cor.or.nam%compute_loc.or.nam%compute_hyb call nam%get(section,'hybrid source',nam%hybrid_source) call nam%get(section,'multivariate strategy',nam%strategy) call nam%get(section,'compute normality',nam%new_normality) @@ -483,6 +463,7 @@ if (conf%get('drivers',section)) then call nam%get(section,'compute moments',nam%new_mom) call nam%get(section,'read moments',nam%load_mom) call nam%get(section,'write moments',nam%write_mom) + call nam%get(section,'write averaged statistics',nam%write_avg) call nam%get(section,'write diagnostics',nam%write_hdiag) call nam%get(section,'write diagnostics detail',nam%write_hdiag_detail) call nam%get(section,'read universe radius',nam%load_universe_radius) @@ -607,10 +588,8 @@ end if ! Ensemble sizes if (conf%get('ensemble sizes',section)) then if (lverbose) call print_section(mpl,section,'Ensemble sizes') - call nam%get(section,'total ensemble size',nam%ens1_ne) - call nam%get(section,'sub-ensembles',nam%ens1_nsub) - call nam%get(section,'total lowres ensemble size',nam%ens2_ne) - call nam%get(section,'lowres sub-ensembles',nam%ens2_nsub) + call nam%get(section,'total ensemble size',nam%ens_ne) + call nam%get(section,'sub-ensembles',nam%ens_nsub) end if ! Sampling section @@ -667,7 +646,6 @@ end if if (conf%get('diagnostics',section)) then if (lverbose) call print_section(mpl,section,'diagnostics') call nam%get(section,'target ensemble size',nam%ne) - call nam%get(section,'target lowres ensemble size',nam%ne_lr) call nam%get(section,'gaussian approximation',nam%gau_approx) call nam%get(section,'localization option',nam%loc_option) call nam%get(section,'generalized kurtosis threshold',nam%gen_kurt_th) @@ -1052,7 +1030,7 @@ if (nam%forced_radii) then end if ! Required parameters -if (nam%ne==0) nam%ne = nam%ens1_ne +if (nam%ne==0) nam%ne = nam%ens_ne if (.not.allocated(nam%nicas_interp_type)) then allocate(nam%nicas_interp_type(nam%ng)) nam%nicas_interp_type = 'si' @@ -1103,16 +1081,14 @@ if (nam%nprocio<1) call mpl%abort('${subr}$','number of I/O tasks should be posi if (nam%fname_samp=='') nam%fname_samp = trim(nam%prefix)//'sampling' nam%fname_vbal_cov_default = trim(nam%prefix)//'vbal_cov' if (allocated(nam%fname_vbal_cov)) then - if (size(nam%fname_vbal_cov)nam%ens1_ne)) call mpl%warning('${subr}$', & - & 'ensemble size larger than ens1_ne (might enhance sampling noise)') -if (nam%compute_loc2.and.(nam%ne_lr>nam%ens2_ne)) call mpl%warning('${subr}$', & - & 'ensemble size larger than ens2_ne (might enhance sampling noise)') +if (nam%compute_loc.and.(nam%ne>nam%ens_ne)) call mpl%warning('${subr}$', & + & 'ensemble size larger than ens_ne (might enhance sampling noise)') ! Sampling section if (nam%new_vbal_cov.or.nam%new_vbal.or.(nam%new_hdiag.and.(.not.nam%from_gsi)).or.nam%check_optimality) then @@ -1277,12 +1246,10 @@ end do ! Diagnostics section if (nam%new_hdiag.or.nam%check_optimality) then - if (((.not.nam%from_gsi).and.(nam%compute_cov1.or.nam%compute_cor1.or.nam%compute_loc1)).and.(nam%ne<=3)) & + if (((.not.nam%from_gsi).and.(nam%compute_cov.or.nam%compute_cor.or.nam%compute_loc)).and.(nam%ne<=3)) & & call mpl%abort('${subr}$','ne should be larger than 3') - if (((.not.nam%from_gsi).and.(nam%compute_cov2.or.nam%compute_cor2.or.nam%compute_loc2)).and.(nam%ne_lr<=3)) & - & call mpl%abort('${subr}$','ne_lr should be larger than 3') if (((nam%loc_option=='from_squared_correlation').or.(nam%loc_option=='nice_with_table').or. & - & (nam%loc_option=='nice_without_table')).and.(.not.(nam%compute_cor1.or.nam%compute_cor2))) & + & (nam%loc_option=='nice_without_table')).and.(.not.nam%compute_cor)) & & call mpl%abort('${subr}$','locoption requires compute_correlation') if (.not.(nam%gen_kurt_th>zero)) call mpl%abort('${subr}$','gen_kurt_th should be positive') if (.not.(nam%lengths_scaling>zero)) call mpl%abort('${subr}$','lengths_scaling should be positive') diff --git a/src/saber/bump/type_nicas.fypp b/src/saber/bump/type_nicas.fypp index fcff65abb..daa605f67 100644 --- a/src/saber/bump/type_nicas.fypp +++ b/src/saber/bump/type_nicas.fypp @@ -1766,7 +1766,7 @@ type(nam_type),intent(inout) :: nam !< Namelist variables type(geom_type),intent(in) :: geom !< Geometry ! Local variables -integer :: ifac,itest,nefac(nfac_rnd),ens1_ne +integer :: ifac,itest,nefac(nfac_rnd),ens_ne integer :: ncid,ntest_id,nfac_id,nefac_id,mse_id,mse_th_id real(kind_real) :: fld(geom%nc0a,geom%nl0,nam%nv),mse(ntest,nfac_rnd),mse_th(ntest,nfac_rnd),mse_avg,mse_th_avg real(kind_real),allocatable :: fld_ref(:,:,:,:),fld_save(:,:,:,:) @@ -1802,14 +1802,14 @@ end do call mpl%prog_final ! Save namelist variables -ens1_ne = nam%ens1_ne +ens_ne = nam%ens_ne write(mpl%info,'(a4,a)') '','Test randomization for various ensemble sizes:' call mpl%flush do ifac=1,nfac_rnd ! Ensemble size - nefac(ifac) = max(int(real(ifac,kind_real)/real(nfac_rnd,kind_real)*real(ens1_ne,kind_real)),3) - nam%ens1_ne = nefac(ifac) + nefac(ifac) = max(int(real(ifac,kind_real)/real(nfac_rnd,kind_real)*real(ens_ne,kind_real)),3) + nam%ens_ne = nefac(ifac) write(mpl%info,'(a7,a,i6,a)') '','Ensemble sizes: ',nefac(ifac),' members' call mpl%flush @@ -1831,7 +1831,7 @@ do ifac=1,nfac_rnd fld = fld-fld_ref(:,:,:,itest) call mpl%dot_prod(fld,fld,mse(itest,ifac)) call mpl%dot_prod(fld_ref(:,:,:,itest),fld_ref(:,:,:,itest),mse_th(itest,ifac)) - mse_th(itest,ifac) = one/real(nam%ens1_ne-1,kind_real)*(mse_th(itest,ifac)+real(geom%nc0*geom%nl0*nam%nv,kind_real)) + mse_th(itest,ifac) = one/real(nam%ens_ne-1,kind_real)*(mse_th(itest,ifac)+real(geom%nc0*geom%nl0*nam%nv,kind_real)) ! Update call mpl%prog_print(itest) @@ -1849,7 +1849,7 @@ do ifac=1,nfac_rnd end do ! Reset namelist variables -nam%ens1_ne = ens1_ne +nam%ens_ne = ens_ne if (mpl%main) then ! Create file diff --git a/src/saber/bump/type_var.fypp b/src/saber/bump/type_var.fypp index 5664b8681..09c2533d6 100644 --- a/src/saber/bump/type_var.fypp +++ b/src/saber/bump/type_var.fypp @@ -220,8 +220,8 @@ write(mpl%info,'(a)') '--- Update variance' call mpl%flush ! Indices -isub = (ie-1)/(nam%ens1_ne/nam%ens1_nsub)+1 -ie_sub = ie-(isub-1)*nam%ens1_ne/nam%ens1_nsub +isub = (ie-1)/(nam%ens_ne/nam%ens_nsub)+1 +ie_sub = ie-(isub-1)*nam%ens_ne/nam%ens_nsub ! Computation factors fac1 = one/real(ie_sub,kind_real) @@ -235,7 +235,7 @@ if (ie==1) then call var%alloc(nam,geom) ! Initialization - var%ne = nam%ens1_ne + var%ne = nam%ens_ne var%m2 = zero var%m4 = zero end if @@ -263,15 +263,15 @@ var%seq_m2 = var%seq_m2+fac5*pert_c0a**2 var%seq_m1 = var%seq_m1+fac1*pert_c0a ! Average variance and fourth-order centered moment -if (ie_sub==nam%ens1_ne/nam%ens1_nsub) then +if (ie_sub==nam%ens_ne/nam%ens_nsub) then var%m2 = var%m2+var%seq_m2 var%m4 = var%m4+var%seq_m4 end if -if (ie==nam%ens1_ne) then +if (ie==nam%ens_ne) then ! Normalization - fac_norm_m2 = one/real(nam%ens1_ne-nam%ens1_nsub,kind_real) - fac_norm_m4 = one/real(nam%ens1_ne,kind_real) + fac_norm_m2 = one/real(nam%ens_ne-nam%ens_nsub,kind_real) + fac_norm_m4 = one/real(nam%ens_ne,kind_real) !$omp parallel do schedule(static) private(iv,il0,ic0a) do iv=1,nam%nv do il0=1,geom%nl0 diff --git a/src/saber/bump/type_vbal.fypp b/src/saber/bump/type_vbal.fypp index c2dc5bf04..8c17773b8 100644 --- a/src/saber/bump/type_vbal.fypp +++ b/src/saber/bump/type_vbal.fypp @@ -877,7 +877,7 @@ write(mpl%info,'(a)') '--- Update vertical covariance' call mpl%flush ! Allocation -if (ie==1) call vbal%alloc(mpl,nam,geom,samp,nam%ens1_nsub) +if (ie==1) call vbal%alloc(mpl,nam,geom,samp,nam%ens_nsub) ! Update vertical covariance do iv=1,nam%nv @@ -887,7 +887,7 @@ do iv=1,nam%nv end do ! Write vertical covariance -if ((ie==nam%ens1_ne).and.nam%write_vbal) then +if ((ie==nam%ens_ne).and.nam%write_vbal) then if (nam%load_samp_local.or.nam%write_samp_local) call vbal%cov_write_local(mpl,nam,geom,samp) if (nam%load_samp_global.or.nam%write_samp_global) call vbal%cov_write_global(mpl,nam,geom,samp) end if diff --git a/src/saber/bump/type_vbal_blk.fypp b/src/saber/bump/type_vbal_blk.fypp index 1495365ab..749438a6e 100644 --- a/src/saber/bump/type_vbal_blk.fypp +++ b/src/saber/bump/type_vbal_blk.fypp @@ -203,8 +203,8 @@ real(kind_real) :: fld_c1a_1(samp%nc1a,geom%nl0),fld_c1a_2(samp%nc1a,geom%nl0) @:probe_in() ! Indices -isub = (ie-1)/(nam%ens1_ne/nam%ens1_nsub)+1 -ie_sub = ie-(isub-1)*nam%ens1_ne/nam%ens1_nsub +isub = (ie-1)/(nam%ens_ne/nam%ens_nsub)+1 +ie_sub = ie-(isub-1)*nam%ens_ne/nam%ens_nsub ! Computation factors fac1 = real(ie_sub-1,kind_real)/real(ie_sub,kind_real) @@ -251,11 +251,11 @@ vbal_blk%seq_avg_c1a_1 = vbal_blk%seq_avg_c1a_1+fac2*fld_c1a_1 vbal_blk%seq_avg_c1a_2 = vbal_blk%seq_avg_c1a_2+fac2*fld_c1a_2 ! Average covariances -if (ie_sub==nam%ens1_ne/nam%ens1_nsub) vbal_blk%full_cov_c1a = vbal_blk%full_cov_c1a+vbal_blk%seq_cov_c1a +if (ie_sub==nam%ens_ne/nam%ens_nsub) vbal_blk%full_cov_c1a = vbal_blk%full_cov_c1a+vbal_blk%seq_cov_c1a -if (ie==nam%ens1_ne) then +if (ie==nam%ens_ne) then ! Normalization - fac_norm = one/real(nam%ens1_ne-nam%ens1_nsub,kind_real) + fac_norm = one/real(nam%ens_ne-nam%ens_nsub,kind_real) !$omp parallel do schedule(static) private(il0,jl0,ic1a) do il0=1,geom%nl0 do jl0=1,geom%nl0 @@ -280,7 +280,7 @@ end subroutine vbal_blk_cov_update ! Subroutine: vbal_blk_compute_covariance !> Compute covariance !---------------------------------------------------------------------- -subroutine vbal_blk_compute_covariance(vbal_blk,mpl,nam,geom,samp,ens1,ens2) +subroutine vbal_blk_compute_covariance(vbal_blk,mpl,nam,geom,samp,ens,ensu) implicit none @@ -290,8 +290,8 @@ type(mpl_type),intent(inout) :: mpl !< MPI data type(nam_type), intent(in) :: nam !< Namelist type(geom_type),intent(in) :: geom !< Geometry type(samp_type), intent(in) :: samp !< Sampling -type(ens_type), intent(in) :: ens1 !< Ensemble 1 -type(ens_type), intent(in),optional :: ens2 !< Ensemble 2 (if present, fill cov_c1a; if not, fill full_cov_c1a) +type(ens_type), intent(in) :: ens !< Ensemble 1 +type(ens_type), intent(in),optional :: ensu !< Ensemble 2 (if present, fill cov_c1a; if not, fill full_cov_c1a) ! Local variables integer :: isub,ie_sub,ie,il0,il0ic1,jl0,ic1a @@ -321,19 +321,19 @@ do isub=1,vbal_blk%nsub end if ! Compute centered moments - do ie_sub=1,ens1%ne/vbal_blk%nsub + do ie_sub=1,ens%ne/vbal_blk%nsub write(mpl%info,'(i6)') ie_sub call mpl%flush(newl=.false.) ! Full ensemble index - ie = ie_sub+(isub-1)*ens1%ne/vbal_blk%nsub + ie = ie_sub+(isub-1)*ens%ne/vbal_blk%nsub ! Get perturbation on subset Sc0 - call ens1%get_c0(mpl,vbal_blk%iv,geom,'pert',ie,fld_c0a_1) - if (present(ens2)) then - call ens2%get_c0(mpl,vbal_blk%jv,geom,'pert',ie,fld_c0a_2) + call ens%get_c0(mpl,vbal_blk%iv,geom,'pert',ie,fld_c0a_1) + if (present(ensu)) then + call ensu%get_c0(mpl,vbal_blk%jv,geom,'pert',ie,fld_c0a_2) else - call ens1%get_c0(mpl,vbal_blk%jv,geom,'pert',ie,fld_c0a_2) + call ens%get_c0(mpl,vbal_blk%jv,geom,'pert',ie,fld_c0a_2) end if ! Halo extension @@ -368,7 +368,7 @@ do isub=1,vbal_blk%nsub end do ! Normalization -fac_norm = real(ens1%nsub,kind_real)/real(ens1%ne-ens1%nsub,kind_real) +fac_norm = real(ens%nsub,kind_real)/real(ens%ne-ens%nsub,kind_real) !$omp parallel do schedule(static) private(il0,jl0,ic1a) do il0=1,geom%nl0 do jl0=1,geom%nl0 diff --git a/src/saber/gsi/GSIBlockChain.h b/src/saber/gsi/GSIBlockChain.h index c084d7b39..5656ab963 100644 --- a/src/saber/gsi/GSIBlockChain.h +++ b/src/saber/gsi/GSIBlockChain.h @@ -34,12 +34,10 @@ class SaberGSIBlockChain : public SaberBlockChainBase { public: template SaberGSIBlockChain(const oops::Geometry & geom, - const oops::Geometry & dualResGeom, const oops::Variables & outerVars, oops::FieldSet4D & fset4dXb, oops::FieldSet4D & fset4dFg, oops::FieldSets & fsetEns, - oops::FieldSets & fsetDualResEns, const eckit::LocalConfiguration & covarConf, const eckit::Configuration & conf); ~SaberGSIBlockChain(); @@ -86,12 +84,10 @@ class SaberGSIBlockChain : public SaberBlockChainBase { template SaberGSIBlockChain::SaberGSIBlockChain(const oops::Geometry & geom, - const oops::Geometry & dualResGeom, const oops::Variables & outerVars, oops::FieldSet4D & fset4dXb, oops::FieldSet4D & fset4dFg, oops::FieldSets & fsetEns, - oops::FieldSets & fsetDualResEns, const eckit::LocalConfiguration & covarConf, const eckit::Configuration & conf) : outerFunctionSpace_(geom.functionSpace()), outerVariables_(outerVars) { diff --git a/src/saber/oops/ErrorCovariance.h b/src/saber/oops/ErrorCovariance.h index c33cb9e6b..9546e89a1 100644 --- a/src/saber/oops/ErrorCovariance.h +++ b/src/saber/oops/ErrorCovariance.h @@ -170,41 +170,7 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, params.toConfiguration(), iterativeEnsembleLoading, ensembleConf); - covarConf.set("ensemble configuration", ensembleConf); - // Read dual resolution ensemble if needed - const auto & dualResParams = params.dualResParams.value(); - std::unique_ptr dualResGeometry{}; // the owning pointer - const Geometry_ * dualResGeom = &geom; // the algorithm-facing handle - std::unique_ptr fsetDualResEns; - if (dualResParams != boost::none) { - const auto & dualResGeomConf = dualResParams->geometry.value(); - if (dualResGeomConf != boost::none) { - // Create dualRes geometry - dualResGeometry = std::make_unique(*dualResGeomConf, geom.getComm()); - dualResGeom = dualResGeometry.get(); - } - // Background and first guess at dual resolution geometry - const State4D_ xbDualRes(*dualResGeom, xb); - const State4D_ fgDualRes(*dualResGeom, fg); - // Read dual resolution ensemble - eckit::LocalConfiguration dualResEnsembleConf; - fsetDualResEns = std::make_unique(readEnsemble(*dualResGeom, - outerVars, - xbDualRes, - fgDualRes, - dualResParams->toConfiguration(), - iterativeEnsembleLoading, - dualResEnsembleConf)); - // Add dual resolution ensemble configuration - covarConf.set("dual resolution ensemble configuration", dualResEnsembleConf); - } - if (!fsetDualResEns) { - std::vector dates; - std::vector ensmems; - fsetDualResEns = std::make_unique(dates, - xb.commTime(), ensmems, xb.commEns()); - } // Add ensemble output const auto & outputEnsemble = params.outputEnsemble.value(); @@ -281,12 +247,6 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, } globalTaskOffsetPerComponent[nComponents] = ntasks; - if (dualResParams != boost::none) { - throw eckit::NotImplemented("Parallel Hybrid not compatible " - "with dual resolution ensemble yet", - Here()); - } - const eckit::mpi::Comm & initialDefaultComm = eckit::mpi::comm(); ASSERT(initialDefaultComm.name() == defaultSpaceComm.name()); @@ -412,12 +372,10 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, SaberBlockChainFactory::create (parametricIfNotEnsemble(centralBlockParams.saberBlockName.value()), *localHybridGeom_, - *dualResGeom, cmpOuterVars, localFset4dXb, localFset4dFg, localFset4dCmpEns, - *fsetDualResEns, cmpCovarConf, cmpConf)); @@ -490,12 +448,10 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, (SaberBlockChainFactory::create (parametricIfNotEnsemble(centralBlockParams.saberBlockName.value()), *hybridGeom, - *dualResGeom, cmpOuterVars, *fset4dXb, *fset4dFg, fset4dCmpEns, - *fsetDualResEns, cmpCovarConf, cmpConf)); } @@ -507,12 +463,10 @@ ErrorCovariance::ErrorCovariance(const Geometry_ & geom, (SaberBlockChainFactory::create (parametricIfNotEnsemble(saberCentralBlockParams.saberBlockName.value()), geom, - *dualResGeom, outerVars, *fset4dXb, *fset4dFg, fsetEns, - *fsetDualResEns, covarConf, params.toConfiguration())); diff --git a/src/saber/oops/ErrorCovarianceParameters.h b/src/saber/oops/ErrorCovarianceParameters.h index 86231fa01..ca4bba432 100644 --- a/src/saber/oops/ErrorCovarianceParameters.h +++ b/src/saber/oops/ErrorCovarianceParameters.h @@ -24,21 +24,6 @@ namespace saber { // ------------------------------------------------------------------------------------------------- -class DualResCalibrationParameters : public oops::Parameters { - OOPS_CONCRETE_PARAMETERS(DualResCalibrationParameters, oops::Parameters) - public: - // Geometry - oops::OptionalParameter geometry{"geometry", this}; - - // Ensemble - oops::OptionalParameter ensemble{"ensemble", this}; - oops::OptionalParameter ensemblePert{"ensemble pert", this}; - oops::OptionalParameter ensembleBase{"ensemble base", this}; - oops::OptionalParameter ensemblePairs{"ensemble pairs", this}; -}; - -// ------------------------------------------------------------------------------------------------- - template class ModelSpaceCovarianceParametersBase : public oops::Parameters { OOPS_CONCRETE_PARAMETERS(ModelSpaceCovarianceParametersBase, oops::Parameters) @@ -85,11 +70,6 @@ class ErrorCovarianceParameters : public ModelSpaceCovarianceParametersBase ensembleGeom{ "ensemble geometry", this}; - - // Dual resolution calibration - oops::OptionalParameter dualResParams{ - "dual resolution calibration", this}; - // Output ensemble oops::OptionalParameter outputEnsemble{"output ensemble", this}; diff --git a/src/saber/oops/Localization.h b/src/saber/oops/Localization.h index 0639b09f6..46a92a9dd 100644 --- a/src/saber/oops/Localization.h +++ b/src/saber/oops/Localization.h @@ -101,9 +101,9 @@ Localization::Localization(const Geometry_ & geom, // so this parameter can be anything. covarConf.set("time covariance", "univariate"); // Initialize localization blockchain - loc_ = std::make_unique(geom, geom, + loc_ = std::make_unique(geom, incVars, xb4d, fg4d, - emptyFsetEns, emptyFsetEns, covarConf, conf); + emptyFsetEns, covarConf, conf); oops::Log::trace() << "Localization:Localization done" << std::endl; } diff --git a/src/saber/oops/ProcessPerts.h b/src/saber/oops/ProcessPerts.h index 939591eeb..a1826d82b 100644 --- a/src/saber/oops/ProcessPerts.h +++ b/src/saber/oops/ProcessPerts.h @@ -215,8 +215,6 @@ template class ProcessPerts : public oops::Application { std::vector dates; std::vector ensmems; oops::FieldSets fsetEns(dates, oops::mpi::myself(), ensmems, oops::mpi::myself()); - oops::FieldSets dualResFsetEns(dates, oops::mpi::myself(), - ensmems, oops::mpi::myself()); eckit::LocalConfiguration covarConf; covarConf.set("iterative ensemble loading", false); covarConf.set("inverse test", false); @@ -294,9 +292,9 @@ template class ProcessPerts : public oops::Application { std::vector> saberFilterBlocks; for (const auto & [key, value] : filterCovBlockConfs) { saberFilterBlocks.push_back( - std::make_unique(geom, geom, + std::make_unique(geom, incVars, fsetXb, fsetFg, - fsetEns, dualResFsetEns, + fsetEns, covarConf, value)); } @@ -304,9 +302,9 @@ template class ProcessPerts : public oops::Application { std::vector> saberDiagnosticBlocks; for (const auto & [key, value] : diagBlockConfs) { saberDiagnosticBlocks.push_back( - std::make_unique(geom, geom, + std::make_unique(geom, incVars, fsetXb, fsetFg, - fsetEns, dualResFsetEns, + fsetEns, covarConf, value)); } diff --git a/test/fctest/fctest_nicas_sqrt.F90 b/test/fctest/fctest_nicas_sqrt.F90 index b07e8a2b7..66e2f873a 100644 --- a/test/fctest/fctest_nicas_sqrt.F90 +++ b/test/fctest/fctest_nicas_sqrt.F90 @@ -107,14 +107,14 @@ ! Create output fieldset fspace_out_sc = atlas_functionspace_structuredcolumns(fspace_out%c_ptr()) nmga_out = fspace_out_sc%size_owned() - allocate(gmask_out(nmga_out,bump%geom(1)%nl0)) + allocate(gmask_out(nmga_out,bump%geom%nl0)) gmask_out = .true. call fset_out_1%init(bump%mpl,fspace_out,gmask_out,bump%nam%variables,bump%nam%ilev2d,bump%nam%var2d) call fset_out_2%init(bump%mpl,fspace_out,gmask_out,bump%nam%variables,bump%nam%ilev2d,bump%nam%var2d) ! Initialize output fieldset - allocate(array_out_1(nmga_out,bump%geom(1)%nl0,bump%nam%nv)) - allocate(array_out_2(nmga_out,bump%geom(1)%nl0,bump%nam%nv)) + allocate(array_out_1(nmga_out,bump%geom%nl0,bump%nam%nv)) + allocate(array_out_2(nmga_out,bump%geom%nl0,bump%nam%nv)) call bump%rng%rand_gau(array_out_1) array_out_2 = array_out_1 call fset_out_1%from_array(bump%mpl,array_out_1) diff --git a/test/testdeps/error_covariance_training_bump_hdiag-nicas_3.txt b/test/testdeps/error_covariance_training_bump_hdiag-nicas_3.txt deleted file mode 100644 index fbedff0e0..000000000 --- a/test/testdeps/error_covariance_training_bump_hdiag-nicas_3.txt +++ /dev/null @@ -1 +0,0 @@ -error_covariance_training_bump_hdiag_5 diff --git a/test/testinput/error_covariance_training_bump_hdiag-nicas_3.yaml b/test/testinput/error_covariance_training_bump_hdiag-nicas_3.yaml deleted file mode 100644 index ba44b845c..000000000 --- a/test/testinput/error_covariance_training_bump_hdiag-nicas_3.yaml +++ /dev/null @@ -1,97 +0,0 @@ -geometry: - function space: StructuredColumns - grid: - type: regular_lonlat - N: 12 - groups: - - variables: - - air_horizontal_streamfunction - levels: 2 - halo: 1 -background: - date: 2010-01-01T12:00:00Z - state variables: - - air_horizontal_streamfunction -background error: - covariance model: SABER - dual resolution calibration: - geometry: - function space: StructuredColumns - grid: - type: regular_lonlat - N: 10 - groups: - - variables: - - air_horizontal_streamfunction - levels: 2 - halo: 1 - saber central block: - saber block name: BUMP_NICAS - calibration: - general: - testing: true - io: - data directory: testdata - files prefix: error_covariance_training_bump_hdiag-nicas_3/_MPI_-_OMP_ - overriding sampling file: error_covariance_training_bump_hdiag_5/_MPI_-_OMP__sampling - overriding moments file: - - error_covariance_training_bump_hdiag_5/_MPI_-_OMP__mom_000001_1 - overriding lowres moments file: - - error_covariance_training_bump_hdiag_5/_MPI_-_OMP__mom_000001_2 - drivers: - compute covariance: true - compute lowres covariance: true - compute correlation: true - compute lowres correlation: true - compute localization: true - compute lowres localization: true - compute hybrid weights: true - hybrid source: lowres ensemble - multivariate strategy: univariate - read local sampling: true - read moments: true - write diagnostics: true - compute nicas: true - write local nicas: true - adjoints test: true - normalization test: 10 - internal dirac test: true - ensemble sizes: - total ensemble size: 10 - total lowres ensemble size: 25 - sampling: - computation grid size: 500 - distance classes: 15 - distance class width: 500.0e3 - reduced levels: 2 - diagnostics: - target ensemble size: 10 - target lowres ensemble size: 25 - nicas: - resolution: 4.0 - dirac: - - longitude: 0.0 - latitude: 0.0 - level: 1 - variable: air_horizontal_streamfunction - output model files: - - parameter: loc_rh - file: - filepath: testdata/error_covariance_training_bump_hdiag-nicas_3/_MPI_-_OMP__loc_rh - - parameter: loc_rv - file: - filepath: testdata/error_covariance_training_bump_hdiag-nicas_3/_MPI_-_OMP__loc_rv - - parameter: hyb_coef_ens - file: - filepath: testdata/error_covariance_training_bump_hdiag-nicas_3/_MPI_-_OMP__hyb_coef_ens - - parameter: hyb_coef_ens_lr - file: - filepath: testdata/error_covariance_training_bump_hdiag-nicas_3/_MPI_-_OMP__hyb_coef_ens_lr - - parameter: loc_rh_lr - file: - filepath: testdata/error_covariance_training_bump_hdiag-nicas_3/_MPI_-_OMP__loc_rh_lr - - parameter: loc_rv_lr - file: - filepath: testdata/error_covariance_training_bump_hdiag-nicas_3/_MPI_-_OMP__loc_rv_lr -test: - reference filename: testref/error_covariance_training_bump_hdiag-nicas_3.ref diff --git a/test/testinput/error_covariance_training_bump_hdiag_2.yaml b/test/testinput/error_covariance_training_bump_hdiag_2.yaml index 0c4708111..e62160cc1 100644 --- a/test/testinput/error_covariance_training_bump_hdiag_2.yaml +++ b/test/testinput/error_covariance_training_bump_hdiag_2.yaml @@ -29,7 +29,7 @@ background error: parallel netcdf: false overriding sampling file: error_covariance_training_bump_hdiag_1/_MPI_-_OMP__sampling overriding moments file: - - error_covariance_training_bump_hdiag_1/_MPI_-_OMP__mom_000001_1 + - error_covariance_training_bump_hdiag_1/_MPI_-_OMP__mom_000001 drivers: compute covariance: true compute correlation: true diff --git a/test/testinput/error_covariance_training_bump_hdiag_5.yaml b/test/testinput/error_covariance_training_bump_hdiag_5.yaml index 853e0fb04..c08baa2a9 100644 --- a/test/testinput/error_covariance_training_bump_hdiag_5.yaml +++ b/test/testinput/error_covariance_training_bump_hdiag_5.yaml @@ -2,7 +2,7 @@ geometry: function space: StructuredColumns grid: type: regular_lonlat - N: 12 + N: 10 groups: - variables: - air_horizontal_streamfunction @@ -17,158 +17,81 @@ background error: ensemble: members: - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000001 - state variables: + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000001 + state variables: &id001 - air_horizontal_streamfunction - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000002 - state variables: - - air_horizontal_streamfunction + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000002 + state variables: *id001 - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000003 - state variables: - - air_horizontal_streamfunction + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000003 + state variables: *id001 - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000004 - state variables: - - air_horizontal_streamfunction + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000004 + state variables: *id001 - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000005 - state variables: - - air_horizontal_streamfunction + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000005 + state variables: *id001 - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000006 - state variables: - - air_horizontal_streamfunction + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000006 + state variables: *id001 - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000007 - state variables: - - air_horizontal_streamfunction + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000007 + state variables: *id001 - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000008 - state variables: - - air_horizontal_streamfunction + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000008 + state variables: *id001 - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000009 - state variables: - - air_horizontal_streamfunction + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000009 + state variables: *id001 - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000010 - state variables: - - air_horizontal_streamfunction - dual resolution calibration: - geometry: - function space: StructuredColumns - grid: - type: regular_lonlat - N: 10 - groups: - - variables: - - air_horizontal_streamfunction - levels: 2 - halo: 1 - ensemble: - members: - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000001 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000002 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000003 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000004 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000005 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000006 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000007 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000008 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000009 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000010 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000011 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000012 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000013 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000014 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000015 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000016 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000017 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000018 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000019 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000020 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000021 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000022 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000023 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000024 - state variables: - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000025 - state variables: - - air_horizontal_streamfunction + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000010 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000011 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000012 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000013 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000014 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000015 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000016 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000017 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000018 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000019 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000020 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000021 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000022 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000023 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000024 + state variables: *id001 + - date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_000025 + state variables: *id001 saber central block: saber block name: BUMP_NICAS calibration: @@ -179,17 +102,13 @@ background error: files prefix: error_covariance_training_bump_hdiag_5/_MPI_-_OMP_ drivers: compute covariance: true - compute lowres covariance: true compute correlation: true - compute lowres correlation: true compute localization: true - compute lowres localization: true - compute hybrid weights: true - hybrid source: lowres ensemble multivariate strategy: univariate write local sampling: true compute moments: true write moments: true + write averaged statistics: true write diagnostics: true adjoints test: true normalization test: 10 @@ -199,8 +118,7 @@ background error: distance class width: 500.0e3 reduced levels: 2 diagnostics: - target ensemble size: 10 - target lowres ensemble size: 25 + target ensemble size: 25 output model files: - parameter: loc_rh file: @@ -208,17 +126,5 @@ background error: - parameter: loc_rv file: filepath: testdata/error_covariance_training_bump_hdiag_5/_MPI_-_OMP__loc_rv - - parameter: hyb_coef_ens - file: - filepath: testdata/error_covariance_training_bump_hdiag_5/_MPI_-_OMP__hyb_coef_ens - - parameter: hyb_coef_ens_lr - file: - filepath: testdata/error_covariance_training_bump_hdiag_5/_MPI_-_OMP__hyb_coef_ens_lr - - parameter: loc_rh_lr - file: - filepath: testdata/error_covariance_training_bump_hdiag_5/_MPI_-_OMP__loc_rh_lr - - parameter: loc_rv_lr - file: - filepath: testdata/error_covariance_training_bump_hdiag_5/_MPI_-_OMP__loc_rv_lr test: reference filename: testref/error_covariance_training_bump_hdiag_5.ref diff --git a/test/testinput/error_covariance_training_bump_hdiag_6.yaml b/test/testinput/error_covariance_training_bump_hdiag_6.yaml index 72e4a780d..bb1b880f6 100644 --- a/test/testinput/error_covariance_training_bump_hdiag_6.yaml +++ b/test/testinput/error_covariance_training_bump_hdiag_6.yaml @@ -14,128 +14,16 @@ background: - air_horizontal_streamfunction background error: covariance model: SABER - iterative ensemble loading: true ensemble: - members: - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000001 - state variables: &id001 - - air_horizontal_streamfunction - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000002 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000003 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000004 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000005 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000006 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000007 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000008 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000009 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_000010 - state variables: *id001 - dual resolution calibration: - geometry: - function space: StructuredColumns - grid: - type: regular_lonlat - N: 10 - groups: - - variables: + members from template: + template: + date: 2010-01-01T12:00:00Z + filepath: testdata/randomization_bump_nicas_L12L2/_MPI_-_OMP__member_%mem% + state variables: &id001 - air_horizontal_streamfunction - levels: 2 - halo: 1 - ensemble: - members: - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000001 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000002 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000003 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000004 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000005 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000006 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000007 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000008 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000009 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000010 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000011 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000012 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000013 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000014 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000015 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000016 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000017 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000018 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000019 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000020 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000021 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000022 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000023 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000024 - state variables: *id001 - - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_000025 - state variables: *id001 + pattern: '%mem%' + nmembers: 10 + zero padding: 6 saber central block: saber block name: BUMP_NICAS calibration: @@ -144,16 +32,16 @@ background error: io: data directory: testdata files prefix: error_covariance_training_bump_hdiag_6/_MPI_-_OMP_ + overriding sampling file: error_covariance_training_bump_hdiag_5/_MPI_-_OMP__sampling + overriding averaged statistics file: error_covariance_training_bump_hdiag_5/_MPI_-_OMP__avg drivers: compute covariance: true - compute lowres covariance: true compute correlation: true - compute lowres correlation: true compute localization: true - compute lowres localization: true compute hybrid weights: true hybrid source: lowres ensemble multivariate strategy: univariate + read local sampling: true compute moments: true write diagnostics: true adjoints test: true @@ -165,7 +53,6 @@ background error: reduced levels: 2 diagnostics: target ensemble size: 10 - target lowres ensemble size: 25 output model files: - parameter: loc_rh file: @@ -173,17 +60,11 @@ background error: - parameter: loc_rv file: filepath: testdata/error_covariance_training_bump_hdiag_6/_MPI_-_OMP__loc_rv - - parameter: hyb_coef_ens + - parameter: hyb_coef_1 file: - filepath: testdata/error_covariance_training_bump_hdiag_6/_MPI_-_OMP__hyb_coef_ens - - parameter: hyb_coef_ens_lr + filepath: testdata/error_covariance_training_bump_hdiag_6/_MPI_-_OMP__hyb_coef_1 + - parameter: hyb_coef_2 file: - filepath: testdata/error_covariance_training_bump_hdiag_6/_MPI_-_OMP__hyb_coef_ens_lr - - parameter: loc_rh_lr - file: - filepath: testdata/error_covariance_training_bump_hdiag_6/_MPI_-_OMP__loc_rh_lr - - parameter: loc_rv_lr - file: - filepath: testdata/error_covariance_training_bump_hdiag_6/_MPI_-_OMP__loc_rv_lr + filepath: testdata/error_covariance_training_bump_hdiag_6/_MPI_-_OMP__hyb_coef_2 test: reference filename: testref/error_covariance_training_bump_hdiag_6.ref diff --git a/test/testinput/error_covariance_training_bump_hdiag_7.yaml b/test/testinput/error_covariance_training_bump_hdiag_7.yaml index 270222251..a74097b12 100644 --- a/test/testinput/error_covariance_training_bump_hdiag_7.yaml +++ b/test/testinput/error_covariance_training_bump_hdiag_7.yaml @@ -25,26 +25,6 @@ background error: pattern: '%mem%' nmembers: 10 zero padding: 6 - dual resolution calibration: - geometry: - function space: StructuredColumns - grid: - type: regular_lonlat - N: 10 - groups: - - variables: - - air_horizontal_streamfunction - levels: 2 - halo: 1 - ensemble: - members from template: - template: - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2/_MPI_-_OMP__member_%mem% - state variables: *id001 - pattern: '%mem%' - nmembers: 25 - zero padding: 6 saber central block: saber block name: BUMP_NICAS calibration: @@ -53,13 +33,12 @@ background error: io: data directory: testdata files prefix: error_covariance_training_bump_hdiag_7/_MPI_-_OMP_ + overriding sampling file: error_covariance_training_bump_hdiag_5/_MPI_-_OMP__sampling + overriding averaged statistics file: error_covariance_training_bump_hdiag_5/_MPI_-_OMP__avg drivers: compute covariance: true - compute lowres covariance: true compute correlation: true - compute lowres correlation: true compute localization: true - compute lowres localization: true compute hybrid weights: true hybrid source: lowres ensemble multivariate strategy: univariate @@ -74,7 +53,6 @@ background error: reduced levels: 2 diagnostics: target ensemble size: 10 - target lowres ensemble size: 25 output model files: - parameter: loc_rh file: @@ -82,17 +60,11 @@ background error: - parameter: loc_rv file: filepath: testdata/error_covariance_training_bump_hdiag_7/_MPI_-_OMP__loc_rv - - parameter: hyb_coef_ens - file: - filepath: testdata/error_covariance_training_bump_hdiag_7/_MPI_-_OMP__hyb_coef_ens - - parameter: hyb_coef_ens_lr - file: - filepath: testdata/error_covariance_training_bump_hdiag_7/_MPI_-_OMP__hyb_coef_ens_lr - - parameter: loc_rh_lr + - parameter: hyb_coef_1 file: - filepath: testdata/error_covariance_training_bump_hdiag_7/_MPI_-_OMP__loc_rh_lr - - parameter: loc_rv_lr + filepath: testdata/error_covariance_training_bump_hdiag_7/_MPI_-_OMP__hyb_coef_1 + - parameter: hyb_coef_2 file: - filepath: testdata/error_covariance_training_bump_hdiag_7/_MPI_-_OMP__loc_rv_lr + filepath: testdata/error_covariance_training_bump_hdiag_7/_MPI_-_OMP__hyb_coef_2 test: reference filename: testref/error_covariance_training_bump_hdiag_7.ref diff --git a/test/testinput/error_covariance_training_bump_hdiag_8.yaml b/test/testinput/error_covariance_training_bump_hdiag_8.yaml index bc4722540..cf8de404d 100644 --- a/test/testinput/error_covariance_training_bump_hdiag_8.yaml +++ b/test/testinput/error_covariance_training_bump_hdiag_8.yaml @@ -24,27 +24,6 @@ background error: pattern: '%mem%' nmembers: 10 zero padding: 6 - dual resolution calibration: - geometry: - function space: StructuredColumns - grid: - type: regular_lonlat - N: 10 - groups: - - variables: - - air_horizontal_streamfunction - levels: 2 - halo: 1 - ensemble: - members from template: - template: - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_%mem% - state variables: - - air_horizontal_streamfunction - pattern: '%mem%' - nmembers: 25 - zero padding: 6 saber central block: saber block name: BUMP_NICAS calibration: @@ -53,11 +32,11 @@ background error: io: data directory: testdata files prefix: error_covariance_training_bump_hdiag_8/_MPI_-_OMP_ + overriding sampling file: error_covariance_training_bump_hdiag_5/_MPI_-_OMP__sampling + overriding averaged statistics file: error_covariance_training_bump_hdiag_5/_MPI_-_OMP__avg drivers: compute covariance: true - compute lowres covariance: true compute correlation: true - compute lowres correlation: true compute localization: true compute hybrid weights: true hybrid source: randomized static @@ -73,7 +52,6 @@ background error: reduced levels: 2 diagnostics: target ensemble size: 10 - target lowres ensemble size: 25 output model files: - parameter: loc_rh file: @@ -81,11 +59,11 @@ background error: - parameter: loc_rv file: filepath: testdata/error_covariance_training_bump_hdiag_8/_MPI_-_OMP__loc_rv - - parameter: hyb_coef_ens + - parameter: hyb_coef_1 file: - filepath: testdata/error_covariance_training_bump_hdiag_8/_MPI_-_OMP__hyb_coef_ens - - parameter: hyb_coef_sta + filepath: testdata/error_covariance_training_bump_hdiag_8/_MPI_-_OMP__hyb_coef_1 + - parameter: hyb_coef_2 file: - filepath: testdata/error_covariance_training_bump_hdiag_8/_MPI_-_OMP__hyb_coef_sta + filepath: testdata/error_covariance_training_bump_hdiag_8/_MPI_-_OMP__hyb_coef_2 test: reference filename: testref/error_covariance_training_bump_hdiag_8.ref diff --git a/test/testinput/error_covariance_training_bump_hdiag_9.yaml b/test/testinput/error_covariance_training_bump_hdiag_9.yaml index 435445ac3..ac9e995bb 100644 --- a/test/testinput/error_covariance_training_bump_hdiag_9.yaml +++ b/test/testinput/error_covariance_training_bump_hdiag_9.yaml @@ -24,27 +24,6 @@ background error: pattern: '%mem%' nmembers: 10 zero padding: 6 - dual resolution calibration: - geometry: - function space: StructuredColumns - grid: - type: regular_lonlat - N: 10 - groups: - - variables: - - air_horizontal_streamfunction - levels: 2 - halo: 1 - ensemble: - members from template: - template: - date: 2010-01-01T12:00:00Z - filepath: testdata/randomization_bump_nicas_L10L2_static/_MPI_-_OMP__member_pert_%mem% - state variables: - - air_horizontal_streamfunction - pattern: '%mem%' - nmembers: 25 - zero padding: 6 saber central block: saber block name: BUMP_NICAS calibration: @@ -53,11 +32,11 @@ background error: io: data directory: testdata files prefix: error_covariance_training_bump_hdiag_9/_MPI_-_OMP_ + overriding sampling file: error_covariance_training_bump_hdiag_5/_MPI_-_OMP__sampling + overriding averaged statistics file: error_covariance_training_bump_hdiag_5/_MPI_-_OMP__avg drivers: compute covariance: true - compute lowres covariance: true compute correlation: true - compute lowres correlation: true compute localization: true compute hybrid weights: true hybrid source: randomized static @@ -73,7 +52,6 @@ background error: reduced levels: 2 diagnostics: target ensemble size: 10 - target lowres ensemble size: 25 nicas: explicit length-scales: true horizontal length-scale: @@ -91,11 +69,11 @@ background error: - parameter: loc_rv file: filepath: testdata/error_covariance_training_bump_hdiag_9/_MPI_-_OMP__loc_rv - - parameter: hyb_coef_ens + - parameter: hyb_coef_1 file: - filepath: testdata/error_covariance_training_bump_hdiag_9/_MPI_-_OMP__hyb_coef_ens - - parameter: hyb_coef_sta + filepath: testdata/error_covariance_training_bump_hdiag_9/_MPI_-_OMP__hyb_coef_1 + - parameter: hyb_coef_2 file: - filepath: testdata/error_covariance_training_bump_hdiag_9/_MPI_-_OMP__hyb_coef_sta + filepath: testdata/error_covariance_training_bump_hdiag_9/_MPI_-_OMP__hyb_coef_2 test: reference filename: testref/error_covariance_training_bump_hdiag_9.ref diff --git a/test/testlist/saber_test_tier1-bump.txt b/test/testlist/saber_test_tier1-bump.txt index d2f5c2d71..affdb918d 100644 --- a/test/testlist/saber_test_tier1-bump.txt +++ b/test/testlist/saber_test_tier1-bump.txt @@ -38,7 +38,6 @@ error_covariance_training_bump_hdiag_12 error_covariance_training_bump_hdiag_13 error_covariance_training_bump_hdiag-nicas_1 error_covariance_training_bump_hdiag-nicas_2 -error_covariance_training_bump_hdiag-nicas_3 error_covariance_training_bump_hdiag-nicas_4 error_covariance_training_bump_hdiag-nicas_5 error_covariance_training_bump_nicas_1 diff --git a/test/testref/error_covariance_training_bump_hdiag-nicas_3.ref b/test/testref/error_covariance_training_bump_hdiag-nicas_3.ref deleted file mode 100644 index b8e8f15ae..000000000 --- a/test/testref/error_covariance_training_bump_hdiag-nicas_3.ref +++ /dev/null @@ -1,156 +0,0 @@ - Independent levels: 1[2] - Subset Sc0 size: 1106 - Domain area (% of Earth area): 0.100E+03% - Level 1 ~> 100.0% - Level 2 ~> 100.0% - Level 1 ~> 0.100E+01 vert. coord. - Level 2 ~> 0.200E+01 vert. coord. - Independent levels: 1[2] - Subset Sc0 size: 762 - Domain area (% of Earth area): 0.100E+03% - Level 1 ~> 100.0% - Level 2 ~> 100.0% - Level 1 ~> 0.100E+01 vert. coord. - Level 2 ~> 0.200E+01 vert. coord. - nc1 = 500 - Independent levels: 1[2] - Independent levels for angular sector 1 / class 1: 1[2] - Independent levels for angular sector 1 / class 2: 1[2] - Independent levels for angular sector 1 / class 3: 1[2] - Independent levels for angular sector 1 / class 4: 1[2] - Independent levels for angular sector 1 / class 5: 1[2] - Independent levels for angular sector 1 / class 6: 1[2] - Independent levels for angular sector 1 / class 7: 1[2] - Independent levels for angular sector 1 / class 8: 1[2] - Independent levels for angular sector 1 / class 9: 1[2] - Independent levels for angular sector 1 / class 10: 1[2] - Independent levels for angular sector 1 / class 11: 1[2] - Independent levels for angular sector 1 / class 12: 1[2] - Independent levels for angular sector 1 / class 13: 1[2] - Independent levels for angular sector 1 / class 14: 1[2] - Independent levels for angular sector 1 / class 15: 1[2] - nc1 = 500 - Independent levels: 1[2] - Independent levels for angular sector 1 / class 1: 1[2] - Independent levels for angular sector 1 / class 2: 1[2] - Independent levels for angular sector 1 / class 3: 1[2] - Independent levels for angular sector 1 / class 4: 1[2] - Independent levels for angular sector 1 / class 5: 1[2] - Independent levels for angular sector 1 / class 6: 1[2] - Independent levels for angular sector 1 / class 7: 1[2] - Independent levels for angular sector 1 / class 8: 1[2] - Independent levels for angular sector 1 / class 9: 1[2] - Independent levels for angular sector 1 / class 10: 1[2] - Independent levels for angular sector 1 / class 11: 1[2] - Independent levels for angular sector 1 / class 12: 1[2] - Independent levels for angular sector 1 / class 13: 1[2] - Independent levels for angular sector 1 / class 14: 1[2] - Independent levels for angular sector 1 / class 15: 1[2] - Level: 1 ~> cov. at class zero: 0.96E+00 - Level: 2 ~> cov. at class zero: 0.91E+00 - Level: 1 ~> cov. at class zero: 0.10E+01 - Level: 2 ~> cov. at class zero: 0.99E+00 - Block air_horizontal_streamfunction: 0.13646608E+00 for 60 diagnostic points - Level: 1 ~> amplitude: 1.00 - cor. hor. support: 3722.94 km - cor. ver. support: 3.10 vertical units - Level: 2 ~> amplitude: 1.00 - cor. hor. support: 3817.09 km - cor. ver. support: 3.10 vertical units - Block air_horizontal_streamfunction: 0.15267547E+00 for 60 diagnostic points - Level: 1 ~> amplitude: 1.00 - cor. hor. support: 3607.14 km - cor. ver. support: 3.22 vertical units - Level: 2 ~> amplitude: 1.00 - cor. hor. support: 3694.74 km - cor. ver. support: 3.22 vertical units - Block air_horizontal_streamfunction: 0.23629308E+00 for 30 diagnostic points - Level: 1 ~> loc. at class zero: 0.83 - Level: 2 ~> loc. at class zero: 0.82 - Level: 1 ~> amplitude: 1.00 - loc. hor. support: 4484.40 km - loc. ver. support: 4.10 vertical units - Level: 2 ~> amplitude: 1.00 - loc. hor. support: 4344.81 km - loc. ver. support: 4.10 vertical units - Block air_horizontal_streamfunction: 0.25563407E+00 for 41 diagnostic points - Level: 1 ~> loc. at class zero: 0.92 - Level: 2 ~> loc. at class zero: 0.92 - Level: 1 ~> amplitude: 1.00 - loc. hor. support: 5436.12 km - loc. ver. support: 6.03 vertical units - Level: 2 ~> amplitude: 1.00 - loc. hor. support: 5378.97 km - loc. ver. support: 6.04 vertical units - Level: 1 ~> hybrid coefficients: 0.50 / 0.47 - Level: 2 ~> hybrid coefficients: 0.43 / 0.52 - Effective levels: 1 2 - Horizontal support radius: 4484.40 km ( 4484.40 km - 4484.40 km) - Estimated nc1 from horizontal support radius: 468 - Decimate full grid, at least 468 points required, 1082 valid points found - Subgrid hash: 65621077 - Final nc1: 468 - Effective horizontal resolution: 4.00 - Horizontal support radius: 4344.81 km ( 4344.81 km - 4344.81 km) - Estimated nc1 from horizontal support radius: 499 - Decimate full grid, at least 499 points required, 1090 valid points found - Subgrid hash: -1746176229 - Final nc1: 499 - Effective horizontal resolution: 4.00 - nc1( 1) = 468 - nc1( 2) = 499 - ns = 967 - v%n_s = 2 - c%n_s[global] = 26193 - Effective levels: 1 2 - Horizontal support radius: 5436.12 km ( 5436.12 km - 5436.12 km) - Estimated nc1 from horizontal support radius: 318 - Decimate full grid, at least 318 points required, 762 valid points found - Subgrid hash: 850038257 - Final nc1: 318 - Effective horizontal resolution: 3.99 - Horizontal support radius: 5378.97 km ( 5378.97 km - 5378.97 km) - Estimated nc1 from horizontal support radius: 325 - Decimate full grid, at least 325 points required, 762 valid points found - Subgrid hash: -925443391 - Final nc1: 325 - Effective horizontal resolution: 4.00 - nc1( 1) = 318 - nc1( 2) = 325 - ns = 643 - v%n_s = 2 - c%n_s[global] = 17103 - Full NICAS adjoint test result: T - Block NICAS adjoint test result: T - Interpolation adjoint test (horizontal) result: T - Interpolation adjoint test (vertical) result: T - Interpolation adjoint test (total) result: T - Communication AB adjoint test result: T - Communication AC adjoint test result: T - Convolution / communication adjoint test result: T - Component NICAS adjoint test result: T - Min / max: 1.0000000 / 1.0000000 over 10 tests - Min / max: 1.0000000 / 1.0000000 over 10 tests - 0.0 / 0.0: 1.0000000 - Level 1: 0.0000000 - 1.0000000 - Level 2: 0.0000000 - 0.8105611 - Full NICAS adjoint test result: T - Block NICAS adjoint test result: T - Interpolation adjoint test (horizontal) result: T - Interpolation adjoint test (vertical) result: T - Interpolation adjoint test (total) result: T - Communication AB adjoint test result: T - Communication AC adjoint test result: T - Convolution / communication adjoint test result: T - Component NICAS adjoint test result: T - Min / max: 1.0000000 / 1.0000000 over 10 tests - Min / max: 1.0000000 / 1.0000000 over 10 tests - 0.0 / 0.0: 1.0000000 - Level 1: 0.0000000 - 1.0000000 - Level 2: 0.0000000 - 0.9241828 -Norm of output parameter loc_rh - 1: 2.0765313355080462e+08 -Norm of output parameter loc_rv - 1: 1.9267686907947714e+02 -Norm of output parameter hyb_coef_ens - 1: 2.1960039721223747e+01 -Norm of output parameter hyb_coef_ens_lr - 1: 2.3498553572266275e+01 -Norm of output parameter loc_rh_lr - 1: 2.1589887876004183e+08 -Norm of output parameter loc_rv_lr - 1: 2.4100189906820731e+02 diff --git a/test/testref/error_covariance_training_bump_hdiag_5.ref b/test/testref/error_covariance_training_bump_hdiag_5.ref index 92c9c1b17..8b9546ceb 100644 --- a/test/testref/error_covariance_training_bump_hdiag_5.ref +++ b/test/testref/error_covariance_training_bump_hdiag_5.ref @@ -1,20 +1,3 @@ - Independent levels: 1[2] - Subset Sc0 size: 1106 - Domain area (% of Earth area): 0.100E+03% - Level 1 ~> 100.0% - Level 2 ~> 100.0% - Level 1 ~> 0.100E+01 vert. coord. - Level 2 ~> 0.200E+01 vert. coord. - Norm of air_horizontal_streamfunction: 0.46774069E+02 - Norm of air_horizontal_streamfunction: 0.49473350E+02 - Norm of air_horizontal_streamfunction: 0.46803110E+02 - Norm of air_horizontal_streamfunction: 0.43951618E+02 - Norm of air_horizontal_streamfunction: 0.43045885E+02 - Norm of air_horizontal_streamfunction: 0.37535957E+02 - Norm of air_horizontal_streamfunction: 0.42717053E+02 - Norm of air_horizontal_streamfunction: 0.43655893E+02 - Norm of air_horizontal_streamfunction: 0.45349584E+02 - Norm of air_horizontal_streamfunction: 0.37776353E+02 Independent levels: 1[2] Subset Sc0 size: 762 Domain area (% of Earth area): 0.100E+03% @@ -22,37 +5,37 @@ Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. - Norm of air_horizontal_streamfunction: 0.37605821E+02 - Norm of air_horizontal_streamfunction: 0.37200863E+02 - Norm of air_horizontal_streamfunction: 0.35077753E+02 - Norm of air_horizontal_streamfunction: 0.38494491E+02 - Norm of air_horizontal_streamfunction: 0.37170797E+02 - Norm of air_horizontal_streamfunction: 0.40512855E+02 - Norm of air_horizontal_streamfunction: 0.36281219E+02 - Norm of air_horizontal_streamfunction: 0.42116391E+02 - Norm of air_horizontal_streamfunction: 0.40079268E+02 - Norm of air_horizontal_streamfunction: 0.35628690E+02 - Norm of air_horizontal_streamfunction: 0.38098718E+02 - Norm of air_horizontal_streamfunction: 0.39391517E+02 - Norm of air_horizontal_streamfunction: 0.39894646E+02 - Norm of air_horizontal_streamfunction: 0.42481674E+02 - Norm of air_horizontal_streamfunction: 0.36783160E+02 - Norm of air_horizontal_streamfunction: 0.38989116E+02 - Norm of air_horizontal_streamfunction: 0.41006634E+02 - Norm of air_horizontal_streamfunction: 0.38921431E+02 - Norm of air_horizontal_streamfunction: 0.36785924E+02 - Norm of air_horizontal_streamfunction: 0.38937257E+02 - Norm of air_horizontal_streamfunction: 0.34273483E+02 - Norm of air_horizontal_streamfunction: 0.38175683E+02 - Norm of air_horizontal_streamfunction: 0.39062532E+02 - Norm of air_horizontal_streamfunction: 0.40025048E+02 - Norm of air_horizontal_streamfunction: 0.38887402E+02 + Norm of air_horizontal_streamfunction: 0.38170109E+02 + Norm of air_horizontal_streamfunction: 0.43250360E+02 + Norm of air_horizontal_streamfunction: 0.38420513E+02 + Norm of air_horizontal_streamfunction: 0.40458101E+02 + Norm of air_horizontal_streamfunction: 0.39306400E+02 + Norm of air_horizontal_streamfunction: 0.37952964E+02 + Norm of air_horizontal_streamfunction: 0.30132438E+02 + Norm of air_horizontal_streamfunction: 0.36360075E+02 + Norm of air_horizontal_streamfunction: 0.37320392E+02 + Norm of air_horizontal_streamfunction: 0.45297252E+02 + Norm of air_horizontal_streamfunction: 0.40598589E+02 + Norm of air_horizontal_streamfunction: 0.36987288E+02 + Norm of air_horizontal_streamfunction: 0.42363919E+02 + Norm of air_horizontal_streamfunction: 0.41495608E+02 + Norm of air_horizontal_streamfunction: 0.31955099E+02 + Norm of air_horizontal_streamfunction: 0.37922797E+02 + Norm of air_horizontal_streamfunction: 0.40897696E+02 + Norm of air_horizontal_streamfunction: 0.34571548E+02 + Norm of air_horizontal_streamfunction: 0.40082790E+02 + Norm of air_horizontal_streamfunction: 0.37372096E+02 + Norm of air_horizontal_streamfunction: 0.35555318E+02 + Norm of air_horizontal_streamfunction: 0.35688682E+02 + Norm of air_horizontal_streamfunction: 0.39112869E+02 + Norm of air_horizontal_streamfunction: 0.37715849E+02 + Norm of air_horizontal_streamfunction: 0.39559594E+02 Level 1 ~> 100.0% Level 2 ~> 100.0% - Decimate full grid, at least 500 points required, 1090 valid points found - Subgrid hash: 1120638748 - -90.00 deg. ~>100-54-100-100-99-100-99-100-100-99-100-99-100-100-99 - -90.00 deg. ~>100-54-100-100-99-100-99-100-100-99-100-99-100-100-99 + Decimate full grid, at least 500 points required, 762 valid points found + Subgrid hash: -130003308 + -90.00 deg. ~>100-33-100-99-100-75-100-99-100-99-100-99-100-99-100 + -90.00 deg. ~>100-33-100-99-100-75-100-99-100-99-100-99-100-99-100 nc1 = 500 Independent levels: 1[2] Independent levels for angular sector 1 / class 1: 1[2] @@ -70,64 +53,17 @@ Independent levels for angular sector 1 / class 13: 1[2] Independent levels for angular sector 1 / class 14: 1[2] Independent levels for angular sector 1 / class 15: 1[2] - nc1 = 500 - Independent levels: 1[2] - Independent levels for angular sector 1 / class 1: 1[2] - Independent levels for angular sector 1 / class 2: 1[2] - Independent levels for angular sector 1 / class 3: 1[2] - Independent levels for angular sector 1 / class 4: 1[2] - Independent levels for angular sector 1 / class 5: 1[2] - Independent levels for angular sector 1 / class 6: 1[2] - Independent levels for angular sector 1 / class 7: 1[2] - Independent levels for angular sector 1 / class 8: 1[2] - Independent levels for angular sector 1 / class 9: 1[2] - Independent levels for angular sector 1 / class 10: 1[2] - Independent levels for angular sector 1 / class 11: 1[2] - Independent levels for angular sector 1 / class 12: 1[2] - Independent levels for angular sector 1 / class 13: 1[2] - Independent levels for angular sector 1 / class 14: 1[2] - Independent levels for angular sector 1 / class 15: 1[2] - Level: 1 ~> cov. at class zero: 0.96E+00 - Level: 2 ~> cov. at class zero: 0.91E+00 Level: 1 ~> cov. at class zero: 0.10E+01 Level: 2 ~> cov. at class zero: 0.99E+00 - Block air_horizontal_streamfunction: 0.13646608E+00 for 60 diagnostic points - Level: 1 ~> amplitude: 1.00 - cor. hor. support: 3722.94 km - cor. ver. support: 3.10 vertical units - Level: 2 ~> amplitude: 1.00 - cor. hor. support: 3817.09 km - cor. ver. support: 3.10 vertical units - Block air_horizontal_streamfunction: 0.15267547E+00 for 60 diagnostic points + Block air_horizontal_streamfunction: 0.11222235E+00 for 60 diagnostic points Level: 1 ~> amplitude: 1.00 - cor. hor. support: 3607.14 km - cor. ver. support: 3.22 vertical units + cor. hor. support: 7028.45 km + cor. ver. support: 1.26 vertical units Level: 2 ~> amplitude: 1.00 - cor. hor. support: 3694.74 km - cor. ver. support: 3.22 vertical units - Block air_horizontal_streamfunction: 0.23629308E+00 for 30 diagnostic points - Level: 1 ~> loc. at class zero: 0.83 - Level: 2 ~> loc. at class zero: 0.82 - Level: 1 ~> amplitude: 1.00 - loc. hor. support: 4484.40 km - loc. ver. support: 4.10 vertical units - Level: 2 ~> amplitude: 1.00 - loc. hor. support: 4344.81 km - loc. ver. support: 4.10 vertical units - Block air_horizontal_streamfunction: 0.25563407E+00 for 41 diagnostic points + cor. hor. support: 6680.89 km + cor. ver. support: 1.26 vertical units + Block air_horizontal_streamfunction: not sampled Level: 1 ~> loc. at class zero: 0.92 Level: 2 ~> loc. at class zero: 0.92 - Level: 1 ~> amplitude: 1.00 - loc. hor. support: 5436.12 km - loc. ver. support: 6.03 vertical units - Level: 2 ~> amplitude: 1.00 - loc. hor. support: 5378.97 km - loc. ver. support: 6.04 vertical units - Level: 1 ~> hybrid coefficients: 0.50 / 0.47 - Level: 2 ~> hybrid coefficients: 0.43 / 0.52 -Norm of output parameter loc_rh - 1: 2.0765313355080462e+08 -Norm of output parameter loc_rv - 1: 1.9267686907947714e+02 -Norm of output parameter hyb_coef_ens - 1: 2.1960039721223747e+01 -Norm of output parameter hyb_coef_ens_lr - 1: 2.3498553572266275e+01 -Norm of output parameter loc_rh_lr - 1: 2.1589887876004183e+08 -Norm of output parameter loc_rv_lr - 1: 2.4100189906820731e+02 +Norm of output parameter loc_rh - 1: 1.3018411234733273e+40 +Norm of output parameter loc_rv - 1: 1.3018411234733273e+40 diff --git a/test/testref/error_covariance_training_bump_hdiag_6.ref b/test/testref/error_covariance_training_bump_hdiag_6.ref index f586c9246..3e1c8f2ad 100644 --- a/test/testref/error_covariance_training_bump_hdiag_6.ref +++ b/test/testref/error_covariance_training_bump_hdiag_6.ref @@ -5,12 +5,16 @@ Level 2 ~> 100.0% Level 1 ~> 0.100E+01 vert. coord. Level 2 ~> 0.200E+01 vert. coord. - Level 1 ~> 100.0% - Level 2 ~> 100.0% - Decimate full grid, at least 500 points required, 1090 valid points found - Subgrid hash: 1120638748 - -90.00 deg. ~>100-54-100-100-99-100-99-100-100-99-100-99-100-100-99 - -90.00 deg. ~>100-54-100-100-99-100-99-100-100-99-100-99-100-100-99 + Norm of air_horizontal_streamfunction: 0.46774069E+02 + Norm of air_horizontal_streamfunction: 0.49473350E+02 + Norm of air_horizontal_streamfunction: 0.46803110E+02 + Norm of air_horizontal_streamfunction: 0.43951618E+02 + Norm of air_horizontal_streamfunction: 0.43045885E+02 + Norm of air_horizontal_streamfunction: 0.37535957E+02 + Norm of air_horizontal_streamfunction: 0.42717053E+02 + Norm of air_horizontal_streamfunction: 0.43655893E+02 + Norm of air_horizontal_streamfunction: 0.45349584E+02 + Norm of air_horizontal_streamfunction: 0.37776353E+02 nc1 = 500 Independent levels: 1[2] Independent levels for angular sector 1 / class 1: 1[2] @@ -28,71 +32,27 @@ Independent levels for angular sector 1 / class 13: 1[2] Independent levels for angular sector 1 / class 14: 1[2] Independent levels for angular sector 1 / class 15: 1[2] - Independent levels: 1[2] - Subset Sc0 size: 762 - Domain area (% of Earth area): 0.100E+03% - Level 1 ~> 100.0% - Level 2 ~> 100.0% - Level 1 ~> 0.100E+01 vert. coord. - Level 2 ~> 0.200E+01 vert. coord. - nc1 = 500 - Independent levels: 1[2] - Independent levels for angular sector 1 / class 1: 1[2] - Independent levels for angular sector 1 / class 2: 1[2] - Independent levels for angular sector 1 / class 3: 1[2] - Independent levels for angular sector 1 / class 4: 1[2] - Independent levels for angular sector 1 / class 5: 1[2] - Independent levels for angular sector 1 / class 6: 1[2] - Independent levels for angular sector 1 / class 7: 1[2] - Independent levels for angular sector 1 / class 8: 1[2] - Independent levels for angular sector 1 / class 9: 1[2] - Independent levels for angular sector 1 / class 10: 1[2] - Independent levels for angular sector 1 / class 11: 1[2] - Independent levels for angular sector 1 / class 12: 1[2] - Independent levels for angular sector 1 / class 13: 1[2] - Independent levels for angular sector 1 / class 14: 1[2] - Independent levels for angular sector 1 / class 15: 1[2] - Level: 1 ~> cov. at class zero: 0.96E+00 + Level: 1 ~> cov. at class zero: 0.97E+00 Level: 2 ~> cov. at class zero: 0.91E+00 - Level: 1 ~> cov. at class zero: 0.10E+01 - Level: 2 ~> cov. at class zero: 0.99E+00 - Block air_horizontal_streamfunction: 0.13646608E+00 for 60 diagnostic points - Level: 1 ~> amplitude: 1.00 - cor. hor. support: 3722.94 km - cor. ver. support: 3.10 vertical units - Level: 2 ~> amplitude: 1.00 - cor. hor. support: 3817.09 km - cor. ver. support: 3.10 vertical units - Block air_horizontal_streamfunction: 0.15267547E+00 for 60 diagnostic points + Block air_horizontal_streamfunction: 0.14983360E+00 for 60 diagnostic points Level: 1 ~> amplitude: 1.00 - cor. hor. support: 3607.14 km - cor. ver. support: 3.22 vertical units + cor. hor. support: 3856.10 km + cor. ver. support: 3.07 vertical units Level: 2 ~> amplitude: 1.00 - cor. hor. support: 3694.74 km - cor. ver. support: 3.22 vertical units - Block air_horizontal_streamfunction: 0.23629308E+00 for 30 diagnostic points + cor. hor. support: 4050.80 km + cor. ver. support: 3.07 vertical units + Block air_horizontal_streamfunction: 0.25453757E+00 for 31 diagnostic points Level: 1 ~> loc. at class zero: 0.83 - Level: 2 ~> loc. at class zero: 0.82 - Level: 1 ~> amplitude: 1.00 - loc. hor. support: 4484.40 km - loc. ver. support: 4.10 vertical units - Level: 2 ~> amplitude: 1.00 - loc. hor. support: 4344.81 km - loc. ver. support: 4.10 vertical units - Block air_horizontal_streamfunction: 0.25563407E+00 for 41 diagnostic points - Level: 1 ~> loc. at class zero: 0.92 - Level: 2 ~> loc. at class zero: 0.92 + Level: 2 ~> loc. at class zero: 0.81 Level: 1 ~> amplitude: 1.00 - loc. hor. support: 5436.12 km - loc. ver. support: 6.03 vertical units + loc. hor. support: 4703.58 km + loc. ver. support: 3.97 vertical units Level: 2 ~> amplitude: 1.00 - loc. hor. support: 5378.97 km - loc. ver. support: 6.04 vertical units - Level: 1 ~> hybrid coefficients: 0.50 / 0.47 - Level: 2 ~> hybrid coefficients: 0.43 / 0.52 -Norm of output parameter loc_rh - 1: 2.0765313355080462e+08 -Norm of output parameter loc_rv - 1: 1.9267686907947714e+02 -Norm of output parameter hyb_coef_ens - 1: 2.1960039721223744e+01 -Norm of output parameter hyb_coef_ens_lr - 1: 2.3498553572266275e+01 -Norm of output parameter loc_rh_lr - 1: 2.1589887876004183e+08 -Norm of output parameter loc_rv_lr - 1: 2.4100189906820731e+02 + loc. hor. support: 4718.27 km + loc. ver. support: 3.97 vertical units + Level: 1 ~> hybrid coefficients: 0.62 / 0.38 + Level: 2 ~> hybrid coefficients: 0.60 / 0.37 +Norm of output parameter loc_rh - 1: 2.2156394909447184e+08 +Norm of output parameter loc_rv - 1: 1.8662494847989677e+02 +Norm of output parameter hyb_coef_1 - 1: 2.8551328651696274e+01 +Norm of output parameter hyb_coef_2 - 1: 1.7490111330219747e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag_7.ref b/test/testref/error_covariance_training_bump_hdiag_7.ref index f586c9246..363e6a57d 100644 --- a/test/testref/error_covariance_training_bump_hdiag_7.ref +++ b/test/testref/error_covariance_training_bump_hdiag_7.ref @@ -27,35 +27,9 @@ Independent levels for angular sector 1 / class 12: 1[2] Independent levels for angular sector 1 / class 13: 1[2] Independent levels for angular sector 1 / class 14: 1[2] - Independent levels for angular sector 1 / class 15: 1[2] - Independent levels: 1[2] - Subset Sc0 size: 762 - Domain area (% of Earth area): 0.100E+03% - Level 1 ~> 100.0% - Level 2 ~> 100.0% - Level 1 ~> 0.100E+01 vert. coord. - Level 2 ~> 0.200E+01 vert. coord. - nc1 = 500 - Independent levels: 1[2] - Independent levels for angular sector 1 / class 1: 1[2] - Independent levels for angular sector 1 / class 2: 1[2] - Independent levels for angular sector 1 / class 3: 1[2] - Independent levels for angular sector 1 / class 4: 1[2] - Independent levels for angular sector 1 / class 5: 1[2] - Independent levels for angular sector 1 / class 6: 1[2] - Independent levels for angular sector 1 / class 7: 1[2] - Independent levels for angular sector 1 / class 8: 1[2] - Independent levels for angular sector 1 / class 9: 1[2] - Independent levels for angular sector 1 / class 10: 1[2] - Independent levels for angular sector 1 / class 11: 1[2] - Independent levels for angular sector 1 / class 12: 1[2] - Independent levels for angular sector 1 / class 13: 1[2] - Independent levels for angular sector 1 / class 14: 1[2] Independent levels for angular sector 1 / class 15: 1[2] Level: 1 ~> cov. at class zero: 0.96E+00 Level: 2 ~> cov. at class zero: 0.91E+00 - Level: 1 ~> cov. at class zero: 0.10E+01 - Level: 2 ~> cov. at class zero: 0.99E+00 Block air_horizontal_streamfunction: 0.13646608E+00 for 60 diagnostic points Level: 1 ~> amplitude: 1.00 cor. hor. support: 3722.94 km @@ -63,13 +37,6 @@ Level: 2 ~> amplitude: 1.00 cor. hor. support: 3817.09 km cor. ver. support: 3.10 vertical units - Block air_horizontal_streamfunction: 0.15267547E+00 for 60 diagnostic points - Level: 1 ~> amplitude: 1.00 - cor. hor. support: 3607.14 km - cor. ver. support: 3.22 vertical units - Level: 2 ~> amplitude: 1.00 - cor. hor. support: 3694.74 km - cor. ver. support: 3.22 vertical units Block air_horizontal_streamfunction: 0.23629308E+00 for 30 diagnostic points Level: 1 ~> loc. at class zero: 0.83 Level: 2 ~> loc. at class zero: 0.82 @@ -79,20 +46,9 @@ Level: 2 ~> amplitude: 1.00 loc. hor. support: 4344.81 km loc. ver. support: 4.10 vertical units - Block air_horizontal_streamfunction: 0.25563407E+00 for 41 diagnostic points - Level: 1 ~> loc. at class zero: 0.92 - Level: 2 ~> loc. at class zero: 0.92 - Level: 1 ~> amplitude: 1.00 - loc. hor. support: 5436.12 km - loc. ver. support: 6.03 vertical units - Level: 2 ~> amplitude: 1.00 - loc. hor. support: 5378.97 km - loc. ver. support: 6.04 vertical units - Level: 1 ~> hybrid coefficients: 0.50 / 0.47 - Level: 2 ~> hybrid coefficients: 0.43 / 0.52 + Level: 1 ~> hybrid coefficients: 0.57 / 0.41 + Level: 2 ~> hybrid coefficients: 0.63 / 0.34 Norm of output parameter loc_rh - 1: 2.0765313355080462e+08 Norm of output parameter loc_rv - 1: 1.9267686907947714e+02 -Norm of output parameter hyb_coef_ens - 1: 2.1960039721223744e+01 -Norm of output parameter hyb_coef_ens_lr - 1: 2.3498553572266275e+01 -Norm of output parameter loc_rh_lr - 1: 2.1589887876004183e+08 -Norm of output parameter loc_rv_lr - 1: 2.4100189906820731e+02 +Norm of output parameter hyb_coef_1 - 1: 2.8347533387493492e+01 +Norm of output parameter hyb_coef_2 - 1: 1.7701062128658712e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag_8.ref b/test/testref/error_covariance_training_bump_hdiag_8.ref index ae69a4598..0d1b5db21 100644 --- a/test/testref/error_covariance_training_bump_hdiag_8.ref +++ b/test/testref/error_covariance_training_bump_hdiag_8.ref @@ -15,38 +15,6 @@ Norm of air_horizontal_streamfunction: 0.43655893E+02 Norm of air_horizontal_streamfunction: 0.45349584E+02 Norm of air_horizontal_streamfunction: 0.37776353E+02 - Independent levels: 1[2] - Subset Sc0 size: 762 - Domain area (% of Earth area): 0.100E+03% - Level 1 ~> 100.0% - Level 2 ~> 100.0% - Level 1 ~> 0.100E+01 vert. coord. - Level 2 ~> 0.200E+01 vert. coord. - Norm of air_horizontal_streamfunction: 0.38170109E+02 - Norm of air_horizontal_streamfunction: 0.43250360E+02 - Norm of air_horizontal_streamfunction: 0.38420513E+02 - Norm of air_horizontal_streamfunction: 0.40458101E+02 - Norm of air_horizontal_streamfunction: 0.39306400E+02 - Norm of air_horizontal_streamfunction: 0.37952964E+02 - Norm of air_horizontal_streamfunction: 0.30132438E+02 - Norm of air_horizontal_streamfunction: 0.36360075E+02 - Norm of air_horizontal_streamfunction: 0.37320392E+02 - Norm of air_horizontal_streamfunction: 0.45297252E+02 - Norm of air_horizontal_streamfunction: 0.40598589E+02 - Norm of air_horizontal_streamfunction: 0.36987288E+02 - Norm of air_horizontal_streamfunction: 0.42363919E+02 - Norm of air_horizontal_streamfunction: 0.41495608E+02 - Norm of air_horizontal_streamfunction: 0.31955099E+02 - Norm of air_horizontal_streamfunction: 0.37922797E+02 - Norm of air_horizontal_streamfunction: 0.40897696E+02 - Norm of air_horizontal_streamfunction: 0.34571548E+02 - Norm of air_horizontal_streamfunction: 0.40082790E+02 - Norm of air_horizontal_streamfunction: 0.37372096E+02 - Norm of air_horizontal_streamfunction: 0.35555318E+02 - Norm of air_horizontal_streamfunction: 0.35688682E+02 - Norm of air_horizontal_streamfunction: 0.39112869E+02 - Norm of air_horizontal_streamfunction: 0.37715849E+02 - Norm of air_horizontal_streamfunction: 0.39559594E+02 Level 1 ~> 100.0% Level 2 ~> 100.0% Decimate full grid, at least 500 points required, 1090 valid points found @@ -69,28 +37,9 @@ Independent levels for angular sector 1 / class 12: 1[2] Independent levels for angular sector 1 / class 13: 1[2] Independent levels for angular sector 1 / class 14: 1[2] - Independent levels for angular sector 1 / class 15: 1[2] - nc1 = 500 - Independent levels: 1[2] - Independent levels for angular sector 1 / class 1: 1[2] - Independent levels for angular sector 1 / class 2: 1[2] - Independent levels for angular sector 1 / class 3: 1[2] - Independent levels for angular sector 1 / class 4: 1[2] - Independent levels for angular sector 1 / class 5: 1[2] - Independent levels for angular sector 1 / class 6: 1[2] - Independent levels for angular sector 1 / class 7: 1[2] - Independent levels for angular sector 1 / class 8: 1[2] - Independent levels for angular sector 1 / class 9: 1[2] - Independent levels for angular sector 1 / class 10: 1[2] - Independent levels for angular sector 1 / class 11: 1[2] - Independent levels for angular sector 1 / class 12: 1[2] - Independent levels for angular sector 1 / class 13: 1[2] - Independent levels for angular sector 1 / class 14: 1[2] Independent levels for angular sector 1 / class 15: 1[2] Level: 1 ~> cov. at class zero: 0.96E+00 Level: 2 ~> cov. at class zero: 0.91E+00 - Level: 1 ~> cov. at class zero: 0.10E+01 - Level: 2 ~> cov. at class zero: 0.99E+00 Block air_horizontal_streamfunction: 0.13646608E+00 for 60 diagnostic points Level: 1 ~> amplitude: 1.00 cor. hor. support: 3722.94 km @@ -98,13 +47,6 @@ Level: 2 ~> amplitude: 1.00 cor. hor. support: 3817.09 km cor. ver. support: 3.10 vertical units - Block air_horizontal_streamfunction: 0.13059648E+00 for 60 diagnostic points - Level: 1 ~> amplitude: 1.00 - cor. hor. support: 7069.88 km - cor. ver. support: 1.27 vertical units - Level: 2 ~> amplitude: 1.00 - cor. hor. support: 6747.68 km - cor. ver. support: 1.27 vertical units Block air_horizontal_streamfunction: 0.23629308E+00 for 30 diagnostic points Level: 1 ~> loc. at class zero: 0.83 Level: 2 ~> loc. at class zero: 0.82 @@ -114,9 +56,9 @@ Level: 2 ~> amplitude: 1.00 loc. hor. support: 4344.81 km loc. ver. support: 4.10 vertical units - Level: 1 ~> hybrid coefficients: 0.44 / 0.53 - Level: 2 ~> hybrid coefficients: 0.35 / 0.60 + Level: 1 ~> hybrid coefficients: 0.45 / 0.53 + Level: 2 ~> hybrid coefficients: 0.43 / 0.52 Norm of output parameter loc_rh - 1: 2.0765313355080462e+08 Norm of output parameter loc_rv - 1: 1.9267686907947714e+02 -Norm of output parameter hyb_coef_ens - 1: 1.8705085421661085e+01 -Norm of output parameter hyb_coef_sta - 1: 2.2109787911488581e+01 +Norm of output parameter hyb_coef_1 - 1: 2.0804336651009727e+01 +Norm of output parameter hyb_coef_2 - 1: 2.4636072162525416e+01 diff --git a/test/testref/error_covariance_training_bump_hdiag_9.ref b/test/testref/error_covariance_training_bump_hdiag_9.ref index dccbeb387..a15112e70 100644 --- a/test/testref/error_covariance_training_bump_hdiag_9.ref +++ b/test/testref/error_covariance_training_bump_hdiag_9.ref @@ -15,38 +15,6 @@ Norm of air_horizontal_streamfunction: 0.43655893E+02 Norm of air_horizontal_streamfunction: 0.45349584E+02 Norm of air_horizontal_streamfunction: 0.37776353E+02 - Independent levels: 1[2] - Subset Sc0 size: 762 - Domain area (% of Earth area): 0.100E+03% - Level 1 ~> 100.0% - Level 2 ~> 100.0% - Level 1 ~> 0.100E+01 vert. coord. - Level 2 ~> 0.200E+01 vert. coord. - Norm of air_horizontal_streamfunction: 0.38170109E+02 - Norm of air_horizontal_streamfunction: 0.43250360E+02 - Norm of air_horizontal_streamfunction: 0.38420513E+02 - Norm of air_horizontal_streamfunction: 0.40458101E+02 - Norm of air_horizontal_streamfunction: 0.39306400E+02 - Norm of air_horizontal_streamfunction: 0.37952964E+02 - Norm of air_horizontal_streamfunction: 0.30132438E+02 - Norm of air_horizontal_streamfunction: 0.36360075E+02 - Norm of air_horizontal_streamfunction: 0.37320392E+02 - Norm of air_horizontal_streamfunction: 0.45297252E+02 - Norm of air_horizontal_streamfunction: 0.40598589E+02 - Norm of air_horizontal_streamfunction: 0.36987288E+02 - Norm of air_horizontal_streamfunction: 0.42363919E+02 - Norm of air_horizontal_streamfunction: 0.41495608E+02 - Norm of air_horizontal_streamfunction: 0.31955099E+02 - Norm of air_horizontal_streamfunction: 0.37922797E+02 - Norm of air_horizontal_streamfunction: 0.40897696E+02 - Norm of air_horizontal_streamfunction: 0.34571548E+02 - Norm of air_horizontal_streamfunction: 0.40082790E+02 - Norm of air_horizontal_streamfunction: 0.37372096E+02 - Norm of air_horizontal_streamfunction: 0.35555318E+02 - Norm of air_horizontal_streamfunction: 0.35688682E+02 - Norm of air_horizontal_streamfunction: 0.39112869E+02 - Norm of air_horizontal_streamfunction: 0.37715849E+02 - Norm of air_horizontal_streamfunction: 0.39559594E+02 Level 1 ~> 100.0% Level 2 ~> 100.0% Decimate full grid, at least 500 points required, 1090 valid points found @@ -69,28 +37,9 @@ Independent levels for angular sector 1 / class 12: 1[2] Independent levels for angular sector 1 / class 13: 1[2] Independent levels for angular sector 1 / class 14: 1[2] - Independent levels for angular sector 1 / class 15: 1[2] - nc1 = 500 - Independent levels: 1[2] - Independent levels for angular sector 1 / class 1: 1[2] - Independent levels for angular sector 1 / class 2: 1[2] - Independent levels for angular sector 1 / class 3: 1[2] - Independent levels for angular sector 1 / class 4: 1[2] - Independent levels for angular sector 1 / class 5: 1[2] - Independent levels for angular sector 1 / class 6: 1[2] - Independent levels for angular sector 1 / class 7: 1[2] - Independent levels for angular sector 1 / class 8: 1[2] - Independent levels for angular sector 1 / class 9: 1[2] - Independent levels for angular sector 1 / class 10: 1[2] - Independent levels for angular sector 1 / class 11: 1[2] - Independent levels for angular sector 1 / class 12: 1[2] - Independent levels for angular sector 1 / class 13: 1[2] - Independent levels for angular sector 1 / class 14: 1[2] Independent levels for angular sector 1 / class 15: 1[2] Level: 1 ~> cov. at class zero: 0.96E+00 Level: 2 ~> cov. at class zero: 0.91E+00 - Level: 1 ~> cov. at class zero: 0.10E+01 - Level: 2 ~> cov. at class zero: 0.99E+00 Block air_horizontal_streamfunction: 0.13646608E+00 for 60 diagnostic points Level: 1 ~> amplitude: 1.00 cor. hor. support: 3722.94 km @@ -98,23 +47,16 @@ Level: 2 ~> amplitude: 1.00 cor. hor. support: 3817.09 km cor. ver. support: 3.10 vertical units - Block air_horizontal_streamfunction: 0.13059648E+00 for 60 diagnostic points - Level: 1 ~> amplitude: 1.00 - cor. hor. support: 7069.88 km - cor. ver. support: 1.27 vertical units - Level: 2 ~> amplitude: 1.00 - cor. hor. support: 6747.68 km - cor. ver. support: 1.27 vertical units - Block air_horizontal_streamfunction: 0.00000000E+00 for 0 diagnostic points + Block air_horizontal_streamfunction: not sampled Level: 1 ~> amplitude: 1.00 loc. hor. support: 10000.00 km loc. ver. support: 2.00 vertical units Level: 2 ~> amplitude: 1.00 loc. hor. support: 10000.00 km loc. ver. support: 2.00 vertical units - Level: 1 ~> hybrid coefficients: 0.38 / 0.59 - Level: 2 ~> hybrid coefficients: 0.24 / 0.70 + Level: 1 ~> hybrid coefficients: 0.39 / 0.58 + Level: 2 ~> hybrid coefficients: 0.23 / 0.71 Norm of output parameter loc_rh - 1: 4.7031904065219390e+08 Norm of output parameter loc_rv - 1: 9.4063808130438773e+01 -Norm of output parameter hyb_coef_ens - 1: 1.5014332700824335e+01 -Norm of output parameter hyb_coef_sta - 1: 2.4902921786234842e+01 +Norm of output parameter hyb_coef_1 - 1: 1.5228340242078120e+01 +Norm of output parameter hyb_coef_2 - 1: 3.0394788555688265e+01 From e8fafaf86f1f0d1949f6fbb6c9b02832d4f526c4 Mon Sep 17 00:00:00 2001 From: Anna Shlyaeva Date: Thu, 15 Jan 2026 13:33:18 -0700 Subject: [PATCH 143/199] Adapt to retirement of Increment/StateEnsemble classes (#1163) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Anna Shlyaeva Co-authored-by: Yannick Trémolet <30638944+ytremolet@users.noreply.github.com> --- src/saber/oops/Utilities.cc | 45 ++++++++++++++++++ src/saber/oops/Utilities.h | 92 +++++++++++++------------------------ 2 files changed, 77 insertions(+), 60 deletions(-) diff --git a/src/saber/oops/Utilities.cc b/src/saber/oops/Utilities.cc index 7d56778ee..0c3fe2be3 100644 --- a/src/saber/oops/Utilities.cc +++ b/src/saber/oops/Utilities.cc @@ -111,5 +111,50 @@ void allocateMissingFields(oops::FieldSet3D & fset, // ----------------------------------------------------------------------------- +size_t getNensFromConfig(const eckit::LocalConfiguration & conf) { + // expecting either `members` (list) or `members from template` (object with nmembers/template). + size_t nens = 0; + ASSERT(conf.has("members from template") || conf.has("members")); + ASSERT(!(conf.has("members from template") && conf.has("members"))); + if (conf.has("members")) { + const auto members = conf.getSubConfigurations("members"); + nens = members.size(); + } else { + const auto members = conf.getSubConfiguration("members from template"); + ASSERT(members.has("nmembers")); + ASSERT(members.has("pattern")); + ASSERT(members.has("template")); + nens = members.getInt("nmembers"); + } + return nens; +} + +// ----------------------------------------------------------------------------- + +eckit::LocalConfiguration getEnsSubconfig(const eckit::LocalConfiguration & conf, size_t iens) { + // expecting either `members` (list) or `members from template` (object with nmembers/template). + eckit::LocalConfiguration memConf; + if (conf.has("members")) { + const auto members = conf.getSubConfigurations("members"); + if (!members.empty()) memConf = members[iens]; + } else { + eckit::LocalConfiguration members = conf.getSubConfiguration("members from template"); + memConf = members.getSubConfiguration("template"); + const std::string pattern = members.getString("pattern"); + const int zpad = members.getInt("zero padding", 0); + const std::vector except = members.getUnsignedVector("except", {}); + size_t index = members.getUnsigned("start", 1); + for (size_t jj = 0; jj <= iens; ++jj) { + // Check for excluded members + while (std::count(except.begin(), except.end(), index)) { + index++; + } + // Update counter + if (jj < iens) index++; + } + util::seekAndReplace(memConf, pattern, index, zpad); + } + return memConf; +} } // namespace saber diff --git a/src/saber/oops/Utilities.h b/src/saber/oops/Utilities.h index 38005a280..6ebddd950 100644 --- a/src/saber/oops/Utilities.h +++ b/src/saber/oops/Utilities.h @@ -23,10 +23,8 @@ #include "oops/base/FieldSets.h" #include "oops/base/Geometry.h" #include "oops/base/Increment.h" -#include "oops/base/IncrementEnsemble.h" #include "oops/base/IncrementSet.h" #include "oops/base/State4D.h" -#include "oops/base/StateEnsemble.h" #include "oops/base/StateSet.h" #include "oops/base/Variables.h" #include "oops/interface/ModelData.h" @@ -83,6 +81,14 @@ void allocateMissingFields(oops::FieldSet3D & fset, // ----------------------------------------------------------------------------- +size_t getNensFromConfig(const eckit::LocalConfiguration & conf); + +// ----------------------------------------------------------------------------- + +eckit::LocalConfiguration getEnsSubconfig(const eckit::LocalConfiguration & conf, size_t iens); + +// ----------------------------------------------------------------------------- + template oops::FieldSets readEnsemble(const oops::Geometry & geom, const oops::Variables & modelvars, @@ -102,40 +108,31 @@ oops::FieldSets readEnsemble(const oops::Geometry & geom, eckit::LocalConfiguration varConf; // Ensemble of states, perturbation using the mean - oops::IncrementEnsembleFromStatesParameters ensembleParams; eckit::LocalConfiguration ensembleConf = inputConf.getSubConfiguration("ensemble"); if (inputConf.has("ensemble")) { - ensembleParams.deserialize(ensembleConf); - nens = ensembleParams.states.size(); + nens = getNensFromConfig(ensembleConf); + varConf = getEnsSubconfig(ensembleConf, 0); outputConf.set("ensemble", ensembleConf); - varConf = ensembleParams.states.getStateConfig(0, 0); ++ensembleFound; } // Increment ensemble from increments on disk - oops::IncrementEnsembleParameters ensemblePertParams; - eckit::LocalConfiguration ensemblePert; + eckit::LocalConfiguration ensemblePert = inputConf.getSubConfiguration("ensemble pert"); if (inputConf.has("ensemble pert")) { - ensemblePert = inputConf.getSubConfiguration("ensemble pert"); - ensemblePertParams.deserialize(ensemblePert); - nens = ensemblePertParams.size(); + nens = getNensFromConfig(ensemblePert); + varConf = getEnsSubconfig(ensemblePert, 0); outputConf.set("ensemble pert", ensemblePert); - varConf = ensemblePertParams.getIncrementParameters(0); ++ensembleFound; } // Increment ensemble from difference of two states - oops::StateEnsembleParameters ensembleBaseParams; - oops::StateEnsembleParameters ensemblePairsParams; eckit::LocalConfiguration ensembleBase; eckit::LocalConfiguration ensemblePairs; if (inputConf.has("ensemble base") && inputConf.has("ensemble pairs")) { ensembleBase = inputConf.getSubConfiguration("ensemble base"); ensemblePairs = inputConf.getSubConfiguration("ensemble pairs"); - ensembleBaseParams.deserialize(ensembleBase); - ensemblePairsParams.deserialize(ensemblePairs); - nens = ensembleBaseParams.size(); - varConf = ensembleBaseParams.getStateConfig(0, 0); + nens = getNensFromConfig(ensembleBase); + varConf = getEnsSubconfig(ensembleBase, 0); outputConf.set("ensemble base", ensembleBase); outputConf.set("ensemble pairs", ensemblePairs); ++ensembleFound; @@ -146,29 +143,8 @@ oops::FieldSets readEnsemble(const oops::Geometry & geom, if (inputConf.has("ensemble pert on other geometry") && inputConf.has("ensemble geometry")) { ensemblePertOtherGeom = inputConf.getSubConfiguration("ensemble pert on other geometry"); - - // Bespoke validation, mimicking oops::IncrementEnsembleParameters - ASSERT(ensemblePertOtherGeom.has("date")); - ASSERT(ensemblePertOtherGeom.has("members from template") - || ensemblePertOtherGeom.has("members")); - ASSERT(!(ensemblePertOtherGeom.has("members from template") - && ensemblePertOtherGeom.has("members"))); - - if (ensemblePertOtherGeom.has("members")) { - const auto members = ensemblePertOtherGeom.getSubConfigurations("members"); - nens = members.size(); - varConf = members[0]; - } - - if (ensemblePertOtherGeom.has("members from template")) { - const auto members = ensemblePertOtherGeom.getSubConfiguration("members from template"); - ASSERT(members.has("nmembers")); - ASSERT(members.has("pattern")); - ASSERT(members.has("template")); - nens = members.getInt("nmembers"); - varConf = members.getSubConfiguration("template"); - } - + nens = getNensFromConfig(ensemblePertOtherGeom); + varConf = getEnsSubconfig(ensemblePertOtherGeom, 0); outputConf.set("ensemble pert on other geometry", ensemblePertOtherGeom); outputConf.set("ensemble geometry", inputConf.getSubConfiguration("ensemble geometry")); @@ -204,7 +180,7 @@ oops::FieldSets readEnsemble(const oops::Geometry & geom, if (!ensemblePert.empty()) { oops::Log::info() << "Info : Increment ensemble from increments on disk" << std::endl; oops::IncrementSet ensemble(geom, vars, xb.times(), - ensemblePertParams.toConfiguration(), xb.commTime()); + ensemblePert, xb.commTime()); oops::FieldSets fsetEns(ensemble); return fsetEns; } @@ -213,8 +189,8 @@ oops::FieldSets readEnsemble(const oops::Geometry & geom, if (!ensembleBase.empty() && !ensemblePairs.empty()) { oops::Log::info() << "Info : Increment ensemble from difference of two states" << std::endl; - oops::StateSet states1(geom, ensembleBaseParams.toConfiguration(), xb.commTime()); - oops::StateSet states2(geom, ensemblePairsParams.toConfiguration(), xb.commTime()); + oops::StateSet states1(geom, ensembleBase, xb.commTime()); + oops::StateSet states2(geom, ensemblePairs, xb.commTime()); oops::IncrementSet ensemble(geom, vars, states1.times(), states1.commTime(), states1.members(), states1.commEns()); ensemble.diff(states1, states2); @@ -337,12 +313,10 @@ void readEnsembleMember(const oops::Geometry & geom, const size_t myrank = geom.timeComm().rank(); if (conf.has("ensemble")) { - // Ensemble of states passed as increments - oops::StateEnsembleParameters states; - states.deserialize(conf.getSubConfiguration("ensemble")); - // Read state - oops::State xx(geom, states.getStateConfig(ie, myrank)); + eckit::LocalConfiguration memConf = getEnsSubconfig( + conf.getSubConfiguration("ensemble"), ie); + oops::State xx(geom, memConf); // Copy FieldSet fset.deepCopy(xx.fieldSet()); @@ -352,12 +326,11 @@ void readEnsembleMember(const oops::Geometry & geom, if (conf.has("ensemble pert")) { // Increment ensemble from increments on disk - oops::IncrementEnsembleParameters ensemblePertParams; - ensemblePertParams.deserialize(conf.getSubConfiguration("ensemble pert")); - + eckit::LocalConfiguration memConf = getEnsSubconfig( + conf.getSubConfiguration("ensemble pert"), ie); // Read Increment oops::Increment dx(geom, vars, fset.validTime()); - dx.read(ensemblePertParams.getIncrementParameters(ie)); + dx.read(memConf); // Get FieldSet fset.deepCopy(dx.fieldSet()); @@ -367,15 +340,14 @@ void readEnsembleMember(const oops::Geometry & geom, if (conf.has("ensemble base") && conf.has("ensemble pairs")) { // Increment ensemble from difference of two states - oops::StateEnsembleParameters ensembleBaseParams; - ensembleBaseParams.deserialize(conf.getSubConfiguration("ensemble base")); - oops::StateEnsembleParameters ensemblePairsParams; - ensemblePairsParams.deserialize(conf.getSubConfiguration("ensemble pairs")); + eckit::LocalConfiguration memConfBase = getEnsSubconfig( + conf.getSubConfiguration("ensemble base"), ie); + eckit::LocalConfiguration memConfPairs = getEnsSubconfig( + conf.getSubConfiguration("ensemble pairs"), ie); // Read states - oops::State xxBase(geom, ensembleBaseParams.getStateConfig(ie, myrank)); - oops::State xxPairs(geom, ensemblePairsParams.getStateConfig(ie, myrank)); - + oops::State xxBase(geom, memConfBase); + oops::State xxPairs(geom, memConfPairs); // Compute difference oops::Increment dx(geom, vars, fset.validTime()); dx.diff(xxPairs, xxBase); From dab9b6eae4f84af5416315d98e4f0fc8db390e8d Mon Sep 17 00:00:00 2001 From: Francois Hebert Date: Tue, 20 Jan 2026 15:47:43 -0700 Subject: [PATCH 144/199] Slightly loosen a tolerance for intel ifx builds (#1168) Testing a build of JEDI with the IntelLLVM 2025.3 compiler, I see the ctest saber_test_dirac_bump_5_1-1 will pass/fail depending on the specific compiler flags for floating-point math. So I'm slightly loosening the tolerance in this PR. --- test/testinput/dirac_bump_5.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/testinput/dirac_bump_5.yaml b/test/testinput/dirac_bump_5.yaml index bb58ad95d..497cafc8e 100644 --- a/test/testinput/dirac_bump_5.yaml +++ b/test/testinput/dirac_bump_5.yaml @@ -18,7 +18,7 @@ background error: covariance model: SABER adjoint test: true square-root test: true - square-root tolerance: 3.0e-12 + square-root tolerance: 1.0e-11 ensemble: members from template: template: From 4a2623ca35b1694489fbe586e5cfc335e9c0d9d8 Mon Sep 17 00:00:00 2001 From: Matt Shin Date: Wed, 21 Jan 2026 19:25:08 +0000 Subject: [PATCH 145/199] Remove unused variable (#1167) Follow up for #1163. Debug build failing due to unused variable. Co-authored-by: Michael Cooke <48374999+mikecooke77@users.noreply.github.com> --- src/saber/oops/Utilities.h | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/saber/oops/Utilities.h b/src/saber/oops/Utilities.h index 6ebddd950..45c708a06 100644 --- a/src/saber/oops/Utilities.h +++ b/src/saber/oops/Utilities.h @@ -310,8 +310,6 @@ void readEnsembleMember(const oops::Geometry & geom, // Fill FieldSet size_t ensembleFound = 0; - const size_t myrank = geom.timeComm().rank(); - if (conf.has("ensemble")) { // Read state eckit::LocalConfiguration memConf = getEnsSubconfig( From ab923ff4c65cfc55b39ae973f907d577baaea3a1 Mon Sep 17 00:00:00 2001 From: Benjamin Menetrier <30638301+benjaminmenetrier@users.noreply.github.com> Date: Thu, 22 Jan 2026 19:13:41 +0100 Subject: [PATCH 146/199] Simplify ProcessPerts (#1165) * All tests passing * Update yamls --------- Co-authored-by: Thomas Hutchins Co-authored-by: Anna Shlyaeva --- src/saber/oops/ProcessPerts.h | 49 ++++++++++++------- .../testinput/process_perts_bump_nicas_1.yaml | 5 +- .../testinput/process_perts_bump_nicas_2.yaml | 5 +- .../testinput/process_perts_bump_nicas_3.yaml | 5 +- test/testinput/process_perts_diffusion_1.yaml | 6 +-- .../process_perts_from_csdual_states_1.yaml | 6 +-- .../process_perts_from_gauss_perts_1.yaml | 6 +-- 7 files changed, 46 insertions(+), 36 deletions(-) diff --git a/src/saber/oops/ProcessPerts.h b/src/saber/oops/ProcessPerts.h index a1826d82b..8edd15565 100644 --- a/src/saber/oops/ProcessPerts.h +++ b/src/saber/oops/ProcessPerts.h @@ -92,8 +92,6 @@ template class FilterParameters : /// it is set to "false". oops::Parameter residualFromFilter{ "use residual from filter", false, this}; - oops::Parameter residualIncrementFromOtherBands{ - "residual increment from previous bands", false, this}; // This will give the parameters associated with an ErrorCovariance model // and can be used to provide a filtering operation. @@ -134,7 +132,7 @@ template class BandParameters : typedef FilterParameters FilterParameters_; typedef OutputWriteParameters outputParameters_; - oops::RequiredParameter band{"band", this}; + oops::OptionalParameter band{"band", this}; oops::OptionalParameter output{"output", this}; }; @@ -158,6 +156,8 @@ template class ProcessPertsParameters : oops::RequiredParameter> bands{"bands", this}; + oops::Parameter recursiveFilters{"recursive filters", false, this}; + /// Where to read input ensemble: From states or perturbations oops::OptionalParameter ensemble{"ensemble", this}; oops::OptionalParameter ensemblePert{"ensemble pert", this}; @@ -250,26 +250,28 @@ template class ProcessPerts : public oops::Application { const std::size_t nbands = params.bands.value().size(); const std::vector bandsConfs = fullConfig.getSubConfigurations("bands"); + const bool recursiveFilters = params.recursiveFilters.value(); // need to create a vectors of saber block chains to use later std::map diagBlockConfs; std::map filterCovBlockConfs; std::map genericWriteConfs; std::map modelWriteConfs; - std::vector calcResidualIncrement; std::vector calcComplement; std::size_t b(0); for (const auto & bandConf : bandsConfs) { - eckit::LocalConfiguration bConf = bandConf.getSubConfiguration("band"); - if (bConf.has("filter")) { + if (bandConf.has("band")) { + // Add filter for this band + eckit::LocalConfiguration bConf = bandConf.getSubConfiguration("band"); eckit::LocalConfiguration fConf = bConf.getSubConfiguration("filter"); filterCovBlockConfs[b] = fConf; + calcComplement.push_back( + bConf.getBool("use residual from filter", false) ); + } else { + // Last band without filter: complement of the sum of all previous bands + ASSERT(b == nbands-1); } - calcResidualIncrement.push_back( - bConf.getBool("residual increment from previous bands", false) ); - calcComplement.push_back( - bConf.getBool("use residual from filter", false) ); if (bandConf.has("output")) { eckit::LocalConfiguration oConf = bandConf.getSubConfiguration("output"); @@ -311,6 +313,7 @@ template class ProcessPerts : public oops::Application { // Loop over perturbations for (int jm = 0; jm < nincrements; ++jm) { + // Initialize work perturbation xI from ensemble perturbation x0 oops::FieldSet3D fsetI(fsetEnsI[jm]); oops::FieldSet4D fset4dDxI(fsetI); @@ -318,35 +321,45 @@ template class ProcessPerts : public oops::Application { << "member " << jm+1 << ": " << fsetI.norm(fsetI.variables()) << std::endl; + // Initialize sum of filtered perturbations oops::FieldSet3D fsetSum(fsetI.validTime(), fsetI.commGeom()); fsetSum.allocateOnly(fsetI.fieldSet()); fsetSum.zero(); oops::FieldSet4D fset4dDxSum(fsetSum); for (std::size_t b = 0; b < nbands; ++b) { - // Copy perturbation + // Copy work perturbation x = xI oops::FieldSet3D fset(fsetI.validTime(), fsetI.commGeom()); fset.deepCopy(fsetI.fieldSet()); - oops::FieldSet4D fset4dDx(fset); - // Apply filter blocks if (auto it{filterCovBlockConfs.find(b)}; it != std::end(filterCovBlockConfs)) { + // Get filter blocks index const std::size_t idx = std::distance(std::begin(filterCovBlockConfs), it); + + // Apply filter G on input x: x' = Gx saberFilterBlocks[idx]->filter(fset4dDx); + if (calcComplement[b]) { + // Use filter complement: x' = (I-G)x fset4dDx[0] -= fset4dDxI[0]; fset4dDx[0] *= -1.0; } - } - // residual increment - if (calcResidualIncrement[b]) { + if (recursiveFilters) { + // Recursive filters: xI = xI - x' + fset4dDxI[0] -= fset4dDx[0]; + } + + // Increment sum with the latest x' + fset4dDxSum += fset4dDx; + } else { + // Residual increment: x' = x0 - sum{previous x'} + fset4dDx[0].zero(); + fset4dDx[0] += fsetEnsI[jm]; fset4dDx[0] -= fset4dDxSum[0]; } - fset4dDxSum += fset4dDx; - oops::Log::test() << "Norm of band perturbation: " << "member " << jm+1 << ": band " << b+1 << ": " << fset4dDx[0].norm(fset4dDx[0].variables()) diff --git a/test/testinput/process_perts_bump_nicas_1.yaml b/test/testinput/process_perts_bump_nicas_1.yaml index f4f3aee80..444c1c684 100644 --- a/test/testinput/process_perts_bump_nicas_1.yaml +++ b/test/testinput/process_perts_bump_nicas_1.yaml @@ -42,12 +42,11 @@ bands: model write: filepath: testdata/process_perts_bump_nicas_1/filtered_pert_mb%MEM%_wb1 member pattern: '%MEM%' -- band: - residual increment from previous bands: true - output: +- output: model write: filepath: testdata/process_perts_bump_nicas_1/filtered_pert_mb%MEM%_wb2 member pattern: '%MEM%' +recursive filters: true ensemble pert: date: *date members from template: diff --git a/test/testinput/process_perts_bump_nicas_2.yaml b/test/testinput/process_perts_bump_nicas_2.yaml index deb9192f9..1fde5c573 100644 --- a/test/testinput/process_perts_bump_nicas_2.yaml +++ b/test/testinput/process_perts_bump_nicas_2.yaml @@ -30,12 +30,11 @@ bands: model write: filepath: testdata/process_perts_bump_nicas_2/filtered_pert_mb%MEM%_wb1 member pattern: '%MEM%' -- band: - residual increment from previous bands: true - output: +- output: model write: filepath: testdata/process_perts_bump_nicas_2/filtered_pert_mb%MEM%_wb2 member pattern: '%MEM%' +recursive filters: true ensemble pert: date: *date members from template: diff --git a/test/testinput/process_perts_bump_nicas_3.yaml b/test/testinput/process_perts_bump_nicas_3.yaml index 292401f9e..d86003d83 100644 --- a/test/testinput/process_perts_bump_nicas_3.yaml +++ b/test/testinput/process_perts_bump_nicas_3.yaml @@ -39,12 +39,11 @@ bands: model write: filepath: testdata/process_perts_bump_nicas_3/filtered_pert_mb%MEM%_wb1 member pattern: '%MEM%' -- band: - residual increment from previous bands: true - output: +- output: model write: filepath: testdata/process_perts_bump_nicas_3/filtered_pert_mb%MEM%_wb2 member pattern: '%MEM%' +recursive filters: true ensemble pert: date: *date members from template: diff --git a/test/testinput/process_perts_diffusion_1.yaml b/test/testinput/process_perts_diffusion_1.yaml index 5f28b762d..1456426f4 100644 --- a/test/testinput/process_perts_diffusion_1.yaml +++ b/test/testinput/process_perts_diffusion_1.yaml @@ -29,13 +29,13 @@ bands: model write: filepath: testdata/process_perts_diffusion_1/filtered_pert_mb%MEM%_wb1 member pattern: '%MEM%' -- band: - residual increment from previous bands: true - output: +- output: model write: filepath: testdata/process_perts_diffusion_1/filtered_pert_mb%MEM%_wb2 member pattern: '%MEM%' +recursive filters: true + ensemble pert: date: *date members from template: diff --git a/test/testinput/process_perts_from_csdual_states_1.yaml b/test/testinput/process_perts_from_csdual_states_1.yaml index 79eb742b5..6cbf21636 100644 --- a/test/testinput/process_perts_from_csdual_states_1.yaml +++ b/test/testinput/process_perts_from_csdual_states_1.yaml @@ -34,13 +34,13 @@ bands: model write: filepath: testdata/process_perts_from_csdual_states_1/filtered_pert_mb%MEM%_wb1 member pattern: '%MEM%' -- band: - residual increment from previous bands: true - output: +- output: model write: filepath: testdata/process_perts_from_csdual_states_1/filtered_pert_mb%MEM%_wb2 member pattern: '%MEM%' +recursive filters: true + ensemble: members: - date: *date diff --git a/test/testinput/process_perts_from_gauss_perts_1.yaml b/test/testinput/process_perts_from_gauss_perts_1.yaml index c690f2047..b4e46c60a 100644 --- a/test/testinput/process_perts_from_gauss_perts_1.yaml +++ b/test/testinput/process_perts_from_gauss_perts_1.yaml @@ -47,9 +47,7 @@ bands: - northward_wind - unbalanced_pressure_levels_minus_one filter mode: true # instead of running the adjoint code it runs the inverse -- band: - residual increment from previous bands: true - output: +- output: generic write: filepath: testdata/process_perts_from_gauss_perts_1/filtered_pert_grid_%GRID%_mb%MEM%_wb2 member pattern: '%MEM%' @@ -58,6 +56,8 @@ bands: filepath: testdata/process_perts_from_gauss_perts_1/filtered_pert_mb%MEM%_wb2 member pattern: '%MEM%' +recursive filters: true + ensemble pert: date: *date members from template: From 3c05c33f73b9be6da0e23a6d313049c570730cec Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Mon, 26 Jan 2026 21:00:36 +0000 Subject: [PATCH 147/199] WIP --- src/saber/mgbf/covariance/MGBF_Covariance.h | 1 - 1 file changed, 1 deletion(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index 2a5fb251a..c71e62d2d 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -83,7 +83,6 @@ MGBF_Covariance(const oops::GeometryData & geometryData, void iterativeCalibrationUpdate(const oops::FieldSet3D &) override{}; void iterativeCalibrationFinal() override{}; - void dualResolutionSetup(const oops::GeometryData &) override{}; void write() const override {}; std::vector> fieldsToWrite() const From f0286a9263569ae5bebcab38ff462bc79677de55 Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Mon, 26 Jan 2026 21:01:01 +0000 Subject: [PATCH 148/199] WIP --- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 44cdc12a3..6ae6c5e93 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1507,7 +1507,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) do i=1,this%im do j=1,this%jm - write(6,*)'thinkdeb999 dxfm/dyfm i,j = ',i,' ',j,' ',this%dxfm(i,j),' ',this%dyfm(i,j) this%paspx4d(1,i,j,1)=(rtem1/this%dxfmctrl*this%dxfm(i,j)) ! !cltthinkdeb9999 this%paspy4d(1,i,j,1)=(rtem1/this%dyfmctrl*this%dyfm(i,j)) ! enddo From babaab7846c7adeaeb5c056e8ad9aa5950541ebf Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Mon, 26 Jan 2026 21:02:02 +0000 Subject: [PATCH 149/199] WIP --- quench/src/Increment.cc | 4 ---- 1 file changed, 4 deletions(-) diff --git a/quench/src/Increment.cc b/quench/src/Increment.cc index 4213d96a9..50acd7200 100644 --- a/quench/src/Increment.cc +++ b/quench/src/Increment.cc @@ -123,10 +123,6 @@ void Increment::zero(const util::DateTime & vt) { oops::Log::trace() << classname() << "::zero done" << std::endl; } -void Increment::ones() { - std::cerr << "Error: quench::Increment::ones called unexpectedly. This method should not be used for being now" << std::endl; - throw std::runtime_error("Unexpected call to quench::Increment::ones"); -} // ----------------------------------------------------------------------------- void Increment::axpy(const double & zz, From 28855e5e64f97601fbdce4cf02fbcb39dfd6f542 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Mon, 26 Jan 2026 15:56:28 -0500 Subject: [PATCH 150/199] WIP : openmp directive for mgbf --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 57722d9fa..e389710a4 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -534,9 +534,11 @@ subroutine multiply(self, fields,index_member_in) stop endif enddo +!$omp parallel do private(k) schedule(static) do k=1,nzloc - work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) + work_mgbf(k,:,:) = reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) enddo +!$omp end parallel do if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' @@ -578,9 +580,11 @@ subroutine multiply(self, fields,index_member_in) !clt# work_mgbf=999.0 !thinkdeb for debug call btim(mg_postprocess_time) +!$omp parallel do private(k) schedule(static) do k=1,nlev_vargrp(ivargrp) - vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) + vargrp_work_mgbf2(k,:,:) = vargrp_work_mgbf2(k,:,:) / rnormalization(k,ivargrp) enddo +!$omp end parallel do work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) ii=ii+nlev_vargrp(ivargrp) deallocate(vargrp_work_mgbf) @@ -616,9 +620,11 @@ subroutine multiply(self, fields,index_member_in) endif deallocate(work1var_mgbf) endif +!$omp parallel do private(k) schedule(static) do k=1,nzloc - work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + work2d_mgbf(k,:) = reshape(work_mgbf(k,:,:),[dim2d(2)]) enddo +!$omp end parallel do ilev=1 n_owned_size=0 do isize=1,fields%size() @@ -753,4 +759,3 @@ end function ivar2grp ! -------------------------------------------------------------------------------------------------- end module mgbf_covariance_mod - From cc8d2e1d6af36a3e5a2c0cebd2554024c5d08b7f Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 27 Jan 2026 09:16:26 -0500 Subject: [PATCH 151/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 168 +++++++++++++++--- 1 file changed, 140 insertions(+), 28 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index e389710a4..531710af8 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -55,6 +55,16 @@ module mgbf_covariance_mod real, allocatable :: multigrp_cor(:,:) integer, allocatable :: iscalegroup(:) integer, allocatable :: ivargroup(:) + real(kind=r_kind), allocatable, target :: work_mgbf(:,:,:) + real(kind=r_kind), allocatable, target :: work1var_mgbf(:,:,:) + real(kind=r_kind), allocatable, target :: work2d_mgbf(:,:) + real(kind=r_kind), allocatable, target :: rnormalization(:,:) + integer(kind=i_kind), allocatable, target :: nlev_vargrp(:) + integer(kind=i_kind), allocatable, target :: varvlev_index(:,:) + integer(kind=i_kind) :: ws_total_km_a_all = 0 + integer(kind=i_kind) :: ws_nm = 0 + integer(kind=i_kind) :: ws_mm = 0 + integer(kind=i_kind) :: ws_nz3d = 0 contains procedure, public :: create @@ -100,6 +110,11 @@ subroutine create(self, comm, config, funcspace, background, firstguess) real(r_kind), allocatable :: lonlat_anl(:,:) integer :: npts_owned integer :: npts_total +integer :: total_km_a_all_scale +integer :: max_nm +integer :: max_mm +integer :: max_nz3d +integer :: nvar_create character(len=80) :: readin_mgbf_nml_group(99) @@ -217,6 +232,49 @@ subroutine create(self, comm, config, funcspace, background, firstguess) call flush(6) if (allocated(lonlat_anl)) deallocate(lonlat_anl) +! Allocate persistent workspaces based on intstate sizes +self%ws_total_km_a_all = 0 +self%ws_nm = 0 +self%ws_mm = 0 +self%ws_nz3d = 0 +max_nm = 0 +max_mm = 0 +max_nz3d = 0 +do iscale=1,nscale + total_km_a_all_scale = 0 + do ivargrp=1,nvargrp + total_km_a_all_scale = total_km_a_all_scale + self%intstate(iscale,ivargrp)%km_a_all + enddo + if (total_km_a_all_scale > self%ws_total_km_a_all) self%ws_total_km_a_all = total_km_a_all_scale + if (self%intstate(iscale,1)%nm > max_nm) max_nm = self%intstate(iscale,1)%nm + if (self%intstate(iscale,1)%mm > max_mm) max_mm = self%intstate(iscale,1)%mm + if (self%intstate(iscale,1)%lm_a > max_nz3d) max_nz3d = self%intstate(iscale,1)%lm_a +enddo +self%ws_nm = max_nm +self%ws_mm = max_mm +self%ws_nz3d = max_nz3d + +if (.not. allocated(self%work_mgbf)) then + allocate(self%work_mgbf(self%ws_total_km_a_all, self%ws_nm, self%ws_mm)) +endif +if (.not. allocated(self%work2d_mgbf)) then + allocate(self%work2d_mgbf(self%ws_total_km_a_all, self%ws_nm * self%ws_mm)) +endif +if (.not. allocated(self%rnormalization)) then + allocate(self%rnormalization(self%ws_total_km_a_all, nvargrp)) +endif +if (.not. allocated(self%work1var_mgbf)) then + allocate(self%work1var_mgbf(self%ws_nz3d, self%ws_nm, self%ws_mm)) +endif + +if (.not. allocated(self%nlev_vargrp)) then + allocate(self%nlev_vargrp(nvargrp)) +endif + +nvar_create = background%size() +if (.not. allocated(self%varvlev_index)) then + allocate(self%varvlev_index(nvar_create,3)) +endif end subroutine create ! -------------------------------------------------------------------------------------------------- @@ -239,6 +297,13 @@ subroutine delete(self) enddo !clt endif +if (allocated(self%work_mgbf)) deallocate(self%work_mgbf) +if (allocated(self%work1var_mgbf)) deallocate(self%work1var_mgbf) +if (allocated(self%work2d_mgbf)) deallocate(self%work2d_mgbf) +if (allocated(self%rnormalization)) deallocate(self%rnormalization) +if (allocated(self%nlev_vargrp)) deallocate(self%nlev_vargrp) +if (allocated(self%varvlev_index)) deallocate(self%varvlev_index) + ! Delete the grid ! --------------- !clt call self%grid%delete() @@ -309,19 +374,19 @@ subroutine multiply(self, fields,index_member_in) real(kind=r_kind), pointer :: ptr_2d(:,:) real(kind=r_kind), pointer :: ptr_3d(:,:,:) integer(kind=i_kind):: nz,ilev,isize -real(kind=r_kind), allocatable :: work_mgbf(:,:,:) +real(kind=r_kind), pointer :: work_mgbf(:,:,:) real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) -real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) -real(kind=r_kind), allocatable :: work2d_mgbf(:,:) -real(kind=r_kind), allocatable :: rnormalization(:,:) -integer(kind=i_kind), allocatable :: nlev_vargrp(:) +real(kind=r_kind), pointer :: work1var_mgbf(:,:,:) +real(kind=r_kind), pointer :: work2d_mgbf(:,:) +real(kind=r_kind), pointer :: rnormalization(:,:) +integer(kind=i_kind), pointer :: nlev_vargrp(:) integer(kind=i_kind) :: dim2d(2),dim3d(3) integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d integer(kind=i_kind)::nvar integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit integer(kind=i_kind):: n2d -integer(kind=i_kind),allocatable :: varvlev_index(:,:) +integer(kind=i_kind), pointer :: varvlev_index(:,:) logical :: l2d_encountered logical :: test_once=.false. integer(kind=i_kind)::itest=0 @@ -363,8 +428,14 @@ subroutine multiply(self, fields,index_member_in) fileoutput="mgbftest_static_"//str_rank//".txt" endif - allocate(nlev_vargrp(nvargrp)) - nlev_vargrp=0 + if (.not. allocated(self%nlev_vargrp)) then + error stop "MGBF workspace nlev_vargrp not allocated" + endif + if (size(self%nlev_vargrp) < nvargrp) then + error stop "MGBF workspace nlev_vargrp too small for nvargrp" + endif + nlev_vargrp => self%nlev_vargrp + nlev_vargrp = 0 total_km_a_all=0 !clt do iscale=1,self%nscale do ivargrp=1,self%nvargrp @@ -381,11 +452,36 @@ subroutine multiply(self, fields,index_member_in) n2d=0 l2d_encountered=.false. ivargrp0=1 - allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) - allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) - allocate(rnormalization(total_km_a_all,nvargrp)) - rnormalization=0.0 - work2d_mgbf=0.0 + if (.not. allocated(self%work_mgbf)) then + error stop "MGBF workspace work_mgbf not allocated" + endif + if (size(self%work_mgbf,1) < total_km_a_all .or. & + size(self%work_mgbf,2) < self%intstate(jscale,ivargrp0)%nm .or. & + size(self%work_mgbf,3) < self%intstate(jscale,ivargrp0)%mm) then + error stop "MGBF workspace work_mgbf too small for current scale" + endif + work_mgbf => self%work_mgbf + + if (.not. allocated(self%work2d_mgbf)) then + error stop "MGBF workspace work2d_mgbf not allocated" + endif + if (size(self%work2d_mgbf,1) < total_km_a_all .or. & + size(self%work2d_mgbf,2) < self%intstate(jscale,ivargrp0)%nm * & + self%intstate(jscale,ivargrp0)%mm) then + error stop "MGBF workspace work2d_mgbf too small for current scale" + endif + work2d_mgbf => self%work2d_mgbf + + if (.not. allocated(self%rnormalization)) then + error stop "MGBF workspace rnormalization not allocated" + endif + if (size(self%rnormalization,1) < total_km_a_all .or. & + size(self%rnormalization,2) < nvargrp) then + error stop "MGBF workspace rnormalization too small for current scale" + endif + rnormalization => self%rnormalization + rnormalization = 0.0 + work2d_mgbf = 0.0 ii=1 do ivargrp=1,nvargrp do k=1,self%intstate(jscale,ivargrp)%km2 @@ -400,7 +496,7 @@ subroutine multiply(self, fields,index_member_in) ii=ii+nz3d enddo enddo - + dim2d=shape(work2d_mgbf) dim3d=shape(work_mgbf) @@ -408,8 +504,14 @@ subroutine multiply(self, fields,index_member_in) nyloc=dim3d(3) nzloc=dim3d(1) nvar=fields%size() - allocate( varvlev_index(nvar,3)) - varvlev_index=0 + if (.not. allocated(self%varvlev_index)) then + error stop "MGBF workspace varvlev_index not allocated" + endif + if (size(self%varvlev_index,1) < nvar .or. size(self%varvlev_index,2) /= 3) then + error stop "MGBF workspace varvlev_index too small for current fields" + endif + varvlev_index => self%varvlev_index + varvlev_index = 0 ilev=1 do isize=1,fields%size() @@ -561,12 +663,13 @@ subroutine multiply(self, fields,index_member_in) do ivargrp=1,nvargrp allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) - vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) + vargrp_work_mgbf(:,:,:) = work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) call btim(mg_anal_to_filt_time) call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) - write(6,*)'codexdebug max_in_grp ', ivargrp, maxval(vargrp_work_mgbf) + write(6,*)'codexdebug max_in_grp ', ivargrp, & + maxval(vargrp_work_mgbf) call etim(mg_anal_to_filt_time) call btim(mg_filtering_time) call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) @@ -575,7 +678,8 @@ subroutine multiply(self, fields,index_member_in) !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) call btim(mg_filt_to_anal_time) call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) - write(6,*)'codexdebug max_out_grp ', ivargrp, maxval(vargrp_work_mgbf2) + write(6,*)'codexdebug max_out_grp ', ivargrp, & + maxval(vargrp_work_mgbf2) call etim(mg_filt_to_anal_time) !clt# work_mgbf=999.0 !thinkdeb for debug @@ -585,14 +689,22 @@ subroutine multiply(self, fields,index_member_in) vargrp_work_mgbf2(k,:,:) = vargrp_work_mgbf2(k,:,:) / rnormalization(k,ivargrp) enddo !$omp end parallel do - work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) + work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) = vargrp_work_mgbf2(:,:,:) ii=ii+nlev_vargrp(ivargrp) deallocate(vargrp_work_mgbf) deallocate(vargrp_work_mgbf2) enddo ! ivargrp if(self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx - allocate(work1var_mgbf(nz3d,nxloc,nyloc)) - work1var_mgbf=0.0 + if (.not. allocated(self%work1var_mgbf)) then + error stop "MGBF workspace work1var_mgbf not allocated" + endif + if (size(self%work1var_mgbf,1) < nz3d .or. & + size(self%work1var_mgbf,2) < nxloc .or. & + size(self%work1var_mgbf,3) < nyloc) then + error stop "MGBF workspace work1var_mgbf too small for current scale" + endif + work1var_mgbf => self%work1var_mgbf + work1var_mgbf = 0.0 if(nvargrp == 1 ) then do ivar=1,nvar lev1=varvlev_index(ivar,1) @@ -618,7 +730,7 @@ subroutine multiply(self, fields,index_member_in) work_mgbf(lev1:lev2,:,:)=work1var_mgbf enddo endif - deallocate(work1var_mgbf) + nullify(work1var_mgbf) endif !$omp parallel do private(k) schedule(static) do k=1,nzloc @@ -707,13 +819,13 @@ subroutine multiply(self, fields,index_member_in) call afield%final() - deallocate(work_mgbf) - deallocate(work2d_mgbf) - deallocate(rnormalization) - deallocate( varvlev_index) + nullify(work_mgbf) + nullify(work2d_mgbf) + nullify(rnormalization) + nullify(varvlev_index) !clt enddo !for iscale call etim(mg_multiply_time) - deallocate(nlev_vargrp) + nullify(nlev_vargrp) end subroutine multiply From 51293f01a660ce0128f2105d6c227a21b059600d Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Wed, 28 Jan 2026 03:21:16 +0000 Subject: [PATCH 152/199] WIP: debug --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 273 +++++++----------- 1 file changed, 108 insertions(+), 165 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 531710af8..9e4941909 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -55,16 +55,14 @@ module mgbf_covariance_mod real, allocatable :: multigrp_cor(:,:) integer, allocatable :: iscalegroup(:) integer, allocatable :: ivargroup(:) - real(kind=r_kind), allocatable, target :: work_mgbf(:,:,:) - real(kind=r_kind), allocatable, target :: work1var_mgbf(:,:,:) - real(kind=r_kind), allocatable, target :: work2d_mgbf(:,:) - real(kind=r_kind), allocatable, target :: rnormalization(:,:) - integer(kind=i_kind), allocatable, target :: nlev_vargrp(:) - integer(kind=i_kind), allocatable, target :: varvlev_index(:,:) - integer(kind=i_kind) :: ws_total_km_a_all = 0 - integer(kind=i_kind) :: ws_nm = 0 - integer(kind=i_kind) :: ws_mm = 0 - integer(kind=i_kind) :: ws_nz3d = 0 + real(kind=r_kind), pointer :: work_mgbf(:,:,:) + real(kind=r_kind), pointer:: work1var_mgbf(:,:,:) + real(kind=r_kind), pointer :: work2d_mgbf(:,:) + real(kind=r_kind), pointer :: rnormalization(:,:) + integer(kind=i_kind), pointer :: nlev_vargrp(:) + integer(kind=i_kind), pointer :: varvlev_index(:,:) + integer(kind=i_kind) :: total_km_a_all = 0 + logical:: l_multiply_first_call=.true. contains procedure, public :: create @@ -110,18 +108,19 @@ subroutine create(self, comm, config, funcspace, background, firstguess) real(r_kind), allocatable :: lonlat_anl(:,:) integer :: npts_owned integer :: npts_total -integer :: total_km_a_all_scale integer :: max_nm integer :: max_mm integer :: max_nz3d integer :: nvar_create + + character(len=80) :: readin_mgbf_nml_group(99) real :: readin_multigrp_cor(99)=1.0 integer :: readin_iscalegroup(99)=999 integer :: readin_ivargroup(99)=999 -integer ::i,j, ii +integer ::i,j, ii,nz3d namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup character(len=:), allocatable :: dump_json @@ -233,48 +232,42 @@ subroutine create(self, comm, config, funcspace, background, firstguess) if (allocated(lonlat_anl)) deallocate(lonlat_anl) ! Allocate persistent workspaces based on intstate sizes -self%ws_total_km_a_all = 0 -self%ws_nm = 0 -self%ws_mm = 0 -self%ws_nz3d = 0 -max_nm = 0 -max_mm = 0 -max_nz3d = 0 do iscale=1,nscale - total_km_a_all_scale = 0 + self%total_km_a_all = 0 do ivargrp=1,nvargrp - total_km_a_all_scale = total_km_a_all_scale + self%intstate(iscale,ivargrp)%km_a_all + self%total_km_a_all = self%total_km_a_all + self%intstate(iscale,ivargrp)%km_a_all + if(self%intstate(iscale,ivargrp)%nm /= self%intstate(1,1)%nm ) then + write(6,*)'nm should be the same for all mgbf filters, stop' + call flush(6) + stop + endif + if(self%intstate(iscale,ivargrp)%mm /= self%intstate(1,1)%mm ) then + write(6,*)'mm should be the same for all mgbf filters, stop' + call flush(6) + stop + endif + if(self%intstate(iscale,ivargrp)%lm_a /= self%intstate(1,1)%lm_a ) then + write(6,*)'lm_a should be the same for all mgbf filters, stop' + call flush(6) + stop + endif enddo - if (total_km_a_all_scale > self%ws_total_km_a_all) self%ws_total_km_a_all = total_km_a_all_scale - if (self%intstate(iscale,1)%nm > max_nm) max_nm = self%intstate(iscale,1)%nm - if (self%intstate(iscale,1)%mm > max_mm) max_mm = self%intstate(iscale,1)%mm - if (self%intstate(iscale,1)%lm_a > max_nz3d) max_nz3d = self%intstate(iscale,1)%lm_a enddo -self%ws_nm = max_nm -self%ws_mm = max_mm -self%ws_nz3d = max_nz3d + nz3d=self%intstate(1,1)%lm_a -if (.not. allocated(self%work_mgbf)) then - allocate(self%work_mgbf(self%ws_total_km_a_all, self%ws_nm, self%ws_mm)) -endif -if (.not. allocated(self%work2d_mgbf)) then - allocate(self%work2d_mgbf(self%ws_total_km_a_all, self%ws_nm * self%ws_mm)) -endif -if (.not. allocated(self%rnormalization)) then - allocate(self%rnormalization(self%ws_total_km_a_all, nvargrp)) -endif -if (.not. allocated(self%work1var_mgbf)) then - allocate(self%work1var_mgbf(self%ws_nz3d, self%ws_nm, self%ws_mm)) -endif + allocate(self%work_mgbf(self%total_km_a_all, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) + allocate(self%work2d_mgbf(self%total_km_a_all, self%intstate(1,1)%nm * self%intstate(1,1)%mm)) + allocate(self%rnormalization(self%total_km_a_all, nvargrp)) + allocate(self%work1var_mgbf(nz3d, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) -if (.not. allocated(self%nlev_vargrp)) then allocate(self%nlev_vargrp(nvargrp)) -endif -nvar_create = background%size() -if (.not. allocated(self%varvlev_index)) then allocate(self%varvlev_index(nvar_create,3)) -endif + + + + + end subroutine create ! -------------------------------------------------------------------------------------------------- @@ -297,12 +290,12 @@ subroutine delete(self) enddo !clt endif -if (allocated(self%work_mgbf)) deallocate(self%work_mgbf) -if (allocated(self%work1var_mgbf)) deallocate(self%work1var_mgbf) -if (allocated(self%work2d_mgbf)) deallocate(self%work2d_mgbf) -if (allocated(self%rnormalization)) deallocate(self%rnormalization) -if (allocated(self%nlev_vargrp)) deallocate(self%nlev_vargrp) -if (allocated(self%varvlev_index)) deallocate(self%varvlev_index) +if (associated(self%work_mgbf)) deallocate(self%work_mgbf) +if (associated(self%work1var_mgbf)) deallocate(self%work1var_mgbf) +if (associated(self%work2d_mgbf)) deallocate(self%work2d_mgbf) +if (associated(self%rnormalization)) deallocate(self%rnormalization) +if (associated(self%nlev_vargrp)) deallocate(self%nlev_vargrp) +if (associated(self%varvlev_index)) deallocate(self%varvlev_index) ! Delete the grid ! --------------- @@ -400,7 +393,7 @@ subroutine multiply(self, fields,index_member_in) integer :: ierr integer :: member_index integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp -integer :: total_km_a_all,ii,nvargrp +integer :: ii,nvargrp integer :: ilev1,ilev2 integer :: loc(2) @@ -422,80 +415,65 @@ subroutine multiply(self, fields,index_member_in) endif myrank=self%rank write(str_rank,"(I4.4)")myrank - if(self%intstate(jscale,1)%l_for_localization) then - fileoutput="mgbftest_loc_"//str_rank//".txt" - else - fileoutput="mgbftest_static_"//str_rank//".txt" - endif - if (.not. allocated(self%nlev_vargrp)) then + if (.not. associated(self%nlev_vargrp)) then error stop "MGBF workspace nlev_vargrp not allocated" endif if (size(self%nlev_vargrp) < nvargrp) then error stop "MGBF workspace nlev_vargrp too small for nvargrp" endif + work_mgbf => self%work_mgbf + work2d_mgbf => self%work2d_mgbf + rnormalization => self%rnormalization + nlev_vargrp => self%nlev_vargrp nlev_vargrp = 0 - total_km_a_all=0 + !clt do iscale=1,self%nscale - do ivargrp=1,self%nvargrp - if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & - self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then - error stop "for being now, the filtering grids at the start of MGBF should be the same" - endif - total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all - nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all - enddo nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps n2d=0 l2d_encountered=.false. ivargrp0=1 - if (.not. allocated(self%work_mgbf)) then + if (.not. associated(self%work_mgbf)) then error stop "MGBF workspace work_mgbf not allocated" endif - if (size(self%work_mgbf,1) < total_km_a_all .or. & - size(self%work_mgbf,2) < self%intstate(jscale,ivargrp0)%nm .or. & - size(self%work_mgbf,3) < self%intstate(jscale,ivargrp0)%mm) then - error stop "MGBF workspace work_mgbf too small for current scale" + if (size(work_mgbf,1) /= self%total_km_a_all .or. & + size(work_mgbf,2) /= self%intstate(jscale,ivargrp0)%nm .or. & + size(work_mgbf,3) /= self%intstate(jscale,ivargrp0)%mm) then + error stop "MGBF workspace work_mgbf does not match " endif - work_mgbf => self%work_mgbf - if (.not. allocated(self%work2d_mgbf)) then - error stop "MGBF workspace work2d_mgbf not allocated" - endif - if (size(self%work2d_mgbf,1) < total_km_a_all .or. & - size(self%work2d_mgbf,2) < self%intstate(jscale,ivargrp0)%nm * & + if (size(work2d_mgbf,1) /= self%total_km_a_all .or. & + size(work2d_mgbf,2) /= self%intstate(jscale,ivargrp0)%nm * & self%intstate(jscale,ivargrp0)%mm) then error stop "MGBF workspace work2d_mgbf too small for current scale" endif - work2d_mgbf => self%work2d_mgbf - if (.not. allocated(self%rnormalization)) then - error stop "MGBF workspace rnormalization not allocated" - endif - if (size(self%rnormalization,1) < total_km_a_all .or. & - size(self%rnormalization,2) < nvargrp) then + if (size(rnormalization,1) /= self%total_km_a_all .or. & + size(rnormalization,2) /= nvargrp) then error stop "MGBF workspace rnormalization too small for current scale" endif - rnormalization => self%rnormalization rnormalization = 0.0 work2d_mgbf = 0.0 + work1var_mgbf => self%work1var_mgbf ii=1 - do ivargrp=1,nvargrp - do k=1,self%intstate(jscale,ivargrp)%km2 -!clt if for localization , km2=0 only for -!clt only for l_2dvar_last_vertical_lev - rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) - ii=ii+1 - enddo -!clt if for localization , km2=0 - do k=1,self%intstate(jscale,ivargrp)%km3 - rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) - ii=ii+nz3d - enddo - enddo + if(self%l_multiply_first_call) then + do ivargrp=1,nvargrp + do k=1,self%intstate(jscale,ivargrp)%km2 + !clt if for localization , km2=0 only for + !clt only for l_2dvar_last_vertical_lev + rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) + ii=ii+1 + enddo + !clt if for localization , km2=0 + do k=1,self%intstate(jscale,ivargrp)%km3 + rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) + ii=ii+nz3d + enddo + enddo + endif dim2d=shape(work2d_mgbf) @@ -504,12 +482,6 @@ subroutine multiply(self, fields,index_member_in) nyloc=dim3d(3) nzloc=dim3d(1) nvar=fields%size() - if (.not. allocated(self%varvlev_index)) then - error stop "MGBF workspace varvlev_index not allocated" - endif - if (size(self%varvlev_index,1) < nvar .or. size(self%varvlev_index,2) /= 3) then - error stop "MGBF workspace varvlev_index too small for current fields" - endif varvlev_index => self%varvlev_index varvlev_index = 0 @@ -519,11 +491,8 @@ subroutine multiply(self, fields,index_member_in) afield= fields%field(isize) !clttodo fs= afield%functionspace() !cltthinkfore debug n_owned_size= fs%size_owned() !clt for debug - write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() if(afield%rank() == 2) then - write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() nz=afield%levels() - write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz call afield%data(ptr_2d) if(nz /= 1 .and. nz /= nz3d ) then write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d @@ -532,21 +501,22 @@ subroutine multiply(self, fields,index_member_in) endif if(nz == 1) then - !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then if(self%intstate(jscale,1)%l_for_localization) then if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level - if(ilev+nz3d-1 > total_km_a_all) then + if(ilev+nz3d-1 > self%total_km_a_all) then write(6,*)'MGBF abort 1 : the dimensions are not as expected' call flush(6) stop endif if(n_owned_size >0 ) then work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) + work2d_mgbf(ilev:ilev+nz3d-2,:)=0.0 !other levels are set to 0 and to be updated by the info spreading. else work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + work2d_mgbf(ilev:ilev+nz3d-2,:)=ptr_2d endif else - if(ilev+nz-1 > total_km_a_all) then + if(ilev+nz-1 > self%total_km_a_all) then write(6,*)'MGBF abort 2 : the dimensions are not as expected' call flush(6) stop @@ -556,11 +526,12 @@ subroutine multiply(self, fields,index_member_in) else work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d endif + work2d_mgbf(ilev+nz:ilev+nz3d-1,:)=0.0 endif else - if(ilev+nz-1 > total_km_a_all) then + if(ilev+nz-1 > self%total_km_a_all) then write(6,*)'MGBF abort 3 : the dimensions are not as expected' call flush(6) stop @@ -572,7 +543,7 @@ subroutine multiply(self, fields,index_member_in) endif endif else - if(ilev+nz-1 > total_km_a_all) then + if(ilev+nz-1 > self%total_km_a_all) then write(6,*)'MGBF abort 4 : the dimensions are not as expected' call flush(6) stop @@ -583,41 +554,37 @@ subroutine multiply(self, fields,index_member_in) work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d endif endif - if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then - write(6,*)'thinkdeb333 before max is large 0.5' - loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) - write(6,*)'thinkdeb333 before large 0.5 loc ',loc - endif if(nz == 1) then l2d_encountered=.true. n2d=n2d+1 endif if(nz > 1) then - if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then - write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" + if(l2d_encountered ) then call flush(6) - error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending + error stop ("2dvariable is not put in the ending stop.") ! is required 2d fields are saved consecutively,and at the ending endif endif - if(isize==1) then - varvlev_index(isize,1)= 1 - !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then - if(.not.self%intstate(jscale,1)%l_for_localization )then - varvlev_index(isize,2)= nz - else - varvlev_index(isize,2)= nz3d - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 - else - !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d - varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 - if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then - varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 - else - varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 - endif - varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + if(self%l_multiply_first_call) then + if(isize==1) then + varvlev_index(isize,1)= 1 + !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,1)%l_for_localization )then + varvlev_index(isize,2)= nz + else + varvlev_index(isize,2)= nz3d + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + else + !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d + varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 + if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then + varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 + else + varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + endif endif jvargrp=self%ivar2grp(isize) @@ -647,19 +614,8 @@ subroutine multiply(self, fields,index_member_in) stop ! a better exception handling is to be added endif - if(test_once.and..1.gt.2) then - open(iounit,file=trim(fileoutput), status='replace',form="formatted") - write(iounit,*) work_mgbf - test_once=.false. - close(iounit) - endif call etim(mg_preprocess_time) ii=1 - write(6,*)'codexdebug km2/km3/total/nvar/nz3d ', self%intstate(jscale,1)%km2, & - & self%intstate(jscale,1)%km3, total_km_a_all, nvar, nz3d - do i=1,min(4,nvar) - write(6,*)'codexdebug varvlev_index ', i, varvlev_index(i,1), varvlev_index(i,2) - enddo do ivargrp=1,nvargrp allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) @@ -668,8 +624,6 @@ subroutine multiply(self, fields,index_member_in) call btim(mg_anal_to_filt_time) call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) - write(6,*)'codexdebug max_in_grp ', ivargrp, & - maxval(vargrp_work_mgbf) call etim(mg_anal_to_filt_time) call btim(mg_filtering_time) call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) @@ -695,15 +649,6 @@ subroutine multiply(self, fields,index_member_in) deallocate(vargrp_work_mgbf2) enddo ! ivargrp if(self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx - if (.not. allocated(self%work1var_mgbf)) then - error stop "MGBF workspace work1var_mgbf not allocated" - endif - if (size(self%work1var_mgbf,1) < nz3d .or. & - size(self%work1var_mgbf,2) < nxloc .or. & - size(self%work1var_mgbf,3) < nyloc) then - error stop "MGBF workspace work1var_mgbf too small for current scale" - endif - work1var_mgbf => self%work1var_mgbf work1var_mgbf = 0.0 if(nvargrp == 1 ) then do ivar=1,nvar @@ -743,7 +688,6 @@ subroutine multiply(self, fields,index_member_in) afield=fields%field(isize) !clttodo - write(6,*)'thinkdeb333-2 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() fs= afield%functionspace() !cltthinkfore debug n_owned_size= fs%size_owned() !clt for debug @@ -752,7 +696,6 @@ subroutine multiply(self, fields,index_member_in) call afield%data(ptr_2d) nz=afield%levels() lev1=varvlev_index(isize,1) - write(6,*)'thinkdeb333-3 leve: leve2 ',lev1,' ',lev1+nz if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) write(6,*)'thinkdeb333 max is large 0.5 loc ',loc @@ -766,7 +709,7 @@ subroutine multiply(self, fields,index_member_in) endif else if(self%intstate(1,1)%l_for_localization) then - if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + if( self%l_2dvar_last_vertical_level) then !,2dvars are put on the last vertical level if(n_owned_size >0 ) then ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) @@ -776,9 +719,8 @@ subroutine multiply(self, fields,index_member_in) endif else if(n_owned_size >0 ) then - ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)! else - !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) endif endif @@ -826,6 +768,7 @@ subroutine multiply(self, fields,index_member_in) !clt enddo !for iscale call etim(mg_multiply_time) nullify(nlev_vargrp) + self%l_multiply_first_call=.false. end subroutine multiply From 904403fef17ca176498a05885600086d51d96f7b Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Wed, 28 Jan 2026 04:14:20 +0000 Subject: [PATCH 153/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 9e4941909..c6621619e 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -62,6 +62,7 @@ module mgbf_covariance_mod integer(kind=i_kind), pointer :: nlev_vargrp(:) integer(kind=i_kind), pointer :: varvlev_index(:,:) integer(kind=i_kind) :: total_km_a_all = 0 + integer(kind=i_kind) :: nvar = 0 logical:: l_multiply_first_call=.true. contains @@ -111,7 +112,6 @@ subroutine create(self, comm, config, funcspace, background, firstguess) integer :: max_nm integer :: max_mm integer :: max_nz3d -integer :: nvar_create @@ -253,6 +253,10 @@ subroutine create(self, comm, config, funcspace, background, firstguess) endif enddo enddo + self%nvar = 0 + do ivargrp=1,nvargrp + self%nvar = self%nvar + self%intstate(1,ivargrp)%km2+self%intstate(1,ivargrp)%km3 + enddo nz3d=self%intstate(1,1)%lm_a allocate(self%work_mgbf(self%total_km_a_all, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) @@ -262,7 +266,7 @@ subroutine create(self, comm, config, funcspace, background, firstguess) allocate(self%nlev_vargrp(nvargrp)) - allocate(self%varvlev_index(nvar_create,3)) + allocate(self%varvlev_index(self%nvar,3)) @@ -482,6 +486,11 @@ subroutine multiply(self, fields,index_member_in) nyloc=dim3d(3) nzloc=dim3d(1) nvar=fields%size() + if(nvar /= self%nvar ) then + write(6,*)'wrong, local nvar is not the same as self%nvar stop' + call flush(6) + stop + endif varvlev_index => self%varvlev_index varvlev_index = 0 From 041e44ad686b987a69d8c487ee5f80112943f218 Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Wed, 28 Jan 2026 14:23:56 +0000 Subject: [PATCH 154/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index c6621619e..026248dd8 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -428,10 +428,10 @@ subroutine multiply(self, fields,index_member_in) endif work_mgbf => self%work_mgbf work2d_mgbf => self%work2d_mgbf + work1var_mgbf => self%work1var_mgbf rnormalization => self%rnormalization nlev_vargrp => self%nlev_vargrp - nlev_vargrp = 0 !clt do iscale=1,self%nscale @@ -461,7 +461,7 @@ subroutine multiply(self, fields,index_member_in) endif rnormalization = 0.0 work2d_mgbf = 0.0 - work1var_mgbf => self%work1var_mgbf + work1var_mgbf=0 ii=1 if(self%l_multiply_first_call) then do ivargrp=1,nvargrp @@ -492,7 +492,7 @@ subroutine multiply(self, fields,index_member_in) stop endif varvlev_index => self%varvlev_index - varvlev_index = 0 + if (self%l_multiply_first_call) varvlev_index = 0 ilev=1 do isize=1,fields%size() From 309ec19e4b0f884ec35eb1cf85d537e043715c95 Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Wed, 28 Jan 2026 14:27:52 +0000 Subject: [PATCH 155/199] WIP --- src/saber/mgbf/covariance/f90.org | 756 ++++++++++++++++++++++++++++++ 1 file changed, 756 insertions(+) create mode 100644 src/saber/mgbf/covariance/f90.org diff --git a/src/saber/mgbf/covariance/f90.org b/src/saber/mgbf/covariance/f90.org new file mode 100644 index 000000000..57722d9fa --- /dev/null +++ b/src/saber/mgbf/covariance/f90.org @@ -0,0 +1,756 @@ +! (C) Copyright 2022 United States Government as represented by the Administrator of the National +! Aeronautics and Space Administration +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + +module mgbf_covariance_mod + +! atlas +use atlas_module, only: atlas_fieldset, atlas_field +use atlas_module, only: atlas_functionspace +use atlas_module, only: atlas_functionspace_StructuredColumns +use atlas_module, only : atlas_functionspace, & + atlas_functionspace_nodecolumns, & + atlas_functionspace_pointcloud, & + atlas_functionspace_structuredcolumns, & + atlas_mesh_nodes, atlas_field + +use tools_func, only : sphere_dist +use tools_const, only : req ! Earth radius (m) + +! fckit +use fckit_mpi_module, only: fckit_mpi_comm +use fckit_configuration_module, only: fckit_configuration + +! oops +use mgbf_kinds, only: r_kind,i_kind +use random_mod + +! saber +!clt use mgbf_grid_mod, only: mgbf_grid +use mg_intstate , only: mg_intstate_type +use mg_timers +use mpi +use, intrinsic :: ieee_arithmetic +implicit none +private +public mgbf_covariance + +! Fortran class header +type :: mgbf_covariance + type(mg_intstate_type),allocatable :: intstate(:,:) + integer :: nscale=1 + integer :: nvargrp=1 + logical :: noMGBF + logical :: bypassMGBFbe + logical :: cv ! cv=.true.; sv=.false. + integer :: mp_comm_world + integer :: rank + logical :: l_2dvar_last_vertical_level=.true. !when used for localization,2dvars are put on the last vertical level + !when the fields in fset are stored from top to bottom +!clt integer :: lat2,lon2 ! these belog to mgbf_grid + character(len=:), allocatable :: mgbf_nml + character(len=80), allocatable :: mgbf_nml_group(:,:) + real, allocatable :: multigrp_cor(:,:) + integer, allocatable :: iscalegroup(:) + integer, allocatable :: ivargroup(:) + + contains + procedure, public :: create + procedure, public :: delete + procedure, public :: randomize + procedure, public :: multiply + procedure, public :: multiply_ad + procedure, private :: imem2scale + procedure, private :: ivar2grp +end type mgbf_covariance + +character(len=*), parameter :: myname='mgbf_covariance_mod' + +! -------------------------------------------------------------------------------------------------- + +contains + +! -------------------------------------------------------------------------------------------------- + +subroutine create(self, comm, config, funcspace, background, firstguess) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(fckit_mpi_comm), intent(in) :: comm +type(fckit_configuration), intent(in) :: config +type(atlas_functionspace), intent(in) :: funcspace +type(atlas_fieldset), intent(in) :: background +type(atlas_fieldset), intent(in) :: firstguess + +! Locals +real(r_kind) :: dist_rad, dist_m +integer :: ipt +character(len=*), parameter :: myname_=myname//'*create' +character(len=:), allocatable :: mgbf_nml,centralblockname +logical :: central +integer :: layout(2) +integer :: myunit +integer :: iscale,ivargrp +integer :: nscale=1, nvargrp=1 +type(atlas_field) :: afield, lonlat_field +type(atlas_functionspace_structuredcolumns) :: fs_sc +real(r_kind), pointer :: lonlat_ptr(:,:) +real(r_kind), allocatable :: lonlat_anl(:,:) +integer :: npts_owned +integer :: npts_total + + +character(len=80) :: readin_mgbf_nml_group(99) +real :: readin_multigrp_cor(99)=1.0 +integer :: readin_iscalegroup(99)=999 +integer :: readin_ivargroup(99)=999 +integer ::i,j, ii +namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup + +character(len=:), allocatable :: dump_json + +! Hold communicator +! ----------------- +!self%mp_comm_world=comm%communicator() + +! Create the grid +! --------------- +!clt call self%grid%create(config, comm) +self%rank = comm%rank() + +write(6,*)'thinkdeb mgbf create999 ' +write(6,*)'thinkdeb mgbf create999 config' + dump_json=config%json() ! serialize to a JSON string +write(6,'(A)')trim(dump_json) +call flush(6) +call config%get_or_die("saber block name", centralblockname) +!clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) +if (config%has("mgbf sdl and vdl init namelist file")) then + call config%get_or_die("mgbf sdl and vdl init namelist file", mgbf_nml) + open(newunit=myunit,file=trim(mgbf_nml),status='old') +!# open(unit=10,file=mgbf_nml,status='old',action='read') + read(myunit,nml=parameters_mgbf_init) + close(unit=myunit) + self%nscale=nscale + self%nvargrp=nvargrp + allocate(self%mgbf_nml_group(nscale,nvargrp)) + allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + allocate(self%iscalegroup(nscale) ) + allocate(self%ivargroup(nvargrp) ) + ii=1 + do iscale=1,nscale + do ivargrp=1,nvargrp + self%mgbf_nml_group(iscale,ivargrp)=readin_mgbf_nml_group(ii) + ii=ii+1 + enddo + enddo + do iscale=1,nscale + self%iscalegroup(iscale)=readin_iscalegroup(iscale) + enddo + ii=1 + do i=1,nvargrp + do j=1,nvargrp + self%multigrp_cor(i,j)=readin_multigrp_cor(ii) + ii=ii+1 + enddo + enddo + do i=1,nvargrp + self%ivargroup(i)=readin_ivargroup(i) + enddo +else +call config%get_or_die("mgbf namelist file ", mgbf_nml) +!still need allocate them though nscale=nvargrp=1 + allocate(self%mgbf_nml_group(nscale,nvargrp)) + allocate(self%multigrp_cor(nvargrp,nvargrp)) !clt in the future, it could be used for more cor relationship + self%multigrp_cor=1.0 + allocate(self%iscalegroup(nscale) ) + self%iscalegroup(nscale) =1 + allocate(self%ivargroup(nvargrp) ) + self%ivargroup=1 +endif + + +if(nscale == 1 .and. nvargrp ==1 ) then + self%mgbf_nml_group(1,1)=mgbf_nml !the same mgbf namelist file is used + !and hence, it would be backward-compatible + ! the previous namelist files could be still used,correctly, + ! by the current sdl/vdl enhanced version +endif + +if (trim(funcspace%name()) /= 'StructuredColumns') then + error stop 'MGBF requires StructuredColumns function space' +end if +fs_sc = funcspace +npts_owned = fs_sc%size_owned() +npts_total = fs_sc%size() +write(6,*)'thinkdeb mgbf create npts_owned/_total ',npts_owned, ' ',npts_total +call flush(6) +if(npts_owned.ge.npts_total) then + write(6,*)'the halo points are not present, on which the outer block interpolator would be problematic, stop' + call flush(6) + stop +endif + + +lonlat_field = fs_sc%xy() +call lonlat_field%data(lonlat_ptr) +!bug allocate(lonlat_anl(npts_total,2)) +allocate(lonlat_anl(npts_owned,2)) +lonlat_anl(:,1) = lonlat_ptr(1,1:npts_owned) +lonlat_anl(:,2) = lonlat_ptr(2,1:npts_owned) +call lonlat_field%final() + + +allocate(self%intstate(nscale,nvargrp)) +call flush(6) +do iscale=1,nscale + do ivargrp=1,nvargrp + write(6,*)'the999 nml is ', trim(self%mgbf_nml_group(iscale,ivargrp)) + call flush(6) + call self%intstate(iscale,ivargrp)%mg_initialize(n_owned_anl=npts_owned, & + anl_lonlat1d=lonlat_anl, inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml + enddo +enddo +write(6,*)'thinkdeb mgbf create999 10 ' +call flush(6) +if (allocated(lonlat_anl)) deallocate(lonlat_anl) + +end subroutine create + +! -------------------------------------------------------------------------------------------------- + +subroutine delete(self) + +! Arguments +class(mgbf_covariance) :: self +integer:: iscale,ivargrp + +! Locals + +!clt //if (.not. self%noMGBF) then + call print_mg_timers("mg_timer_output",999,self%rank) + +do iscale=1,self%nscale + do ivargrp=1,self%nvargrp + call self%intstate(iscale,ivargrp)%mg_finalize() + enddo +enddo +!clt endif + +! Delete the grid +! --------------- +!clt call self%grid%delete() + +end subroutine delete + +! -------------------------------------------------------------------------------------------------- + +subroutine randomize(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: psi(:,:), chi(:,:), t(:,:), q(:,:), qi(:,:), ql(:,:), o3(:,:) +real(kind=r_kind), pointer :: ps(:) + +integer, parameter :: rseed = 3 +write(6,*)'thinkdeb this is to be implemente' +call flush(6) +stop +! Get Atlas field +afield = fields%field('stream_function') +call afield%data(psi) + +afield = fields%field('velocity_potential') +call afield%data(chi) + +afield = fields%field('air_temperature') +call afield%data(t) + +afield = fields%field('surface_pressure') +call afield%data(ps) + +afield = fields%field('specific_humidity') +call afield%data(q) + +afield = fields%field('cloud_liquid_ice') +call afield%data(qi) + +afield = fields%field('cloud_liquid_water') +call afield%data(ql) + +afield = fields%field('ozone_mass_mixing_ratio') +call afield%data(o3) + + +! Set fields to random numbers +call normal_distribution(psi, 0.0_r_kind, 1.0_r_kind, rseed) + + +end subroutine randomize + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply(self, fields,index_member_in) +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields +integer , intent(in) :: index_member_in +type(atlas_fieldset) :: fields_tmp +type(atlas_functionspace) :: afunctionspace + +! Locals +type(atlas_field) :: afield +real(kind=r_kind), pointer :: ptr_2d(:,:) +real(kind=r_kind), pointer :: ptr_3d(:,:,:) +integer(kind=i_kind):: nz,ilev,isize +real(kind=r_kind), allocatable :: work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) +real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) +real(kind=r_kind), allocatable :: work1var_mgbf(:,:,:) +real(kind=r_kind), allocatable :: work2d_mgbf(:,:) +real(kind=r_kind), allocatable :: rnormalization(:,:) +integer(kind=i_kind), allocatable :: nlev_vargrp(:) +integer(kind=i_kind) :: dim2d(2),dim3d(3) +integer(kind=i_kind):: myrank,nxloc,nyloc,nzloc,nz3d +integer(kind=i_kind)::nvar +integer(kind=i_kind):: i,ivar,jvar,j,k,ij,lev1,lev2,iounit +integer(kind=i_kind):: n2d +integer(kind=i_kind),allocatable :: varvlev_index(:,:) +logical :: l2d_encountered +logical :: test_once=.false. +integer(kind=i_kind)::itest=0 +character(len=32) :: fileoutput +character(len=4) :: str_rank +integer :: n_owned_size +integer, pointer :: ghost(:) +!clttype(atlas_FunctionSpace) :: fs +type(atlas_functionspace) :: fs_generic +type(atlas_functionspace_StructuredColumns) :: fs +integer :: ierr +integer :: member_index +integer :: iscale,jscale, ivargrp,ivargrp0,jvargrp +integer :: total_km_a_all,ii,nvargrp +integer :: ilev1,ilev2 +integer :: loc(2) + + if(index_member_in >= 999) then ! not set previously and should not be used, + member_index=1 ! the privous ensemble index starts from 0) + else + ! namely, it is not a sdl/vdl run. + member_index=index_member_in+1 ! the privous ensemble index starts from 0) + endif + jscale=self%imem2scale(member_index) + nvargrp=self%nvargrp + call btim(mg_multiply_time) + call btim(mg_preprocess_time) + if(self%intstate(jscale,1)%l_for_localization .and. self%intstate(jscale,1)%km2 > 0) then + write(6,*)"when mgbf is used for localizaiton, all 2d variables will be treated as 3d variable", & +& "in which, the first level contains the 2d variables and others zeros " + + stop !to use a better exit procdure + endif + myrank=self%rank + write(str_rank,"(I4.4)")myrank + if(self%intstate(jscale,1)%l_for_localization) then + fileoutput="mgbftest_loc_"//str_rank//".txt" + else + fileoutput="mgbftest_static_"//str_rank//".txt" + endif + + allocate(nlev_vargrp(nvargrp)) + nlev_vargrp=0 + total_km_a_all=0 +!clt do iscale=1,self%nscale + do ivargrp=1,self%nvargrp + if(self%intstate(jscale,ivargrp)%nm.ne.self%intstate(jscale,1)%nm.or. & + self%intstate(jscale,ivargrp)%mm.ne.self%intstate(jscale,1)%mm) then + error stop "for being now, the filtering grids at the start of MGBF should be the same" + endif + total_km_a_all=self%intstate(jscale,ivargrp)%km_a_all+total_km_a_all + nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all + enddo + + nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps + + n2d=0 + l2d_encountered=.false. + ivargrp0=1 + allocate(work_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm,self%intstate(jscale,ivargrp0)%mm)) + allocate(work2d_mgbf(total_km_a_all,self%intstate(jscale,ivargrp0)%nm*self%intstate(jscale,ivargrp0)%mm)) + allocate(rnormalization(total_km_a_all,nvargrp)) + rnormalization=0.0 + work2d_mgbf=0.0 + ii=1 + do ivargrp=1,nvargrp + do k=1,self%intstate(jscale,ivargrp)%km2 +!clt if for localization , km2=0 only for +!clt only for l_2dvar_last_vertical_lev + rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) + ii=ii+1 + enddo +!clt if for localization , km2=0 + do k=1,self%intstate(jscale,ivargrp)%km3 + rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) + ii=ii+nz3d + enddo + enddo + + dim2d=shape(work2d_mgbf) + + dim3d=shape(work_mgbf) + nxloc=dim3d(2) + nyloc=dim3d(3) + nzloc=dim3d(1) + nvar=fields%size() + allocate( varvlev_index(nvar,3)) + varvlev_index=0 + + ilev=1 + do isize=1,fields%size() + + afield= fields%field(isize) !clttodo + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + write(6,*)'thinkdeb333 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() + if(afield%rank() == 2) then + write(6,*)'thinkdeb333 iszie ',isize,' ',afield%name() + nz=afield%levels() + write(6,*)'thinkdeb333 iszie-nz ',isize,' ',afield%name(),' ',nz + call afield%data(ptr_2d) + if(nz /= 1 .and. nz /= nz3d ) then + write(6,*)'the vertical dimension of the input fields are not as expectd ,stop ',nz,' ',nz3d + call flush(6) + stop + endif + + if(nz == 1) then + !clttothink if(self%intstate(iscale,ivargrp)%l_for_localization) then + if(self%intstate(jscale,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + if(ilev+nz3d-1 > total_km_a_all) then + write(6,*)'MGBF abort 1 : the dimensions are not as expected' + call flush(6) + stop + endif + if(n_owned_size >0 ) then + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev+nz3d-1:ilev+nz3d-1,:)=ptr_2d + endif + else + if(ilev+nz-1 > total_km_a_all) then + write(6,*)'MGBF abort 2 : the dimensions are not as expected' + call flush(6) + stop + endif + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d (:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + + + else + if(ilev+nz-1 > total_km_a_all) then + write(6,*)'MGBF abort 3 : the dimensions are not as expected' + call flush(6) + stop + endif + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + else + if(ilev+nz-1 > total_km_a_all) then + write(6,*)'MGBF abort 4 : the dimensions are not as expected' + call flush(6) + stop + endif + if(n_owned_size >0 ) then + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d(:,1:n_owned_size) + else + work2d_mgbf(ilev:ilev+nz-1,:)=ptr_2d + endif + endif + if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then + write(6,*)'thinkdeb333 before max is large 0.5' + loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) + write(6,*)'thinkdeb333 before large 0.5 loc ',loc + endif + + if(nz == 1) then + l2d_encountered=.true. + n2d=n2d+1 + endif + if(nz > 1) then + if(l2d_encountered .and. .not.self%intstate(jscale,1)%l_for_localization ) then + write(6,*)"l2d_encountered is true , 2dvariable is not put in the ending and l_for_localization=.false. , stop" + call flush(6) + error stop ("2dvariable is not put in the ending and l_for_localization=.false.") ! is required 2d fields are saved consecutively,and at the ending + endif + endif + if(isize==1) then + varvlev_index(isize,1)= 1 + !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then + if(.not.self%intstate(jscale,1)%l_for_localization )then + varvlev_index(isize,2)= nz + else + varvlev_index(isize,2)= nz3d + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + else + !cltorg varvlev_index(isize,1)= varvlev_index(isize-1,1)+nz3d + varvlev_index(isize,1)= varvlev_index(isize-1,2)+1 + if(.not.self%intstate(jscale,ivargrp0)%l_for_localization )then + varvlev_index(isize,2)= varvlev_index(isize,1)+nz-1 + else + varvlev_index(isize,2)= varvlev_index(isize,1)+nz3d-1 + endif + varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 + endif + jvargrp=self%ivar2grp(isize) + + + ilev=varvlev_index(isize,2)+1 + elseif (afield%rank() == 3) then + write(6,*)'this case needs more work, stop' ! a better exption handling to be added + call flush(6) + stop + call afield%data(ptr_3d) + nz=afield%levels() + work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + stop + endif + enddo + do k=1,nzloc + work_mgbf(k,:,:) =reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) + enddo + + if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then + write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' + stop ! a better exception handling is to be added + endif + + if(test_once.and..1.gt.2) then + open(iounit,file=trim(fileoutput), status='replace',form="formatted") + write(iounit,*) work_mgbf + test_once=.false. + close(iounit) + endif + call etim(mg_preprocess_time) + ii=1 + write(6,*)'codexdebug km2/km3/total/nvar/nz3d ', self%intstate(jscale,1)%km2, & + & self%intstate(jscale,1)%km3, total_km_a_all, nvar, nz3d + do i=1,min(4,nvar) + write(6,*)'codexdebug varvlev_index ', i, varvlev_index(i,1), varvlev_index(i,2) + enddo + do ivargrp=1,nvargrp + allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) + allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) + vargrp_work_mgbf(:,:,:)=work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) + + + call btim(mg_anal_to_filt_time) + call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) + write(6,*)'codexdebug max_in_grp ', ivargrp, maxval(vargrp_work_mgbf) + call etim(mg_anal_to_filt_time) + call btim(mg_filtering_time) + call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) + call etim(mg_filtering_time) + + !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) + call btim(mg_filt_to_anal_time) + call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) + write(6,*)'codexdebug max_out_grp ', ivargrp, maxval(vargrp_work_mgbf2) + call etim(mg_filt_to_anal_time) + !clt# work_mgbf=999.0 !thinkdeb for debug + + call btim(mg_postprocess_time) + do k=1,nlev_vargrp(ivargrp) + vargrp_work_mgbf2(k,:,:)=vargrp_work_mgbf2(k,:,:)/rnormalization(k,ivargrp) + enddo + work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:)=vargrp_work_mgbf2(:,:,:) + ii=ii+nlev_vargrp(ivargrp) + deallocate(vargrp_work_mgbf) + deallocate(vargrp_work_mgbf2) + enddo ! ivargrp + if(self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx + allocate(work1var_mgbf(nz3d,nxloc,nyloc)) + work1var_mgbf=0.0 + if(nvargrp == 1 ) then + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + work1var_mgbf=work1var_mgbf+work_mgbf(lev1:lev2,:,:) + enddo + do jvar=1,nvar + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + else + do jvar=1,nvar + jvargrp=self%ivar2grp(jvar) + do ivar=1,nvar + lev1=varvlev_index(ivar,1) + lev2=varvlev_index(ivar,2) + ivargrp=self%ivar2grp(ivar) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf(lev1:lev2,:,:) + enddo + lev1=varvlev_index(jvar,1) + lev2=varvlev_index(jvar,2) + work_mgbf(lev1:lev2,:,:)=work1var_mgbf + enddo + endif + deallocate(work1var_mgbf) + endif + do k=1,nzloc + work2d_mgbf(k,:)=reshape(work_mgbf(k,:,:),[dim2d(2)]) + enddo + ilev=1 + n_owned_size=0 + do isize=1,fields%size() + + + afield=fields%field(isize) !clttodo + write(6,*)'thinkdeb333-2 iszie-rank ',isize,' ',afield%name(),' ',afield%rank() + fs= afield%functionspace() !cltthinkfore debug + n_owned_size= fs%size_owned() !clt for debug + + + if(afield%rank() == 2) then + call afield%data(ptr_2d) + nz=afield%levels() + lev1=varvlev_index(isize,1) + write(6,*)'thinkdeb333-3 leve: leve2 ',lev1,' ',lev1+nz + if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then + loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) + write(6,*)'thinkdeb333 max is large 0.5 loc ',loc + endif + if(nz.gt.1) then + if(n_owned_size >0 ) then + ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1:nz,:)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(self%intstate(1,1)%l_for_localization) then + if( self%l_2dvar_last_vertical_level) then !when used for localization,2dvars are put on the last vertical level + + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1+nz3d-1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + endif + else + if(n_owned_size >0 ) then + ptr_2d(1,1:n_owned_size)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + else + !cltthinkdebto now, the n_owned_size can't be got rightly for mgbf_grid using PointCloud function space + write(6,*)'suspicous situation while n_owned_szie =0 ,stop' + call flush(6) + stop + ptr_2d(1,:)=work2d_mgbf(lev1,:)!if nz=1, only the first level is used (like for surface pressure) + endif + + endif + endif !nz >1 or not + + elseif (afield%rank() == 3) then + call afield%data(ptr_3d) + nz=afield%levels() + write(6,*)'wrong in mgbf_covariance_mod.f90 todo ' !todo + call flush(6) + stop + + + !clt ptr_3d=work2d_mgbf(ilev:ilev+nz-1,:) + ilev=ilev+nz + else + write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo + call flush(6) + stop + endif + enddo + + call etim(mg_postprocess_time) + + + + call afield%final() + + deallocate(work_mgbf) + deallocate(work2d_mgbf) + deallocate(rnormalization) + deallocate( varvlev_index) + !clt enddo !for iscale + call etim(mg_multiply_time) + deallocate(nlev_vargrp) + +end subroutine multiply + +! -------------------------------------------------------------------------------------------------- + +subroutine multiply_ad(self, fields) + +! Arguments +class(mgbf_covariance), intent(inout) :: self +type(atlas_fieldset), intent(inout) :: fields + +! This routine only needed when B = G^T G (sqrt-factored) + +! To do list for this method +! 1. Convert fields (Atlas fieldsets) to MGBF bundle +! 2. Call MGBF covariance operator adjoint (sqrt version) +! afield = fields%field('stream_function') +! call afield%data(var3d) +! var3d=0.0_r_kind + +end subroutine multiply_ad +function imem2scale(self,imem) result(iscale) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::imem + integer :: iscale + iscale=1 + do while (iscale.le.self%nscale-1.and.imem > self%iscalegroup(iscale) ) + iscale=iscale+1 + enddo + +end function imem2scale +function ivar2grp(self,ivar) result(jvargrp) + class(mgbf_covariance),intent(in)::self + integer, intent(in)::ivar + integer :: jvargrp + jvargrp=1 + do while (jvargrp.le.self%nvargrp-1.and.ivar > self%ivargroup(jvargrp) ) + jvargrp=jvargrp+1 + enddo + +end function ivar2grp + +! -------------------------------------------------------------------------------------------------- + +end module mgbf_covariance_mod + From 9ec8ce7f6588ca622806a005a97f9fc4db7f5838 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Wed, 28 Jan 2026 11:32:58 -0500 Subject: [PATCH 156/199] adding fill missing values for state variable inversion --- src/saber/interpolation/Interpolation.cc | 86 ++++++++++++++++++++++++ src/saber/interpolation/Interpolation.h | 1 + 2 files changed, 87 insertions(+) diff --git a/src/saber/interpolation/Interpolation.cc b/src/saber/interpolation/Interpolation.cc index 9a484e017..ba4e87f1e 100644 --- a/src/saber/interpolation/Interpolation.cc +++ b/src/saber/interpolation/Interpolation.cc @@ -8,9 +8,12 @@ #include "saber/interpolation/Interpolation.h" #include "atlas/util/Config.h" +#include "atlas/util/Geometry.h" +#include "atlas/util/KDTree.h" #include "oops/util/FieldSetOperations.h" #include "oops/util/Logger.h" +#include "oops/util/missingValues.h" #include "mpi.h" //cltthinkdeb todo #include //cltthink @@ -23,6 +26,83 @@ static SaberOuterBlockMaker makerInterpolation_("interpolation"); // ----------------------------------------------------------------------------- +namespace { + +void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, + atlas::FieldSet & targetFieldSet, + const oops::Variables & vars, + const atlas::FunctionSpace & sourceFs, + const atlas::FunctionSpace & targetFs) { + if (vars.size() == 0) { + return; + } + + const auto src_lonlat = atlas::array::make_view(sourceFs.lonlat()); + const auto src_ghost = atlas::array::make_view(sourceFs.ghost()); + std::vector lons; + std::vector lats; + std::vector indices; + lons.reserve(src_lonlat.shape(0)); + lats.reserve(src_lonlat.shape(0)); + indices.reserve(src_lonlat.shape(0)); + for (atlas::idx_t jj = 0; jj < src_lonlat.shape(0); ++jj) { + if (src_ghost(jj) == 0) { + lons.push_back(src_lonlat(jj, 0)); + lats.push_back(src_lonlat(jj, 1)); + indices.push_back(jj); + } + } + if (indices.empty()) { + return; + } + + const atlas::Geometry earth(atlas::util::Earth::radius()); + atlas::util::IndexKDTree2D tree(earth); + tree.build(lons, lats, indices); + + const auto tgt_lonlat = atlas::array::make_view(targetFs.lonlat()); + const auto tgt_ghost = atlas::array::make_view(targetFs.ghost()); + const double missing = oops::util::missingValue(); + + for (const auto & var : vars) { + if (!targetFieldSet.has(var.name()) || !sourceFieldSet.has(var.name())) { + continue; + } + auto tgt_view = atlas::array::make_view(targetFieldSet[var.name()]); + const auto src_view = atlas::array::make_view( + sourceFieldSet.field(var.name())); + + for (atlas::idx_t jloc = 0; jloc < tgt_view.shape(0); ++jloc) { + if (tgt_ghost(jloc) != 0) { + continue; + } + bool has_missing = false; + for (atlas::idx_t jlev = 0; jlev < tgt_view.shape(1); ++jlev) { + if (tgt_view(jloc, jlev) == missing) { + has_missing = true; + break; + } + } + if (!has_missing) { + continue; + } + + atlas::PointLonLat pll(tgt_lonlat(jloc, 0), tgt_lonlat(jloc, 1)); + const auto item = tree.closestPoint(pll); + const atlas::idx_t src_index = item.payload(); + for (atlas::idx_t jlev = 0; jlev < tgt_view.shape(1); ++jlev) { + if (tgt_view(jloc, jlev) == missing) { + tgt_view(jloc, jlev) = src_view(src_index, jlev); + } + } + } + } +} + +} // namespace + +// ----------------------------------------------------------------------------- + Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, const oops::Variables & outerVars, const eckit::Configuration & covarConf, @@ -213,6 +293,12 @@ void Interpolation::leftInverseMultiply(oops::FieldSet3D & fieldSet) const { inverseRegionalInterp_->execute(sourceFieldSet, targetFieldSet); } + if (params_.fillMissingValues.value()) { + fillMissingValuesNearest(sourceFieldSet, targetFieldSet, invVars, + outerGeomData_.functionSpace(), + innerGeomData_->functionSpace()); + } + // Reset fieldSet.fieldSet() = targetFieldSet; diff --git a/src/saber/interpolation/Interpolation.h b/src/saber/interpolation/Interpolation.h index 3760d9b11..76662f339 100644 --- a/src/saber/interpolation/Interpolation.h +++ b/src/saber/interpolation/Interpolation.h @@ -41,6 +41,7 @@ class InterpolationParameters : public SaberBlockParametersBase { eckit::LocalConfiguration(), this}; oops::Parameter inverseInterpConf{"inverse interpolator", eckit::LocalConfiguration(), this}; + oops::Parameter fillMissingValues{"fill missing values", false, this}; oops::Variables mandatoryActiveVars() const override {return oops::Variables();} }; From 13d2cb44915d2634e50c44f57b3945576ccba00c Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Thu, 29 Jan 2026 15:46:58 +0000 Subject: [PATCH 157/199] a working version for refactoring and openmp enhanced mgbf/saber in the branch :use_required_atlas_grid --- src/saber/interpolation/Interpolation.cc | 2 +- src/saber/interpolation/Interpolation.h | 2 +- .../covariance/MGBF_Covariance.interface.F90 | 8 ---- .../mgbf/covariance/mgbf_covariance_mod.f90 | 41 +++++++++++-------- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 1 - 5 files changed, 25 insertions(+), 29 deletions(-) diff --git a/src/saber/interpolation/Interpolation.cc b/src/saber/interpolation/Interpolation.cc index ba4e87f1e..c82b9708a 100644 --- a/src/saber/interpolation/Interpolation.cc +++ b/src/saber/interpolation/Interpolation.cc @@ -62,7 +62,7 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, const auto tgt_lonlat = atlas::array::make_view(targetFs.lonlat()); const auto tgt_ghost = atlas::array::make_view(targetFs.ghost()); - const double missing = oops::util::missingValue(); + const double missing = util::missingValue(); for (const auto & var : vars) { if (!targetFieldSet.has(var.name()) || !sourceFieldSet.has(var.name())) { diff --git a/src/saber/interpolation/Interpolation.h b/src/saber/interpolation/Interpolation.h index 76662f339..97749456c 100644 --- a/src/saber/interpolation/Interpolation.h +++ b/src/saber/interpolation/Interpolation.h @@ -41,7 +41,7 @@ class InterpolationParameters : public SaberBlockParametersBase { eckit::LocalConfiguration(), this}; oops::Parameter inverseInterpConf{"inverse interpolator", eckit::LocalConfiguration(), this}; - oops::Parameter fillMissingValues{"fill missing values", false, this}; + oops::Parameter fillMissingValues{"fill state missing values", false, this}; oops::Variables mandatoryActiveVars() const override {return oops::Variables();} }; diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 index d75282ca3..0758d5f5c 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 +++ b/src/saber/mgbf/covariance/MGBF_Covariance.interface.F90 @@ -160,14 +160,8 @@ subroutine mgbf_covariance_multiply_cpp(c_self, c_afieldset,c_index_member_in) & type(atlas_fieldset) :: f_fieldset integer :: index_member_in=0 !cltthink type(fieldset_type) :: f_fieldset -write(6,*)'thinkdeb 999 in inteface f90 star' -call flush(6) call btim(mg_interface_multiply_time) -write(6,*)'thinkdeb 999 in inteface f90 star0.5 c_index_member_in ',c_index_member_in -call flush(6) index_member_in=int(c_index_member_in,kind=kind(index_member_in)) -write(6,*)'thinkdeb 999 in inteface f90 star1' -call flush(6) ! LinkedList ! ---------- call btim(mg_interface_registry_get_time) @@ -182,8 +176,6 @@ subroutine mgbf_covariance_multiply_cpp(c_self, c_afieldset,c_index_member_in) & ! Call implementation ! ------------------- -write(6,*)'thinkdeb 999 in inteface f90 star2' -call flush(6) call f_self%multiply(f_fieldset,index_member_in) call etim(mg_interface_multiply_time) call f_fieldset%final() diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 026248dd8..4acb6350e 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -138,7 +138,6 @@ subroutine create(self, comm, config, funcspace, background, firstguess) write(6,*)'thinkdeb mgbf create999 config' dump_json=config%json() ! serialize to a JSON string write(6,'(A)')trim(dump_json) -call flush(6) call config%get_or_die("saber block name", centralblockname) !clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) if (config%has("mgbf sdl and vdl init namelist file")) then @@ -199,8 +198,6 @@ subroutine create(self, comm, config, funcspace, background, firstguess) fs_sc = funcspace npts_owned = fs_sc%size_owned() npts_total = fs_sc%size() -write(6,*)'thinkdeb mgbf create npts_owned/_total ',npts_owned, ' ',npts_total -call flush(6) if(npts_owned.ge.npts_total) then write(6,*)'the halo points are not present, on which the outer block interpolator would be problematic, stop' call flush(6) @@ -218,17 +215,12 @@ subroutine create(self, comm, config, funcspace, background, firstguess) allocate(self%intstate(nscale,nvargrp)) -call flush(6) do iscale=1,nscale do ivargrp=1,nvargrp - write(6,*)'the999 nml is ', trim(self%mgbf_nml_group(iscale,ivargrp)) - call flush(6) call self%intstate(iscale,ivargrp)%mg_initialize(n_owned_anl=npts_owned, & anl_lonlat1d=lonlat_anl, inputfilename=self%mgbf_nml_group(iscale,ivargrp)) !mgbf_nml like mgbeta.nml enddo enddo -write(6,*)'thinkdeb mgbf create999 10 ' -call flush(6) if (allocated(lonlat_anl)) deallocate(lonlat_anl) ! Allocate persistent workspaces based on intstate sizes @@ -252,6 +244,27 @@ subroutine create(self, comm, config, funcspace, background, firstguess) stop endif enddo +enddo +self%total_km_a_all=0 +do iscale=1,nscale + do ivargrp=1,nvargrp + if (iscale == 1 ) self%total_km_a_all = self%total_km_a_all + self%intstate(iscale,ivargrp)%km_a_all + if(self%intstate(iscale,ivargrp)%nm /= self%intstate(1,1)%nm ) then + write(6,*)'nm should be the same for all mgbf filters, stop' + call flush(6) + stop + endif + if(self%intstate(iscale,ivargrp)%mm /= self%intstate(1,1)%mm ) then + write(6,*)'mm should be the same for all mgbf filters, stop' + call flush(6) + stop + endif + if(self%intstate(iscale,ivargrp)%lm_a /= self%intstate(1,1)%lm_a ) then + write(6,*)'lm_a should be the same for all mgbf filters, stop' + call flush(6) + stop + endif + enddo enddo self%nvar = 0 do ivargrp=1,nvargrp @@ -271,7 +284,6 @@ subroutine create(self, comm, config, funcspace, background, firstguess) - end subroutine create ! -------------------------------------------------------------------------------------------------- @@ -419,7 +431,6 @@ subroutine multiply(self, fields,index_member_in) endif myrank=self%rank write(str_rank,"(I4.4)")myrank - if (.not. associated(self%nlev_vargrp)) then error stop "MGBF workspace nlev_vargrp not allocated" endif @@ -476,6 +487,7 @@ subroutine multiply(self, fields,index_member_in) rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) ii=ii+nz3d enddo + nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all enddo endif @@ -595,7 +607,6 @@ subroutine multiply(self, fields,index_member_in) varvlev_index(isize,3)= varvlev_index(isize,2) -varvlev_index(isize,1)+1 endif endif - jvargrp=self%ivar2grp(isize) ilev=varvlev_index(isize,2)+1 @@ -603,10 +614,6 @@ subroutine multiply(self, fields,index_member_in) write(6,*)'this case needs more work, stop' ! a better exption handling to be added call flush(6) stop - call afield%data(ptr_3d) - nz=afield%levels() - work_mgbf(ilev:ilev+nz-1,:,:)=ptr_3d - ilev=ilev+nz else write(6,*)'wrong in mgbf_covariance_mod.f90 ' !todo stop @@ -629,7 +636,7 @@ subroutine multiply(self, fields,index_member_in) allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) vargrp_work_mgbf(:,:,:) = work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) - + call btim(mg_anal_to_filt_time) call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) @@ -641,8 +648,6 @@ subroutine multiply(self, fields,index_member_in) !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) call btim(mg_filt_to_anal_time) call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) - write(6,*)'codexdebug max_out_grp ', ivargrp, & - maxval(vargrp_work_mgbf2) call etim(mg_filt_to_anal_time) !clt# work_mgbf=999.0 !thinkdeb for debug diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index b5b2e2680..396d0d196 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -569,7 +569,6 @@ subroutine init_mg_parameter(this,inputfilename) character*4 :: str_rank integer :: n_sample_levelsx4normalization logical :: l_exist - namelist /parameters_mgbeta/ mg_ampl01,mg_ampl02,mg_ampl03 & ,mg_weig1,mg_weig2,mg_weig3,mg_weig4 & ,hx,hy,hz,p & From 587f8d6bcdb56727bc09907553b056474e0b5310 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 29 Jan 2026 11:04:36 -0500 Subject: [PATCH 158/199] debugging fillMisingVluees --- src/saber/interpolation/Interpolation.cc | 29 ++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/src/saber/interpolation/Interpolation.cc b/src/saber/interpolation/Interpolation.cc index c82b9708a..03ca59f19 100644 --- a/src/saber/interpolation/Interpolation.cc +++ b/src/saber/interpolation/Interpolation.cc @@ -34,6 +34,7 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, const atlas::FunctionSpace & sourceFs, const atlas::FunctionSpace & targetFs) { if (vars.size() == 0) { + oops::Log::info() << "fillMissingValuesNearest: no variables to process" << std::endl; return; } @@ -53,6 +54,7 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, } } if (indices.empty()) { + oops::Log::info() << "fillMissingValuesNearest: no owned source points" << std::endl; return; } @@ -64,14 +66,23 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, const auto tgt_ghost = atlas::array::make_view(targetFs.ghost()); const double missing = util::missingValue(); + oops::Log::info() << "fillMissingValuesNearest: processing vars = " + << vars.variables() << std::endl; + for (const auto & var : vars) { if (!targetFieldSet.has(var.name()) || !sourceFieldSet.has(var.name())) { + oops::Log::info() << "fillMissingValuesNearest: skipping var (missing in fset) " + << var.name() << std::endl; continue; } auto tgt_view = atlas::array::make_view(targetFieldSet[var.name()]); const auto src_view = atlas::array::make_view( sourceFieldSet.field(var.name())); + std::size_t missing_before = 0; + std::size_t missing_after = 0; + std::size_t filled = 0; + for (atlas::idx_t jloc = 0; jloc < tgt_view.shape(0); ++jloc) { if (tgt_ghost(jloc) != 0) { continue; @@ -80,6 +91,7 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, for (atlas::idx_t jlev = 0; jlev < tgt_view.shape(1); ++jlev) { if (tgt_view(jloc, jlev) == missing) { has_missing = true; + ++missing_before; break; } } @@ -93,9 +105,26 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, for (atlas::idx_t jlev = 0; jlev < tgt_view.shape(1); ++jlev) { if (tgt_view(jloc, jlev) == missing) { tgt_view(jloc, jlev) = src_view(src_index, jlev); + ++filled; } } } + + for (atlas::idx_t jloc = 0; jloc < tgt_view.shape(0); ++jloc) { + if (tgt_ghost(jloc) != 0) { + continue; + } + for (atlas::idx_t jlev = 0; jlev < tgt_view.shape(1); ++jlev) { + if (tgt_view(jloc, jlev) == missing) { + ++missing_after; + } + } + } + + oops::Log::info() << "fillMissingValuesNearest: var=" << var.name() + << " missing_before=" << missing_before + << " filled=" << filled + << " missing_after=" << missing_after << std::endl; } } From 812210baf2a1b4656cbbe6dae23c22250e35a8dd Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 29 Jan 2026 16:48:55 -0500 Subject: [PATCH 159/199] WIP --- src/saber/interpolation/Interpolation.cc | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/src/saber/interpolation/Interpolation.cc b/src/saber/interpolation/Interpolation.cc index 03ca59f19..f685004b7 100644 --- a/src/saber/interpolation/Interpolation.cc +++ b/src/saber/interpolation/Interpolation.cc @@ -82,6 +82,11 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, std::size_t missing_before = 0; std::size_t missing_after = 0; std::size_t filled = 0; + std::size_t logged = 0; + const bool log_values = (var.name() == "air_pressure_thickness"); + const std::size_t log_limit = 20; + const double small_value_threshold = 1.0e-6; + std::size_t small_after_fill = 0; for (atlas::idx_t jloc = 0; jloc < tgt_view.shape(0); ++jloc) { if (tgt_ghost(jloc) != 0) { @@ -106,6 +111,21 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, if (tgt_view(jloc, jlev) == missing) { tgt_view(jloc, jlev) = src_view(src_index, jlev); ++filled; + if (std::abs(tgt_view(jloc, jlev)) < small_value_threshold) { + ++small_after_fill; + } + if (log_values && logged < log_limit) { + oops::Log::info() + << "fillMissingValuesNearest: var=" << var.name() + << " jloc=" << jloc + << " lev=" << jlev + << " lat=" << tgt_lonlat(jloc, 1) + << " lon=" << tgt_lonlat(jloc, 0) + << " src_index=" << src_index + << " filled_value=" << tgt_view(jloc, jlev) + << std::endl; + ++logged; + } } } } @@ -124,7 +144,8 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, oops::Log::info() << "fillMissingValuesNearest: var=" << var.name() << " missing_before=" << missing_before << " filled=" << filled - << " missing_after=" << missing_after << std::endl; + << " missing_after=" << missing_after + << " small_after_fill=" << small_after_fill << std::endl; } } From 4d989db0512c0c17c4a17de7a971b5352be51886 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 29 Jan 2026 19:33:01 -0500 Subject: [PATCH 160/199] WIP --- src/saber/interpolation/Interpolation.cc | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/src/saber/interpolation/Interpolation.cc b/src/saber/interpolation/Interpolation.cc index f685004b7..026feb270 100644 --- a/src/saber/interpolation/Interpolation.cc +++ b/src/saber/interpolation/Interpolation.cc @@ -66,7 +66,10 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, const auto tgt_ghost = atlas::array::make_view(targetFs.ghost()); const double missing = util::missingValue(); - oops::Log::info() << "fillMissingValuesNearest: processing vars = " + int mpirank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); + oops::Log::info() << "rank " << mpirank + << " fillMissingValuesNearest: processing vars = " << vars.variables() << std::endl; for (const auto & var : vars) { @@ -87,6 +90,7 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, const std::size_t log_limit = 20; const double small_value_threshold = 1.0e-6; std::size_t small_after_fill = 0; + std::size_t small_logged = 0; for (atlas::idx_t jloc = 0; jloc < tgt_view.shape(0); ++jloc) { if (tgt_ghost(jloc) != 0) { @@ -113,6 +117,17 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, ++filled; if (std::abs(tgt_view(jloc, jlev)) < small_value_threshold) { ++small_after_fill; + if (var.name() == "air_pressure_at_surface" && small_logged < log_limit) { + std::cout << "rank " << mpirank + << " small ps after fill: jloc=" << jloc + << " lev=" << jlev + << " lat=" << tgt_lonlat(jloc, 1) + << " lon=" << tgt_lonlat(jloc, 0) + << " src_index=" << src_index + << " value=" << tgt_view(jloc, jlev) + << std::endl; + ++small_logged; + } } if (log_values && logged < log_limit) { oops::Log::info() @@ -141,7 +156,8 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, } } - oops::Log::info() << "fillMissingValuesNearest: var=" << var.name() + oops::Log::info() << "rank " << mpirank + << " fillMissingValuesNearest: var=" << var.name() << " missing_before=" << missing_before << " filled=" << filled << " missing_after=" << missing_after From 7eed258b3b49d89f6b40802db1c04e10ea62a8b3 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 30 Jan 2026 11:40:21 -0500 Subject: [PATCH 161/199] WIP --- src/saber/interpolation/Interpolation.cc | 125 +++++++++++++++++++---- 1 file changed, 103 insertions(+), 22 deletions(-) diff --git a/src/saber/interpolation/Interpolation.cc b/src/saber/interpolation/Interpolation.cc index 026feb270..fe5277466 100644 --- a/src/saber/interpolation/Interpolation.cc +++ b/src/saber/interpolation/Interpolation.cc @@ -34,7 +34,10 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, const atlas::FunctionSpace & sourceFs, const atlas::FunctionSpace & targetFs) { if (vars.size() == 0) { - oops::Log::info() << "fillMissingValuesNearest: no variables to process" << std::endl; + int mpirank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); + std::cout << "rank " << mpirank + << " fillMissingValuesNearest: no variables to process" << std::endl; return; } @@ -54,7 +57,10 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, } } if (indices.empty()) { - oops::Log::info() << "fillMissingValuesNearest: no owned source points" << std::endl; + int mpirank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); + std::cout << "rank " << mpirank + << " fillMissingValuesNearest: no owned source points" << std::endl; return; } @@ -68,14 +74,15 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, int mpirank = 0; MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); - oops::Log::info() << "rank " << mpirank - << " fillMissingValuesNearest: processing vars = " - << vars.variables() << std::endl; + std::cout << "rank " << mpirank + << " fillMissingValuesNearest: processing vars = " + << vars.variables() << std::endl; for (const auto & var : vars) { if (!targetFieldSet.has(var.name()) || !sourceFieldSet.has(var.name())) { - oops::Log::info() << "fillMissingValuesNearest: skipping var (missing in fset) " - << var.name() << std::endl; + std::cout << "rank " << mpirank + << " fillMissingValuesNearest: skipping var (missing in fset) " + << var.name() << std::endl; continue; } auto tgt_view = atlas::array::make_view(targetFieldSet[var.name()]); @@ -130,15 +137,15 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, } } if (log_values && logged < log_limit) { - oops::Log::info() - << "fillMissingValuesNearest: var=" << var.name() - << " jloc=" << jloc - << " lev=" << jlev - << " lat=" << tgt_lonlat(jloc, 1) - << " lon=" << tgt_lonlat(jloc, 0) - << " src_index=" << src_index - << " filled_value=" << tgt_view(jloc, jlev) - << std::endl; + std::cout << "rank " << mpirank + << " fillMissingValuesNearest: var=" << var.name() + << " jloc=" << jloc + << " lev=" << jlev + << " lat=" << tgt_lonlat(jloc, 1) + << " lon=" << tgt_lonlat(jloc, 0) + << " src_index=" << src_index + << " filled_value=" << tgt_view(jloc, jlev) + << std::endl; ++logged; } } @@ -156,12 +163,12 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, } } - oops::Log::info() << "rank " << mpirank - << " fillMissingValuesNearest: var=" << var.name() - << " missing_before=" << missing_before - << " filled=" << filled - << " missing_after=" << missing_after - << " small_after_fill=" << small_after_fill << std::endl; + std::cout << "rank " << mpirank + << " fillMissingValuesNearest: var=" << var.name() + << " missing_before=" << missing_before + << " filled=" << filled + << " missing_after=" << missing_after + << " small_after_fill=" << small_after_fill << std::endl; } } @@ -341,6 +348,42 @@ void Interpolation::leftInverseMultiply(oops::FieldSet3D & fieldSet) const { sourceFieldSet.add(fieldSet[var.name()]); } + // Debug check: model-grid ps before inverse interpolation + if (sourceFieldSet.has("air_pressure_at_surface")) { + const atlas::Field & psField = sourceFieldSet["air_pressure_at_surface"]; + const auto psView = atlas::array::make_view(psField); + const auto psGhost = atlas::array::make_view(psField.functionspace().ghost()); + const double missing = util::missingValue(); + std::size_t psMissingOwned = 0; + std::size_t psMissingHalo = 0; + double psMinOwned = std::numeric_limits::max(); + double psMaxOwned = -std::numeric_limits::max(); + for (atlas::idx_t jloc = 0; jloc < psView.shape(0); ++jloc) { + const bool isHalo = (psGhost(jloc) != 0); + for (atlas::idx_t jlev = 0; jlev < psView.shape(1); ++jlev) { + const double v = psView(jloc, jlev); + if (v == missing) { + if (isHalo) { + ++psMissingHalo; + } else { + ++psMissingOwned; + } + } else if (!isHalo) { + psMinOwned = std::min(psMinOwned, v); + psMaxOwned = std::max(psMaxOwned, v); + } + } + } + int mpirank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); + std::cout << "rank " << mpirank + << " leftInverseMultiply: model ps missing owned=" << psMissingOwned + << " halo=" << psMissingHalo + << " minOwned=" << psMinOwned + << " maxOwned=" << psMaxOwned + << std::endl; + } + // Interpolate to target/inner grid atlas::FieldSet targetFieldSet; if (inverseGlobalInterp_) { @@ -363,6 +406,44 @@ void Interpolation::leftInverseMultiply(oops::FieldSet3D & fieldSet) const { fillMissingValuesNearest(sourceFieldSet, targetFieldSet, invVars, outerGeomData_.functionSpace(), innerGeomData_->functionSpace()); + // Update halos after filling missing values so boundary points are consistent + targetFieldSet.haloExchange(); + } + + // Debug check: filtering-grid ps after inverse interpolation + halo exchange + if (targetFieldSet.has("air_pressure_at_surface")) { + const atlas::Field & psField = targetFieldSet["air_pressure_at_surface"]; + const auto psView = atlas::array::make_view(psField); + const auto psGhost = atlas::array::make_view(psField.functionspace().ghost()); + const double missing = util::missingValue(); + std::size_t psMissingOwned = 0; + std::size_t psMissingHalo = 0; + double psMinOwned = std::numeric_limits::max(); + double psMaxOwned = -std::numeric_limits::max(); + for (atlas::idx_t jloc = 0; jloc < psView.shape(0); ++jloc) { + const bool isHalo = (psGhost(jloc) != 0); + for (atlas::idx_t jlev = 0; jlev < psView.shape(1); ++jlev) { + const double v = psView(jloc, jlev); + if (v == missing) { + if (isHalo) { + ++psMissingHalo; + } else { + ++psMissingOwned; + } + } else if (!isHalo) { + psMinOwned = std::min(psMinOwned, v); + psMaxOwned = std::max(psMaxOwned, v); + } + } + } + int mpirank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); + std::cout << "rank " << mpirank + << " leftInverseMultiply: filtering ps missing owned=" << psMissingOwned + << " halo=" << psMissingHalo + << " minOwned=" << psMinOwned + << " maxOwned=" << psMaxOwned + << std::endl; } // Reset From 1fc39cb2096f53ccbbd8dd327587722117f0a95f Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 6 Feb 2026 17:55:46 +0000 Subject: [PATCH 162/199] bug fix, a working version of the refactored mgbf_covariance_mod.f90 --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 4acb6350e..7b0da920d 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -275,6 +275,8 @@ subroutine create(self, comm, config, funcspace, background, firstguess) allocate(self%work_mgbf(self%total_km_a_all, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) allocate(self%work2d_mgbf(self%total_km_a_all, self%intstate(1,1)%nm * self%intstate(1,1)%mm)) allocate(self%rnormalization(self%total_km_a_all, nvargrp)) + self%rnormalization(self%total_km_a_all, nvargrp)=0.0 + allocate(self%work1var_mgbf(nz3d, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) allocate(self%nlev_vargrp(nvargrp)) @@ -470,23 +472,23 @@ subroutine multiply(self, fields,index_member_in) size(rnormalization,2) /= nvargrp) then error stop "MGBF workspace rnormalization too small for current scale" endif - rnormalization = 0.0 work2d_mgbf = 0.0 work1var_mgbf=0 - ii=1 if(self%l_multiply_first_call) then + ii=1 do ivargrp=1,nvargrp + !clt if for localization , km2=0 + do k=1,self%intstate(jscale,ivargrp)%km3 + rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) + ii=ii+nz3d + + enddo do k=1,self%intstate(jscale,ivargrp)%km2 !clt if for localization , km2=0 only for !clt only for l_2dvar_last_vertical_lev rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) ii=ii+1 enddo - !clt if for localization , km2=0 - do k=1,self%intstate(jscale,ivargrp)%km3 - rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) - ii=ii+nz3d - enddo nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all enddo endif From 349fa1a164eeb21926ee158f3d03ee719ad0cd0f Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 6 Feb 2026 17:43:59 -0500 Subject: [PATCH 163/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 7b0da920d..27edbd7c2 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -475,8 +475,8 @@ subroutine multiply(self, fields,index_member_in) work2d_mgbf = 0.0 work1var_mgbf=0 if(self%l_multiply_first_call) then - ii=1 do ivargrp=1,nvargrp + ii=1 !clt if for localization , km2=0 do k=1,self%intstate(jscale,ivargrp)%km3 rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) @@ -490,6 +490,10 @@ subroutine multiply(self, fields,index_member_in) ii=ii+1 enddo nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all + if (any(rnormalization(1:nlev_vargrp(ivargrp), ivargrp) == 0.0_r_kind)) then + write(6,*) 'DBG zero normalization in group', ivargrp, & + ' nlev=', nlev_vargrp(ivargrp), ' jscale=', jscale, ' rank=', self%rank + endif enddo endif From 80c473d8e9fe1e646142fdacd9f5be2b5a810c03 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Fri, 6 Feb 2026 20:52:42 -0500 Subject: [PATCH 164/199] major part of openmp added for mgbf component --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 5 ++++ src/saber/mgbf/mgbf_lib/jp_pbfil.f90 | 3 ++- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 12 +++++++++ src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 | 6 +++++ src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 16 ++++++++++++ src/saber/mgbf/mgbf_lib/mg_generations.f90 | 16 ++++++++++++ src/saber/mgbf/mgbf_lib/mg_interpolate.f90 | 26 +++++++++++++++++++ src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 4 +++ src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 | 3 ++- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 6 +++++ src/saber/mgbf/mgbf_lib/mg_transfer.f90 | 6 +++++ src/saber/mgbf/mgbf_lib/phint1.f90 | 5 +++- 12 files changed, 105 insertions(+), 3 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 27edbd7c2..f563313f0 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -475,6 +475,7 @@ subroutine multiply(self, fields,index_member_in) work2d_mgbf = 0.0 work1var_mgbf=0 if(self%l_multiply_first_call) then +!$omp parallel do private(ivargrp,ii,k) schedule(static) do ivargrp=1,nvargrp ii=1 !clt if for localization , km2=0 @@ -495,6 +496,7 @@ subroutine multiply(self, fields,index_member_in) ' nlev=', nlev_vargrp(ivargrp), ' jscale=', jscale, ' rank=', self%rank endif enddo +!$omp end parallel do endif dim2d=shape(work2d_mgbf) @@ -676,12 +678,15 @@ subroutine multiply(self, fields,index_member_in) lev2=varvlev_index(ivar,2) work1var_mgbf=work1var_mgbf+work_mgbf(lev1:lev2,:,:) enddo +!$omp parallel do private(jvar,lev1,lev2) schedule(static) do jvar=1,nvar lev1=varvlev_index(jvar,1) lev2=varvlev_index(jvar,2) work_mgbf(lev1:lev2,:,:)=work1var_mgbf enddo +!$omp end parallel do else +!clttodo, further optimizaiton do jvar=1,nvar jvargrp=self%ivar2grp(jvar) do ivar=1,nvar diff --git a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 index f730d06bb..3af5a5efa 100755 --- a/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pbfil.f90 @@ -80,7 +80,9 @@ module subroutine cholaspect1(lx,mx, el) ! [cholaspect] !----------------------------------------------------------------------------- integer :: ix !============================================================================= +!$omp parallel do private(ix) schedule(static) do ix=lx,mx; el(1,1,ix)=u1/sqrt(el(1,1,ix)); enddo +!$omp end parallel do end subroutine cholaspect1 !============================================================================= module subroutine cholaspect2(lx,mx, ly,my, el) ! [cholaspect] @@ -1238,4 +1240,3 @@ module subroutine vrbeta3T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rb end subroutine vrbeta3t end submodule jp_pbfil - diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index 147a917c2..c6ed2d5a7 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -186,11 +186,13 @@ module subroutine boco_2d_g1 & allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) +!$omp parallel do private(i,j) schedule(static) do j=1,nby do i=1,imax sBuf_S(:,i,j) = W(:,i,j) enddo enddo +!$omp end parallel do call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & mpi_comm_comp, sHandle(3), isend) @@ -203,11 +205,13 @@ module subroutine boco_2d_g1 & allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) +!$omp parallel do private(i,j) schedule(static) do j=1,nby do i=1,imax sBuf_N(:,i,j)=W(:,i,jmax-nby+j) enddo enddo +!$omp end parallel do call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & mpi_comm_comp, sHandle(1), isend) @@ -247,19 +251,23 @@ module subroutine boco_2d_g1 & if(lsouth) then +!$omp parallel do private(i,j) schedule(static) do j=1,nby do i=1,imax W(:,i,-nby+j)=W(:,i,nby+1-j) end do end do +!$omp end parallel do else +!$omp parallel do private(i,j) schedule(static) do j=1,nby do i=1,imax W(:,i,-nby+j)=rBuf_S(:,i,j) enddo enddo +!$omp end parallel do endif @@ -268,19 +276,23 @@ module subroutine boco_2d_g1 & if( lnorth) then +!$omp parallel do private(i,j) schedule(static) do j=1,nby do i=1,imax W(:,i,jmax+j)=W(:,i,jmax+1-j) enddo enddo +!$omp end parallel do else +!$omp parallel do private(i,j) schedule(static) do j=1,nby do i=1,imax W(:,i,jmax+j)=rBuf_N(:,i,j) enddo enddo +!$omp end parallel do endif diff --git a/src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 b/src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 index 4b48ecae5..826090992 100755 --- a/src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_domain_loc.f90 @@ -355,6 +355,7 @@ module subroutine targup_loc(this) ! g1 --> g2 ! +!$omp parallel do private(n,js,is,ix_prox,jy_prox) schedule(static) do n=1,4 js=(n-1)/2 is= n-1 -js*2 @@ -363,6 +364,7 @@ module subroutine targup_loc(this) Fitargup_loc12(n)=nxm*(jy_prox-1)+ix_prox-1 enddo +!$omp end parallel do ! write(12,'(i5,a,4i5)') mype,' ---> ', Fitargup_loc12(1),Fitargup_loc12(2),Fitargup_loc12(3),Fitargup_loc12(4) @@ -372,6 +374,7 @@ module subroutine targup_loc(this) il = (ix_0-1)/(nxm/2) jl = (jy_0-1)/(nym/2) +!$omp parallel do private(n,js,is,ix_prox,jy_prox) schedule(static) do n=1,4 js=(n-1)/2 is= n-1-js*2 @@ -380,6 +383,7 @@ module subroutine targup_loc(this) Fitargup_loc23(n)=nxm*(jy_prox-1)+ix_prox-1 enddo +!$omp end parallel do ! write(23,'(i5,a,4i5)') mype,' ---> ', Fitargup_loc23(1),Fitargup_loc23(2),Fitargup_loc23(3),Fitargup_loc23(4) @@ -389,6 +393,7 @@ module subroutine targup_loc(this) il = (ix_0-1)/(nxm/4) jl = (jy_0-1)/(nym/4) +!$omp parallel do private(n,js,is,ix_prox,jy_prox) schedule(static) do n=1,4 js=(n-1)/2 is= n-1-js*2 @@ -397,6 +402,7 @@ module subroutine targup_loc(this) Fitargup_loc34(n)=nxm*(jy_prox-1)+ix_prox-1 enddo +!$omp end parallel do ! write(34,'(i5,a,4i5)') mype,' ---> ', !Fitargup_loc34(1),Fitargup_loc34(2),Fitargup_loc34(3),Fitargup_loc34(4) diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index eca1c8862..82a9eb5f5 100755 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -988,6 +988,7 @@ module subroutine filtering_fast_bkg(this) !*** Apply adjoint of Beta filter at all generations !*** call btim(hfiltT_tim) +!$omp parallel do private(i,k,lev1,lev2) schedule(static) do i=im,1,-1 do k=1,km3 lev1=(k-1)*lm+1 @@ -1005,11 +1006,13 @@ module subroutine filtering_fast_bkg(this) lev2=lev2+1 enddo enddo +!$omp end parallel do 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) +!$omp parallel do private(j,k,lev1,lev2) schedule(static) do j=jm,1,-1 do k=1,km3 lev1=(k-1)*lm+1 @@ -1027,12 +1030,14 @@ module subroutine filtering_fast_bkg(this) lev2=lev2+1 enddo enddo +!$omp end parallel do 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) +!$omp parallel do private(i,k,lev1,lev2) schedule(static) do i=im,1,-1 do k=1,km3 lev1=(k-1)*lm+1 @@ -1049,6 +1054,7 @@ module subroutine filtering_fast_bkg(this) lev2=lev2+1 enddo enddo +!$omp end parallel do call etim(hfiltT_tim) endif @@ -1057,6 +1063,7 @@ module subroutine filtering_fast_bkg(this) call etim(bocoT_tim) if(l_hgen) then call btim(hfiltT_tim) +!$omp parallel do private(j,k,lev1,lev2) schedule(static) do j=jm,1,-1 do k=1,km3 lev1=(k-1)*lm+1 @@ -1073,6 +1080,7 @@ module subroutine filtering_fast_bkg(this) lev2=lev2+1 enddo enddo +!$omp end parallel do call etim(hfiltT_tim) endif call btim(bocoT_tim) @@ -1091,6 +1099,7 @@ module subroutine filtering_fast_bkg(this) call this%bocox(VALL,km,im,jm,hx,hy) call etim(boco_tim) call btim(hfilt_tim) +!$omp parallel do private(j,k,lev1,lev2) schedule(static) do j=1,jm do k=1,km3 lev1=(k-1)*lm+1 @@ -1107,11 +1116,13 @@ module subroutine filtering_fast_bkg(this) lev2=lev2+1 enddo enddo +!$omp end parallel do 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) +!$omp parallel do private(i,k,lev1,lev2) schedule(static) do i=1,im do k=1,km3 lev1=(k-1)*lm+1 @@ -1129,12 +1140,14 @@ module subroutine filtering_fast_bkg(this) lev2=lev2+1 enddo enddo +!$omp end parallel do 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) +!$omp parallel do private(j,k,lev1,lev2) schedule(static) do j=1,jm do k=1,km3 lev1=(k-1)*lm+1 @@ -1151,6 +1164,7 @@ module subroutine filtering_fast_bkg(this) lev2=lev2+1 enddo enddo +!$omp end parallel do call etim(hfilt_tim) endif call btim(boco_tim) @@ -1158,6 +1172,7 @@ module subroutine filtering_fast_bkg(this) call etim(boco_tim) if(l_hgen) then call btim(hfilt_tim) +!$omp parallel do private(i,k,lev1,lev2) schedule(static) do i=1,im do k=1,km3 lev1=(k-1)*lm+1 @@ -1175,6 +1190,7 @@ module subroutine filtering_fast_bkg(this) lev2=lev2+1 enddo enddo +!$omp end parallel do call etim(hfilt_tim) endif !*** diff --git a/src/saber/mgbf/mgbf_lib/mg_generations.f90 b/src/saber/mgbf/mgbf_lib/mg_generations.f90 index 127c35afa..1d51b395d 100755 --- a/src/saber/mgbf/mgbf_lib/mg_generations.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_generations.f90 @@ -1079,17 +1079,22 @@ module subroutine weighting_helm & integer(i_kind):: i,j,l,k,imx,jmx !----------------------------------------------------------------------- +!$omp parallel do private(i,j) schedule(static) do j=1,this%jm do i=0,this%im DIFX(:,i,j)=V(:,i+1,j)-V(:,i,j) enddo enddo +!$omp end parallel do +!$omp parallel do private(i,j) schedule(static) do j=0,this%jm do i=1,this%im DIFY(:,i,j)=V(:,i,j+1)-V(:,i,j) enddo enddo +!$omp end parallel do +!$omp parallel do private(i,j) schedule(static) do j=1,this%jm do i=1,this%im V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j) & @@ -1097,6 +1102,7 @@ module subroutine weighting_helm & +DIFY(:,i,j)-DIFY(:,i,j-1)) enddo enddo +!$omp end parallel do if(this%l_hgen) then @@ -1106,17 +1112,22 @@ module subroutine weighting_helm & imx = this%im jmx = this%jm +!$omp parallel do private(i,j) schedule(static) do j=1,jmx do i=0,imx DIFXH(:,i,j)=H(:,i+1,j)-H(:,i,j) enddo enddo +!$omp end parallel do +!$omp parallel do private(i,j) schedule(static) do j=0,jmx do i=1,imx DIFYH(:,i,j)=H(:,i,j+1)-H(:,i,j) enddo enddo +!$omp end parallel do +!$omp parallel do private(i,j) schedule(static) do j=1,jmx do i=1,imx H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) & @@ -1124,6 +1135,7 @@ module subroutine weighting_helm & +DIFYH(:,i,j)-DIFYH(:,i,j-1)) enddo enddo +!$omp end parallel do endif @@ -1146,22 +1158,26 @@ module subroutine weighting & integer(i_kind):: i,j,l,k,imx,jmx !----------------------------------------------------------------------- +!$omp parallel do private(i,j) schedule(static) do j=1,this%jm do i=1,this%im V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j) enddo enddo +!$omp end parallel do if(this%l_hgen) then imx = this%im jmx = this%jm +!$omp parallel do private(i,j) schedule(static) do j=1,jmx do i=1,imx H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) enddo enddo +!$omp end parallel do endif diff --git a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 index f66da76e2..eb2d76092 100755 --- a/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_interpolate.f90 @@ -112,21 +112,29 @@ module subroutine lsqr_mg_coef (this) ! Initialize ! +!$omp parallel do private(n) schedule(static) do n=1,this%nm xa(n)=this%xa0+this%dxa*(n-1) enddo +!$omp end parallel do +!$omp parallel do private(i) schedule(static) do i=1-this%ib,this%im+this%ib xf(i)=this%xf0+this%dxf*(i-1) enddo +!$omp end parallel do +!$omp parallel do private(m) schedule(static) do m=1,this%mm ya(m)=this%ya0+this%dya*(m-1) enddo +!$omp end parallel do +!$omp parallel do private(j) schedule(static) do j=1-this%jb,this%jm+this%jb yf(j)=this%yf0+this%dyf*(j-1) enddo +!$omp end parallel do ! ! Find iref and jref @@ -153,6 +161,7 @@ module subroutine lsqr_mg_coef (this) enddo enddo +!$omp parallel do private(n,i,x1,x2,x3,x4,x,x1x,x2x,x3x,x4x,rx2x1,rx3x1,rx4x1,rx3x2,rx4x2,rx4x3,CFL1,CFL2,CFL3,CLL,CFR1,CFR2,CFR3,CRR) schedule(static) do n=1,this%nm i=this%iref(n) x1=xf(i) @@ -183,7 +192,9 @@ module subroutine lsqr_mg_coef (this) this%cx2(n)=CFL3*CLL+CFR2*CRR this%cx3(n)=CFR3*CRR enddo +!$omp end parallel do +!$omp parallel do private(m,j,y1,y2,y3,y4,y,y1y,y2y,y3y,y4y,ry2y1,ry3y1,ry4y1,ry3y2,ry4y2,ry4y3,CFL1,CFL2,CFL3,CLL,CFR1,CFR2,CFR3,CRR) schedule(static) do m=1,this%mm j=this%jref(m) y1=yf(j) @@ -214,10 +225,12 @@ module subroutine lsqr_mg_coef (this) this%cy2(m)=CFL3*CLL+CFR2*CRR this%cy3(m)=CFR3*CRR enddo +!$omp end parallel do ! ! Quadratic interpolations ! +!$omp parallel do private(n,i,x1,x2,x3,x,x1_x,x2_x,x3_x,rx2x1,rx3x1,rx3x2) schedule(static) do n=1,this%nm i=this%irefq(n) x1=xf(i) @@ -234,7 +247,9 @@ module subroutine lsqr_mg_coef (this) this%qx1(n) =-x1_x*x3_x*rx2x1*rx3x2 this%qx2(n) = x1_x*x2_x*rx3x1*rx3x2 enddo +!$omp end parallel do +!$omp parallel do private(m,i,y1,y2,y3,y,y1_y,y2_y,y3_y,ry2y1,ry3y1,ry3y2) schedule(static) do m=1,this%mm i=this%jrefq(m) y1=yf(i) @@ -251,10 +266,12 @@ module subroutine lsqr_mg_coef (this) this%qy1(m) =-y1_y*y3_y*ry2y1*ry3y2 this%qy2(m) = y1_y*y2_y*ry3y1*ry3y2 enddo +!$omp end parallel do ! ! Linear interpolations ! +!$omp parallel do private(n,i,x1,x2,x,x1_x,x2_x,rx2x1) schedule(static) do n=1,this%nm i=this%irefL(n) x1=xf(i) @@ -266,7 +283,9 @@ module subroutine lsqr_mg_coef (this) this%Lx0(n) = x2_x*rx2x1 this%Lx1(n) =-x1_x*rx2x1 enddo +!$omp end parallel do +!$omp parallel do private(m,j,y1,y2,y,y1_y,y2_y,ry2y1) schedule(static) do m=1,this%mm j=this%jrefL(m) y1=yf(j) @@ -278,6 +297,7 @@ module subroutine lsqr_mg_coef (this) this%Ly0(m) = y2_y*ry2y1 this%Ly1(m) =-y1_y*ry2y1 enddo +!$omp end parallel do !----------------------------------------------------------------------- endsubroutine lsqr_mg_coef @@ -308,16 +328,21 @@ module subroutine lwq_vertical_coef & integer(i_kind):: i,n !----------------------------------------------------------------------- +!$omp parallel do private(i) schedule(static) do i=0,im_in+1 x(i)=(i-1)*1. enddo +!$omp end parallel do dy = 1.*(im_in-1)/(nm_in-1) +!$omp parallel do private(n) schedule(static) do n=1,nm_in y(n)=(n-1)*dy enddo +!$omp end parallel do y(nm_in)=x(im_in) +!$omp parallel do private(n,i,x1,x2,x3,x4,dx1,dx2,dx3,dx4,dx13,dx23,dx24) schedule(static) do n=2,nm_in-1 i = y(n)+1 x1 = x(i-1) @@ -346,6 +371,7 @@ module subroutine lwq_vertical_coef & c4(n)=0. endif enddo +!$omp end parallel do 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(nm_in)=0. diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 6ae6c5e93..6cc8b3904 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1530,6 +1530,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) #endif endif +!$omp parallel do private(i,j) schedule(static) do j=1,this%jm do i=1,this%im this%pasp2(1,1,i,j)=this%pasp02*(1.+this%p_del(i,j)) @@ -1538,7 +1539,9 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) this%pasp2(2,1,i,j)=this%pasp02*this%p_eps(i,j) end do end do +!$omp end parallel do +!$omp parallel do private(i,j,l) schedule(static) do L=1,this%lm do j=1,this%jm do i=1,this%im @@ -1556,6 +1559,7 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) end do +!$omp end parallel do !cltorg if(.not.this%mgbf_line) then diff --git a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 index c2bdaf72f..86be6dfee 100755 --- a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 @@ -115,9 +115,11 @@ module subroutine init_mg_MPI(this) ! ! Create a new group out of exising group ! +!$omp parallel do private(nf) schedule(static) do nf = 1,npes_filt out_ranks(nf)=nf-1 enddo +!$omp end parallel do call MPI_GROUP_INCL(group_world,npes_filt,out_ranks,group_work,ierr) ! @@ -187,4 +189,3 @@ module subroutine finishMPI(this) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ end submodule mg_mppstuff - diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index 396d0d196..dc8c0a83b 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -960,9 +960,11 @@ subroutine init_mg_parameter(this,inputfilename) write(6,*)'thinkdeb999 2 9 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid call flush(6) +!$omp parallel do private(g) schedule(static) do g=1,this%gm this%nxy(g)=this%ixm(g)*this%jym(g) enddo +!$omp end parallel do this%maxpe_fgen(0)= 0 do g=1,this%gm @@ -982,15 +984,19 @@ subroutine init_mg_parameter(this,inputfilename) this%jm0(g)=this%jm0(g-1)/2 enddo +!$omp parallel do private(g) schedule(static) 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 +!$omp end parallel do +!$omp parallel do private(g) schedule(static) do g=1,this%gm this%FimaxL(g)=this%Fimax(g)/2 this%FjmaxL(g)=this%Fjmax(g)/2 enddo +!$omp end parallel do !*** !*** Filter related parameters diff --git a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 index 039d55f7c..e57493a32 100755 --- a/src/saber/mgbf/mgbf_lib/mg_transfer.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_transfer.f90 @@ -138,18 +138,22 @@ module subroutine anal_to_filt_all(this,WORKA) else !clttothink +!$omp parallel do private(L) schedule(static) do L=1,lm F3D(:,:,:,L)=A3D(:,:,:,L) enddo +!$omp end parallel do endif call this%C2S_ens(F3D,WORK,1,nm,1,mm,lm,km,km_all) endif !2.gt.3 if(lm_a>lm) then +!$omp parallel do private(ivar) schedule(static) do ivar=1,this%km2 !2dvar is directly passed work(this%km_all-ivar+1,:,:)=worka(this%km_all-ivar+1,:,:) enddo +!$omp end parallel do do ivar=1,this%km3 lev1_a=1+(ivar-1)*this%lm_a @@ -204,9 +208,11 @@ module subroutine filt_to_anal_all(this,WORKA) allocate(WORK(km_all,1:nm,1:mm)) call this%filt_to_anal(WORK) !cltadded if(lm_a>lm) then +!$omp parallel do private(ivar) schedule(static) do ivar=1,this%km2 !2dvar is directly passed worka(this%km_a_all-ivar+1,:,:)=work(this%km_all-ivar+1,:,:) enddo +!$omp end parallel do do ivar=1,this%km3 lev1_a=1+(ivar-1)*this%lm_a diff --git a/src/saber/mgbf/mgbf_lib/phint1.f90 b/src/saber/mgbf/mgbf_lib/phint1.f90 index 2cf6dd850..e5f11df62 100644 --- a/src/saber/mgbf/mgbf_lib/phint1.f90 +++ b/src/saber/mgbf/mgbf_lib/phint1.f90 @@ -85,15 +85,19 @@ subroutine make_ssf(nz,nf,sigofz,ssofzf)! [make_ssf] !============================================================================= nzf=nz*nf dzf=u1/nf +!$omp parallel do private(izf) schedule(static) do izf=0,nzf zofzf(izf)=izf*dzf enddo +!$omp end parallel do call logintgrid(nz,nzf,zofzf,u1/sigofz, sigiofzf) ! Integrate sigiofzf s=0; ssofzf(0)=s +!$omp parallel do private(izf) schedule(static) do izf=1,nzf s=s+sigiofzf(izf-1)+sigiofzf(izf); ssofzf(izf)=s enddo +!$omp end parallel do ssofzf=ssofzf*dzf*o2 end subroutine make_ssf @@ -942,4 +946,3 @@ end subroutine intgrid_f2a_3d_ad_top2bot end module phint1 !# - From 331a710a23e8bddedd04ab6b16610321de6e9458 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 15:35:34 +0000 Subject: [PATCH 165/199] WIP: optimization --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 3 +-- src/saber/mgbf/mgbf_lib/mg_filtering.f90 | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index f563313f0..bd31000b9 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -275,7 +275,7 @@ subroutine create(self, comm, config, funcspace, background, firstguess) allocate(self%work_mgbf(self%total_km_a_all, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) allocate(self%work2d_mgbf(self%total_km_a_all, self%intstate(1,1)%nm * self%intstate(1,1)%mm)) allocate(self%rnormalization(self%total_km_a_all, nvargrp)) - self%rnormalization(self%total_km_a_all, nvargrp)=0.0 + self%rnormalization(1:self%total_km_a_all,1:nvargrp)=0.0 allocate(self%work1var_mgbf(nz3d, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) @@ -472,7 +472,6 @@ subroutine multiply(self, fields,index_member_in) size(rnormalization,2) /= nvargrp) then error stop "MGBF workspace rnormalization too small for current scale" endif - work2d_mgbf = 0.0 work1var_mgbf=0 if(self%l_multiply_first_call) then !$omp parallel do private(ivargrp,ii,k) schedule(static) diff --git a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 index 82a9eb5f5..04d2ef017 100755 --- a/src/saber/mgbf/mgbf_lib/mg_filtering.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_filtering.f90 @@ -1111,7 +1111,7 @@ module subroutine filtering_fast_bkg(this) do k=1,km2 lev1=lev2+1 lev2=lev1 - call this%rbetaT(1,hx,1,im,this%paspx4d(lm:lm,1:im,j,1),this%ssx4d(lm:lm,1:im,j,1),VALL(lev1:lev2,:,j)) + call this%rbeta(1,hx,1,im,this%paspx4d(lm:lm,1:im,j,1),this%ssx4d(lm:lm,1:im,j,1),VALL(lev1:lev2,:,j)) lev1=lev1+1 lev2=lev2+1 enddo From 548429f5d17eb8d1856b21b1f619ef06dd43b520 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 17:13:21 +0000 Subject: [PATCH 166/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 67 +++++++++++++------ 1 file changed, 48 insertions(+), 19 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index bd31000b9..6206402b5 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -38,6 +38,7 @@ module mgbf_covariance_mod public mgbf_covariance ! Fortran class header +integer(kind=i_kind),parameter:: max_scales=100 type :: mgbf_covariance type(mg_intstate_type),allocatable :: intstate(:,:) integer :: nscale=1 @@ -59,11 +60,13 @@ module mgbf_covariance_mod real(kind=r_kind), pointer:: work1var_mgbf(:,:,:) real(kind=r_kind), pointer :: work2d_mgbf(:,:) real(kind=r_kind), pointer :: rnormalization(:,:) + real(kind=r_kind), pointer :: vargrp_work_mgbf(:,:,:) + real(kind=r_kind), pointer :: vargrp_work_mgbf2(:,:,:) integer(kind=i_kind), pointer :: nlev_vargrp(:) integer(kind=i_kind), pointer :: varvlev_index(:,:) integer(kind=i_kind) :: total_km_a_all = 0 integer(kind=i_kind) :: nvar = 0 - logical:: l_multiply_first_call=.true. + logical:: l_multiply_first_call(max_scales)=.true. contains procedure, public :: create @@ -109,9 +112,6 @@ subroutine create(self, comm, config, funcspace, background, firstguess) real(r_kind), allocatable :: lonlat_anl(:,:) integer :: npts_owned integer :: npts_total -integer :: max_nm -integer :: max_mm -integer :: max_nz3d @@ -120,10 +120,11 @@ subroutine create(self, comm, config, funcspace, background, firstguess) real :: readin_multigrp_cor(99)=1.0 integer :: readin_iscalegroup(99)=999 integer :: readin_ivargroup(99)=999 -integer ::i,j, ii,nz3d +integer ::i,j,k, ii,nz3d namelist /parameters_mgbf_init/ nscale,nvargrp,readin_mgbf_nml_group ,readin_multigrp_cor,readin_iscalegroup,readin_ivargroup character(len=:), allocatable :: dump_json +integer(i_kind):: max_nlevs ! Hold communicator ! ----------------- @@ -276,12 +277,41 @@ subroutine create(self, comm, config, funcspace, background, firstguess) allocate(self%work2d_mgbf(self%total_km_a_all, self%intstate(1,1)%nm * self%intstate(1,1)%mm)) allocate(self%rnormalization(self%total_km_a_all, nvargrp)) self%rnormalization(1:self%total_km_a_all,1:nvargrp)=0.0 + allocate(self%varvlev_index(self%nvar,3)) + allocate(self%nlev_vargrp(nvargrp)) +! Note, for different scales, they should have the sma esetup (using the same "zero level" filtering grids from the atlas ) +!$omp parallel do private(ivargrp,ii,k) schedule(static) + do ivargrp=1,nvargrp + ii=1 + !clt if for localization , km2=0 + do k=1,self%intstate(1,ivargrp)%km3 + self%rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(1,ivargrp)%coef_normalization(1:nz3d) + ii=ii+nz3d + + enddo + do k=1,self%intstate(1,ivargrp)%km2 + !clt if for localization , km2=0 only for + !clt only for l_2dvar_last_vertical_lev + self%rnormalization(ii,ivargrp)=self%intstate(1,ivargrp)%coef_normalization(nz3d) + ii=ii+1 + enddo + self%nlev_vargrp(ivargrp)=self%intstate(1,ivargrp)%km_a_all + if (any(self%rnormalization(1:self%nlev_vargrp(ivargrp), ivargrp) == 0.0_r_kind)) then + write(6,*) 'DBG zero normalization in group', ivargrp, & + ' nlev=', self%nlev_vargrp(ivargrp), ' rank=', self%rank + endif + enddo +!$omp end parallel do + max_nlevs=1 + do ivargrp=1,nvargrp + max_nlevs=max(max_nlevs,self%nlev_vargrp(ivargrp)) + enddo + allocate(self%vargrp_work_mgbf(max_nlevs, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) + allocate(self%vargrp_work_mgbf2(max_nlevs, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) allocate(self%work1var_mgbf(nz3d, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) - allocate(self%nlev_vargrp(nvargrp)) - allocate(self%varvlev_index(self%nvar,3)) @@ -314,6 +344,7 @@ subroutine delete(self) if (associated(self%rnormalization)) deallocate(self%rnormalization) if (associated(self%nlev_vargrp)) deallocate(self%nlev_vargrp) if (associated(self%varvlev_index)) deallocate(self%varvlev_index) + deallocate(self%vargrp_work_mgbf,self%vargrp_work_mgbf2) ! Delete the grid ! --------------- @@ -386,8 +417,8 @@ subroutine multiply(self, fields,index_member_in) real(kind=r_kind), pointer :: ptr_3d(:,:,:) integer(kind=i_kind):: nz,ilev,isize real(kind=r_kind), pointer :: work_mgbf(:,:,:) -real(kind=r_kind), allocatable :: vargrp_work_mgbf(:,:,:) -real(kind=r_kind), allocatable :: vargrp_work_mgbf2(:,:,:) +real(kind=r_kind), pointer :: vargrp_work_mgbf(:,:,:) +real(kind=r_kind), pointer :: vargrp_work_mgbf2(:,:,:) real(kind=r_kind), pointer :: work1var_mgbf(:,:,:) real(kind=r_kind), pointer :: work2d_mgbf(:,:) real(kind=r_kind), pointer :: rnormalization(:,:) @@ -443,6 +474,8 @@ subroutine multiply(self, fields,index_member_in) work2d_mgbf => self%work2d_mgbf work1var_mgbf => self%work1var_mgbf rnormalization => self%rnormalization + vargrp_work_mgbf=> self%vargrp_work_mgbf + vargrp_work_mgbf2=> self%vargrp_work_mgbf2 nlev_vargrp => self%nlev_vargrp @@ -473,7 +506,7 @@ subroutine multiply(self, fields,index_member_in) error stop "MGBF workspace rnormalization too small for current scale" endif work1var_mgbf=0 - if(self%l_multiply_first_call) then + if(self%l_multiply_first_call(jscale)) then !$omp parallel do private(ivargrp,ii,k) schedule(static) do ivargrp=1,nvargrp ii=1 @@ -511,7 +544,7 @@ subroutine multiply(self, fields,index_member_in) stop endif varvlev_index => self%varvlev_index - if (self%l_multiply_first_call) varvlev_index = 0 + if (self%l_multiply_first_call(jscale)) varvlev_index = 0 ilev=1 do isize=1,fields%size() @@ -593,7 +626,7 @@ subroutine multiply(self, fields,index_member_in) error stop ("2dvariable is not put in the ending stop.") ! is required 2d fields are saved consecutively,and at the ending endif endif - if(self%l_multiply_first_call) then + if(self%l_multiply_first_call(jscale)) then if(isize==1) then varvlev_index(isize,1)= 1 !cltothink if(.not.self%intstate(iscale,ivargrp)%l_for_localization )then @@ -640,9 +673,7 @@ subroutine multiply(self, fields,index_member_in) call etim(mg_preprocess_time) ii=1 do ivargrp=1,nvargrp - allocate(vargrp_work_mgbf(nlev_vargrp(ivargrp),nxloc,nyloc)) - allocate(vargrp_work_mgbf2(nlev_vargrp(ivargrp),nxloc,nyloc)) - vargrp_work_mgbf(:,:,:) = work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) + vargrp_work_mgbf(1:nlev_vargrp(ivargrp),:,:) = work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) call btim(mg_anal_to_filt_time) @@ -664,10 +695,8 @@ subroutine multiply(self, fields,index_member_in) vargrp_work_mgbf2(k,:,:) = vargrp_work_mgbf2(k,:,:) / rnormalization(k,ivargrp) enddo !$omp end parallel do - work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) = vargrp_work_mgbf2(:,:,:) + work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) = vargrp_work_mgbf2(1:nlev_vargrp(ivargrp),:,:) ii=ii+nlev_vargrp(ivargrp) - deallocate(vargrp_work_mgbf) - deallocate(vargrp_work_mgbf2) enddo ! ivargrp if(self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx work1var_mgbf = 0.0 @@ -792,7 +821,7 @@ subroutine multiply(self, fields,index_member_in) !clt enddo !for iscale call etim(mg_multiply_time) nullify(nlev_vargrp) - self%l_multiply_first_call=.false. + self%l_multiply_first_call(jscale)=.false. end subroutine multiply From 1947179d68781783711b4ebeab6a518347951cf8 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 19:53:51 +0000 Subject: [PATCH 167/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 46 ++++++++++--------- 1 file changed, 24 insertions(+), 22 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 6206402b5..8f0a48177 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -280,28 +280,6 @@ subroutine create(self, comm, config, funcspace, background, firstguess) allocate(self%varvlev_index(self%nvar,3)) allocate(self%nlev_vargrp(nvargrp)) ! Note, for different scales, they should have the sma esetup (using the same "zero level" filtering grids from the atlas ) -!$omp parallel do private(ivargrp,ii,k) schedule(static) - do ivargrp=1,nvargrp - ii=1 - !clt if for localization , km2=0 - do k=1,self%intstate(1,ivargrp)%km3 - self%rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(1,ivargrp)%coef_normalization(1:nz3d) - ii=ii+nz3d - - enddo - do k=1,self%intstate(1,ivargrp)%km2 - !clt if for localization , km2=0 only for - !clt only for l_2dvar_last_vertical_lev - self%rnormalization(ii,ivargrp)=self%intstate(1,ivargrp)%coef_normalization(nz3d) - ii=ii+1 - enddo - self%nlev_vargrp(ivargrp)=self%intstate(1,ivargrp)%km_a_all - if (any(self%rnormalization(1:self%nlev_vargrp(ivargrp), ivargrp) == 0.0_r_kind)) then - write(6,*) 'DBG zero normalization in group', ivargrp, & - ' nlev=', self%nlev_vargrp(ivargrp), ' rank=', self%rank - endif - enddo -!$omp end parallel do max_nlevs=1 do ivargrp=1,nvargrp max_nlevs=max(max_nlevs,self%nlev_vargrp(ivargrp)) @@ -478,7 +456,31 @@ subroutine multiply(self, fields,index_member_in) vargrp_work_mgbf2=> self%vargrp_work_mgbf2 nlev_vargrp => self%nlev_vargrp + + if(self%l_multiply_first_call(jscale)) then +!$omp parallel do private(ivargrp,ii,k) schedule(static) + do ivargrp=1,nvargrp + ii=1 + !clt if for localization , km2=0 + do k=1,self%intstate(1,ivargrp)%km3 + rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) + ii=ii+nz3d + + enddo + do k=1,self%intstate(jscale,ivargrp)%km2 + !clt if for localization , km2=0 only for + !clt only for l_2dvar_last_vertical_lev + rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) + ii=ii+1 + enddo + self%nlev_vargrp(ivargrp)=self%intstate(1,ivargrp)%km_a_all + if (any(rnormalization(1:self%nlev_vargrp(ivargrp), ivargrp) == 0.0_r_kind)) then + write(6,*) 'DBG zero normalization in group', ivargrp, & + ' nlev=', self%nlev_vargrp(ivargrp), ' rank=', self%rank + endif + enddo + endif !clt do iscale=1,self%nscale nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps From 59421a5ed3446ab4dfef0bc91a1ce2313ef6caaf Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 20:10:33 +0000 Subject: [PATCH 168/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 8f0a48177..decda90a1 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -676,10 +676,10 @@ subroutine multiply(self, fields,index_member_in) ii=1 do ivargrp=1,nvargrp vargrp_work_mgbf(1:nlev_vargrp(ivargrp),:,:) = work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) - call btim(mg_anal_to_filt_time) - call self%intstate(jscale,ivargrp)%anal_to_filt_allmap(vargrp_work_mgbf) + call self%intstate(jscale,ivargrp)%anal_to_filt_allmap \ + (vargrp_work_mgbf(1:nlev_vargrp(ivargrp),:,:)) call etim(mg_anal_to_filt_time) call btim(mg_filtering_time) call self%intstate(jscale,ivargrp)%filtering_procedure(self%intstate(jscale,ivargrp)%mgbf_proc,1) @@ -687,7 +687,8 @@ subroutine multiply(self, fields,index_member_in) !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) call btim(mg_filt_to_anal_time) - call self%intstate(jscale,ivargrp)%filt_to_anal_allmap(vargrp_work_mgbf2) + call self%intstate(jscale,ivargrp)%filt_to_anal_allmap \ + (vargrp_work_mgbf2(1:nlev_vargrp(ivargrp),:,:)) call etim(mg_filt_to_anal_time) !clt# work_mgbf=999.0 !thinkdeb for debug From 37463826a642f4b6a6a669798a5ef8517f0da236 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 23:09:11 +0000 Subject: [PATCH 169/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 35 ++++--------------- 1 file changed, 7 insertions(+), 28 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index decda90a1..da6ae8539 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -59,7 +59,7 @@ module mgbf_covariance_mod real(kind=r_kind), pointer :: work_mgbf(:,:,:) real(kind=r_kind), pointer:: work1var_mgbf(:,:,:) real(kind=r_kind), pointer :: work2d_mgbf(:,:) - real(kind=r_kind), pointer :: rnormalization(:,:) + real(kind=r_kind), pointer :: rnormalization(:,:,:) real(kind=r_kind), pointer :: vargrp_work_mgbf(:,:,:) real(kind=r_kind), pointer :: vargrp_work_mgbf2(:,:,:) integer(kind=i_kind), pointer :: nlev_vargrp(:) @@ -275,10 +275,13 @@ subroutine create(self, comm, config, funcspace, background, firstguess) allocate(self%work_mgbf(self%total_km_a_all, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) allocate(self%work2d_mgbf(self%total_km_a_all, self%intstate(1,1)%nm * self%intstate(1,1)%mm)) - allocate(self%rnormalization(self%total_km_a_all, nvargrp)) - self%rnormalization(1:self%total_km_a_all,1:nvargrp)=0.0 + allocate(self%rnormalization(self%total_km_a_all, nvargrp,nscale)) + self%rnormalization(1:self%total_km_a_all,1:nvargrp,1:nscale)=0.0 allocate(self%varvlev_index(self%nvar,3)) allocate(self%nlev_vargrp(nvargrp)) + do ivargrp=1,nvargrp + self%nlev_vargrp(ivargrp)=self%intstate(1,ivargrp)%km_a_all + enddo ! Note, for different scales, they should have the sma esetup (using the same "zero level" filtering grids from the atlas ) max_nlevs=1 do ivargrp=1,nvargrp @@ -451,36 +454,12 @@ subroutine multiply(self, fields,index_member_in) work_mgbf => self%work_mgbf work2d_mgbf => self%work2d_mgbf work1var_mgbf => self%work1var_mgbf - rnormalization => self%rnormalization + rnormalization => self%rnormalization(:,:,jscale) vargrp_work_mgbf=> self%vargrp_work_mgbf vargrp_work_mgbf2=> self%vargrp_work_mgbf2 nlev_vargrp => self%nlev_vargrp - if(self%l_multiply_first_call(jscale)) then -!$omp parallel do private(ivargrp,ii,k) schedule(static) - do ivargrp=1,nvargrp - ii=1 - !clt if for localization , km2=0 - do k=1,self%intstate(1,ivargrp)%km3 - rnormalization(ii:ii+nz3d-1,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(1:nz3d) - ii=ii+nz3d - - enddo - do k=1,self%intstate(jscale,ivargrp)%km2 - !clt if for localization , km2=0 only for - !clt only for l_2dvar_last_vertical_lev - rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) - ii=ii+1 - enddo - self%nlev_vargrp(ivargrp)=self%intstate(1,ivargrp)%km_a_all - if (any(rnormalization(1:self%nlev_vargrp(ivargrp), ivargrp) == 0.0_r_kind)) then - write(6,*) 'DBG zero normalization in group', ivargrp, & - ' nlev=', self%nlev_vargrp(ivargrp), ' rank=', self%rank - endif - enddo - - endif !clt do iscale=1,self%nscale nz3d=self%intstate(jscale,1)%lm_a !should be the same for different vargrps From 5f68edcfc9f0f66ca8d23becafd048d1c48adea6 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 23:43:24 +0000 Subject: [PATCH 170/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 27 ++++++++++--------- 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index da6ae8539..2f2099cc4 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -62,8 +62,8 @@ module mgbf_covariance_mod real(kind=r_kind), pointer :: rnormalization(:,:,:) real(kind=r_kind), pointer :: vargrp_work_mgbf(:,:,:) real(kind=r_kind), pointer :: vargrp_work_mgbf2(:,:,:) - integer(kind=i_kind), pointer :: nlev_vargrp(:) - integer(kind=i_kind), pointer :: varvlev_index(:,:) + integer(kind=i_kind), pointer :: nlev_vargrp(:,:) + integer(kind=i_kind), pointer :: varvlev_index(:,:,:) integer(kind=i_kind) :: total_km_a_all = 0 integer(kind=i_kind) :: nvar = 0 logical:: l_multiply_first_call(max_scales)=.true. @@ -277,15 +277,19 @@ subroutine create(self, comm, config, funcspace, background, firstguess) allocate(self%work2d_mgbf(self%total_km_a_all, self%intstate(1,1)%nm * self%intstate(1,1)%mm)) allocate(self%rnormalization(self%total_km_a_all, nvargrp,nscale)) self%rnormalization(1:self%total_km_a_all,1:nvargrp,1:nscale)=0.0 - allocate(self%varvlev_index(self%nvar,3)) - allocate(self%nlev_vargrp(nvargrp)) + allocate(self%varvlev_index(self%nvar,3,nscale)) + allocate(self%nlev_vargrp(nvargrp,nscale)) + do iscale=1,nscale do ivargrp=1,nvargrp - self%nlev_vargrp(ivargrp)=self%intstate(1,ivargrp)%km_a_all + self%nlev_vargrp(ivargrp,iscale)=self%intstate(iscale,ivargrp)%km_a_all + enddo enddo ! Note, for different scales, they should have the sma esetup (using the same "zero level" filtering grids from the atlas ) max_nlevs=1 + do iscale=1,nscale do ivargrp=1,nvargrp - max_nlevs=max(max_nlevs,self%nlev_vargrp(ivargrp)) + max_nlevs=max(max_nlevs,self%nlev_vargrp(ivargrp,iscale)) + enddo enddo allocate(self%vargrp_work_mgbf(max_nlevs, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) allocate(self%vargrp_work_mgbf2(max_nlevs, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) @@ -445,10 +449,11 @@ subroutine multiply(self, fields,index_member_in) endif myrank=self%rank write(str_rank,"(I4.4)")myrank - if (.not. associated(self%nlev_vargrp)) then + nlev_vargrp=>self%nlev_vargrp(:,jscale) + if (.not. associated(nlev_vargrp)) then error stop "MGBF workspace nlev_vargrp not allocated" endif - if (size(self%nlev_vargrp) < nvargrp) then + if (size(nlev_vargrp) < nvargrp) then error stop "MGBF workspace nlev_vargrp too small for nvargrp" endif work_mgbf => self%work_mgbf @@ -458,7 +463,6 @@ subroutine multiply(self, fields,index_member_in) vargrp_work_mgbf=> self%vargrp_work_mgbf vargrp_work_mgbf2=> self%vargrp_work_mgbf2 - nlev_vargrp => self%nlev_vargrp !clt do iscale=1,self%nscale @@ -503,7 +507,6 @@ subroutine multiply(self, fields,index_member_in) rnormalization(ii,ivargrp)=self%intstate(jscale,ivargrp)%coef_normalization(nz3d) ii=ii+1 enddo - nlev_vargrp(ivargrp)=self%intstate(jscale,ivargrp)%km_a_all if (any(rnormalization(1:nlev_vargrp(ivargrp), ivargrp) == 0.0_r_kind)) then write(6,*) 'DBG zero normalization in group', ivargrp, & ' nlev=', nlev_vargrp(ivargrp), ' jscale=', jscale, ' rank=', self%rank @@ -524,7 +527,7 @@ subroutine multiply(self, fields,index_member_in) call flush(6) stop endif - varvlev_index => self%varvlev_index + varvlev_index => self%varvlev_index(:,:,jscale) if (self%l_multiply_first_call(jscale)) varvlev_index = 0 ilev=1 @@ -811,7 +814,7 @@ end subroutine multiply subroutine multiply_ad(self, fields) -! Arguments +! Arguments(:,:,jscale) class(mgbf_covariance), intent(inout) :: self type(atlas_fieldset), intent(inout) :: fields From ca8ca513d8683a96c2b6e7ad93531ca64411da85 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 23:54:18 +0000 Subject: [PATCH 171/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 2f2099cc4..f2bec377b 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -449,10 +449,10 @@ subroutine multiply(self, fields,index_member_in) endif myrank=self%rank write(str_rank,"(I4.4)")myrank - nlev_vargrp=>self%nlev_vargrp(:,jscale) - if (.not. associated(nlev_vargrp)) then + if (.not. associated(self%nlev_vargrp)) then error stop "MGBF workspace nlev_vargrp not allocated" endif + nlev_vargrp=>self%nlev_vargrp(:,jscale) if (size(nlev_vargrp) < nvargrp) then error stop "MGBF workspace nlev_vargrp too small for nvargrp" endif From 9a98a3f2ffac70194d6e0f39b5dca9b5c785dd86 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sun, 8 Feb 2026 01:12:28 +0000 Subject: [PATCH 172/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 1 - src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index f2bec377b..53f87540c 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -814,7 +814,6 @@ end subroutine multiply subroutine multiply_ad(self, fields) -! Arguments(:,:,jscale) class(mgbf_covariance), intent(inout) :: self type(atlas_fieldset), intent(inout) :: fields diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index c6ed2d5a7..52112f6d6 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -2105,8 +2105,8 @@ module subroutine boco_3d_gh & 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 ) + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) end if From eefc17b763fd6e33fb90a29759ff4420ba1e5983 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 20:22:52 -0500 Subject: [PATCH 173/199] WIP --- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 144 +++++++++++++++++++++------ 1 file changed, 115 insertions(+), 29 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index 52112f6d6..cde2b3015 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -229,7 +229,6 @@ module subroutine boco_2d_g1 & 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 @@ -241,10 +240,18 @@ module subroutine boco_2d_g1 & 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 ! +! Make sure receives are complete before using rBuf_N / rBuf_S +! + if( itarg_n >= 0 ) then + call MPI_WAIT( rHandle(1), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( rHandle(3), istat, ierr ) + end if +! ! Assign received values from NORTH and SOUTH ! ! From SOUTH @@ -349,7 +356,6 @@ module subroutine boco_2d_g1 & 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 @@ -361,10 +367,16 @@ module subroutine boco_2d_g1 & 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 +! Make sure receives are complete before using rBuf_E / rBuf_W + if( itarg_e >= 0 ) then + call MPI_WAIT( rHandle(2), istat, ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( rHandle(4), istat, ierr ) + end if ! ! Assign received values from EAST and WEST @@ -594,7 +606,6 @@ module subroutine boco_2d_gh & 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 @@ -606,10 +617,17 @@ module subroutine boco_2d_gh & 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 +! Make sure receives are complete before using rBuf_N / rBuf_S + if( itarg_n >= 0 ) then + call MPI_WAIT( rHandle(1), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( rHandle(3), istat, ierr ) + end if + ! ! Assign received values from NORTH and SOUTH ! @@ -708,7 +726,6 @@ module subroutine boco_2d_gh & 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 @@ -720,10 +737,17 @@ module subroutine boco_2d_gh & 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 +! Make sure receives are complete before using rBuf_E / rBuf_W + if( itarg_e >= 0 ) then + call MPI_WAIT( rHandle(2), istat, ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( rHandle(4), istat, ierr ) + end if + ! ! Assign received values from WEST and EAST ! @@ -936,7 +960,6 @@ module subroutine bocoT_2d_g1 & 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 @@ -946,14 +969,21 @@ module subroutine bocoT_2d_g1 & if( itarg_w >= 0 ) then nebpe = itarg_w - allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + 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 +! Make sure receives are complete before using rBuf_W / rBuf_E + if( itarg_e >= 0 ) then + call MPI_WAIT( rHandle(2), istat, ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( rHandle(4), istat, ierr ) + end if + ! ! Assign received halos from WEST and EAST to interrior of domains ! @@ -1042,7 +1072,6 @@ module subroutine bocoT_2d_g1 & 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 @@ -1055,11 +1084,18 @@ module subroutine bocoT_2d_g1 & 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 +! Make sure receives are complete before using rBuf_S / rBuf_N + if( itarg_n >= 0 ) then + call MPI_WAIT( rHandle(1), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( rHandle(3), istat, ierr ) + end if + ! ! ASSIGN received values from SOUTH and NORTH ! @@ -1267,7 +1303,6 @@ module subroutine bocoT_2d_gh & 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 @@ -1279,10 +1314,18 @@ module subroutine bocoT_2d_gh & 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 ! +! Make sure receives are complete before using rBuf_W / rBuf_E +! + if( itarg_e >= 0 ) then + call MPI_WAIT( rHandle(2), istat, ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( rHandle(4), istat, ierr ) + end if +! ! Assign received values from WEST and EAST ! @@ -1369,7 +1412,6 @@ module subroutine bocoT_2d_gh & 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 @@ -1382,11 +1424,18 @@ module subroutine bocoT_2d_gh & 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 +! Make sure receives are complete before using rBuf_S / rBuf_N + if( itarg_n >= 0 ) then + call MPI_WAIT( rHandle(1), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( rHandle(3), istat, ierr ) + end if + ! ! Assign received values from SOUTH and NORTH ! @@ -1949,7 +1998,6 @@ module subroutine boco_3d_gh & 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 @@ -1961,7 +2009,6 @@ module subroutine boco_3d_gh & 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 @@ -1976,6 +2023,14 @@ module subroutine boco_3d_gh & end if !TEST +! Make sure receives are complete before using or deallocating rBuf_* + if( itarg_n >= 0 ) then + call MPI_WAIT( rHandle(1), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( rHandle(3), istat, ierr ) + end if + ! ! Assign received values from NORTH and SOUTH ! @@ -2094,7 +2149,6 @@ module subroutine boco_3d_gh & 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 @@ -2106,7 +2160,6 @@ module subroutine boco_3d_gh & 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(4), irecv) - call MPI_WAIT( rHandle(4), istat, ierr ) end if @@ -2122,6 +2175,14 @@ module subroutine boco_3d_gh & deallocate( sBuf_W, stat = ierr ) end if +! Make sure receives are complete before using or deallocating rBuf_* + if( itarg_e >= 0 ) then + call MPI_WAIT( rHandle(2), istat, ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( rHandle(4), istat, ierr ) + end if + ! ! Assign received values from WEST and EAST ! @@ -2327,7 +2388,6 @@ module subroutine bocoT_3d_g1 & 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 @@ -2340,11 +2400,19 @@ module subroutine bocoT_3d_g1 & 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 ! +! Make sure receives are complete before using rBuf_W / rBuf_E +! + if( itarg_e >= 0 ) then + call MPI_WAIT( rHandle(2), istat, ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( rHandle(4), istat, ierr ) + end if +! ! Assign received extended halos from WEST and EAST to interior of domains ! @@ -2444,7 +2512,6 @@ module subroutine bocoT_3d_g1 & 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 @@ -2457,11 +2524,18 @@ module subroutine bocoT_3d_g1 & 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 +! Make sure receives are complete before using rBuf_S / rBuf_N + if( itarg_n >= 0 ) then + call MPI_WAIT( rHandle(1), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( rHandle(3), istat, ierr ) + end if + ! ! Assign received values from SOUTH and NORTH ! @@ -2706,7 +2780,6 @@ module subroutine bocoT_3d_gh & 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 @@ -2719,11 +2792,18 @@ module subroutine bocoT_3d_gh & 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 +! Make sure receives are complete before using rBuf_W / rBuf_E + if( itarg_e >= 0 ) then + call MPI_WAIT( rHandle(2), istat, ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( rHandle(4), istat, ierr ) + end if + ! ! Assign received extended halos from WEST and EAST ! @@ -2824,7 +2904,6 @@ module subroutine bocoT_3d_gh & 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 @@ -2837,11 +2916,18 @@ module subroutine bocoT_3d_gh & 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 +! Make sure receives are complete before using rBuf_S / rBuf_N + if( itarg_n >= 0 ) then + call MPI_WAIT( rHandle(1), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( rHandle(3), istat, ierr ) + end if + !----------------------------------------------------------------------- ! From a0f0b73a5c415d35aba3ebfd74e71fe198cbdaae Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 21:04:23 -0500 Subject: [PATCH 174/199] WIP --- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 86 +++++++++++----------------- 1 file changed, 34 insertions(+), 52 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index cde2b3015..2f643a263 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -242,16 +242,6 @@ module subroutine boco_2d_g1 & mpi_comm_comp, rHandle(3), irecv) end if -! -! Make sure receives are complete before using rBuf_N / rBuf_S -! - if( itarg_n >= 0 ) then - call MPI_WAIT( rHandle(1), istat, ierr ) - end if - if( itarg_s >= 0 ) then - call MPI_WAIT( rHandle(3), istat, ierr ) - end if -! ! Assign received values from NORTH and SOUTH ! ! From SOUTH @@ -268,6 +258,7 @@ module subroutine boco_2d_g1 & else + if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) !$omp parallel do private(i,j) schedule(static) do j=1,nby do i=1,imax @@ -293,6 +284,7 @@ module subroutine boco_2d_g1 & else + if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) !$omp parallel do private(i,j) schedule(static) do j=1,nby do i=1,imax @@ -370,14 +362,6 @@ module subroutine boco_2d_g1 & end if -! Make sure receives are complete before using rBuf_E / rBuf_W - if( itarg_e >= 0 ) then - call MPI_WAIT( rHandle(2), istat, ierr ) - end if - if( itarg_w >= 0 ) then - call MPI_WAIT( rHandle(4), istat, ierr ) - end if - ! ! Assign received values from EAST and WEST ! @@ -394,9 +378,10 @@ module subroutine boco_2d_g1 & else - do j=1-nby,jmax+nby - do i=1,nbx - W(:,-nbx+i,j)= rBuf_W(:,i,j) + if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) enddo enddo @@ -415,9 +400,10 @@ module subroutine boco_2d_g1 & else - do j=1-nby,jmax+nby - do i=1,nbx - W(:,imax+i,j)=rBuf_E(:,i,j) + if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) enddo enddo @@ -428,6 +414,10 @@ module subroutine boco_2d_g1 & ! ! DEALLOCATE rBufferes ! + if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) if( itarg_s >= 0 ) then deallocate( rBuf_S, stat = iderr) @@ -620,14 +610,6 @@ module subroutine boco_2d_gh & end if -! Make sure receives are complete before using rBuf_N / rBuf_S - if( itarg_n >= 0 ) then - call MPI_WAIT( rHandle(1), istat, ierr ) - end if - if( itarg_s >= 0 ) then - call MPI_WAIT( rHandle(3), istat, ierr ) - end if - ! ! Assign received values from NORTH and SOUTH ! @@ -645,9 +627,10 @@ module subroutine boco_2d_gh & else - do j=1,nby - do i=1,imax - W(:,i,-nby+j)=rBuf_S(:,i,j) + if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) enddo enddo @@ -666,9 +649,10 @@ module subroutine boco_2d_gh & else - do j=1,nby - do i=1,imax - W(:,i,jmax+j)=rBuf_N(:,i,j) + if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) enddo enddo @@ -740,14 +724,6 @@ module subroutine boco_2d_gh & end if -! Make sure receives are complete before using rBuf_E / rBuf_W - if( itarg_e >= 0 ) then - call MPI_WAIT( rHandle(2), istat, ierr ) - end if - if( itarg_w >= 0 ) then - call MPI_WAIT( rHandle(4), istat, ierr ) - end if - ! ! Assign received values from WEST and EAST ! @@ -764,9 +740,10 @@ module subroutine boco_2d_gh & else - do j=1-nby,jmax+nby - do i=1,nbx - W(:,-nbx+i,j)= rBuf_W(:,i,j) + if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) enddo enddo @@ -785,9 +762,10 @@ module subroutine boco_2d_gh & else - do j=1-nby,jmax+nby - do i=1,nbx - W(:,imax+i,j)=rBuf_E(:,i,j) + if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) enddo enddo @@ -797,6 +775,10 @@ module subroutine boco_2d_gh & ! ! DEALLOCATE rBufferes ! + if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) end if From a0ac2d53ce91edbf195bd573c0761aa0241c8ce3 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 21:39:14 -0500 Subject: [PATCH 175/199] WIP --- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 182 ++++++++++++--------------- 1 file changed, 80 insertions(+), 102 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index 2f643a263..9ccba0f18 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -1606,7 +1606,6 @@ module subroutine boco_3d_g1 & 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 @@ -1618,7 +1617,6 @@ module subroutine boco_3d_g1 & 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 ! @@ -1639,9 +1637,10 @@ module subroutine boco_3d_g1 & else - do L=1,Lm_in - do j=1,nby - do i=1,imax + if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + 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 @@ -1663,9 +1662,10 @@ module subroutine boco_3d_g1 & else - do L=1,Lm_in - do j=1,nby - do i=1,imax + if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + 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 @@ -1728,7 +1728,6 @@ module subroutine boco_3d_g1 & 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 @@ -1740,7 +1739,6 @@ module subroutine boco_3d_g1 & 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 @@ -1761,9 +1759,10 @@ module subroutine boco_3d_g1 & else - do L=1,Lm_in - do j=1-nby,jmax+nby - do i=1,nbx + if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + 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 @@ -1786,9 +1785,10 @@ module subroutine boco_3d_g1 & else - do L=1,Lm_in - do j=1-nby,jmax+nby - do i=1,nbx + if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + 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 @@ -1800,6 +1800,10 @@ module subroutine boco_3d_g1 & ! ! DEALLOCATE rBufferes ! + if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) @@ -2005,14 +2009,6 @@ module subroutine boco_3d_gh & end if !TEST -! Make sure receives are complete before using or deallocating rBuf_* - if( itarg_n >= 0 ) then - call MPI_WAIT( rHandle(1), istat, ierr ) - end if - if( itarg_s >= 0 ) then - call MPI_WAIT( rHandle(3), istat, ierr ) - end if - ! ! Assign received values from NORTH and SOUTH ! @@ -2031,9 +2027,10 @@ module subroutine boco_3d_gh & else - do L=1,Lm_in - do j=1,nby - do i=1,imax + if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + 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 @@ -2055,9 +2052,10 @@ module subroutine boco_3d_gh & else - do L=1,Lm_in - do j=1,nby - do i=1,imax + if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + 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 @@ -2066,6 +2064,8 @@ module subroutine boco_3d_gh & endif !TEST + if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) if( itarg_n >= 0 ) then deallocate( rBuf_N, stat = iderr) endif @@ -2157,14 +2157,6 @@ module subroutine boco_3d_gh & deallocate( sBuf_W, stat = ierr ) end if -! Make sure receives are complete before using or deallocating rBuf_* - if( itarg_e >= 0 ) then - call MPI_WAIT( rHandle(2), istat, ierr ) - end if - if( itarg_w >= 0 ) then - call MPI_WAIT( rHandle(4), istat, ierr ) - end if - ! ! Assign received values from WEST and EAST ! @@ -2182,9 +2174,10 @@ module subroutine boco_3d_gh & else - do L=1,Lm_in - do j=1-nby,jmax+nby - do i=1,nbx + if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + 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 @@ -2207,9 +2200,10 @@ module subroutine boco_3d_gh & else - do L=1,Lm_in - do j=1-nby,jmax+nby - do i=1,nbx + if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + 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 @@ -2230,6 +2224,8 @@ module subroutine boco_3d_gh & ! ! DEALLOCATE rBufferes ! + if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) @@ -2386,15 +2382,6 @@ module subroutine bocoT_3d_g1 & end if ! -! Make sure receives are complete before using rBuf_W / rBuf_E -! - if( itarg_e >= 0 ) then - call MPI_WAIT( rHandle(2), istat, ierr ) - end if - if( itarg_w >= 0 ) then - call MPI_WAIT( rHandle(4), istat, ierr ) - end if -! ! Assign received extended halos from WEST and EAST to interior of domains ! @@ -2409,9 +2396,10 @@ module subroutine bocoT_3d_g1 & end do end do else - do L=1,lm_in - do j=1-nby,jmax+nby - do i=1,nbx + if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + 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 @@ -2429,9 +2417,10 @@ module subroutine bocoT_3d_g1 & end do end do else - do L=1,lm_in - do j=1-nby,jmax+nby - do i=1,nbx + if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + 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 @@ -2510,14 +2499,6 @@ module subroutine bocoT_3d_g1 & end if -! Make sure receives are complete before using rBuf_S / rBuf_N - if( itarg_n >= 0 ) then - call MPI_WAIT( rHandle(1), istat, ierr ) - end if - if( itarg_s >= 0 ) then - call MPI_WAIT( rHandle(3), istat, ierr ) - end if - ! ! Assign received values from SOUTH and NORTH ! @@ -2533,9 +2514,10 @@ module subroutine bocoT_3d_g1 & end do end do else - do L=1,lm_in - do j=1,nby - do i=1,imax + if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + 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 @@ -2553,9 +2535,10 @@ module subroutine bocoT_3d_g1 & enddo enddo else - do L=1,lm_in - do j=1,nby - do i=1,imax + if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + 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 @@ -2601,6 +2584,10 @@ module subroutine bocoT_3d_g1 & ! ! DEALLOCATE rBufferes ! + if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) @@ -2778,14 +2765,6 @@ module subroutine bocoT_3d_gh & end if -! Make sure receives are complete before using rBuf_W / rBuf_E - if( itarg_e >= 0 ) then - call MPI_WAIT( rHandle(2), istat, ierr ) - end if - if( itarg_w >= 0 ) then - call MPI_WAIT( rHandle(4), istat, ierr ) - end if - ! ! Assign received extended halos from WEST and EAST ! @@ -2801,9 +2780,10 @@ module subroutine bocoT_3d_gh & end do end do else - do L=1,lm_in - do j=1-nby,jmax+nby - do i=1,nbx + if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + 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 @@ -2821,9 +2801,10 @@ module subroutine bocoT_3d_gh & end do end do else - do L=1,lm_in - do j=1-nby,jmax+nby - do i=1,nbx + if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + 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 @@ -2902,15 +2883,6 @@ module subroutine bocoT_3d_gh & end if -! Make sure receives are complete before using rBuf_S / rBuf_N - if( itarg_n >= 0 ) then - call MPI_WAIT( rHandle(1), istat, ierr ) - end if - if( itarg_s >= 0 ) then - call MPI_WAIT( rHandle(3), istat, ierr ) - end if - - !----------------------------------------------------------------------- ! ! Assign received halos from SOUTH and NORTH @@ -2925,9 +2897,10 @@ module subroutine bocoT_3d_gh & end do end do else - do L=1,lm_in - do j=1,nby - do i=1,imax + if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + 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 @@ -2945,9 +2918,10 @@ module subroutine bocoT_3d_gh & enddo enddo else - do L=1,lm_in - do j=1,nby - do i=1,imax + if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + 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 @@ -2988,6 +2962,10 @@ module subroutine bocoT_3d_gh & ! ! DEALLOCATE rBufferes ! + if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) From a4c7ac21de5cd2d7e2b299fd3587b9cd0d0fc82e Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 22:01:28 -0500 Subject: [PATCH 176/199] WIP --- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 146 +++++++++++++++------------ 1 file changed, 82 insertions(+), 64 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index 9ccba0f18..dd5c30e57 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -4205,7 +4205,6 @@ module subroutine bocox_2d_g1 & 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 @@ -4217,7 +4216,6 @@ module subroutine bocox_2d_g1 & 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 @@ -4238,9 +4236,10 @@ module subroutine bocox_2d_g1 & else - do j=1,jmax - do i=1,nbx - W(:,-nbx+i,j)= rBuf_W(:,i,j) + if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + do j=1,jmax + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) enddo enddo @@ -4259,9 +4258,10 @@ module subroutine bocox_2d_g1 & else - do j=1,jmax - do i=1,nbx - W(:,imax+i,j)=rBuf_E(:,i,j) + if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + do j=1,jmax + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) enddo enddo @@ -4272,6 +4272,8 @@ module subroutine bocox_2d_g1 & ! ! DEALLOCATE rBufferes ! + if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) if( itarg_e >= 0 ) then deallocate( rBuf_E, stat = iderr) @@ -4433,7 +4435,6 @@ module subroutine bocox_2d_gh & 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 @@ -4445,7 +4446,6 @@ module subroutine bocox_2d_gh & 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 @@ -4465,9 +4465,10 @@ module subroutine bocox_2d_gh & else - do j=1,jmax - do i=1,nbx - W(:,-nbx+i,j)= rBuf_W(:,i,j) + if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + do j=1,jmax + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) enddo enddo @@ -4486,9 +4487,10 @@ module subroutine bocox_2d_gh & else - do j=1,jmax - do i=1,nbx - W(:,imax+i,j)=rBuf_E(:,i,j) + if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + do j=1,jmax + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) enddo enddo @@ -4498,6 +4500,8 @@ module subroutine bocox_2d_gh & ! ! DEALLOCATE rBufferes ! + if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) if( itarg_e >= 0 ) then deallocate( rBuf_E, stat = iderr) @@ -4639,7 +4643,6 @@ module subroutine bocoy_2d_g1 & 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 @@ -4651,7 +4654,6 @@ module subroutine bocoy_2d_g1 & 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 ! @@ -4670,9 +4672,10 @@ module subroutine bocoy_2d_g1 & else - do j=1,nby - do i=1,imax - W(:,i,jmax+j)=rBuf_N(:,i,j) + if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) enddo enddo @@ -4690,9 +4693,10 @@ module subroutine bocoy_2d_g1 & else - do j=1,nby - do i=1,imax - W(:,i,-nby+j)=rBuf_S(:,i,j) + if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) enddo enddo @@ -4704,6 +4708,8 @@ module subroutine bocoy_2d_g1 & ! ! DEALLOCATE rBufferes ! + if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) if( itarg_s >= 0 ) then deallocate( rBuf_S, stat = iderr) @@ -4862,7 +4868,6 @@ module subroutine bocoy_2d_gh & 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 @@ -4874,7 +4879,6 @@ module subroutine bocoy_2d_gh & 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 @@ -4894,9 +4898,10 @@ module subroutine bocoy_2d_gh & else - do j=1,nby - do i=1,imax - W(:,i,jmax+j)=rBuf_N(:,i,j) + if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) enddo enddo @@ -4914,9 +4919,10 @@ module subroutine bocoy_2d_gh & else - do j=1,nby - do i=1,imax - W(:,i,-nby+j)=rBuf_S(:,i,j) + if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) enddo enddo @@ -4926,6 +4932,8 @@ module subroutine bocoy_2d_gh & ! ! DEALLOCATE rBufferes ! + if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) if( itarg_s >= 0 ) then deallocate( rBuf_S, stat = iderr) @@ -5069,7 +5077,6 @@ module subroutine bocoTx_2d_g1 & 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 @@ -5082,7 +5089,6 @@ module subroutine bocoTx_2d_g1 & 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 @@ -5100,9 +5106,10 @@ module subroutine bocoTx_2d_g1 & end do end do else - do j=1,jmax - do i=1,nbx - W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + if( itarg_w >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + do j=1,jmax + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) end do end do endif @@ -5116,9 +5123,10 @@ module subroutine bocoTx_2d_g1 & 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) + if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + 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 @@ -5127,6 +5135,8 @@ module subroutine bocoTx_2d_g1 & ! ! DEALLOCATE rBufferes ! + if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) @@ -5284,7 +5294,6 @@ module subroutine bocoTx_2d_gh & 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 @@ -5296,7 +5305,6 @@ module subroutine bocoTx_2d_gh & 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 ! @@ -5312,9 +5320,10 @@ module subroutine bocoTx_2d_gh & end do end do else - do j=1,jmax - do i=1,nbx - W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + do j=1,jmax + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) end do end do endif @@ -5328,9 +5337,10 @@ module subroutine bocoTx_2d_gh & 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) + if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + 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 @@ -5339,6 +5349,9 @@ module subroutine bocoTx_2d_gh & ! DEALLOCATE rBufferes + if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) + if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) end if @@ -5474,7 +5487,6 @@ module subroutine bocoTy_2d_g1 & 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 @@ -5487,7 +5499,6 @@ module subroutine bocoTy_2d_g1 & 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 @@ -5505,9 +5516,10 @@ module subroutine bocoTy_2d_g1 & end do end do else - do j=1,nby - do i=1,imax - W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + if( itarg_s >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) end do end do endif @@ -5521,9 +5533,10 @@ module subroutine bocoTy_2d_g1 & 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) + if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + 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 @@ -5532,6 +5545,8 @@ module subroutine bocoTy_2d_g1 & ! ! DEALLOCATE rBufferes ! + if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) if( itarg_s >= 0 ) then deallocate( rBuf_S, stat = iderr) @@ -5690,7 +5705,6 @@ module subroutine bocoTy_2d_gh & 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 @@ -5703,7 +5717,6 @@ module subroutine bocoTy_2d_gh & 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 @@ -5721,9 +5734,10 @@ module subroutine bocoTy_2d_gh & end do end do else - do j=1,nby - do i=1,imax - W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + if( itarg_s >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) end do end do endif @@ -5737,9 +5751,10 @@ module subroutine bocoTy_2d_gh & 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) + if( itarg_n >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + 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 @@ -5748,6 +5763,9 @@ module subroutine bocoTy_2d_gh & ! DEALLOCATE rBufferes + if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) + if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) + if( itarg_s >= 0 ) then deallocate( rBuf_S, stat = iderr) end if From 6ae7b1a3395babe3de3f9af859927c29caad8145 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 22:27:25 -0500 Subject: [PATCH 177/199] WIP --- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 36 +++++++++++++++++++++------- 1 file changed, 27 insertions(+), 9 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index dd5c30e57..9eb68ef47 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -140,6 +140,7 @@ module subroutine boco_2d_g1 & integer(i_kind) iaerr,ierr,iderr,l,i,j integer(i_kind) isend,irecv,nebpe integer(i_kind) ndatax,ndatay,nbxy +integer(i_kind) rWait(2),nwait,istatall(MPI_STATUS_SIZE,2) integer(i_kind) g_ind,g logical l_sidesend include "type_parameter_locpointer.inc" @@ -242,6 +243,19 @@ module subroutine boco_2d_g1 & mpi_comm_comp, rHandle(3), irecv) end if +! +! Complete NORTH/SOUTH receives as a group +! + nwait=0 + if( itarg_n >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(1) + end if + if( itarg_s >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(3) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) ! Assign received values from NORTH and SOUTH ! ! From SOUTH @@ -258,7 +272,6 @@ module subroutine boco_2d_g1 & else - if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) !$omp parallel do private(i,j) schedule(static) do j=1,nby do i=1,imax @@ -284,7 +297,6 @@ module subroutine boco_2d_g1 & else - if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) !$omp parallel do private(i,j) schedule(static) do j=1,nby do i=1,imax @@ -361,6 +373,19 @@ module subroutine boco_2d_g1 & mpi_comm_comp, rHandle(4), irecv) end if +! +! Complete EAST/WEST receives as a group +! + nwait=0 + if( itarg_e >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(2) + end if + if( itarg_w >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(4) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) ! ! Assign received values from EAST and WEST @@ -378,7 +403,6 @@ module subroutine boco_2d_g1 & else - if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) do j=1-nby,jmax+nby do i=1,nbx W(:,-nbx+i,j)= rBuf_W(:,i,j) @@ -400,7 +424,6 @@ module subroutine boco_2d_g1 & else - if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) do j=1-nby,jmax+nby do i=1,nbx W(:,imax+i,j)=rBuf_E(:,i,j) @@ -414,11 +437,6 @@ module subroutine boco_2d_g1 & ! ! DEALLOCATE rBufferes ! - if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) - if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) - if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) - if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) - if( itarg_s >= 0 ) then deallocate( rBuf_S, stat = iderr) end if From 5815b642f5cb004e65ae0ce93c1274c6c11d5ffa Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 22:55:27 -0500 Subject: [PATCH 178/199] wip --- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 103 ++++++++++++++++++++------- 1 file changed, 77 insertions(+), 26 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index 9eb68ef47..4f566930f 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -509,6 +509,7 @@ module subroutine boco_2d_gh & integer(i_kind) iaerr,ierr,iderr,l,i,j integer(i_kind) isend,irecv,nebpe integer(i_kind) ndatax,ndatay +integer(i_kind) rWait(2),nwait,istatall(MPI_STATUS_SIZE,2) integer(i_kind) g_ind,g logical l_sidesend include "type_parameter_locpointer.inc" @@ -628,6 +629,18 @@ module subroutine boco_2d_gh & end if +! Complete NORTH/SOUTH receives as a group + nwait=0 + if( itarg_n >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(1) + end if + if( itarg_s >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(3) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) + ! ! Assign received values from NORTH and SOUTH ! @@ -645,7 +658,6 @@ module subroutine boco_2d_gh & else - if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) do j=1,nby do i=1,imax W(:,i,-nby+j)=rBuf_S(:,i,j) @@ -667,7 +679,6 @@ module subroutine boco_2d_gh & else - if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) do j=1,nby do i=1,imax W(:,i,jmax+j)=rBuf_N(:,i,j) @@ -742,6 +753,18 @@ module subroutine boco_2d_gh & end if +! Complete EAST/WEST receives as a group + nwait=0 + if( itarg_e >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(2) + end if + if( itarg_w >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(4) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) + ! ! Assign received values from WEST and EAST ! @@ -758,7 +781,6 @@ module subroutine boco_2d_gh & else - if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) do j=1-nby,jmax+nby do i=1,nbx W(:,-nbx+i,j)= rBuf_W(:,i,j) @@ -780,7 +802,6 @@ module subroutine boco_2d_gh & else - if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) do j=1-nby,jmax+nby do i=1,nbx W(:,imax+i,j)=rBuf_E(:,i,j) @@ -793,10 +814,6 @@ module subroutine boco_2d_gh & ! ! DEALLOCATE rBufferes ! - if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) - if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) - if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) - if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) end if @@ -1540,6 +1557,7 @@ module subroutine boco_3d_g1 & integer(i_kind) iaerr,ierr,iderr,l,i,j integer(i_kind) isend,irecv,nebpe integer(i_kind) ndatax,ndatay +integer(i_kind) rWait(2),nwait,istatall(MPI_STATUS_SIZE,2) integer(i_kind) g_ind,g logical l_sidesend !----------------------------------------------------------------------- @@ -1638,6 +1656,19 @@ module subroutine boco_3d_g1 & end if ! +! Complete NORTH/SOUTH receives as a group +! + nwait=0 + if( itarg_n >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(1) + end if + if( itarg_s >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(3) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) +! ! Assign received values from NORTH and SOUTH ! @@ -1655,7 +1686,6 @@ module subroutine boco_3d_g1 & else - if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) do L=1,Lm_in do j=1,nby do i=1,imax @@ -1680,7 +1710,6 @@ module subroutine boco_3d_g1 & else - if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) do L=1,Lm_in do j=1,nby do i=1,imax @@ -1760,6 +1789,18 @@ module subroutine boco_3d_g1 & end if +! Complete EAST/WEST receives as a group + nwait=0 + if( itarg_e >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(2) + end if + if( itarg_w >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(4) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) + ! ! Assign received values from EAST and WEST ! @@ -1777,7 +1818,6 @@ module subroutine boco_3d_g1 & else - if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) do L=1,Lm_in do j=1-nby,jmax+nby do i=1,nbx @@ -1803,7 +1843,6 @@ module subroutine boco_3d_g1 & else - if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) do L=1,Lm_in do j=1-nby,jmax+nby do i=1,nbx @@ -1818,11 +1857,6 @@ module subroutine boco_3d_g1 & ! ! DEALLOCATE rBufferes ! - if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) - if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) - if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) - if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) - if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) end if @@ -1896,6 +1930,7 @@ module subroutine boco_3d_gh & integer(i_kind) iaerr,ierr,iderr,l,i,j integer(i_kind) isend,irecv,nebpe integer(i_kind) ndatax,ndatay +integer(i_kind) rWait(2),nwait,istatall(MPI_STATUS_SIZE,2) integer(i_kind) g_ind,g logical l_sidesend include "type_parameter_locpointer.inc" @@ -2015,6 +2050,19 @@ module subroutine boco_3d_gh & mpi_comm_work, rHandle(3), irecv) end if +! +! Complete NORTH/SOUTH receives as a group +! + nwait=0 + if( itarg_n >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(1) + end if + if( itarg_s >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(3) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) !TEST if( itarg_n >= 0 ) then @@ -2045,7 +2093,6 @@ module subroutine boco_3d_gh & else - if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) do L=1,Lm_in do j=1,nby do i=1,imax @@ -2070,7 +2117,6 @@ module subroutine boco_3d_gh & else - if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) do L=1,Lm_in do j=1,nby do i=1,imax @@ -2082,8 +2128,6 @@ module subroutine boco_3d_gh & endif !TEST - if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) - if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) if( itarg_n >= 0 ) then deallocate( rBuf_N, stat = iderr) endif @@ -2163,6 +2207,18 @@ module subroutine boco_3d_gh & end if +! Complete EAST/WEST receives as a group + nwait=0 + if( itarg_e >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(2) + end if + if( itarg_w >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(4) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) + ! ! Deallocate send bufferes from EAST and WEST ! @@ -2192,7 +2248,6 @@ module subroutine boco_3d_gh & else - if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) do L=1,Lm_in do j=1-nby,jmax+nby do i=1,nbx @@ -2218,7 +2273,6 @@ module subroutine boco_3d_gh & else - if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) do L=1,Lm_in do j=1-nby,jmax+nby do i=1,nbx @@ -2242,9 +2296,6 @@ module subroutine boco_3d_gh & ! ! DEALLOCATE rBufferes ! - if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) - if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) - if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) endif From 2030e9b812dc9733c107ca7a6093def71e3ab914 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sat, 7 Feb 2026 23:26:38 -0500 Subject: [PATCH 179/199] WIP --- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 70 +++++++++++++++++++++------- 1 file changed, 52 insertions(+), 18 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index 4f566930f..682ca7c5a 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -890,6 +890,7 @@ module subroutine bocoT_2d_g1 & integer(i_kind) iaerr,ierr,iderr,L,i,j integer(i_kind) isend,irecv,nebpe integer(i_kind) ndatax,ndatay +integer(i_kind) rWait(2),nwait,istatall(MPI_STATUS_SIZE,2) logical l_sidesend integer(i_kind) g_ind,g,k !----------------------------------------------------------------------- @@ -1211,6 +1212,7 @@ module subroutine bocoT_2d_gh & integer(i_kind) iaerr,ierr,iderr,L,i,j integer(i_kind) isend,irecv,nebpe integer(i_kind) ndatax,ndatay +integer(i_kind) rWait(2),nwait,istatall(MPI_STATUS_SIZE,2) logical l_sidesend integer(i_kind) g_ind,g,k !----------------------------------------------------------------------- @@ -2347,6 +2349,7 @@ module subroutine bocoT_3d_g1 & integer(i_kind) iaerr,ierr,iderr,L,i,j integer(i_kind) isend,irecv,nebpe integer(i_kind) ndatax,ndatay +integer(i_kind) rWait(2),nwait,istatall(MPI_STATUS_SIZE,2) logical l_sidesend integer(i_kind) g_ind,g,k include "type_parameter_locpointer.inc" @@ -2450,6 +2453,18 @@ module subroutine bocoT_3d_g1 & end if + +! Complete EAST/WEST receives as a group + nwait=0 + if( itarg_e >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(2) + end if + if( itarg_w >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(4) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) ! ! Assign received extended halos from WEST and EAST to interior of domains ! @@ -2465,7 +2480,6 @@ module subroutine bocoT_3d_g1 & end do end do else - if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) do L=1,lm_in do j=1-nby,jmax+nby do i=1,nbx @@ -2486,7 +2500,6 @@ module subroutine bocoT_3d_g1 & end do end do else - if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) do L=1,lm_in do j=1-nby,jmax+nby do i=1,nbx @@ -2568,6 +2581,18 @@ module subroutine bocoT_3d_g1 & end if +! Complete NORTH/SOUTH receives as a group + nwait=0 + if( itarg_n >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(1) + end if + if( itarg_s >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(3) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) + ! ! Assign received values from SOUTH and NORTH ! @@ -2583,7 +2608,6 @@ module subroutine bocoT_3d_g1 & end do end do else - if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) do L=1,lm_in do j=1,nby do i=1,imax @@ -2604,7 +2628,6 @@ module subroutine bocoT_3d_g1 & enddo enddo else - if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) do L=1,lm_in do j=1,nby do i=1,imax @@ -2653,11 +2676,6 @@ module subroutine bocoT_3d_g1 & ! ! DEALLOCATE rBufferes ! - if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) - if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) - if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) - if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) - if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) endif @@ -2708,6 +2726,7 @@ module subroutine bocoT_3d_gh & integer(i_kind) iaerr,ierr,iderr,L,i,j integer(i_kind) isend,irecv,nebpe integer(i_kind) ndatax,ndatay +integer(i_kind) rWait(2),nwait,istatall(MPI_STATUS_SIZE,2) logical l_sidesend integer(i_kind) g_ind,g,k include "type_parameter_locpointer.inc" @@ -2834,6 +2853,18 @@ module subroutine bocoT_3d_gh & end if +! Complete EAST/WEST receives as a group + nwait=0 + if( itarg_e >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(2) + end if + if( itarg_w >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(4) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) + ! ! Assign received extended halos from WEST and EAST ! @@ -2849,7 +2880,6 @@ module subroutine bocoT_3d_gh & end do end do else - if( itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) do L=1,lm_in do j=1-nby,jmax+nby do i=1,nbx @@ -2870,7 +2900,6 @@ module subroutine bocoT_3d_gh & end do end do else - if( itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) do L=1,lm_in do j=1-nby,jmax+nby do i=1,nbx @@ -2952,6 +2981,18 @@ module subroutine bocoT_3d_gh & end if +! Complete NORTH/SOUTH receives as a group + nwait=0 + if( itarg_n >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(1) + end if + if( itarg_s >= 0 ) then + nwait=nwait+1 + rWait(nwait)=rHandle(3) + end if + if( nwait > 0 ) call MPI_WAITALL( nwait, rWait, istatall, ierr ) + !----------------------------------------------------------------------- ! ! Assign received halos from SOUTH and NORTH @@ -2966,7 +3007,6 @@ module subroutine bocoT_3d_gh & end do end do else - if( itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) do L=1,lm_in do j=1,nby do i=1,imax @@ -2987,7 +3027,6 @@ module subroutine bocoT_3d_gh & enddo enddo else - if( itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) do L=1,lm_in do j=1,nby do i=1,imax @@ -3031,11 +3070,6 @@ module subroutine bocoT_3d_gh & ! ! DEALLOCATE rBufferes ! - if( lwest .and. itarg_w >= 0 ) call MPI_WAIT( rHandle(4), istat, ierr ) - if( least .and. itarg_e >= 0 ) call MPI_WAIT( rHandle(2), istat, ierr ) - if( lsouth .and. itarg_s >= 0 ) call MPI_WAIT( rHandle(3), istat, ierr ) - if( lnorth .and. itarg_n >= 0 ) call MPI_WAIT( rHandle(1), istat, ierr ) - if( itarg_w >= 0 ) then deallocate( rBuf_W, stat = iderr) endif From c36b1c527c2d327dbd52bbc2d6856814c9b09c03 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Sun, 8 Feb 2026 21:51:08 +0000 Subject: [PATCH 180/199] WIP --- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 12 +++--------- src/saber/mgbf/mgbf_lib/phint1.f90 | 2 ++ 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index dc8c0a83b..c159f6d6d 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -1055,7 +1055,9 @@ subroutine convert_vert_varied_aspt integer(i_kind):: user_mpi_real real (r_kind) :: mg_ampl01_org - allocate(this%aspect_vert_profile_angrid(lm_a),this%aspect_vert_profile_filtgrid(lm)) + if( .not. allocated(this%aspect_vert_profile_angrid )) then + allocate(this%aspect_vert_profile_angrid(lm_a),this%aspect_vert_profile_filtgrid(lm)) + endif allocate(sigofz(lm_a),sigofis(lm)) call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr) write(6,*)'thinkdeb999 2.0 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid @@ -1109,19 +1111,11 @@ subroutine convert_vert_varied_aspt ! these scales sig to each of the new s-grid points: !clt call logintgrid(nz,ns,zofis,sigofz,sigofis) call zsigtossig(lm_a-1,nf,lm-1,this%zofis,sigofz,sigofis) - print'('' list the profile coordinates of zofis,sigofis, for each is:'')' -! if(this%l_use_aspt_nml) then -!j sigofis=sqrt(mg_amp01) -! else mg_ampl01_org=mg_ampl01 mg_ampl01=(sum(sigofis**2)/size(sigofis)) if(.not.this%l_vert_stretched_filtgrid) then !the former could be only true when the latter is in effect write(6,*)' suggested and actual/original ampl01 is ',mg_ampl01,' ' ,mg_ampl01_org mg_ampl01=mg_ampl01_org -! if (abs(mg_ampl01_org-mg_ampl01)/mg_ampl01_org .gt.0.001) then -! write(6,*)'thinkdeb the new ampl01 is too much difference from the original one ,when this%l_use_aspt_nml' -! stop -! endif endif write(6,*)' the original and final ampl01 is ',mg_ampl01_org,' ' ,mg_ampl01 diff --git a/src/saber/mgbf/mgbf_lib/phint1.f90 b/src/saber/mgbf/mgbf_lib/phint1.f90 index e5f11df62..65429a89c 100644 --- a/src/saber/mgbf/mgbf_lib/phint1.f90 +++ b/src/saber/mgbf/mgbf_lib/phint1.f90 @@ -149,6 +149,7 @@ subroutine make_ssgrid(nz,nf,ns,sigofz, sstop,dss,sofz,zofs)! [make_ssgrid] integer(i_kind) :: iz,izf,izfm,izfp,is,nzf !============================================================================ ! Interpolate the log of the sigofz distribution to a finer grid: +write(6,*)'thinkdeb555 nz.. ',nz,nf,ns dzf=u1/nf nzf=nz*nf call make_ssf(nz,nf,sigofz,ssf) @@ -177,6 +178,7 @@ subroutine make_ssgrid(nz,nf,ns,sigofz, sstop,dss,sofz,zofs)! [make_ssgrid] izf=izfp-1 r=(s-ssf(izf))/(ssf(izfp)-ssf(izf)) zofs(is)=(izf+r)/nf + write(6,*)'thinkdeb555 zofs = ',is , ' ',zofs(is) enddo end subroutine make_ssgrid From 6cc99b26e36746d387102a42c2a04815116806a6 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Sun, 8 Feb 2026 23:35:53 +0000 Subject: [PATCH 181/199] WIP --- src/saber/mgbf/mgbf_lib/phint1.f90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/phint1.f90 b/src/saber/mgbf/mgbf_lib/phint1.f90 index 65429a89c..ade8ff77d 100644 --- a/src/saber/mgbf/mgbf_lib/phint1.f90 +++ b/src/saber/mgbf/mgbf_lib/phint1.f90 @@ -93,11 +93,9 @@ subroutine make_ssf(nz,nf,sigofz,ssofzf)! [make_ssf] call logintgrid(nz,nzf,zofzf,u1/sigofz, sigiofzf) ! Integrate sigiofzf s=0; ssofzf(0)=s -!$omp parallel do private(izf) schedule(static) do izf=1,nzf s=s+sigiofzf(izf-1)+sigiofzf(izf); ssofzf(izf)=s enddo -!$omp end parallel do ssofzf=ssofzf*dzf*o2 end subroutine make_ssf From 73789231b8fafa6dc5ad63598b5dec0a64b48812 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Mon, 9 Feb 2026 22:17:55 +0000 Subject: [PATCH 182/199] cleaning --- src/saber/mgbf/covariance/MGBF_Covariance.h | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index c71e62d2d..219219a07 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -125,15 +125,10 @@ MGBF_Covariance::MGBF_Covariance(const oops::GeometryData & geometryData, activeVars_ = getActiveVars(params, centralVars); util::Timer timer(classname(), "Covariance"); - std::cout<<"thinkdebconfig0 ifhas -1 "< Date: Thu, 12 Feb 2026 20:12:31 +0000 Subject: [PATCH 183/199] WIP merging --- src/saber/gsi/covariance/gsi_covariance_mod.f90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/saber/gsi/covariance/gsi_covariance_mod.f90 b/src/saber/gsi/covariance/gsi_covariance_mod.f90 index db2e27170..205912e5a 100644 --- a/src/saber/gsi/covariance/gsi_covariance_mod.f90 +++ b/src/saber/gsi/covariance/gsi_covariance_mod.f90 @@ -988,6 +988,7 @@ subroutine cvfix_(gsicv,jedicv,vflip,need,ntimes,which) ! real(kind=kind_real), allocatable :: t_pt(:,:,:) real(kind=kind_real), pointer :: tv(:,:,:)=>NULL() + real(kind=kind_real), pointer :: t(:,:,:)=>NULL() real(kind=kind_real), pointer :: tv_pt(:,:,:)=>NULL() real(kind=kind_real), pointer :: q(:,:,:)=>NULL() real(kind=kind_real), pointer :: q_pt(:,:,:)=>NULL() @@ -1020,7 +1021,7 @@ subroutine cvfix_(gsicv,jedicv,vflip,need,ntimes,which) endif ! retrieve missing field if(which=='tlm') then - call gsi_tv_to_t_tl(tv,tv_pt,q,q_pt,t_pt) + call gsi_tv_to_t_tl(tv,tv_pt,q,q_pt,t_pt,t) ! pass it back to JEDI ... allocate(aux1(size(rank2,2))) if (vflip) then @@ -1040,7 +1041,7 @@ subroutine cvfix_(gsicv,jedicv,vflip,need,ntimes,which) endwhere endif if(which=='adm') then - call gsi_tv_to_t_ad(tv,tv_pt,q,q_pt,t_pt) + call gsi_tv_to_t_ad(tv,tv_pt,q,q_pt,t_pt,t) where(need=='tv') need='filled-'//need endwhere @@ -1101,6 +1102,7 @@ subroutine svfix_(gsisv,jedicv,vflip,need,ntimes,which) ! real(kind=kind_real), allocatable :: t_pt(:,:,:) real(kind=kind_real), pointer :: tv(:,:,:)=>NULL() + real(kind=kind_real), pointer :: t(:,:,:)=>NULL() real(kind=kind_real), pointer :: tv_pt(:,:,:)=>NULL() real(kind=kind_real), pointer :: q(:,:,:)=>NULL() real(kind=kind_real), pointer :: q_pt(:,:,:)=>NULL() @@ -1147,7 +1149,7 @@ subroutine svfix_(gsisv,jedicv,vflip,need,ntimes,which) endif ! retrieve missing field if(which=='tlm') then - call gsi_tv_to_t_tl(tv,tv_pt,q,q_pt,t_pt) + call gsi_tv_to_t_tl(tv,tv_pt,q,q_pt,t_pt,t) where(need=='tv') need='filled-'//need endwhere @@ -1167,7 +1169,7 @@ subroutine svfix_(gsisv,jedicv,vflip,need,ntimes,which) deallocate(aux1) endif if(which=='adm') then - call gsi_tv_to_t_ad(tv,tv_pt,q,q_pt,t_pt) + call gsi_tv_to_t_ad(tv,tv_pt,q,q_pt,t_pt,t) where(need=='tv') need='filled-'//need endwhere From e0d5dea77d332cf4602185f41d65f8d332f6e78c Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Tue, 24 Feb 2026 00:41:54 +0000 Subject: [PATCH 184/199] added Harray=0 in downsend_all_g2 --- src/saber/blocks/SaberEnsembleBlockChain.h | 1 + src/saber/blocks/SaberParametricBlockChain.h | 88 +------------------- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 1 + src/saber/oops/ProcessPerts.h | 1 + 4 files changed, 6 insertions(+), 85 deletions(-) diff --git a/src/saber/blocks/SaberEnsembleBlockChain.h b/src/saber/blocks/SaberEnsembleBlockChain.h index 8e5e2a32d..8150adfd9 100644 --- a/src/saber/blocks/SaberEnsembleBlockChain.h +++ b/src/saber/blocks/SaberEnsembleBlockChain.h @@ -306,6 +306,7 @@ SaberEnsembleBlockChain::SaberEnsembleBlockChain(const oops::Geometry & g currentOuterVars, fset4dXb, fset4dFg, + locMergedConf); } } // Direct calibration diff --git a/src/saber/blocks/SaberParametricBlockChain.h b/src/saber/blocks/SaberParametricBlockChain.h index 7f96fa86a..6a69dfb4c 100644 --- a/src/saber/blocks/SaberParametricBlockChain.h +++ b/src/saber/blocks/SaberParametricBlockChain.h @@ -162,7 +162,6 @@ SaberParametricBlockChain::SaberParametricBlockChain(const oops::Geometry fsetEns, centralDirectCalibration); } - oops::Log::trace() << "SaberParametricBlockChain ctor starting outerblockchain finished" << std::endl; // Set outer geometry data for central block const oops::GeometryData & currentOuterGeom = outerBlockChain_ ? outerBlockChain_->innerGeometryData() : geom.generic(); @@ -177,10 +176,7 @@ SaberParametricBlockChain::SaberParametricBlockChain(const oops::Geometry fset4dFg); // Read and add model fields - // //clttothink - oops::Log::trace() << "in SaberParametricBlockChain.h before centralBlock_->read "<read(geom, currentOuterVars); - oops::Log::trace() << "in SaberParametricBlockChain.h after centralBlock_->read "<doCalibration()) { // Calibration @@ -199,93 +195,15 @@ SaberParametricBlockChain::SaberParametricBlockChain(const oops::Geometry centralBlock_->read(); } + if (centralBlock_->forceWrite() || centralBlock_->doCalibration()) { // Write data oops::Log::info() << "Info : Write data" << std::endl; centralBlock_->write(geom); centralBlock_->write(); } - // Write final ensemble - if (covarConf.has("output ensemble")) { - // Get output parameters configuration - const eckit::LocalConfiguration outputEnsembleConf(covarConf, "output ensemble"); - - // Check whether geometry grid is similar to the last outer block inner geometry - const bool useModelWriter = (util::getGridUid(geom.functionSpace()) - == util::getGridUid(currentOuterGeom.functionSpace())); - - // Get ensemble size - size_t ensembleSize = ensembleConf.getInt("ensemble size"); - - // Estimate mean - oops::FieldSet3D fsetMean(fset4dXb[0].validTime(), geom.getComm()); - if (iterativeEnsembleLoading) { - for (size_t ie = 0; ie < ensembleSize; ++ie) { - // Read member - oops::FieldSet3D fsetMem(fset4dXb[0].validTime(), geom.getComm()); - readEnsembleMember(geom, activeVars, ensembleConf, ie, fsetMem); - - // Update mean - if (ie == 0) { - fsetMean.deepCopy(fsetMem); - } else { - fsetMean += fsetMem; - } - } - - // Normalize mean - fsetMean *= 1.0/static_cast(ensembleSize); - } - - // Write first member only - const bool firstMemberOnly = outputEnsembleConf.getBool("first member only", false); - if (firstMemberOnly) { - ensembleSize = 1; - } - - for (size_t ie = 0; ie < ensembleSize; ++ie) { - oops::Log::info() << "Info : Write member " << ie << std::endl; - - // Increment pointer - oops::Increment dx(geom, activeVars, fset4dXb[0].validTime()); - - // Get ensemble member - if (iterativeEnsembleLoading) { - // Read ensemble member - oops::FieldSet3D fset(fset4dXb[0].validTime(), geom.getComm()); - readEnsembleMember(geom, activeVars, ensembleConf, ie, fset); - - // Remove mean - fset -= fsetMean; - - // Apply outer blocks inverse - if (outerBlockChain_) outerBlockChain_->leftInverseMultiply(fset); - - // ATLAS fieldset to Increment_ - dx.fromFieldSet(fset.fieldSet()); - } else { - // ATLAS fieldset to Increment_ - dx.fromFieldSet(fsetEns[ie].fieldSet()); - } - - if (useModelWriter) { - // Use model writer - - // Set member index - eckit::LocalConfiguration outputMemberConf(outputEnsembleConf); - util::setMember(outputMemberConf, ie+1); - - // Write Increment - dx.write(outputMemberConf); - oops::Log::test() << "Norm of ensemble member " << ie << ": " << dx.norm() << std::endl; - } else { - // Use generic ATLAS writer - throw eckit::NotImplemented("generic output ensemble write not implemented yet", Here()); - } - } - } - - testCentralBlock(covarConf, saberCentralBlockParams, currentOuterGeom, activeVars); + // Test central block + testCentralBlock(fullConf); oops::Log::trace() << "SaberParametricBlockChain ctor done" << std::endl; } diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index 682ca7c5a..5999d8547 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -3947,6 +3947,7 @@ module subroutine downsend_all_g2 & ! ! Define generational flags ! + Harray(:,:,:) = 0.0d0 mygen_up=2 mygen_dn=1 diff --git a/src/saber/oops/ProcessPerts.h b/src/saber/oops/ProcessPerts.h index 6a8be9baa..28e0e91c1 100644 --- a/src/saber/oops/ProcessPerts.h +++ b/src/saber/oops/ProcessPerts.h @@ -283,6 +283,7 @@ template class ProcessPerts : public oops::Application { saberFilterBlocks.push_back( std::make_unique(geom, incVars, fsetXb, fsetFg, + conf)); } std::vector> saberDiagnosticBlocks; From bcf20973faaf74a7a8d752056a764d747d6051c2 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Tue, 24 Feb 2026 03:30:46 +0000 Subject: [PATCH 185/199] more zero initilizaiton --- src/saber/mgbf/mgbf_lib/mg_bocos.f90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 index 5999d8547..0b1b3905a 100755 --- a/src/saber/mgbf/mgbf_lib/mg_bocos.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_bocos.f90 @@ -3948,6 +3948,10 @@ module subroutine downsend_all_g2 & ! Define generational flags ! Harray(:,:,:) = 0.0d0 + dBuf_SW=0.0d0 !brutal forced to zero to avoid undefined values in the output + dBuf_SE=0.0d0 + dBuf_NW=0.0d0 + dBuf_NE=0.0d0 mygen_up=2 mygen_dn=1 From 7e87a657f5a6c82432ef35b25486dbca6f51854a Mon Sep 17 00:00:00 2001 From: "Ting.Lei-NOAA" Date: Wed, 25 Feb 2026 20:37:18 +0000 Subject: [PATCH 186/199] upgrad mgbf to the current saber --- src/saber/CMakeLists.txt | 2 +- src/saber/mgbf/covariance/MGBF_Covariance.h | 5 +---- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/src/saber/CMakeLists.txt b/src/saber/CMakeLists.txt index 57a525cf4..b75acce03 100644 --- a/src/saber/CMakeLists.txt +++ b/src/saber/CMakeLists.txt @@ -4,7 +4,7 @@ # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # Build list of subdirs with files to add -set( _subdirs bifourier blocks bump diffusion fastlam generic gsi interpolation oops spectralb util vader ) +set( _subdirs bifourier blocks bump diffusion fastlam generic gsi interpolation oops spectralb util vader mgbf) foreach( _subdir IN LISTS _subdirs ) add_subdirectory( ${_subdir} ) list( TRANSFORM ${_subdir}_src_files PREPEND ${_subdir}/ ) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index 219219a07..9975ad567 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -103,7 +103,6 @@ MGBF_Covariance(const oops::GeometryData & geometryData, std::vector variables_; // Function space atlas::FunctionSpace mgbfGridFuncSpace_; - oops::Variables activeVars_; const eckit::mpi::Comm * comm_; }; @@ -116,13 +115,11 @@ MGBF_Covariance::MGBF_Covariance(const oops::GeometryData & geometryData, const Parameters_ & params, const oops::FieldSet3D & xb, const oops::FieldSet3D & fg) - : SaberCentralBlockBase(params, xb.validTime()), + : SaberCentralBlockBase(params, xb.validTime(),geometryData, centralVars), params_(params), variables_(params.activeVars.value().get_value_or(centralVars).variables()), mgbfGridFuncSpace_(geometryData.functionSpace()), comm_(&geometryData.comm()) { oops::Log::trace() << classname() << "MGBF::Covariance starting" << std::endl; - // Get active variables - activeVars_ = getActiveVars(params, centralVars); util::Timer timer(classname(), "Covariance"); eckit::LocalConfiguration mgbf_config = params.toConfiguration(); From f86f3fc71a87f4e49f0a77e99fa965e174b4b3a8 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Thu, 19 Mar 2026 16:07:54 +0000 Subject: [PATCH 187/199] WIP --- .../gsi/covariance/gsi_covariance_mod.f90 | 152 ++++-------------- 1 file changed, 32 insertions(+), 120 deletions(-) diff --git a/src/saber/gsi/covariance/gsi_covariance_mod.f90 b/src/saber/gsi/covariance/gsi_covariance_mod.f90 index 205912e5a..2c7cf0f2a 100644 --- a/src/saber/gsi/covariance/gsi_covariance_mod.f90 +++ b/src/saber/gsi/covariance/gsi_covariance_mod.f90 @@ -808,7 +808,7 @@ subroutine atlas_to_gsi_(rank,var,pe,layout) integer, intent(in), optional :: pe integer, intent(in), optional :: layout(2) integer ii,jj,jnode - integer mylat2,mylon2,mype,nxpe,nype + integer mylat2,mylon2,mype,nxpe,nype,sizeofrank mylat2 = size(var,1) mylon2 = size(var,2) jnode=1 @@ -819,131 +819,43 @@ subroutine atlas_to_gsi_(rank,var,pe,layout) jnode = jnode + 1 enddo enddo + + if(mylon2*mylat2.le.sizeofrank) then !in global domain, or regional, the subdomains are of the laterary boundaries + ! and the halo points are not "complete"/absent along the laterary boundies of the whole + ! domain + !for simplicity, in that situation, the halo points would be defined by adjacent inner + !points ! fill in halos ! atlas inserts halos in this order: ! - all x @ ymin ! - pairs of (xmin, xmax) @ each y from (ymin+1, ymax-1) ! - all x @ ymax - - if(present(pe).and.present(layout)) then - mype = pe - nxpe = layout(1) - nype = layout(2) - if(mype == 0) then - do jj=2,mylat2-1 - var(jj,mylon2) = rank(jnode) - jnode = jnode + 1 - enddo - do ii=2,mylon2 - var(mylat2,ii) = rank(jnode) - jnode = jnode + 1 - enddo - else if(mype == nxpe-1) then - do jj=2,mylat2-1 - var(jj,1) = rank(jnode) - jnode = jnode + 1 - enddo - do ii=1,mylon2-1 - var(mylat2,ii) = rank(jnode) - jnode = jnode + 1 - enddo - else if(mype == nxpe*(nype-1)) then - do ii=2,mylon2 - var(1,ii) = rank(jnode) - jnode = jnode + 1 - enddo - do jj=2,mylat2-1 - var(jj,mylon2) = rank(jnode) - jnode = jnode + 1 - enddo - else if(mype == nxpe*nype-1) then - do ii=1,mylon2-1 - var(1,ii) = rank(jnode) - jnode = jnode + 1 - enddo - do jj=2,mylat2-1 - var(jj,1) = rank(jnode) - jnode = jnode + 1 - enddo - else if(mype>0 .and. mypenxpe*(nype-1) .and. mype0 .and. mypenxpe-1 .and. mype Date: Tue, 14 Apr 2026 01:17:48 +0200 Subject: [PATCH 188/199] Fix gcov usage for offline code coverage estimation (#1196) Co-authored-by: Nate Crossette --- CMakeLists.txt | 56 ++++++++++++++++++++++----------------------- tools/saber_gcov.sh | 23 ++++++------------- 2 files changed, 35 insertions(+), 44 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 75daf1aee..83f258ea3 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -128,6 +128,17 @@ else() message( STATUS "SABER block SPECTRALB is NOT enabled" ) endif() +if( BUILD_TESTING AND ENABLE_OFFLINE_CODECOV ) + ## Code coverage + message( STATUS "Offline code coverage is enabled" ) + set( CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -fprofile-arcs -ftest-coverage") + set( CMAKE_CXX_LINK_FLAGS "${CMAKE_CXX_LINK_FLAGS} -fprofile-arcs -ftest-coverage") + set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fprofile-arcs -ftest-coverage") + set( CMAKE_Fortran_LINK_FLAGS "${CMAKE_Fortran_LINK_FLAGS} -fprofile-arcs -ftest-coverage") +else() + message( STATUS "Offline code coverage is not enabled" ) +endif() + ## Sources add_subdirectory( src/saber ) add_subdirectory( tools ) @@ -151,36 +162,25 @@ else() endif() if( BUILD_TESTING ) - # Test data - find_package( jedi-model-data 1.0.0 QUIET ) - - ## Code coverage - if ( ENABLE_OFFLINE_CODECOV ) - message( STATUS "Offline code coverage is enabled" ) - set( CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -fprofile-arcs -ftest-coverage") - set( CMAKE_CXX_LINK_FLAGS "${CMAKE_CXX_LINK_FLAGS} -fprofile-arcs -ftest-coverage") - set( CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fprofile-arcs -ftest-coverage") - set( CMAKE_Fortran_LINK_FLAGS "${CMAKE_Fortran_LINK_FLAGS} -fprofile-arcs -ftest-coverage") - else() - message( STATUS "Offline code coverage is not enabled" ) - endif() - - # If test data repo found build the tests - if( jedi-model-data_FOUND ) - message( STATUS "jedi-model-data found; building saber tests" ) - add_subdirectory( test ) - else() - message( STATUS "jedi-model-data not found; skipping saber tests" ) - endif() - - ## Global tests - ecbuild_add_test( TARGET saber_coding_norms_src - TYPE SCRIPT - COMMAND ${CMAKE_BINARY_DIR}/bin/${PROJECT_NAME}_cpplint.py - ARGS --quiet --recursive ${CMAKE_SOURCE_DIR}/${PROJECT_NAME}/src ) + # Test data + find_package( jedi-model-data 1.0.0 QUIET ) + + # If test data repo found build the tests + if( jedi-model-data_FOUND ) + message( STATUS "jedi-model-data found; building saber tests" ) + add_subdirectory( test ) + else() + message( STATUS "jedi-model-data not found; skipping saber tests" ) + endif() + + ## Global tests + ecbuild_add_test( TARGET saber_coding_norms_src + TYPE SCRIPT + COMMAND ${CMAKE_BINARY_DIR}/bin/${PROJECT_NAME}_cpplint.py + ARGS --quiet --recursive ${CMAKE_SOURCE_DIR}/${PROJECT_NAME}/src ) endif() if( ENABLE_QUENCH ) - add_subdirectory( quench ) + add_subdirectory( quench ) endif() ## Package Config diff --git a/tools/saber_gcov.sh b/tools/saber_gcov.sh index fa570837d..838e6e425 100755 --- a/tools/saber_gcov.sh +++ b/tools/saber_gcov.sh @@ -26,10 +26,14 @@ else fi # Hard-coded parameters -build_dir=${HOME}/build/gnu_10.3.0/bundle_debug +build_dir=${HOME}/build/jedi-bundle_codecov saber_dirs=" +bifourier +blocks bump -external +diffusion +fastlam +generic gsi interpolation oops @@ -37,19 +41,6 @@ spectralb util vader" -# Process output with gcov -for dir in ${saber_dirs}; do - cd ${build_dir}/saber/src/saber/CMakeFiles/saber.dir/${dir} - for file in $(ls *.F90.gcda *.F90.gcno); do - newfile=$(echo ${file} | sed -e 's/\.F90\././1') - if [ ! -f ${newfile} ]; then - ln -sf ${file} ${newfile} - fi - done - ln -sf ${build_dir}/saber/src/saber/${dir}/*.F90 . - gcov *.F90 -done - # Process output with lcov cd ${build_dir}/saber/src/saber/CMakeFiles/saber.dir rm -fr coverage.info html @@ -63,7 +54,7 @@ if [[ ${final_tar} == "true" ]]; then tar -cf coverage.tar html elif [[ ${final_tar} == "false" ]]; then # Open html with firefox - firefox html/saber/src/saber/bump/index.html + firefox html/index.html else # Wrong final_tar argument echo "Error: wrong final_tar argument, should be true or false" From 8ae1ea2b604f4d8da00514821f5e9413234978e6 Mon Sep 17 00:00:00 2001 From: Anna Shlyaeva Date: Wed, 15 Apr 2026 07:57:04 -0600 Subject: [PATCH 189/199] Add a block-diagonal coupled covariance with optional common outer blocks (#1186) * Introduce HybridBlockChain * Add a block diagonal coupled covariance * Add common outer blocks option * different implementation for common outer blocks * Changes to new implementation of component 4D classes in oops * Introduce HybridBlockChain * trigger CI * Some updates + a fake balance block * Bugfix: different interpolator for bg/fg * an oopsie bug * Hybrid block chain: cleanup and remove fake blocks (#1131) * Introduce HybridBlockChain * Cleanup and remove fake blocks --------- Co-authored-by: Anna Shlyaeva * fix indentation * Bugfix for couplederrorcovariance * Another bugfix for couplederrorcovariance * Make the balance non-triangular; fix a bug * All tests passing * Consistent handling of parameters * Trigger tests: * keep localHybridGeom_ in scope long enough * Address Anna's comments * Trigger CI with updated jjtests * Updates for merge * updates for merge * remove fake balance block that was used for debugging * simplify if statement and add check for duplicated variables * trigger CI --------- Co-authored-by: Anna Shlyaeva Co-authored-by: Benjamin Menetrier Co-authored-by: mo-joshuacolclough Co-authored-by: Nate Crossette --- quench/mains/CMakeLists.txt | 9 +- .../quenchCoupledErrorCovarianceToolbox.cc | 19 + quench/src/ModelData.h | 6 + quench/src/Traits.h | 15 + src/saber/CMakeLists.txt | 2 +- src/saber/coupled/CMakeLists.txt | 15 + src/saber/coupled/CoupledErrorCovariance.h | 445 ++++++++++++++++++ .../CoupledErrorCovarianceParameters.h | 52 ++ .../coupled/instantiateCoupledCovarFactory.h | 42 ++ test/CMakeLists.txt | 6 +- test/testdeps/coupled_dirac_id.txt | 0 test/testinput/coupled_dirac_id.yaml | 112 +++++ test/testlist/saber_test_tier1-coupled.txt | 1 + test/testref/coupled_dirac_id.ref | 57 +++ 14 files changed, 778 insertions(+), 3 deletions(-) create mode 100644 quench/mains/quenchCoupledErrorCovarianceToolbox.cc create mode 100644 src/saber/coupled/CMakeLists.txt create mode 100644 src/saber/coupled/CoupledErrorCovariance.h create mode 100644 src/saber/coupled/CoupledErrorCovarianceParameters.h create mode 100644 src/saber/coupled/instantiateCoupledCovarFactory.h create mode 100644 test/testdeps/coupled_dirac_id.txt create mode 100644 test/testinput/coupled_dirac_id.yaml create mode 100644 test/testlist/saber_test_tier1-coupled.txt create mode 100644 test/testref/coupled_dirac_id.ref diff --git a/quench/mains/CMakeLists.txt b/quench/mains/CMakeLists.txt index b3e897374..59f3f1bf0 100644 --- a/quench/mains/CMakeLists.txt +++ b/quench/mains/CMakeLists.txt @@ -24,9 +24,16 @@ ecbuild_add_executable( TARGET saber_quench_convertstate.x vader saber ) +ecbuild_add_executable( TARGET saber_quench_coupled_error_covariance_toolbox.x + SOURCES quenchCoupledErrorCovarianceToolbox.cc + LIBS quench + vader + ${gsibec_LIBRARIES} + saber ) + # Add RPATH for Torch libraries if found if( Torch_FOUND AND DEFINED Torch_ROOT ) - foreach(target saber_quench_error_covariance_toolbox.x saber_quench_process_perts.x saber_quench_convertstate.x) + foreach(target saber_quench_error_covariance_toolbox.x saber_quench_process_perts.x saber_quench_convertstate.x saber_quench_coupled_error_covariance_toolbox.x) get_target_property(EXISTING_RPATH ${target} BUILD_RPATH) if(EXISTING_RPATH) set_target_properties( ${target} PROPERTIES diff --git a/quench/mains/quenchCoupledErrorCovarianceToolbox.cc b/quench/mains/quenchCoupledErrorCovarianceToolbox.cc new file mode 100644 index 000000000..7a5c2135b --- /dev/null +++ b/quench/mains/quenchCoupledErrorCovarianceToolbox.cc @@ -0,0 +1,19 @@ +/* + * (C) Copyright 2025- UCAR. + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ + +#include "oops/coupled/TraitCoupled.h" +#include "oops/runs/Run.h" +#include "saber/coupled/instantiateCoupledCovarFactory.h" +#include "saber/oops/ErrorCovarianceToolbox.h" +#include "src/Traits.h" + +int main(int argc, char ** argv) { + oops::Run run(argc, argv); + saber::instantiateCoupledCovarFactory(); + saber::ErrorCovarianceToolbox> ect; + return run.execute(ect); +} diff --git a/quench/src/ModelData.h b/quench/src/ModelData.h index 72a2bffdc..bd1257df1 100644 --- a/quench/src/ModelData.h +++ b/quench/src/ModelData.h @@ -10,6 +10,7 @@ #include #include +#include #include "eckit/config/LocalConfiguration.h" @@ -36,6 +37,11 @@ class ModelData : public util::Printable, // Model data accessor const eckit::LocalConfiguration modelData() const {return modelData_;} + static const oops::Variables defaultVariables() { + return oops::Variables(std::vector{"air_horizontal_streamfunction", + "air_horizontal_velocity_potential", "air_temperature"}); + } + private: // Print void print(std::ostream & os) const diff --git a/quench/src/Traits.h b/quench/src/Traits.h index f56c8ccb2..226801658 100644 --- a/quench/src/Traits.h +++ b/quench/src/Traits.h @@ -40,4 +40,19 @@ struct Traits { typedef quench::VariableChange VariableChange; }; +struct Traits2 { + static std::string name() + {return "quench2";} + static std::string nameCovar() + {return "quenchCovariance2";} + + typedef quench::Covariance Covariance; + typedef quench::Geometry Geometry; + typedef quench::Increment Increment; + typedef quench::LinearVariableChange LinearVariableChange; + typedef quench::ModelData ModelData; + typedef quench::State State; + typedef quench::VariableChange VariableChange; +}; + } // namespace quench diff --git a/src/saber/CMakeLists.txt b/src/saber/CMakeLists.txt index 8cd6c5255..aaf7e1dc5 100644 --- a/src/saber/CMakeLists.txt +++ b/src/saber/CMakeLists.txt @@ -4,7 +4,7 @@ # which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. # Build list of subdirs with files to add -set( _subdirs bifourier blocks bump diffusion fastlam generic gsi interpolation oops spectralb torchbalance util vader ) +set( _subdirs bifourier blocks bump coupled diffusion fastlam generic gsi interpolation oops spectralb torchbalance util vader ) foreach( _subdir IN LISTS _subdirs ) add_subdirectory( ${_subdir} ) list( TRANSFORM ${_subdir}_src_files PREPEND ${_subdir}/ ) diff --git a/src/saber/coupled/CMakeLists.txt b/src/saber/coupled/CMakeLists.txt new file mode 100644 index 000000000..c9969ae08 --- /dev/null +++ b/src/saber/coupled/CMakeLists.txt @@ -0,0 +1,15 @@ +# (C) Copyright 2025- UCAR. +# (C) Copyright 2025- NOAA/EMC. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + +list( APPEND coupled_src_files_list +instantiateCoupledCovarFactory.h + +CoupledErrorCovariance.h + +CoupledErrorCovarianceParameters.h +) + +set( coupled_src_files ${coupled_src_files_list} PARENT_SCOPE ) diff --git a/src/saber/coupled/CoupledErrorCovariance.h b/src/saber/coupled/CoupledErrorCovariance.h new file mode 100644 index 000000000..5f1be8a0c --- /dev/null +++ b/src/saber/coupled/CoupledErrorCovariance.h @@ -0,0 +1,445 @@ +/* + * (C) Copyright 2025- UCAR + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ + +#pragma once + +#include +#include +#include + +#include "atlas/field.h" + +#include "eckit/mpi/Comm.h" + +#include "oops/assimilation/GMRESR.h" +#include "oops/base/Geometry.h" +#include "oops/base/IdentityMatrix.h" +#include "oops/base/Increment.h" +#include "oops/base/Increment4D.h" +#include "oops/base/ModelSpaceCovarianceBase.h" +#include "oops/base/State.h" +#include "oops/base/State4D.h" +#include "oops/base/Variables.h" +#include "oops/coupled/TraitCoupled.h" +#include "oops/coupled/UtilsCoupled.h" +#include "oops/util/FieldSetOperations.h" +#include "oops/util/FieldSetSubCommunicators.h" +#include "oops/util/Logger.h" +#include "oops/util/ObjectCounter.h" +#include "oops/util/Printable.h" +#include "oops/util/Timer.h" + +#include "saber/blocks/SaberBlockChainBase.h" +#include "saber/coupled/CoupledErrorCovarianceParameters.h" +#include "saber/oops/ErrorCovarianceParameters.h" +#include "saber/oops/Utilities.h" + +namespace saber { + +// ----------------------------------------------------------------------------- +/// \brief Coupled error covariance. +/// \details Implements block-diagonal error covariance for coupled models, with +/// optional common outer blocks. +/// If common outer blocks are specified, two identical common outer blocks chains +/// are created, one for each component model, operating on its geometry. +/// oops::GlobalInterpolator is used to interpolate backgrounds and inputs to the +/// component models' geometries. +template +class CoupledErrorCovariance + : public oops::ModelSpaceCovarianceBase>, + public util::Printable, + private util::ObjectCounter> { + typedef oops::TraitCoupled COUPLED; + typedef oops::Geometry Geometry_; + typedef oops::Increment Increment_; + typedef oops::Increment4D Increment4D_; + typedef oops::State4D State4D_; + + public: + static const std::string classname() {return "saber::CoupledErrorCovariance";} + + CoupledErrorCovariance(const Geometry_ &, const oops::Variables &, + const eckit::Configuration &, + const State4D_ &, const State4D_ &); + virtual ~CoupledErrorCovariance() = default; + + void multiply(const Increment4D_ & dxi, Increment4D_ & dxo) const {this->doMultiply(dxi, dxo);} + + private: + CoupledErrorCovariance(const CoupledErrorCovariance&); + CoupledErrorCovariance& operator=(const CoupledErrorCovariance&); + + void doRandomize(Increment4D_ &) const override; + void doMultiply(const Increment4D_ &, Increment4D_ &) const override; + void doInverseMultiply(const Increment4D_ &, Increment4D_ &) const override; + + void print(std::ostream &) const override; + + /// Chain of blocks (hybrid or ensemble or parametric) for each component model + std::unique_ptr blockChain1_; + std::unique_ptr blockChain2_; + /// @brief Interpolation operators to the other model's geometry (if needed) + std::unique_ptr interp12_; + std::unique_ptr interp21_; + /// Variables for each component model + const std::vector incVars_; + /// @brief Common outer block chains, one for each model (if needed) + std::unique_ptr commonOuterBlockChain1_; + std::unique_ptr commonOuterBlockChain2_; + + /// Helper method to create block chain for a component model + template + std::unique_ptr createBlockChain( + const oops::Geometry & geom, + const oops::Variables & vars, + const ErrorCovarianceParameters & params, + const oops::State4D & xb, + const oops::State4D & fg); +}; + +// ----------------------------------------------------------------------------- + +template +CoupledErrorCovariance::CoupledErrorCovariance(const Geometry_ & geom, + const oops::Variables & incVars, + const eckit::Configuration & config, + const State4D_ & xb, + const State4D_ & fg) + : oops::ModelSpaceCovarianceBase(geom, config, xb, fg), + incVars_(oops::splitVariables(incVars, geom.geometry().variables())) +{ + oops::Log::trace() << "CoupledErrorCovariance::CoupledErrorCovariance starting" << std::endl; + util::Timer timer(classname(), "CoupledErrorCovariance"); + // Deserialize parameters and fill configuration with missing values + CoupledErrorCovarianceParameters params; + params.deserialize(config); + eckit::LocalConfiguration fullConf; + params.serialize(fullConf); + + // Change xb/fg to inner loop resolution + State4D_ xb_lowres(geom, xb); + State4D_ fg_lowres(geom, fg); + // Create State4D objects for each component model + oops::State4D xb1 = share_state1(xb_lowres); + oops::State4D xb2 = share_state2(xb_lowres); + oops::State4D fg1 = share_state1(fg_lowres); + oops::State4D fg2 = share_state2(fg_lowres); + + // Create block chains for each component model + blockChain1_ = createBlockChain(geom.geometry().geometry1(), incVars_[0], + params.errorCov1.value(), xb1, fg1); + blockChain2_ = createBlockChain(geom.geometry().geometry2(), incVars_[1], + params.errorCov2.value(), xb2, fg2); + + // Create interpolation operators to other component's geometry if needed + if (params.interp.value() && params.commonOuterBlocks.value()) { + // Check that there are no overlapping variables between the two components + oops::Variables overlap = xb1.variables(); + overlap.intersection(xb2.variables()); + ASSERT(overlap.size() == 0); + overlap = fg1.variables(); + overlap.intersection(fg2.variables()); + ASSERT(overlap.size() == 0); + + // Create interpolators + interp12_ = std::make_unique( + params.interp.value()->interp1.value(), + geom.geometry().geometry1().generic(), + geom.geometry().geometry2().generic().functionSpace(), + geom.geometry().geometry2().generic().comm()); + interp21_ = std::make_unique( + params.interp.value()->interp2.value(), + geom.geometry().geometry2().generic(), + geom.geometry().geometry1().generic().functionSpace(), + geom.geometry().geometry1().generic().comm()); + + // Local copy of background and first guess that can undergo interpolation + oops::FieldSet4D fset4dXb1(xb.times(), xb.commTime(), geom.geometry().getComm()); + oops::FieldSet4D fset4dFg1(fg.times(), fg.commTime(), geom.geometry().getComm()); + oops::FieldSet4D fset4dXb2(xb.times(), xb.commTime(), geom.geometry().getComm()); + oops::FieldSet4D fset4dFg2(fg.times(), fg.commTime(), geom.geometry().getComm()); + + for (size_t jt = 0; jt < xb.size(); ++jt) { + // Get background and first guess fieldsets for both components + oops::FieldSet3D fset1xb = oops::copyFieldSet3D(xb1[jt].fieldSet()); + oops::FieldSet3D fset2xb = oops::copyFieldSet3D(xb2[jt].fieldSet()); + oops::FieldSet3D fset1fg = oops::copyFieldSet3D(fg1[jt].fieldSet()); + oops::FieldSet3D fset2fg = oops::copyFieldSet3D(fg2[jt].fieldSet()); + // Interpolate states to the other component geometry + atlas::FieldSet fset1xb_interp, fset2xb_interp; + atlas::FieldSet fset1fg_interp, fset2fg_interp; + interp12_->apply(fset1xb.fieldSet(), fset1xb_interp); + interp12_->apply(fset1fg.fieldSet(), fset1fg_interp); + interp21_->apply(fset2xb.fieldSet(), fset2xb_interp); + interp21_->apply(fset2fg.fieldSet(), fset2fg_interp); + // Add interpolated fields to the relevant fieldsets + for (auto & field : fset2xb_interp) fset1xb.add(field); + for (auto & field : fset1xb_interp) fset2xb.add(field); + for (auto & field : fset2fg_interp) fset1fg.add(field); + for (auto & field : fset1fg_interp) fset2fg.add(field); + // Assign to the 4D fieldsets + fset4dXb1[jt].shallowCopy(fset1xb); + fset4dXb2[jt].shallowCopy(fset2xb); + fset4dFg1[jt].shallowCopy(fset1fg); + fset4dFg2[jt].shallowCopy(fset2fg); + } + // Create common outer block chains for each component model + commonOuterBlockChain1_ = std::make_unique( + geom.geometry().geometry1().generic(), + incVars, + fset4dXb1, + fset4dFg1, + fullConf, + *params.commonOuterBlocks.value()); + commonOuterBlockChain2_ = std::make_unique( + geom.geometry().geometry2().generic(), + incVars, + fset4dXb2, + fset4dFg2, + fullConf, + *params.commonOuterBlocks.value()); + } + oops::Log::trace() << "CoupledErrorCovariance::CoupledErrorCovariance done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +template +template +std::unique_ptr + CoupledErrorCovariance::createBlockChain( + const oops::Geometry & geom, + const oops::Variables & vars, + const ErrorCovarianceParameters & params, + const oops::State4D & xb, + const oops::State4D & fg) { + + // Local copy of background and first guess that can undergo interpolation + std::unique_ptr fset4dXb; + std::unique_ptr fset4dFg; + + // Change resolution if needed + if (params.changeBackgroundResolution) { + const oops::State4D xb_lowres(geom, xb); + const oops::State4D fg_lowres(geom, fg); + const oops::FieldSet4D fset4dXbTmp(xb_lowres); + const oops::FieldSet4D fset4dFgTmp(fg_lowres); + fset4dXb = std::make_unique(oops::copyFieldSet4D(fset4dXbTmp)); + fset4dFg = std::make_unique(oops::copyFieldSet4D(fset4dFgTmp)); + } else { + const oops::FieldSet4D fset4dXbTmp(xb); + const oops::FieldSet4D fset4dFgTmp(fg); + fset4dXb = std::make_unique(oops::copyFieldSet4D(fset4dXbTmp)); + fset4dFg = std::make_unique(oops::copyFieldSet4D(fset4dFgTmp)); + } + + // Initialize outer variables + const std::vector vlevs = geom.variableSizes(vars); + oops::Variables outerVars(vars); + for (std::size_t i = 0; i < vlevs.size() ; ++i) { + outerVars[i].setLevels(vlevs[i]); + } + + // Create block chain + return SaberBlockChainFactory::create( + geom, + outerVars, + *fset4dXb, + *fset4dFg, + params.toConfiguration()); +} + +// ----------------------------------------------------------------------------- + +template +void CoupledErrorCovariance::doRandomize(Increment4D_ & dx) const { + oops::Log::trace() << "CoupledErrorCovariance::doRandomize starting" << std::endl; + util::Timer timer(classname(), "doRandomize"); + + oops::Increment4D dx1 = share_increment1(dx); + oops::Increment4D dx2 = share_increment2(dx); + + // This extra fieldset is only needed for backward compatibility in tests + oops::FieldSet4D fset4dSum1(dx1.times(), dx1.commTime(), dx1.geometry().getComm()); + for (size_t jtime = 0; jtime < fset4dSum1.size(); ++jtime) { + fset4dSum1[jtime].init(blockChain1_->outerFunctionSpace(), + blockChain1_->outerVariables(), + 0.0); + } + + oops::FieldSet4D fset4dSum2(dx2.times(), dx2.commTime(), dx2.geometry().getComm()); + for (size_t jtime = 0; jtime < fset4dSum2.size(); ++jtime) { + fset4dSum2[jtime].init(blockChain2_->outerFunctionSpace(), + blockChain2_->outerVariables(), + 0.0); + } + + // Create FieldSet4D, run randomize on them + oops::FieldSet4D fset4d1(dx1.times(), dx1.commTime(), dx1.geometry().getComm()); + oops::FieldSet4D fset4d2(dx2.times(), dx2.commTime(), dx2.geometry().getComm()); + + blockChain1_->randomize(fset4d1); + blockChain2_->randomize(fset4d2); + + // If there are common outer blocks, interpolate, apply, and interpolate back + if (commonOuterBlockChain1_ && commonOuterBlockChain2_) { + // Interpolate to common geometry + for (size_t jt = 0; jt < fset4d1.size(); ++jt) { + atlas::FieldSet fset1_interp, fset2_interp; + interp12_->apply(fset4d1[jt].fieldSet(), fset1_interp); + interp21_->apply(fset4d2[jt].fieldSet(), fset2_interp); + for (auto & field : fset2_interp) { + fset4d1[jt].add(field); + } + for (auto & field : fset1_interp) { + fset4d2[jt].add(field); + } + } + // Apply common outer blocks + commonOuterBlockChain1_->applyOuterBlocks(fset4d1); + commonOuterBlockChain2_->applyOuterBlocks(fset4d2); + + // Remove the variables that were only needed as inputs for the + // common outer blocks + fset4d1.removeFields(incVars_[1]); + fset4d2.removeFields(incVars_[0]); + } + + // For backward compatibility in tests + fset4dSum1 += fset4d1; + fset4dSum2 += fset4d2; + + // ATLAS fieldset to Increment_ + for (size_t jtime = 0; jtime < dx1.size(); ++jtime) { + dx1[jtime].fromFieldSet(fset4dSum1[jtime].fieldSet()); + } + for (size_t jtime = 0; jtime < dx2.size(); ++jtime) { + dx2[jtime].fromFieldSet(fset4dSum2[jtime].fieldSet()); + } + + oops::Log::trace() << "CoupledErrorCovariance::doRandomize done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +template +void CoupledErrorCovariance::doMultiply(const Increment4D_ & dxi, + Increment4D_ & dxo) const { + oops::Log::trace() << "CoupledErrorCovariance::doMultiply starting" << std::endl; + util::Timer timer(classname(), "doMultiply"); + + // Copy input + dxo = dxi; + + oops::Increment4D dxo1 = share_increment1(dxo); + oops::Increment4D dxo2 = share_increment2(dxo); + + oops::FieldSet4D fset4d1(dxo1); + oops::FieldSet4D fset4d2(dxo2); + + // Extra fieldset only needed for backward compatibility in tests + oops::FieldSet4D fset4dSum1 = oops::copyFieldSet4D(fset4d1); + oops::FieldSet4D fset4dSum2 = oops::copyFieldSet4D(fset4d2); + fset4dSum1.zero(); + fset4dSum2.zero(); + + // If there are common outer blocks, interpolate inputs and apply them + if (commonOuterBlockChain1_ && commonOuterBlockChain2_) { + // Interpolate to common geometry + for (size_t jt = 0; jt < fset4d1.size(); ++jt) { + atlas::FieldSet fset1_interp, fset2_interp; + interp12_->apply(fset4d1[jt].fieldSet(), fset1_interp); + interp21_->apply(fset4d2[jt].fieldSet(), fset2_interp); + for (auto & field : fset2_interp) { + fset4d1[jt].add(field); + } + for (auto & field : fset1_interp) { + fset4d2[jt].add(field); + } + } + + // Apply common outer blocks + commonOuterBlockChain1_->applyOuterBlocksAD(fset4d1); + commonOuterBlockChain2_->applyOuterBlocksAD(fset4d2); + + // Remove the variables that were only needed as inputs for the + // common outer blocks + fset4d1.removeFields(incVars_[1]); + fset4d2.removeFields(incVars_[0]); + } + + // Apply SABER block chains + blockChain1_->multiply(fset4d1); + blockChain2_->multiply(fset4d2); + + // If there are common outer blocks, interpolate, apply, and interpolate back + if (commonOuterBlockChain1_ && commonOuterBlockChain2_) { + // Interpolate to common geometry + for (size_t jt = 0; jt < fset4d1.size(); ++jt) { + atlas::FieldSet fset1_interp, fset2_interp; + interp12_->apply(fset4d1[jt].fieldSet(), fset1_interp); + interp21_->apply(fset4d2[jt].fieldSet(), fset2_interp); + for (auto & field : fset2_interp) { + fset4d1[jt].add(field); + } + for (auto & field : fset1_interp) { + fset4d2[jt].add(field); + } + } + // Apply common outer blocks + commonOuterBlockChain1_->applyOuterBlocks(fset4d1); + commonOuterBlockChain2_->applyOuterBlocks(fset4d2); + + // Remove the variables that were only needed as inputs for the + // common outer blocks + fset4d1.removeFields(incVars_[1]); + fset4d2.removeFields(incVars_[0]); + } + + // For backward compatibility in tests + fset4dSum1 += fset4d1; + fset4dSum2 += fset4d2; + + // ATLAS fieldset to Increment + for (size_t jtime = 0; jtime < dxo1.size(); ++jtime) { + dxo1[jtime].fromFieldSet(fset4dSum1[jtime].fieldSet()); + } + for (size_t jtime = 0; jtime < dxo2.size(); ++jtime) { + dxo2[jtime].fromFieldSet(fset4dSum2[jtime].fieldSet()); + } + + oops::Log::trace() << "CoupledErrorCovariance::doMultiply done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +template +void CoupledErrorCovariance::doInverseMultiply(const Increment4D_ & dxi, + Increment4D_ & dxo) const { + oops::Log::trace() << "CoupledErrorCovariance::doInverseMultiply starting" << std::endl; + util::Timer timer(classname(), "doInverseMultiply"); + + // Iterative inverse - this operates on the full coupled increment + oops::IdentityMatrix Id; + dxo.zero(); + GMRESR(dxo, dxi, *this, Id, 10, 1.0e-3); + + oops::Log::trace() << "CoupledErrorCovariance::doInverseMultiply done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +template +void CoupledErrorCovariance::print(std::ostream & os) const { + oops::Log::trace() << "CoupledErrorCovariance::print starting" << std::endl; + os << "SABER CoupledErrorCovariance"; + oops::Log::trace() << "CoupledErrorCovariance::print done" << std::endl; +} + +// ----------------------------------------------------------------------------- + +} // namespace saber diff --git a/src/saber/coupled/CoupledErrorCovarianceParameters.h b/src/saber/coupled/CoupledErrorCovarianceParameters.h new file mode 100644 index 000000000..e936c548f --- /dev/null +++ b/src/saber/coupled/CoupledErrorCovarianceParameters.h @@ -0,0 +1,52 @@ +/* + * (C) Copyright 2025- UCAR + * (C) Copyright 2025- NOAA/EMC + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ + +#pragma once + +#include + +#include "oops/coupled/TraitCoupled.h" +#include "oops/util/parameters/Parameters.h" +#include "oops/util/parameters/RequiredParameter.h" + +#include "saber/oops/ErrorCovarianceParameters.h" + +namespace saber { + +/// @brief Parameters class for interpolation configurations for coupled error covariance +template +class InterpolationForCoupledErrorCovarianceParameters : public oops::Parameters { + OOPS_CONCRETE_PARAMETERS(InterpolationForCoupledErrorCovarianceParameters, Parameters) + public: + oops::RequiredParameter + interp1{MODEL1::name().c_str(), this}; + oops::RequiredParameter + interp2{MODEL2::name().c_str(), this}; +}; + +// ------------------------------------------------------------------------------------------------- +/// Parameters class for block-diagonal SABER coupled error covariance +template +class CoupledErrorCovarianceParameters : public ErrorCovarianceParametersBase { + OOPS_CONCRETE_PARAMETERS(CoupledErrorCovarianceParameters, ErrorCovarianceParametersBase) + + public: + oops::RequiredParameter + errorCov1{MODEL1::name().c_str(), this}; + oops::RequiredParameter + errorCov2{MODEL2::name().c_str(), this}; + + oops::OptionalParameter> + commonOuterBlocks{"common outer blocks", this}; + oops::OptionalParameter> + interp{"interpolation", this}; +}; + +// ----------------------------------------------------------------------------- + +} // namespace saber diff --git a/src/saber/coupled/instantiateCoupledCovarFactory.h b/src/saber/coupled/instantiateCoupledCovarFactory.h new file mode 100644 index 000000000..2d94cb4a9 --- /dev/null +++ b/src/saber/coupled/instantiateCoupledCovarFactory.h @@ -0,0 +1,42 @@ +/* + * (C) Copyright 2025- UCAR + * (C) Copyright 2025- NOAA/EMC + * + * This software is licensed under the terms of the Apache Licence Version 2.0 + * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. + */ + +#pragma once + +#include "oops/base/instantiateCovarFactory.h" +#include "oops/coupled/BlockDiagonalCovarianceCoupled.h" +#include "oops/coupled/TraitCoupled.h" + +#include "saber/blocks/instantiateBlockChainFactory.h" +#include "saber/coupled/CoupledErrorCovariance.h" +#include "saber/oops/ErrorCovariance.h" +#include "saber/oops/instantiateCovarFactory.h" +#include "saber/oops/instantiateLocalizationFactory.h" + +namespace saber { + +// ----------------------------------------------------------------------------- + +template void instantiateCoupledCovarFactory() { + // covariances both for coupled and single models + saber::instantiateCovarFactory>(); + saber::instantiateCovarFactory(); + saber::instantiateCovarFactory(); + // oops block diagonal covariance + static oops::CovarMaker, + oops::BlockDiagonalCovarianceCoupled > + makerCoupled_("Coupled Block Diagonal"); + // saber coupled covariance + static oops::CovarMaker, + CoupledErrorCovariance > + makerSABERCoupled_("SABER coupled"); +} + +// ----------------------------------------------------------------------------- + +} // namespace saber diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index aadc95182..c1373560b 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -107,6 +107,8 @@ if( ENABLE_QUENCH ) message( STATUS " - TIER 1 base" ) file( STRINGS testlist/saber_test_tier1.txt saber_test ) list( APPEND saber_test_full ${saber_test} ) + file( STRINGS testlist/saber_test_tier1-coupled.txt saber_test ) + list( APPEND saber_test_full ${saber_test} ) if( SABER_TEST_FASTLAM ) message( STATUS " - TIER 1 FastLAM-specific" ) file( STRINGS testlist/saber_test_tier1-fastlam.txt saber_test ) @@ -273,7 +275,7 @@ if( ENABLE_QUENCH ) endif() # Executables list - list( APPEND exe_list convertcov convertstate randomization error_covariance_training process_perts dirac ) + list( APPEND exe_list convertcov convertstate randomization error_covariance_training process_perts dirac coupled ) # Loop over MPI/OpenMP configurations foreach( mpi omp IN ZIP_LISTS mpi_list omp_list ) @@ -285,6 +287,8 @@ if( ENABLE_QUENCH ) set( exename "convertstate" ) elseif ("${exe}" STREQUAL "process_perts" ) set( exename "process_perts" ) + elseif ("${exe}" STREQUAL "coupled" ) + set( exename "coupled_error_covariance_toolbox" ) else() set( exename "error_covariance_toolbox" ) endif() diff --git a/test/testdeps/coupled_dirac_id.txt b/test/testdeps/coupled_dirac_id.txt new file mode 100644 index 000000000..e69de29bb diff --git a/test/testinput/coupled_dirac_id.yaml b/test/testinput/coupled_dirac_id.yaml new file mode 100644 index 000000000..64bd887a6 --- /dev/null +++ b/test/testinput/coupled_dirac_id.yaml @@ -0,0 +1,112 @@ +geometry: + quench: + function space: NodeColumns + grid: + name: CS-LFR-15 + partitioner: cubedsphere + halo: 1 + groups: + - variables: + - air_temperature + levels: 2 + halo: 1 + quench2: + function space: StructuredColumns + grid: + type: regular_gaussian + N: 10 + groups: + - variables: &vars + - air_horizontal_streamfunction + - air_horizontal_velocity_potential + levels: &levels 10 + halo: 1 + + quench exclude variables: + - air_horizontal_streamfunction + - air_horizontal_velocity_potential + quench2 exclude variables: + - air_temperature +background: + quench: + date: 2010-01-01T12:00:00Z + state variables: + - air_temperature + quench2: + date: 2010-01-01T12:00:00Z + state variables: + - air_horizontal_streamfunction + - air_horizontal_velocity_potential + +background error: + covariance model: SABER coupled + interpolation: + quench: + local interpolator type: oops unstructured grid interpolator + quench2: + local interpolator type: oops unstructured grid interpolator + common outer blocks: + - saber block name: StdDev + standard deviations: + - variable: air_horizontal_streamfunction + stddev: 2.0 + - variable: air_horizontal_velocity_potential + stddev: 2.0 + - variable: air_temperature + stddev: 2.0 + quench: + saber central block: + saber block name: ID + quench2: + saber central block: + saber block name: diffusion + read: + groups: + - variables: *vars + horizontal: + filepath: testdata/error_covariance_training_diffusion_2/hz-_MPI_-_OMP_ + vertical: + levels: *levels + filepath: testdata/error_covariance_training_diffusion_2/vt-_MPI_-_OMP_ +dirac: + quench: + lon: + - 0.0 + lat: + - -4.38894 + level: + - 1 + variable: + - air_temperature + quench2: + lon: + - 0.01 + - 180.01 + lat: + - 0.01 + - 88.01 + level: + - 1 + - 1 + variable: + - air_horizontal_streamfunction + - air_horizontal_velocity_potential +output dirac: + quench: + mpi pattern: '%MPI%' + filepath: testdata/coupled_dirac_id/%MPI%_dirac_%id% + quench2: + mpi pattern: '%MPI%' + filepath: testdata/coupled_dirac_id/%MPI%_dirac2_%id% +output variance: + quench: + mpi pattern: '%MPI%' + filepath: testdata/coupled_dirac_id/%MPI%_variance + formats: [default, gmsh] + quench2: + mpi pattern: '%MPI%' + filepath: testdata/coupled_dirac_id/%MPI%_variance2 + formats: [default, gmsh] +test: + reference filename: testref/coupled_dirac_id.ref + test output filename: testref/coupled_dirac_id.out diff --git a/test/testlist/saber_test_tier1-coupled.txt b/test/testlist/saber_test_tier1-coupled.txt new file mode 100644 index 000000000..61b2ac93d --- /dev/null +++ b/test/testlist/saber_test_tier1-coupled.txt @@ -0,0 +1 @@ +coupled_dirac_id \ No newline at end of file diff --git a/test/testref/coupled_dirac_id.ref b/test/testref/coupled_dirac_id.ref new file mode 100644 index 000000000..f8ec8f71c --- /dev/null +++ b/test/testref/coupled_dirac_id.ref @@ -0,0 +1,57 @@ +Input Dirac increment: +IncrementCoupled: quench + +- Valid time: 2010-01-01T12:00:00Z + Geometry: CS-LFR-15 [1350] + Fields: + - air_temperature (2 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 3.7037037037037035e-04 + + stddev = 1.9245008972986654e-02 + + +IncrementCoupled: quench2 + +- Valid time: 2010-01-01T12:00:00Z + Geometry: F10 [800] + Fields: + - air_horizontal_streamfunction (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 1.2500000000000000e-04 + + stddev = 1.1180339887497977e-02 + - air_horizontal_velocity_potential (10 levels): + + min = 0.0000000000000000e+00 + + max = 1.0000000000000000e+00 + + mean = 1.2500000000000000e-04 + + stddev = 1.1180339887497228e-02 + +Covariance(SABER coupled) * Increment: +IncrementCoupled: quench + +- Valid time: 2010-01-01T12:00:00Z + Geometry: CS-LFR-15 [1350] + Fields: + - air_temperature (2 levels): + + min = 0.0000000000000000e+00 + + max = 4.0000000000000000e+00 + + mean = 1.4814814814814814e-03 + + stddev = 7.6980035891949739e-02 + + +IncrementCoupled: quench2 + +- Valid time: 2010-01-01T12:00:00Z + Geometry: F10 [800] + Fields: + - air_horizontal_streamfunction (10 levels): + + min = 0.0000000000000000e+00 + + max = 3.8124013112978044e+00 + + mean = 2.7171863362235389e-03 + + stddev = 6.2610810357832364e-02 + - air_horizontal_velocity_potential (10 levels): + + min = 0.0000000000000000e+00 + + max = 3.8065697952602293e+00 + + mean = 2.1344080405865759e-02 + + stddev = 1.9294872194770990e-01 From 311c38e65f18934c5297b0cc8380e076a1fc9850 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Wed, 15 Apr 2026 15:16:13 +0000 Subject: [PATCH 190/199] WIP --- src/saber/blocks/SaberOuterBlockChain.h | 9 +- src/saber/interpolation/Interpolation.cc | 201 ++---------------- .../mgbf/covariance/mgbf_covariance_mod.f90 | 4 +- 3 files changed, 18 insertions(+), 196 deletions(-) diff --git a/src/saber/blocks/SaberOuterBlockChain.h b/src/saber/blocks/SaberOuterBlockChain.h index d2d2fe7f0..9a027057a 100644 --- a/src/saber/blocks/SaberOuterBlockChain.h +++ b/src/saber/blocks/SaberOuterBlockChain.h @@ -243,7 +243,7 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, std::shared_ptr fsetEns, const bool & centralDirectCalibration) { oops::Log::trace() << "SaberOuterBlockChain ctor starting" << std::endl; - oops::Log::info() << "Info xx : Creating outer blocks" << std::endl; + oops::Log::info() << "Info : Creating outer blocks" << std::endl; // In addition to other configuration option pass model data information for vader // TODO(AS): check whether conf needs to be passed to the blocks (ideally not) @@ -266,7 +266,6 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, geom.generic() : innerGeometryData(); // Initialize outer block - oops::Log::trace() << "SaberOuterBlockChain before initBlock" << std::endl; const auto[saberOuterBlockParams, currentOuterVars, activeVars] @@ -276,12 +275,6 @@ SaberOuterBlockChain::SaberOuterBlockChain(const oops::Geometry & geom, outerVars, fset4dXb, fset4dFg); - oops::Log::trace() << "SaberOuterBlockChain after initBlock" << std::endl; - - // Update MODEL geometry validity, by checking whether the inner geometry data returned by - // the last outer block shares the same reference as its own outer geometry data - validModelGeom = validModelGeom && - (&(outerBlocks_.back()->innerGeometryData()) == ¤tOuterGeometryData); // Update MODEL geometry validity, by checking whether the inner geometry data returned by // the last outer block shares the same reference as its own outer geometry data diff --git a/src/saber/interpolation/Interpolation.cc b/src/saber/interpolation/Interpolation.cc index 3618ef289..e18df4465 100644 --- a/src/saber/interpolation/Interpolation.cc +++ b/src/saber/interpolation/Interpolation.cc @@ -8,14 +8,10 @@ #include "saber/interpolation/Interpolation.h" #include "atlas/util/Config.h" -#include "atlas/util/Geometry.h" -#include "atlas/util/KDTree.h" #include "oops/util/FieldSetOperations.h" #include "oops/util/Logger.h" #include "oops/util/missingValues.h" -#include "mpi.h" //cltthinkdeb todo -#include //cltthink namespace saber { namespace interpolation { @@ -24,20 +20,17 @@ namespace interpolation { static SaberOuterBlockMaker makerInterpolation_("interpolation"); -// ----------------------------------------------------------------------------- - namespace { - void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, atlas::FieldSet & targetFieldSet, const oops::Variables & vars, const atlas::FunctionSpace & sourceFs, const atlas::FunctionSpace & targetFs) { if (vars.size() == 0) { - int mpirank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); - std::cout << "rank " << mpirank - << " fillMissingValuesNearest: no variables to process" << std::endl; + oops::Log::trace() + << Interpolation::classname() + << "fillMissingValuesNearest: no variables to process" + << std::endl; return; } @@ -57,10 +50,10 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, } } if (indices.empty()) { - int mpirank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); - std::cout << "rank " << mpirank - << " fillMissingValuesNearest: no owned source points" << std::endl; + oops::Log::trace() + << Interpolation::classname() + << "fillMissingValuesNearest: no owned source points" + << std::endl; return; } @@ -72,33 +65,19 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, const auto tgt_ghost = atlas::array::make_view(targetFs.ghost()); const double missing = util::missingValue(); - int mpirank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); - std::cout << "rank " << mpirank - << " fillMissingValuesNearest: processing vars = " - << vars.variables() << std::endl; for (const auto & var : vars) { if (!targetFieldSet.has(var.name()) || !sourceFieldSet.has(var.name())) { - std::cout << "rank " << mpirank - << " fillMissingValuesNearest: skipping var (missing in fset) " - << var.name() << std::endl; + oops::Log::trace() + << Interpolation::classname() + << "fillMissingValuesNearest: skipping var (missing in fset)" <(targetFieldSet[var.name()]); const auto src_view = atlas::array::make_view( sourceFieldSet.field(var.name())); - std::size_t missing_before = 0; - std::size_t missing_after = 0; - std::size_t filled = 0; - std::size_t logged = 0; - const bool log_values = (var.name() == "air_pressure_thickness"); - const std::size_t log_limit = 20; - const double small_value_threshold = 1.0e-6; - std::size_t small_after_fill = 0; - std::size_t small_logged = 0; - for (atlas::idx_t jloc = 0; jloc < tgt_view.shape(0); ++jloc) { if (tgt_ghost(jloc) != 0) { continue; @@ -107,73 +86,24 @@ void fillMissingValuesNearest(const atlas::FieldSet & sourceFieldSet, for (atlas::idx_t jlev = 0; jlev < tgt_view.shape(1); ++jlev) { if (tgt_view(jloc, jlev) == missing) { has_missing = true; - ++missing_before; break; } } if (!has_missing) { continue; } - atlas::PointLonLat pll(tgt_lonlat(jloc, 0), tgt_lonlat(jloc, 1)); const auto item = tree.closestPoint(pll); const atlas::idx_t src_index = item.payload(); for (atlas::idx_t jlev = 0; jlev < tgt_view.shape(1); ++jlev) { if (tgt_view(jloc, jlev) == missing) { tgt_view(jloc, jlev) = src_view(src_index, jlev); - ++filled; - if (std::abs(tgt_view(jloc, jlev)) < small_value_threshold) { - ++small_after_fill; - if (var.name() == "air_pressure_at_surface" && small_logged < log_limit) { - std::cout << "rank " << mpirank - << " small ps after fill: jloc=" << jloc - << " lev=" << jlev - << " lat=" << tgt_lonlat(jloc, 1) - << " lon=" << tgt_lonlat(jloc, 0) - << " src_index=" << src_index - << " value=" << tgt_view(jloc, jlev) - << std::endl; - ++small_logged; - } - } - if (log_values && logged < log_limit) { - std::cout << "rank " << mpirank - << " fillMissingValuesNearest: var=" << var.name() - << " jloc=" << jloc - << " lev=" << jlev - << " lat=" << tgt_lonlat(jloc, 1) - << " lon=" << tgt_lonlat(jloc, 0) - << " src_index=" << src_index - << " filled_value=" << tgt_view(jloc, jlev) - << std::endl; - ++logged; - } - } + } } } - - for (atlas::idx_t jloc = 0; jloc < tgt_view.shape(0); ++jloc) { - if (tgt_ghost(jloc) != 0) { - continue; - } - for (atlas::idx_t jlev = 0; jlev < tgt_view.shape(1); ++jlev) { - if (tgt_view(jloc, jlev) == missing) { - ++missing_after; - } - } - } - - std::cout << "rank " << mpirank - << " fillMissingValuesNearest: var=" << var.name() - << " missing_before=" << missing_before - << " filled=" << filled - << " missing_after=" << missing_after - << " small_after_fill=" << small_after_fill << std::endl; } } - } // namespace - // ----------------------------------------------------------------------------- Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, @@ -187,11 +117,10 @@ Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, activeVars_(params.activeVars.value().get_value_or(outerVars)), invVars_(params.inverseVars.value()) { - oops::Log::trace() << classname() << "::Interpolationthinkdeb555 starting" << std::endl; + oops::Log::trace() << classname() << "::Interpolation starting" << std::endl; // Set up GeometryData Geometry geom(params.innerGeom, outerGeometryData.comm()); - oops::Log::trace() << classname() << "::Interpolation after geom ctor" << std::endl; innerGeomData_.reset(new oops::GeometryData(geom.functionSpace(), geom.fields(), true, outerGeometryData.comm())); @@ -199,24 +128,10 @@ Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, globalInterp_.reset(new oops::GlobalInterpolator( params.forwardInterpConf.value(), *innerGeomData_, outerGeometryData.functionSpace(), outerGeometryData.comm())); - int mpirank; - MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); - std::ofstream file("mgbf_filtering_grid_latlon_"+std::to_string(mpirank)+".txt"); - innerGeomData_->functionSpace().lonlat().dump(file); - std::ofstream file2("model_native_grid_latlon_"+std::to_string(mpirank)+".txt"); - outerGeomData_.functionSpace().lonlat().dump(file2); } else if (params.interpType.value() == "regional") { regionalInterp_.reset(new atlas::Interpolation( - atlas::util::Config("type", "regional-linear-2d"), innerGeomData_->functionSpace(), outerGeometryData.functionSpace())); - int mpirank; - MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); - std::ofstream file("mgbf_filtering_grid_latlon_"+std::to_string(mpirank)+".txt"); - innerGeomData_->functionSpace().lonlat().dump(file); - std::ofstream file2("model_native_grid_latlon_"+std::to_string(mpirank)+".txt"); - outerGeomData_.functionSpace().lonlat().dump(file2); - } else { throw eckit::UserError("wrong interpolator type: " + params.interpType.value(), Here()); } @@ -228,7 +143,6 @@ Interpolation::Interpolation(const oops::GeometryData & outerGeometryData, void Interpolation::multiply(oops::FieldSet3D & fieldSet) const { oops::Log::trace() << classname() << "::multiply starting" << std::endl; - util::Timer timer(classname(), "multiply"); // Temporary FieldSet of active variables for interpolation source atlas::FieldSet sourceFieldSet; @@ -271,12 +185,9 @@ void Interpolation::multiply(oops::FieldSet3D & fieldSet) const { void Interpolation::multiplyAD(oops::FieldSet3D & fieldSet) const { oops::Log::trace() << classname() << "::multiplyAD starting" << std::endl; - util::Timer timer(classname(), "multiplyAD"); // Temporary FieldSet of active variables for interpolation target atlas::FieldSet targetFieldSet; - atlas::FieldSet backup_input_fieldset; - backup_input_fieldset.metadata()=fieldSet.fieldSet().metadata(); for (const auto & var : activeVars_) { targetFieldSet.add(fieldSet[var.name()]); } @@ -307,14 +218,6 @@ void Interpolation::multiplyAD(oops::FieldSet3D & fieldSet) const { } fieldSet.fieldSet() = sourceFieldSet; - - auto & dst_fset = fieldSet.fieldSet(); - if (backup_input_fieldset.metadata().has("ensemble member index")) { - oops::Log::trace() << classname() << "interpolationmultiplyAD 999 yes" << std::endl; - dst_fset.metadata().template set("ensemble member index", backup_input_fieldset.metadata().template get("ensemble member index")); - } - - oops::Log::trace() << classname() << "::multiplyAD done" << std::endl; } @@ -341,49 +244,12 @@ void Interpolation::inverseMultiply(oops::FieldSet3D & fieldSet) const { atlas::util::Config("type", "regional-linear-2d"), outerGeometryData_.functionSpace(), innerGeomData_->functionSpace())); } - // Temporary FieldSet of active variables for interpolation source atlas::FieldSet sourceFieldSet; for (const auto & var : invVars) { sourceFieldSet.add(fieldSet[var.name()]); } - // Debug check: model-grid ps before inverse interpolation - if (sourceFieldSet.has("air_pressure_at_surface")) { - const atlas::Field & psField = sourceFieldSet["air_pressure_at_surface"]; - const auto psView = atlas::array::make_view(psField); - const auto psGhost = atlas::array::make_view(psField.functionspace().ghost()); - const double missing = util::missingValue(); - std::size_t psMissingOwned = 0; - std::size_t psMissingHalo = 0; - double psMinOwned = std::numeric_limits::max(); - double psMaxOwned = -std::numeric_limits::max(); - for (atlas::idx_t jloc = 0; jloc < psView.shape(0); ++jloc) { - const bool isHalo = (psGhost(jloc) != 0); - for (atlas::idx_t jlev = 0; jlev < psView.shape(1); ++jlev) { - const double v = psView(jloc, jlev); - if (v == missing) { - if (isHalo) { - ++psMissingHalo; - } else { - ++psMissingOwned; - } - } else if (!isHalo) { - psMinOwned = std::min(psMinOwned, v); - psMaxOwned = std::max(psMaxOwned, v); - } - } - } - int mpirank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); - std::cout << "rank " << mpirank - << " leftInverseMultiply: model ps missing owned=" << psMissingOwned - << " halo=" << psMissingHalo - << " minOwned=" << psMinOwned - << " maxOwned=" << psMaxOwned - << std::endl; - } - // Interpolate to target/inner grid atlas::FieldSet targetFieldSet; if (inverseGlobalInterp_) { @@ -401,51 +267,14 @@ void Interpolation::inverseMultiply(oops::FieldSet3D & fieldSet) const { } inverseRegionalInterp_->execute(sourceFieldSet, targetFieldSet); } - if (params_.fillMissingValues.value()) { fillMissingValuesNearest(sourceFieldSet, targetFieldSet, invVars, - outerGeomData_.functionSpace(), + outerGeometryData_.functionSpace(), innerGeomData_->functionSpace()); // Update halos after filling missing values so boundary points are consistent targetFieldSet.haloExchange(); } - // Debug check: filtering-grid ps after inverse interpolation + halo exchange - if (targetFieldSet.has("air_pressure_at_surface")) { - const atlas::Field & psField = targetFieldSet["air_pressure_at_surface"]; - const auto psView = atlas::array::make_view(psField); - const auto psGhost = atlas::array::make_view(psField.functionspace().ghost()); - const double missing = util::missingValue(); - std::size_t psMissingOwned = 0; - std::size_t psMissingHalo = 0; - double psMinOwned = std::numeric_limits::max(); - double psMaxOwned = -std::numeric_limits::max(); - for (atlas::idx_t jloc = 0; jloc < psView.shape(0); ++jloc) { - const bool isHalo = (psGhost(jloc) != 0); - for (atlas::idx_t jlev = 0; jlev < psView.shape(1); ++jlev) { - const double v = psView(jloc, jlev); - if (v == missing) { - if (isHalo) { - ++psMissingHalo; - } else { - ++psMissingOwned; - } - } else if (!isHalo) { - psMinOwned = std::min(psMinOwned, v); - psMaxOwned = std::max(psMaxOwned, v); - } - } - } - int mpirank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &mpirank); - std::cout << "rank " << mpirank - << " leftInverseMultiply: filtering ps missing owned=" << psMissingOwned - << " halo=" << psMissingHalo - << " minOwned=" << psMinOwned - << " maxOwned=" << psMaxOwned - << std::endl; - } - // Reset fieldSet.fieldSet() = targetFieldSet; diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 53f87540c..626b91547 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -660,7 +660,7 @@ subroutine multiply(self, fields,index_member_in) vargrp_work_mgbf(1:nlev_vargrp(ivargrp),:,:) = work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) call btim(mg_anal_to_filt_time) - call self%intstate(jscale,ivargrp)%anal_to_filt_allmap \ + call self%intstate(jscale,ivargrp)%anal_to_filt_allmap & (vargrp_work_mgbf(1:nlev_vargrp(ivargrp),:,:)) call etim(mg_anal_to_filt_time) call btim(mg_filtering_time) @@ -669,7 +669,7 @@ subroutine multiply(self, fields,index_member_in) !cltorg call self%intstate%filt_to_anal_allmap(work_mgbf) call btim(mg_filt_to_anal_time) - call self%intstate(jscale,ivargrp)%filt_to_anal_allmap \ + call self%intstate(jscale,ivargrp)%filt_to_anal_allmap & (vargrp_work_mgbf2(1:nlev_vargrp(ivargrp),:,:)) call etim(mg_filt_to_anal_time) !clt# work_mgbf=999.0 !thinkdeb for debug From 232860be12309730bd8b6bab26b7083aeb972cf3 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Tue, 21 Apr 2026 23:33:50 +0000 Subject: [PATCH 191/199] changes according to copilot review in https://github.com/JCSDA-internal/saber/pull/1227 --- src/saber/mgbf/covariance/MGBF_Covariance.h | 1 + src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 12 ++++++++---- src/saber/mgbf/mgbf_lib/CMakeLists.txt | 2 +- src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 | 2 +- src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 | 5 +++-- src/saber/mgbf/mgbf_lib/phint.f90 | 3 ++- 6 files changed, 16 insertions(+), 9 deletions(-) diff --git a/src/saber/mgbf/covariance/MGBF_Covariance.h b/src/saber/mgbf/covariance/MGBF_Covariance.h index 9975ad567..6d717826d 100755 --- a/src/saber/mgbf/covariance/MGBF_Covariance.h +++ b/src/saber/mgbf/covariance/MGBF_Covariance.h @@ -44,6 +44,7 @@ class MGBF_CovarianceParameters: public SaberBlockParametersBase { public: oops::OptionalParameter SDL_MGBFNML{"mgbf sdl and vdl init namelist file", this}; oops::OptionalParameter MGBFNML{"mgbf namelist file", this}; + oops::OptionalParameter debugPrint{"debug print", this}; // Mandatory active variables oops::Variables mandatoryActiveVars() const override {return oops::Variables();} }; diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 626b91547..9401a9b56 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -125,6 +125,7 @@ subroutine create(self, comm, config, funcspace, background, firstguess) character(len=:), allocatable :: dump_json integer(i_kind):: max_nlevs +logical l_debug_print ! Hold communicator ! ----------------- @@ -135,10 +136,13 @@ subroutine create(self, comm, config, funcspace, background, firstguess) !clt call self%grid%create(config, comm) self%rank = comm%rank() -write(6,*)'thinkdeb mgbf create999 ' -write(6,*)'thinkdeb mgbf create999 config' - dump_json=config%json() ! serialize to a JSON string -write(6,'(A)')trim(dump_json) +l_debug_print = .false. +if (config%has("debug print")) call config%get_or_die("debug print", l_debug_print) + +if (l_debug_print .and. self%rank == 0) then + dump_json = config%json() + write(6,'(A)') trim(dump_json) +endif call config%get_or_die("saber block name", centralblockname) !clt call config%get_or_die("debuggingxx bypass mgbf", self%noMGBF) if (config%has("mgbf sdl and vdl init namelist file")) then diff --git a/src/saber/mgbf/mgbf_lib/CMakeLists.txt b/src/saber/mgbf/mgbf_lib/CMakeLists.txt index 149a5a7d1..35ee62888 100755 --- a/src/saber/mgbf/mgbf_lib/CMakeLists.txt +++ b/src/saber/mgbf/mgbf_lib/CMakeLists.txt @@ -15,7 +15,7 @@ ${jbfilenames} #PARENT_SCOPE ) add_library(mgbflib STATIC ${mgbf_lib_src_files}) -set_target_properties(mgbf_lib PROPERTIES +set_target_properties(mgbflib PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/modules) diff --git a/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 b/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 index 8f3097225..0e09be294 100755 --- a/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 +++ b/src/saber/mgbf/mgbf_lib/jp_pietc_s.f90 @@ -32,7 +32,7 @@ module jp_pietc_s 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, & + o5=u1/u5,o6=u1/u6,mo2=-o2,mo3=-o3,mo4=-o4,mo5=-o5,mo6=-o6, & pi =3.1415926535897932384626433832795028841971693993751058209749e0_sp, & pi2=6.2831853071795864769252867665590057683943387987502116419498e0_sp, & pih=1.5707963267948966192313216916397514420985846996875529104874e0_sp, & diff --git a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 index 86be6dfee..53a378bf6 100755 --- a/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_mppstuff.f90 @@ -180,9 +180,10 @@ module subroutine finishMPI(this) class(mg_parameter_type),target::this ! ! don't need mpi_finalize if mgbf is a lib to be called from outside + write(6,*) "mggbf%finishmpi should not be invoked if mgbf is used as a lib" ! - call MPI_FINALIZE(this%ierr) - stop +!clt call MPI_FINALIZE(this%ierr) +!clt stop ! !----------------------------------------------------------------------- endsubroutine finishMPI diff --git a/src/saber/mgbf/mgbf_lib/phint.f90 b/src/saber/mgbf/mgbf_lib/phint.f90 index 1063e6919..8d165041a 100644 --- a/src/saber/mgbf/mgbf_lib/phint.f90 +++ b/src/saber/mgbf/mgbf_lib/phint.f90 @@ -376,7 +376,8 @@ subroutine v1_wint3d(xs,x,wint,dwint)! [wint3 !----------------------------------------------------------------------------- real(r_kind):: x01,x12,x02,x0,x1,x2 !============================================================================= -x01=xs(1)-xs(0) +!cltorg x01=xs(1)-xs(0) +x01=xs(1)-xs(2) x12=xs(0)-xs(1) x02=xs(0)-xs(2) x0=x-xs(2) From fc87a408b99384d29474e90753b48b9839b4c282 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Tue, 28 Apr 2026 14:04:52 +0000 Subject: [PATCH 192/199] WIP --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 9401a9b56..fc766465e 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -738,10 +738,10 @@ subroutine multiply(self, fields,index_member_in) call afield%data(ptr_2d) nz=afield%levels() lev1=varvlev_index(isize,1) - if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then - loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) - write(6,*)'thinkdeb333 max is large 0.5 loc ',loc - endif +!clt if( maxval(work2d_mgbf(lev1:lev1+nz-1,:)) .gt.0.5) then +!clt loc=maxloc(work2d_mgbf(lev1:lev1+nz-1,:)) +!clt write(6,*)'thinkdeb333 max is large 0.5 loc ',loc +!lct endif if(nz.gt.1) then if(n_owned_size >0 ) then ptr_2d(1:nz,1:n_owned_size)=work2d_mgbf(lev1:lev1+nz-1,:)!if nz=1, only the first level is used (like for surface pressure) From 1da095492739b397f9e42822068da361de37f013 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Tue, 5 May 2026 21:51:40 +0000 Subject: [PATCH 193/199] WIP --- src/saber/mgbf/mgbf_lib/mg_intstate.f90 | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 index 6cc8b3904..f797b0a0b 100755 --- a/src/saber/mgbf/mgbf_lib/mg_intstate.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_intstate.f90 @@ -1461,7 +1461,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) this%paspx=this%pasp02 this%paspy=this%pasp02 !paspx and paspy will be replaced by paspx4d/paspy4d when the x/y filter ! is used ( filtering_fast_bkg ) -#if 1 allocate (lonlat2d_anl(this%nm,this%mm,2)) allocate (lonlat2d_filt(this%im,this%jm,2)) lonlat2d_anl(:,:,1)=reshape(lonlat1d_anl(:,1),[size(lonlat2d_anl,1),size(lonlat2d_anl,2)]) @@ -1524,10 +1523,6 @@ subroutine def_mg_weights(this,n_owned_anl,lonlat1d_anl) deallocate (lonlat2d_anl) deallocate (lonlat2d_filt) -#else - this%paspx4d(:,:,:,1)=this%pasp02 - this%paspy4d(:,:,:,1)=this%pasp02 -#endif endif !$omp parallel do private(i,j) schedule(static) From 103522b7495a1dc0294d5f901f8afd321a76101e Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Wed, 6 May 2026 13:32:59 +0000 Subject: [PATCH 194/199] some cleaning in mgbf --- src/saber/mgbf/mgbf_lib/mg_entrymod.f90 | 17 ----------------- src/saber/mgbf/mgbf_lib/mg_parameter.f90 | 12 ++---------- src/saber/mgbf/mgbf_lib/phint1.f90 | 2 -- 3 files changed, 2 insertions(+), 29 deletions(-) diff --git a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 index f0b5e7da3..0a4b243c8 100755 --- a/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_entrymod.f90 @@ -83,15 +83,11 @@ module subroutine mg_initialize(this,n_owned_anl,anl_lonlat1d,inputfilename,obj_ !*** !*** Initialize integration domain !*** - write(6,*)'thinkdeb in mg_entry, ', 3 - call flush(6) call this%init_mg_domain if(this%l_loc) then call this%init_domain_loc endif - write(6,*)'thinkdeb in mg_entry, ', 4 - call flush(6) !--------------------------------------------------------------------------- ! ! All others are function of km2,km3,km,nm,mm,im,jm @@ -109,35 +105,22 @@ module subroutine mg_initialize(this,n_owned_anl,anl_lonlat1d,inputfilename,obj_ !*** call this%allocate_mg_intstate - write(6,*)'thinkdeb in mg_entry, ', 5 - call flush(6) call this%def_offset_coef - write(6,*)'thinkdeb in mg_entry, ', 6 - call flush(6) if(present(n_owned_anl).and.present(anl_lonlat1d)) then call this%def_mg_weights(n_owned_anl=n_owned_anl,lonlat1d_anl=anl_lonlat1d) else call this%def_mg_weights endif - write(6,*)'thinkdeb in mg_entry, ', 7 - call flush(6) if(this%mgbf_line) then - write(6,*)'thinkdeb init_mg_line is called' call this%init_mg_line endif - write(6,*)'thinkdeb in mg_entry, ', 8 - call flush(6) call this%lsqr_mg_coef - write(6,*)'thinkdeb in mg_entry, ', 9 - call flush(6) call this%lwq_vertical_coef(this%lm_a,this%lm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref) - write(6,*)'thinkdeb in mg_entry, ', 10 - call flush(6) !*** !*** Just for testing of standalone version. In GSI WORKA will be given !*** through a separate subroutine diff --git a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 index c159f6d6d..1a9b3c6d0 100644 --- a/src/saber/mgbf/mgbf_lib/mg_parameter.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_parameter.f90 @@ -603,16 +603,12 @@ subroutine init_mg_parameter(this,inputfilename) ! allocate(this%zofis(lm)) allocate(this%isofz(lm_a)) - write(6,*)"thinkdeb999 filgrid is ",l_vert_stretched_filtgrid this%l_vert_stretched_filtgrid=l_vert_stretched_filtgrid -#if 1 if(lm_a .ne. lm ) then - write(6,*)'thinkdeb999 l_vert_stretched_filtgrid ',this%l_vert_stretched_filtgrid call convert_vert_varied_aspt !in which the mg_ampl01 will be re-defined endif -#endif !----------------------------------------------------------------- !for safety, copy all namelist loc vars to them of this object this%mg_ampl01=mg_ampl01 @@ -685,7 +681,6 @@ subroutine init_mg_parameter(this,inputfilename) this%coef_normalization=coef_normalization this%dxfmctrl=dxfmctrl; this%dyfmctrl=dyfmctrl - write(6,*)'thinkdeb999 readin l_constant_aspt2 ',l_constant_aspt2 this%l_constant_aspt2 = l_constant_aspt2 this%km2=km2 this%km3=km3 @@ -942,8 +937,6 @@ subroutine init_mg_parameter(this,inputfilename) ! Set number of processors at higher generations ! - write(6,*)'thinkdeb999 2 8 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid - call flush(6) allocate(this%ixm(this%gm)) allocate(this%jym(this%gm)) allocate(this%nxy(this%gm)) @@ -1040,7 +1033,6 @@ subroutine init_mg_parameter(this,inputfilename) this%rmom2_2=u1/sqrt(this%pee2+4) this%rmom2_3=u1/sqrt(this%pee2+5) this%rmom2_4=u1/sqrt(this%pee2+6) -#if 1 write(6,*)'thinkdeb999 2 10 ',this%l_vert_stretched_filtgrid ,' ',"l_use",this%l_vert_stretched_filtgrid call flush(6) @@ -1118,7 +1110,7 @@ subroutine convert_vert_varied_aspt mg_ampl01=mg_ampl01_org endif write(6,*)' the original and final ampl01 is ',mg_ampl01_org,' ' ,mg_ampl01 - + if(1.gt.2) then do is=1,lm write(6,*)is,this%zofis(is),(sigofis(is))**2 enddo @@ -1129,6 +1121,7 @@ subroutine convert_vert_varied_aspt enddo close(myunit) endif + endif !1>2 !clt if(this%l_2dvar_last_vertical_level == .true. ) then !the fieldset passed into mgbf will be top-down,so !clttodo need to access this from mgbf lib too this%zofis=this%zofis(lm:1:-1) @@ -1140,7 +1133,6 @@ subroutine convert_vert_varied_aspt deallocate(sigofz,sigofis) end subroutine convert_vert_varied_aspt -#endif !---------------------------------------------------------------------- diff --git a/src/saber/mgbf/mgbf_lib/phint1.f90 b/src/saber/mgbf/mgbf_lib/phint1.f90 index ade8ff77d..d8e1d359d 100644 --- a/src/saber/mgbf/mgbf_lib/phint1.f90 +++ b/src/saber/mgbf/mgbf_lib/phint1.f90 @@ -147,7 +147,6 @@ subroutine make_ssgrid(nz,nf,ns,sigofz, sstop,dss,sofz,zofs)! [make_ssgrid] integer(i_kind) :: iz,izf,izfm,izfp,is,nzf !============================================================================ ! Interpolate the log of the sigofz distribution to a finer grid: -write(6,*)'thinkdeb555 nz.. ',nz,nf,ns dzf=u1/nf nzf=nz*nf call make_ssf(nz,nf,sigofz,ssf) @@ -176,7 +175,6 @@ subroutine make_ssgrid(nz,nf,ns,sigofz, sstop,dss,sofz,zofs)! [make_ssgrid] izf=izfp-1 r=(s-ssf(izf))/(ssf(izfp)-ssf(izf)) zofs(is)=(izf+r)/nf - write(6,*)'thinkdeb555 zofs = ',is , ' ',zofs(is) enddo end subroutine make_ssgrid From 640feace4c32bc3f5f0d3de6151d9587bf4f0d53 Mon Sep 17 00:00:00 2001 From: Tinglei-daprediction Date: Wed, 6 May 2026 21:24:02 +0000 Subject: [PATCH 195/199] A bug fix in the zero initialization of work1var_mgbf in vdl situations --- src/saber/mgbf/covariance/mgbf_covariance_mod.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index fc766465e..8ea24a19a 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -494,7 +494,6 @@ subroutine multiply(self, fields,index_member_in) size(rnormalization,2) /= nvargrp) then error stop "MGBF workspace rnormalization too small for current scale" endif - work1var_mgbf=0 if(self%l_multiply_first_call(jscale)) then !$omp parallel do private(ivargrp,ii,k) schedule(static) do ivargrp=1,nvargrp @@ -688,8 +687,8 @@ subroutine multiply(self, fields,index_member_in) ii=ii+nlev_vargrp(ivargrp) enddo ! ivargrp if(self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx - work1var_mgbf = 0.0 if(nvargrp == 1 ) then + work1var_mgbf = 0.0 do ivar=1,nvar lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) @@ -705,6 +704,7 @@ subroutine multiply(self, fields,index_member_in) else !clttodo, further optimizaiton do jvar=1,nvar + work1var_mgbf = 0.0 jvargrp=self%ivar2grp(jvar) do ivar=1,nvar lev1=varvlev_index(ivar,1) From 225f683f2ee7ab82807735806b8494f656850d38 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Wed, 6 May 2026 17:52:07 -0400 Subject: [PATCH 196/199] WIP --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 35 +++++++++++++------ 1 file changed, 25 insertions(+), 10 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 8ea24a19a..90b34f4c1 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -57,6 +57,7 @@ module mgbf_covariance_mod integer, allocatable :: iscalegroup(:) integer, allocatable :: ivargroup(:) real(kind=r_kind), pointer :: work_mgbf(:,:,:) + real(kind=r_kind), pointer :: work_mgbf_tmp(:,:,:) real(kind=r_kind), pointer:: work1var_mgbf(:,:,:) real(kind=r_kind), pointer :: work2d_mgbf(:,:) real(kind=r_kind), pointer :: rnormalization(:,:,:) @@ -278,6 +279,7 @@ subroutine create(self, comm, config, funcspace, background, firstguess) nz3d=self%intstate(1,1)%lm_a allocate(self%work_mgbf(self%total_km_a_all, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) + allocate(self%work_mgbf_tmp(self%total_km_a_all, self%intstate(1,1)%nm, self%intstate(1,1)%mm)) allocate(self%work2d_mgbf(self%total_km_a_all, self%intstate(1,1)%nm * self%intstate(1,1)%mm)) allocate(self%rnormalization(self%total_km_a_all, nvargrp,nscale)) self%rnormalization(1:self%total_km_a_all,1:nvargrp,1:nscale)=0.0 @@ -328,6 +330,7 @@ subroutine delete(self) !clt endif if (associated(self%work_mgbf)) deallocate(self%work_mgbf) +if (associated(self%work_mgbf_tmp)) deallocate(self%work_mgbf_tmp) if (associated(self%work1var_mgbf)) deallocate(self%work1var_mgbf) if (associated(self%work2d_mgbf)) deallocate(self%work2d_mgbf) if (associated(self%rnormalization)) deallocate(self%rnormalization) @@ -406,6 +409,7 @@ subroutine multiply(self, fields,index_member_in) real(kind=r_kind), pointer :: ptr_3d(:,:,:) integer(kind=i_kind):: nz,ilev,isize real(kind=r_kind), pointer :: work_mgbf(:,:,:) +real(kind=r_kind), pointer :: work_mgbf_tmp(:,:,:) real(kind=r_kind), pointer :: vargrp_work_mgbf(:,:,:) real(kind=r_kind), pointer :: vargrp_work_mgbf2(:,:,:) real(kind=r_kind), pointer :: work1var_mgbf(:,:,:) @@ -461,6 +465,7 @@ subroutine multiply(self, fields,index_member_in) error stop "MGBF workspace nlev_vargrp too small for nvargrp" endif work_mgbf => self%work_mgbf + work_mgbf_tmp => self%work_mgbf_tmp work2d_mgbf => self%work2d_mgbf work1var_mgbf => self%work1var_mgbf rnormalization => self%rnormalization(:,:,jscale) @@ -478,13 +483,21 @@ subroutine multiply(self, fields,index_member_in) if (.not. associated(self%work_mgbf)) then error stop "MGBF workspace work_mgbf not allocated" endif - if (size(work_mgbf,1) /= self%total_km_a_all .or. & - size(work_mgbf,2) /= self%intstate(jscale,ivargrp0)%nm .or. & - size(work_mgbf,3) /= self%intstate(jscale,ivargrp0)%mm) then - error stop "MGBF workspace work_mgbf does not match " - endif - - if (size(work2d_mgbf,1) /= self%total_km_a_all .or. & + if (size(work_mgbf,1) /= self%total_km_a_all .or. & + size(work_mgbf,2) /= self%intstate(jscale,ivargrp0)%nm .or. & + size(work_mgbf,3) /= self%intstate(jscale,ivargrp0)%mm) then + error stop "MGBF workspace work_mgbf does not match " + endif + if (.not. associated(self%work_mgbf_tmp)) then + error stop "MGBF workspace work_mgbf_tmp not allocated" + endif + if (size(work_mgbf_tmp,1) /= self%total_km_a_all .or. & + size(work_mgbf_tmp,2) /= self%intstate(jscale,ivargrp0)%nm .or. & + size(work_mgbf_tmp,3) /= self%intstate(jscale,ivargrp0)%mm) then + error stop "MGBF workspace work_mgbf_tmp does not match " + endif + + if (size(work2d_mgbf,1) /= self%total_km_a_all .or. & size(work2d_mgbf,2) /= self%intstate(jscale,ivargrp0)%nm * & self%intstate(jscale,ivargrp0)%mm) then error stop "MGBF workspace work2d_mgbf too small for current scale" @@ -703,6 +716,7 @@ subroutine multiply(self, fields,index_member_in) !$omp end parallel do else !clttodo, further optimizaiton + work_mgbf_tmp = work_mgbf do jvar=1,nvar work1var_mgbf = 0.0 jvargrp=self%ivar2grp(jvar) @@ -710,7 +724,7 @@ subroutine multiply(self, fields,index_member_in) lev1=varvlev_index(ivar,1) lev2=varvlev_index(ivar,2) ivargrp=self%ivar2grp(ivar) - work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf(lev1:lev2,:,:) + work1var_mgbf=work1var_mgbf+self%multigrp_cor(jvargrp,ivargrp)*work_mgbf_tmp(lev1:lev2,:,:) enddo lev1=varvlev_index(jvar,1) lev2=varvlev_index(jvar,2) @@ -803,8 +817,9 @@ subroutine multiply(self, fields,index_member_in) call afield%final() - nullify(work_mgbf) - nullify(work2d_mgbf) + nullify(work_mgbf) + nullify(work_mgbf_tmp) + nullify(work2d_mgbf) nullify(rnormalization) nullify(varvlev_index) !clt enddo !for iscale From 6e5ddad91a04eb308662f41682b487d969591c93 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Wed, 6 May 2026 18:36:35 -0400 Subject: [PATCH 197/199] add more mgbf timers --- .../mgbf/covariance/mgbf_covariance_mod.f90 | 14 ++++++++ src/saber/mgbf/mgbf_lib/mg_timers.f90 | 34 +++++++++++++++++-- 2 files changed, 45 insertions(+), 3 deletions(-) diff --git a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 index 90b34f4c1..7365a7ad0 100755 --- a/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 +++ b/src/saber/mgbf/covariance/mgbf_covariance_mod.f90 @@ -546,6 +546,7 @@ subroutine multiply(self, fields,index_member_in) varvlev_index => self%varvlev_index(:,:,jscale) if (self%l_multiply_first_call(jscale)) varvlev_index = 0 + call btim(mg_pack_fields_time) ilev=1 do isize=1,fields%size() @@ -659,11 +660,14 @@ subroutine multiply(self, fields,index_member_in) stop endif enddo + call etim(mg_pack_fields_time) + call btim(mg_reshape_to_mgbf_time) !$omp parallel do private(k) schedule(static) do k=1,nzloc work_mgbf(k,:,:) = reshape(work2d_mgbf(k,:),[dim3d(2),dim3d(3)]) enddo !$omp end parallel do + call etim(mg_reshape_to_mgbf_time) if(self%intstate(jscale,ivargrp0)%km2.ne.n2d.and. .not.self%intstate(jscale,ivargrp0)%l_for_localization ) then write(6,*)'The numbers of 2d variables is different from mgbf-expected ,stop' @@ -673,7 +677,9 @@ subroutine multiply(self, fields,index_member_in) call etim(mg_preprocess_time) ii=1 do ivargrp=1,nvargrp + call btim(mg_group_copy_time) vargrp_work_mgbf(1:nlev_vargrp(ivargrp),:,:) = work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) + call etim(mg_group_copy_time) call btim(mg_anal_to_filt_time) call self%intstate(jscale,ivargrp)%anal_to_filt_allmap & @@ -691,15 +697,18 @@ subroutine multiply(self, fields,index_member_in) !clt# work_mgbf=999.0 !thinkdeb for debug call btim(mg_postprocess_time) + call btim(mg_normalize_copy_time) !$omp parallel do private(k) schedule(static) do k=1,nlev_vargrp(ivargrp) vargrp_work_mgbf2(k,:,:) = vargrp_work_mgbf2(k,:,:) / rnormalization(k,ivargrp) enddo !$omp end parallel do work_mgbf(ii:ii+nlev_vargrp(ivargrp)-1,:,:) = vargrp_work_mgbf2(1:nlev_vargrp(ivargrp),:,:) + call etim(mg_normalize_copy_time) ii=ii+nlev_vargrp(ivargrp) enddo ! ivargrp if(self%intstate(jscale,ivargrp0)%l_for_localization ) then !clthinkdebxxx + call btim(mg_localization_mix_time) if(nvargrp == 1 ) then work1var_mgbf = 0.0 do ivar=1,nvar @@ -731,13 +740,17 @@ subroutine multiply(self, fields,index_member_in) work_mgbf(lev1:lev2,:,:)=work1var_mgbf enddo endif + call etim(mg_localization_mix_time) nullify(work1var_mgbf) endif + call btim(mg_reshape_to_fields_time) !$omp parallel do private(k) schedule(static) do k=1,nzloc work2d_mgbf(k,:) = reshape(work_mgbf(k,:,:),[dim2d(2)]) enddo !$omp end parallel do + call etim(mg_reshape_to_fields_time) + call btim(mg_unpack_fields_time) ilev=1 n_owned_size=0 do isize=1,fields%size() @@ -810,6 +823,7 @@ subroutine multiply(self, fields,index_member_in) stop endif enddo + call etim(mg_unpack_fields_time) call etim(mg_postprocess_time) diff --git a/src/saber/mgbf/mgbf_lib/mg_timers.f90 b/src/saber/mgbf/mgbf_lib/mg_timers.f90 index dcabe43c0..ed9ea2157 100755 --- a/src/saber/mgbf/mgbf_lib/mg_timers.f90 +++ b/src/saber/mgbf/mgbf_lib/mg_timers.f90 @@ -89,6 +89,13 @@ module mg_timers type(timer),save,public :: mg_anal_to_filt_time type(timer),save,public :: mg_filt_to_anal_time type(timer),save,public :: mg_filtering_time + type(timer),save,public :: mg_pack_fields_time + type(timer),save,public :: mg_reshape_to_mgbf_time + type(timer),save,public :: mg_group_copy_time + type(timer),save,public :: mg_normalize_copy_time + type(timer),save,public :: mg_localization_mix_time + type(timer),save,public :: mg_reshape_to_fields_time + type(timer),save,public :: mg_unpack_fields_time integer, parameter, public :: print_clock = 1, & print_cpu = 2, & @@ -168,7 +175,7 @@ subroutine print_mg_timers(filename, print_type,mype) buffer1=' '; buffer2=' ';buffer3=' ';buffer4=' ' !cltj# if ( print_type == print_clock ) then ! write(6,*)'thinkdebxxx icound is ',mg_interface_multiply_time%icount - write(buffer1,"(I6,25(',',F10.4),',',I10)") mype, & + write(buffer1,"(I6,32(',',F10.4),',',I10)") mype, & init_tim%time_clock, & upsend_tim%time_clock, & dnsend_tim%time_clock, & @@ -195,8 +202,15 @@ subroutine print_mg_timers(filename, print_type,mype) mg_filtering_time%time_clock, & mg_filt_to_anal_time%time_clock, & mg_postprocess_time%time_clock , & + mg_pack_fields_time%time_clock , & + mg_reshape_to_mgbf_time%time_clock , & + mg_group_copy_time%time_clock , & + mg_normalize_copy_time%time_clock , & + mg_localization_mix_time%time_clock , & + mg_reshape_to_fields_time%time_clock , & + mg_unpack_fields_time%time_clock , & mg_interface_multiply_time%icount - write(buffer2,"(I6,25(',',F10.4),',',I10)") mype, & + write(buffer2,"(I6,32(',',F10.4),',',I10)") mype, & init_tim%time_cpu, & upsend_tim%time_cpu, & dnsend_tim%time_cpu, & @@ -222,6 +236,13 @@ subroutine print_mg_timers(filename, print_type,mype) mg_filtering_time%time_cpu, & mg_filt_to_anal_time%time_cpu, & mg_postprocess_time%time_cpu, & + mg_pack_fields_time%time_cpu, & + mg_reshape_to_mgbf_time%time_cpu, & + mg_group_copy_time%time_cpu, & + mg_normalize_copy_time%time_cpu, & + mg_localization_mix_time%time_cpu, & + mg_reshape_to_fields_time%time_cpu, & + mg_unpack_fields_time%time_cpu, & mg_interface_multiply_time%icount !clt# else if ( print_type == print_cpu ) then ! end if @@ -231,7 +252,7 @@ subroutine print_mg_timers(filename, print_type,mype) buffer1(bufsize1:bufsize1) = NEW_LINE(' ') buffer2(bufsize2:bufsize2) = NEW_LINE(' ') - write(header1,"(A6,26(',',A10))") "mype", & + write(header1,"(A6,33(',',A10))") "mype", & "init", & "upsend", & "dnsend", & @@ -257,6 +278,13 @@ subroutine print_mg_timers(filename, print_type,mype) "filtering", & "filt_to_anal", & "postprocess" , & + "pack_fld", & + "to_mgbf", & + "grp_copy", & + "norm_copy", & + "loc_mix", & + "to_fld", & + "unpack", & "icount" header1(bufsize1:bufsize1) = NEW_LINE(' ') From 1f369e53b492f12380c319bbcb60d4a53ce51273 Mon Sep 17 00:00:00 2001 From: TingLei-daprediction Date: Thu, 7 May 2026 20:35:47 -0400 Subject: [PATCH 198/199] added scripts to review mg_timer.output --- tools/review_mg_timer_output.py | 259 ++++++++++++++++++++++++++++ tools/run_review_mg_timer_output.sh | 23 +++ 2 files changed, 282 insertions(+) create mode 100644 tools/review_mg_timer_output.py create mode 100644 tools/run_review_mg_timer_output.sh diff --git a/tools/review_mg_timer_output.py b/tools/review_mg_timer_output.py new file mode 100644 index 000000000..77563f237 --- /dev/null +++ b/tools/review_mg_timer_output.py @@ -0,0 +1,259 @@ +#!/usr/bin/env python +"""Review and plot mg_timer_output-style timer text files. + +This script is intentionally tolerant because timer outputs vary across builds. +It scans each line, tries to extract a timer label plus one or more numeric +columns, and uses the last numeric value as the total time unless a better +pattern is obvious. +""" + +from __future__ import annotations + +import argparse +import csv +import math +import re +from dataclasses import dataclass +from pathlib import Path + +import matplotlib.pyplot as plt + + +NUM_RE = re.compile(r"[-+]?\d*\.?\d+(?:[eE][-+]?\d+)?") + + +@dataclass +class TimerRow: + label: str + total_time: float + calls: int | None + avg_time: float | None + raw_line: str + + +def _clean_label(label: str) -> str: + label = label.strip(" :-|,\t") + label = re.sub(r"\s+", " ", label) + return label + + +def _looks_like_label(label: str) -> bool: + if not label: + return False + if len(label) < 3: + return False + if not any(ch.isalpha() for ch in label): + return False + if label.lower().startswith(("rank ", "thread ", "time ", "total ")): + return True + return True + + +def parse_timer_line(line: str) -> TimerRow | None: + stripped = line.strip() + if not stripped: + return None + if stripped.startswith(("#", "=", "-", "*")): + return None + + numbers = list(NUM_RE.finditer(stripped)) + if not numbers: + return None + + label = _clean_label(stripped[: numbers[0].start()]) + if not _looks_like_label(label): + return None + + values = [float(match.group(0)) for match in numbers] + if not values: + return None + + total_time = values[-1] + if not math.isfinite(total_time): + return None + if total_time < 0: + return None + + calls = None + avg_time = None + + # Common loose heuristic: + # label ...