Compare commits

..
Author SHA1 Message Date
sfilippone f523d0195f Merge branch 'dev-openmp' into TestFerdous 2023-06-08 09:30:44 +02:00
Salvatore Filippone edea0caa63 Fix names for par_aggr_alg_names 2021-10-13 09:10:22 -04:00
Salvatore Filippone bd8495794a More fix for logarithmic transformation. 2021-09-28 17:59:38 +02:00
Salvatore Filippone 0f223ca269 Fix log transformation of weights 2021-09-28 17:39:05 +02:00
Salvatore Filippone c4e584a8d2 Update tnewmtc.inp 2021-09-27 16:56:28 +02:00
Salvatore Filippone 9004e623fe Merge branch 'development' into TestFerdous 2021-09-27 16:41:10 +02:00
Salvatore Filippone 653074995a Merge branch 'development' into TestFerdous 2021-09-27 08:59:08 -04:00
Salvatore Filippone 09928af671 Fix silly bug introduced by even more silly mistake. 2021-09-27 08:55:16 -04:00
Salvatore Filippone ba2c6aa721 Fix TestFerdous 2021-09-27 14:19:04 +02:00
Salvatore Filippone c65304f255 Default for lambda 2021-09-25 02:59:44 -04:00
Salvatore Filippone cf67905788 Fix makefiles 2021-09-24 21:35:51 +02:00
Salvatore Filippone 19325ed390 Fix merge 2021-09-24 15:33:48 -04:00
Salvatore Filippone c7b55a452e Merge branch 'TestFerdous' of github.com:sfilippone/amg4psblas into TestFerdous 2021-09-24 15:24:04 -04:00
Salvatore Filippone c80d2d8b1d Merge branch 'TF' into TestFerdous 2021-09-24 15:23:21 -04:00
Salvatore Filippone 8cf193ec5b Fix TF 2021-09-24 15:21:00 -04:00
Salvatore Filippone 8cf8c0fc7b Fix TF 2021-09-24 15:20:12 -04:00
Salvatore Filippone b11a7db667 Merge branch 'TestFerdous' of github.com:sfilippone/amg4psblas into TestFerdous 2021-09-24 15:00:45 -04:00
Salvatore Filippone d700e4c7e4 Fix compilation process for CXX sources. 2021-09-24 07:46:32 -04:00
Salvatore Filippone 43d3659a9e New test input 2021-09-24 03:09:05 -04:00
Salvatore Filippone 82e7e7d7e7 Merge branch 'TestFerdous' of github.com:sfilippone/amg4psblas into TestFerdous 2021-09-22 12:16:52 -04:00
Salvatore Filippone 5993b79749 Made matching algorithms set from test code 2021-09-22 12:12:14 -04:00
Salvatore Filippone 0523053c49 Merge branch 'development' into TestFerdous 2021-09-22 05:08:38 -04:00
Salvatore Filippone 52eaa06f9e Define XTRALINK 2021-09-21 07:30:59 -04:00
Salvatore Filippone 71156dbb3c Fix newmatch description printouts. 2021-09-20 11:35:21 -04:00
Salvatore Filippone 9dab2a8c7c Further build new matching 2021-09-20 10:59:44 -04:00
Salvatore Filippone f2cf59c276 Fix interface to matching method. 2021-09-20 10:15:54 -04:00
Salvatore Filippone fa2f8f53d5 Batch of fixes from initial test. Still more to go. 2021-09-20 09:16:44 -04:00
Salvatore Filippone 9609ea262f Get compilation through for newmatch. Now onto testing. 2021-09-20 06:00:19 -04:00
Salvatore Filippone eb30e8be90 Add decmatch module 2021-09-20 03:49:56 -04:00
Salvatore Filippone 9779eeec9f More work on interfacing with new OpenMP matching 2021-09-17 11:40:36 -04:00
Salvatore Filippone 6f419a2210 Base new matching on parmatch, to be deeply reworked 2021-09-16 09:36:20 -04:00
Salvatore Filippone c4801635b8 Merge branch 'TestFerdous' of github.com:sfilippone/amg4psblas into TestFerdous 2021-09-14 15:42:40 +02:00
Salvatore Filippone c18e5720f5 Change Makefile for CXX objs. 2021-09-14 15:42:24 +02:00
Salvatore Filippone 9ab599367b Start work on interfacing new matching 2021-09-14 06:52:46 -04:00
Salvatore Filippone 2396123b44 Start work on new matching aggregation 2021-09-14 11:17:19 +02:00
491 changed files with 18198 additions and 276390 deletions
+3 -6
View File
@@ -5,7 +5,6 @@
# header files generated
cbind/*.h
amgprec/amg_config.h
# Make.inc generated
/Make.inc
@@ -13,13 +12,11 @@ config.log
config.status
# generated folder
/include/
/modules/
/docs/src/tmp
include/
modules/
docs/src/tmp
autom4te.cache
# the executable from tests
runs
# Documentation temporary files
docs/src/userguide.pdf
+165
View File
@@ -0,0 +1,165 @@
Changelog. A lot less detailed than usual, at least for past
history.
2022/05/20: Restart ChangeLog. Updated to new name AMG4PSBLAS, now using PSB3.8
2018/10/28: Fix interface to MUMPS and configry machinery. Require PSB 3.6.
2018/10/10: ICTXT argument in prec%init().
2018/07/30: Fixes for Intel compilers. BootCMatch interface in examples.
2018/05/14: Interface for extension of aggregation methods.
2018/02/28: New cartesian distribution for sample programs.
2017/12/15: New WRK component of preconditioner levels, preallocation.
2017/10/25: New example input file formats. Added sample matrices.
2017/10/02: New CBIND in PSBLAS 3.5.0
2017/07/30: Refactored examples. Change default thresholds.
2017/05/31: New internal description of ML.
2017/05/16: Improve build process.
2017/04/20: Force %set interface. Update docs.
2017/04/03: Remove obsolete stuff.
2017/03/17: Fixed level%cnv; add coarse _solver tracker.
2017/02/18: Take out clean_zeros; changed NOFILTER; defined FBGS; take out
n_prec_levs.
2017/02/12: Updated mat_dist usage, dubious SP shell for UMFPACK, fixes
for RPM packaging.
2017/02/02: Fix superlu configury
2016/11/12: Fix hierarchy/smoothers build to handle 1 level.
2016/10/03: Merged changes to hierearchy building.
2016/08/20: Reimplemented decoupled aggregation
2016/07/20: Refactored application of multilevel. Defined V,W and
K-cycles.
2016/05/18: Reworked internals of PRECSET. Defined Forward-Backward
Gauss-Seidel solver. Now available separate PRE and POST smoother
objects.
2016/03/30: MUMPS interface.
2016/02/28: Hybrid Gauss-Seidel method.
2016/02/03: unify integer argument checks.
2015/12/15: defaults single vs. double precision. Use clean_zeros.
2015/12/08: new matdist interface
2015/10/17: configry fixes
2015/10/13: Fixes for SLUDIST versions 3 and 4
2015/05/03: New heap interface
2015/04/21: INTENT fixes
2014/12/21: New error handling
2014/10/27: Added versioncheck to configure.
2014/03/31: New get_diag.
2013/11/07: Merged changes from experimental branch. Fix INCDIR in
makefiles.
2013/07/15: Fixes for UMFPACK 5.4, SuperLU 4.3, SuperLU_Dist 3.3
2013/04/05: CLONE method.
2013/03/08: Reworked SET routines.
2012/12/10: Enable long_integers.
2012/12/05: Split smoother/solver objects.
2012/04/30: New scheme to find dynamically the number of level based on
the size of the coarse matrix
2012/01/10: Done split interface/implementation, plus subdir restructure.
2011/12/13: Start split interface/implementation to improve build time.
2011/11/25: Now works with _vect methods from PSBLAS.
2011/10/24: New test generation methods.
2011/06/15: Dump prolongator/restrictor
2011/04/14: Added MOLD argument(s) to precbld.
2011/03/30: Fixed: descriptive methods, example programs.
2011/03/08: Re-factored modules for ILU methods.
2011/03/04: Make X intent(inout) in APPLY to allow for preconditioners
using SPMM.
2011/03/02: New set methods.
2011/01/07: Fixed UMF interfacing for Z data.
2011/01/04: Added UMF inteface for D data.
2011/01/02: Fix usage of DESC_DATA. Switched all names to F90 ending.
2010/12/16: Fix usage of replicated space descriptor.
2010/11/16: Fix Jacobi smoother in case of empty off-diagonal.
2010/11/04: Defined and tested single real and complex.
2010/11/02: Aligned usage of sparse data type with psblas3.
2009/12/22: Aligned constants with mld2p4 v1.2
2009/12/11: First working version of double multilevel.
2009/12/05: Inttroduction of Smoother/Solver object hierarchy.
2009/09/23: Initial F2003 version.
2009/01/28: Changed names from XbaseprcY to XbaseprecY.
2009/01/27: Changed names from mld_transfer to mld_move_alloc.
2009/01/13: Repackaged the one-level preconditioners. Reorganized the
build routines, taking out mlprec_bld, and switching the
number of levels when needed.
2008/10/27: Changed the definition of prec_type: repackaged with a
onelev-prec-type, containing a baseprec and maps between
index spaces. No performance impact; no changes to
user-level interfaces.
2008/09/18: Changed mld_sizeof to integer(8); updated samples.
2008/08/26: Fixed matrix generation in sample programs.
2008/07/25: missing implicit none in mld_prec_type.
2008/07/23: added HTML documentation
2008/06/13: Fixed aggregation for replicated index spaces.
2008/06/02: Threshold into decoupled aggregation algorithm.
2008/05/27: Single precision version.
2008/03/09: Introduced configure script.
2008/02/08: Merged changes from intermesh branch: we now have an
inter_desc_type object. Cleaned up data allocation and
variable initialization in multilevel prec application.
2008/01/10: Merged various fixes for: prologues, unused variables,
interface details.
2007/12/21: Merge version with prologues and internal docs.
2007/11/15: Created pargen example.
2007/11/14: Fix INTENT(IN) on X vector in preconditioner routines.
2007/10/19: Merged in ILU(P,T). To be tested extensively.
2007/10/17: Merged ILU(K) into trunk.
2007/10/16: Fixed ILU(K), it now performs satisfactorily. Also updated
ILU(0) to be more legible.
2007/10/11: First working version of ILU(K). Still slow, there should
be room for improvement.
2007/10/09: Added benchmark code.
2007/10/09: Added MILU_N_. Beware: values for UMF_ etc. have been
shifted.
2007/10/02: To do: decide whether to name MLD_KRYLOV_MOD or
PSB_KRYLOV_MOD.
2007/10/01: Start of this changelog. MLD2P4 now has a different
structure, to enable a build not embedded in PSBLAS.
+3 -3
View File
@@ -1,10 +1,10 @@
AMG4PSBLAS version 1.2
AMG4PSBLAS version 1.1
Algebraic Multigrid Package
based on PSBLAS (Parallel Sparse BLAS version 3.9)
based on PSBLAS (Parallel Sparse BLAS version 3.8)
(C) Copyright 2025
(C) Copyright 2022
Salvatore Filippone
Pasqua D'Ambra
+1 -1
View File
@@ -49,7 +49,7 @@ PSBLAS_INCLUDES=@PSBLAS_INCLUDES@
PSBLAS_LIBS=@PSBLAS_LIBS@
PSBBASEMODNAME=psb_base_mod
PSBPRECMODNAME=psb_prec_mod
PSBMETHDMODNAME=psb_linsolve_mod
PSBMETHDMODNAME=psb_krylov_mod
PSBUTILMODNAME=psb_util_mod
+6 -9
View File
@@ -3,9 +3,9 @@ include Make.inc
all: objs lib
objs: libdir amgp cbnd
objs: amgp cbnd
lib: objs
lib: libdir objs
cd amgprec && $(MAKE) lib
cd cbind && $(MAKE) lib
@@ -44,10 +44,8 @@ cleanlib:
(cd include; /bin/rm -f *.a *$(.mod) *$(.fh))
(cd modules; /bin/rm -f *.a *$(.mod) *$(.fh))
distclean: clean samplesclean
/bin/rm -fr Make.inc amgprec/amg_config.h
samplesclean: clean
veryclean: cleanlib
(cd amgprec && $(MAKE) veryclean)
(cd samples/simple/fileread && $(MAKE) clean)
(cd samples/simple/pdegen && $(MAKE) clean)
(cd samples/advanced/fileread && $(MAKE) clean)
@@ -56,6 +54,5 @@ samplesclean: clean
check: all
make check -C samples/advanced/pdegen
clean: cleanlib
(cd amgprec && $(MAKE) veryclean)
(cd cbind && $(MAKE) veryclean)
clean:
(cd amgprec && $(MAKE) clean)
+35 -57
View File
@@ -1,76 +1,54 @@
# AMG4PSBLAS v1.2
Algebraic Multigrid Package based on [PSBLAS](https://github.com/sfilippone/psblas3) (Parallel Sparse BLAS version 3.9)
AMG4PSBLAS
Algebraic Multigrid Package based on PSBLAS (Parallel Sparse BLAS version 3.8)
Salvatore Filippone (University of Rome Tor Vergata and IAC-CNR)
Pasqua D'Ambra (IAC-CNR, Naples, IT)
Fabio Durastante (IAC-CNR, Naples, IT)
AMG4PSBLAS is a package of parallel algebraic multilevel preconditioners included in the PSCToolkit (Parallel Sparse Computation Toolkit) software framework.
---------------------------------------------------------------------
It is a progress of a software development project started in 2007, named MLD2P4, which originally implemented a multilevel version of some domain decomposition preconditioners of additive-Schwarz type and was based on a parallel decoupled version of the well known smoothed aggregation method to generate the multilevel hierarchy of coarser matrices.
AMG4PSBLAS is a package of Algebraic MultiGrid (AMG)
preconditioners for the iterative solution of large and sparse linear systems.
In the last years the package was extended for including new algorithms and functionalities for the setup and application new AMG preconditioners with the final aims of improving efficiency and scalability when tens of thousands cores are used and of boosting reliability in dealing with general symmetric positive definite linear systems.
It is an evolution of MLD2P4 (see LICENSE.MLD2P4), but it has been
thoroughly reworked, and it is sufficiently different to warrant a new
project name.
It is an evolution of MLD2P4 (see [LICENSE.MLD2P4](LICENSE.MLD2P4)), but due to the significant number of changes and the increase in scope, we decided to rename the package as AMG4PSBLAS.
AMG4PSBLAS has been designed to provide scalable and easy-to-use preconditioners in the context of the PSBLAS (Parallel Sparse Basic Linear Algebra Subprograms) computational framework and can be used in conjuction with the Krylov solvers available in this framework. Our package is based on a completely algebraic approach; therefore users level interfaces assume that the system matrix and preconditioners are represented as PSBLAS distributed sparse matrices.
MAIN REFERENCES:
AMG4PSBLAS enables the user to easily specify different features of an algebraic multilevel preconditioner, thus allowing to experiment with different preconditioners for the problem and parallel computers at hand.
The package employs object-oriented design techniques in Fortran 2008, with interfaces to additional third party libraries such as MUMPS, UMFPACK, SuperLU, and SuperLU_Dist, which can be exploited in building multilevel preconditioners. The parallel implementation is based on a Single Program Multiple Data (SPMD) paradigm; the inter-process communication is based on MPI and is managed mainly through PSBLAS.
P. D'Ambra, D. di Serafino, S. Filippone,
MLD2P4: a Package of Parallel Algebraic Multilevel Domain Decomposition
Preconditioners in Fortran 95,
ACM Transactions on Mathematical Software, 37 (3), 2010, art. 30,
doi: 10.1145/1824801.1824808.
## Main Refrerences:
The main reference for this project is
> D'Ambra, P., Durastante, F., & Filippone, S. (2021). AMG preconditioners for linear solvers towards extreme scale. SIAM Journal on Scientific Computing, 43(5), S679-S703.
AMG4PSBLAS is the suite of preconditioners for the Parallel Sparse Computation Toolkit ([PSCToolkit](https://psctoolkit.github.io/)) suite of libraries. See the paper:
> D’Ambra, P., Durastante, F., & Filippone, S. (2023). Parallel Sparse Computation Toolkit. Software Impacts, 15, 100463.
The main reference for features inherited from MLD2P4 is
> P. D'Ambra, D. di Serafino, S. Filippone,
> MLD2P4: a Package of Parallel Algebraic Multilevel Domain Decomposition
> Preconditioners in Fortran 95,
> ACM Transactions on Mathematical Software, 37 (3), 2010, art. 30,
> doi: 10.1145/1824801.1824808.
## Installing
Installation requires having a working version of the [PSBLAS](https://github.com/sfilippone/psblas3) library installed.
AMG4PSBLAS has several interfaces to third-party libraries that can be used in the construction and application phases of preconditioners.
In particular, it is possible to link AMG4PSBLAS with the libraries: MUMPS, SuperLU, SuperLU_Dist, UMFPACK. This is _not mandatory_ and the library can run
in isolation and without these features.
TO COMPILE
0. Unpack the tar file in a directory of your choice (preferrably
outside the main PSBLAS directory).
1. run configure `--with-psblas=<ABSOLUTE path of the PSBLAS install directory>`
1. run configure --with-psblas=<ABSOLUTE path of the PSBLAS install directory>
adding the options for MUMPS, SuperLU, SuperLU_Dist, UMFPACK as desired.
See [AMG4PSBLAS User's and Reference Guide](docs/amg4psblas_1.0-guide.pdf) (Section 3) for details.
2. Tweak `Make.inc` if you are not satisfied.
3. run `make`;
See MLD2P4 User's and Reference Guide (Section 3) for details.
2. Tweak Make.inc if you are not satisfied.
3. make;
4. Go into the test subdirectory and build the examples of your choice.
5. (if desired): `make install`
5. (if desired): make install
>[!CAUTION]
>The single precision version is supported only by MUMPS and SuperLU;
>thus, even if you specify at configure time to use UMFPACK or SuperLU_Dist,
>the corresponding preconditioner options will be available only from
>the double precision version.
### CUDA, OpeMP, OpenACC
NOTES
CUDA, OpenMP and OpenACC features are transparently inherited by PSBLAS installation. If PSBLAS has been configured (and installed) with these supports then AMG4PSBLAS will transparently inherit them. It will then be possible to move the computation to GPU accelerator simply by selecting the appropriate variable types. If these have not been activated or installed for PSBLAS then they will not be available for AMG4PSBLAS either and the operation will be purely on CPU/MPI. See also the samples/cuda folder.
- The single precision version is supported only by MUMPS and SuperLU;
thus, even if you specify at configure time to use UMFPACK or SuperLU_Dist,
the corresponding preconditioner options will be available only from
the double precision version.
### EoCoE - Software as service portal
In the European project “Energy oriented Center of Excellence: toward exascale for energy” we made available a software as service portal: [https://eocoe.psnc.pl/](https://eocoe.psnc.pl/). This permits to test several cutting-edge computational methods for accelerating the transition to the production, storage and management of clean, decarbonized energy. Among them you have the possibility of running PSBLAS+AMG4PSBLAS on some test problems to become familiar with using the software.
## TODO and bugs
- [X] Fix all reamining bugs. Bugs? We dont' have any ! 🤓
> [!NOTE]
> To report bugs 🐛 or issues ❓ please use the [GitHub issue system](https://github.com/sfilippone/amg4psblas/issues).
## The AMG4PSBLAS team.
- Pasqua D'Ambra (IAC-CNR, Naples, IT)
- Fabio Durastante (University of Pisa and IAC-CNR, IT)
- Salvatore Filippone (University of Rome Tor Vergata and IAC-CNR, IT)
The AMG4PSBLAS team.
---------------
Salvatore Filippone
Pasqua D'Ambra
Fabio Durastante
-14
View File
@@ -1,19 +1,5 @@
WHAT'S NEW
AMG4PSBLAS
Version 1.2
1. New polynomial smoothers.
2. Introduced L1-variants
3. Reorganization of sample programs.
Version 1.1
1. Reworked approximate inverse solvers.
Version 1.0
1. Transitioned from MLD2P4
MLD2P4
Version 2.1
1. The multigrid preconditioner now include fully general V- and
W-cycles. We also support K-cycles, both for symmetric and
+15 -15
View File
@@ -9,21 +9,21 @@ FINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(INCDIR) $(PSBLAS_INCLUDES)
DMODOBJS=amg_d_prec_type.o \
amg_d_inner_mod.o amg_d_ilu_solver.o amg_d_diag_solver.o amg_d_jac_smoother.o amg_d_as_smoother.o \
amg_d_poly_smoother.o amg_d_poly_coeff_mod.o\
amg_d_umf_solver.o amg_d_slu_solver.o amg_d_sludist_solver.o amg_d_id_solver.o\
amg_d_base_solver_mod.o amg_d_base_smoother_mod.o amg_d_onelev_mod.o \
amg_d_gs_solver.o amg_d_mumps_solver.o amg_d_jac_solver.o \
amg_d_gs_solver.o amg_d_mumps_solver.o \
amg_d_base_aggregator_mod.o \
amg_d_dec_aggregator_mod.o amg_d_symdec_aggregator_mod.o \
amg_d_ainv_solver.o amg_d_base_ainv_mod.o \
amg_d_invk_solver.o amg_d_invt_solver.o amg_d_krm_solver.o \
amg_d_matchboxp_mod.o amg_d_parmatch_aggregator_mod.o
amg_d_matchboxp_mod.o amg_d_parmatch_aggregator_mod.o \
amg_d_newmatch_aggregator_mod.o amg_d_decmatch_mod.o
SMODOBJS=amg_s_prec_type.o amg_s_ilu_fact_mod.o \
amg_s_inner_mod.o amg_s_ilu_solver.o amg_s_diag_solver.o amg_s_jac_smoother.o amg_s_as_smoother.o \
amg_s_poly_smoother.o amg_s_slu_solver.o amg_s_id_solver.o\
amg_s_slu_solver.o amg_s_id_solver.o\
amg_s_base_solver_mod.o amg_s_base_smoother_mod.o amg_s_onelev_mod.o \
amg_s_gs_solver.o amg_s_mumps_solver.o amg_s_jac_solver.o \
amg_s_gs_solver.o amg_s_mumps_solver.o \
amg_s_base_aggregator_mod.o \
amg_s_dec_aggregator_mod.o amg_s_symdec_aggregator_mod.o \
amg_s_ainv_solver.o amg_s_base_ainv_mod.o \
@@ -34,7 +34,7 @@ ZMODOBJS=amg_z_prec_type.o amg_z_ilu_fact_mod.o \
amg_z_inner_mod.o amg_z_ilu_solver.o amg_z_diag_solver.o amg_z_jac_smoother.o amg_z_as_smoother.o \
amg_z_umf_solver.o amg_z_slu_solver.o amg_z_sludist_solver.o amg_z_id_solver.o\
amg_z_base_solver_mod.o amg_z_base_smoother_mod.o amg_z_onelev_mod.o \
amg_z_gs_solver.o amg_z_mumps_solver.o amg_z_jac_solver.o \
amg_z_gs_solver.o amg_z_mumps_solver.o \
amg_z_base_aggregator_mod.o \
amg_z_dec_aggregator_mod.o amg_z_symdec_aggregator_mod.o \
amg_z_ainv_solver.o amg_z_base_ainv_mod.o \
@@ -44,7 +44,7 @@ CMODOBJS=amg_c_prec_type.o amg_c_ilu_fact_mod.o \
amg_c_inner_mod.o amg_c_ilu_solver.o amg_c_diag_solver.o amg_c_jac_smoother.o amg_c_as_smoother.o \
amg_c_slu_solver.o amg_c_id_solver.o\
amg_c_base_solver_mod.o amg_c_base_smoother_mod.o amg_c_onelev_mod.o \
amg_c_gs_solver.o amg_c_mumps_solver.o amg_c_jac_solver.o \
amg_c_gs_solver.o amg_c_mumps_solver.o \
amg_c_base_aggregator_mod.o \
amg_c_dec_aggregator_mod.o amg_c_symdec_aggregator_mod.o \
amg_c_ainv_solver.o amg_c_base_ainv_mod.o \
@@ -66,7 +66,7 @@ LIBNAME=libamg_prec.a
all: objs impld
objs: $(OBJS)
/bin/cp -p amg_const.h amg_config.h $(INCDIR)
/bin/cp -p amg_const.h $(INCDIR)
/bin/cp -p *$(.mod) $(MODDIR)
impld: objs
@@ -117,7 +117,7 @@ amg_c_prec_type.o: amg_c_onelev_mod.o
amg_z_prec_type.o: amg_z_onelev_mod.o
amg_s_onelev_mod.o: amg_s_base_smoother_mod.o amg_s_dec_aggregator_mod.o amg_s_parmatch_aggregator_mod.o
amg_d_onelev_mod.o: amg_d_base_smoother_mod.o amg_d_dec_aggregator_mod.o amg_d_parmatch_aggregator_mod.o
amg_d_onelev_mod.o: amg_d_base_smoother_mod.o amg_d_dec_aggregator_mod.o amg_d_parmatch_aggregator_mod.o amg_d_newmatch_aggregator_mod.o
amg_c_onelev_mod.o: amg_c_base_smoother_mod.o amg_c_dec_aggregator_mod.o
amg_z_onelev_mod.o: amg_z_base_smoother_mod.o amg_z_dec_aggregator_mod.o
@@ -130,6 +130,8 @@ amg_d_base_aggregator_mod.o: amg_base_prec_type.o
amg_d_parmatch_aggregator_mod.o amg_d_dec_aggregator_mod.o: amg_d_base_aggregator_mod.o
amg_d_hybrid_aggregator_mod.o amg_d_symdec_aggregator_mod.o: amg_d_dec_aggregator_mod.o
amg_d_parmatch_aggregator_mod.o: amg_d_matchboxp_mod.o
amg_d_newmatch_aggregator_mod.o: amg_d_base_aggregator_mod.o
amg_d_newmatch_aggregator_mod.o: amg_d_decmatch_mod.o
amg_c_base_aggregator_mod.o: amg_base_prec_type.o
amg_c_parmatch_aggregator_mod.o amg_c_dec_aggregator_mod.o: amg_c_base_aggregator_mod.o
@@ -156,7 +158,7 @@ amg_z_base_ainv_mod.o: amg_z_base_solver_mod.o amg_base_ainv_mod.o
amg_s_base_solver_mod.o amg_d_base_solver_mod.o amg_c_base_solver_mod.o amg_z_base_solver_mod.o: amg_base_prec_type.o
amg_d_mumps_solver.o amg_d_gs_solver.o amg_d_id_solver.o amg_d_sludist_solver.o amg_d_slu_solver.o \
amg_d_umf_solver.o amg_d_diag_solver.o amg_d_ilu_solver.o amg_d_jac_solver.o: amg_d_base_solver_mod.o amg_d_prec_type.o
amg_d_umf_solver.o amg_d_diag_solver.o amg_d_ilu_solver.o: amg_d_base_solver_mod.o amg_d_prec_type.o
#amg_d_ilu_fact_mod.o: amg_base_prec_type.o amg_d_base_solver_mod.o
#amg_d_ilu_solver.o amg_d_iluk_fact.o: amg_d_ilu_fact_mod.o
@@ -165,11 +167,9 @@ amg_d_jac_smoother.o: amg_d_diag_solver.o
amg_dprecinit.o amg_dprecset.o: amg_d_diag_solver.o amg_d_ilu_solver.o \
amg_d_umf_solver.o amg_d_as_smoother.o amg_d_jac_smoother.o \
amg_d_id_solver.o amg_d_slu_solver.o amg_d_sludist_solver.o
amg_d_poly_smoother.o: amg_d_base_smoother_mod.o amg_d_poly_coeff_mod.o
amg_s_poly_smoother.o: amg_s_base_smoother_mod.o amg_d_poly_coeff_mod.o
amg_s_mumps_solver.o amg_s_gs_solver.o amg_s_id_solver.o amg_s_slu_solver.o \
amg_s_diag_solver.o amg_s_ilu_solver.o amg_s_jac_solver.o: amg_s_base_solver_mod.o amg_s_prec_type.o
amg_s_diag_solver.o amg_s_ilu_solver.o: amg_s_base_solver_mod.o amg_s_prec_type.o
amg_s_ilu_fact_mod.o: amg_base_prec_type.o amg_s_base_solver_mod.o
amg_s_ilu_solver.o amg_s_iluk_fact.o: amg_s_ilu_fact_mod.o
amg_s_as_smoother.o amg_s_jac_smoother.o: amg_s_base_smoother_mod.o
@@ -179,7 +179,7 @@ amg_sprecinit.o amg_sprecset.o: amg_s_diag_solver.o amg_s_ilu_solver.o \
amg_s_id_solver.o amg_s_slu_solver.o
amg_z_mumps_solver.o amg_z_gs_solver.o amg_z_id_solver.o amg_z_sludist_solver.o amg_z_slu_solver.o \
amg_z_umf_solver.o amg_z_diag_solver.o amg_z_ilu_solver.o amg_z_jac_solver.o: amg_z_base_solver_mod.o amg_z_prec_type.o
amg_z_umf_solver.o amg_z_diag_solver.o amg_z_ilu_solver.o: amg_z_base_solver_mod.o amg_z_prec_type.o
amg_z_ilu_fact_mod.o: amg_base_prec_type.o amg_z_base_solver_mod.o
amg_z_ilu_solver.o amg_z_iluk_fact.o: amg_z_ilu_fact_mod.o
amg_z_as_smoother.o amg_z_jac_smoother.o: amg_z_base_smoother_mod.o
@@ -189,7 +189,7 @@ amg_zprecinit.o amg_zprecset.o: amg_z_diag_solver.o amg_z_ilu_solver.o \
amg_z_id_solver.o amg_z_slu_solver.o amg_z_sludist_solver.o
amg_c_mumps_solver.o amg_c_gs_solver.o amg_c_id_solver.o amg_c_sludist_solver.o amg_c_slu_solver.o \
amg_c_diag_solver.o amg_c_ilu_solver.o amg_c_jac_solver.o: amg_c_base_solver_mod.o amg_c_prec_type.o
amg_c_diag_solver.o amg_c_ilu_solver.o: amg_c_base_solver_mod.o amg_c_prec_type.o
amg_c_ilu_fact_mod.o: amg_base_prec_type.o amg_c_base_solver_mod.o
amg_c_ilu_solver.o amg_c_iluk_fact.o: amg_c_ilu_fact_mod.o
amg_c_as_smoother.o amg_c_jac_smoother.o: amg_c_base_smoother_mod.o
+4
View File
@@ -55,6 +55,10 @@ module amg_base_ainv_mod
integer, parameter :: amg_ainv_llk_noth_ = amg_ainv_s_ft_llk_ + 1
integer, parameter :: amg_ainv_mlk_ = amg_ainv_llk_noth_ + 1
integer, parameter :: amg_ainv_lmx_ = amg_ainv_mlk_
#if defined(HAVE_TUMA_SAINV)
integer, parameter :: amg_ainv_s_tuma_ = amg_ainv_lmx_ + 1
integer, parameter :: amg_ainv_l_tuma_ = amg_ainv_s_tuma_ + 1
#endif
end module amg_base_ainv_mod
+40 -91
View File
@@ -81,9 +81,9 @@ module amg_base_prec_type
!
! Version numbers
!
character(len=*), parameter :: amg_version_string_ = "1.2.0"
character(len=*), parameter :: amg_version_string_ = "1.1.0"
integer(psb_ipk_), parameter :: amg_version_major_ = 1
integer(psb_ipk_), parameter :: amg_version_minor_ = 2
integer(psb_ipk_), parameter :: amg_version_minor_ = 1
integer(psb_ipk_), parameter :: amg_patchlevel_ = 0
type amg_ml_parms
@@ -94,7 +94,6 @@ module amg_base_prec_type
integer(psb_ipk_) :: aggr_omega_alg, aggr_eig, aggr_filter
integer(psb_ipk_) :: coarse_mat, coarse_solve
contains
procedure, pass(pm) :: get_coarse_mat => ml_parms_get_coarse_mat
procedure, pass(pm) :: get_coarse => ml_parms_get_coarse
procedure, pass(pm) :: clone => ml_parms_clone
procedure, pass(pm) :: descr => ml_parms_descr
@@ -215,8 +214,7 @@ module amg_base_prec_type
integer(psb_ipk_), parameter :: amg_fbgs_ = 6
integer(psb_ipk_), parameter :: amg_l1_gs_ = 7
integer(psb_ipk_), parameter :: amg_l1_fbgs_ = 8
integer(psb_ipk_), parameter :: amg_poly_ = 9
integer(psb_ipk_), parameter :: amg_max_prec_ = 9
integer(psb_ipk_), parameter :: amg_max_prec_ = 8
!
! Constants for pre/post signaling. Now only used internally
!
@@ -234,9 +232,9 @@ module amg_base_prec_type
integer(psb_ipk_), parameter :: amg_diag_scale_ = amg_slv_delta_+1
integer(psb_ipk_), parameter :: amg_l1_diag_scale_ = amg_slv_delta_+2
integer(psb_ipk_), parameter :: amg_gs_ = amg_slv_delta_+3
integer(psb_ipk_), parameter :: amg_ilu_n_ = amg_slv_delta_+4
integer(psb_ipk_), parameter :: amg_milu_n_ = amg_slv_delta_+5
integer(psb_ipk_), parameter :: amg_ilu_t_ = amg_slv_delta_+6
! !$ integer(psb_ipk_), parameter :: amg_ilu_n_ = amg_slv_delta_+4
! !$ integer(psb_ipk_), parameter :: amg_milu_n_ = amg_slv_delta_+5
! !$ integer(psb_ipk_), parameter :: amg_ilu_t_ = amg_slv_delta_+6
integer(psb_ipk_), parameter :: amg_slu_ = amg_slv_delta_+7
integer(psb_ipk_), parameter :: amg_umf_ = amg_slv_delta_+8
integer(psb_ipk_), parameter :: amg_sludist_ = amg_slv_delta_+9
@@ -277,7 +275,8 @@ module amg_base_prec_type
integer(psb_ipk_), parameter :: amg_sym_dec_aggr_ = 1
integer(psb_ipk_), parameter :: amg_ext_aggr_ = 2
integer(psb_ipk_), parameter :: amg_coupled_aggr_ = 3
integer(psb_ipk_), parameter :: amg_max_par_aggr_alg_ = amg_coupled_aggr_
integer(psb_ipk_), parameter :: amg_newmtc_aggr_ = 4
integer(psb_ipk_), parameter :: amg_max_par_aggr_alg_ = amg_newmtc_aggr_
!
! Legal values for entry: amg_aggr_type_
!
@@ -285,22 +284,21 @@ module amg_base_prec_type
integer(psb_ipk_), parameter :: amg_soc1_ = 1
integer(psb_ipk_), parameter :: amg_soc2_ = 2
integer(psb_ipk_), parameter :: amg_matchboxp_ = 3
integer(psb_ipk_), parameter :: amg_newmatch_ = 4
!
! Legal values for entry: amg_aggr_prol_
!
integer(psb_ipk_), parameter :: amg_no_smooth_ = 0
integer(psb_ipk_), parameter :: amg_smooth_prol_ = 1
integer(psb_ipk_), parameter :: amg_l1_smooth_prol_ = 2
integer(psb_ipk_), parameter :: amg_min_energy_ = 3
integer(psb_ipk_), parameter :: amg_no_smooth_ = 0
integer(psb_ipk_), parameter :: amg_smooth_prol_ = 1
integer(psb_ipk_), parameter :: amg_min_energy_ = 2
! Disabling min_energy for the time being.
integer(psb_ipk_), parameter :: amg_max_aggr_prol_= amg_l1_smooth_prol_
integer(psb_ipk_), parameter :: amg_max_aggr_prol_=amg_smooth_prol_
!
! Legal values for entry: amg_aggr_filter_
!
integer(psb_ipk_), parameter :: amg_no_filter_mat_ = 0
integer(psb_ipk_), parameter :: amg_filter_mat_ = 1
integer(psb_ipk_), parameter :: amg_filter_prow_mat_ = 2
integer(psb_ipk_), parameter :: amg_max_filter_mat_ = amg_filter_prow_mat_
integer(psb_ipk_), parameter :: amg_no_filter_mat_ = 0
integer(psb_ipk_), parameter :: amg_filter_mat_ = 1
integer(psb_ipk_), parameter :: amg_max_filter_mat_ = amg_filter_mat_
!
! Legal values for entry: amg_aggr_ord_
!
@@ -322,16 +320,6 @@ module amg_base_prec_type
integer(psb_ipk_), parameter :: amg_distr_mat_ = 0
integer(psb_ipk_), parameter :: amg_repl_mat_ = 1
integer(psb_ipk_), parameter :: amg_max_coarse_mat_ = amg_repl_mat_
!
! Legal values for entry: amg_poly_variant_
!
integer(psb_ipk_), parameter :: amg_cheb_4_ = 0
integer(psb_ipk_), parameter :: amg_cheb_4_opt_ = 1
integer(psb_ipk_), parameter :: amg_cheb_1_opt_ = 2
integer(psb_ipk_), parameter :: amg_poly_dbg_ = 8
integer(psb_ipk_), parameter :: amg_poly_rho_est_power_ = 0
!
! Legal values for entry: amg_prec_status_
!
@@ -378,21 +366,21 @@ module amg_base_prec_type
character(len=19), parameter, private :: &
& eigen_estimates(0:0)=(/'infinity norm '/)
character(len=15), parameter, private :: &
& aggr_prols(0:4)=(/'unsmoothed ','smoothed ',&
& 'l1-smoothed ','min energy ','bizr. smoothed'/)
& aggr_prols(0:3)=(/'unsmoothed ','smoothed ',&
& 'min energy ','bizr. smoothed'/)
character(len=15), parameter, private :: &
& aggr_filters(0:2)=(/'no filtering ','filtering ',&
& 'filtering rsum'/)
& aggr_filters(0:1)=(/'no filtering ','filtering '/)
character(len=15), parameter, private :: &
& matrix_names(0:1)=(/'distributed ','replicated '/)
character(len=18), parameter, private :: &
& aggr_type_names(0:3)=(/'None ',&
& aggr_type_names(0:4)=(/'None ',&
& 'SOC measure 1 ', 'SOC Measure 2 ',&
& 'Parallel Matching '/)
& 'Parallel Matching ','Decoupled Matching'/)
character(len=18), parameter, private :: &
& par_aggr_alg_names(0:3)=(/&
& par_aggr_alg_names(0:4)=(/&
& 'decoupled aggr. ', 'sym. dec. aggr. ',&
& 'user defined aggr.', 'coupled aggr. '/)
& 'user defined aggr.', 'coupled aggr. ',&
& 'new matching aggr.'/)
character(len=18), parameter, private :: &
& ord_names(0:1)=(/'Natural ordering ','Desc. degree ord. '/)
character(len=6), parameter, private :: &
@@ -404,12 +392,12 @@ module amg_base_prec_type
& ml_names(0:7)=(/'none ','additive ',&
& 'multiplicative', 'VCycle ','WCycle ',&
& 'KCycle ','KCycleSym ','new ML '/)
character(len=16), parameter :: &
character(len=15), parameter :: &
& amg_fact_names(0:amg_max_sub_solve_)=(/&
& 'none ','Jacobi ',&
& 'L1-Jacobi ','none ','none ',&
& 'none ','none ','L1-GS ',&
& 'L1-FBGS ','Polynomial ','none ','Point Jacobi ',&
& 'L1-FBGS ','none ','Point Jacobi ',&
& 'L1-Jacobi ','Gauss-Seidel ','ILU(n) ',&
& 'MILU(n) ','ILU(t,n) ',&
& 'SuperLU ','UMFPACK LU ',&
@@ -471,12 +459,12 @@ contains
character(len=*), parameter :: name='amg_stringval'
! Local variable
integer :: index_tab
character(len=128) ::string2
character(len=15) ::string2
index_tab=index(string,char(9))
if (index_tab.NE.0) then
string2=string(1:index_tab-1)
string2=string(1:index_tab-1)
else
string2=string
string2=string
endif
select case(psb_toupper(trim(string2)))
case('NONE')
@@ -496,11 +484,11 @@ contains
case('BGS','BWGS')
val = amg_bwgs_
case('ILU')
val = amg_ilu_n_
val = psb_ilu_n_
case('MILU')
val = amg_milu_n_
val = psb_milu_n_
case('ILUT')
val = amg_ilu_t_
val = psb_ilu_t_
case('MUMPS')
val = amg_mumps_
case('UMF')
@@ -531,6 +519,10 @@ contains
val = amg_soc2_
case('SOC1')
val = amg_soc1_
case('NEWMATCH')
val = amg_newmatch_
case('NEWMTC')
val = amg_newmtc_aggr_
case('MATCHBOXP','PARMATCH')
val = amg_matchboxp_
case('COUPLED','COUP')
@@ -551,8 +543,6 @@ contains
val = amg_no_smooth_
case('SMOOTHED')
val = amg_smooth_prol_
case('L1-SMOOTHED','L1SMOOTHED')
val = amg_l1_smooth_prol_
case('MINENERGY')
val = amg_min_energy_
case('NOPREC')
@@ -573,18 +563,6 @@ contains
val = amg_krm_
case('AS')
val = amg_as_
case('POLY')
val = amg_poly_
case('CHEB_4')
val = amg_cheb_4_
case('CHEB_4_OPT')
val = amg_cheb_4_opt_
case('CHEB_1_OPT')
val = amg_cheb_1_opt_
case('POLY_DBG')
val = amg_poly_dbg_
case('POLY_RHO_EST_POWER')
val = amg_poly_rho_est_power_
case('A_NORMI')
val = amg_max_norm_
case('USER_CHOICE')
@@ -593,8 +571,6 @@ contains
val = amg_eig_est_
case('FILTER')
val = amg_filter_mat_
case('FILTERROWSUM')
val = amg_filter_prow_mat_
case('NOFILTER','NO_FILTER')
val = amg_no_filter_mat_
case('OUTER_SWEEPS')
@@ -608,33 +584,6 @@ contains
end select
end function amg_stringval
function amg_get_coarse_mat_name(val) result(res)
character(len=15) :: res
integer :: val
select case(val)
case (0,1)
res = matrix_names(val)
case default
res = 'Unknown '
end select
end function amg_get_coarse_mat_name
subroutine amg_warn_coarse_mat(val,expected)
integer(psb_ipk_) :: val, expected
if (val /= expected) then
write(0,*) 'Warning: resetting COARSE_MAT on an existing hierarchy from ',&
& amg_get_coarse_mat_name(val), ' to ',amg_get_coarse_mat_name(expected)
end if
end subroutine amg_warn_coarse_mat
function ml_parms_get_coarse_mat(pm) result(res)
implicit none
class(amg_ml_parms), intent(in) :: pm
integer(psb_ipk_) :: res
res = pm%coarse_mat
end function ml_parms_get_coarse_mat
subroutine ml_parms_get_coarse(pm,pmin)
implicit none
class(amg_ml_parms), intent(inout) :: pm
@@ -697,10 +646,10 @@ contains
& ml_names(pm%ml_cycle)
select case (pm%ml_cycle)
case (amg_add_ml_)
write(iout,*) ' Number of smoother sweeps/degree : ',&
write(iout,*) ' Number of smoother sweeps : ',&
& pm%sweeps_pre
case (amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_, amg_kcycle_ml_, amg_kcyclesym_ml_)
write(iout,*) ' Number of smoother sweeps/degree : pre: ',&
write(iout,*) ' Number of smoother sweeps : pre: ',&
& pm%sweeps_pre ,' post: ', pm%sweeps_post
end select
@@ -1066,8 +1015,8 @@ contains
integer(psb_ipk_), intent(in) :: ip
logical :: is_legal_ilu_fact
is_legal_ilu_fact = ((ip==amg_ilu_n_).or.&
& (ip==amg_milu_n_).or.(ip==amg_ilu_t_))
is_legal_ilu_fact = ((ip==psb_ilu_n_).or.&
& (ip==psb_milu_n_).or.(ip==psb_ilu_t_))
return
end function is_legal_ilu_fact
function is_legal_d_omega(ip)
+3 -11
View File
@@ -58,10 +58,12 @@ module amg_c_ainv_solver
procedure, pass(sv) :: check => amg_c_ainv_solver_check
procedure, pass(sv) :: build => amg_c_ainv_solver_bld
procedure, pass(sv) :: clone => amg_c_ainv_solver_clone
procedure, pass(sv) :: clone_settings => amg_c_ainv_solver_clone_settings
procedure, pass(sv) :: cseti => amg_c_ainv_solver_cseti
procedure, pass(sv) :: csetc => amg_c_ainv_solver_csetc
procedure, pass(sv) :: csetr => amg_c_ainv_solver_csetr
!!$ procedure, pass(sv) :: seti => amg_c_ainv_solver_seti
!!$ procedure, pass(sv) :: setc => amg_c_ainv_solver_setc
!!$ procedure, pass(sv) :: setr => amg_c_ainv_solver_setr
procedure, pass(sv) :: descr => amg_c_ainv_solver_descr
procedure, pass(sv) :: default => c_ainv_solver_default
procedure, nopass :: stringval => c_ainv_stringval
@@ -83,16 +85,6 @@ module amg_c_ainv_solver
end subroutine amg_c_ainv_solver_clone
end interface
interface
subroutine amg_c_ainv_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
& amg_c_base_solver_type, psb_dpk_, amg_c_ainv_solver_type, psb_ipk_
Implicit None
class(amg_c_ainv_solver_type), intent(inout) :: sv
class(amg_c_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_c_ainv_solver_clone_settings
end interface
interface
subroutine amg_c_ainv_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+1 -2
View File
@@ -302,7 +302,7 @@ contains
integer(psb_ipk_), intent(out) :: info
! Do nothing
info = psb_success_
return
end subroutine amg_c_base_aggregator_set_aggr_type
@@ -486,7 +486,6 @@ contains
integer(psb_ipk_) :: err_act
character(len=20) :: name='c_base_aggregator_bld_map'
info = psb_success_
call psb_erractionsave(err_act)
!
! Copy the prolongation/restriction matrices into the descriptor map.
+1 -2
View File
@@ -150,7 +150,7 @@ contains
class(amg_c_dec_aggregator_type), intent(inout) :: ag
type(amg_sml_parms), intent(in) :: parms
integer(psb_ipk_), intent(out) :: info
info = psb_success_
select case(parms%aggr_type)
case (amg_noalg_)
ag%soc_map_bld => null()
@@ -192,7 +192,6 @@ contains
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix
character(1024) :: prefix_
info = psb_success_
if (present(prefix)) then
prefix_ = prefix
else
+125
View File
@@ -0,0 +1,125 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
! The aggregator object hosts the aggregation method for building
! the multilevel hierarchy. This variant is based on the hybrid method
! presented in
!
! S. Gratton, P. Henon, P. Jiranek and X. Vasseur:
! Reducing complexity of algebraic multigrid by aggregation
! Numerical Lin. Algebra with Applications, 2016, 23:501-518
!
module amg_c_hybrid_aggregator_mod
use amg_c_dec_aggregator_mod
!
! sm - class(amg_T_base_smoother_type), allocatable
! The current level preconditioner (aka smoother).
! parms - type(amg_RTml_parms)
! The parameters defining the multilevel strategy.
! ac - The local part of the current-level matrix, built by
! coarsening the previous-level matrix.
! desc_ac - type(psb_desc_type).
! The communication descriptor associated to the matrix
! stored in ac.
! base_a - type(psb_Tspmat_type), pointer.
! Pointer (really a pointer!) to the local part of the current
! matrix (so we have a unified treatment of residuals).
! We need this to avoid passing explicitly the current matrix
! to the routine which applies the preconditioner.
! base_desc - type(psb_desc_type), pointer.
! Pointer to the communication descriptor associated to the
! matrix pointed by base_a.
! map - Stores the maps (restriction and prolongation) between the
! vector spaces associated to the index spaces of the previous
! and current levels.
!
! Methods:
! Most methods follow the encapsulation hierarchy: they take whatever action
! is appropriate for the current object, then call the corresponding method for
! the contained object.
! As an example: the descr() method prints out a description of the
! level. It starts by invoking the descr() method of the parms object,
! then calls the descr() method of the smoother object.
!
! descr - Prints a description of the object.
! default - Set default values
! dump - Dump to file object contents
! set - Sets various parameters; when a request is unknown
! it is passed to the smoother object for further processing.
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
!
!
type, extends(amg_c_dec_aggregator_type) :: amg_c_hybrid_aggregator_type
contains
procedure, pass(ag) :: bld_tprol => amg_c_hybrid_aggregator_build_tprol
procedure, nopass :: fmt => amg_c_hybrid_aggregator_fmt
end type amg_c_hybrid_aggregator_type
interface
subroutine amg_c_hybrid_aggregator_build_tprol(ag,parms,a,desc_a,ilaggr,nlaggr,op_prol,info)
import :: amg_c_hybrid_aggregator_type, psb_desc_type, psb_cspmat_type, psb_spk_, &
& psb_ipk_, psb_long_int_k_, amg_sml_parms
implicit none
class(amg_c_hybrid_aggregator_type), target, intent(inout) :: ag
type(amg_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_cspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine amg_c_hybrid_aggregator_build_tprol
end interface
contains
function amg_c_hybrid_aggregator_fmt() result(val)
implicit none
character(len=32) :: val
val = "Hybrid Decoupled aggregation"
end function amg_c_hybrid_aggregator_fmt
end module amg_c_hybrid_aggregator_mod
+7 -7
View File
@@ -234,7 +234,7 @@ contains
! Arguments
class(amg_c_ilu_solver_type), intent(inout) :: sv
sv%fact_type = amg_ilu_n_
sv%fact_type = psb_ilu_n_
sv%fill_in = 0
sv%thresh = szero
@@ -255,13 +255,13 @@ contains
info = psb_success_
call amg_check_def(sv%fact_type,&
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(amg_ilu_n_,amg_milu_n_)
case(psb_ilu_n_,psb_milu_n_)
call amg_check_def(sv%fill_in,&
& 'Level',izero,is_int_non_negative)
case(amg_ilu_t_)
case(psb_ilu_t_)
call amg_check_def(sv%thresh,&
& 'Eps',szero,is_legal_s_fact_thrs)
end select
@@ -439,9 +439,9 @@ contains
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
& amg_fact_names(sv%fact_type)
select case(sv%fact_type)
case(amg_ilu_n_,amg_milu_n_)
case(psb_ilu_n_,psb_milu_n_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
case(amg_ilu_t_)
case(psb_ilu_t_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
end select
@@ -496,7 +496,7 @@ contains
implicit none
integer(psb_ipk_) :: val
val = amg_ilu_n_
val = psb_ilu_n_
end function c_ilu_solver_get_id
function c_ilu_solver_get_wrksize() result(val)
+1 -2
View File
@@ -109,12 +109,11 @@ module amg_c_inner_mod
end interface amg_map_to_tprol
abstract interface
subroutine amg_caggrmat_var_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,parms,&
subroutine amg_caggrmat_var_bld(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
import :: psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_, psb_lcspmat_type
import :: amg_c_onelev_type, amg_sml_parms
implicit none
integer(psb_ipk_), intent(in) :: dol1smoothing
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
-12
View File
@@ -52,7 +52,6 @@ module amg_c_invk_solver
contains
procedure, pass(sv) :: check => amg_c_invk_solver_check
procedure, pass(sv) :: clone => amg_c_invk_solver_clone
procedure, pass(sv) :: clone_settings => amg_c_invk_solver_clone_settings
procedure, pass(sv) :: build => amg_c_invk_solver_bld
procedure, pass(sv) :: cseti => amg_c_invk_solver_cseti
procedure, pass(sv) :: descr => amg_c_invk_solver_descr
@@ -74,17 +73,6 @@ module amg_c_invk_solver
end subroutine amg_c_invk_solver_clone
end interface
interface
subroutine amg_c_invk_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
& amg_c_base_solver_type, psb_spk_, amg_c_invk_solver_type, psb_ipk_
Implicit None
class(amg_c_invk_solver_type), intent(inout) :: sv
class(amg_c_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_c_invk_solver_clone_settings
end interface
interface
subroutine amg_c_invk_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
-12
View File
@@ -52,7 +52,6 @@ module amg_c_invt_solver
contains
procedure, pass(sv) :: check => amg_c_invt_solver_check
procedure, pass(sv) :: clone => amg_c_invt_solver_clone
procedure, pass(sv) :: clone_settings => amg_c_invt_solver_clone_settings
procedure, pass(sv) :: build => amg_c_invt_solver_bld
procedure, pass(sv) :: cseti => amg_c_invt_solver_cseti
procedure, pass(sv) :: csetr => amg_c_invt_solver_csetr
@@ -74,17 +73,6 @@ module amg_c_invt_solver
end subroutine amg_c_invt_solver_clone
end interface
interface
subroutine amg_c_invt_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
& amg_c_base_solver_type, psb_spk_, amg_c_invt_solver_type, psb_ipk_
Implicit None
class(amg_c_invt_solver_type), intent(inout) :: sv
class(amg_c_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_c_invt_solver_clone_settings
end interface
interface
subroutine amg_c_invt_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
+2 -2
View File
@@ -203,8 +203,8 @@ module amg_c_jac_smoother
subroutine amg_c_jac_smoother_clone_settings(sm,smout,info)
import :: amg_c_jac_smoother_type, psb_spk_, &
& amg_c_base_smoother_type, psb_ipk_
class(amg_c_jac_smoother_type), intent(inout) :: sm
class(amg_c_base_smoother_type), intent(inout) :: smout
class(amg_c_jac_smoother_type), intent(inout) :: sm
class(amg_c_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_c_jac_smoother_clone_settings
end interface
-585
View File
@@ -1,585 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
! File: amg_c_jac_solver_mod.f90
!
! Module: amg_c_jac_solver_mod
!
! This module defines:
! - the amg_c_jac_solver_type data structure containing the ingredients
! for a local Jacobi iteration. The iterations are local to a process
! (they operate on the block diagonal).
!
!
module amg_c_jac_solver
use amg_c_base_solver_mod
type, extends(amg_c_base_solver_type) :: amg_c_jac_solver_type
type(psb_cspmat_type) :: a
type(psb_c_vect_type), allocatable :: dv
complex(psb_spk_), allocatable :: d(:)
integer(psb_ipk_) :: sweeps
real(psb_spk_) :: eps
contains
procedure, pass(sv) :: dump => amg_c_jac_solver_dmp
procedure, pass(sv) :: check => c_jac_solver_check
procedure, pass(sv) :: clone => amg_c_jac_solver_clone
procedure, pass(sv) :: clone_settings => amg_c_jac_solver_clone_settings
procedure, pass(sv) :: clear_data => amg_c_jac_solver_clear_data
procedure, pass(sv) :: build => amg_c_jac_solver_bld
procedure, pass(sv) :: cnv => amg_c_jac_solver_cnv
procedure, pass(sv) :: apply_v => amg_c_jac_solver_apply_vect
procedure, pass(sv) :: apply_a => amg_c_jac_solver_apply
procedure, pass(sv) :: free => c_jac_solver_free
procedure, pass(sv) :: cseti => c_jac_solver_cseti
procedure, pass(sv) :: csetc => c_jac_solver_csetc
procedure, pass(sv) :: csetr => c_jac_solver_csetr
procedure, pass(sv) :: descr => c_jac_solver_descr
procedure, pass(sv) :: default => c_jac_solver_default
procedure, pass(sv) :: sizeof => c_jac_solver_sizeof
procedure, pass(sv) :: get_nzeros => c_jac_solver_get_nzeros
procedure, nopass :: get_wrksz => c_jac_solver_get_wrksize
procedure, nopass :: get_fmt => c_jac_solver_get_fmt
procedure, nopass :: get_id => c_jac_solver_get_id
procedure, nopass :: is_iterative => c_jac_solver_is_iterative
end type amg_c_jac_solver_type
type, extends(amg_c_jac_solver_type) :: amg_c_l1_jac_solver_type
contains
procedure, pass(sv) :: build => amg_c_l1_jac_solver_bld
procedure, pass(sv) :: descr => c_l1_jac_solver_descr
procedure, nopass :: get_fmt => c_l1_jac_solver_get_fmt
procedure, nopass :: get_id => c_l1_jac_solver_get_id
end type amg_c_l1_jac_solver_type
private :: c_jac_solver_bld, c_jac_solver_apply, &
& c_jac_solver_free, &
& c_jac_solver_descr, c_jac_solver_sizeof, &
& c_jac_solver_default, c_jac_solver_dmp, &
& c_jac_solver_apply_vect, c_jac_solver_get_nzeros, &
& c_jac_solver_get_fmt, c_jac_solver_check,&
& c_jac_solver_is_iterative, &
& c_jac_solver_get_id, c_jac_solver_get_wrksize
interface
subroutine amg_c_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,wv,info,init,initu)
import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(amg_c_jac_solver_type), intent(inout) :: sv
type(psb_c_vect_type),intent(inout) :: x
type(psb_c_vect_type),intent(inout) :: y
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
end subroutine amg_c_jac_solver_apply_vect
end interface
interface
subroutine amg_c_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(amg_c_jac_solver_type), intent(inout) :: sv
complex(psb_spk_),intent(inout) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
complex(psb_spk_),intent(inout), optional :: initu(:)
end subroutine amg_c_jac_solver_apply
end interface
interface
subroutine amg_c_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
type(psb_cspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_c_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_cspmat_type), intent(in), target, optional :: b
class(psb_c_base_sparse_mat), intent(in), optional :: amold
class(psb_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_c_jac_solver_bld
end interface
interface
subroutine amg_c_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, amg_c_l1_jac_solver_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
type(psb_cspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_c_l1_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_cspmat_type), intent(in), target, optional :: b
class(psb_c_base_sparse_mat), intent(in), optional :: amold
class(psb_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_c_l1_jac_solver_bld
end interface
interface
subroutine amg_c_jac_solver_cnv(sv,info,amold,vmold,imold)
import :: amg_c_jac_solver_type, psb_spk_, &
& psb_c_base_sparse_mat, psb_c_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
class(amg_c_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_sparse_mat), intent(in), optional :: amold
class(psb_c_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_c_jac_solver_cnv
end interface
interface
subroutine amg_c_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, &
& psb_ipk_
implicit none
class(amg_c_jac_solver_type), intent(in) :: sv
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: level
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: solver, global_num
end subroutine amg_c_jac_solver_dmp
end interface
interface
subroutine amg_c_jac_solver_clone(sv,svout,info)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
& psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
& amg_c_base_solver_type, amg_c_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_c_jac_solver_type), intent(inout) :: sv
class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_c_jac_solver_clone
end interface
!!$ interface
!!$ subroutine amg_c_l1_jac_solver_clone(sv,svout,info)
!!$ import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
!!$ & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
!!$ & amg_c_base_solver_type, amg_c_l1_jac_solver_type, psb_ipk_
!!$ Implicit None
!!$
!!$ ! Arguments
!!$ class(amg_c_l1_jac_solver_type), intent(inout) :: sv
!!$ class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ end subroutine amg_c_l1_jac_solver_clone
!!$ end interface
interface
subroutine amg_c_jac_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
& psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
& amg_c_base_solver_type, amg_c_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_c_jac_solver_type), intent(inout) :: sv
class(amg_c_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_c_jac_solver_clone_settings
end interface
interface
subroutine amg_c_jac_solver_clear_data(sv,info)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
& psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
& amg_c_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_c_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
end subroutine amg_c_jac_solver_clear_data
end interface
contains
subroutine c_jac_solver_default(sv)
Implicit None
! Arguments
class(amg_c_jac_solver_type), intent(inout) :: sv
sv%sweeps = ione
sv%eps = dzero
return
end subroutine c_jac_solver_default
subroutine c_jac_solver_check(sv,info)
Implicit None
! Arguments
class(amg_c_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='c_jac_solver_check'
call psb_erractionsave(err_act)
info = psb_success_
call amg_check_def(sv%sweeps,&
& 'Jacobi sweeps',ione,is_int_positive)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine c_jac_solver_check
subroutine c_jac_solver_cseti(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_c_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act
character(len=20) :: name='c_jac_solver_cseti'
info = psb_success_
call psb_erractionsave(err_act)
select case(psb_toupper(what))
case('SOLVER_SWEEPS')
sv%sweeps = val
case default
call sv%amg_c_base_solver_type%set(what,val,info,idx=idx)
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine c_jac_solver_cseti
subroutine c_jac_solver_csetc(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_c_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act, ival
character(len=20) :: name='c_jac_solver_csetc'
info = psb_success_
call psb_erractionsave(err_act)
call sv%amg_c_base_solver_type%set(what,val,info,idx=idx)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info, name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine c_jac_solver_csetc
subroutine c_jac_solver_csetr(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_c_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act
character(len=20) :: name='c_jac_solver_csetr'
call psb_erractionsave(err_act)
info = psb_success_
select case(psb_toupper(what))
case('SOLVER_EPS')
sv%eps = val
case default
call sv%amg_c_base_solver_type%set(what,val,info,idx=idx)
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine c_jac_solver_csetr
subroutine c_jac_solver_free(sv,info)
Implicit None
! Arguments
class(amg_c_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='c_jac_solver_free'
call psb_erractionsave(err_act)
info = psb_success_
call sv%a%free()
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
if (allocated(sv%d)) deallocate(sv%d)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine c_jac_solver_free
subroutine c_jac_solver_descr(sv,info,iout,coarse,prefix)
Implicit None
! Arguments
class(amg_c_jac_solver_type), intent(in) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='amg_c_jac_solver_descr'
integer(psb_ipk_) :: iout_
character(1024) :: prefix_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
endif
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if (sv%eps<=dzero) then
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine c_jac_solver_descr
function c_jac_solver_get_nzeros(sv) result(val)
implicit none
! Arguments
class(amg_c_jac_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = 0
val = val + sv%a%get_nzeros()
val = val + sv%dv%get_nrows()
return
end function c_jac_solver_get_nzeros
function c_jac_solver_sizeof(sv) result(val)
implicit none
! Arguments
class(amg_c_jac_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = psb_sizeof_ip
val = val + sv%a%sizeof()
val = val + sv%dv%sizeof()
return
end function c_jac_solver_sizeof
function c_jac_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Jacobi solver"
end function c_jac_solver_get_fmt
function c_jac_solver_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_jac_
end function c_jac_solver_get_id
!
! If this is true, then the solver needs a starting
! guess. Currently only handled in JAC smoother.
!
function c_jac_solver_is_iterative() result(val)
implicit none
logical :: val
val = .true.
end function c_jac_solver_is_iterative
function c_jac_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 2
end function c_jac_solver_get_wrksize
subroutine c_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
Implicit None
! Arguments
class(amg_c_l1_jac_solver_type), intent(in) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='amg_c_l1_jac_solver_descr'
integer(psb_ipk_) :: iout_
character(1024) :: prefix_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
endif
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if (sv%eps<=dzero) then
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine c_l1_jac_solver_descr
function c_l1_jac_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "L1-Jacobi solver"
end function c_l1_jac_solver_get_fmt
function c_l1_jac_solver_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_l1_jac_
end function c_l1_jac_solver_get_id
end module amg_c_jac_solver
+12 -13
View File
@@ -52,10 +52,10 @@
!
module amg_c_mumps_solver
use amg_c_base_solver_mod
#if defined(AMG_HAVE_MUMPS) && defined(AMG_HAVE_MUMPS_MODULES)
#if defined(HAVE_MUMPS_) && defined(HAVE_MUMPS_MODULES_)
use cmumps_struc_def
#endif
#if defined(AMG_HAVE_MUMPS) && defined(AMG_HAVE_MUMPS_INCLUDES)
#if defined(HAVE_MUMPS_) && defined(HAVE_MUMPS_INCLUDES_)
include 'cmumps_struc.h'
#endif
@@ -68,7 +68,7 @@ module amg_c_mumps_solver
end type amg_c_mumps_rcntl_item
type, extends(amg_c_base_solver_type) :: amg_c_mumps_solver_type
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
type(cmumps_struc), allocatable :: id
#else
integer, allocatable :: id
@@ -78,8 +78,7 @@ module amg_c_mumps_solver
!
! Controls to be set before MUMPS instantiation:
!
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: 'LOCAL_SOLVER
! 1==amg_global_solver_: 'GLOBAL_SOLVER'
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: LOCAL 1==amg_global_solver_: GLOBAL
! IPAR(2) : MUMPS_PRINT_ERR print verbosity (see MUMPS)
! IPAR(3) : MUMPS_SYM 0: non-symmetric 2: symmetric
integer(psb_ipk_), dimension(3) :: ipar
@@ -189,7 +188,7 @@ contains
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
@@ -239,7 +238,7 @@ contains
character(len=20) :: name='c_mumps_solver_clear_data'
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
if (allocated(sv%id)) then
if (sv%built) then
@@ -279,7 +278,7 @@ contains
character(len=20) :: name='c_mumps_solver_free'
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
call sv%clear_data(info)
if ((info == 0).and.allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
@@ -383,7 +382,7 @@ subroutine c_mumps_solver_csetc(sv,what,val,info,idx)
select case(psb_toupper(trim(what)))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_LOC_GLOB')
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
#endif
@@ -421,7 +420,7 @@ subroutine c_mumps_solver_cseti(sv,what,val,info,idx)
call psb_erractionsave(err_act)
select case(psb_toupper(what))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_LOC_GLOB')
sv%ipar(1) = val
case('MUMPS_PRINT_ERR')
@@ -467,7 +466,7 @@ subroutine c_mumps_solver_csetr(sv,what,val,info,idx)
call psb_erractionsave(err_act)
select case(psb_toupper(what))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_RPAR_ENTRY')
if(present(idx)) then
! Note: this will allocate %item
@@ -504,7 +503,7 @@ subroutine c_mumps_solver_default(sv)
info = psb_success_
call psb_erractionsave(err_act)
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
if (.not.allocated(sv%id)) then
allocate(sv%id,stat=info)
if (info /= psb_success_) then
@@ -561,7 +560,7 @@ function c_mumps_solver_sizeof(sv) result(val)
class(amg_c_mumps_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer :: i
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
#else
val = 0
+1 -32
View File
@@ -187,10 +187,8 @@ module amg_c_onelev_mod
procedure, pass(lv) :: clone => c_base_onelev_clone
procedure, pass(lv) :: cnv => amg_c_base_onelev_cnv
procedure, pass(lv) :: descr => amg_c_base_onelev_descr
procedure, pass(lv) :: memory_use => amg_c_base_onelev_memory_use
procedure, pass(lv) :: default => c_base_onelev_default
procedure, pass(lv) :: free => amg_c_base_onelev_free
procedure, pass(lv) :: free_smoothers => amg_c_base_onelev_free_smoothers
procedure, pass(lv) :: nullify => c_base_onelev_nullify
procedure, pass(lv) :: check => amg_c_base_onelev_check
procedure, pass(lv) :: dump => amg_c_base_onelev_dump
@@ -274,23 +272,6 @@ module amg_c_onelev_mod
end subroutine amg_c_base_onelev_descr
end interface
interface
subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
Implicit None
! Arguments
class(amg_c_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_c_base_onelev_memory_use
end interface
interface
subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
import :: amg_c_onelev_type, psb_c_base_vect_type, psb_spk_, &
@@ -304,7 +285,7 @@ module amg_c_onelev_mod
end subroutine amg_c_base_onelev_cnv
end interface
interface
interface
subroutine amg_c_base_onelev_free(lv,info)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
@@ -316,18 +297,6 @@ module amg_c_onelev_mod
end subroutine amg_c_base_onelev_free
end interface
interface
subroutine amg_c_base_onelev_free_smoothers(lv,info)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
implicit none
class(amg_c_onelev_type), intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
end subroutine amg_c_base_onelev_free_smoothers
end interface
interface
subroutine amg_c_base_onelev_check(lv,info)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
-90
View File
@@ -113,7 +113,6 @@ module amg_c_prec_type
procedure, pass(prec) :: free => amg_c_prec_free
procedure, pass(prec) :: allocate_wrk => amg_c_allocate_wrk
procedure, pass(prec) :: free_wrk => amg_c_free_wrk
procedure, pass(prec) :: deallocate_wrk => amg_c_free_wrk
procedure, pass(prec) :: is_allocated_wrk => amg_c_is_allocated_wrk
procedure, pass(prec) :: get_complexity => amg_c_get_compl
procedure, pass(prec) :: cmp_complexity => amg_c_cmp_compl
@@ -136,11 +135,8 @@ module amg_c_prec_type
procedure, pass(prec) :: build => amg_cprecbld
procedure, pass(prec) :: hierarchy_build => amg_c_hierarchy_bld
procedure, pass(prec) :: hierarchy_rebuild => amg_c_hierarchy_rebld
procedure, pass(prec) :: hierarchy_free => amg_c_hierarchy_free
procedure, pass(prec) :: smoothers_build => amg_c_smoothers_bld
procedure, pass(prec) :: smoothers_free => amg_c_smoothers_free
procedure, pass(prec) :: descr => amg_cfile_prec_descr
procedure, pass(prec) :: memory_use => amg_cfile_prec_memory_use
end type amg_cprec_type
private :: amg_c_dump, amg_c_get_compl, amg_c_cmp_compl,&
@@ -172,22 +168,6 @@ module amg_c_prec_type
end subroutine amg_cfile_prec_descr
end interface
interface amg_memory_use
subroutine amg_cfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
import :: amg_cprec_type, psb_ipk_
implicit none
! Arguments
class(amg_cprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_cfile_prec_memory_use
end interface
interface amg_sizeof
module procedure amg_cprec_sizeof
end interface
@@ -365,14 +345,6 @@ module amg_c_prec_type
end subroutine amg_c_smoothers_bld
end interface amg_smoothers_bld
interface amg_smoothers_free
module procedure amg_c_smoothers_free
end interface amg_smoothers_free
interface amg_hierarchy_free
module procedure amg_c_hierarchy_free
end interface amg_hierarchy_free
contains
!
! Function returning a pointer to the smoother
@@ -646,68 +618,6 @@ contains
end subroutine amg_c_prec_free
subroutine amg_c_smoothers_free(prec,info)
implicit none
! Arguments
class(amg_cprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: me,err_act,i
character(len=20) :: name
info=psb_success_
name = 'amg_c_smoothers_free'
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
end if
if (allocated(prec%precv)) then
do i=1,size(prec%precv)
call prec%precv(i)%free_smoothers(info)
end do
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_c_smoothers_free
subroutine amg_c_hierarchy_free(prec,info)
implicit none
! Arguments
class(amg_cprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: me,err_act,i
character(len=20) :: name
info=psb_success_
name = 'amg_c_hierarchy_free'
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
end if
me=-1
write(0,*) 'Missing implementation '
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_c_hierarchy_free
!
+1 -1
View File
@@ -51,7 +51,7 @@ module amg_c_slu_solver
use iso_c_binding
use amg_c_base_solver_mod
#if defined(PSB_IPK8)
#if defined(IPK8)
type, extends(amg_c_base_solver_type) :: amg_c_slu_solver_type
+1 -1
View File
@@ -97,7 +97,7 @@ contains
character(len=*), intent(in), optional :: prefix
character(1024) :: prefix_
info = psb_success_
if (present(prefix)) then
prefix_ = prefix
else
-17
View File
@@ -1,17 +0,0 @@
#ifndef AMG_CONFIG_H
#define AMG_CONFIG_H
#include "psb_config.h"
@CHAVEUMF@
@CHAVESLU@
@CSLUVERSION@
@CHAVESLUDIST@
@CSLUDISTVERSION@
@CHAVEMUMPS@
@CHAVEMUMPSMODULES@
@CHAVEMUMPSINCLUDES@
@CXXMATCHBOXBIT@
#endif
+3 -11
View File
@@ -58,10 +58,12 @@ module amg_d_ainv_solver
procedure, pass(sv) :: check => amg_d_ainv_solver_check
procedure, pass(sv) :: build => amg_d_ainv_solver_bld
procedure, pass(sv) :: clone => amg_d_ainv_solver_clone
procedure, pass(sv) :: clone_settings => amg_d_ainv_solver_clone_settings
procedure, pass(sv) :: cseti => amg_d_ainv_solver_cseti
procedure, pass(sv) :: csetc => amg_d_ainv_solver_csetc
procedure, pass(sv) :: csetr => amg_d_ainv_solver_csetr
!!$ procedure, pass(sv) :: seti => amg_d_ainv_solver_seti
!!$ procedure, pass(sv) :: setc => amg_d_ainv_solver_setc
!!$ procedure, pass(sv) :: setr => amg_d_ainv_solver_setr
procedure, pass(sv) :: descr => amg_d_ainv_solver_descr
procedure, pass(sv) :: default => d_ainv_solver_default
procedure, nopass :: stringval => d_ainv_stringval
@@ -83,16 +85,6 @@ module amg_d_ainv_solver
end subroutine amg_d_ainv_solver_clone
end interface
interface
subroutine amg_d_ainv_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
& amg_d_base_solver_type, psb_dpk_, amg_d_ainv_solver_type, psb_ipk_
Implicit None
class(amg_d_ainv_solver_type), intent(inout) :: sv
class(amg_d_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_ainv_solver_clone_settings
end interface
interface
subroutine amg_d_ainv_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+1 -2
View File
@@ -302,7 +302,7 @@ contains
integer(psb_ipk_), intent(out) :: info
! Do nothing
info = psb_success_
return
end subroutine amg_d_base_aggregator_set_aggr_type
@@ -486,7 +486,6 @@ contains
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_base_aggregator_bld_map'
info = psb_success_
call psb_erractionsave(err_act)
!
! Copy the prolongation/restriction matrices into the descriptor map.
+1 -2
View File
@@ -150,7 +150,7 @@ contains
class(amg_d_dec_aggregator_type), intent(inout) :: ag
type(amg_dml_parms), intent(in) :: parms
integer(psb_ipk_), intent(out) :: info
info = psb_success_
select case(parms%aggr_type)
case (amg_noalg_)
ag%soc_map_bld => null()
@@ -192,7 +192,6 @@ contains
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix
character(1024) :: prefix_
info = psb_success_
if (present(prefix)) then
prefix_ = prefix
else
+529
View File
@@ -0,0 +1,529 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
module amg_d_decmatch_mod
use iso_c_binding
use psb_base_cbind_mod
interface new_Match_If
function dnew_Match_If(ipar,matching,lambda,nr, irp, ja, val, diag, w, mate) &
& bind(c,name="dnew_Match_If") result(res)
use iso_c_binding
import :: psb_c_ipk_, psb_c_lpk_, psb_c_mpk_, psb_c_epk_
implicit none
integer(psb_c_ipk_) :: res
integer(psb_c_ipk_), value :: nr,ipar,matching
real(c_double), value :: lambda
type(c_ptr), value :: irp, ja, mate
type(c_ptr), value :: val, diag, w
end function dnew_Match_If
end interface new_Match_If
interface amg_build_decmatch
module procedure amg_dbuild_decmatch
end interface amg_build_decmatch
logical, parameter, private :: print_statistics=.false.
contains
subroutine amg_ddecmatch_build_prol(w,a,desc_a,ilaggr,nlaggr,prol,info,&
& symmetrize,reproducible,display_inp, display_out, print_out, &
& parallel, matching,lambda)
use psb_base_mod
use psb_util_mod
use iso_c_binding
implicit none
real(psb_dpk_), allocatable, intent(inout) :: w(:)
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:)
integer(psb_lpk_), allocatable, intent(out) :: nlaggr(:)
type(psb_ldspmat_type), intent(out) :: prol
integer(psb_ipk_), intent(out) :: info
logical, optional, intent(in) :: display_inp, display_out, reproducible
logical, optional, intent(in) :: symmetrize, print_out, parallel
integer(psb_ipk_), optional, intent(in) :: matching
real(psb_dpk_), optional, intent(in) :: lambda
!
!
type(psb_ctxt_type) :: ictxt
integer(psb_ipk_) :: iam, np, iown
integer(psb_ipk_) :: nr, nc, sweep, nzl, ncsave, nct, idx
integer(psb_lpk_) :: i, k, kg, idxg, ntaggr, naggrm1, naggrp1, &
& ip, nlpairs, nlsingl, nunmatched, lnr
real(psb_dpk_) :: wk, widx, wmax, nrmagg
real(psb_dpk_), allocatable :: wtemp(:)
integer(psb_ipk_), allocatable :: mate(:)
integer(psb_lpk_), allocatable :: ilv(:)
integer(psb_ipk_), save :: cnt=1
character(len=256) :: aname
type(psb_ld_coo_sparse_mat) :: tmpcoo
logical :: display_out_, print_out_, reproducible_, parallel_
integer(psb_ipk_) :: matching_
real(psb_dpk_) :: lambda_
logical, parameter :: dump=.false., debug=.false., dump_mate=.false., &
& debug_ilaggr=.false., debug_sync=.false.
integer(psb_ipk_), save :: idx_bldmtc=-1, idx_phase1=-1, idx_phase2=-1, idx_phase3=-1
logical, parameter :: do_timings=.true.
ictxt = desc_a%get_ctxt()
call psb_info(ictxt,iam,np)
if ((do_timings).and.(idx_phase1==-1)) &
& idx_phase1 = psb_get_timer_idx("MBP_BLDP: phase1 ")
if ((do_timings).and.(idx_bldmtc==-1)) &
& idx_bldmtc = psb_get_timer_idx("MBP_BLDP: buil_matching")
if ((do_timings).and.(idx_phase2==-1)) &
& idx_phase2 = psb_get_timer_idx("MBP_BLDP: phase2 ")
if ((do_timings).and.(idx_phase3==-1)) &
& idx_phase3 = psb_get_timer_idx("MBP_BLDP: phase3 ")
if (do_timings) call psb_tic(idx_phase1)
if (present(display_out)) then
display_out_ = display_out
else
display_out_ = .false.
end if
if (present(print_out)) then
print_out_ = print_out
else
print_out_ = .false.
end if
if (present(reproducible)) then
reproducible_ = reproducible
else
reproducible_ = .false.
end if
if (present(parallel)) then
parallel_ = parallel
else
parallel_ = .true.
end if
if (present(matching)) then
matching_ = matching
else
matching_ = 2
end if
if (present(lambda)) then
lambda_ = lambda
else
lambda_ = 2.0
end if
allocate(nlaggr(0:np-1),stat=info)
if (info /= 0) then
return
end if
nlaggr = 0
ilv = [(i,i=1,desc_a%get_local_cols())]
call desc_a%l2gip(ilv,info,owned=.false.)
call psb_geall(ilaggr,desc_a,info)
ilaggr = -1
call psb_geasb(ilaggr,desc_a,info)
nr = a%get_nrows()
nc = a%get_ncols()
if (size(w) < nc) then
call psb_realloc(nc,w,info)
end if
call psb_halo(w,desc_a,info)
if (debug) write(0,*) iam,' buildprol into buildmatching:',&
& nr, nc
if (debug_sync) then
call psb_barrier(ictxt)
if (iam == 0) write(0,*)' buildprol into buildmatching:',&
& nr, nc
end if
if (do_timings) call psb_toc(idx_phase1)
if (do_timings) call psb_tic(idx_bldmtc)
call amg_dbuild_decmatch(parallel_,matching_,lambda_,w,a,desc_a,mate,info)
if (do_timings) call psb_toc(idx_bldmtc)
if (debug) write(0,*) iam,' buildprol from buildmatching:',&
& info
if (debug_sync) then
call psb_barrier(ictxt)
if (iam == 0) write(0,*)' out from buildmatching:', info
end if
if (info == 0) then
if (do_timings) call psb_tic(idx_phase2)
if (debug_sync) then
call psb_barrier(ictxt)
if (iam == 0) write(0,*)' Into building the tentative prol:'
end if
call psb_geall(wtemp,desc_a,info)
wtemp = dzero
call psb_geasb(wtemp,desc_a,info)
nlaggr(iam) = 0
nlpairs = 0
nlsingl = 0
nunmatched = 0
!
! First sweep
! On return from build_matching, mate has been converted to local numbering,
! so assigning to idx is OK.
!
do k=1, nr
idx = mate(k)
!
! Figure out an allocation of aggregates to processes
!
if (idx < 0) then
!
! Unmatched vertex, potential singleton.
!
nunmatched = nunmatched + 1
if (abs(w(k))<epsilon(nrmagg)) then
! Keep it unaggregated
wtemp(k) = dzero
else
! Create a singleton aggregate
nlaggr(iam) = nlaggr(iam) + 1
ilaggr(k) = nlaggr(iam)
wtemp(k) = w(k)/abs(w(k))
nlsingl = nlsingl + 1
end if
!!$ write(0,*) k,mate(k),ilaggr(k),' negative match ',abs(w(k)), epsilon(nrmagg)
else if (idx > nc) then
write(0,*) 'Impossible: mate(k) > nc'
cycle
else
if (ilaggr(k) == -1) then
wk = w(k)
widx = w(idx)
wmax = max(abs(wk),abs(widx))
nrmagg = wmax*sqrt((wk/wmax)**2+(widx/wmax)**2)
if (nrmagg > epsilon(nrmagg)) then
if (idx <= nr) then
if (ilaggr(idx) == -1) then
! Now, if both vertices are local, the aggregate is local
! (kinda obvious).
nlaggr(iam) = nlaggr(iam) + 1
ilaggr(k) = nlaggr(iam)
ilaggr(idx) = nlaggr(iam)
wtemp(k) = w(k)/nrmagg
wtemp(idx) = w(idx)/nrmagg
end if
nlpairs = nlpairs+1
else
write(0,*) 'Really? mate(k) > nr? ',mate(k),nr
end if
else
if (abs(w(k))<epsilon(nrmagg)) then
! Keep it unaggregated
wtemp(k) = dzero
else
! Create a singleton aggregate
nlaggr(iam) = nlaggr(iam) + 1
ilaggr(k) = nlaggr(iam)
wtemp(k) = w(k)/abs(w(k))
nlsingl = nlsingl + 1
end if
end if
end if
end if
end do
if (do_timings) call psb_toc(idx_phase2)
if (do_timings) call psb_tic(idx_phase3)
! Ok, now compute offsets, gather halo and fix non-local
! aggregates (those where ilaggr == -2)
call psb_sum(ictxt,nlaggr)
ntaggr = sum(nlaggr(0:np-1))
naggrm1 = sum(nlaggr(0:iam-1))
naggrp1 = sum(nlaggr(0:iam))
!
! Shift all indices already assigned (i.e. >0)
!
do k=1,nr
if (ilaggr(k) > 0) then
ilaggr(k) = ilaggr(k) + naggrm1
!!$ else
!!$ write(0,*) 'Leftover ILAGGR',k,ilaggr(k),mate(k),abs(w(k)),epsilon(nrmagg)
end if
end do
call psb_halo(ilaggr,desc_a,info)
call psb_halo(wtemp,desc_a,info)
! Cleanup as yet unmarked entries
do k=1,nr
if (ilaggr(k) == -2) then
idx = mate(k)
if (idx > nr) then
i = ilaggr(idx)
if (i > 0) then
ilaggr(k) = i
else
write(0,*) 'Error : unresolved (paired) index ',k,idx,i,nr,nc, ilv(k),ilv(idx)
end if
else
write(0,*) 'Error : unresolved (paired) index ',k,idx,i,nr,nc, ilv(k),ilv(idx)
end if
end if
if (ilaggr(k) <0) then
write(0,*) 'Decmatch: Funny number: ',k,ilv(k),ilaggr(k),wtemp(k)
end if
end do
if (debug_sync) then
call psb_barrier(ictxt)
if (iam == 0) write(0,*)' Done building the tentative prol:'
end if
if (dump_mate) then
block
integer(psb_lpk_), allocatable :: glaggr(:)
write(aname,'(a,i3.3,a,i3.3,a)') 'mateg-',cnt,'-p',iam,'.mtx'
open(20,file=aname)
write(20,'(a,I3,a)') '% sparse vector on process ',iam,' '
do k=1, nr
write(20,'(3(I8,1X))') ilv(k),ilv(mate(k))
end do
close(20)
write(aname,'(a,i3.3,a,i3.3,a)') 'nloc-',cnt,'-p',iam,'.mtx'
open(20,file=aname)
write(20,'(a,I3,a)') '% sparse vector on process ',iam,' '
write(20,'(a,I12,a)') 'nlpairs ',nlpairs
write(20,'(a,I12,a)') 'nlsingl ',nlsingl
write(20,'(a,I12,a)') 'nlaggr(iam) ',nlaggr(iam)
close(20)
write(aname,'(a,i3.3,a,i3.3,a,i3.3,a)') 'ilaggr-',cnt,'-i',iam,'-p',np,'.mtx'
open(20,file=aname)
write(20,'(a,I3,a)') '% sparse vector on process ',iam,' '
do k=1, nr
write(20,'(3(I8,1X))') ilv(k),ilaggr(k)
end do
close(20)
write(aname,'(a,i3.3,a,i3.3,a)') 'glaggr-',cnt,'-p',np,'.mtx'
call psb_gather(glaggr,ilaggr,desc_a,info,root=izero)
if (iam==0) call mm_array_write(glaggr,'Aggregates ',info,filename=aname)
cnt=cnt+1
end block
end if
block
integer(psb_lpk_) :: v(3)
v(1) = nunmatched
v(2) = nlsingl
v(3) = nlpairs
call psb_sum(ictxt,v)
nunmatched = v(1)
nlsingl = v(2)
nlpairs = v(3)
end block
if (print_statistics) then
if (iam == 0) then
write(0,*) 'Matching statistics: Unmatched nodes ',&
& nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs
end if
end if
if (display_out_) then
block
integer(psb_ipk_) :: idx
!
! And finally print out
!
do i=0,np-1
call psb_barrier(ictxt)
if (iam == i) then
write(0,*) 'Process ', iam,' hosts aggregates: (',naggrm1+1,' : ',naggrp1-1,')'
do k=1, nr
idx = mate(k)
kg = ilv(k)
if (idx >0) then
idxg = ilv(idx)
else
idxg = -1
end if
if (idx < 0) then
write(0,*) kg,': singleton (',kg,' ( Proc',iam,') ) into aggregate => ', ilaggr(k)
else if (idx <= nr) then
write(0,*) kg,': paired with (',idxg,' ( Proc',iam,') ) into aggregate => ', ilaggr(k)
else
call desc_a%indxmap%qry_halo_owner(idx,iown,info)
write(0,*) kg,': paired with (',idxg,' ( Proc',iown,') ) into aggregate => ', ilaggr(k)
end if
end do
flush(0)
end if
end do
end block
end if
! Dirty trick: allocate tmpcoo with local
! number of aggregates, then change to ntaggr.
! Just to make sure the allocation is not global
lnr = nr
call tmpcoo%allocate(lnr,nlaggr(iam),lnr)
k = 0
do i=1,nr
!
! Note: at this point, a value ilaggr(i)<=0
! tags an unaggregated row, and it has to be
! left alone (i.e.: it should stay at fine level only)
!
if (ilaggr(i)>0) then
k = k + 1
tmpcoo%val(k) = wtemp(i)
tmpcoo%ia(k) = i
tmpcoo%ja(k) = ilaggr(i)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! This is now in row-major
if (display_out_) then
call psb_barrier(ictxt)
flush(0)
if (iam == 0) write(0,*) 'Prolongator: '
flush(0)
do i=0,np-1
call psb_barrier(ictxt)
if (iam == i) then
do k=1, nr
write(0,*) ilv(tmpcoo%ia(k)),tmpcoo%ja(k), tmpcoo%val(k)
end do
flush(0)
end if
end do
end if
call prol%mv_from(tmpcoo)
if (do_timings) call psb_toc(idx_phase3)
if (print_out_) then
write(aname,'(a,i3.3,a)') 'prol-g-',iam,'.mtx'
call prol%print(fname=aname,head='Test ',ivr=ilv)
write(aname,'(a,i3.3,a)') 'prol-',iam,'.mtx'
call prol%print(fname=aname,head='Test ')
end if
else
write(0,*) iam,' : error from Matching: ',info
end if
end subroutine amg_ddecmatch_build_prol
subroutine amg_dbuild_decmatch(parallel,matching,lambda,w,a,desc_a,mate,info)
use psb_base_mod
use psb_util_mod
use iso_c_binding
implicit none
logical, intent(in) :: parallel
integer(psb_ipk_), intent(in) :: matching
real(psb_dpk_), intent(in) :: lambda
real(psb_dpk_), target :: w(:)
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type) :: desc_a
integer(psb_ipk_), allocatable, intent(out), target :: mate(:)
integer(psb_ipk_), intent(out) :: info
type(psb_d_csr_sparse_mat), target :: tcsr
real(psb_dpk_), allocatable, target :: diag(:)
real(psb_dpk_) :: ph0t,ph1t,ph2t
type(psb_ctxt_type) :: ictxt
integer(psb_ipk_) :: iam, np
integer(psb_ipk_) :: nr, nc, nz, i, nunmatch, ipar
integer(psb_ipk_), save :: cnt=2
logical, parameter :: debug=.false., dump_ahat=.false., debug_sync=.false.
logical, parameter :: old_style=.false., sort_minp=.true.
character(len=40) :: name='build_matching', fname
integer(psb_ipk_), save :: idx_cmboxp=-1, idx_bldahat=-1, idx_phase2=-1, idx_phase3=-1
logical, parameter :: do_timings=.true.
ictxt = desc_a%get_ctxt()
call psb_info(ictxt,iam,np)
nr = a%get_nrows()
call a%cp_to(tcsr)
call psb_realloc(nr,mate,info)
diag = a%get_diag(info)
if (parallel) then
ipar = 2
else
ipar = 1
end if
!
! Now call matching!
!
if (debug) write(0,*) iam,' buildmatching into NewMatch:'
if (do_timings) call psb_tic(idx_cmboxp)
info = dnew_Match_If(ipar,matching,lambda,nr,c_loc(tcsr%irp),c_loc(tcsr%ja),&
& c_loc(tcsr%val),c_loc(diag),c_loc(w),c_loc(mate))
if (do_timings) call psb_toc(idx_cmboxp)
if (debug) write(0,*) iam,' buildmatching from NewMatch:', info
if (debug_sync) then
call psb_max(ictxt,info)
if (iam == 0) write(0,*)' done NewMatch', info
end if
if (do_timings) call psb_tic(idx_phase3)
nunmatch = count(mate(1:nr)<=0)
! call psb_sum(ictxt,nunmatch)
!if (nunmatch /= 0) write(0,*) iam,' Unmatched nodes local imbalance ',nunmatch
! if (count(mate(1:nr)<0) /= nunmatch) write(0,*) iam,' Matching results ?',&
! & nunmatch, count(mate(1:nr)<0)
if (debug_sync) then
call psb_barrier(ictxt)
if (iam == 0) write(0,*)' done build_matching '
end if
if (do_timings) call psb_toc(idx_phase3)
return
9999 continue
call psb_error(ictxt)
end subroutine amg_dbuild_decmatch
end module amg_d_decmatch_mod
+125
View File
@@ -0,0 +1,125 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
! The aggregator object hosts the aggregation method for building
! the multilevel hierarchy. This variant is based on the hybrid method
! presented in
!
! S. Gratton, P. Henon, P. Jiranek and X. Vasseur:
! Reducing complexity of algebraic multigrid by aggregation
! Numerical Lin. Algebra with Applications, 2016, 23:501-518
!
module amg_d_hybrid_aggregator_mod
use amg_d_dec_aggregator_mod
!
! sm - class(amg_T_base_smoother_type), allocatable
! The current level preconditioner (aka smoother).
! parms - type(amg_RTml_parms)
! The parameters defining the multilevel strategy.
! ac - The local part of the current-level matrix, built by
! coarsening the previous-level matrix.
! desc_ac - type(psb_desc_type).
! The communication descriptor associated to the matrix
! stored in ac.
! base_a - type(psb_Tspmat_type), pointer.
! Pointer (really a pointer!) to the local part of the current
! matrix (so we have a unified treatment of residuals).
! We need this to avoid passing explicitly the current matrix
! to the routine which applies the preconditioner.
! base_desc - type(psb_desc_type), pointer.
! Pointer to the communication descriptor associated to the
! matrix pointed by base_a.
! map - Stores the maps (restriction and prolongation) between the
! vector spaces associated to the index spaces of the previous
! and current levels.
!
! Methods:
! Most methods follow the encapsulation hierarchy: they take whatever action
! is appropriate for the current object, then call the corresponding method for
! the contained object.
! As an example: the descr() method prints out a description of the
! level. It starts by invoking the descr() method of the parms object,
! then calls the descr() method of the smoother object.
!
! descr - Prints a description of the object.
! default - Set default values
! dump - Dump to file object contents
! set - Sets various parameters; when a request is unknown
! it is passed to the smoother object for further processing.
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
!
!
type, extends(amg_d_dec_aggregator_type) :: amg_d_hybrid_aggregator_type
contains
procedure, pass(ag) :: bld_tprol => amg_d_hybrid_aggregator_build_tprol
procedure, nopass :: fmt => amg_d_hybrid_aggregator_fmt
end type amg_d_hybrid_aggregator_type
interface
subroutine amg_d_hybrid_aggregator_build_tprol(ag,parms,a,desc_a,ilaggr,nlaggr,op_prol,info)
import :: amg_d_hybrid_aggregator_type, psb_desc_type, psb_dspmat_type, psb_dpk_, &
& psb_ipk_, psb_long_int_k_, amg_dml_parms
implicit none
class(amg_d_hybrid_aggregator_type), target, intent(inout) :: ag
type(amg_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_dspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_hybrid_aggregator_build_tprol
end interface
contains
function amg_d_hybrid_aggregator_fmt() result(val)
implicit none
character(len=32) :: val
val = "Hybrid Decoupled aggregation"
end function amg_d_hybrid_aggregator_fmt
end module amg_d_hybrid_aggregator_mod
+7 -7
View File
@@ -234,7 +234,7 @@ contains
! Arguments
class(amg_d_ilu_solver_type), intent(inout) :: sv
sv%fact_type = amg_ilu_n_
sv%fact_type = psb_ilu_n_
sv%fill_in = 0
sv%thresh = dzero
@@ -255,13 +255,13 @@ contains
info = psb_success_
call amg_check_def(sv%fact_type,&
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(amg_ilu_n_,amg_milu_n_)
case(psb_ilu_n_,psb_milu_n_)
call amg_check_def(sv%fill_in,&
& 'Level',izero,is_int_non_negative)
case(amg_ilu_t_)
case(psb_ilu_t_)
call amg_check_def(sv%thresh,&
& 'Eps',dzero,is_legal_d_fact_thrs)
end select
@@ -439,9 +439,9 @@ contains
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
& amg_fact_names(sv%fact_type)
select case(sv%fact_type)
case(amg_ilu_n_,amg_milu_n_)
case(psb_ilu_n_,psb_milu_n_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
case(amg_ilu_t_)
case(psb_ilu_t_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
end select
@@ -496,7 +496,7 @@ contains
implicit none
integer(psb_ipk_) :: val
val = amg_ilu_n_
val = psb_ilu_n_
end function d_ilu_solver_get_id
function d_ilu_solver_get_wrksize() result(val)
+1 -2
View File
@@ -109,12 +109,11 @@ module amg_d_inner_mod
end interface amg_map_to_tprol
abstract interface
subroutine amg_daggrmat_var_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,parms,&
subroutine amg_daggrmat_var_bld(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
import :: psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_, psb_ldspmat_type
import :: amg_d_onelev_type, amg_dml_parms
implicit none
integer(psb_ipk_), intent(in) :: dol1smoothing
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
-12
View File
@@ -52,7 +52,6 @@ module amg_d_invk_solver
contains
procedure, pass(sv) :: check => amg_d_invk_solver_check
procedure, pass(sv) :: clone => amg_d_invk_solver_clone
procedure, pass(sv) :: clone_settings => amg_d_invk_solver_clone_settings
procedure, pass(sv) :: build => amg_d_invk_solver_bld
procedure, pass(sv) :: cseti => amg_d_invk_solver_cseti
procedure, pass(sv) :: descr => amg_d_invk_solver_descr
@@ -74,17 +73,6 @@ module amg_d_invk_solver
end subroutine amg_d_invk_solver_clone
end interface
interface
subroutine amg_d_invk_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
& amg_d_base_solver_type, psb_dpk_, amg_d_invk_solver_type, psb_ipk_
Implicit None
class(amg_d_invk_solver_type), intent(inout) :: sv
class(amg_d_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_invk_solver_clone_settings
end interface
interface
subroutine amg_d_invk_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
-12
View File
@@ -52,7 +52,6 @@ module amg_d_invt_solver
contains
procedure, pass(sv) :: check => amg_d_invt_solver_check
procedure, pass(sv) :: clone => amg_d_invt_solver_clone
procedure, pass(sv) :: clone_settings => amg_d_invt_solver_clone_settings
procedure, pass(sv) :: build => amg_d_invt_solver_bld
procedure, pass(sv) :: cseti => amg_d_invt_solver_cseti
procedure, pass(sv) :: csetr => amg_d_invt_solver_csetr
@@ -74,17 +73,6 @@ module amg_d_invt_solver
end subroutine amg_d_invt_solver_clone
end interface
interface
subroutine amg_d_invt_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
& amg_d_base_solver_type, psb_dpk_, amg_d_invt_solver_type, psb_ipk_
Implicit None
class(amg_d_invt_solver_type), intent(inout) :: sv
class(amg_d_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_invt_solver_clone_settings
end interface
interface
subroutine amg_d_invt_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
+2 -2
View File
@@ -203,8 +203,8 @@ module amg_d_jac_smoother
subroutine amg_d_jac_smoother_clone_settings(sm,smout,info)
import :: amg_d_jac_smoother_type, psb_dpk_, &
& amg_d_base_smoother_type, psb_ipk_
class(amg_d_jac_smoother_type), intent(inout) :: sm
class(amg_d_base_smoother_type), intent(inout) :: smout
class(amg_d_jac_smoother_type), intent(inout) :: sm
class(amg_d_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_jac_smoother_clone_settings
end interface
-585
View File
@@ -1,585 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
! File: amg_d_jac_solver_mod.f90
!
! Module: amg_d_jac_solver_mod
!
! This module defines:
! - the amg_d_jac_solver_type data structure containing the ingredients
! for a local Jacobi iteration. The iterations are local to a process
! (they operate on the block diagonal).
!
!
module amg_d_jac_solver
use amg_d_base_solver_mod
type, extends(amg_d_base_solver_type) :: amg_d_jac_solver_type
type(psb_dspmat_type) :: a
type(psb_d_vect_type), allocatable :: dv
real(psb_dpk_), allocatable :: d(:)
integer(psb_ipk_) :: sweeps
real(psb_dpk_) :: eps
contains
procedure, pass(sv) :: dump => amg_d_jac_solver_dmp
procedure, pass(sv) :: check => d_jac_solver_check
procedure, pass(sv) :: clone => amg_d_jac_solver_clone
procedure, pass(sv) :: clone_settings => amg_d_jac_solver_clone_settings
procedure, pass(sv) :: clear_data => amg_d_jac_solver_clear_data
procedure, pass(sv) :: build => amg_d_jac_solver_bld
procedure, pass(sv) :: cnv => amg_d_jac_solver_cnv
procedure, pass(sv) :: apply_v => amg_d_jac_solver_apply_vect
procedure, pass(sv) :: apply_a => amg_d_jac_solver_apply
procedure, pass(sv) :: free => d_jac_solver_free
procedure, pass(sv) :: cseti => d_jac_solver_cseti
procedure, pass(sv) :: csetc => d_jac_solver_csetc
procedure, pass(sv) :: csetr => d_jac_solver_csetr
procedure, pass(sv) :: descr => d_jac_solver_descr
procedure, pass(sv) :: default => d_jac_solver_default
procedure, pass(sv) :: sizeof => d_jac_solver_sizeof
procedure, pass(sv) :: get_nzeros => d_jac_solver_get_nzeros
procedure, nopass :: get_wrksz => d_jac_solver_get_wrksize
procedure, nopass :: get_fmt => d_jac_solver_get_fmt
procedure, nopass :: get_id => d_jac_solver_get_id
procedure, nopass :: is_iterative => d_jac_solver_is_iterative
end type amg_d_jac_solver_type
type, extends(amg_d_jac_solver_type) :: amg_d_l1_jac_solver_type
contains
procedure, pass(sv) :: build => amg_d_l1_jac_solver_bld
procedure, pass(sv) :: descr => d_l1_jac_solver_descr
procedure, nopass :: get_fmt => d_l1_jac_solver_get_fmt
procedure, nopass :: get_id => d_l1_jac_solver_get_id
end type amg_d_l1_jac_solver_type
private :: d_jac_solver_bld, d_jac_solver_apply, &
& d_jac_solver_free, &
& d_jac_solver_descr, d_jac_solver_sizeof, &
& d_jac_solver_default, d_jac_solver_dmp, &
& d_jac_solver_apply_vect, d_jac_solver_get_nzeros, &
& d_jac_solver_get_fmt, d_jac_solver_check,&
& d_jac_solver_is_iterative, &
& d_jac_solver_get_id, d_jac_solver_get_wrksize
interface
subroutine amg_d_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,wv,info,init,initu)
import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(amg_d_jac_solver_type), intent(inout) :: sv
type(psb_d_vect_type),intent(inout) :: x
type(psb_d_vect_type),intent(inout) :: y
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
end subroutine amg_d_jac_solver_apply_vect
end interface
interface
subroutine amg_d_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(amg_d_jac_solver_type), intent(inout) :: sv
real(psb_dpk_),intent(inout) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
real(psb_dpk_),intent(inout), optional :: initu(:)
end subroutine amg_d_jac_solver_apply
end interface
interface
subroutine amg_d_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_d_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_dspmat_type), intent(in), target, optional :: b
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_d_jac_solver_bld
end interface
interface
subroutine amg_d_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, amg_d_l1_jac_solver_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_d_l1_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_dspmat_type), intent(in), target, optional :: b
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_d_l1_jac_solver_bld
end interface
interface
subroutine amg_d_jac_solver_cnv(sv,info,amold,vmold,imold)
import :: amg_d_jac_solver_type, psb_dpk_, &
& psb_d_base_sparse_mat, psb_d_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
class(amg_d_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_d_jac_solver_cnv
end interface
interface
subroutine amg_d_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, &
& psb_ipk_
implicit none
class(amg_d_jac_solver_type), intent(in) :: sv
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: level
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: solver, global_num
end subroutine amg_d_jac_solver_dmp
end interface
interface
subroutine amg_d_jac_solver_clone(sv,svout,info)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
& psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
& amg_d_base_solver_type, amg_d_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_d_jac_solver_type), intent(inout) :: sv
class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_jac_solver_clone
end interface
!!$ interface
!!$ subroutine amg_d_l1_jac_solver_clone(sv,svout,info)
!!$ import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
!!$ & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
!!$ & amg_d_base_solver_type, amg_d_l1_jac_solver_type, psb_ipk_
!!$ Implicit None
!!$
!!$ ! Arguments
!!$ class(amg_d_l1_jac_solver_type), intent(inout) :: sv
!!$ class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ end subroutine amg_d_l1_jac_solver_clone
!!$ end interface
interface
subroutine amg_d_jac_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
& psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
& amg_d_base_solver_type, amg_d_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_d_jac_solver_type), intent(inout) :: sv
class(amg_d_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_jac_solver_clone_settings
end interface
interface
subroutine amg_d_jac_solver_clear_data(sv,info)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
& psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
& amg_d_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_d_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_jac_solver_clear_data
end interface
contains
subroutine d_jac_solver_default(sv)
Implicit None
! Arguments
class(amg_d_jac_solver_type), intent(inout) :: sv
sv%sweeps = ione
sv%eps = dzero
return
end subroutine d_jac_solver_default
subroutine d_jac_solver_check(sv,info)
Implicit None
! Arguments
class(amg_d_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_jac_solver_check'
call psb_erractionsave(err_act)
info = psb_success_
call amg_check_def(sv%sweeps,&
& 'Jacobi sweeps',ione,is_int_positive)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine d_jac_solver_check
subroutine d_jac_solver_cseti(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_d_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_jac_solver_cseti'
info = psb_success_
call psb_erractionsave(err_act)
select case(psb_toupper(what))
case('SOLVER_SWEEPS')
sv%sweeps = val
case default
call sv%amg_d_base_solver_type%set(what,val,info,idx=idx)
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine d_jac_solver_cseti
subroutine d_jac_solver_csetc(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_d_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act, ival
character(len=20) :: name='d_jac_solver_csetc'
info = psb_success_
call psb_erractionsave(err_act)
call sv%amg_d_base_solver_type%set(what,val,info,idx=idx)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info, name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine d_jac_solver_csetc
subroutine d_jac_solver_csetr(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_d_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_jac_solver_csetr'
call psb_erractionsave(err_act)
info = psb_success_
select case(psb_toupper(what))
case('SOLVER_EPS')
sv%eps = val
case default
call sv%amg_d_base_solver_type%set(what,val,info,idx=idx)
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine d_jac_solver_csetr
subroutine d_jac_solver_free(sv,info)
Implicit None
! Arguments
class(amg_d_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_jac_solver_free'
call psb_erractionsave(err_act)
info = psb_success_
call sv%a%free()
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
if (allocated(sv%d)) deallocate(sv%d)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine d_jac_solver_free
subroutine d_jac_solver_descr(sv,info,iout,coarse,prefix)
Implicit None
! Arguments
class(amg_d_jac_solver_type), intent(in) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='amg_d_jac_solver_descr'
integer(psb_ipk_) :: iout_
character(1024) :: prefix_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
endif
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if (sv%eps<=dzero) then
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine d_jac_solver_descr
function d_jac_solver_get_nzeros(sv) result(val)
implicit none
! Arguments
class(amg_d_jac_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = 0
val = val + sv%a%get_nzeros()
val = val + sv%dv%get_nrows()
return
end function d_jac_solver_get_nzeros
function d_jac_solver_sizeof(sv) result(val)
implicit none
! Arguments
class(amg_d_jac_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = psb_sizeof_ip
val = val + sv%a%sizeof()
val = val + sv%dv%sizeof()
return
end function d_jac_solver_sizeof
function d_jac_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Jacobi solver"
end function d_jac_solver_get_fmt
function d_jac_solver_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_jac_
end function d_jac_solver_get_id
!
! If this is true, then the solver needs a starting
! guess. Currently only handled in JAC smoother.
!
function d_jac_solver_is_iterative() result(val)
implicit none
logical :: val
val = .true.
end function d_jac_solver_is_iterative
function d_jac_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 2
end function d_jac_solver_get_wrksize
subroutine d_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
Implicit None
! Arguments
class(amg_d_l1_jac_solver_type), intent(in) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='amg_d_l1_jac_solver_descr'
integer(psb_ipk_) :: iout_
character(1024) :: prefix_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
endif
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if (sv%eps<=dzero) then
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine d_l1_jac_solver_descr
function d_l1_jac_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "L1-Jacobi solver"
end function d_l1_jac_solver_get_fmt
function d_l1_jac_solver_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_l1_jac_
end function d_l1_jac_solver_get_id
end module amg_d_jac_solver
@@ -73,22 +73,6 @@ module amg_d_matchboxp_mod
use iso_c_binding
use psb_base_cbind_mod
#if defined(PSB_SERIAL_MPI)
interface MatchingC
subroutine dMatchingC(nlver,nledge,verlocptr,verlocind,edgelocweight,&
& verdistance, mate) bind(c,name='dMatching')
use iso_c_binding
import :: psb_c_ipk_, psb_c_lpk_
implicit none
integer(psb_c_lpk_), value :: nlver,nledge
integer(psb_c_lpk_) :: verlocptr(*),verlocind(*), verdistance(*)
integer(psb_c_lpk_) :: mate(*)
real(c_double) :: edgelocweight(*)
end subroutine dMatchingC
end interface MatchingC
#else
interface MatchBoxPC
subroutine dMatchBoxPC(nlver,nledge,verlocptr,verlocind,edgelocweight,&
& verdistance, mate, myrank, numprocs, icomm,&
@@ -109,7 +93,7 @@ module amg_d_matchboxp_mod
real(c_double) :: msgpercent(*)
end subroutine dMatchBoxPC
end interface MatchBoxPC
#endif
interface amg_i_aggr_assign
module procedure amg_i_d_aggr_assign
end interface amg_i_aggr_assign
@@ -1145,15 +1129,11 @@ contains
call psb_barrier(ictxt)
if (me == 0) write(0,*)' Calling MatchBoxP '
end if
#if defined(PSB_SERIAL_MPI)
call MatchingC(nlver,nledge,verlocptr,verlocind,edgelocweight,&
& verdistance, mate)
#else
call MatchBoxPC(nlver,nledge,verlocptr,verlocind,edgelocweight,&
& verdistance, mate, mrank, mnp, icomm,&
& msgindsent,msgactualsent,msgpercent,&
& ph0_time, ph1_time, ph2_time, ph1_card, ph2_card)
#endif
verlocptr(:) = verlocptr(:) + 1
verlocind(:) = verlocind(:) + 1
verdistance(:) = verdistance(:) + 1
+12 -13
View File
@@ -52,10 +52,10 @@
!
module amg_d_mumps_solver
use amg_d_base_solver_mod
#if defined(AMG_HAVE_MUMPS) && defined(AMG_HAVE_MUMPS_MODULES)
#if defined(HAVE_MUMPS_) && defined(HAVE_MUMPS_MODULES_)
use dmumps_struc_def
#endif
#if defined(AMG_HAVE_MUMPS) && defined(AMG_HAVE_MUMPS_INCLUDES)
#if defined(HAVE_MUMPS_) && defined(HAVE_MUMPS_INCLUDES_)
include 'dmumps_struc.h'
#endif
@@ -68,7 +68,7 @@ module amg_d_mumps_solver
end type amg_d_mumps_rcntl_item
type, extends(amg_d_base_solver_type) :: amg_d_mumps_solver_type
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
type(dmumps_struc), allocatable :: id
#else
integer, allocatable :: id
@@ -78,8 +78,7 @@ module amg_d_mumps_solver
!
! Controls to be set before MUMPS instantiation:
!
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: 'LOCAL_SOLVER
! 1==amg_global_solver_: 'GLOBAL_SOLVER'
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: LOCAL 1==amg_global_solver_: GLOBAL
! IPAR(2) : MUMPS_PRINT_ERR print verbosity (see MUMPS)
! IPAR(3) : MUMPS_SYM 0: non-symmetric 2: symmetric
integer(psb_ipk_), dimension(3) :: ipar
@@ -189,7 +188,7 @@ contains
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
@@ -239,7 +238,7 @@ contains
character(len=20) :: name='d_mumps_solver_clear_data'
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
if (allocated(sv%id)) then
if (sv%built) then
@@ -279,7 +278,7 @@ contains
character(len=20) :: name='d_mumps_solver_free'
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
call sv%clear_data(info)
if ((info == 0).and.allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
@@ -383,7 +382,7 @@ subroutine d_mumps_solver_csetc(sv,what,val,info,idx)
select case(psb_toupper(trim(what)))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_LOC_GLOB')
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
#endif
@@ -421,7 +420,7 @@ subroutine d_mumps_solver_cseti(sv,what,val,info,idx)
call psb_erractionsave(err_act)
select case(psb_toupper(what))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_LOC_GLOB')
sv%ipar(1) = val
case('MUMPS_PRINT_ERR')
@@ -467,7 +466,7 @@ subroutine d_mumps_solver_csetr(sv,what,val,info,idx)
call psb_erractionsave(err_act)
select case(psb_toupper(what))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_RPAR_ENTRY')
if(present(idx)) then
! Note: this will allocate %item
@@ -504,7 +503,7 @@ subroutine d_mumps_solver_default(sv)
info = psb_success_
call psb_erractionsave(err_act)
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
if (.not.allocated(sv%id)) then
allocate(sv%id,stat=info)
if (info /= psb_success_) then
@@ -561,7 +560,7 @@ function d_mumps_solver_sizeof(sv) result(val)
class(amg_d_mumps_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer :: i
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
#else
val = 0
+585
View File
@@ -0,0 +1,585 @@
!
!
! The aggregator object hosts the aggregation method for building
! the multilevel hierarchy. This variant is based on the hybrid method
! presented in
!
!
! sm - class(amg_T_base_smoother_type), allocatable
! The current level preconditioner (aka smoother).
! parms - type(amg_RTml_parms)
! The parameters defining the multilevel strategy.
! ac - The local part of the current-level matrix, built by
! coarsening the previous-level matrix.
! desc_ac - type(psb_desc_type).
! The communication descriptor associated to the matrix
! stored in ac.
! base_a - type(psb_Tspmat_type), pointer.
! Pointer (really a pointer!) to the local part of the current
! matrix (so we have a unified treatment of residuals).
! We need this to avoid passing explicitly the current matrix
! to the routine which applies the preconditioner.
! base_desc - type(psb_desc_type), pointer.
! Pointer to the communication descriptor associated to the
! matrix pointed by base_a.
! map - Stores the maps (restriction and prolongation) between the
! vector spaces associated to the index spaces of the previous
! and current levels.
!
! Methods:
! Most methods follow the encapsulation hierarchy: they take whatever action
! is appropriate for the current object, then call the corresponding method for
! the contained object.
! As an example: the descr() method prints out a description of the
! level. It starts by invoking the descr() method of the parms object,
! then calls the descr() method of the smoother object.
!
! descr - Prints a description of the object.
! default - Set default values
! dump - Dump to file object contents
! set - Sets various parameters; when a request is unknown
! it is passed to the smoother object for further processing.
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
!
!
module amg_d_newmatch_aggregator_mod
use amg_d_base_aggregator_mod
use iso_c_binding
type, bind(c):: nwm_Vector
type(c_ptr) :: data
integer(c_int) :: size
integer(c_int) :: owns_data
end type nwm_Vector
type, bind(c):: nwm_CSRMatrix
type(c_ptr) :: i
type(c_ptr) :: j
integer(c_int) :: num_rows
integer(c_int) :: num_cols
integer(c_int) :: num_nonzeros
integer(c_int) :: owns_data
type(c_ptr) :: data
end type nwm_CSRMatrix
type, extends(amg_d_base_aggregator_type) :: amg_d_newmatch_aggregator_type
integer(psb_ipk_) :: matching_alg
integer(psb_ipk_) :: n_sweeps
!
! Note: the BootCMatch kernel we invoke overwrites
! the W argument with its update. Hence, copy it in w_nxt
! before passing it to the matching
!
integer(psb_ipk_) :: orig_aggr_size
integer(psb_ipk_) :: jacobi_sweeps
real(psb_dpk_), allocatable :: w(:), w_nxt(:)
type(psb_dspmat_type), allocatable :: prol, restr
type(psb_dspmat_type), allocatable :: ac, base_a, rwa
type(psb_desc_type), allocatable :: desc_ac, desc_ax, base_desc, rwdesc
type(nwm_Vector) :: w_c_nxt
integer(psb_ipk_) :: max_csize
integer(psb_ipk_) :: max_nlevels
real(psb_dpk_) :: lambda
logical :: reproducible_matching = .false.
logical :: need_symmetrize = .false.
logical :: unsmoothed_hierarchy = .true.
logical :: parallel_matching = .true.
contains
procedure, pass(ag) :: bld_tprol => amg_d_newmatch_aggregator_build_tprol
procedure, pass(ag) :: csetc => amg_d_newmatch_aggr_csetc
procedure, pass(ag) :: csetr => amg_d_newmatch_aggr_csetr
procedure, pass(ag) :: cseti => d_newmatch_aggr_cseti
procedure, pass(ag) :: default => d_newmatch_aggr_set_default
procedure, pass(ag) :: mat_asb => amg_d_newmatch_aggregator_mat_asb
procedure, pass(ag) :: mat_bld => amg_d_newmatch_aggregator_mat_bld
procedure, pass(ag) :: inner_mat_asb => amg_d_newmatch_aggregator_inner_mat_asb
procedure, pass(ag) :: update_next => d_newmatch_aggregator_update_next
procedure, pass(ag) :: bld_wnxt => d_newmatch_bld_wnxt
procedure, pass(ag) :: bld_default_w => d_bld_default_w
procedure, pass(ag) :: set_c_default_w => d_set_default_nwm_w
procedure, pass(ag) :: descr => d_newmatch_aggregator_descr
procedure, pass(ag) :: clone => d_newmatch_aggregator_clone
procedure, pass(ag) :: free => d_newmatch_aggregator_free
procedure, nopass :: fmt => d_newmatch_aggregator_fmt
end type amg_d_newmatch_aggregator_type
interface
subroutine amg_d_newmatch_aggregator_build_tprol(ag,parms,ag_data,&
& a,desc_a,ilaggr,nlaggr,t_prol,info)
import :: amg_d_newmatch_aggregator_type, psb_desc_type, &
& psb_dspmat_type, psb_ldspmat_type, psb_dpk_, &
& psb_ipk_, psb_lpk_, psb_epk_, amg_dml_parms, amg_daggr_data
implicit none
class(amg_d_newmatch_aggregator_type), target, intent(inout) :: ag
type(amg_dml_parms), intent(inout) :: parms
type(amg_daggr_data), intent(in) :: ag_data
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_ldspmat_type), intent(out) :: t_prol
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_newmatch_aggregator_build_tprol
end interface
interface
subroutine amg_d_newmatch_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
import :: amg_d_newmatch_aggregator_type, psb_desc_type, &
& psb_dspmat_type, psb_ldspmat_type, psb_dpk_, &
& psb_ipk_, psb_lpk_, psb_epk_, amg_dml_parms
implicit none
class(amg_d_newmatch_aggregator_type), target, intent(inout) :: ag
type(amg_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(psb_dspmat_type), intent(out) :: op_prol,ac,op_restr
type(psb_ldspmat_type), intent(inout) :: t_prol
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_newmatch_aggregator_mat_bld
end interface
interface
subroutine amg_d_newmatch_aggregator_mat_asb(ag,parms,a,desc_a,&
& ac,desc_ac, op_prol,op_restr,info)
import :: amg_d_newmatch_aggregator_type, psb_desc_type, &
& psb_dspmat_type, psb_ldspmat_type, psb_dpk_, &
& psb_ipk_, psb_lpk_, psb_epk_, amg_dml_parms
implicit none
class(amg_d_newmatch_aggregator_type), target, intent(inout) :: ag
type(amg_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_newmatch_aggregator_mat_asb
end interface
interface
subroutine amg_d_newmatch_map_to_tprol(desc_a,ilaggr,nlaggr,valaggr, op_prol,info)
import :: amg_d_newmatch_aggregator_type, psb_desc_type, &
& psb_dspmat_type, psb_ldspmat_type, psb_dpk_, &
& psb_ipk_, psb_lpk_, psb_epk_, amg_dml_parms
implicit none
type(psb_desc_type), intent(in) :: desc_a
integer(psb_lpk_), allocatable, intent(inout) :: ilaggr(:),nlaggr(:)
real(psb_dpk_), allocatable, intent(inout) :: valaggr(:)
type(psb_ldspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_newmatch_map_to_tprol
end interface
interface
subroutine amg_daggrmat_unsmth_spmm_asb(a,desc_a,ilaggr,nlaggr,parms,&
& ac,op_prol,op_restr,info)
import :: amg_d_newmatch_aggregator_type, psb_desc_type, &
& psb_dspmat_type, psb_ldspmat_type, psb_dpk_, &
& psb_ipk_, psb_lpk_, psb_epk_, amg_dml_parms
implicit none
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: op_prol
type(psb_ldspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
end subroutine amg_daggrmat_unsmth_spmm_asb
end interface
interface
subroutine amg_d_newmatch_aggregator_inner_mat_asb(ag,parms,a,desc_a,&
& ac,desc_ac, op_prol,op_restr,info)
import :: amg_d_newmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
implicit none
class(amg_d_newmatch_aggregator_type), target, intent(inout) :: ag
type(amg_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(inout) :: op_prol,op_restr
type(psb_dspmat_type), intent(inout) :: ac
type(psb_desc_type), intent(inout) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_newmatch_aggregator_inner_mat_asb
end interface
!!$ interface
!!$ subroutine amg_d_newmatch_unsmth_spmm_bld(a,desc_a,ilaggr,nlaggr,parms,&
!!$ & ac,desc_ac,op_prol,op_restr,t_prol,info)
!!$ import :: amg_d_newmatch_aggregator_type, psb_desc_type, &
!!$ & psb_dspmat_type, psb_ldspmat_type, psb_dpk_, &
!!$ & psb_ipk_, psb_lpk_, psb_epk_, amg_dml_parms
!!$
!!$ implicit none
!!$
!!$ ! Arguments
!!$ type(psb_dspmat_type), intent(in) :: a
!!$ type(psb_desc_type), intent(in) :: desc_a
!!$ integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
!!$ type(amg_dml_parms), intent(inout) :: parms
!!$ type(psb_ldspmat_type), intent(inout) :: t_prol
!!$ type(psb_dspmat_type), intent(inout) :: op_prol,ac,op_restr
!!$ type(psb_desc_type), intent(inout) :: desc_ac
!!$ integer(psb_ipk_), intent(out) :: info
!!$ end subroutine amg_d_newmatch_unsmth_spmm_bld
!!$ end interface
interface
subroutine amg_d_newmatch_spmm_bld_ov(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
import :: amg_d_newmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
implicit none
type(psb_dspmat_type), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: t_prol
type(psb_dspmat_type), intent(inout) :: op_prol,ac, op_restr
type(psb_desc_type), intent(out) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_newmatch_spmm_bld_ov
end interface
interface
subroutine amg_d_newmatch_spmm_bld_inner(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
import :: amg_d_newmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data,&
& psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat
implicit none
type(psb_d_csr_sparse_mat), intent(inout) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(amg_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: t_prol
type(psb_dspmat_type), intent(inout) :: op_prol,ac, op_restr
type(psb_desc_type), intent(out) :: desc_ac
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_newmatch_spmm_bld_inner
end interface
private :: is_legal_malg, is_legal_csize, is_legal_nsweeps, is_legal_nlevels
contains
subroutine d_bld_default_w(ag,nr)
use psb_realloc_mod
implicit none
class(amg_d_newmatch_aggregator_type), target, intent(inout) :: ag
integer(psb_ipk_), intent(in) :: nr
integer(psb_ipk_) :: info
call psb_realloc(nr,ag%w,info)
if (info /= psb_success_) return
ag%w = done
call ag%set_c_default_w()
end subroutine d_bld_default_w
subroutine d_set_default_nwm_w(ag)
use psb_realloc_mod
use iso_c_binding
implicit none
class(amg_d_newmatch_aggregator_type), target, intent(inout) :: ag
integer(psb_ipk_) :: info
call psb_safe_ab_cpy(ag%w,ag%w_nxt,info)
ag%w_c_nxt%size = psb_size(ag%w_nxt)
ag%w_c_nxt%owns_data = 0
if (ag%w_c_nxt%size > 0) call set_cloc(ag%w_nxt, ag%w_c_nxt)
end subroutine d_set_default_nwm_w
subroutine set_cloc(vect,w_c_nxt)
use iso_c_binding
real(psb_dpk_), target :: vect(:)
type(nwm_Vector) :: w_c_nxt
w_c_nxt%data = c_loc(vect)
end subroutine set_cloc
subroutine d_newmatch_bld_wnxt(ag,ilaggr,valaggr,nx)
use psb_realloc_mod
implicit none
class(amg_d_newmatch_aggregator_type), target, intent(inout) :: ag
integer(psb_lpk_), intent(in) :: ilaggr(:)
real(psb_dpk_), intent(in) :: valaggr(:)
integer(psb_ipk_), intent(in) :: nx
integer(psb_ipk_) :: info,i,j
! The vector was already fixed in the call to Newmatch.
call psb_realloc(nx,ag%w_nxt,info)
end subroutine d_newmatch_bld_wnxt
function d_newmatch_aggregator_fmt() result(val)
implicit none
character(len=32) :: val
val = "new matching aggregation"
end function d_newmatch_aggregator_fmt
subroutine d_newmatch_aggregator_descr(ag,parms,iout,info,prefix)
implicit none
class(amg_d_newmatch_aggregator_type), intent(in) :: ag
type(amg_dml_parms), intent(in) :: parms
integer(psb_ipk_), intent(in) :: iout
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix
character(1024) :: prefix_
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
write(iout,*) trim(prefix_),' ','NewMatch Aggregator'
write(iout,*) trim(prefix_),' ',' Number of Matching sweeps: ',ag%n_sweeps
write(iout,*) trim(prefix_),' ',' Matching algorithm : ',ag%matching_alg
write(iout,*) trim(prefix_),' ','Aggregator object type: ',ag%fmt()
call parms%mldescr(iout,info)
return
end subroutine d_newmatch_aggregator_descr
function is_legal_malg(alg) result(val)
logical :: val
integer(psb_ipk_) :: alg
val = ((0<=alg).and.(alg<=2))
end function is_legal_malg
function is_legal_csize(csize) result(val)
logical :: val
integer(psb_ipk_) :: csize
val = ((-1==csize).or.(csize >0))
end function is_legal_csize
function is_legal_nsweeps(nsw) result(val)
logical :: val
integer(psb_ipk_) :: nsw
val = (1<=nsw)
end function is_legal_nsweeps
function is_legal_nlevels(nlv) result(val)
logical :: val
integer(psb_ipk_) :: nlv
val = (1<=nlv)
end function is_legal_nlevels
subroutine d_newmatch_aggregator_update_next(ag,agnext,info)
use psb_realloc_mod
implicit none
class(amg_d_newmatch_aggregator_type), target, intent(inout) :: ag
class(amg_d_base_aggregator_type), target, intent(inout) :: agnext
integer(psb_ipk_), intent(out) :: info
!
!
select type(agnext)
class is (amg_d_newmatch_aggregator_type)
if (.not.is_legal_malg(agnext%matching_alg)) &
& agnext%matching_alg = ag%matching_alg
if (.not.is_legal_nsweeps(agnext%n_sweeps))&
& agnext%n_sweeps = ag%n_sweeps
if (.not.is_legal_csize(agnext%max_csize))&
& agnext%max_csize = ag%max_csize
if (.not.is_legal_nlevels(agnext%max_nlevels))&
& agnext%max_nlevels = ag%max_nlevels
! Is this going to generate shallow copies/memory leaks/double frees?
! To be investigated further.
call psb_safe_ab_cpy(ag%w_nxt,agnext%w,info)
call agnext%set_c_default_w()
class default
! What should we do here?
end select
info = 0
end subroutine d_newmatch_aggregator_update_next
subroutine amg_d_newmatch_aggr_csetr(ag,what,val,info,idx)
Implicit None
! Arguments
class(amg_d_newmatch_aggregator_type), intent(inout) :: ag
character(len=*), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act, iwhat
character(len=20) :: name='d_newmatch_aggr_csetr'
info = psb_success_
! For now we ignore IDX
select case(psb_toupper(trim(what)))
case('NWM_LAMBDA')
ag%lambda = val
case default
! Do nothing
end select
return
end subroutine amg_d_newmatch_aggr_csetr
subroutine amg_d_newmatch_aggr_csetc(ag,what,val,info,idx)
Implicit None
! Arguments
class(amg_d_newmatch_aggregator_type), intent(inout) :: ag
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act, iwhat
character(len=20) :: name='d_newmatch_aggr_csetc'
info = psb_success_
! For now we ignore IDX
select case(psb_toupper(trim(what)))
case('NWM_PARALLEL_MATCHING')
select case(psb_toupper(trim(val)))
case('SEQUENTIAL','F','FALSE')
ag%parallel_matching = .false.
case('PARALLEL','TRUE','T')
ag%parallel_matching =.true.
end select
case('NWM_REPRODUCIBLE_MATCHING')
select case(psb_toupper(trim(val)))
case('F','FALSE')
ag%reproducible_matching = .false.
case('REPRODUCIBLE','TRUE','T')
ag%reproducible_matching =.true.
end select
case('NWM_NEED_SYMMETRIZE')
select case(psb_toupper(trim(val)))
case('FALSE','F')
ag%need_symmetrize = .false.
case('SYMMETRIZE','TRUE','T')
ag%need_symmetrize =.true.
end select
case('NWM_UNSMOOTHED_HIERARCHY')
select case(psb_toupper(trim(val)))
case('F','FALSE')
ag%unsmoothed_hierarchy = .false.
case('T','TRUE')
ag%unsmoothed_hierarchy =.true.
end select
case default
! Do nothing
end select
return
end subroutine amg_d_newmatch_aggr_csetc
subroutine d_newmatch_aggr_cseti(ag,what,val,info,idx)
Implicit None
! Arguments
class(amg_d_newmatch_aggregator_type), intent(inout) :: ag
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act, iwhat
character(len=20) :: name='d_newmatch_aggr_cseti'
info = psb_success_
! For now we ignore IDX
select case(psb_toupper(trim(what)))
case('NWM_MATCH_ALG','NWM_MATCHING_ALG')
ag%matching_alg = val
case('NWM_SWEEPS')
ag%n_sweeps=val
case('NWM_MAX_CSIZE')
ag%max_csize = val
case('NWM_MAX_NLEVELS')
ag%max_nlevels = val
case('NWM_W_SIZE')
call ag%bld_default_w(val)
case('AGGR_SIZE')
ag%orig_aggr_size = val
ag%n_sweeps=max(1,ceiling(log(val*1.0)/log(2.0)))
case default
! Do nothing
end select
return
end subroutine d_newmatch_aggr_cseti
subroutine d_newmatch_aggr_set_default(ag)
Implicit None
! Arguments
class(amg_d_newmatch_aggregator_type), intent(inout) :: ag
character(len=20) :: name='d_newmatch_aggr_set_default'
ag%matching_alg = 1
ag%n_sweeps = 1
ag%max_nlevels = 36
ag%max_csize = -1
ag%lambda = -1
!
! Apparently newMatch works better
! by keeping all entries
!
ag%do_clean_zeros = .false.
return
end subroutine d_newmatch_aggr_set_default
subroutine d_newmatch_aggregator_free(ag,info)
use iso_c_binding
implicit none
class(amg_d_newmatch_aggregator_type), intent(inout) :: ag
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(ag%w)) deallocate(ag%w,stat=info)
if (info /= 0) return
if (allocated(ag%w_nxt)) deallocate(ag%w_nxt,stat=info)
if (info /= 0) return
ag%w_c_nxt%size = 0
ag%w_c_nxt%data = c_null_ptr
ag%w_c_nxt%owns_data = 0
end subroutine d_newmatch_aggregator_free
subroutine d_newmatch_aggregator_clone(ag,agnext,info)
implicit none
class(amg_d_newmatch_aggregator_type), intent(inout) :: ag
class(amg_d_base_aggregator_type), allocatable, intent(inout) :: agnext
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(agnext)) then
call agnext%free(info)
if (info == 0) deallocate(agnext,stat=info)
end if
if (info /= 0) return
allocate(agnext,source=ag,stat=info)
select type(agnext)
class is (amg_d_newmatch_aggregator_type)
call agnext%set_c_default_w()
class default
! Should never ever get here
info = -1
end select
end subroutine d_newmatch_aggregator_clone
end module amg_d_newmatch_aggregator_mod
+2 -32
View File
@@ -57,6 +57,7 @@ module amg_d_onelev_mod
use amg_d_base_smoother_mod
use amg_d_dec_aggregator_mod
use amg_d_parmatch_aggregator_mod
use amg_d_newmatch_aggregator_mod
use psb_base_mod, only : psb_dspmat_type, psb_d_vect_type, &
& psb_d_base_vect_type, psb_ldspmat_type, psb_dlinmap_type, psb_dpk_, &
@@ -188,10 +189,8 @@ module amg_d_onelev_mod
procedure, pass(lv) :: clone => d_base_onelev_clone
procedure, pass(lv) :: cnv => amg_d_base_onelev_cnv
procedure, pass(lv) :: descr => amg_d_base_onelev_descr
procedure, pass(lv) :: memory_use => amg_d_base_onelev_memory_use
procedure, pass(lv) :: default => d_base_onelev_default
procedure, pass(lv) :: free => amg_d_base_onelev_free
procedure, pass(lv) :: free_smoothers => amg_d_base_onelev_free_smoothers
procedure, pass(lv) :: nullify => d_base_onelev_nullify
procedure, pass(lv) :: check => amg_d_base_onelev_check
procedure, pass(lv) :: dump => amg_d_base_onelev_dump
@@ -275,23 +274,6 @@ module amg_d_onelev_mod
end subroutine amg_d_base_onelev_descr
end interface
interface
subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
Implicit None
! Arguments
class(amg_d_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_d_base_onelev_memory_use
end interface
interface
subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
import :: amg_d_onelev_type, psb_d_base_vect_type, psb_dpk_, &
@@ -305,7 +287,7 @@ module amg_d_onelev_mod
end subroutine amg_d_base_onelev_cnv
end interface
interface
interface
subroutine amg_d_base_onelev_free(lv,info)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
@@ -317,18 +299,6 @@ module amg_d_onelev_mod
end subroutine amg_d_base_onelev_free
end interface
interface
subroutine amg_d_base_onelev_free_smoothers(lv,info)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
implicit none
class(amg_d_onelev_type), intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_base_onelev_free_smoothers
end interface
interface
subroutine amg_d_base_onelev_check(lv,info)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
+14 -9
View File
@@ -119,6 +119,10 @@
module amg_d_parmatch_aggregator_mod
use amg_d_base_aggregator_mod
use amg_d_matchboxp_mod
#if defined(SERIAL_MPI)
type, extends(amg_d_base_aggregator_type) :: amg_d_parmatch_aggregator_type
end type amg_d_parmatch_aggregator_type
#else
type, extends(amg_d_base_aggregator_type) :: amg_d_parmatch_aggregator_type
integer(psb_ipk_) :: matching_alg
integer(psb_ipk_) :: n_sweeps ! When n_sweeps >1 we need an auxiliary descriptor
@@ -240,12 +244,11 @@ module amg_d_parmatch_aggregator_mod
end interface
interface
subroutine amg_d_parmatch_unsmth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,parms,&
subroutine amg_d_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
implicit none
integer(psb_ipk_), intent(in) :: dol1smoothing
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
@@ -259,12 +262,11 @@ module amg_d_parmatch_aggregator_mod
end interface
interface
subroutine amg_d_parmatch_smth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,parms,&
subroutine amg_d_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
import :: amg_d_parmatch_aggregator_type, psb_desc_type, psb_dspmat_type,&
& psb_ldspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_dml_parms, amg_daggr_data
implicit none
integer(psb_ipk_), intent(in) :: dol1smoothing
class(amg_d_parmatch_aggregator_type), target, intent(inout) :: ag
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
@@ -396,7 +398,6 @@ contains
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix
character(1024) :: prefix_
info = psb_success_
if (present(prefix)) then
prefix_ = prefix
else
@@ -448,7 +449,6 @@ contains
class(amg_d_base_aggregator_type), target, intent(inout) :: agnext
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
!
select type(agnext)
@@ -588,7 +588,7 @@ contains
class(amg_d_parmatch_aggregator_type), intent(inout) :: ag
integer(psb_ipk_), intent(out) :: info
info = psb_success_
info = 0
if ((info == 0).and.allocated(ag%w)) deallocate(ag%w,stat=info)
if ((info == 0).and.allocated(ag%w_nxt)) deallocate(ag%w_nxt,stat=info)
if ((info == 0).and.allocated(ag%prol)) then
@@ -627,7 +627,7 @@ contains
class(amg_d_base_aggregator_type), allocatable, intent(inout) :: agnext
integer(psb_ipk_), intent(out) :: info
info = psb_success_
info = 0
if (allocated(agnext)) then
call agnext%free(info)
if (info == 0) deallocate(agnext,stat=info)
@@ -656,7 +656,6 @@ contains
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_parmatch_aggregator_bld_map'
info = psb_success_
call psb_erractionsave(err_act)
!
! Copy the prolongation/restriction matrices into the descriptor map.
@@ -674,6 +673,11 @@ contains
map = psb_linmap(psb_map_gen_linear_,desc_a,&
& desc_ac,op_restr,op_prol,ilaggr,nlaggr)
end if
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
call psb_erractionrestore(err_act)
return
@@ -681,4 +685,5 @@ contains
return
end subroutine amg_d_parmatch_aggregator_bld_map
#endif
end module amg_d_parmatch_aggregator_mod
-548
View File
@@ -1,548 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
! File: amg_d_poly_smoother_mod.f90
!
! Module: amg_d_poly_smoother_mod
!
! This module defines:
! the amg_d_poly_smoother_type data structure containing the
! smoother for a Jacobi/block Jacobi smoother.
! The smoother stores in ND the block off-diagonal matrix.
! One special case is treated separately, when the solver is DIAG or L1-DIAG
! then the ND is the entire off-diagonal part of the matrix (including the
! main diagonal block), so that it becomes possible to implement
! a pure Jacobi or L1-Jacobi global solver.
!
module amg_d_poly_coeff_mod
use psb_base_mod
real(psb_dpk_), parameter :: amg_d_poly_a_vect(30) = [ &
& 0.3333333333333333_psb_dpk_, &
& 0.1805359927403007_psb_dpk_, &
& 0.1159278464862213_psb_dpk_, &
& 0.0820780659590383_psb_dpk_, &
& 0.0618496002413377_psb_dpk_, &
& 0.0486605823426062_psb_dpk_, &
& 0.0395132986024057_psb_dpk_, &
& 0.0328701017544880_psb_dpk_, &
& 0.0278702862721800_psb_dpk_, &
& 0.0239987409600620_psb_dpk_, &
& 0.0209304400432259_psb_dpk_, &
& 0.0184513099045066_psb_dpk_, &
& 0.0164152586042591_psb_dpk_, &
& 0.0147195638076874_psb_dpk_, &
& 0.0132901324757843_psb_dpk_, &
& 0.0120723317737698_psb_dpk_, &
& 0.0110250964606384_psb_dpk_, &
& 0.0101170330064859_psb_dpk_, &
& 0.0093237789039835_psb_dpk_, &
& 0.0086261728849515_psb_dpk_, &
& 0.0080089618703679_psb_dpk_, &
& 0.0074598709610601_psb_dpk_, &
& 0.0069689238144320_psb_dpk_, &
& 0.0065279387776372_psb_dpk_, &
& 0.0061301503808627_psb_dpk_, &
& 0.0057699215598864_psb_dpk_, &
& 0.0054425224281914_psb_dpk_, &
& 0.0051439584672521_psb_dpk_, &
& 0.0048708358327268_psb_dpk_, &
& 0.0046202548314912_psb_dpk_ ];
real(psb_dpk_), parameter :: amg_d_poly_beta_vect(900) = [ &
& 1.1250000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0238728757031315_psb_dpk_, 1.2640890537108553_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0084254478202830_psb_dpk_, 1.0886783920873087_psb_dpk_, &
& 1.3375312590961856_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0039131042728535_psb_dpk_, 1.0403581118859304_psb_dpk_, &
& 1.1486349854625493_psb_dpk_, 1.3826886924100055_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0021293014616472_psb_dpk_, 1.0217371154926094_psb_dpk_, &
& 1.0787243319260302_psb_dpk_, 1.1981006529266300_psb_dpk_, &
& 1.4132254279168215_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0012851725594023_psb_dpk_, 1.0130429303523338_psb_dpk_, &
& 1.0467821512411335_psb_dpk_, 1.1161648941967548_psb_dpk_, &
& 1.2382902021844453_psb_dpk_, 1.4352429710674484_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0008346439791242_psb_dpk_, 1.0084394943012289_psb_dpk_, &
& 1.0300870776871385_psb_dpk_, 1.0740838409200377_psb_dpk_, &
& 1.1503618670736642_psb_dpk_, 1.2711647404613990_psb_dpk_, &
& 1.4518665864936395_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0005724663119766_psb_dpk_, 1.0057742766241562_psb_dpk_, &
& 1.0205018792294143_psb_dpk_, 1.0501980344456543_psb_dpk_, &
& 1.1011557298494106_psb_dpk_, 1.1808604280685657_psb_dpk_, &
& 1.2983858538257604_psb_dpk_, 1.4648607315109978_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0004096007283281_psb_dpk_, 1.0041243950610661_psb_dpk_, &
& 1.0146021214826659_psb_dpk_, 1.0356111362667175_psb_dpk_, &
& 1.0713997252919425_psb_dpk_, 1.1268827371096291_psb_dpk_, &
& 1.2078521914072933_psb_dpk_, 1.3212193071674674_psb_dpk_, &
& 1.4752964282069962_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0003031222965291_psb_dpk_, 1.0030484066079688_psb_dpk_, &
& 1.0107702271538761_psb_dpk_, 1.0261901159764004_psb_dpk_, &
& 1.0523172493375519_psb_dpk_, 1.0925574320754976_psb_dpk_, &
& 1.1508337666397197_psb_dpk_, 1.2317225087089441_psb_dpk_, &
& 1.3406080202445980_psb_dpk_, 1.4838612440701109_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0002305859520939_psb_dpk_, 1.0023167502402850_psb_dpk_, &
& 1.0081724539630488_psb_dpk_, 1.0198298656634219_psb_dpk_, &
& 1.0395021023532465_psb_dpk_, 1.0696504270054137_psb_dpk_, &
& 1.1130575429574259_psb_dpk_, 1.1729087627556418_psb_dpk_, &
& 1.2528830057679230_psb_dpk_, 1.3572557991951903_psb_dpk_, &
& 1.4910167256413891_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0001794720082837_psb_dpk_, 1.0018018913961957_psb_dpk_, &
& 1.0063486190730762_psb_dpk_, 1.0153786456630600_psb_dpk_, &
& 1.0305694283076039_psb_dpk_, 1.0537601969394355_psb_dpk_, &
& 1.0869986259207296_psb_dpk_, 1.1325918309791341_psb_dpk_, &
& 1.1931627335817252_psb_dpk_, 1.2717129367511055_psb_dpk_, &
& 1.3716933796979953_psb_dpk_, 1.4970841857556243_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0001424192155957_psb_dpk_, 1.0014290693262966_psb_dpk_, &
& 1.0050302898629815_psb_dpk_, 1.0121691051849540_psb_dpk_, &
& 1.0241487434279255_psb_dpk_, 1.0423815888082042_psb_dpk_, &
& 1.0684200812870084_psb_dpk_, 1.1039901093675994_psb_dpk_, &
& 1.1510274824264566_psb_dpk_, 1.2117181191012512_psb_dpk_, &
& 1.2885426486512805_psb_dpk_, 1.3843261938099158_psb_dpk_, &
& 1.5022941875736890_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0001149053826193_psb_dpk_, 1.0011524637691460_psb_dpk_, &
& 1.0040535733326481_psb_dpk_, 1.0097959057315313_psb_dpk_, &
& 1.0194130047299461_psb_dpk_, 1.0340142503543679_psb_dpk_, &
& 1.0548059960662932_psb_dpk_, 1.0831142030181304_psb_dpk_, &
& 1.1204089166089239_psb_dpk_, 1.1683309565544606_psb_dpk_, &
& 1.2287212228823874_psb_dpk_, 1.3036530570781755_psb_dpk_, &
& 1.3954681405367855_psb_dpk_, 1.5068164620958386_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000940475075257_psb_dpk_, 1.0009429169634352_psb_dpk_, &
& 1.0033144905644482_psb_dpk_, 1.0080029483381612_psb_dpk_, &
& 1.0158423625914039_psb_dpk_, 1.0277208331770495_psb_dpk_, &
& 1.0445953542283146_psb_dpk_, 1.0675076120612534_psb_dpk_, &
& 1.0976009254588965_psb_dpk_, 1.1361385536615733_psb_dpk_, &
& 1.1845236142623621_psb_dpk_, 1.2443208730447588_psb_dpk_, &
& 1.3172806908339272_psb_dpk_, 1.4053654389356023_psb_dpk_, &
& 1.5107787250184523_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000779482817921_psb_dpk_, 1.0007812684725339_psb_dpk_, &
& 1.0027448797440124_psb_dpk_, 1.0066229101701514_psb_dpk_, &
& 1.0130985883697137_psb_dpk_, 1.0228944832933697_psb_dpk_, &
& 1.0367832140998394_psb_dpk_, 1.0555987571989653_psb_dpk_, &
& 1.0802484840556024_psb_dpk_, 1.1117260713149764_psb_dpk_, &
& 1.1511254343107276_psb_dpk_, 1.1996558461497355_psb_dpk_, &
& 1.2586584174494597_psb_dpk_, 1.3296241265666493_psb_dpk_, &
& 1.4142136069557629_psb_dpk_, 1.5142789173034623_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000653242183546_psb_dpk_, 1.0006545722939437_psb_dpk_, &
& 1.0022987777448662_psb_dpk_, 1.0055432691173583_psb_dpk_, &
& 1.0109550075016893_psb_dpk_, 1.0191301541168694_psb_dpk_, &
& 1.0307019481191382_psb_dpk_, 1.0463489778000818_psb_dpk_, &
& 1.0668039321569163_psb_dpk_, 1.0928629244731740_psb_dpk_, &
& 1.1253954850882542_psb_dpk_, 1.1653553270075827_psb_dpk_, &
& 1.2137919954743157_psb_dpk_, 1.2718635211544003_psb_dpk_, &
& 1.3408502062615073_psb_dpk_, 1.4221696838526183_psb_dpk_, &
& 1.5173934027630227_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000552858792859_psb_dpk_, 1.0005538659610900_psb_dpk_, &
& 1.0019444166743086_psb_dpk_, 1.0046864301776393_psb_dpk_, &
& 1.0092557508630260_psb_dpk_, 1.0161502674772371_psb_dpk_, &
& 1.0258958148322650_psb_dpk_, 1.0390523408953256_psb_dpk_, &
& 1.0562203973533295_psb_dpk_, 1.0780480145522537_psb_dpk_, &
& 1.1052380250439366_psb_dpk_, 1.1385559038570177_psb_dpk_, &
& 1.1788381980793483_psb_dpk_, 1.2270016234308427_psb_dpk_, &
& 1.2840529112630572_psb_dpk_, 1.3510994958895055_psb_dpk_, &
& 1.4293611393851839_psb_dpk_, 1.5201825990516680_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000472036358790_psb_dpk_, 1.0004728102642675_psb_dpk_, &
& 1.0016593577469159_psb_dpk_, 1.0039976891368516_psb_dpk_, &
& 1.0078911941833455_psb_dpk_, 1.0137601583069535_psb_dpk_, &
& 1.0220462561721002_psb_dpk_, 1.0332172281153209_psb_dpk_, &
& 1.0477717791157513_psb_dpk_, 1.0662447417325256_psb_dpk_, &
& 1.0892125464929936_psb_dpk_, 1.1172990456131733_psb_dpk_, &
& 1.1511817386833911_psb_dpk_, 1.1915984520803475_psb_dpk_, &
& 1.2393545273929878_psb_dpk_, 1.2953305781018039_psb_dpk_, &
& 1.3604908781568688_psb_dpk_, 1.4358924509939206_psb_dpk_, &
& 1.5226949329440265_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000406232569254_psb_dpk_, 1.0004068351374691_psb_dpk_, &
& 1.0014274431564170_psb_dpk_, 1.0034377175807407_psb_dpk_, &
& 1.0067826854070978_psb_dpk_, 1.0118204999571436_psb_dpk_, &
& 1.0189259121271075_psb_dpk_, 1.0284938700470616_psb_dpk_, &
& 1.0409432748132981_psb_dpk_, 1.0567209210598594_psb_dpk_, &
& 1.0763056524407055_psb_dpk_, 1.1002127636100871_psb_dpk_, &
& 1.1289986820268283_psb_dpk_, 1.1632659648787138_psb_dpk_, &
& 1.2036686486408621_psb_dpk_, 1.2509179912601627_psb_dpk_, &
& 1.3057886497146727_psb_dpk_, 1.3691253387497200_psb_dpk_, &
& 1.4418500199624611_psb_dpk_, 1.5249696741164267_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000352114440929_psb_dpk_, 1.0003525892395289_psb_dpk_, &
& 1.0012368357172980_psb_dpk_, 1.0029777430511673_psb_dpk_, &
& 1.0058727830027672_psb_dpk_, 1.0102297507781717_psb_dpk_, &
& 1.0163694815733537_psb_dpk_, 1.0246286588536329_psb_dpk_, &
& 1.0353627340015590_psb_dpk_, 1.0489489776835172_psb_dpk_, &
& 1.0657896841306789_psb_dpk_, 1.0863155505114006_psb_dpk_, &
& 1.1109892546943501_psb_dpk_, 1.1403092559728156_psb_dpk_, &
& 1.1748138447471401_psb_dpk_, 1.2150854687543668_psb_dpk_, &
& 1.2617553651999671_psb_dpk_, 1.3155085300984379_psb_dpk_, &
& 1.3770890582780710_psb_dpk_, 1.4473058898645985_psb_dpk_, &
& 1.5270390016420912_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000307198714835_psb_dpk_, 1.0003075769178242_psb_dpk_, &
& 1.0010787281022711_psb_dpk_, 1.0025963829693492_psb_dpk_, &
& 1.0051188625231162_psb_dpk_, 1.0089126974249720_psb_dpk_, &
& 1.0142547789760521_psb_dpk_, 1.0214345766593154_psb_dpk_, &
& 1.0307564364069204_psb_dpk_, 1.0425419742322541_psb_dpk_, &
& 1.0571325804249445_psb_dpk_, 1.0748920501551993_psb_dpk_, &
& 1.0962093570737961_psb_dpk_, 1.1215015873309027_psb_dpk_, &
& 1.1512170523743910_psb_dpk_, 1.1858385999327761_psb_dpk_, &
& 1.2258871437439198_psb_dpk_, 1.2719254338660289_psb_dpk_, &
& 1.3245620908078453_psb_dpk_, 1.3844559282498121_psb_dpk_, &
& 1.4523205908039656_psb_dpk_, 1.5289295350887884_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000269609460124_psb_dpk_, 1.0002699137181752_psb_dpk_, &
& 1.0009464748475532_psb_dpk_, 1.0022775198638552_psb_dpk_, &
& 1.0044888368184179_psb_dpk_, 1.0078128087804721_psb_dpk_, &
& 1.0124901352066715_psb_dpk_, 1.0187716022931539_psb_dpk_, &
& 1.0269199126829005_psb_dpk_, 1.0372115852204526_psb_dpk_, &
& 1.0499389358225151_psb_dpk_, 1.0654121509688057_psb_dpk_, &
& 1.0839614658147161_psb_dpk_, 1.1059394594887115_psb_dpk_, &
& 1.1317234807654135_psb_dpk_, 1.1617182180038959_psb_dpk_, &
& 1.1963584280123116_psb_dpk_, 1.2361118393501820_psb_dpk_, &
& 1.2814822465106404_psb_dpk_, 1.3330128124440397_psb_dpk_, &
& 1.3912895979940381_psb_dpk_, 1.4569453380258381_psb_dpk_, &
& 1.5306634853375161_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000237911597230_psb_dpk_, 1.0002381585998457_psb_dpk_, &
& 1.0008349974382460_psb_dpk_, 1.0020088476285827_psb_dpk_, &
& 1.0039582343156432_psb_dpk_, 1.0068870298152559_psb_dpk_, &
& 1.0110058445931565_psb_dpk_, 1.0165334547611182_psb_dpk_, &
& 1.0236982737890488_psb_dpk_, 1.0327398763510158_psb_dpk_, &
& 1.0439105824804926_psb_dpk_, 1.0574771105088172_psb_dpk_, &
& 1.0737223076000839_psb_dpk_, 1.0929469670793606_psb_dpk_, &
& 1.1154717421787756_psb_dpk_, 1.1416391663018148_psb_dpk_, &
& 1.1718157904303341_psb_dpk_, 1.2063944488757254_psb_dpk_, &
& 1.2457966652063013_psb_dpk_, 1.2904752108716941_psb_dpk_, &
& 1.3409168297942540_psb_dpk_, 1.3976451430108305_psb_dpk_, &
& 1.4612237483301715_psb_dpk_, 1.5322595309246121_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000210994601235_psb_dpk_, 1.0002111968041199_psb_dpk_, &
& 1.0007403694573151_psb_dpk_, 1.0017808593384865_psb_dpk_, &
& 1.0035081686576977_psb_dpk_, 1.0061021720448531_psb_dpk_, &
& 1.0097482505685551_psb_dpk_, 1.0146384533048582_psb_dpk_, &
& 1.0209726922414943_psb_dpk_, 1.0289599764553270_psb_dpk_, &
& 1.0388196916802268_psb_dpk_, 1.0507829315895938_psb_dpk_, &
& 1.0650938873538003_psb_dpk_, 1.0820113022982043_psb_dpk_, &
& 1.1018099987843295_psb_dpk_, 1.1247824847650900_psb_dpk_, &
& 1.1512406478277994_psb_dpk_, 1.1815175449359154_psb_dpk_, &
& 1.2159692965153148_psb_dpk_, 1.2549770940040335_psb_dpk_, &
& 1.2989493304988182_psb_dpk_, 1.3483238646890843_psb_dpk_, &
& 1.4035704288718982_psb_dpk_, 1.4651931924923849_psb_dpk_, &
& 1.5337334933563860_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000187989989242_psb_dpk_, 1.0001881567984481_psb_dpk_, &
& 1.0006595227084085_psb_dpk_, 1.0015861311895899_psb_dpk_, &
& 1.0031239047778964_psb_dpk_, 1.0054323694760092_psb_dpk_, &
& 1.0086755868504005_psb_dpk_, 1.0130231071421940_psb_dpk_, &
& 1.0186509477893992_psb_dpk_, 1.0257426018654052_psb_dpk_, &
& 1.0344900810652515_psb_dpk_, 1.0450949980170887_psb_dpk_, &
& 1.0577696928624343_psb_dpk_, 1.0727384092356933_psb_dpk_, &
& 1.0902385249817814_psb_dpk_, 1.1105218431816117_psb_dpk_, &
& 1.1338559493090710_psb_dpk_, 1.1605256406217599_psb_dpk_, &
& 1.1908344341913664_psb_dpk_, 1.2251061603103259_psb_dpk_, &
& 1.2636866483695495_psb_dpk_, 1.3069455126904677_psb_dpk_, &
& 1.3552780462128098_psb_dpk_, 1.4091072303921326_psb_dpk_, &
& 1.4688858701459975_psb_dpk_, 1.5350988632115488_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000168211938973_psb_dpk_, 1.0001683505351420_psb_dpk_, &
& 1.0005900360142315_psb_dpk_, 1.0014188084960041_psb_dpk_, &
& 1.0027938311393803_psb_dpk_, 1.0048572584314193_psb_dpk_, &
& 1.0077550080990554_psb_dpk_, 1.0116375492127350_psb_dpk_, &
& 1.0166607098595459_psb_dpk_, 1.0229865078405374_psb_dpk_, &
& 1.0307840079371537_psb_dpk_, 1.0402302093961155_psb_dpk_, &
& 1.0515109674005423_psb_dpk_, 1.0648219524284319_psb_dpk_, &
& 1.0803696515480321_psb_dpk_, 1.0983724158638981_psb_dpk_, &
& 1.1190615585080472_psb_dpk_, 1.1426825077681895_psb_dpk_, &
& 1.1694960201606786_psb_dpk_, 1.1997794584895700_psb_dpk_, &
& 1.2338281401870808_psb_dpk_, 1.2719567615042522_psb_dpk_, &
& 1.3145009034164739_psb_dpk_, 1.3618186254259919_psb_dpk_, &
& 1.4142921537855777_psb_dpk_, 1.4723296710339275_psb_dpk_, &
& 1.5363672141264497_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000151113991291_psb_dpk_, 1.0001512299115287_psb_dpk_, &
& 1.0005299814085029_psb_dpk_, 1.0012742317597600_psb_dpk_, &
& 1.0025087130476142_psb_dpk_, 1.0043606572645858_psb_dpk_, &
& 1.0069604400315522_psb_dpk_, 1.0104422369100252_psb_dpk_, &
& 1.0149446949285030_psb_dpk_, 1.0206116219981500_psb_dpk_, &
& 1.0275926969588451_psb_dpk_, 1.0360442030716124_psb_dpk_, &
& 1.0461297878595799_psb_dpk_, 1.0580212522952626_psb_dpk_, &
& 1.0718993724396861_psb_dpk_, 1.0879547567564958_psb_dpk_, &
& 1.1063887424550545_psb_dpk_, 1.1274143343577541_psb_dpk_, &
& 1.1512571899424711_psb_dpk_, 1.1781566543781672_psb_dpk_, &
& 1.2083668495540898_psb_dpk_, 1.2421578212983135_psb_dpk_, &
& 1.2798167491932815_psb_dpk_, 1.3216492236219661_psb_dpk_, &
& 1.3679805949228399_psb_dpk_, 1.4191573997915068_psb_dpk_, &
& 1.4755488703473389_psb_dpk_, 1.5375485315807513_psb_dpk_, &
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000136257096588_psb_dpk_, 1.0001363546506836_psb_dpk_, &
& 1.0004778107488095_psb_dpk_, 1.0011486612681773_psb_dpk_, &
& 1.0022611433613271_psb_dpk_, 1.0039295964948667_psb_dpk_, &
& 1.0062710027404669_psb_dpk_, 1.0094055369479136_psb_dpk_, &
& 1.0134571288503909_psb_dpk_, 1.0185540391932908_psb_dpk_, &
& 1.0248294520252528_psb_dpk_, 1.0324220853457433_psb_dpk_, &
& 1.0414768223656390_psb_dpk_, 1.0521453657079123_psb_dpk_, &
& 1.0645869169533493_psb_dpk_, 1.0789688840227822_psb_dpk_, &
& 1.0954676189818162_psb_dpk_, 1.1142691889576817_psb_dpk_, &
& 1.1355701829701565_psb_dpk_, 1.1595785576006521_psb_dpk_, &
& 1.1865145245551894_psb_dpk_, 1.2166114833191515_psb_dpk_, &
& 1.2501170022543431_psb_dpk_, 1.2872938516530203_psb_dpk_, &
& 1.3284210924391027_psb_dpk_, 1.3737952243949607_psb_dpk_, &
& 1.4237313979931023_psb_dpk_, 1.4785646941265451_psb_dpk_, &
& 1.5386514762605854_psb_dpk_, 0.0000000000000000_psb_dpk_, &
& 1.0000123285767939_psb_dpk_, 1.0001233683396147_psb_dpk_, &
& 1.0004322711781202_psb_dpk_, 1.0010390719329101_psb_dpk_, &
& 1.0020451337350940_psb_dpk_, 1.0035535979966428_psb_dpk_, &
& 1.0056698406248343_psb_dpk_, 1.0085019360540697_psb_dpk_, &
& 1.0121611307132341_psb_dpk_, 1.0167623275769953_psb_dpk_, &
& 1.0224245834847208_psb_dpk_, 1.0292716209515502_psb_dpk_, &
& 1.0374323562422998_psb_dpk_, 1.0470414455308106_psb_dpk_, &
& 1.0582398510249318_psb_dpk_, 1.0711754290010183_psb_dpk_, &
& 1.0860035417614331_psb_dpk_, 1.1028876956049132_psb_dpk_, &
& 1.1220002069820316_psb_dpk_, 1.1435228990979547_psb_dpk_, &
& 1.1676478313209715_psb_dpk_, 1.1945780638597872_psb_dpk_, &
& 1.2245284602839432_psb_dpk_, 1.2577265305821996_psb_dpk_, &
& 1.2944133175813315_psb_dpk_, 1.3348443296857557_psb_dpk_, &
& 1.3792905230439911_psb_dpk_, 1.4280393364047606_psb_dpk_, &
& 1.4813957820911738_psb_dpk_, 1.5396835966986973_psb_dpk_ ]
!!$ [1.1250000000000000_psb_dpk_, 0.0_psb_dpk_, 0.0_psb_dpk__psb_dpk_,,&
!!$ & 1.0238728757031315_psb_dpk_, 1.2640890537108553_psb_dpk_, 0.0_psb_dpk_,&
!!$ & 1.0084254478202830_psb_dpk_, 1.0886783920873087_psb_dpk_, 1.3375312590961856_psb_dpk_]
real(psb_dpk_), parameter :: amg_d_poly_beta_mat(30,30)=reshape(amg_d_poly_beta_vect,[30,30])
end module amg_d_poly_coeff_mod
-374
View File
@@ -1,374 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
! File: amg_d_poly_smoother_mod.f90
!
! Module: amg_d_poly_smoother_mod
!
! This module defines:
! the amg_d_poly_smoother_type data structure containing the
! smoother for a Jacobi/block Jacobi smoother.
! The smoother stores in ND the block off-diagonal matrix.
! One special case is treated separately, when the solver is DIAG or L1-DIAG
! then the ND is the entire off-diagonal part of the matrix (including the
! main diagonal block), so that it becomes possible to implement
! a pure Jacobi or L1-Jacobi global solver.
!
module amg_d_poly_smoother
use amg_d_base_smoother_mod
use amg_d_poly_coeff_mod
type, extends(amg_d_base_smoother_type) :: amg_d_poly_smoother_type
! The local solver component is inherited from the
! parent type.
! class(amg_d_base_solver_type), allocatable :: sv
!
integer(psb_ipk_) :: pdegree, variant
integer(psb_ipk_) :: rho_estimate=amg_poly_rho_est_power_
integer(psb_ipk_) :: rho_estimate_iterations=10
type(psb_dspmat_type), pointer :: pa => null()
real(psb_dpk_), allocatable :: poly_beta(:)
real(psb_dpk_) :: cf_a = dzero
real(psb_dpk_) :: rho_ba = -done
contains
procedure, pass(sm) :: apply_v => amg_d_poly_smoother_apply_vect
!!$ procedure, pass(sm) :: apply_a => amg_d_poly_smoother_apply
procedure, pass(sm) :: dump => amg_d_poly_smoother_dmp
procedure, pass(sm) :: build => amg_d_poly_smoother_bld
procedure, pass(sm) :: cnv => amg_d_poly_smoother_cnv
procedure, pass(sm) :: clone => amg_d_poly_smoother_clone
procedure, pass(sm) :: clone_settings => amg_d_poly_smoother_clone_settings
procedure, pass(sm) :: clear_data => amg_d_poly_smoother_clear_data
procedure, pass(sm) :: free => d_poly_smoother_free
procedure, pass(sm) :: cseti => amg_d_poly_smoother_cseti
procedure, pass(sm) :: csetc => amg_d_poly_smoother_csetc
procedure, pass(sm) :: csetr => amg_d_poly_smoother_csetr
procedure, pass(sm) :: descr => amg_d_poly_smoother_descr
procedure, pass(sm) :: sizeof => d_poly_smoother_sizeof
procedure, pass(sm) :: default => d_poly_smoother_default
procedure, pass(sm) :: get_nzeros => d_poly_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => d_poly_smoother_get_wrksize
procedure, nopass :: get_fmt => d_poly_smoother_get_fmt
procedure, nopass :: get_id => d_poly_smoother_get_id
end type amg_d_poly_smoother_type
private :: d_poly_smoother_free, &
& d_poly_smoother_sizeof, d_poly_smoother_get_nzeros, &
& d_poly_smoother_get_fmt, d_poly_smoother_get_id, &
& d_poly_smoother_get_wrksize
interface
subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,wv,info,init,initu)
import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
& psb_ipk_
type(psb_desc_type), intent(in) :: desc_data
class(amg_d_poly_smoother_type), intent(inout) :: sm
type(psb_d_vect_type),intent(inout) :: x
type(psb_d_vect_type),intent(inout) :: y
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
end subroutine amg_d_poly_smoother_apply_vect
end interface
!!$ interface
!!$ subroutine amg_d_poly_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
!!$ & sweeps,work,info,init,initu)
!!$ import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
!!$ & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, &
!!$ & psb_ipk_
!!$ type(psb_desc_type), intent(in) :: desc_data
!!$ class(amg_d_poly_smoother_type), intent(inout) :: sm
!!$ real(psb_dpk_),intent(inout) :: x(:)
!!$ real(psb_dpk_),intent(inout) :: y(:)
!!$ real(psb_dpk_),intent(in) :: alpha,beta
!!$ character(len=1),intent(in) :: trans
!!$ integer(psb_ipk_), intent(in) :: sweeps
!!$ real(psb_dpk_),target, intent(inout) :: work(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ character, intent(in), optional :: init
!!$ real(psb_dpk_),intent(inout), optional :: initu(:)
!!$ end subroutine amg_d_poly_smoother_apply
!!$ end interface
!!$
interface
subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_d_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_d_poly_smoother_bld
end interface
interface
subroutine amg_d_poly_smoother_cnv(sm,info,amold,vmold,imold)
import :: amg_d_poly_smoother_type, psb_dpk_, &
& psb_d_base_sparse_mat, psb_d_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
class(amg_d_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_sparse_mat), intent(in), optional :: amold
class(psb_d_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_d_poly_smoother_cnv
end interface
interface
subroutine amg_d_poly_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, &
& psb_ipk_
implicit none
class(amg_d_poly_smoother_type), intent(in) :: sm
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: level
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver, global_num
end subroutine amg_d_poly_smoother_dmp
end interface
interface
subroutine amg_d_poly_smoother_clone(sm,smout,info)
import :: amg_d_poly_smoother_type, psb_dpk_, &
& amg_d_base_smoother_type, psb_ipk_
class(amg_d_poly_smoother_type), intent(inout) :: sm
class(amg_d_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_poly_smoother_clone
end interface
interface
subroutine amg_d_poly_smoother_clone_settings(sm,smout,info)
import :: amg_d_poly_smoother_type, psb_dpk_, &
& amg_d_base_smoother_type, psb_ipk_
class(amg_d_poly_smoother_type), intent(inout) :: sm
class(amg_d_base_smoother_type), intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_poly_smoother_clone_settings
end interface
interface
subroutine amg_d_poly_smoother_clear_data(sm,info)
import :: amg_d_poly_smoother_type, psb_dpk_, &
& amg_d_base_smoother_type, psb_ipk_
class(amg_d_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
end subroutine amg_d_poly_smoother_clear_data
end interface
interface
subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix)
import :: amg_d_poly_smoother_type, psb_ipk_
class(amg_d_poly_smoother_type), intent(in) :: sm
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
end subroutine amg_d_poly_smoother_descr
end interface
interface
subroutine amg_d_poly_smoother_cseti(sm,what,val,info,idx)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_d_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_d_poly_smoother_cseti
end interface
interface
subroutine amg_d_poly_smoother_csetc(sm,what,val,info,idx)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_d_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_d_poly_smoother_csetc
end interface
interface
subroutine amg_d_poly_smoother_csetr(sm,what,val,info,idx)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_d_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_d_poly_smoother_csetr
end interface
contains
subroutine d_poly_smoother_free(sm,info)
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_poly_smoother_free'
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(sm%sv)) then
call sm%sv%free(info)
if (info == psb_success_) deallocate(sm%sv,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
end if
if (allocated(sm%poly_beta)) deallocate(sm%poly_beta)
sm%pa => null()
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine d_poly_smoother_free
function d_poly_smoother_sizeof(sm) result(val)
implicit none
! Arguments
class(amg_d_poly_smoother_type), intent(in) :: sm
integer(psb_epk_) :: val
val = psb_sizeof_dp
if (allocated(sm%sv)) val = val + sm%sv%sizeof()
if (allocated(sm%poly_beta)) val = val + psb_sizeof_dp * size(sm%poly_beta)
return
end function d_poly_smoother_sizeof
subroutine d_poly_smoother_default(sm)
Implicit None
! Arguments
class(amg_d_poly_smoother_type), intent(inout) :: sm
!
! Default: BJAC with no residual check
!
sm%pdegree = 1
sm%rho_ba = -done
sm%variant = amg_cheb_4_
sm%rho_estimate = amg_poly_rho_est_power_
sm%rho_estimate_iterations = 20
if (allocated(sm%sv)) then
call sm%sv%default()
end if
return
end subroutine d_poly_smoother_default
function d_poly_smoother_get_nzeros(sm) result(val)
implicit none
! Arguments
class(amg_d_poly_smoother_type), intent(in) :: sm
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = 0
if (allocated(sm%sv)) val = val + sm%sv%get_nzeros()
return
end function d_poly_smoother_get_nzeros
function d_poly_smoother_get_wrksize(sm) result(val)
implicit none
class(amg_d_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 4
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function d_poly_smoother_get_wrksize
function d_poly_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Polynomial smoother"
end function d_poly_smoother_get_fmt
function d_poly_smoother_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_poly_
end function d_poly_smoother_get_id
end module amg_d_poly_smoother
-90
View File
@@ -113,7 +113,6 @@ module amg_d_prec_type
procedure, pass(prec) :: free => amg_d_prec_free
procedure, pass(prec) :: allocate_wrk => amg_d_allocate_wrk
procedure, pass(prec) :: free_wrk => amg_d_free_wrk
procedure, pass(prec) :: deallocate_wrk => amg_d_free_wrk
procedure, pass(prec) :: is_allocated_wrk => amg_d_is_allocated_wrk
procedure, pass(prec) :: get_complexity => amg_d_get_compl
procedure, pass(prec) :: cmp_complexity => amg_d_cmp_compl
@@ -136,11 +135,8 @@ module amg_d_prec_type
procedure, pass(prec) :: build => amg_dprecbld
procedure, pass(prec) :: hierarchy_build => amg_d_hierarchy_bld
procedure, pass(prec) :: hierarchy_rebuild => amg_d_hierarchy_rebld
procedure, pass(prec) :: hierarchy_free => amg_d_hierarchy_free
procedure, pass(prec) :: smoothers_build => amg_d_smoothers_bld
procedure, pass(prec) :: smoothers_free => amg_d_smoothers_free
procedure, pass(prec) :: descr => amg_dfile_prec_descr
procedure, pass(prec) :: memory_use => amg_dfile_prec_memory_use
end type amg_dprec_type
private :: amg_d_dump, amg_d_get_compl, amg_d_cmp_compl,&
@@ -172,22 +168,6 @@ module amg_d_prec_type
end subroutine amg_dfile_prec_descr
end interface
interface amg_memory_use
subroutine amg_dfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
import :: amg_dprec_type, psb_ipk_
implicit none
! Arguments
class(amg_dprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_dfile_prec_memory_use
end interface
interface amg_sizeof
module procedure amg_dprec_sizeof
end interface
@@ -365,14 +345,6 @@ module amg_d_prec_type
end subroutine amg_d_smoothers_bld
end interface amg_smoothers_bld
interface amg_smoothers_free
module procedure amg_d_smoothers_free
end interface amg_smoothers_free
interface amg_hierarchy_free
module procedure amg_d_hierarchy_free
end interface amg_hierarchy_free
contains
!
! Function returning a pointer to the smoother
@@ -646,68 +618,6 @@ contains
end subroutine amg_d_prec_free
subroutine amg_d_smoothers_free(prec,info)
implicit none
! Arguments
class(amg_dprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: me,err_act,i
character(len=20) :: name
info=psb_success_
name = 'amg_d_smoothers_free'
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
end if
if (allocated(prec%precv)) then
do i=1,size(prec%precv)
call prec%precv(i)%free_smoothers(info)
end do
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_smoothers_free
subroutine amg_d_hierarchy_free(prec,info)
implicit none
! Arguments
class(amg_dprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: me,err_act,i
character(len=20) :: name
info=psb_success_
name = 'amg_d_hierarchy_free'
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
end if
me=-1
write(0,*) 'Missing implementation '
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_d_hierarchy_free
!
+1 -1
View File
@@ -51,7 +51,7 @@ module amg_d_slu_solver
use iso_c_binding
use amg_d_base_solver_mod
#if defined(PSB_IPK8)
#if defined(IPK8)
type, extends(amg_d_base_solver_type) :: amg_d_slu_solver_type
+1 -1
View File
@@ -52,7 +52,7 @@ module amg_d_sludist_solver
use iso_c_binding
use amg_d_base_solver_mod
#if (!defined(AMG_HAVE_SLUDIST)) || defined(PSB_IPK8)
#if (!defined(HAVE_SLUDIST_)) || defined(IPK8)
type, extends(amg_d_base_solver_type) :: amg_d_sludist_solver_type
+1 -1
View File
@@ -97,7 +97,7 @@ contains
character(len=*), intent(in), optional :: prefix
character(1024) :: prefix_
info = psb_success_
if (present(prefix)) then
prefix_ = prefix
else
+1 -1
View File
@@ -51,7 +51,7 @@ module amg_d_umf_solver
use iso_c_binding
use amg_d_base_solver_mod
#if defined(PSB_IPK8)
#if defined(IPK8)
type, extends(amg_d_base_solver_type) :: amg_d_umf_solver_type
end type amg_d_umf_solver_type
+3 -11
View File
@@ -58,10 +58,12 @@ module amg_s_ainv_solver
procedure, pass(sv) :: check => amg_s_ainv_solver_check
procedure, pass(sv) :: build => amg_s_ainv_solver_bld
procedure, pass(sv) :: clone => amg_s_ainv_solver_clone
procedure, pass(sv) :: clone_settings => amg_s_ainv_solver_clone_settings
procedure, pass(sv) :: cseti => amg_s_ainv_solver_cseti
procedure, pass(sv) :: csetc => amg_s_ainv_solver_csetc
procedure, pass(sv) :: csetr => amg_s_ainv_solver_csetr
!!$ procedure, pass(sv) :: seti => amg_s_ainv_solver_seti
!!$ procedure, pass(sv) :: setc => amg_s_ainv_solver_setc
!!$ procedure, pass(sv) :: setr => amg_s_ainv_solver_setr
procedure, pass(sv) :: descr => amg_s_ainv_solver_descr
procedure, pass(sv) :: default => s_ainv_solver_default
procedure, nopass :: stringval => s_ainv_stringval
@@ -83,16 +85,6 @@ module amg_s_ainv_solver
end subroutine amg_s_ainv_solver_clone
end interface
interface
subroutine amg_s_ainv_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
& amg_s_base_solver_type, psb_dpk_, amg_s_ainv_solver_type, psb_ipk_
Implicit None
class(amg_s_ainv_solver_type), intent(inout) :: sv
class(amg_s_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_ainv_solver_clone_settings
end interface
interface
subroutine amg_s_ainv_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+1 -2
View File
@@ -302,7 +302,7 @@ contains
integer(psb_ipk_), intent(out) :: info
! Do nothing
info = psb_success_
return
end subroutine amg_s_base_aggregator_set_aggr_type
@@ -486,7 +486,6 @@ contains
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_base_aggregator_bld_map'
info = psb_success_
call psb_erractionsave(err_act)
!
! Copy the prolongation/restriction matrices into the descriptor map.
+1 -2
View File
@@ -150,7 +150,7 @@ contains
class(amg_s_dec_aggregator_type), intent(inout) :: ag
type(amg_sml_parms), intent(in) :: parms
integer(psb_ipk_), intent(out) :: info
info = psb_success_
select case(parms%aggr_type)
case (amg_noalg_)
ag%soc_map_bld => null()
@@ -192,7 +192,6 @@ contains
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix
character(1024) :: prefix_
info = psb_success_
if (present(prefix)) then
prefix_ = prefix
else
+125
View File
@@ -0,0 +1,125 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
! The aggregator object hosts the aggregation method for building
! the multilevel hierarchy. This variant is based on the hybrid method
! presented in
!
! S. Gratton, P. Henon, P. Jiranek and X. Vasseur:
! Reducing complexity of algebraic multigrid by aggregation
! Numerical Lin. Algebra with Applications, 2016, 23:501-518
!
module amg_s_hybrid_aggregator_mod
use amg_s_dec_aggregator_mod
!
! sm - class(amg_T_base_smoother_type), allocatable
! The current level preconditioner (aka smoother).
! parms - type(amg_RTml_parms)
! The parameters defining the multilevel strategy.
! ac - The local part of the current-level matrix, built by
! coarsening the previous-level matrix.
! desc_ac - type(psb_desc_type).
! The communication descriptor associated to the matrix
! stored in ac.
! base_a - type(psb_Tspmat_type), pointer.
! Pointer (really a pointer!) to the local part of the current
! matrix (so we have a unified treatment of residuals).
! We need this to avoid passing explicitly the current matrix
! to the routine which applies the preconditioner.
! base_desc - type(psb_desc_type), pointer.
! Pointer to the communication descriptor associated to the
! matrix pointed by base_a.
! map - Stores the maps (restriction and prolongation) between the
! vector spaces associated to the index spaces of the previous
! and current levels.
!
! Methods:
! Most methods follow the encapsulation hierarchy: they take whatever action
! is appropriate for the current object, then call the corresponding method for
! the contained object.
! As an example: the descr() method prints out a description of the
! level. It starts by invoking the descr() method of the parms object,
! then calls the descr() method of the smoother object.
!
! descr - Prints a description of the object.
! default - Set default values
! dump - Dump to file object contents
! set - Sets various parameters; when a request is unknown
! it is passed to the smoother object for further processing.
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
!
!
type, extends(amg_s_dec_aggregator_type) :: amg_s_hybrid_aggregator_type
contains
procedure, pass(ag) :: bld_tprol => amg_s_hybrid_aggregator_build_tprol
procedure, nopass :: fmt => amg_s_hybrid_aggregator_fmt
end type amg_s_hybrid_aggregator_type
interface
subroutine amg_s_hybrid_aggregator_build_tprol(ag,parms,a,desc_a,ilaggr,nlaggr,op_prol,info)
import :: amg_s_hybrid_aggregator_type, psb_desc_type, psb_sspmat_type, psb_spk_, &
& psb_ipk_, psb_long_int_k_, amg_sml_parms
implicit none
class(amg_s_hybrid_aggregator_type), target, intent(inout) :: ag
type(amg_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_sspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_hybrid_aggregator_build_tprol
end interface
contains
function amg_s_hybrid_aggregator_fmt() result(val)
implicit none
character(len=32) :: val
val = "Hybrid Decoupled aggregation"
end function amg_s_hybrid_aggregator_fmt
end module amg_s_hybrid_aggregator_mod
+7 -7
View File
@@ -234,7 +234,7 @@ contains
! Arguments
class(amg_s_ilu_solver_type), intent(inout) :: sv
sv%fact_type = amg_ilu_n_
sv%fact_type = psb_ilu_n_
sv%fill_in = 0
sv%thresh = szero
@@ -255,13 +255,13 @@ contains
info = psb_success_
call amg_check_def(sv%fact_type,&
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(amg_ilu_n_,amg_milu_n_)
case(psb_ilu_n_,psb_milu_n_)
call amg_check_def(sv%fill_in,&
& 'Level',izero,is_int_non_negative)
case(amg_ilu_t_)
case(psb_ilu_t_)
call amg_check_def(sv%thresh,&
& 'Eps',szero,is_legal_s_fact_thrs)
end select
@@ -439,9 +439,9 @@ contains
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
& amg_fact_names(sv%fact_type)
select case(sv%fact_type)
case(amg_ilu_n_,amg_milu_n_)
case(psb_ilu_n_,psb_milu_n_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
case(amg_ilu_t_)
case(psb_ilu_t_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
end select
@@ -496,7 +496,7 @@ contains
implicit none
integer(psb_ipk_) :: val
val = amg_ilu_n_
val = psb_ilu_n_
end function s_ilu_solver_get_id
function s_ilu_solver_get_wrksize() result(val)
+1 -2
View File
@@ -109,12 +109,11 @@ module amg_s_inner_mod
end interface amg_map_to_tprol
abstract interface
subroutine amg_saggrmat_var_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,parms,&
subroutine amg_saggrmat_var_bld(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
import :: psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_, psb_lsspmat_type
import :: amg_s_onelev_type, amg_sml_parms
implicit none
integer(psb_ipk_), intent(in) :: dol1smoothing
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
-12
View File
@@ -52,7 +52,6 @@ module amg_s_invk_solver
contains
procedure, pass(sv) :: check => amg_s_invk_solver_check
procedure, pass(sv) :: clone => amg_s_invk_solver_clone
procedure, pass(sv) :: clone_settings => amg_s_invk_solver_clone_settings
procedure, pass(sv) :: build => amg_s_invk_solver_bld
procedure, pass(sv) :: cseti => amg_s_invk_solver_cseti
procedure, pass(sv) :: descr => amg_s_invk_solver_descr
@@ -74,17 +73,6 @@ module amg_s_invk_solver
end subroutine amg_s_invk_solver_clone
end interface
interface
subroutine amg_s_invk_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
& amg_s_base_solver_type, psb_spk_, amg_s_invk_solver_type, psb_ipk_
Implicit None
class(amg_s_invk_solver_type), intent(inout) :: sv
class(amg_s_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_invk_solver_clone_settings
end interface
interface
subroutine amg_s_invk_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
-12
View File
@@ -52,7 +52,6 @@ module amg_s_invt_solver
contains
procedure, pass(sv) :: check => amg_s_invt_solver_check
procedure, pass(sv) :: clone => amg_s_invt_solver_clone
procedure, pass(sv) :: clone_settings => amg_s_invt_solver_clone_settings
procedure, pass(sv) :: build => amg_s_invt_solver_bld
procedure, pass(sv) :: cseti => amg_s_invt_solver_cseti
procedure, pass(sv) :: csetr => amg_s_invt_solver_csetr
@@ -74,17 +73,6 @@ module amg_s_invt_solver
end subroutine amg_s_invt_solver_clone
end interface
interface
subroutine amg_s_invt_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
& amg_s_base_solver_type, psb_spk_, amg_s_invt_solver_type, psb_ipk_
Implicit None
class(amg_s_invt_solver_type), intent(inout) :: sv
class(amg_s_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_invt_solver_clone_settings
end interface
interface
subroutine amg_s_invt_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
+2 -2
View File
@@ -203,8 +203,8 @@ module amg_s_jac_smoother
subroutine amg_s_jac_smoother_clone_settings(sm,smout,info)
import :: amg_s_jac_smoother_type, psb_spk_, &
& amg_s_base_smoother_type, psb_ipk_
class(amg_s_jac_smoother_type), intent(inout) :: sm
class(amg_s_base_smoother_type), intent(inout) :: smout
class(amg_s_jac_smoother_type), intent(inout) :: sm
class(amg_s_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_jac_smoother_clone_settings
end interface
-585
View File
@@ -1,585 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
! File: amg_s_jac_solver_mod.f90
!
! Module: amg_s_jac_solver_mod
!
! This module defines:
! - the amg_s_jac_solver_type data structure containing the ingredients
! for a local Jacobi iteration. The iterations are local to a process
! (they operate on the block diagonal).
!
!
module amg_s_jac_solver
use amg_s_base_solver_mod
type, extends(amg_s_base_solver_type) :: amg_s_jac_solver_type
type(psb_sspmat_type) :: a
type(psb_s_vect_type), allocatable :: dv
real(psb_spk_), allocatable :: d(:)
integer(psb_ipk_) :: sweeps
real(psb_spk_) :: eps
contains
procedure, pass(sv) :: dump => amg_s_jac_solver_dmp
procedure, pass(sv) :: check => s_jac_solver_check
procedure, pass(sv) :: clone => amg_s_jac_solver_clone
procedure, pass(sv) :: clone_settings => amg_s_jac_solver_clone_settings
procedure, pass(sv) :: clear_data => amg_s_jac_solver_clear_data
procedure, pass(sv) :: build => amg_s_jac_solver_bld
procedure, pass(sv) :: cnv => amg_s_jac_solver_cnv
procedure, pass(sv) :: apply_v => amg_s_jac_solver_apply_vect
procedure, pass(sv) :: apply_a => amg_s_jac_solver_apply
procedure, pass(sv) :: free => s_jac_solver_free
procedure, pass(sv) :: cseti => s_jac_solver_cseti
procedure, pass(sv) :: csetc => s_jac_solver_csetc
procedure, pass(sv) :: csetr => s_jac_solver_csetr
procedure, pass(sv) :: descr => s_jac_solver_descr
procedure, pass(sv) :: default => s_jac_solver_default
procedure, pass(sv) :: sizeof => s_jac_solver_sizeof
procedure, pass(sv) :: get_nzeros => s_jac_solver_get_nzeros
procedure, nopass :: get_wrksz => s_jac_solver_get_wrksize
procedure, nopass :: get_fmt => s_jac_solver_get_fmt
procedure, nopass :: get_id => s_jac_solver_get_id
procedure, nopass :: is_iterative => s_jac_solver_is_iterative
end type amg_s_jac_solver_type
type, extends(amg_s_jac_solver_type) :: amg_s_l1_jac_solver_type
contains
procedure, pass(sv) :: build => amg_s_l1_jac_solver_bld
procedure, pass(sv) :: descr => s_l1_jac_solver_descr
procedure, nopass :: get_fmt => s_l1_jac_solver_get_fmt
procedure, nopass :: get_id => s_l1_jac_solver_get_id
end type amg_s_l1_jac_solver_type
private :: s_jac_solver_bld, s_jac_solver_apply, &
& s_jac_solver_free, &
& s_jac_solver_descr, s_jac_solver_sizeof, &
& s_jac_solver_default, s_jac_solver_dmp, &
& s_jac_solver_apply_vect, s_jac_solver_get_nzeros, &
& s_jac_solver_get_fmt, s_jac_solver_check,&
& s_jac_solver_is_iterative, &
& s_jac_solver_get_id, s_jac_solver_get_wrksize
interface
subroutine amg_s_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,wv,info,init,initu)
import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(amg_s_jac_solver_type), intent(inout) :: sv
type(psb_s_vect_type),intent(inout) :: x
type(psb_s_vect_type),intent(inout) :: y
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
end subroutine amg_s_jac_solver_apply_vect
end interface
interface
subroutine amg_s_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(amg_s_jac_solver_type), intent(inout) :: sv
real(psb_spk_),intent(inout) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
real(psb_spk_),intent(inout), optional :: initu(:)
end subroutine amg_s_jac_solver_apply
end interface
interface
subroutine amg_s_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_s_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_s_jac_solver_bld
end interface
interface
subroutine amg_s_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, amg_s_l1_jac_solver_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_s_l1_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_s_l1_jac_solver_bld
end interface
interface
subroutine amg_s_jac_solver_cnv(sv,info,amold,vmold,imold)
import :: amg_s_jac_solver_type, psb_spk_, &
& psb_s_base_sparse_mat, psb_s_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
class(amg_s_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_s_jac_solver_cnv
end interface
interface
subroutine amg_s_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, &
& psb_ipk_
implicit none
class(amg_s_jac_solver_type), intent(in) :: sv
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: level
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: solver, global_num
end subroutine amg_s_jac_solver_dmp
end interface
interface
subroutine amg_s_jac_solver_clone(sv,svout,info)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
& psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
& amg_s_base_solver_type, amg_s_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_s_jac_solver_type), intent(inout) :: sv
class(amg_s_base_solver_type), allocatable, intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_jac_solver_clone
end interface
!!$ interface
!!$ subroutine amg_s_l1_jac_solver_clone(sv,svout,info)
!!$ import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
!!$ & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
!!$ & amg_s_base_solver_type, amg_s_l1_jac_solver_type, psb_ipk_
!!$ Implicit None
!!$
!!$ ! Arguments
!!$ class(amg_s_l1_jac_solver_type), intent(inout) :: sv
!!$ class(amg_s_base_solver_type), allocatable, intent(inout) :: svout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ end subroutine amg_s_l1_jac_solver_clone
!!$ end interface
interface
subroutine amg_s_jac_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
& psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
& amg_s_base_solver_type, amg_s_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_s_jac_solver_type), intent(inout) :: sv
class(amg_s_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_jac_solver_clone_settings
end interface
interface
subroutine amg_s_jac_solver_clear_data(sv,info)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
& psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
& amg_s_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_s_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_jac_solver_clear_data
end interface
contains
subroutine s_jac_solver_default(sv)
Implicit None
! Arguments
class(amg_s_jac_solver_type), intent(inout) :: sv
sv%sweeps = ione
sv%eps = dzero
return
end subroutine s_jac_solver_default
subroutine s_jac_solver_check(sv,info)
Implicit None
! Arguments
class(amg_s_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_jac_solver_check'
call psb_erractionsave(err_act)
info = psb_success_
call amg_check_def(sv%sweeps,&
& 'Jacobi sweeps',ione,is_int_positive)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine s_jac_solver_check
subroutine s_jac_solver_cseti(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_s_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_jac_solver_cseti'
info = psb_success_
call psb_erractionsave(err_act)
select case(psb_toupper(what))
case('SOLVER_SWEEPS')
sv%sweeps = val
case default
call sv%amg_s_base_solver_type%set(what,val,info,idx=idx)
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine s_jac_solver_cseti
subroutine s_jac_solver_csetc(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_s_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act, ival
character(len=20) :: name='s_jac_solver_csetc'
info = psb_success_
call psb_erractionsave(err_act)
call sv%amg_s_base_solver_type%set(what,val,info,idx=idx)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info, name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine s_jac_solver_csetc
subroutine s_jac_solver_csetr(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_s_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_jac_solver_csetr'
call psb_erractionsave(err_act)
info = psb_success_
select case(psb_toupper(what))
case('SOLVER_EPS')
sv%eps = val
case default
call sv%amg_s_base_solver_type%set(what,val,info,idx=idx)
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine s_jac_solver_csetr
subroutine s_jac_solver_free(sv,info)
Implicit None
! Arguments
class(amg_s_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_jac_solver_free'
call psb_erractionsave(err_act)
info = psb_success_
call sv%a%free()
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
if (allocated(sv%d)) deallocate(sv%d)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine s_jac_solver_free
subroutine s_jac_solver_descr(sv,info,iout,coarse,prefix)
Implicit None
! Arguments
class(amg_s_jac_solver_type), intent(in) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='amg_s_jac_solver_descr'
integer(psb_ipk_) :: iout_
character(1024) :: prefix_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
endif
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if (sv%eps<=dzero) then
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine s_jac_solver_descr
function s_jac_solver_get_nzeros(sv) result(val)
implicit none
! Arguments
class(amg_s_jac_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = 0
val = val + sv%a%get_nzeros()
val = val + sv%dv%get_nrows()
return
end function s_jac_solver_get_nzeros
function s_jac_solver_sizeof(sv) result(val)
implicit none
! Arguments
class(amg_s_jac_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = psb_sizeof_ip
val = val + sv%a%sizeof()
val = val + sv%dv%sizeof()
return
end function s_jac_solver_sizeof
function s_jac_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Jacobi solver"
end function s_jac_solver_get_fmt
function s_jac_solver_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_jac_
end function s_jac_solver_get_id
!
! If this is true, then the solver needs a starting
! guess. Currently only handled in JAC smoother.
!
function s_jac_solver_is_iterative() result(val)
implicit none
logical :: val
val = .true.
end function s_jac_solver_is_iterative
function s_jac_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 2
end function s_jac_solver_get_wrksize
subroutine s_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
Implicit None
! Arguments
class(amg_s_l1_jac_solver_type), intent(in) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='amg_s_l1_jac_solver_descr'
integer(psb_ipk_) :: iout_
character(1024) :: prefix_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
endif
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if (sv%eps<=dzero) then
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine s_l1_jac_solver_descr
function s_l1_jac_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "L1-Jacobi solver"
end function s_l1_jac_solver_get_fmt
function s_l1_jac_solver_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_l1_jac_
end function s_l1_jac_solver_get_id
end module amg_s_jac_solver
@@ -73,22 +73,6 @@ module amg_s_matchboxp_mod
use iso_c_binding
use psb_base_cbind_mod
#if defined(PSB_SERIAL_MPI)
interface MatchingC
subroutine sMatchingC(nlver,nledge,verlocptr,verlocind,edgelocweight,&
& verdistance, mate) bind(c,name='sMatching')
use iso_c_binding
import :: psb_c_ipk_, psb_c_lpk_
implicit none
integer(psb_c_lpk_), value :: nlver,nledge
integer(psb_c_lpk_) :: verlocptr(*),verlocind(*), verdistance(*)
integer(psb_c_lpk_) :: mate(*)
real(c_float) :: edgelocweight(*)
end subroutine sMatchingC
end interface MatchingC
#else
interface MatchBoxPC
subroutine sMatchBoxPC(nlver,nledge,verlocptr,verlocind,edgelocweight,&
& verdistance, mate, myrank, numprocs, icomm,&
@@ -109,7 +93,7 @@ module amg_s_matchboxp_mod
real(c_double) :: msgpercent(*)
end subroutine sMatchBoxPC
end interface MatchBoxPC
#endif
interface amg_i_aggr_assign
module procedure amg_i_s_aggr_assign
end interface amg_i_aggr_assign
@@ -1145,15 +1129,11 @@ contains
call psb_barrier(ictxt)
if (me == 0) write(0,*)' Calling MatchBoxP '
end if
#if defined(PSB_SERIAL_MPI)
call MatchingC(nlver,nledge,verlocptr,verlocind,edgelocweight,&
& verdistance, mate)
#else
call MatchBoxPC(nlver,nledge,verlocptr,verlocind,edgelocweight,&
& verdistance, mate, mrank, mnp, icomm,&
& msgindsent,msgactualsent,msgpercent,&
& ph0_time, ph1_time, ph2_time, ph1_card, ph2_card)
#endif
verlocptr(:) = verlocptr(:) + 1
verlocind(:) = verlocind(:) + 1
verdistance(:) = verdistance(:) + 1
+12 -13
View File
@@ -52,10 +52,10 @@
!
module amg_s_mumps_solver
use amg_s_base_solver_mod
#if defined(AMG_HAVE_MUMPS) && defined(AMG_HAVE_MUMPS_MODULES)
#if defined(HAVE_MUMPS_) && defined(HAVE_MUMPS_MODULES_)
use smumps_struc_def
#endif
#if defined(AMG_HAVE_MUMPS) && defined(AMG_HAVE_MUMPS_INCLUDES)
#if defined(HAVE_MUMPS_) && defined(HAVE_MUMPS_INCLUDES_)
include 'smumps_struc.h'
#endif
@@ -68,7 +68,7 @@ module amg_s_mumps_solver
end type amg_s_mumps_rcntl_item
type, extends(amg_s_base_solver_type) :: amg_s_mumps_solver_type
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
type(smumps_struc), allocatable :: id
#else
integer, allocatable :: id
@@ -78,8 +78,7 @@ module amg_s_mumps_solver
!
! Controls to be set before MUMPS instantiation:
!
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: 'LOCAL_SOLVER
! 1==amg_global_solver_: 'GLOBAL_SOLVER'
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: LOCAL 1==amg_global_solver_: GLOBAL
! IPAR(2) : MUMPS_PRINT_ERR print verbosity (see MUMPS)
! IPAR(3) : MUMPS_SYM 0: non-symmetric 2: symmetric
integer(psb_ipk_), dimension(3) :: ipar
@@ -189,7 +188,7 @@ contains
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
@@ -239,7 +238,7 @@ contains
character(len=20) :: name='s_mumps_solver_clear_data'
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
if (allocated(sv%id)) then
if (sv%built) then
@@ -279,7 +278,7 @@ contains
character(len=20) :: name='s_mumps_solver_free'
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
call sv%clear_data(info)
if ((info == 0).and.allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
@@ -383,7 +382,7 @@ subroutine s_mumps_solver_csetc(sv,what,val,info,idx)
select case(psb_toupper(trim(what)))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_LOC_GLOB')
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
#endif
@@ -421,7 +420,7 @@ subroutine s_mumps_solver_cseti(sv,what,val,info,idx)
call psb_erractionsave(err_act)
select case(psb_toupper(what))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_LOC_GLOB')
sv%ipar(1) = val
case('MUMPS_PRINT_ERR')
@@ -467,7 +466,7 @@ subroutine s_mumps_solver_csetr(sv,what,val,info,idx)
call psb_erractionsave(err_act)
select case(psb_toupper(what))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_RPAR_ENTRY')
if(present(idx)) then
! Note: this will allocate %item
@@ -504,7 +503,7 @@ subroutine s_mumps_solver_default(sv)
info = psb_success_
call psb_erractionsave(err_act)
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
if (.not.allocated(sv%id)) then
allocate(sv%id,stat=info)
if (info /= psb_success_) then
@@ -561,7 +560,7 @@ function s_mumps_solver_sizeof(sv) result(val)
class(amg_s_mumps_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer :: i
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
#else
val = 0
+1 -32
View File
@@ -188,10 +188,8 @@ module amg_s_onelev_mod
procedure, pass(lv) :: clone => s_base_onelev_clone
procedure, pass(lv) :: cnv => amg_s_base_onelev_cnv
procedure, pass(lv) :: descr => amg_s_base_onelev_descr
procedure, pass(lv) :: memory_use => amg_s_base_onelev_memory_use
procedure, pass(lv) :: default => s_base_onelev_default
procedure, pass(lv) :: free => amg_s_base_onelev_free
procedure, pass(lv) :: free_smoothers => amg_s_base_onelev_free_smoothers
procedure, pass(lv) :: nullify => s_base_onelev_nullify
procedure, pass(lv) :: check => amg_s_base_onelev_check
procedure, pass(lv) :: dump => amg_s_base_onelev_dump
@@ -275,23 +273,6 @@ module amg_s_onelev_mod
end subroutine amg_s_base_onelev_descr
end interface
interface
subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
Implicit None
! Arguments
class(amg_s_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_s_base_onelev_memory_use
end interface
interface
subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold)
import :: amg_s_onelev_type, psb_s_base_vect_type, psb_spk_, &
@@ -305,7 +286,7 @@ module amg_s_onelev_mod
end subroutine amg_s_base_onelev_cnv
end interface
interface
interface
subroutine amg_s_base_onelev_free(lv,info)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
@@ -317,18 +298,6 @@ module amg_s_onelev_mod
end subroutine amg_s_base_onelev_free
end interface
interface
subroutine amg_s_base_onelev_free_smoothers(lv,info)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
implicit none
class(amg_s_onelev_type), intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_base_onelev_free_smoothers
end interface
interface
subroutine amg_s_base_onelev_check(lv,info)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
+14 -9
View File
@@ -119,6 +119,10 @@
module amg_s_parmatch_aggregator_mod
use amg_s_base_aggregator_mod
use amg_s_matchboxp_mod
#if defined(SERIAL_MPI)
type, extends(amg_s_base_aggregator_type) :: amg_s_parmatch_aggregator_type
end type amg_s_parmatch_aggregator_type
#else
type, extends(amg_s_base_aggregator_type) :: amg_s_parmatch_aggregator_type
integer(psb_ipk_) :: matching_alg
integer(psb_ipk_) :: n_sweeps ! When n_sweeps >1 we need an auxiliary descriptor
@@ -240,12 +244,11 @@ module amg_s_parmatch_aggregator_mod
end interface
interface
subroutine amg_s_parmatch_unsmth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,parms,&
subroutine amg_s_parmatch_unsmth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
implicit none
integer(psb_ipk_), intent(in) :: dol1smoothing
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
@@ -259,12 +262,11 @@ module amg_s_parmatch_aggregator_mod
end interface
interface
subroutine amg_s_parmatch_smth_bld(dol1smoothing,ag,a,desc_a,ilaggr,nlaggr,parms,&
subroutine amg_s_parmatch_smth_bld(ag,a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
import :: amg_s_parmatch_aggregator_type, psb_desc_type, psb_sspmat_type,&
& psb_lsspmat_type, psb_dpk_, psb_ipk_, psb_lpk_, amg_sml_parms, amg_saggr_data
implicit none
integer(psb_ipk_), intent(in) :: dol1smoothing
class(amg_s_parmatch_aggregator_type), target, intent(inout) :: ag
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
@@ -396,7 +398,6 @@ contains
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix
character(1024) :: prefix_
info = psb_success_
if (present(prefix)) then
prefix_ = prefix
else
@@ -448,7 +449,6 @@ contains
class(amg_s_base_aggregator_type), target, intent(inout) :: agnext
integer(psb_ipk_), intent(out) :: info
info = psb_success_
!
!
select type(agnext)
@@ -588,7 +588,7 @@ contains
class(amg_s_parmatch_aggregator_type), intent(inout) :: ag
integer(psb_ipk_), intent(out) :: info
info = psb_success_
info = 0
if ((info == 0).and.allocated(ag%w)) deallocate(ag%w,stat=info)
if ((info == 0).and.allocated(ag%w_nxt)) deallocate(ag%w_nxt,stat=info)
if ((info == 0).and.allocated(ag%prol)) then
@@ -627,7 +627,7 @@ contains
class(amg_s_base_aggregator_type), allocatable, intent(inout) :: agnext
integer(psb_ipk_), intent(out) :: info
info = psb_success_
info = 0
if (allocated(agnext)) then
call agnext%free(info)
if (info == 0) deallocate(agnext,stat=info)
@@ -656,7 +656,6 @@ contains
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_parmatch_aggregator_bld_map'
info = psb_success_
call psb_erractionsave(err_act)
!
! Copy the prolongation/restriction matrices into the descriptor map.
@@ -674,6 +673,11 @@ contains
map = psb_linmap(psb_map_gen_linear_,desc_a,&
& desc_ac,op_restr,op_prol,ilaggr,nlaggr)
end if
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
call psb_erractionrestore(err_act)
return
@@ -681,4 +685,5 @@ contains
return
end subroutine amg_s_parmatch_aggregator_bld_map
#endif
end module amg_s_parmatch_aggregator_mod
-374
View File
@@ -1,374 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Daniela di Serafino
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
! File: amg_s_poly_smoother_mod.f90
!
! Module: amg_s_poly_smoother_mod
!
! This module defines:
! the amg_s_poly_smoother_type data structure containing the
! smoother for a Jacobi/block Jacobi smoother.
! The smoother stores in ND the block off-diagonal matrix.
! One special case is treated separately, when the solver is DIAG or L1-DIAG
! then the ND is the entire off-diagonal part of the matrix (including the
! main diagonal block), so that it becomes possible to implement
! a pure Jacobi or L1-Jacobi global solver.
!
module amg_s_poly_smoother
use amg_s_base_smoother_mod
use amg_d_poly_coeff_mod
type, extends(amg_s_base_smoother_type) :: amg_s_poly_smoother_type
! The local solver component is inherited from the
! parent type.
! class(amg_s_base_solver_type), allocatable :: sv
!
integer(psb_ipk_) :: pdegree, variant
integer(psb_ipk_) :: rho_estimate=amg_poly_rho_est_power_
integer(psb_ipk_) :: rho_estimate_iterations=10
type(psb_sspmat_type), pointer :: pa => null()
real(psb_spk_), allocatable :: poly_beta(:)
real(psb_spk_) :: cf_a = szero
real(psb_spk_) :: rho_ba = -sone
contains
procedure, pass(sm) :: apply_v => amg_s_poly_smoother_apply_vect
!!$ procedure, pass(sm) :: apply_a => amg_s_poly_smoother_apply
procedure, pass(sm) :: dump => amg_s_poly_smoother_dmp
procedure, pass(sm) :: build => amg_s_poly_smoother_bld
procedure, pass(sm) :: cnv => amg_s_poly_smoother_cnv
procedure, pass(sm) :: clone => amg_s_poly_smoother_clone
procedure, pass(sm) :: clone_settings => amg_s_poly_smoother_clone_settings
procedure, pass(sm) :: clear_data => amg_s_poly_smoother_clear_data
procedure, pass(sm) :: free => s_poly_smoother_free
procedure, pass(sm) :: cseti => amg_s_poly_smoother_cseti
procedure, pass(sm) :: csetc => amg_s_poly_smoother_csetc
procedure, pass(sm) :: csetr => amg_s_poly_smoother_csetr
procedure, pass(sm) :: descr => amg_s_poly_smoother_descr
procedure, pass(sm) :: sizeof => s_poly_smoother_sizeof
procedure, pass(sm) :: default => s_poly_smoother_default
procedure, pass(sm) :: get_nzeros => s_poly_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => s_poly_smoother_get_wrksize
procedure, nopass :: get_fmt => s_poly_smoother_get_fmt
procedure, nopass :: get_id => s_poly_smoother_get_id
end type amg_s_poly_smoother_type
private :: s_poly_smoother_free, &
& s_poly_smoother_sizeof, s_poly_smoother_get_nzeros, &
& s_poly_smoother_get_fmt, s_poly_smoother_get_id, &
& s_poly_smoother_get_wrksize
interface
subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,wv,info,init,initu)
import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
& psb_ipk_
type(psb_desc_type), intent(in) :: desc_data
class(amg_s_poly_smoother_type), intent(inout) :: sm
type(psb_s_vect_type),intent(inout) :: x
type(psb_s_vect_type),intent(inout) :: y
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
end subroutine amg_s_poly_smoother_apply_vect
end interface
!!$ interface
!!$ subroutine amg_s_poly_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
!!$ & sweeps,work,info,init,initu)
!!$ import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
!!$ & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, &
!!$ & psb_ipk_
!!$ type(psb_desc_type), intent(in) :: desc_data
!!$ class(amg_s_poly_smoother_type), intent(inout) :: sm
!!$ real(psb_spk_),intent(inout) :: x(:)
!!$ real(psb_spk_),intent(inout) :: y(:)
!!$ real(psb_spk_),intent(in) :: alpha,beta
!!$ character(len=1),intent(in) :: trans
!!$ integer(psb_ipk_), intent(in) :: sweeps
!!$ real(psb_spk_),target, intent(inout) :: work(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ character, intent(in), optional :: init
!!$ real(psb_spk_),intent(inout), optional :: initu(:)
!!$ end subroutine amg_s_poly_smoother_apply
!!$ end interface
!!$
interface
subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_s_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_s_poly_smoother_bld
end interface
interface
subroutine amg_s_poly_smoother_cnv(sm,info,amold,vmold,imold)
import :: amg_s_poly_smoother_type, psb_spk_, &
& psb_s_base_sparse_mat, psb_s_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
class(amg_s_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_sparse_mat), intent(in), optional :: amold
class(psb_s_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_s_poly_smoother_cnv
end interface
interface
subroutine amg_s_poly_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, &
& psb_ipk_
implicit none
class(amg_s_poly_smoother_type), intent(in) :: sm
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: level
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: smoother, solver, global_num
end subroutine amg_s_poly_smoother_dmp
end interface
interface
subroutine amg_s_poly_smoother_clone(sm,smout,info)
import :: amg_s_poly_smoother_type, psb_spk_, &
& amg_s_base_smoother_type, psb_ipk_
class(amg_s_poly_smoother_type), intent(inout) :: sm
class(amg_s_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_poly_smoother_clone
end interface
interface
subroutine amg_s_poly_smoother_clone_settings(sm,smout,info)
import :: amg_s_poly_smoother_type, psb_spk_, &
& amg_s_base_smoother_type, psb_ipk_
class(amg_s_poly_smoother_type), intent(inout) :: sm
class(amg_s_base_smoother_type), intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_poly_smoother_clone_settings
end interface
interface
subroutine amg_s_poly_smoother_clear_data(sm,info)
import :: amg_s_poly_smoother_type, psb_spk_, &
& amg_s_base_smoother_type, psb_ipk_
class(amg_s_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
end subroutine amg_s_poly_smoother_clear_data
end interface
interface
subroutine amg_s_poly_smoother_descr(sm,info,iout,coarse,prefix)
import :: amg_s_poly_smoother_type, psb_ipk_
class(amg_s_poly_smoother_type), intent(in) :: sm
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
end subroutine amg_s_poly_smoother_descr
end interface
interface
subroutine amg_s_poly_smoother_cseti(sm,what,val,info,idx)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_s_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_s_poly_smoother_cseti
end interface
interface
subroutine amg_s_poly_smoother_csetc(sm,what,val,info,idx)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_s_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_s_poly_smoother_csetc
end interface
interface
subroutine amg_s_poly_smoother_csetr(sm,what,val,info,idx)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
implicit none
class(amg_s_poly_smoother_type), intent(inout) :: sm
character(len=*), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
end subroutine amg_s_poly_smoother_csetr
end interface
contains
subroutine s_poly_smoother_free(sm,info)
Implicit None
! Arguments
class(amg_s_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_poly_smoother_free'
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(sm%sv)) then
call sm%sv%free(info)
if (info == psb_success_) deallocate(sm%sv,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
end if
if (allocated(sm%poly_beta)) deallocate(sm%poly_beta)
sm%pa => null()
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine s_poly_smoother_free
function s_poly_smoother_sizeof(sm) result(val)
implicit none
! Arguments
class(amg_s_poly_smoother_type), intent(in) :: sm
integer(psb_epk_) :: val
val = psb_sizeof_dp
if (allocated(sm%sv)) val = val + sm%sv%sizeof()
if (allocated(sm%poly_beta)) val = val + psb_sizeof_dp * size(sm%poly_beta)
return
end function s_poly_smoother_sizeof
subroutine s_poly_smoother_default(sm)
Implicit None
! Arguments
class(amg_s_poly_smoother_type), intent(inout) :: sm
!
! Default: BJAC with no residual check
!
sm%pdegree = 1
sm%rho_ba = -sone
sm%variant = amg_cheb_4_
sm%rho_estimate = amg_poly_rho_est_power_
sm%rho_estimate_iterations = 20
if (allocated(sm%sv)) then
call sm%sv%default()
end if
return
end subroutine s_poly_smoother_default
function s_poly_smoother_get_nzeros(sm) result(val)
implicit none
! Arguments
class(amg_s_poly_smoother_type), intent(in) :: sm
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = 0
if (allocated(sm%sv)) val = val + sm%sv%get_nzeros()
return
end function s_poly_smoother_get_nzeros
function s_poly_smoother_get_wrksize(sm) result(val)
implicit none
class(amg_s_poly_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 4
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function s_poly_smoother_get_wrksize
function s_poly_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Polynomial smoother"
end function s_poly_smoother_get_fmt
function s_poly_smoother_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_poly_
end function s_poly_smoother_get_id
end module amg_s_poly_smoother
-90
View File
@@ -113,7 +113,6 @@ module amg_s_prec_type
procedure, pass(prec) :: free => amg_s_prec_free
procedure, pass(prec) :: allocate_wrk => amg_s_allocate_wrk
procedure, pass(prec) :: free_wrk => amg_s_free_wrk
procedure, pass(prec) :: deallocate_wrk => amg_s_free_wrk
procedure, pass(prec) :: is_allocated_wrk => amg_s_is_allocated_wrk
procedure, pass(prec) :: get_complexity => amg_s_get_compl
procedure, pass(prec) :: cmp_complexity => amg_s_cmp_compl
@@ -136,11 +135,8 @@ module amg_s_prec_type
procedure, pass(prec) :: build => amg_sprecbld
procedure, pass(prec) :: hierarchy_build => amg_s_hierarchy_bld
procedure, pass(prec) :: hierarchy_rebuild => amg_s_hierarchy_rebld
procedure, pass(prec) :: hierarchy_free => amg_s_hierarchy_free
procedure, pass(prec) :: smoothers_build => amg_s_smoothers_bld
procedure, pass(prec) :: smoothers_free => amg_s_smoothers_free
procedure, pass(prec) :: descr => amg_sfile_prec_descr
procedure, pass(prec) :: memory_use => amg_sfile_prec_memory_use
end type amg_sprec_type
private :: amg_s_dump, amg_s_get_compl, amg_s_cmp_compl,&
@@ -172,22 +168,6 @@ module amg_s_prec_type
end subroutine amg_sfile_prec_descr
end interface
interface amg_memory_use
subroutine amg_sfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
import :: amg_sprec_type, psb_ipk_
implicit none
! Arguments
class(amg_sprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_sfile_prec_memory_use
end interface
interface amg_sizeof
module procedure amg_sprec_sizeof
end interface
@@ -365,14 +345,6 @@ module amg_s_prec_type
end subroutine amg_s_smoothers_bld
end interface amg_smoothers_bld
interface amg_smoothers_free
module procedure amg_s_smoothers_free
end interface amg_smoothers_free
interface amg_hierarchy_free
module procedure amg_s_hierarchy_free
end interface amg_hierarchy_free
contains
!
! Function returning a pointer to the smoother
@@ -646,68 +618,6 @@ contains
end subroutine amg_s_prec_free
subroutine amg_s_smoothers_free(prec,info)
implicit none
! Arguments
class(amg_sprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: me,err_act,i
character(len=20) :: name
info=psb_success_
name = 'amg_s_smoothers_free'
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
end if
if (allocated(prec%precv)) then
do i=1,size(prec%precv)
call prec%precv(i)%free_smoothers(info)
end do
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_s_smoothers_free
subroutine amg_s_hierarchy_free(prec,info)
implicit none
! Arguments
class(amg_sprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: me,err_act,i
character(len=20) :: name
info=psb_success_
name = 'amg_s_hierarchy_free'
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
end if
me=-1
write(0,*) 'Missing implementation '
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_s_hierarchy_free
!
+1 -1
View File
@@ -51,7 +51,7 @@ module amg_s_slu_solver
use iso_c_binding
use amg_s_base_solver_mod
#if defined(PSB_IPK8)
#if defined(IPK8)
type, extends(amg_s_base_solver_type) :: amg_s_slu_solver_type
+1 -1
View File
@@ -97,7 +97,7 @@ contains
character(len=*), intent(in), optional :: prefix
character(1024) :: prefix_
info = psb_success_
if (present(prefix)) then
prefix_ = prefix
else
+3 -11
View File
@@ -58,10 +58,12 @@ module amg_z_ainv_solver
procedure, pass(sv) :: check => amg_z_ainv_solver_check
procedure, pass(sv) :: build => amg_z_ainv_solver_bld
procedure, pass(sv) :: clone => amg_z_ainv_solver_clone
procedure, pass(sv) :: clone_settings => amg_z_ainv_solver_clone_settings
procedure, pass(sv) :: cseti => amg_z_ainv_solver_cseti
procedure, pass(sv) :: csetc => amg_z_ainv_solver_csetc
procedure, pass(sv) :: csetr => amg_z_ainv_solver_csetr
!!$ procedure, pass(sv) :: seti => amg_z_ainv_solver_seti
!!$ procedure, pass(sv) :: setc => amg_z_ainv_solver_setc
!!$ procedure, pass(sv) :: setr => amg_z_ainv_solver_setr
procedure, pass(sv) :: descr => amg_z_ainv_solver_descr
procedure, pass(sv) :: default => z_ainv_solver_default
procedure, nopass :: stringval => z_ainv_stringval
@@ -83,16 +85,6 @@ module amg_z_ainv_solver
end subroutine amg_z_ainv_solver_clone
end interface
interface
subroutine amg_z_ainv_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
& amg_z_base_solver_type, psb_dpk_, amg_z_ainv_solver_type, psb_ipk_
Implicit None
class(amg_z_ainv_solver_type), intent(inout) :: sv
class(amg_z_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_z_ainv_solver_clone_settings
end interface
interface
subroutine amg_z_ainv_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
+1 -2
View File
@@ -302,7 +302,7 @@ contains
integer(psb_ipk_), intent(out) :: info
! Do nothing
info = psb_success_
return
end subroutine amg_z_base_aggregator_set_aggr_type
@@ -486,7 +486,6 @@ contains
integer(psb_ipk_) :: err_act
character(len=20) :: name='z_base_aggregator_bld_map'
info = psb_success_
call psb_erractionsave(err_act)
!
! Copy the prolongation/restriction matrices into the descriptor map.
+1 -2
View File
@@ -150,7 +150,7 @@ contains
class(amg_z_dec_aggregator_type), intent(inout) :: ag
type(amg_dml_parms), intent(in) :: parms
integer(psb_ipk_), intent(out) :: info
info = psb_success_
select case(parms%aggr_type)
case (amg_noalg_)
ag%soc_map_bld => null()
@@ -192,7 +192,6 @@ contains
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix
character(1024) :: prefix_
info = psb_success_
if (present(prefix)) then
prefix_ = prefix
else
+125
View File
@@ -0,0 +1,125 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2020
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
! The aggregator object hosts the aggregation method for building
! the multilevel hierarchy. This variant is based on the hybrid method
! presented in
!
! S. Gratton, P. Henon, P. Jiranek and X. Vasseur:
! Reducing complexity of algebraic multigrid by aggregation
! Numerical Lin. Algebra with Applications, 2016, 23:501-518
!
module amg_z_hybrid_aggregator_mod
use amg_z_dec_aggregator_mod
!
! sm - class(amg_T_base_smoother_type), allocatable
! The current level preconditioner (aka smoother).
! parms - type(amg_RTml_parms)
! The parameters defining the multilevel strategy.
! ac - The local part of the current-level matrix, built by
! coarsening the previous-level matrix.
! desc_ac - type(psb_desc_type).
! The communication descriptor associated to the matrix
! stored in ac.
! base_a - type(psb_Tspmat_type), pointer.
! Pointer (really a pointer!) to the local part of the current
! matrix (so we have a unified treatment of residuals).
! We need this to avoid passing explicitly the current matrix
! to the routine which applies the preconditioner.
! base_desc - type(psb_desc_type), pointer.
! Pointer to the communication descriptor associated to the
! matrix pointed by base_a.
! map - Stores the maps (restriction and prolongation) between the
! vector spaces associated to the index spaces of the previous
! and current levels.
!
! Methods:
! Most methods follow the encapsulation hierarchy: they take whatever action
! is appropriate for the current object, then call the corresponding method for
! the contained object.
! As an example: the descr() method prints out a description of the
! level. It starts by invoking the descr() method of the parms object,
! then calls the descr() method of the smoother object.
!
! descr - Prints a description of the object.
! default - Set default values
! dump - Dump to file object contents
! set - Sets various parameters; when a request is unknown
! it is passed to the smoother object for further processing.
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
!
!
type, extends(amg_z_dec_aggregator_type) :: amg_z_hybrid_aggregator_type
contains
procedure, pass(ag) :: bld_tprol => amg_z_hybrid_aggregator_build_tprol
procedure, nopass :: fmt => amg_z_hybrid_aggregator_fmt
end type amg_z_hybrid_aggregator_type
interface
subroutine amg_z_hybrid_aggregator_build_tprol(ag,parms,a,desc_a,ilaggr,nlaggr,op_prol,info)
import :: amg_z_hybrid_aggregator_type, psb_desc_type, psb_zspmat_type, psb_dpk_, &
& psb_ipk_, psb_long_int_k_, amg_dml_parms
implicit none
class(amg_z_hybrid_aggregator_type), target, intent(inout) :: ag
type(amg_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), allocatable, intent(out) :: ilaggr(:),nlaggr(:)
type(psb_zspmat_type), intent(out) :: op_prol
integer(psb_ipk_), intent(out) :: info
end subroutine amg_z_hybrid_aggregator_build_tprol
end interface
contains
function amg_z_hybrid_aggregator_fmt() result(val)
implicit none
character(len=32) :: val
val = "Hybrid Decoupled aggregation"
end function amg_z_hybrid_aggregator_fmt
end module amg_z_hybrid_aggregator_mod
+7 -7
View File
@@ -234,7 +234,7 @@ contains
! Arguments
class(amg_z_ilu_solver_type), intent(inout) :: sv
sv%fact_type = amg_ilu_n_
sv%fact_type = psb_ilu_n_
sv%fill_in = 0
sv%thresh = dzero
@@ -255,13 +255,13 @@ contains
info = psb_success_
call amg_check_def(sv%fact_type,&
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
select case(sv%fact_type)
case(amg_ilu_n_,amg_milu_n_)
case(psb_ilu_n_,psb_milu_n_)
call amg_check_def(sv%fill_in,&
& 'Level',izero,is_int_non_negative)
case(amg_ilu_t_)
case(psb_ilu_t_)
call amg_check_def(sv%thresh,&
& 'Eps',dzero,is_legal_d_fact_thrs)
end select
@@ -439,9 +439,9 @@ contains
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
& amg_fact_names(sv%fact_type)
select case(sv%fact_type)
case(amg_ilu_n_,amg_milu_n_)
case(psb_ilu_n_,psb_milu_n_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
case(amg_ilu_t_)
case(psb_ilu_t_)
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
end select
@@ -496,7 +496,7 @@ contains
implicit none
integer(psb_ipk_) :: val
val = amg_ilu_n_
val = psb_ilu_n_
end function z_ilu_solver_get_id
function z_ilu_solver_get_wrksize() result(val)
+1 -2
View File
@@ -109,12 +109,11 @@ module amg_z_inner_mod
end interface amg_map_to_tprol
abstract interface
subroutine amg_zaggrmat_var_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,parms,&
subroutine amg_zaggrmat_var_bld(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
import :: psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_, psb_lzspmat_type
import :: amg_z_onelev_type, amg_dml_parms
implicit none
integer(psb_ipk_), intent(in) :: dol1smoothing
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
-12
View File
@@ -52,7 +52,6 @@ module amg_z_invk_solver
contains
procedure, pass(sv) :: check => amg_z_invk_solver_check
procedure, pass(sv) :: clone => amg_z_invk_solver_clone
procedure, pass(sv) :: clone_settings => amg_z_invk_solver_clone_settings
procedure, pass(sv) :: build => amg_z_invk_solver_bld
procedure, pass(sv) :: cseti => amg_z_invk_solver_cseti
procedure, pass(sv) :: descr => amg_z_invk_solver_descr
@@ -74,17 +73,6 @@ module amg_z_invk_solver
end subroutine amg_z_invk_solver_clone
end interface
interface
subroutine amg_z_invk_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
& amg_z_base_solver_type, psb_dpk_, amg_z_invk_solver_type, psb_ipk_
Implicit None
class(amg_z_invk_solver_type), intent(inout) :: sv
class(amg_z_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_z_invk_solver_clone_settings
end interface
interface
subroutine amg_z_invk_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
-12
View File
@@ -52,7 +52,6 @@ module amg_z_invt_solver
contains
procedure, pass(sv) :: check => amg_z_invt_solver_check
procedure, pass(sv) :: clone => amg_z_invt_solver_clone
procedure, pass(sv) :: clone_settings => amg_z_invt_solver_clone_settings
procedure, pass(sv) :: build => amg_z_invt_solver_bld
procedure, pass(sv) :: cseti => amg_z_invt_solver_cseti
procedure, pass(sv) :: csetr => amg_z_invt_solver_csetr
@@ -74,17 +73,6 @@ module amg_z_invt_solver
end subroutine amg_z_invt_solver_clone
end interface
interface
subroutine amg_z_invt_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
& amg_z_base_solver_type, psb_dpk_, amg_z_invt_solver_type, psb_ipk_
Implicit None
class(amg_z_invt_solver_type), intent(inout) :: sv
class(amg_z_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_z_invt_solver_clone_settings
end interface
interface
subroutine amg_z_invt_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
+2 -2
View File
@@ -203,8 +203,8 @@ module amg_z_jac_smoother
subroutine amg_z_jac_smoother_clone_settings(sm,smout,info)
import :: amg_z_jac_smoother_type, psb_dpk_, &
& amg_z_base_smoother_type, psb_ipk_
class(amg_z_jac_smoother_type), intent(inout) :: sm
class(amg_z_base_smoother_type), intent(inout) :: smout
class(amg_z_jac_smoother_type), intent(inout) :: sm
class(amg_z_base_smoother_type), allocatable, intent(inout) :: smout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_z_jac_smoother_clone_settings
end interface
-585
View File
@@ -1,585 +0,0 @@
!
!
! AMG4PSBLAS version 1.0
! Algebraic Multigrid Package
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
!
! (C) Copyright 2021
!
! Salvatore Filippone
! Pasqua D'Ambra
! Fabio Durastante
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
! File: amg_z_jac_solver_mod.f90
!
! Module: amg_z_jac_solver_mod
!
! This module defines:
! - the amg_z_jac_solver_type data structure containing the ingredients
! for a local Jacobi iteration. The iterations are local to a process
! (they operate on the block diagonal).
!
!
module amg_z_jac_solver
use amg_z_base_solver_mod
type, extends(amg_z_base_solver_type) :: amg_z_jac_solver_type
type(psb_zspmat_type) :: a
type(psb_z_vect_type), allocatable :: dv
complex(psb_dpk_), allocatable :: d(:)
integer(psb_ipk_) :: sweeps
real(psb_dpk_) :: eps
contains
procedure, pass(sv) :: dump => amg_z_jac_solver_dmp
procedure, pass(sv) :: check => z_jac_solver_check
procedure, pass(sv) :: clone => amg_z_jac_solver_clone
procedure, pass(sv) :: clone_settings => amg_z_jac_solver_clone_settings
procedure, pass(sv) :: clear_data => amg_z_jac_solver_clear_data
procedure, pass(sv) :: build => amg_z_jac_solver_bld
procedure, pass(sv) :: cnv => amg_z_jac_solver_cnv
procedure, pass(sv) :: apply_v => amg_z_jac_solver_apply_vect
procedure, pass(sv) :: apply_a => amg_z_jac_solver_apply
procedure, pass(sv) :: free => z_jac_solver_free
procedure, pass(sv) :: cseti => z_jac_solver_cseti
procedure, pass(sv) :: csetc => z_jac_solver_csetc
procedure, pass(sv) :: csetr => z_jac_solver_csetr
procedure, pass(sv) :: descr => z_jac_solver_descr
procedure, pass(sv) :: default => z_jac_solver_default
procedure, pass(sv) :: sizeof => z_jac_solver_sizeof
procedure, pass(sv) :: get_nzeros => z_jac_solver_get_nzeros
procedure, nopass :: get_wrksz => z_jac_solver_get_wrksize
procedure, nopass :: get_fmt => z_jac_solver_get_fmt
procedure, nopass :: get_id => z_jac_solver_get_id
procedure, nopass :: is_iterative => z_jac_solver_is_iterative
end type amg_z_jac_solver_type
type, extends(amg_z_jac_solver_type) :: amg_z_l1_jac_solver_type
contains
procedure, pass(sv) :: build => amg_z_l1_jac_solver_bld
procedure, pass(sv) :: descr => z_l1_jac_solver_descr
procedure, nopass :: get_fmt => z_l1_jac_solver_get_fmt
procedure, nopass :: get_id => z_l1_jac_solver_get_id
end type amg_z_l1_jac_solver_type
private :: z_jac_solver_bld, z_jac_solver_apply, &
& z_jac_solver_free, &
& z_jac_solver_descr, z_jac_solver_sizeof, &
& z_jac_solver_default, z_jac_solver_dmp, &
& z_jac_solver_apply_vect, z_jac_solver_get_nzeros, &
& z_jac_solver_get_fmt, z_jac_solver_check,&
& z_jac_solver_is_iterative, &
& z_jac_solver_get_id, z_jac_solver_get_wrksize
interface
subroutine amg_z_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,wv,info,init,initu)
import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(amg_z_jac_solver_type), intent(inout) :: sv
type(psb_z_vect_type),intent(inout) :: x
type(psb_z_vect_type),intent(inout) :: y
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
end subroutine amg_z_jac_solver_apply_vect
end interface
interface
subroutine amg_z_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
implicit none
type(psb_desc_type), intent(in) :: desc_data
class(amg_z_jac_solver_type), intent(inout) :: sv
complex(psb_dpk_),intent(inout) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
complex(psb_dpk_),intent(inout), optional :: initu(:)
end subroutine amg_z_jac_solver_apply
end interface
interface
subroutine amg_z_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
type(psb_zspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_z_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_zspmat_type), intent(in), target, optional :: b
class(psb_z_base_sparse_mat), intent(in), optional :: amold
class(psb_z_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_z_jac_solver_bld
end interface
interface
subroutine amg_z_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
import :: psb_desc_type, amg_z_l1_jac_solver_type, psb_z_vect_type, psb_dpk_, &
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
type(psb_zspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(inout) :: desc_a
class(amg_z_l1_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
type(psb_zspmat_type), intent(in), target, optional :: b
class(psb_z_base_sparse_mat), intent(in), optional :: amold
class(psb_z_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_z_l1_jac_solver_bld
end interface
interface
subroutine amg_z_jac_solver_cnv(sv,info,amold,vmold,imold)
import :: amg_z_jac_solver_type, psb_dpk_, &
& psb_z_base_sparse_mat, psb_z_base_vect_type,&
& psb_ipk_, psb_i_base_vect_type
implicit none
class(amg_z_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_sparse_mat), intent(in), optional :: amold
class(psb_z_base_vect_type), intent(in), optional :: vmold
class(psb_i_base_vect_type), intent(in), optional :: imold
end subroutine amg_z_jac_solver_cnv
end interface
interface
subroutine amg_z_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, &
& psb_ipk_
implicit none
class(amg_z_jac_solver_type), intent(in) :: sv
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: level
integer(psb_ipk_), intent(out) :: info
character(len=*), intent(in), optional :: prefix, head
logical, optional, intent(in) :: solver, global_num
end subroutine amg_z_jac_solver_dmp
end interface
interface
subroutine amg_z_jac_solver_clone(sv,svout,info)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
& psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
& amg_z_base_solver_type, amg_z_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_z_jac_solver_type), intent(inout) :: sv
class(amg_z_base_solver_type), allocatable, intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_z_jac_solver_clone
end interface
!!$ interface
!!$ subroutine amg_z_l1_jac_solver_clone(sv,svout,info)
!!$ import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
!!$ & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
!!$ & amg_z_base_solver_type, amg_z_l1_jac_solver_type, psb_ipk_
!!$ Implicit None
!!$
!!$ ! Arguments
!!$ class(amg_z_l1_jac_solver_type), intent(inout) :: sv
!!$ class(amg_z_base_solver_type), allocatable, intent(inout) :: svout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ end subroutine amg_z_l1_jac_solver_clone
!!$ end interface
interface
subroutine amg_z_jac_solver_clone_settings(sv,svout,info)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
& psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
& amg_z_base_solver_type, amg_z_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_z_jac_solver_type), intent(inout) :: sv
class(amg_z_base_solver_type), intent(inout) :: svout
integer(psb_ipk_), intent(out) :: info
end subroutine amg_z_jac_solver_clone_settings
end interface
interface
subroutine amg_z_jac_solver_clear_data(sv,info)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
& psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
& amg_z_jac_solver_type, psb_ipk_
Implicit None
! Arguments
class(amg_z_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
end subroutine amg_z_jac_solver_clear_data
end interface
contains
subroutine z_jac_solver_default(sv)
Implicit None
! Arguments
class(amg_z_jac_solver_type), intent(inout) :: sv
sv%sweeps = ione
sv%eps = dzero
return
end subroutine z_jac_solver_default
subroutine z_jac_solver_check(sv,info)
Implicit None
! Arguments
class(amg_z_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='z_jac_solver_check'
call psb_erractionsave(err_act)
info = psb_success_
call amg_check_def(sv%sweeps,&
& 'Jacobi sweeps',ione,is_int_positive)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine z_jac_solver_check
subroutine z_jac_solver_cseti(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_z_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act
character(len=20) :: name='z_jac_solver_cseti'
info = psb_success_
call psb_erractionsave(err_act)
select case(psb_toupper(what))
case('SOLVER_SWEEPS')
sv%sweeps = val
case default
call sv%amg_z_base_solver_type%set(what,val,info,idx=idx)
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine z_jac_solver_cseti
subroutine z_jac_solver_csetc(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_z_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
character(len=*), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act, ival
character(len=20) :: name='z_jac_solver_csetc'
info = psb_success_
call psb_erractionsave(err_act)
call sv%amg_z_base_solver_type%set(what,val,info,idx=idx)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info, name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine z_jac_solver_csetc
subroutine z_jac_solver_csetr(sv,what,val,info,idx)
Implicit None
! Arguments
class(amg_z_jac_solver_type), intent(inout) :: sv
character(len=*), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: idx
integer(psb_ipk_) :: err_act
character(len=20) :: name='z_jac_solver_csetr'
call psb_erractionsave(err_act)
info = psb_success_
select case(psb_toupper(what))
case('SOLVER_EPS')
sv%eps = val
case default
call sv%amg_z_base_solver_type%set(what,val,info,idx=idx)
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine z_jac_solver_csetr
subroutine z_jac_solver_free(sv,info)
Implicit None
! Arguments
class(amg_z_jac_solver_type), intent(inout) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act
character(len=20) :: name='z_jac_solver_free'
call psb_erractionsave(err_act)
info = psb_success_
call sv%a%free()
if (allocated(sv%dv)) then
call sv%dv%free(info)
deallocate(sv%dv)
end if
if (allocated(sv%d)) deallocate(sv%d)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine z_jac_solver_free
subroutine z_jac_solver_descr(sv,info,iout,coarse,prefix)
Implicit None
! Arguments
class(amg_z_jac_solver_type), intent(in) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='amg_z_jac_solver_descr'
integer(psb_ipk_) :: iout_
character(1024) :: prefix_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
endif
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if (sv%eps<=dzero) then
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine z_jac_solver_descr
function z_jac_solver_get_nzeros(sv) result(val)
implicit none
! Arguments
class(amg_z_jac_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = 0
val = val + sv%a%get_nzeros()
val = val + sv%dv%get_nrows()
return
end function z_jac_solver_get_nzeros
function z_jac_solver_sizeof(sv) result(val)
implicit none
! Arguments
class(amg_z_jac_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer(psb_ipk_) :: i
val = psb_sizeof_ip
val = val + sv%a%sizeof()
val = val + sv%dv%sizeof()
return
end function z_jac_solver_sizeof
function z_jac_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "Jacobi solver"
end function z_jac_solver_get_fmt
function z_jac_solver_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_jac_
end function z_jac_solver_get_id
!
! If this is true, then the solver needs a starting
! guess. Currently only handled in JAC smoother.
!
function z_jac_solver_is_iterative() result(val)
implicit none
logical :: val
val = .true.
end function z_jac_solver_is_iterative
function z_jac_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 2
end function z_jac_solver_get_wrksize
subroutine z_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
Implicit None
! Arguments
class(amg_z_l1_jac_solver_type), intent(in) :: sv
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
logical, intent(in), optional :: coarse
character(len=*), intent(in), optional :: prefix
! Local variables
integer(psb_ipk_) :: err_act
character(len=20), parameter :: name='amg_z_l1_jac_solver_descr'
integer(psb_ipk_) :: iout_
character(1024) :: prefix_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = psb_out_unit
endif
if (present(prefix)) then
prefix_ = prefix
else
prefix_ = ""
end if
if (sv%eps<=dzero) then
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',&
& sv%sweeps,' sweeps'
else
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',&
& sv%eps,' and maxit', sv%sweeps
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine z_l1_jac_solver_descr
function z_l1_jac_solver_get_fmt() result(val)
implicit none
character(len=32) :: val
val = "L1-Jacobi solver"
end function z_l1_jac_solver_get_fmt
function z_l1_jac_solver_get_id() result(val)
implicit none
integer(psb_ipk_) :: val
val = amg_l1_jac_
end function z_l1_jac_solver_get_id
end module amg_z_jac_solver
+12 -13
View File
@@ -52,10 +52,10 @@
!
module amg_z_mumps_solver
use amg_z_base_solver_mod
#if defined(AMG_HAVE_MUMPS) && defined(AMG_HAVE_MUMPS_MODULES)
#if defined(HAVE_MUMPS_) && defined(HAVE_MUMPS_MODULES_)
use zmumps_struc_def
#endif
#if defined(AMG_HAVE_MUMPS) && defined(AMG_HAVE_MUMPS_INCLUDES)
#if defined(HAVE_MUMPS_) && defined(HAVE_MUMPS_INCLUDES_)
include 'zmumps_struc.h'
#endif
@@ -68,7 +68,7 @@ module amg_z_mumps_solver
end type amg_z_mumps_rcntl_item
type, extends(amg_z_base_solver_type) :: amg_z_mumps_solver_type
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
type(zmumps_struc), allocatable :: id
#else
integer, allocatable :: id
@@ -78,8 +78,7 @@ module amg_z_mumps_solver
!
! Controls to be set before MUMPS instantiation:
!
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: 'LOCAL_SOLVER
! 1==amg_global_solver_: 'GLOBAL_SOLVER'
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: LOCAL 1==amg_global_solver_: GLOBAL
! IPAR(2) : MUMPS_PRINT_ERR print verbosity (see MUMPS)
! IPAR(3) : MUMPS_SYM 0: non-symmetric 2: symmetric
integer(psb_ipk_), dimension(3) :: ipar
@@ -189,7 +188,7 @@ contains
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
@@ -239,7 +238,7 @@ contains
character(len=20) :: name='z_mumps_solver_clear_data'
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
if (allocated(sv%id)) then
if (sv%built) then
@@ -279,7 +278,7 @@ contains
character(len=20) :: name='z_mumps_solver_free'
info = 0
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
call psb_erractionsave(err_act)
call sv%clear_data(info)
if ((info == 0).and.allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
@@ -383,7 +382,7 @@ subroutine z_mumps_solver_csetc(sv,what,val,info,idx)
select case(psb_toupper(trim(what)))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_LOC_GLOB')
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
#endif
@@ -421,7 +420,7 @@ subroutine z_mumps_solver_cseti(sv,what,val,info,idx)
call psb_erractionsave(err_act)
select case(psb_toupper(what))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_LOC_GLOB')
sv%ipar(1) = val
case('MUMPS_PRINT_ERR')
@@ -467,7 +466,7 @@ subroutine z_mumps_solver_csetr(sv,what,val,info,idx)
call psb_erractionsave(err_act)
select case(psb_toupper(what))
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
case('MUMPS_RPAR_ENTRY')
if(present(idx)) then
! Note: this will allocate %item
@@ -504,7 +503,7 @@ subroutine z_mumps_solver_default(sv)
info = psb_success_
call psb_erractionsave(err_act)
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
if (.not.allocated(sv%id)) then
allocate(sv%id,stat=info)
if (info /= psb_success_) then
@@ -561,7 +560,7 @@ function z_mumps_solver_sizeof(sv) result(val)
class(amg_z_mumps_solver_type), intent(in) :: sv
integer(psb_epk_) :: val
integer :: i
#if defined(AMG_HAVE_MUMPS)
#if defined(HAVE_MUMPS_)
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
#else
val = 0
+1 -32
View File
@@ -187,10 +187,8 @@ module amg_z_onelev_mod
procedure, pass(lv) :: clone => z_base_onelev_clone
procedure, pass(lv) :: cnv => amg_z_base_onelev_cnv
procedure, pass(lv) :: descr => amg_z_base_onelev_descr
procedure, pass(lv) :: memory_use => amg_z_base_onelev_memory_use
procedure, pass(lv) :: default => z_base_onelev_default
procedure, pass(lv) :: free => amg_z_base_onelev_free
procedure, pass(lv) :: free_smoothers => amg_z_base_onelev_free_smoothers
procedure, pass(lv) :: nullify => z_base_onelev_nullify
procedure, pass(lv) :: check => amg_z_base_onelev_check
procedure, pass(lv) :: dump => amg_z_base_onelev_dump
@@ -274,23 +272,6 @@ module amg_z_onelev_mod
end subroutine amg_z_base_onelev_descr
end interface
interface
subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
Implicit None
! Arguments
class(amg_z_onelev_type), intent(in) :: lv
integer(psb_ipk_), intent(in) :: il,nl,ilmin
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_z_base_onelev_memory_use
end interface
interface
subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold)
import :: amg_z_onelev_type, psb_z_base_vect_type, psb_dpk_, &
@@ -304,7 +285,7 @@ module amg_z_onelev_mod
end subroutine amg_z_base_onelev_cnv
end interface
interface
interface
subroutine amg_z_base_onelev_free(lv,info)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
@@ -316,18 +297,6 @@ module amg_z_onelev_mod
end subroutine amg_z_base_onelev_free
end interface
interface
subroutine amg_z_base_onelev_free_smoothers(lv,info)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
& psb_ipk_, psb_epk_, psb_desc_type
implicit none
class(amg_z_onelev_type), intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
end subroutine amg_z_base_onelev_free_smoothers
end interface
interface
subroutine amg_z_base_onelev_check(lv,info)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
-90
View File
@@ -113,7 +113,6 @@ module amg_z_prec_type
procedure, pass(prec) :: free => amg_z_prec_free
procedure, pass(prec) :: allocate_wrk => amg_z_allocate_wrk
procedure, pass(prec) :: free_wrk => amg_z_free_wrk
procedure, pass(prec) :: deallocate_wrk => amg_z_free_wrk
procedure, pass(prec) :: is_allocated_wrk => amg_z_is_allocated_wrk
procedure, pass(prec) :: get_complexity => amg_z_get_compl
procedure, pass(prec) :: cmp_complexity => amg_z_cmp_compl
@@ -136,11 +135,8 @@ module amg_z_prec_type
procedure, pass(prec) :: build => amg_zprecbld
procedure, pass(prec) :: hierarchy_build => amg_z_hierarchy_bld
procedure, pass(prec) :: hierarchy_rebuild => amg_z_hierarchy_rebld
procedure, pass(prec) :: hierarchy_free => amg_z_hierarchy_free
procedure, pass(prec) :: smoothers_build => amg_z_smoothers_bld
procedure, pass(prec) :: smoothers_free => amg_z_smoothers_free
procedure, pass(prec) :: descr => amg_zfile_prec_descr
procedure, pass(prec) :: memory_use => amg_zfile_prec_memory_use
end type amg_zprec_type
private :: amg_z_dump, amg_z_get_compl, amg_z_cmp_compl,&
@@ -172,22 +168,6 @@ module amg_z_prec_type
end subroutine amg_zfile_prec_descr
end interface
interface amg_memory_use
subroutine amg_zfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
import :: amg_zprec_type, psb_ipk_
implicit none
! Arguments
class(amg_zprec_type), intent(in) :: prec
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: iout
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in), optional :: verbosity
character(len=*), intent(in), optional :: prefix
logical, intent(in), optional :: global
end subroutine amg_zfile_prec_memory_use
end interface
interface amg_sizeof
module procedure amg_zprec_sizeof
end interface
@@ -365,14 +345,6 @@ module amg_z_prec_type
end subroutine amg_z_smoothers_bld
end interface amg_smoothers_bld
interface amg_smoothers_free
module procedure amg_z_smoothers_free
end interface amg_smoothers_free
interface amg_hierarchy_free
module procedure amg_z_hierarchy_free
end interface amg_hierarchy_free
contains
!
! Function returning a pointer to the smoother
@@ -646,68 +618,6 @@ contains
end subroutine amg_z_prec_free
subroutine amg_z_smoothers_free(prec,info)
implicit none
! Arguments
class(amg_zprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: me,err_act,i
character(len=20) :: name
info=psb_success_
name = 'amg_z_smoothers_free'
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
end if
if (allocated(prec%precv)) then
do i=1,size(prec%precv)
call prec%precv(i)%free_smoothers(info)
end do
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_z_smoothers_free
subroutine amg_z_hierarchy_free(prec,info)
implicit none
! Arguments
class(amg_zprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: me,err_act,i
character(len=20) :: name
info=psb_success_
name = 'amg_z_hierarchy_free'
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
end if
me=-1
write(0,*) 'Missing implementation '
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine amg_z_hierarchy_free
!
+1 -1
View File
@@ -51,7 +51,7 @@ module amg_z_slu_solver
use iso_c_binding
use amg_z_base_solver_mod
#if defined(PSB_IPK8)
#if defined(IPK8)
type, extends(amg_z_base_solver_type) :: amg_z_slu_solver_type
+1 -1
View File
@@ -52,7 +52,7 @@ module amg_z_sludist_solver
use iso_c_binding
use amg_z_base_solver_mod
#if (!defined(AMG_HAVE_SLUDIST)) || defined(PSB_IPK8)
#if (!defined(HAVE_SLUDIST_)) || defined(IPK8)
type, extends(amg_z_base_solver_type) :: amg_z_sludist_solver_type
+1 -1
View File
@@ -97,7 +97,7 @@ contains
character(len=*), intent(in), optional :: prefix
character(1024) :: prefix_
info = psb_success_
if (present(prefix)) then
prefix_ = prefix
else
+1 -1
View File
@@ -51,7 +51,7 @@ module amg_z_umf_solver
use iso_c_binding
use amg_z_base_solver_mod
#if defined(PSB_IPK8)
#if defined(IPK8)
type, extends(amg_z_base_solver_type) :: amg_z_umf_solver_type
end type amg_z_umf_solver_type
+4 -5
View File
@@ -5,7 +5,6 @@ MODDIR=../../modules
HERE=..
FINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) $(PSBLAS_INCLUDES)
CINCLUDES=-I. -I.. -I$(PSBLAS_INCDIR)
@@ -23,22 +22,22 @@ MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS)
MPCOBJS=amg_dslud_interface.o amg_zslud_interface.o
DINNEROBJS= amg_dmlprec_bld.o amg_dfile_prec_descr.o amg_dfile_prec_memory_use.o \
DINNEROBJS= amg_dmlprec_bld.o amg_dfile_prec_descr.o \
amg_d_smoothers_bld.o amg_d_hierarchy_bld.o amg_d_hierarchy_rebld.o \
amg_dmlprec_aply.o \
$(DMPFOBJS) amg_d_extprol_bld.o
SINNEROBJS= amg_smlprec_bld.o amg_sfile_prec_descr.o amg_sfile_prec_memory_use.o \
SINNEROBJS= amg_smlprec_bld.o amg_sfile_prec_descr.o \
amg_s_smoothers_bld.o amg_s_hierarchy_bld.o amg_s_hierarchy_rebld.o \
amg_smlprec_aply.o \
$(SMPFOBJS) amg_s_extprol_bld.o
ZINNEROBJS= amg_zmlprec_bld.o amg_zfile_prec_descr.o amg_zfile_prec_memory_use.o \
ZINNEROBJS= amg_zmlprec_bld.o amg_zfile_prec_descr.o \
amg_z_smoothers_bld.o amg_z_hierarchy_bld.o amg_z_hierarchy_rebld.o \
amg_zmlprec_aply.o \
$(ZMPFOBJS) amg_z_extprol_bld.o
CINNEROBJS= amg_cmlprec_bld.o amg_cfile_prec_descr.o amg_cfile_prec_memory_use.o \
CINNEROBJS= amg_cmlprec_bld.o amg_cfile_prec_descr.o \
amg_c_smoothers_bld.o amg_c_hierarchy_bld.o amg_c_hierarchy_rebld.o \
amg_cmlprec_aply.o \
$(CMPFOBJS) amg_c_extprol_bld.o
+15 -12
View File
@@ -5,8 +5,7 @@ MODDIR=../../../modules
HERE=../..
FINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR) $(PSBLAS_INCLUDES)
CXXINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(INCDIR) $(FMFLAG)/. -I$(PSBLAS_INCDIR)
CINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(INCDIR) $(FMFLAG)/. -I$(PSBLAS_INCDIR)
CXXINCLUDES=$(FIFLAG)$(HERE) $(FIFLAG)$(INCDIR) $(FIFLAG)/. -I../../../../ParallelRomaF-main/include -I$(PSBLAS_INCDIR)
#CINCLUDES= -I${SUPERLU_INCDIR} -I${HSL_INCDIR} -I${SPRAL_INCDIR} -I/home/users/pasqua/Ambra/BootCMatch/include -lBCM -L/home/users/pasqua/Ambra/BootCMatch/lib -lm
@@ -60,10 +59,18 @@ amg_s_parmatch_spmm_bld.o \
amg_s_parmatch_spmm_bld_ov.o \
amg_s_parmatch_unsmth_bld.o \
amg_s_parmatch_smth_bld.o \
amg_s_parmatch_spmm_bld_inner.o
amg_s_parmatch_spmm_bld_inner.o \
amg_d_newmatch_aggregator_inner_mat_asb.o\
amg_d_newmatch_aggregator_mat_asb.o \
amg_d_newmatch_aggregator_mat_bld.o \
amg_d_newmatch_aggregator_tprol.o \
amg_d_newmatch_map_to_tprol.o \
amg_d_newmatch_spmm_bld_inner.o \
amg_d_newmatch_spmm_bld_ov.o
MPCOBJS=Matching.o \
MatchBoxPC.o \
MPCXXOBJS=MatchBoxPC.o \
algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.o \
newmatch_interface.o \
sendBundledMessages.o \
initialize.o \
extractUChunk.o \
@@ -78,10 +85,10 @@ processCrossEdge.o \
queueTransfer.o \
processMessages.o \
processExposedVertex.o \
algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.o \
algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.o
algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.o \
MatchingAlgorithms.o
OBJS = $(FOBJS) $(MPCOBJS)
OBJS = $(FOBJS) $(MPCOBJS) $(MPCXXOBJS)
LIBNAME=libamg_prec.a
@@ -91,10 +98,6 @@ lib: objs
$(AR) $(HERE)/$(LIBNAME) $(OBJS)
$(RANLIB) $(HERE)/$(LIBNAME)
mpobjs:
(make $(MPFOBJS) F90="$(MPF90)" F90COPT="$(F90COPT)")
(make $(MPCOBJS) CC="$(MPCC)" CCOPT="$(CCOPT)")
veryclean: clean
/bin/rm -f $(LIBNAME)
+21 -32
View File
@@ -40,17 +40,15 @@
// ************************************************************************
#include <stdio.h>
#include <stdlib.h>
#include "amg_config.h"
#include "MatchBoxPC.h"
#if !defined(PSB_SERIAL_MPI)
#if !defined(SERIAL_MPI)
#include <mpi.h>
#endif
#include "MatchBoxPC.h"
#ifdef __cplusplus
extern "C" {
#endif
#if !defined(PSB_SERIAL_MPI)
void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt* verLocPtr, MilanLongInt* verLocInd, MilanReal* edgeLocWeight,
@@ -60,6 +58,7 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
#if !defined(SERIAL_MPI)
MPI_Comm C_comm=MPI_Comm_f2c(icomm);
#ifdef DEBUG
@@ -68,13 +67,13 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
#endif
#undef TIME_TRACKER
#ifdef TIME_TRACKER
double tmr = MPI_Wtime();
#endif
#define TIME_TRACKER
#ifdef TIME_TRACKER
double tmr = MPI_Wtime();
#endif
#if defined(PSB_OPENMP)
//fprintf(stderr,"Warning: using buggy OpenMP matching!\n");
#define OMP
#ifdef OMP
dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge,
verLocPtr, verLocInd, edgeLocWeight,
verDistance, Mate,
@@ -93,11 +92,12 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
#endif
#ifdef TIME_TRACKER
tmr = MPI_Wtime() - tmr;
fprintf(stderr, "Elaboration time: %f for %ld nodes\n", tmr, NLVer);
#ifdef TIME_TRACKER
tmr = MPI_Wtime() - tmr;
fprintf(stderr, "Elaboration time: %f for %ld nodes\n", tmr, NLVer);
#endif
#endif
}
void sMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
@@ -108,33 +108,22 @@ void sMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
#if !defined(SERIAL_MPI)
MPI_Comm C_comm=MPI_Comm_f2c(icomm);
#ifdef DEBUG
fprintf(stderr,"MatchBoxPC: rank %d nlver %ld nledge %ld [ %ld %ld ]\n",
myRank,NLVer, NLEdge,verDistance[0],verDistance[1]);
#endif
#if defined(PSB_OPENMP)
//fprintf(stderr,"Warning: using buggy OpenMP matching!\n");
salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge,
verLocPtr, verLocInd, edgeLocWeight,
verDistance, Mate,
myRank, numProcs, C_comm,
msgIndSent, msgActualSent, msgPercent,
ph0_time, ph1_time, ph2_time,
ph1_card, ph2_card );
#else
salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(NLVer, NLEdge,
verLocPtr, verLocInd, edgeLocWeight,
verDistance, Mate,
myRank, numProcs, C_comm,
msgIndSent, msgActualSent, msgPercent,
ph0_time, ph1_time, ph2_time,
ph1_card, ph2_card );
verLocPtr, verLocInd, edgeLocWeight,
verDistance, Mate,
myRank, numProcs, C_comm,
msgIndSent, msgActualSent, msgPercent,
ph0_time, ph1_time, ph2_time,
ph1_card, ph2_card );
#endif
}
#endif
#ifdef __cplusplus
}
#endif
+243 -415
View File
@@ -59,14 +59,7 @@
#include <assert.h>
#include <map>
#include <vector>
#include "amg_config.h"
#if !defined(PSB_SERIAL_MPI)
#ifdef PSB_OPENMP
// OpenMP is included and used if and only if the OpenMP version of the matching
// is required
#include "omp.h"
#endif
#include "primitiveDataTypeDefinitions.h"
#include "dataStrStaticQueue.h"
@@ -85,7 +78,6 @@ const int BundleTag = 9; // Predefined tag
static vector<MilanLongInt> DEFAULT_VECTOR;
// MPI type map
template <typename T>
MPI_Datatype TypeMap();
@@ -103,6 +95,7 @@ extern "C"
{
#endif
#if !defined(SERIAL_MPI)
#define MilanMpiLongInt MPI_LONG_LONG
@@ -117,7 +110,7 @@ extern "C"
// Regular long integer:
#ifndef LONG_INT_H
#define LONG_INT_H
#ifdef AMG_MATCHBOXP_BIT64
#ifdef BIT64
typedef int64_t MilanLongInt;
typedef MPI_LONG MilanMpiLongInt;
#else
@@ -163,7 +156,7 @@ extern "C"
#define MilanIntMax INT32_MAX
#define MilanIntMin INT32_MIN
#ifdef AMG_MATCHBOXP_BIT64
#ifdef BIT64
#define MilanLongIntMax INT64_MAX
#define MilanLongIntMin -INT64_MAX
#else
@@ -181,416 +174,252 @@ extern "C"
#define MilanRealMin MINUS_INFINITY
#endif
/* These functions are only used in the experimental OMP implementation, if that
is disabled there is no reason to actually compile or reference them. */
// Function of find the owner of a ghost vertex using binary search:
MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
MilanInt myRank, MilanInt numProcs);
// Function of find the owner of a ghost vertex using binary search:
MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
MilanInt myRank, MilanInt numProcs);
MilanLongInt firstComputeCandidateMateD(MilanLongInt adj1,
MilanLongInt adj2,
MilanLongInt *verLocInd,
MilanReal *edgeLocWeight);
MilanLongInt firstComputeCandidateMate(MilanLongInt adj1,
MilanLongInt adj2,
MilanLongInt *verLocInd,
MilanReal *edgeLocWeight);
void queuesTransfer(vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
bool isAlreadyMatched(MilanLongInt node,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
MilanLongInt computeCandidateMateD(MilanLongInt adj1,
MilanLongInt adj2,
MilanReal *edgeLocWeight,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
void initialize(MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt StartIndex, MilanLongInt EndIndex,
MilanLongInt *numGhostEdgesPtr,
MilanLongInt *numGhostVerticesPtr,
MilanLongInt *S,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
vector<MilanLongInt> &Counter,
vector<MilanLongInt> &verGhostPtr,
vector<MilanLongInt> &verGhostInd,
vector<MilanLongInt> &tempCounter,
vector<MilanLongInt> &GMate,
vector<MilanLongInt> &Message,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
MilanLongInt *&candidateMate,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void clean(MilanLongInt NLVer,
MilanInt myRank,
MilanLongInt MessageIndex,
vector<MPI_Request> &SRequest,
vector<MPI_Status> &SStatus,
MilanInt BufferSize,
MilanLongInt *Buffer,
MilanLongInt msgActual,
MilanLongInt *msgActualSent,
MilanLongInt msgInd,
MilanLongInt *msgIndSent,
MilanLongInt NumMessagesBundled,
MilanReal *msgPercent);
void PARALLEL_COMPUTE_CANDIDATE_MATE_BD(MilanLongInt NLVer,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanInt myRank,
MilanReal *edgeLocWeight,
MilanLongInt *candidateMate);
void PARALLEL_PROCESS_EXPOSED_VERTEX_BD(MilanLongInt NLVer,
MilanLongInt *candidateMate,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *Mate,
vector<MilanLongInt> &GMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void PROCESS_CROSS_EDGE(MilanLongInt *edge,
MilanLongInt *SPtr);
void processMatchedVerticesD(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void processMatchedVerticesAndSendMessagesD(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner,
MPI_Comm comm,
MilanLongInt *msgActual,
vector<MilanLongInt> &Message);
void sendBundledMessages(MilanLongInt *numGhostEdgesPtr,
MilanInt *BufferSizePtr,
MilanLongInt *Buffer,
vector<MilanLongInt> &PCumulative,
vector<MilanLongInt> &PMessageBundle,
vector<MilanLongInt> &PSizeInfoMessages,
MilanLongInt *PCounter,
MilanLongInt NumMessagesBundled,
MilanLongInt *msgActualPtr,
MilanLongInt *MessageIndexPtr,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MPI_Request> &SRequest,
vector<MPI_Status> &SStatus);
void processMessagesD(
MilanLongInt NLVer,
MilanLongInt *Mate,
MilanLongInt *candidateMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
vector<MilanLongInt> &GMate,
vector<MilanLongInt> &Counter,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *msgActualPtr,
MilanReal *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *verLocPtr,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &Message,
MilanLongInt numGhostEdges,
MilanLongInt u,
MilanLongInt v,
MilanLongInt *SPtr,
vector<MilanLongInt> &U);
void extractUChunk(
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU);
void queuesTransfer(vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
MilanLongInt firstComputeCandidateMateS(MilanLongInt adj1,
MilanLongInt adj2,
MilanLongInt *verLocInd,
MilanFloat *edgeLocWeight);
bool isAlreadyMatched(MilanLongInt node,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
MilanLongInt computeCandidateMateS(MilanLongInt adj1,
MilanLongInt adj2,
MilanFloat *edgeLocWeight,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
void PARALLEL_COMPUTE_CANDIDATE_MATE_BS(MilanLongInt NLVer,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanInt myRank,
MilanFloat *edgeLocWeight,
MilanLongInt *candidateMate);
void PARALLEL_PROCESS_EXPOSED_VERTEX_BS(MilanLongInt NLVer,
MilanLongInt *candidateMate,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *Mate,
vector<MilanLongInt> &GMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanFloat *edgeLocWeight,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void processMatchedVerticesS(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanFloat *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void processMatchedVerticesAndSendMessagesS(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanFloat *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner,
MPI_Comm comm,
MilanLongInt *msgActual,
vector<MilanLongInt> &Message);
void processMessagesS(
MilanLongInt NLVer,
MilanLongInt *Mate,
MilanLongInt *candidateMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
vector<MilanLongInt> &GMate,
vector<MilanLongInt> &Counter,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *msgActualPtr,
MilanFloat *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *verLocPtr,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &Message,
MilanLongInt numGhostEdges,
MilanLongInt u,
MilanLongInt v,
MilanLongInt *SPtr,
vector<MilanLongInt> &U);
void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanReal *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
MilanLongInt computeCandidateMate(MilanLongInt adj1,
MilanLongInt adj2,
MilanReal *edgeLocWeight,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
void salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanFloat *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
void initialize(MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt StartIndex, MilanLongInt EndIndex,
MilanLongInt *numGhostEdgesPtr,
MilanLongInt *numGhostVerticesPtr,
MilanLongInt *S,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
vector<MilanLongInt> &Counter,
vector<MilanLongInt> &verGhostPtr,
vector<MilanLongInt> &verGhostInd,
vector<MilanLongInt> &tempCounter,
vector<MilanLongInt> &GMate,
vector<MilanLongInt> &Message,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
MilanLongInt *&candidateMate,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void clean(MilanLongInt NLVer,
MilanInt myRank,
MilanLongInt MessageIndex,
vector<MPI_Request> &SRequest,
vector<MPI_Status> &SStatus,
MilanInt BufferSize,
MilanLongInt *Buffer,
MilanLongInt msgActual,
MilanLongInt *msgActualSent,
MilanLongInt msgInd,
MilanLongInt *msgIndSent,
MilanLongInt NumMessagesBundled,
MilanReal *msgPercent);
void PARALLEL_COMPUTE_CANDIDATE_MATE_B(MilanLongInt NLVer,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanInt myRank,
MilanReal *edgeLocWeight,
MilanLongInt *candidateMate);
void PARALLEL_PROCESS_EXPOSED_VERTEX_B(MilanLongInt NLVer,
MilanLongInt *candidateMate,
MilanLongInt *verLocInd,
MilanLongInt *verLocPtr,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *Mate,
vector<MilanLongInt> &GMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void PROCESS_CROSS_EDGE(MilanLongInt *edge,
MilanLongInt *SPtr);
void processMatchedVertices(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner);
void processMatchedVerticesAndSendMessages(
MilanLongInt NLVer,
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *NumMessagesBundledPtr,
MilanLongInt *SPtr,
MilanLongInt *verLocPtr,
MilanLongInt *verLocInd,
MilanLongInt *verDistance,
MilanLongInt *PCounter,
vector<MilanLongInt> &Counter,
MilanInt myRank,
MilanInt numProcs,
MilanLongInt *candidateMate,
vector<MilanLongInt> &GMate,
MilanLongInt *Mate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
MilanReal *edgeLocWeight,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MilanLongInt> &privateQLocalVtx,
vector<MilanLongInt> &privateQGhostVtx,
vector<MilanLongInt> &privateQMsgType,
vector<MilanInt> &privateQOwner,
MPI_Comm comm,
MilanLongInt *msgActual,
vector<MilanLongInt> &Message);
void sendBundledMessages(MilanLongInt *numGhostEdgesPtr,
MilanInt *BufferSizePtr,
MilanLongInt *Buffer,
vector<MilanLongInt> &PCumulative,
vector<MilanLongInt> &PMessageBundle,
vector<MilanLongInt> &PSizeInfoMessages,
MilanLongInt *PCounter,
MilanLongInt NumMessagesBundled,
MilanLongInt *msgActualPtr,
MilanLongInt *MessageIndexPtr,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &QLocalVtx,
vector<MilanLongInt> &QGhostVtx,
vector<MilanLongInt> &QMsgType,
vector<MilanInt> &QOwner,
vector<MPI_Request> &SRequest,
vector<MPI_Status> &SStatus);
void processMessages(
MilanLongInt NLVer,
MilanLongInt *Mate,
MilanLongInt *candidateMate,
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
vector<MilanLongInt> &GMate,
vector<MilanLongInt> &Counter,
MilanLongInt StartIndex,
MilanLongInt EndIndex,
MilanLongInt *myCardPtr,
MilanLongInt *msgIndPtr,
MilanLongInt *msgActualPtr,
MilanReal *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *verLocPtr,
MilanLongInt k,
MilanLongInt *verLocInd,
MilanInt numProcs,
MilanInt myRank,
MPI_Comm comm,
vector<MilanLongInt> &Message,
MilanLongInt numGhostEdges,
MilanLongInt u,
MilanLongInt v,
MilanLongInt *SPtr,
vector<MilanLongInt> &U);
void extractUChunk(
vector<MilanLongInt> &UChunkBeingProcessed,
vector<MilanLongInt> &U,
vector<MilanLongInt> &privateU);
void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanReal *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
MilanLongInt NLVer, MilanLongInt NLEdge,
@@ -630,9 +459,8 @@ is disabled there is no reason to actually compile or reference them. */
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
#endif
#ifdef __cplusplus
}
#endif
#endif
#endif
-504
View File
@@ -1,504 +0,0 @@
/*
AMG4PSBLAS version 1.2
Algebraic Multigrid Package
based on PSBLAS (Parallel Sparse BLAS version 3.9)
(C) Copyright 2021
Salvatore Filippone
Pasqua D'Ambra
Fabio Durastante
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions, and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The name of the AMG4PSBLAS group or the names of its contributors may
not be used to endorse or promote products derived from this
software without specific written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
Includes material from BootCMatch, see copyright below.
*/
/*
BootCMatch
Bootstrap AMG based on Compatible weighted Matching, version 0.9
(C) Copyright 2017
Pasqua D'Ambra IAC-CNR, IT
Panayot S. Vassilevski Portland State University, OR USA
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions, and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The name of the BootCMatch group or the names of its contributors may
not be used to endorse or promote products derived from this
software without specific written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE BootCMatch GROUP OR ITS CONTRIBUTORS
BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#include "amg_config.h"
#if defined(PSB_SERIAL_MPI)
#include <stdlib.h>
#include "psb_types.h"
psb_l_t d_trymatch(psb_l_t rowindex, psb_l_t colindex,
psb_l_t nrows_W, psb_l_t *W_i, psb_l_t *W_j, psb_d_t *W_data,
psb_l_t *jrowindex, psb_l_t ljrowindex,
psb_l_t *jcolindex, psb_l_t ljcolindex, psb_l_t *rmatch)
{
psb_l_t tryrowmatch, trycolmatch;
psb_l_t i, j, k, nzrow_W, startj, kindex;
psb_d_t cweight, nweight;
// psb_l_t *W_i = bcm_CSRMatrixI(W);
// psb_l_t *W_j = bcm_CSRMatrixJ(W);
// psb_l_t nrows_W = bcm_CSRMatrixNumRows(W);
// psb_d_t *W_data=bcm_CSRMatrixData(W);
k=-1;
i=0;
while (i<ljrowindex && k ==-1)
{
if(jrowindex[i]==colindex) k=i;
i++;
}
if(k >= 0)
{
ljrowindex=ljrowindex-1;
for(i=k; i<ljrowindex; ++i) jrowindex[i]=jrowindex[i+1];
}
k=-1;
i=0;
while(i<ljcolindex && k==-1)
{
if(jcolindex[i]==rowindex) k=i;
i++;
}
if(k >= 0)
{
ljcolindex=ljcolindex-1;
for(i=k; i<ljcolindex; ++i) jcolindex[i]=jcolindex[i+1];
}
nzrow_W=W_i[rowindex+1]-W_i[rowindex];
startj=W_i[rowindex];
kindex=-1;
k=0;
while(k<nzrow_W && kindex==-1)
{
if(W_j[startj+k]==colindex) kindex=startj+k;
k++;
}
cweight=W_data[kindex];
while((rmatch[rowindex]==-1 && rmatch[colindex]==-1)
&& (ljrowindex !=0 || ljcolindex !=0))
{
if (rmatch[rowindex] == -1 && ljrowindex !=0)
{
tryrowmatch=jrowindex[0];
nzrow_W=W_i[rowindex+1]-W_i[rowindex];
startj=W_i[rowindex];
k=0;
kindex=-1;
while(k<nzrow_W && kindex==-1)
{
if(W_j[startj+k]==tryrowmatch) kindex=startj+k;
k++;
}
nweight=W_data[kindex];
ljrowindex=ljrowindex-1;
for(i=0; i<ljrowindex; ++i) jrowindex[i]=jrowindex[i+1];
if(nweight > cweight && rmatch[tryrowmatch]==-1)
{
nzrow_W=W_i[tryrowmatch+1]-W_i[tryrowmatch];
psb_l_t *trymatchindexrow;
trymatchindexrow= (psb_l_t *) calloc(nzrow_W, sizeof(psb_l_t));
startj=W_i[tryrowmatch];
for(k=0; k<nzrow_W; ++k) trymatchindexrow[k]=W_j[startj+k];
d_trymatch(rowindex,tryrowmatch,
nrows_W, W_i, W_j, W_data,
jrowindex,ljrowindex,
trymatchindexrow,nzrow_W,rmatch);
free(trymatchindexrow);
}
}
if(rmatch[colindex]==-1 && ljcolindex!=0)
{
trycolmatch=jcolindex[0];
nzrow_W=W_i[colindex+1]-W_i[colindex];
startj=W_i[colindex];
k=0;
kindex=-1;
while(k<nzrow_W && kindex==-1)
{
if(W_j[startj+k]==trycolmatch) kindex=startj+k;
k++;
}
nweight=W_data[kindex];
ljcolindex=ljcolindex-1;
for(i=0; i<ljcolindex; ++i) jcolindex[i]=jcolindex[i+1];
if(nweight > cweight && rmatch[trycolmatch]==-1)
{
nzrow_W=W_i[trycolmatch+1]-W_i[trycolmatch];
psb_l_t *trymatchindexcol;
trymatchindexcol= (psb_l_t *) calloc(nzrow_W, sizeof(psb_l_t));
startj=W_i[trycolmatch];
for(k=0; k<nzrow_W; ++k) trymatchindexcol[k]=W_j[startj+k];
d_trymatch(colindex,trycolmatch,
nrows_W, W_i, W_j, W_data,
jcolindex,ljcolindex,
trymatchindexcol,nzrow_W,rmatch);
free(trymatchindexcol);
}
}
}
if(rmatch[rowindex]==-1 & rmatch[colindex]==-1)
{
rmatch[rowindex]=colindex;
rmatch[colindex]=rowindex;
}
return 0;
}
psb_l_t *d_CSRMatrixHMatch( psb_l_t nrows_B, psb_l_t ncols_B,
psb_l_t nnz_B, psb_l_t *B_i,
psb_l_t *B_j, psb_d_t *B_data)
{
psb_l_t i, j, k, *rmatch;
psb_d_t *c, alpha;
psb_l_t jbp, nzrows_B;
psb_d_t tmp=0.0;
psb_l_t rno, cno, nzrows_cno, startj, ljrowindex, ljjrowindex;
psb_l_t *jrowindex, *jjrowindex;
#if 0
psb_l_t *B_i = bcm_CSRMatrixI(B);
psb_l_t *B_j = bcm_CSRMatrixJ(B);
psb_d_t *B_data = bcm_CSRMatrixData(B);
psb_l_t nrows_B = bcm_CSRMatrixNumRows(B);
psb_l_t ncols_B = bcm_CSRMatrixNumCols(B);
psb_l_t nnz_B = bcm_CSRMatrixNumNonzeros(B);
#endif
// assert(nrows_B==ncols_B);
rmatch = (psb_l_t *) calloc(nrows_B, sizeof(psb_l_t));
for(i=0; i<nrows_B; ++i) rmatch[i]=-1;
jrowindex = (psb_l_t *) calloc(nrows_B, sizeof(psb_l_t));
jjrowindex = (psb_l_t *) calloc(nrows_B, sizeof(psb_l_t));
jbp=0;
for(i=0; i< nrows_B; ++i)
{
nzrows_B=B_i[i+1]-B_i[i];
for(j=0; j<nzrows_B; ++j) jrowindex[j]=B_j[jbp+j];
for(j=0; j<nzrows_B; ++j)
{
rno=i;
cno=B_j[jbp+j];
startj=B_i[cno];
nzrows_cno=B_i[cno+1]-startj;
for(k=0; k<nzrows_cno; ++k) jjrowindex[k]=B_j[startj+k];
if(rmatch[rno] == -1 && rmatch[cno] == -1)
d_trymatch(rno,cno,nrows_B,B_i,B_j,B_data,
jrowindex,nzrows_B,jjrowindex,nzrows_cno,rmatch);
}
jbp=jbp+nzrows_B;
}
free(jrowindex);
free(jjrowindex);
return rmatch;
}
void dMatching(psb_l_t NLVer, psb_l_t NLEdge,
psb_l_t *verLocPtr, psb_l_t *verLocInd, psb_d_t *edgeLocWeight,
psb_l_t *verDistance, psb_l_t *Mate)
{
psb_l_t *lmate;
lmate = d_CSRMatrixHMatch( NLVer, NLVer, NLEdge,
verLocPtr, verLocInd,edgeLocWeight);
for (psb_l_t i=0; i<NLVer; i++){
Mate[i] = lmate[i];
}
free(lmate);
return;
}
psb_l_t s_trymatch(psb_l_t rowindex, psb_l_t colindex,
psb_l_t nrows_W, psb_l_t *W_i, psb_l_t *W_j, psb_s_t *W_data,
psb_l_t *jrowindex, psb_l_t ljrowindex,
psb_l_t *jcolindex, psb_l_t ljcolindex, psb_l_t *rmatch)
{
psb_l_t tryrowmatch, trycolmatch;
psb_l_t i, j, k, nzrow_W, startj, kindex;
psb_s_t cweight, nweight;
// psb_l_t *W_i = bcm_CSRMatrixI(W);
// psb_l_t *W_j = bcm_CSRMatrixJ(W);
// psb_l_t nrows_W = bcm_CSRMatrixNumRows(W);
// psb_s_t *W_data=bcm_CSRMatrixData(W);
k=-1;
i=0;
while (i<ljrowindex && k ==-1)
{
if(jrowindex[i]==colindex) k=i;
i++;
}
if(k >= 0)
{
ljrowindex=ljrowindex-1;
for(i=k; i<ljrowindex; ++i) jrowindex[i]=jrowindex[i+1];
}
k=-1;
i=0;
while(i<ljcolindex && k==-1)
{
if(jcolindex[i]==rowindex) k=i;
i++;
}
if(k >= 0)
{
ljcolindex=ljcolindex-1;
for(i=k; i<ljcolindex; ++i) jcolindex[i]=jcolindex[i+1];
}
nzrow_W=W_i[rowindex+1]-W_i[rowindex];
startj=W_i[rowindex];
kindex=-1;
k=0;
while(k<nzrow_W && kindex==-1)
{
if(W_j[startj+k]==colindex) kindex=startj+k;
k++;
}
cweight=W_data[kindex];
while((rmatch[rowindex]==-1 && rmatch[colindex]==-1)
&& (ljrowindex !=0 || ljcolindex !=0))
{
if (rmatch[rowindex] == -1 && ljrowindex !=0)
{
tryrowmatch=jrowindex[0];
nzrow_W=W_i[rowindex+1]-W_i[rowindex];
startj=W_i[rowindex];
k=0;
kindex=-1;
while(k<nzrow_W && kindex==-1)
{
if(W_j[startj+k]==tryrowmatch) kindex=startj+k;
k++;
}
nweight=W_data[kindex];
ljrowindex=ljrowindex-1;
for(i=0; i<ljrowindex; ++i) jrowindex[i]=jrowindex[i+1];
if(nweight > cweight && rmatch[tryrowmatch]==-1)
{
nzrow_W=W_i[tryrowmatch+1]-W_i[tryrowmatch];
psb_l_t *trymatchindexrow;
trymatchindexrow= (psb_l_t *) calloc(nzrow_W, sizeof(psb_l_t));
startj=W_i[tryrowmatch];
for(k=0; k<nzrow_W; ++k) trymatchindexrow[k]=W_j[startj+k];
s_trymatch(rowindex,tryrowmatch,
nrows_W, W_i, W_j, W_data,
jrowindex,ljrowindex,
trymatchindexrow,nzrow_W,rmatch);
free(trymatchindexrow);
}
}
if(rmatch[colindex]==-1 && ljcolindex!=0)
{
trycolmatch=jcolindex[0];
nzrow_W=W_i[colindex+1]-W_i[colindex];
startj=W_i[colindex];
k=0;
kindex=-1;
while(k<nzrow_W && kindex==-1)
{
if(W_j[startj+k]==trycolmatch) kindex=startj+k;
k++;
}
nweight=W_data[kindex];
ljcolindex=ljcolindex-1;
for(i=0; i<ljcolindex; ++i) jcolindex[i]=jcolindex[i+1];
if(nweight > cweight && rmatch[trycolmatch]==-1)
{
nzrow_W=W_i[trycolmatch+1]-W_i[trycolmatch];
psb_l_t *trymatchindexcol;
trymatchindexcol= (psb_l_t *) calloc(nzrow_W, sizeof(psb_l_t));
startj=W_i[trycolmatch];
for(k=0; k<nzrow_W; ++k) trymatchindexcol[k]=W_j[startj+k];
s_trymatch(colindex,trycolmatch,
nrows_W, W_i, W_j, W_data,
jcolindex,ljcolindex,
trymatchindexcol,nzrow_W,rmatch);
free(trymatchindexcol);
}
}
}
if(rmatch[rowindex]==-1 & rmatch[colindex]==-1)
{
rmatch[rowindex]=colindex;
rmatch[colindex]=rowindex;
}
return 0;
}
psb_l_t *s_CSRMatrixHMatch( psb_l_t nrows_B, psb_l_t ncols_B,
psb_l_t nnz_B, psb_l_t *B_i,
psb_l_t *B_j, psb_s_t *B_data)
{
psb_l_t i, j, k, *rmatch;
psb_s_t *c, alpha;
psb_l_t jbp, nzrows_B;
psb_s_t tmp=0.0;
psb_l_t rno, cno, nzrows_cno, startj, ljrowindex, ljjrowindex;
psb_l_t *jrowindex, *jjrowindex;
#if 0
psb_l_t *B_i = bcm_CSRMatrixI(B);
psb_l_t *B_j = bcm_CSRMatrixJ(B);
psb_s_t *B_data = bcm_CSRMatrixData(B);
psb_l_t nrows_B = bcm_CSRMatrixNumRows(B);
psb_l_t ncols_B = bcm_CSRMatrixNumCols(B);
psb_l_t nnz_B = bcm_CSRMatrixNumNonzeros(B);
#endif
// assert(nrows_B==ncols_B);
rmatch = (psb_l_t *) calloc(nrows_B, sizeof(psb_l_t));
for(i=0; i<nrows_B; ++i) rmatch[i]=-1;
jrowindex = (psb_l_t *) calloc(nrows_B, sizeof(psb_l_t));
jjrowindex = (psb_l_t *) calloc(nrows_B, sizeof(psb_l_t));
jbp=0;
for(i=0; i< nrows_B; ++i)
{
nzrows_B=B_i[i+1]-B_i[i];
for(j=0; j<nzrows_B; ++j) jrowindex[j]=B_j[jbp+j];
for(j=0; j<nzrows_B; ++j)
{
rno=i;
cno=B_j[jbp+j];
startj=B_i[cno];
nzrows_cno=B_i[cno+1]-startj;
for(k=0; k<nzrows_cno; ++k) jjrowindex[k]=B_j[startj+k];
if(rmatch[rno] == -1 && rmatch[cno] == -1)
s_trymatch(rno,cno,nrows_B,B_i,B_j,B_data,
jrowindex,nzrows_B,jjrowindex,nzrows_cno,rmatch);
}
jbp=jbp+nzrows_B;
}
free(jrowindex);
free(jjrowindex);
return rmatch;
}
void sMatching(psb_l_t NLVer, psb_l_t NLEdge,
psb_l_t *verLocPtr, psb_l_t *verLocInd, psb_s_t *edgeLocWeight,
psb_l_t *verDistance, psb_l_t *Mate)
{
psb_l_t *lmate;
lmate = s_CSRMatrixHMatch( NLVer, NLVer, NLEdge,
verLocPtr, verLocInd,edgeLocWeight);
for (psb_l_t i=0; i<NLVer; i++){
Mate[i] = lmate[i];
}
free(lmate);
return;
}
#endif
-81
View File
@@ -1,81 +0,0 @@
/*
AMG4PSBLAS version 1.2
Algebraic Multigrid Package
based on PSBLAS (Parallel Sparse BLAS version 3.9)
(C) Copyright 2021
Salvatore Filippone
Pasqua D'Ambra
Fabio Durastante
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions, and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The name of the AMG4PSBLAS group or the names of its contributors may
not be used to endorse or promote products derived from this
software without specific written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
Includes material from BootCMatch, see copyright below.
*/
/*
BootCMatch
Bootstrap AMG based on Compatible weighted Matching, version 0.9
(C) Copyright 2017
Pasqua D'Ambra IAC-CNR, IT
Panayot S. Vassilevski Portland State University, OR USA
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions, and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The name of the BootCMatch group or the names of its contributors may
not be used to endorse or promote products derived from this
software without specific written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE BootCMatch GROUP OR ITS CONTRIBUTORS
BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
#include "amg_config.h"
#if defined(PSB_SERIAL_MPI)
#include "psb_types.h"
void dMatching(psb_l_t NLVer, psb_l_t NLEdge,
psb_l_t *verLocPtr, psb_l_t *verLocInd, psb_d_t *edgeLocWeight,
psb_l_t *verDistance, psb_l_t *Mate);
void sMatching(psb_l_t NLVer, psb_l_t NLEdge,
psb_l_t *verLocPtr, psb_l_t *verLocInd, psb_s_t *edgeLocWeight,
psb_l_t *verDistance, psb_l_t *Mate);
#endif
@@ -70,7 +70,7 @@
Statistics: ph1_card, ph2_card : Size: |P| number of processes in the comm-world (number of matched edges in Phase 1 and Phase 2)
*/
#ifdef PSB_SERIAL_MPI
#ifdef SERIAL_MPI
#else
// DOUBLE PRECISION VERSION
@@ -86,7 +86,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
MilanReal* msgPercent,
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
#if !defined(PSB_SERIAL_MPI)
#if !defined(SERIAL_MPI)
#ifdef PRINT_DEBUG_INFO_
cout<<"\n("<<myRank<<")Within algoEdgeApproxDominatingEdgesLinearSearchMessageBundling()"; fflush(stdout);
#endif
@@ -1303,17 +1303,17 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
// SINGLE PRECISION VERSION
void salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt* verLocPtr, MilanLongInt* verLocInd,
MilanFloat* edgeLocWeight,
MilanLongInt* verDistance,
MilanLongInt* Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent,
MilanReal* msgPercent,
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
#if !defined(PSB_SERIAL_MPI)
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt* verLocPtr, MilanLongInt* verLocInd,
MilanFloat* edgeLocWeight,
MilanLongInt* verDistance,
MilanLongInt* Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent,
MilanReal* msgPercent,
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
#if !defined(SERIAL_MPI)
#ifdef PRINT_DEBUG_INFO_
cout<<"\n("<<myRank<<")Within algoEdgeApproxDominatingEdgesLinearSearchMessageBundling()"; fflush(stdout);
#endif
@@ -1,4 +1,5 @@
#include "MatchBoxPC.h"
// ***********************************************************************
//
// MatchboxP: A C++ library for approximate weighted matching
@@ -70,7 +71,7 @@
Statistics: ph1_card, ph2_card : Size: |P| number of processes in the comm-world (number of matched edges in Phase 1 and Phase 2)
*/
//#define DEBUG_HANG_
#ifdef PSB_SERIAL_MPI
#ifdef SERIAL_MPI
#else
// DOUBLE PRECISION VERSION
@@ -102,7 +103,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
* i+1-th value is the position of the first element on the i+1-th row
*/
#if !defined(PSB_SERIAL_MPI)
#if !defined(SERIAL_MPI)
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Within algoEdgeApproxDominatingEdgesLinearSearchMessageBundling()";
fflush(stdout);
@@ -125,10 +126,8 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
fflush(stdout);
#endif
// The starting vertex owned by the current rank
MilanLongInt StartIndex = verDistance[myRank];
// The ending vertex owned by the current rank
MilanLongInt EndIndex = verDistance[myRank + 1] - 1;
MilanLongInt StartIndex = verDistance[myRank]; // The starting vertex owned by the current rank
MilanLongInt EndIndex = verDistance[myRank + 1] - 1; // The ending vertex owned by the current rank
MPI_Status computeStatus;
@@ -146,8 +145,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
// only one message will be sent in the initialization phase -
// one of: REQUEST/FAILURE/SUCCESS
vector<MilanLongInt> QLocalVtx, QGhostVtx, QMsgType;
// Changed by Fabio to be an integer, addresses needs to be integers!
vector<MilanInt> QOwner;
vector<MilanInt> QOwner; // Changed by Fabio to be an integer, addresses needs to be integers!
MilanLongInt *PCounter = new MilanLongInt[numProcs];
for (int i = 0; i < numProcs; i++)
@@ -155,8 +153,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
MilanLongInt NumMessagesBundled = 0;
// TODO when the last computational section will be refactored this could be eliminated
// Changed by Fabio to be an integer, addresses needs to be integers!
MilanInt ghostOwner = 0;
MilanInt ghostOwner = 0; // Changed by Fabio to be an integer, addresses needs to be integers!
MilanLongInt *candidateMate = nullptr;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")NV: " << NLVer << " Edges: " << NLEdge;
@@ -171,12 +168,9 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
MilanLongInt myCard = 0;
// Build the Ghost Vertex Set: Vg
// Map each ghost vertex to a local vertex
map<MilanLongInt, MilanLongInt> Ghost2LocalMap;
// Store the edge count for each ghost vertex
vector<MilanLongInt> Counter;
// Number of Ghost vertices
MilanLongInt numGhostVertices = 0, numGhostEdges = 0;
map<MilanLongInt, MilanLongInt> Ghost2LocalMap; // Map each ghost vertex to a local vertex
vector<MilanLongInt> Counter; // Store the edge count for each ghost vertex
MilanLongInt numGhostVertices = 0, numGhostEdges = 0; // Number of Ghost vertices
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")About to compute Ghost Vertices...";
@@ -228,7 +222,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
cout << myRank << " Finished initialization" << endl;
fflush(stdout);
#endif
startTime = MPI_Wtime();
/////////////////////////////////////////////////////////////////////////////////////////
@@ -243,7 +237,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
* PARALLEL_COMPUTE_CANDIDATE_MATE_B is now totally parallel.
*/
PARALLEL_COMPUTE_CANDIDATE_MATE_BD(NLVer,
PARALLEL_COMPUTE_CANDIDATE_MATE_B(NLVer,
verLocPtr,
verLocInd,
myRank,
@@ -268,7 +262,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
* TODO: Test when it's actually more efficient to execute this code
* in parallel.
*/
PARALLEL_PROCESS_EXPOSED_VERTEX_BD(NLVer,
PARALLEL_PROCESS_EXPOSED_VERTEX_B(NLVer,
candidateMate,
verLocInd,
verLocPtr,
@@ -320,7 +314,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
vector<MilanLongInt> UChunkBeingProcessed;
UChunkBeingProcessed.reserve(UCHUNK);
processMatchedVerticesD(NLVer,
processMatchedVertices(NLVer,
UChunkBeingProcessed,
U,
privateU,
@@ -397,7 +391,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
cout << myRank << " Finished sendBundles" << endl;
fflush(stdout);
#endif
*ph1_card = myCard; // Cardinality at the end of Phase-1
startTime = MPI_Wtime();
/////////////////////////////////////////////////////////////////////////////////////////
@@ -428,8 +422,8 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
///////////////////////////////////////////////////////////////////////////////////
/////////////////////////// PROCESS MATCHED VERTICES //////////////////////////////
///////////////////////////////////////////////////////////////////////////////////
processMatchedVerticesAndSendMessagesD(NLVer,
processMatchedVerticesAndSendMessages(NLVer,
UChunkBeingProcessed,
U,
privateU,
@@ -462,7 +456,7 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
comm,
&msgActual,
Message);
///////////////////////// END OF PROCESS MATCHED VERTICES /////////////////////////
//// BREAK IF NO MESSAGES EXPECTED /////////
@@ -489,8 +483,8 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
///////////////////////////////////////////////////////////////////////////////////
/////////////////////////// PROCESS MESSAGES //////////////////////////////////////
///////////////////////////////////////////////////////////////////////////////////
//startTime = MPI_Wtime();
processMessagesD(NLVer,
processMessages(NLVer,
Mate,
candidateMate,
Ghost2LocalMap,
@@ -555,489 +549,6 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
*ph2_card = myCard; // Cardinality at the end of Phase-2
}
// End of algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMate
void salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
MilanLongInt NLVer, MilanLongInt NLEdge,
MilanLongInt *verLocPtr, MilanLongInt *verLocInd,
MilanFloat *edgeLocWeight,
MilanLongInt *verDistance,
MilanLongInt *Mate,
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent,
MilanReal *msgPercent,
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
MilanLongInt *ph1_card, MilanLongInt *ph2_card)
{
/*
* verDistance: it's a vector long as the number of processors.
* verDistance[i] contains the first node index of the i-th processor
* verDistance[i + 1] contains the last node index of the i-th processor
* NLVer: number of elements in the LocPtr
* NLEdge: number of edges assigned to the current processor
*
* Contains the portion of matrix assigned to the processor in
* Yale notation
* verLocInd: contains the positions on row of the matrix
* verLocPtr: i-th value is the position of the first element on the i-th row and
* i+1-th value is the position of the first element on the i+1-th row
*/
#if !defined(PSB_SERIAL_MPI)
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Within algoEdgeApproxDominatingEdgesLinearSearchMessageBundling()";
fflush(stdout);
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ") verDistance [" ;
for (int i = 0; i < numProcs; i++)
cout << verDistance[i] << "," << verDistance[i+1];
cout << "]\n";
fflush(stdout);
#endif
#ifdef DEBUG_HANG_
if (myRank == 0) {
cout << "\n(" << myRank << ") verDistance [" ;
for (int i = 0; i < numProcs; i++)
cout << verDistance[i] << "," ;
cout << verDistance[numProcs]<< "]\n";
}
fflush(stdout);
#endif
// The starting vertex owned by the current rank
MilanLongInt StartIndex = verDistance[myRank];
// The ending vertex owned by the current rank
MilanLongInt EndIndex = verDistance[myRank + 1] - 1;
MPI_Status computeStatus;
MilanLongInt msgActual = 0, msgInd = 0;
MilanFloat heaviestEdgeWt = 0.0f; // Assumes positive weight
MilanReal startTime, finishTime;
startTime = MPI_Wtime();
// Data structures for sending and receiving messages:
vector<MilanLongInt> Message; // [ u, v, message_type ]
Message.resize(3, -1);
// Data structures for Message Bundling:
// Although up to two messages can be sent along any cross edge,
// only one message will be sent in the initialization phase -
// one of: REQUEST/FAILURE/SUCCESS
vector<MilanLongInt> QLocalVtx, QGhostVtx, QMsgType;
// Changed by Fabio to be an integer, addresses needs to be integers!
vector<MilanInt> QOwner;
MilanLongInt *PCounter = new MilanLongInt[numProcs];
for (int i = 0; i < numProcs; i++)
PCounter[i] = 0;
MilanLongInt NumMessagesBundled = 0;
// TODO when the last computational section will be refactored this could be eliminated
// Changed by Fabio to be an integer, addresses needs to be integers!
MilanInt ghostOwner = 0;
MilanLongInt *candidateMate = nullptr;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")NV: " << NLVer << " Edges: " << NLEdge;
fflush(stdout);
cout << "\n(" << myRank << ")StartIndex: " << StartIndex << " EndIndex: " << EndIndex;
fflush(stdout);
#endif
// Other Variables:
MilanLongInt u = -1, v = -1, w = -1, i = 0;
MilanLongInt k = -1, adj1 = -1, adj2 = -1;
MilanLongInt k1 = -1, adj11 = -1, adj12 = -1;
MilanLongInt myCard = 0;
// Build the Ghost Vertex Set: Vg
// Map each ghost vertex to a local vertex
map<MilanLongInt, MilanLongInt> Ghost2LocalMap;
// Store the edge count for each ghost vertex
vector<MilanLongInt> Counter;
// Number of Ghost vertices
MilanLongInt numGhostVertices = 0, numGhostEdges = 0;
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")About to compute Ghost Vertices...";
fflush(stdout);
#endif
#ifdef DEBUG_HANG_
if (myRank == 0)
cout << "\n(" << myRank << ")About to compute Ghost Vertices...";
fflush(stdout);
#endif
// Define Adjacency Lists for Ghost Vertices:
// cout<<"Building Ghost data structures ... \n\n";
vector<MilanLongInt> verGhostPtr, verGhostInd, tempCounter;
// Mate array for ghost vertices:
vector<MilanLongInt> GMate; // Proportional to the number of ghost vertices
MilanLongInt S;
MilanLongInt privateMyCard = 0;
vector<MilanLongInt> PCumulative, PMessageBundle, PSizeInfoMessages;
vector<MPI_Request> SRequest; // Requests that are used for each send message
vector<MPI_Status> SStatus; // Status of sent messages, used in MPI_Wait
MilanLongInt MessageIndex = 0; // Pointer for current message
MilanInt BufferSize;
MilanLongInt *Buffer;
vector<MilanLongInt> privateQLocalVtx, privateQGhostVtx, privateQMsgType;
vector<MilanInt> privateQOwner;
vector<MilanLongInt> U, privateU;
initialize(NLVer, NLEdge, StartIndex,
EndIndex, &numGhostEdges,
&numGhostVertices, &S,
verLocInd, verLocPtr,
Ghost2LocalMap, Counter,
verGhostPtr, verGhostInd,
tempCounter, GMate,
Message, QLocalVtx,
QGhostVtx, QMsgType, QOwner,
candidateMate, U,
privateU,
privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner);
finishTime = MPI_Wtime();
*ph0_time = finishTime - startTime; // Time taken for Phase-0: Initialization
#ifdef DEBUG_HANG_
cout << myRank << " Finished initialization" << endl;
fflush(stdout);
#endif
startTime = MPI_Wtime();
/////////////////////////////////////////////////////////////////////////////////////////
//////////////////////////////////// INITIALIZATION /////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////
// Compute the Initial Matching Set:
/*
* OMP PARALLEL_COMPUTE_CANDIDATE_MATE_B has been splitted from
* PARALLEL_PROCESS_EXPOSED_VERTEX_B in order to better parallelize
* the two.
* PARALLEL_COMPUTE_CANDIDATE_MATE_B is now totally parallel.
*/
PARALLEL_COMPUTE_CANDIDATE_MATE_BS(NLVer,
verLocPtr,
verLocInd,
myRank,
edgeLocWeight,
candidateMate);
#ifdef DEBUG_HANG_
cout << myRank << " Finished Exposed Vertex" << endl;
fflush(stdout);
#if 0
cout << myRank << " candidateMate after parallelCompute " <<endl;
for (int i=0; i<NLVer; i++) {
cout << candidateMate[i] << " " ;
}
cout << endl;
#endif
#endif
/*
* PARALLEL_PROCESS_EXPOSED_VERTEX_B
* TODO: write comment
*
* TODO: Test when it's actually more efficient to execute this code
* in parallel.
*/
PARALLEL_PROCESS_EXPOSED_VERTEX_BS(NLVer,
candidateMate,
verLocInd,
verLocPtr,
StartIndex,
EndIndex,
Mate,
GMate,
Ghost2LocalMap,
edgeLocWeight,
&myCard,
&msgInd,
&NumMessagesBundled,
&S,
verDistance,
PCounter,
Counter,
myRank,
numProcs,
U,
privateU,
QLocalVtx,
QGhostVtx,
QMsgType,
QOwner,
privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner);
tempCounter.clear(); // Do not need this any more
#ifdef DEBUG_HANG_
cout << myRank << " Finished Exposed Vertex" << endl;
fflush(stdout);
#if 0
cout << myRank << " Mate after Exposed Vertices " <<endl;
for (int i=0; i<NLVer; i++) {
cout << Mate[i] << " " ;
}
cout << endl;
#endif
#endif
///////////////////////////////////////////////////////////////////////////////////
/////////////////////////// PROCESS MATCHED VERTICES //////////////////////////////
///////////////////////////////////////////////////////////////////////////////////
// TODO what would be the optimal UCHUNK
vector<MilanLongInt> UChunkBeingProcessed;
UChunkBeingProcessed.reserve(UCHUNK);
processMatchedVerticesS(NLVer,
UChunkBeingProcessed,
U,
privateU,
StartIndex,
EndIndex,
&myCard,
&msgInd,
&NumMessagesBundled,
&S,
verLocPtr,
verLocInd,
verDistance,
PCounter,
Counter,
myRank,
numProcs,
candidateMate,
GMate,
Mate,
Ghost2LocalMap,
edgeLocWeight,
QLocalVtx,
QGhostVtx,
QMsgType,
QOwner,
privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner);
#ifdef DEBUG_HANG_
cout << myRank << " Finished Process Vertices" << endl;
fflush(stdout);
#if 0
cout << myRank << " Mate after Matched Vertices " <<endl;
for (int i=0; i<NLVer; i++) {
cout << Mate[i] << " " ;
}
cout << endl;
#endif
#endif
/////////////////////////////////////////////////////////////////////////////////////////
///////////////////////////// SEND BUNDLED MESSAGES /////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////
sendBundledMessages(&numGhostEdges,
&BufferSize,
Buffer,
PCumulative,
PMessageBundle,
PSizeInfoMessages,
PCounter,
NumMessagesBundled,
&msgActual,
&MessageIndex,
numProcs,
myRank,
comm,
QLocalVtx,
QGhostVtx,
QMsgType,
QOwner,
SRequest,
SStatus);
///////////////////////// END OF SEND BUNDLED MESSAGES //////////////////////////////////
finishTime = MPI_Wtime();
*ph1_time = finishTime - startTime; // Time taken for Phase-1
#ifdef DEBUG_HANG_
cout << myRank << " Finished sendBundles" << endl;
fflush(stdout);
#endif
*ph1_card = myCard; // Cardinality at the end of Phase-1
startTime = MPI_Wtime();
/////////////////////////////////////////////////////////////////////////////////////////
//////////////////////////////////////// MAIN LOOP //////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////
// Main While Loop:
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << "=========================************===============================" << endl;
fflush(stdout);
fflush(stdout);
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Entering While(true) loop..";
fflush(stdout);
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << "=========================************===============================" << endl;
fflush(stdout);
fflush(stdout);
#endif
while (true) {
#ifdef DEBUG_HANG_
//if (myRank == 0)
cout << "\n(" << myRank << ") Main loop" << endl;
fflush(stdout);
#endif
///////////////////////////////////////////////////////////////////////////////////
/////////////////////////// PROCESS MATCHED VERTICES //////////////////////////////
///////////////////////////////////////////////////////////////////////////////////
processMatchedVerticesAndSendMessagesS(NLVer,
UChunkBeingProcessed,
U,
privateU,
StartIndex,
EndIndex,
&myCard,
&msgInd,
&NumMessagesBundled,
&S,
verLocPtr,
verLocInd,
verDistance,
PCounter,
Counter,
myRank,
numProcs,
candidateMate,
GMate,
Mate,
Ghost2LocalMap,
edgeLocWeight,
QLocalVtx,
QGhostVtx,
QMsgType,
QOwner,
privateQLocalVtx,
privateQGhostVtx,
privateQMsgType,
privateQOwner,
comm,
&msgActual,
Message);
///////////////////////// END OF PROCESS MATCHED VERTICES /////////////////////////
//// BREAK IF NO MESSAGES EXPECTED /////////
#ifdef DEBUG_HANG_
#if 0
cout << myRank << " Mate after ProcessMatchedAndSend phase "<<S <<endl;
for (int i=0; i<NLVer; i++) {
cout << Mate[i] << " " ;
}
cout << endl;
#endif
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Deciding whether to break: S= " << S << endl;
#endif
if (S == 0) {
#ifdef DEBUG_HANG_
cout << "\n(" << myRank << ") Breaking out" << endl;
fflush(stdout);
#endif
break;
}
///////////////////////////////////////////////////////////////////////////////////
/////////////////////////// PROCESS MESSAGES //////////////////////////////////////
///////////////////////////////////////////////////////////////////////////////////
processMessagesS(NLVer,
Mate,
candidateMate,
Ghost2LocalMap,
GMate,
Counter,
StartIndex,
EndIndex,
&myCard,
&msgInd,
&msgActual,
edgeLocWeight,
verDistance,
verLocPtr,
k,
verLocInd,
numProcs,
myRank,
comm,
Message,
numGhostEdges,
u,
v,
&S,
U);
///////////////////////// END OF PROCESS MESSAGES /////////////////////////////////
#ifdef DEBUG_HANG_
#if 0
cout << myRank << " Mate after ProcessMessages phase "<<S <<endl;
for (int i=0; i<NLVer; i++) {
cout << Mate[i] << " " ;
}
cout << endl;
#endif
#endif
#ifdef PRINT_DEBUG_INFO_
cout << "\n(" << myRank << ")Finished Message processing phase: S= " << S;
fflush(stdout);
cout << "\n(" << myRank << ")** SENT : ACTUAL= " << msgActual;
fflush(stdout);
cout << "\n(" << myRank << ")** SENT : INDIVIDUAL= " << msgInd << endl;
fflush(stdout);
#endif
} // End of while (true)
clean(NLVer,
myRank,
MessageIndex,
SRequest,
SStatus,
BufferSize,
Buffer,
msgActual,
msgActualSent,
msgInd,
msgIndSent,
NumMessagesBundled,
msgPercent);
finishTime = MPI_Wtime();
*ph2_time = finishTime - startTime; // Time taken for Phase-2
*ph2_card = myCard; // Cardinality at the end of Phase-2
}
#endif
#endif
#endif
@@ -177,24 +177,23 @@ subroutine amg_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,&
select case (parms%aggr_prol)
case (amg_no_smooth_)
call amg_caggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,&
nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
call amg_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,&
& parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
case(amg_smooth_prol_,amg_l1_smooth_prol_)
case(amg_smooth_prol_)
call amg_caggrmat_smth_bld(parms%aggr_prol,a,desc_a,&
ilaggr,nlaggr,parms,ac,desc_ac,op_prol,&
op_restr,t_prol,info)
call amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr, &
& parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
!!$ case(amg_biz_prol_)
!!$
!!$ call amg_caggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, &
!!$ & parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
case(amg_min_energy_)
call amg_caggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,&
nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
call amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr, &
& parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
case default
info = psb_err_internal_error_
+14 -23
View File
@@ -76,7 +76,7 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
integer(psb_lpk_) :: nrsave, ncsave, nzsave, nza
logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.
integer(psb_ipk_), save :: idx_spspmm=-1, idx_cpytrans1=-1, idx_cpytrans2=-1
integer(psb_ipk_), save :: idx_spspmm=-1
name='amg_ptap_bld'
if(psb_get_errstatus().ne.0) return
@@ -93,11 +93,7 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
ncol = desc_a%get_local_cols()
if ((do_timings).and.(idx_spspmm==-1)) &
& idx_spspmm = psb_get_timer_idx("PTAP_BLD: par_spspmm")
if ((do_timings).and.(idx_cpytrans1==-1)) &
& idx_cpytrans1 = psb_get_timer_idx("PTAP_BLD: cpy&trans1")
if ((do_timings).and.(idx_cpytrans2==-1)) &
& idx_cpytrans2 = psb_get_timer_idx("PTAP_BLD: cpy&trans2")
& idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
@@ -132,7 +128,6 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
! Ok first product done.
if (present(desc_ax)) then
if (do_timings) call psb_tic(idx_cpytrans1)
block
call coo_prol%cp_to_coo(coo_restr,info)
call coo_restr%set_ncols(desc_ac%get_local_cols())
@@ -142,7 +137,7 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
call coo_restr%set_ncols(desc_ax%get_local_cols())
end block
call csr_restr%cp_from_coo(coo_restr,info)
if (do_timings) call psb_toc(idx_cpytrans1)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
goto 9999
@@ -172,28 +167,27 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
call coo_restr%transp()
nzl = coo_restr%get_nzeros()
nrl = desc_ac%get_local_rows()
call coo_restr%fix(info)
i=coo_restr%get_nzeros()
nrl = desc_ac%get_local_rows()
i=0
!
! Only keep local rows
!
search: do k=i,1,-1
if (coo_restr%ia(k) <= nrl) then
call coo_restr%set_nzeros(k)
exit search
do k=1, nzl
if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
i = i+1
coo_restr%val(i) = coo_restr%val(k)
coo_restr%ia(i) = coo_restr%ia(k)
coo_restr%ja(i) = coo_restr%ja(k)
end if
end do search
end do
call coo_restr%set_nzeros(i)
call coo_restr%fix(info)
nzl = coo_restr%get_nzeros()
call coo_restr%set_nrows(desc_ac%get_local_rows())
call coo_restr%set_ncols(desc_a%get_local_cols())
if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
if (do_timings) call psb_tic(idx_cpytrans2)
call csr_restr%cp_from_coo(coo_restr,info)
if (do_timings) call psb_toc(idx_cpytrans2)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
goto 9999
@@ -216,7 +210,6 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
call ac_csr%set_nrows(desc_ac%get_local_rows())
call ac_csr%set_ncols(desc_ac%get_local_cols())
call ac_csr%clean_zeros(info)
call ac%mv_from(ac_csr)
call ac%set_asb()
@@ -421,7 +414,6 @@ subroutine amg_c_lc_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
call ac_csr%set_nrows(desc_ac%get_local_rows())
call ac_csr%set_ncols(desc_ac%get_local_cols())
call ac_csr%clean_zeros(info)
call ac%mv_from(ac_csr)
call ac%set_asb()
@@ -631,7 +623,6 @@ subroutine amg_lc_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
call ac_csr%set_nrows(desc_ac%get_local_rows())
call ac_csr%set_ncols(desc_ac%get_local_cols())
call ac_csr%clean_zeros(info)
call ac%mv_from(ac_csr)
call ac%set_asb()
-1
View File
@@ -142,7 +142,6 @@ subroutine amg_c_rap(a_csr,desc_a,nlaggr,parms,ac,&
call ac_csr%set_nrows(desc_ac%get_local_rows())
call ac_csr%set_ncols(desc_ac%get_local_cols())
call ac_csr%clean_zeros(info)
call ac%mv_from(ac_csr)
call ac%set_asb()
@@ -72,9 +72,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
use psb_base_mod
use amg_base_prec_type
use amg_c_inner_mod
#if defined(PSB_OPENMP)
use omp_lib
#endif
implicit none
! Arguments
@@ -87,7 +85,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_), allocatable :: neigh(:), irow(:), icol(:),&
integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),&
& ideg(:), idxs(:)
integer(psb_lpk_), allocatable :: tmpaggr(:)
complex(psb_spk_), allocatable :: val(:), diag(:)
@@ -101,9 +99,6 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
integer(psb_ipk_) :: nrow, ncol, n_ne
integer(psb_lpk_) :: nrglob
character(len=20) :: name, ch_err
integer(psb_ipk_), save :: idx_soc1_p1=-1, idx_soc1_p2=-1, idx_soc1_p3=-1
integer(psb_ipk_), save :: idx_soc1_p0=-1
logical, parameter :: do_timings=.true.
info=psb_success_
name = 'amg_soc1_map_bld'
@@ -119,14 +114,6 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrglob = desc_a%get_global_rows()
if ((do_timings).and.(idx_soc1_p0==-1)) &
& idx_soc1_p0 = psb_get_timer_idx("SOC1_MAP: phase0")
if ((do_timings).and.(idx_soc1_p1==-1)) &
& idx_soc1_p1 = psb_get_timer_idx("SOC1_MAP: phase1")
if ((do_timings).and.(idx_soc1_p2==-1)) &
& idx_soc1_p2 = psb_get_timer_idx("SOC1_MAP: phase2")
if ((do_timings).and.(idx_soc1_p3==-1)) &
& idx_soc1_p3 = psb_get_timer_idx("SOC1_MAP: phase3")
nr = a%get_nrows()
nc = a%get_ncols()
@@ -146,205 +133,41 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
goto 9999
end if
if (do_timings) call psb_tic(idx_soc1_p0)
call a%cp_to(acsr)
if (do_timings) call psb_toc(idx_soc1_p0)
if (clean_zeros) call acsr%clean_zeros(info)
if (iorder == amg_aggr_ord_nat_) then
!$omp parallel do private(i) schedule(static)
do i=1, nr
ilaggr(i) = -(nr+1)
idxs(i) = i
idxs(i) = i
end do
!$omp end parallel do
else
!$omp parallel do private(i) schedule(static)
else
do i=1, nr
ilaggr(i) = -(nr+1)
ideg(i) = acsr%irp(i+1) - acsr%irp(i)
end do
!$omp end parallel do
call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
end if
if (do_timings) call psb_tic(idx_soc1_p1)
!
! Phase one: Start with disjoint groups.
!
naggr = 0
#if defined(PSB_OPENMP)
block
integer(psb_ipk_), allocatable :: bnds(:), locnaggr(:)
integer(psb_ipk_) :: myth,nths, kk
! The parallelization makes use of a locaggr(:) array; each thread
! keeps its own version of naggr, and when the loop ends, a prefix is applied
! to locnaggr to determine:
! 1. The total number of aggregaters NAGGR;
! 2. How much should each thread shift its own aggregates
! Part 2 requires to keep track of which thread defined each entry
! of ilaggr(), so that each entry can be adjusted correctly: even
! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
! been set because it is strongly connected to an entry J belonging to a
! different thread.
!$omp parallel shared(bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
!$omp private(icol,val,myth,kk)
block
integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz, nc, i,j,m, nz, ilg, ip, rsz
integer(psb_lpk_) :: itmp
!$omp master
nths = omp_get_num_threads()
allocate(bnds(0:nths),locnaggr(0:nths+1))
locnaggr(:) = 0
bnds(0) = 1
!$omp end master
!$omp barrier
myth = omp_get_thread_num()
rsz = nr/nths
if (myth < mod(nr,nths)) rsz = rsz + 1
bnds(myth+1) = rsz
!$omp barrier
!$omp master
do i=1,nths
bnds(i) = bnds(i) + bnds(i-1)
end do
info = 0
!$omp end master
!$omp barrier
!$omp do schedule(static) private(disjoint)
do kk=0, nths-1
step1: do ii=bnds(kk), bnds(kk+1)-1
i = idxs(ii)
if (info /= 0) cycle step1
if ((i<1).or.(i>nr)) then
!$omp atomic write
info=psb_err_internal_error_
!$omp end atomic
call psb_errpush(info,name)
cycle step1
!goto 9999
end if
if (ilaggr(i) == -(nr+1)) then
nz = (acsr%irp(i+1)-acsr%irp(i))
if ((nz<0).or.(nz>size(icol))) then
!$omp atomic write
info=psb_err_internal_error_
!$omp end atomic
call psb_errpush(info,name)
cycle step1
!goto 9999
end if
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
val(1:nz) = acsr%val(acsr%irp(i):acsr%irp(i+1)-1)
!
! Build the set of all strongly coupled nodes
!
ip = 0
do k=1, nz
j = icol(k)
! If any of the neighbours is already assigned,
! we will not reset.
if (j>nr) cycle step1
if (ilaggr(j) > 0) cycle step1
if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))).and.(diag(i).ne.czero)) then
ip = ip + 1
icol(ip) = icol(k)
end if
enddo
!
! If the whole strongly coupled neighborhood of I is
! as yet unconnected, turn it into the next aggregate.
! Same if ip==0 (in which case, neighborhood only
! contains I even if it does not look like it from matrix)
! The fact that DISJOINT is private and not under lock
! generates a certain un-repeatability, in that between
! computing DISJOINT and assigning, another thread might
! alter the values of ILAGGR.
! However, a certain unrepeatability is already present
! because the sequence of aggregates is computed with a
! different order than in serial mode.
! In any case, even if the enteries of ILAGGR may be
! overwritten, the important thing is that each entry is
! consistent and they generate a correct aggregation map.
!
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
if (disjoint) then
locnaggr(kk) = locnaggr(kk) + 1
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
itmp = itmp*nths+kk
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
!$omp atomic update
info = max(12345678,info)
!$omp end atomic
cycle step1
end if
!$omp atomic write
ilaggr(i) = itmp
!$omp end atomic
do k=1, ip
!$omp atomic write
ilaggr(icol(k)) = itmp
!$omp end atomic
end do
end if
end if
enddo step1
end do
!$omp end do
!$omp master
naggr = sum(locnaggr(0:nths-1))
do i=1,nths
locnaggr(i) = locnaggr(i) + locnaggr(i-1)
end do
do i=nths+1,1,-1
locnaggr(i) = locnaggr(i-1)
end do
locnaggr(0) = 0
!$omp end master
!$omp barrier
!$omp do schedule(static)
do kk=0, nths-1
do ii=bnds(kk), bnds(kk+1)-1
if (ilaggr(ii) > 0) then
kp = mod(ilaggr(ii),nths)
ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
end if
end do
end do
!$omp end do
end block
!$omp end parallel
end block
if (info /= 0) then
if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
end if
#else
icnt = 0
step1: do ii=1, nr
if (info /= 0) cycle
i = idxs(ii)
if ((i<1).or.(i>nr)) then
info=psb_err_internal_error_
call psb_errpush(info,name)
cycle step1
!goto 9999
goto 9999
end if
if (ilaggr(i) == -(nr+1)) then
nz = (acsr%irp(i+1)-acsr%irp(i))
if ((nz<0).or.(nz>size(icol))) then
info=psb_err_internal_error_
call psb_errpush(info,name)
cycle step1
!goto 9999
goto 9999
end if
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
@@ -353,11 +176,11 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
!
! Build the set of all strongly coupled nodes
!
ip = 0
ip = 0
do k=1, nz
j = icol(k)
if ((1<=j).and.(j<=nr)) then
if ((abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))).and.(diag(i).ne.czero)) then
if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
ip = ip + 1
icol(ip) = icol(k)
end if
@@ -371,7 +194,8 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
! contains I even if it does not look like it from matrix)
!
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
if (disjoint) then
if (disjoint) then
icnt = icnt + 1
naggr = naggr + 1
do k=1, ip
ilaggr(icol(k)) = naggr
@@ -380,22 +204,16 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
end if
endif
enddo step1
#endif
if (debug_level >= psb_debug_outer_) then
write(debug_unit,*) me,' ',trim(name),&
& ' Check 1:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
& ' Check 1:',count(ilaggr == -(nr+1))
end if
if (do_timings) call psb_toc(idx_soc1_p1)
if (do_timings) call psb_tic(idx_soc1_p2)
!
! Phase two: join the neighbours
!
!$omp workshare
tmpaggr = ilaggr
!$omp end workshare
!$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,theta)&
!$omp private(ii,i,j,k,nz,icol,val,ip,cpling)
step2: do ii=1,nr
i = idxs(ii)
@@ -426,15 +244,8 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
end if
end if
end do step2
!$omp end parallel do
if (do_timings) call psb_toc(idx_soc1_p2)
if (debug_level >= psb_debug_outer_) then
write(debug_unit,*) me,' ',trim(name),&
& ' Check 1.5:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
end if
if (do_timings) call psb_tic(idx_soc1_p3)
!
! Phase three: sweep over leftovers, if any
!
@@ -463,6 +274,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
end if
enddo
if (ip > 0) then
icnt = icnt + 1
naggr = naggr + 1
ilaggr(i) = naggr
do k=1, ip
@@ -480,10 +292,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
end do step3
! Any leftovers?
!$omp parallel do schedule(static) shared(ilaggr,info)&
!$omp private(ii,i,j,k,nz,icol,val,ip)
do i=1, nr
if (info /= 0) cycle
if (ilaggr(i) < 0) then
nz = (acsr%irp(i+1)-acsr%irp(i))
if (nz == 1) then
@@ -494,18 +303,15 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
! other processes.
ilaggr(i) = -(nrglob+nr)
else
!$omp atomic write
info=psb_err_internal_error_
!$omp end atomic
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
cycle
goto 9999
endif
end if
end do
!$omp end parallel do
if (info /= 0) goto 9999
if (do_timings) call psb_toc(idx_soc1_p3)
if (naggr > ncol) then
!write(0,*) name,'Error : naggr > ncol',naggr,ncol
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
goto 9999
@@ -530,13 +336,9 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
nlaggr(:) = 0
nlaggr(me+1) = naggr
call psb_sum(ctxt,nlaggr(1:np))
if (debug_level >= psb_debug_outer_) then
write(debug_unit,*) me,' ',trim(name),&
& ' Check 2:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
end if
call acsr%free()
call psb_erractionrestore(err_act)
return
@@ -545,3 +347,4 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
return
end subroutine amg_c_soc1_map_bld
@@ -68,12 +68,9 @@
!
subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod
use psb_base_mod
use amg_base_prec_type
use amg_c_inner_mod
#if defined(PSB_OPENMP)
use omp_lib
#endif
implicit none
@@ -102,9 +99,6 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
integer(psb_ipk_) :: np, me
integer(psb_ipk_) :: nrow, ncol, n_ne
character(len=20) :: name, ch_err
integer(psb_ipk_), save :: idx_soc2_p1=-1, idx_soc2_p2=-1, idx_soc2_p3=-1
integer(psb_ipk_), save :: idx_soc2_p0=-1
logical, parameter :: do_timings=.true.
info=psb_success_
name = 'amg_soc2_map_bld'
@@ -120,14 +114,6 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrglob = desc_a%get_global_rows()
if ((do_timings).and.(idx_soc2_p0==-1)) &
& idx_soc2_p0 = psb_get_timer_idx("SOC2_MAP: phase0")
if ((do_timings).and.(idx_soc2_p1==-1)) &
& idx_soc2_p1 = psb_get_timer_idx("SOC2_MAP: phase1")
if ((do_timings).and.(idx_soc2_p2==-1)) &
& idx_soc2_p2 = psb_get_timer_idx("SOC2_MAP: phase2")
if ((do_timings).and.(idx_soc2_p3==-1)) &
& idx_soc2_p3 = psb_get_timer_idx("SOC2_MAP: phase3")
nr = a%get_nrows()
nc = a%get_ncols()
@@ -139,7 +125,6 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
goto 9999
end if
if (do_timings) call psb_tic(idx_soc2_p0)
diag = a%get_diag(info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
@@ -152,218 +137,55 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
!
call a%cp_to(muij)
if (clean_zeros) call muij%clean_zeros(info)
!$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
do i=1, nr
do k=muij%irp(i),muij%irp(i+1)-1
j = muij%ja(k)
if (j<= nr) muij%val(k) = abs(muij%val(k))/sqrt(abs(diag(i)*diag(j)))
end do
end do
!$omp end parallel do
!
! Compute the 1-neigbour; mark strong links with +1, weak links with -1
!
call s_neigh_coo%allocate(nr,nr,muij%get_nzeros())
!$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
ip = 0
do i=1, nr
do k=muij%irp(i),muij%irp(i+1)-1
j = muij%ja(k)
s_neigh_coo%ia(k) = i
s_neigh_coo%ja(k) = j
if (j<=nr) then
ip = ip + 1
s_neigh_coo%ia(ip) = i
s_neigh_coo%ja(ip) = j
if (real(muij%val(k)) >= theta) then
s_neigh_coo%val(k) = sone
s_neigh_coo%val(ip) = sone
else
s_neigh_coo%val(k) = -sone
s_neigh_coo%val(ip) = -sone
end if
else
s_neigh_coo%val(k) = -sone
end if
end do
end do
!$omp end parallel do
!write(*,*) 'S_NEIGH: ',nr,ip
call s_neigh_coo%set_nzeros(muij%get_nzeros())
call s_neigh_coo%set_nzeros(ip)
call s_neigh%mv_from_coo(s_neigh_coo,info)
if (iorder == amg_aggr_ord_nat_) then
!$omp parallel do private(i) shared(ilaggr,idxs) schedule(static)
if (iorder == amg_aggr_ord_nat_) then
do i=1, nr
ilaggr(i) = -(nr+1)
idxs(i) = i
end do
!$omp end parallel do
else
!$omp parallel do private(i) shared(ilaggr,idxs,muij) schedule(static)
do i=1, nr
ilaggr(i) = -(nr+1)
ideg(i) = muij%irp(i+1) - muij%irp(i)
end do
!$omp end parallel do
call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
end if
if (do_timings) call psb_toc(idx_soc2_p0)
if (do_timings) call psb_tic(idx_soc2_p1)
!
! Phase one: Start with disjoint groups.
!
naggr = 0
#if defined(PSB_OPENMP)
block
integer(psb_ipk_), allocatable :: bnds(:), locnaggr(:)
integer(psb_ipk_) :: myth,nths, kk
! The parallelization makes use of a locaggr(:) array; each thread
! keeps its own version of naggr, and when the loop ends, a prefix is applied
! to locnaggr to determine:
! 1. The total number of aggregaters NAGGR;
! 2. How much should each thread shift its own aggregates
! Part 2 requires to keep track of which thread defined each entry
! of ilaggr(), so that each entry can be adjusted correctly: even
! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
! been set because it is strongly connected to an entry J belonging to a
! different thread.
!$omp parallel shared(s_neigh,bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
!$omp private(icol,val,myth,kk)
block
integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz,nc,i,j,m,nz,ilg,ip,rsz,ip1,nzcnt
integer(psb_lpk_) :: itmp
!$omp master
nths = omp_get_num_threads()
allocate(bnds(0:nths),locnaggr(0:nths+1))
locnaggr(:) = 0
bnds(0) = 1
!$omp end master
!$omp barrier
myth = omp_get_thread_num()
rsz = nr/nths
if (myth < mod(nr,nths)) rsz = rsz + 1
bnds(myth+1) = rsz
!$omp barrier
!$omp master
do i=1,nths
bnds(i) = bnds(i) + bnds(i-1)
end do
info = 0
!$omp end master
!$omp barrier
!$omp do schedule(static) private(disjoint)
do kk=0, nths-1
step1: do ii=bnds(kk), bnds(kk+1)-1
i = idxs(ii)
if (info /= 0) then
write(0,*) ' Step1:',kk,ii,i,info
cycle step1
end if
if ((i<1).or.(i>nr)) then
!$omp atomic write
info=psb_err_internal_error_
!$omp end atomic
call psb_errpush(info,name)
cycle step1
!goto 9999
end if
if (ilaggr(i) == -(nr+1)) then
!
! Get the 1-neighbourhood of I
!
ip1 = s_neigh%irp(i)
nz = s_neigh%irp(i+1)-ip1
!
! If the neighbourhood only contains I, skip it
!
if (nz ==0) then
ilaggr(i) = 0
cycle step1
end if
if ((nz==1).and.(s_neigh%ja(ip1)==i)) then
ilaggr(i) = 0
cycle step1
end if
nzcnt = count(real(s_neigh%val(ip1:ip1+nz-1)) > 0)
icol(1:nzcnt) = pack(s_neigh%ja(ip1:ip1+nz-1),(real(s_neigh%val(ip1:ip1+nz-1)) > 0))
disjoint = all(ilaggr(icol(1:nzcnt)) == -(nr+1))
!
! If the whole strongly coupled neighborhood of I is
! as yet unconnected, turn it into the next aggregate.
! Same if ip==0 (in which case, neighborhood only
! contains I even if it does not look like it from matrix)
! The fact that DISJOINT is private and not under lock
! generates a certain un-repeatability, in that between
! computing DISJOINT and assigning, another thread might
! alter the values of ILAGGR.
! However, a certain unrepeatability is already present
! because the sequence of aggregates is computed with a
! different order than in serial mode.
! In any case, even if the enteries of ILAGGR may be
! overwritten, the important thing is that each entry is
! consistent and they generate a correct aggregation map.
!
if (disjoint) then
locnaggr(kk) = locnaggr(kk) + 1
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
itmp = itmp*nths+kk
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
!$omp atomic update
info = max(12345678,info)
!$omp end atomic
cycle step1
end if
!$omp atomic write
ilaggr(i) = itmp
!$omp end atomic
do k=1, nzcnt
!$omp atomic write
ilaggr(icol(k)) = itmp
!$omp end atomic
end do
end if
end if
enddo step1
end do
!$omp end do
!$omp master
naggr = sum(locnaggr(0:nths-1))
do i=1,nths
locnaggr(i) = locnaggr(i) + locnaggr(i-1)
end do
do i=nths+1,1,-1
locnaggr(i) = locnaggr(i-1)
end do
locnaggr(0) = 0
!write(0,*) 'LNAG ',locnaggr(nths+1)
!$omp end master
!$omp barrier
!$omp do schedule(static)
do kk=0, nths-1
do ii=bnds(kk), bnds(kk+1)-1
if (ilaggr(ii) > 0) then
kp = mod(ilaggr(ii),nths)
ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
end if
end do
end do
!$omp end do
end block
!$omp end parallel
end block
if (info /= 0) then
if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
info=psb_err_internal_error_
call psb_errpush(info,name)
goto 9999
end if
#else
icnt = 0
step1: do ii=1, nr
i = idxs(ii)
@@ -402,21 +224,16 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
end if
endif
enddo step1
#endif
if (debug_level >= psb_debug_outer_) then
write(debug_unit,*) me,' ',trim(name),&
& ' Check 1:',count(ilaggr == -(nr+1))
end if
if (do_timings) call psb_toc(idx_soc2_p1)
if (do_timings) call psb_tic(idx_soc2_p2)
!
! Phase two: join the neighbours
!
!$omp workshare
tmpaggr = ilaggr
!$omp end workshare
!$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,muij,s_neigh)&
!$omp private(ii,i,j,k,nz,icol,val,ip,cpling)
step2: do ii=1,nr
i = idxs(ii)
@@ -442,9 +259,8 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
end if
end if
end do step2
!$omp end parallel do
if (do_timings) call psb_toc(idx_soc2_p2)
if (do_timings) call psb_tic(idx_soc2_p3)
!
! Phase three: sweep over leftovers, if any
!
@@ -478,8 +294,6 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
end do step3
! Any leftovers?
!$omp parallel do schedule(static) shared(ilaggr,s_neigh,info)&
!$omp private(ii,i,j,k)
do i=1, nr
if (ilaggr(i) <= 0) then
nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
@@ -491,17 +305,13 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
! other processes.
ilaggr(i) = -(nrglob+nr)
else
!$omp atomic write
info=psb_err_internal_error_
!$omp end atomic
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
cycle
goto 9999
endif
end if
end do
!$omp end parallel do
if (info /= 0) goto 9999
if (do_timings) call psb_toc(idx_soc2_p3)
if (naggr > ncol) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
@@ -69,7 +69,6 @@
!
!
! Arguments:
! dol1smoothing - fictitious integer argument, it is not used inside
! a - type(psb_cspmat_type), input.
! The sparse matrix structure containing the local part of
! the fine-level matrix.
@@ -105,8 +104,8 @@
! Error code.
!
!
subroutine amg_caggrmat_minnrg_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
subroutine amg_caggrmat_minnrg_bld(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
use psb_base_mod
use amg_base_prec_type
use amg_c_inner_mod, amg_protect_name => amg_caggrmat_minnrg_bld
@@ -114,7 +113,6 @@ subroutine amg_caggrmat_minnrg_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
implicit none
! Arguments
integer(psb_ipk_), intent(in) :: dol1smoothing
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
@@ -173,13 +171,6 @@ subroutine amg_caggrmat_minnrg_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
filter_mat = (parms%aggr_filter == amg_filter_mat_)
if (dol1smoothing.ne.amg_no_smooth_) then
info=psb_err_fatal_;
call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
goto 9999
end if
!NEEDS TO BE REWORKED !!
! naggr: number of local aggregates
@@ -309,7 +300,7 @@ subroutine amg_caggrmat_minnrg_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
!!$ endif
!!$ enddo
!!$ if (jd == -1) then
!!$ write(0,*) name,': Warning: there is no diagonal element', i
!!$ write(0,*) 'Wrong input: we need the diagonal!!!!', i
!!$ else
!!$ acsrf%val(jd)=acsrf%val(jd)-tmp
!!$ end if
@@ -94,11 +94,10 @@
!
! info - integer, output.
! Error code.
! dol1smoothing - optional, this is here just for interfacing reasons. It is not used by the
! code
!
subroutine amg_caggrmat_nosmth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
!
subroutine amg_caggrmat_nosmth_bld(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
use psb_base_mod
use amg_base_prec_type
use amg_c_inner_mod, amg_protect_name => amg_caggrmat_nosmth_bld
@@ -106,7 +105,6 @@ subroutine amg_caggrmat_nosmth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
implicit none
! Arguments
integer(psb_ipk_), intent(in) :: dol1smoothing
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
@@ -139,12 +137,6 @@ subroutine amg_caggrmat_nosmth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (dol1smoothing.ne.amg_no_smooth_) then
info=psb_err_fatal_;
call psb_errpush(info,name,a_err='Are you trying to smooth an unsmoothed aggregation?')
goto 9999
end if
nglob = desc_a%get_global_rows()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
@@ -69,8 +69,6 @@
!
!
! Arguments:
! dol1smooth - Integer taking the type of smoother that has to be used
! on the tentative prolongator
! a - type(psb_cspmat_type), input.
! The sparse matrix structure containing the local part of
! the fine-level matrix.
@@ -104,18 +102,16 @@
! info - integer, output.
! Error code.
!
subroutine amg_caggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
parms,ac,desc_ac,op_prol,op_restr,t_prol,info)
subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
& ac,desc_ac,op_prol,op_restr,t_prol,info)
use psb_base_mod
use amg_base_prec_type
use amg_c_inner_mod, amg_protect_name => amg_caggrmat_smth_bld
use amg_c_base_aggregator_mod
! use, intrinsic :: ieee_arithmetic
implicit none
! Arguments
integer(psb_ipk_), intent(in) :: dol1smoothing
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(inout) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
@@ -136,7 +132,7 @@ subroutine amg_caggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
type(psb_c_coo_sparse_mat) :: coo_prol, coo_restr
type(psb_c_csr_sparse_mat) :: acsr1, acsrf, csr_prol, acsr
complex(psb_spk_), allocatable :: adiag(:)
real(psb_spk_), allocatable :: arwsum(:),l1rwsum(:)
real(psb_spk_), allocatable :: arwsum(:)
integer(psb_ipk_) :: ierr(5)
logical :: filter_mat
integer(psb_ipk_) :: debug_level, debug_unit, err_act
@@ -145,7 +141,6 @@ subroutine amg_caggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
logical, parameter :: debug_new=.false.
character(len=80) :: filename
logical, parameter :: do_timings=.false.
logical :: do_l1correction=.false.
integer(psb_ipk_), save :: idx_spspmm=-1, idx_phase1=-1, idx_gtrans=-1, idx_phase2=-1, idx_refine=-1
integer(psb_ipk_), save :: idx_phase3=-1, idx_cdasb=-1, idx_ptap=-1
@@ -178,9 +173,6 @@ subroutine amg_caggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
if ((do_timings).and.(idx_ptap==-1)) &
& idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld ")
! check if we have to use Jacobi or l1-Jacobi to smooth the tentative prolongator
if (dol1smoothing.eq.amg_l1_smooth_prol_) do_l1correction=.true.
nglob = desc_a%get_global_rows()
nrow = desc_a%get_local_rows()
@@ -193,7 +185,7 @@ subroutine amg_caggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == amg_filter_mat_).or.(parms%aggr_filter == amg_filter_prow_mat_)
filter_mat = (parms%aggr_filter == amg_filter_mat_)
!
! naggr: number of local aggregates
@@ -208,24 +200,6 @@ subroutine amg_caggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to(acsr)
!
! Do the l1-correction on the diagonal if it is requested
!
if (do_l1correction) then
allocate(l1rwsum(nrow))
call acsr%arwsum(l1rwsum)
if (info == psb_success_) &
& call psb_realloc(ncol,l1rwsum,info)
if (info == psb_success_) &
& call psb_halo(l1rwsum,desc_a,info)
! \tilde{D}_{i,i} = \sum_{j \ne i} |a_{i,j}|
!$OMP parallel do private(i) schedule(static)
do i=1,size(adiag)
adiag(i) = adiag(i) + l1rwsum(i) - abs(adiag(i))
end do
!$OMP end parallel do
end if
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
@@ -256,15 +230,9 @@ subroutine amg_caggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
enddo
if (jd == -1) then
! if (.not.do_l1correction)
write(0,*) 'Wrong input: we need the diagonal!!!!', i
else if (parms%aggr_filter == amg_filter_mat_) then
! We perform filtering in the standard way assuming that A is an M-matrix
else
acsrf%val(jd)=acsrf%val(jd)-tmp
else if (parms%aggr_filter == amg_filter_prow_mat_) then
! We are probably doing l1-correction, hence we want to preserve the
! row sum of the matrix: note the change in sign
acsrf%val(jd)=acsrf%val(jd)+tmp
end if
enddo
!$OMP end parallel do
@@ -272,6 +240,7 @@ subroutine amg_caggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
call acsrf%clean_zeros(info)
end if
!$OMP parallel do private(i) schedule(static)
do i=1,size(adiag)
if (adiag(i) /= czero) then
@@ -283,17 +252,14 @@ subroutine amg_caggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
!$OMP end parallel do
if (parms%aggr_omega_alg == amg_eig_est_) then
if ( (parms%aggr_filter == amg_filter_prow_mat_).and.(do_l1correction) ) then
! For l1-Jacobi this can be estimated with 1:
! this makes sense only if we are preserving the row-sum!
parms%aggr_omega_val = done
else if (parms%aggr_eig == amg_max_norm_) then
if (parms%aggr_eig == amg_max_norm_) then
allocate(arwsum(nrow))
call acsr%arwsum(arwsum)
anorm = maxval(abs(adiag(1:nrow)*arwsum(1:nrow)))
call psb_amx(ctxt,anorm)
omega = 4.d0/(3.d0*anorm)
parms%aggr_omega_val = omega
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid amg_aggr_eig_')
@@ -356,7 +322,6 @@ subroutine amg_caggrmat_smth_bld(dol1smoothing,a,desc_a,ilaggr,nlaggr,&
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '
if (allocated(l1rwsum)) deallocate(l1rwsum)
call psb_erractionrestore(err_act)
return

Some files were not shown because too many files have changed in this diff Show More